pax_global_header00006660000000000000000000000064147372016750014526gustar00rootroot0000000000000052 comment=a75b14fad50313d615881713d4703e6c9cd6e111 corn-8.20.0/000077500000000000000000000000001473720167500125565ustar00rootroot00000000000000corn-8.20.0/.github/000077500000000000000000000000001473720167500141165ustar00rootroot00000000000000corn-8.20.0/.github/workflows/000077500000000000000000000000001473720167500161535ustar00rootroot00000000000000corn-8.20.0/.github/workflows/docker-action.yml000066400000000000000000000015221473720167500214200ustar00rootroot00000000000000# This file was generated from `meta.yml`, please do not edit manually. # Follow the instructions on https://github.com/coq-community/templates to regenerate. name: Docker CI on: push: branches: - master pull_request: branches: - '**' jobs: build: # the OS must be GNU/Linux to be able to use the docker-coq-action runs-on: ubuntu-latest strategy: matrix: image: - 'coqorg/coq:dev' - 'coqorg/coq:8.19' - 'coqorg/coq:8.18' fail-fast: false steps: - uses: actions/checkout@v3 - uses: coq-community/docker-coq-action@v1 with: opam_file: 'coq-corn.opam' custom_image: ${{ matrix.image }} # See also: # https://github.com/coq-community/docker-coq-action#readme # https://github.com/erikmd/docker-coq-github-action-demo corn-8.20.0/.gitignore000066400000000000000000000006031473720167500145450ustar00rootroot00000000000000Makefile.bak Make Makefile Makefile.conf Makefile.coq Makefile.coq.conf *.vo *.vok *.vos *.d *.glob *.pyc tree.dot tree.ps tree.pdf tree.svg doc.ps doc/html/* coqdoc.css .docdepend .doclist deps .sconsign.dblite .lia.cache coqidescript *.new *# deps.dot deps.pdf *.native *.aux *.crashcoqide *.cmi *.cmo *.cmx *.cmxs *.cmxa *.byte *.ml.d *.o *.a plot.pgm coqdoc *.native *.aux *~ result corn-8.20.0/LICENSE000066400000000000000000000431031473720167500135640ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. corn-8.20.0/Make.in000066400000000000000000000000461473720167500137630ustar00rootroot00000000000000# Library name -R . CoRN # Coq files corn-8.20.0/README.md000066400000000000000000000112531473720167500140370ustar00rootroot00000000000000 # C-CoRN [![Docker CI][docker-action-shield]][docker-action-link] [![Contributing][contributing-shield]][contributing-link] [![Code of Conduct][conduct-shield]][conduct-link] [![Zulip][zulip-shield]][zulip-link] [docker-action-shield]: https://github.com/coq-community/corn/actions/workflows/docker-action.yml/badge.svg?branch=master [docker-action-link]: https://github.com/coq-community/corn/actions/workflows/docker-action.yml [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users CoRN includes the following parts: - Algebraic Hierarchy An axiomatic formalization of the most common algebraic structures, including setoids, monoids, groups, rings, fields, ordered fields, rings of polynomials, real and complex numbers - Model of the Real Numbers Construction of a concrete real number structure satisfying the previously defined axioms - Fundamental Theorem of Algebra A proof that every non-constant polynomial on the complex plane has at least one root - Real Calculus A collection of elementary results on real analysis, including continuity, differentiability, integration, Taylor's theorem and the Fundamental Theorem of Calculus - Exact Real Computation Fast verified computation inside Coq. This includes: real numbers, functions, integrals, graphs of functions, differential equations. ## Meta - Author(s): - Evgeny Makarov - Robbert Krebbers - Eelis van der Weegen - Bas Spitters - Jelle Herold - Russell O'Connor - Cezary Kaliszyk - Dan Synek - Luís Cruz-Filipe - Milad Niqui - Iris Loeb - Herman Geuvers - Randy Pollack - Freek Wiedijk - Jan Zwanenburg - Dimitri Hendriks - Henk Barendregt - Mariusz Giero - Rik van Ginneken - Dimitri Hendriks - Sébastien Hinderer - Bart Kirkels - Pierre Letouzey - Lionel Mamane - Nickolay Shmyrev - Vincent Semeria - Coq-community maintainer(s): - Bas Spitters ([**@spitters**](https://github.com/spitters)) - Vincent Semeria ([**@vincentse**](https://github.com/vincentse)) - Xia Li-yao ([**@Lysxia**](https://github.com/Lysxia)) - License: [GNU General Public License v2](LICENSE) - Compatible Coq versions: Coq 8.18 or greater - Additional dependencies: - [Math-Classes](https://github.com/coq-community/math-classes) 8.8.1 or greater, which is a library of abstract interfaces for mathematical structures that is heavily based on Coq's type classes. - [Bignums](https://github/com/coq/bignums) - Coq namespace: `CoRN` - Related publication(s): - [See this page for the list of publications](http://corn.cs.ru.nl/pub.html) ## Building and installation instructions The easiest way to install the latest released version of C-CoRN is via [OPAM](https://opam.ocaml.org/doc/Install.html): ```shell opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-corn ``` To instead build and install manually, you have to start with the `bignums` dependency: ``` shell git clone https://github.com/coq/bignums cd bignums make # or make -j make install ``` The last `make install` is necessary, it copies `bignums` to a common folder, which is usually `coq/user-contrib`. Afterwards the similar commands for `math-classes` will find `bignums` there. Finally build `corn` itself: ``` shell git clone https://github.com/coq-community/corn cd corn ./configure.sh make # or make -j make install ``` ### Building C-CoRN with SCons C-CoRN supports building with [SCons](http://www.scons.org/). SCons is a modern Python-based Make-replacement. To build C-CoRN with SCons run `scons` to build the whole library, or `scons some/module.vo` to just build `some/module.vo` (and its dependencies). In addition to common Make options like `-j N` and `-k`, SCons supports some useful options of its own, such as `--debug=time`, which displays the time spent executing individual build commands. `scons -c` replaces Make clean For more information, see the [SCons documentation](http://www.scons.org/). ### Building documentation To build CoqDoc documentation, say `scons coqdoc`. corn-8.20.0/SConstruct000066400000000000000000000027141473720167500146140ustar00rootroot00000000000000import os, glob, string # Removing examples directory since we do not need it every time. dirs_to_compile = ['algebra', 'complex', 'coq_reals', 'fta', 'ftc', 'liouville', 'logic', 'metrics', 'model', 'raster', 'reals', 'tactics', 'transc', 'order', 'metric2', 'stdlib_omissions', 'util', 'classes', 'ode'] nodes = map(lambda x: './' + x, dirs_to_compile) dirs = [] vs = [] env = DefaultEnvironment(ENV = os.environ, tools=['default', 'Coq']) while nodes: node = nodes.pop() b = os.path.basename(node) if (node.endswith('.v') and not b.startswith('Opaque_') and not b.startswith('Transparent_')): vs += [File(node)] if os.path.isdir(node): dirs += [node] nodes += glob.glob(node + '/*') includes = ' '.join(map(lambda x: '-I ' + x, dirs[1:])) Rs = '-R . CoRN' coqcmd = 'coqc ${str(SOURCE)[:-2]} ' + Rs env['COQFLAGS'] = Rs for node in vs: env.Coq(node, COQCMD=coqcmd) #mc_vs, mc_vos, mc_globs = env.SConscript(dirs='math-classes/src') os.system('coqdep ' + ' '.join(map(str, vs)) + ' ' + includes + ' ' + Rs + ' > deps') ParseDepends('deps') open('coqidescript', 'w').write('#!/bin/sh\ncoqide ' + Rs + ' $@ \n') os.chmod('coqidescript', 0755) #env.CoqDoc(env.Dir('coqdoc'), vs+mc_vs, COQDOCFLAGS='-utf8 --toc -g --no-lib-name --coqlib http://coq.inria.fr/library') env.CoqDoc(env.Dir('coqdoc'), vs, COQDOCFLAGS='-utf8 --toc -g --no-lib-name --coqlib http://coq.inria.fr/library') #env.Command('deps.dot', [], 'tools/DepsToDot.hs < deps > $TARGET') corn-8.20.0/_CoqProject000066400000000000000000000000121473720167500147020ustar00rootroot00000000000000-R . CoRN corn-8.20.0/algebra/000077500000000000000000000000001473720167500141535ustar00rootroot00000000000000corn-8.20.0/algebra/Bernstein.v000066400000000000000000000454341473720167500163050ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.algebra.CPolynomials. Require Import CoRN.algebra.CSums. Require Import CoRN.tactics.Rational. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.algebra.COrdFields2. Require Import CoRN.algebra.CRing_Homomorphisms. Require Coq.Vectors.Vector. Export Vector.VectorNotations. From Coq Require Import Lia. Set Implicit Arguments. (** ** Bernstein Polynomials *) Section Bernstein. Opaque cpoly_cring. Variable R : CRing. Add Ring R : (CRing_Ring R) (preprocess [unfold cg_minus;simpl]). Add Ring cpolycring_th : (CRing_Ring (cpoly_cring R)) (preprocess [unfold cg_minus;simpl]). (** [Bernstein n i] is the ith element of the n dimensional Bernstein basis *) Fixpoint Bernstein (n i:nat) {struct n}: (i <= n) -> cpoly_cring R := match n return (i <= n) -> cpoly_cring R with O => fun _ => [1] |S n' => match i return (i <= S n') -> cpoly_cring R with O => fun _ => ([1][-]_X_)[*](Bernstein (Nat.le_0_l n')) |S i' => fun p => match (le_lt_eq_dec _ _ p) with | left p' => ([1][-]_X_)[*](Bernstein (proj1 (Nat.lt_succ_r _ _) p'))[+]_X_[*](Bernstein (le_S_n _ _ p)) | right _ => _X_[*](Bernstein (proj1 (Nat.lt_succ_r _ _) p)) end end end. (** These lemmas provide an induction principle for polynomials using the Bernstien basis *) Lemma Bernstein_inv1 : forall n i (H:i < n) (H0:S i <= S n), Bernstein H0[=]([1][-]_X_)[*](Bernstein (proj1 (Nat.lt_succ_r _ _) (proj1 (Nat.succ_lt_mono _ _) H)))[+]_X_[*](Bernstein (le_S_n _ _ H0)). Proof. intros n i H H0. simpl (Bernstein H0). destruct (le_lt_eq_dec _ _ H0). replace (proj1 (Nat.lt_succ_r (S i) n) l) with (proj1 (Nat.lt_succ_r _ _) (proj1 (Nat.succ_lt_mono _ _) H)) by apply le_irrelevent. reflexivity. exfalso; lia. Qed. Lemma Bernstein_inv2 : forall n (H:S n <= S n), Bernstein H[=]_X_[*](Bernstein (le_S_n _ _ H)). Proof. intros n H. simpl (Bernstein H). destruct (le_lt_eq_dec _ _ H). exfalso; lia. replace (proj1 (Nat.lt_succ_r n n) H) with (le_S_n n n H) by apply le_irrelevent. reflexivity. Qed. Lemma Bernstein_ind : forall n i (H:i<=n) (P : nat -> nat -> cpoly_cring R -> Prop), P 0 0 [1] -> (forall n p, P n 0 p -> P (S n) 0 (([1][-]_X_)[*]p)) -> (forall n p, P n n p -> P (S n) (S n) (_X_[*]p)) -> (forall i n p q, (i < n) -> P n i p -> P n (S i) q -> P (S n) (S i) (([1][-]_X_)[*]q[+]_X_[*]p)) -> P n i (Bernstein H). Proof. intros n i H P H0 H1 H2 H3. revert n i H. induction n; intros [|i] H. apply H0. exfalso; auto with *. apply H1. apply IHn. simpl. destruct (le_lt_eq_dec (S i) (S n)). apply H3; auto with *. inversion e. revert H. rewrite H5. intros H. apply H2. auto with *. Qed. (** [1] important property of the Bernstein basis is that its elements form a partition of unity *) Lemma partitionOfUnity : forall n, @Sumx (cpoly_cring R) _ (fun i H => Bernstein (proj1 (Nat.lt_succ_r i n) H)) [=][1]. Proof. induction n. reflexivity. set (A:=(fun (i : nat) (H : i < S n) => Bernstein (proj1 (Nat.lt_succ_r i n) H))) in *. set (B:=(fun i => ([1][-]_X_)[*](part_tot_nat_fun (cpoly_cring R) _ A i)[+]_X_[*]match i with O => [0] | S i' => (part_tot_nat_fun _ _ A i') end)). rewrite -> (fun a b => Sumx_Sum0 _ a b B). unfold B. rewrite -> Sum0_plus_Sum0. do 2 rewrite -> mult_distr_sum0_lft. rewrite -> Sumx_to_Sum in IHn; auto with *. setoid_replace (Sum0 (S (S n)) (part_tot_nat_fun (cpoly_cring R) (S n) A)) with (Sum0 (S (S n)) (part_tot_nat_fun (cpoly_cring R) (S n) A)[-][0]) using relation (@st_eq (cpoly_cring R)) by ring. change (Sum0 (S (S n)) (part_tot_nat_fun (cpoly_cring R) (S n) A)[-][0]) with (Sum 0 (S n) (part_tot_nat_fun (cpoly_cring R) (S n) A)). set (C:=(fun i : nat => match i with | 0 => ([0] : cpoly_cring R) | S i' => part_tot_nat_fun (cpoly_cring R) (S n) A i' end)). setoid_replace (Sum0 (S (S n)) C) with (Sum0 (S (S n)) C[-][0]) using relation (@st_eq (cpoly_cring R)) by ring. change (Sum0 (S (S n)) C[-][0]) with (Sum 0 (S n) C). rewrite -> Sum_last. rewrite -> IHn. replace (part_tot_nat_fun (cpoly_cring R) (S n) A (S n)) with ([0]:cpoly_cring R). rewrite -> Sum_first. change (C 0) with ([0]:cpoly_cring R). rewrite <- (Sum_shift _ (part_tot_nat_fun (cpoly_cring R) (S n) A)) by reflexivity. rewrite -> IHn by ring. ring. unfold part_tot_nat_fun. destruct (le_lt_dec (S n) (S n)). reflexivity. exfalso; lia. intros i j Hij. subst. intros Hi Hj. unfold A. replace (proj1 (Nat.lt_succ_r j n) Hi) with (proj1 (Nat.lt_succ_r j n) Hj) by apply le_irrelevent. apply eq_reflexive. destruct i; intros Hi; unfold B, A, part_tot_nat_fun. simpl. symmetry. rewrite <- (le_irrelevent _ _ (Nat.le_0_l _) _). ring. destruct (le_lt_dec (S n) i). exfalso; lia. destruct (le_lt_dec (S n) (S i)); simpl (Bernstein (proj1 (Nat.lt_succ_r (S i) (S n)) Hi)); destruct (le_lt_eq_dec (S i) (S n) (proj1 (Nat.lt_succ_r (S i) (S n)) Hi)). exfalso; lia. replace (proj1 (Nat.lt_succ_r i n) (proj1 (Nat.lt_succ_r (S i) (S n)) Hi)) with (proj1 (Nat.lt_succ_r i n) l) by apply le_irrelevent. ring. replace (le_S_n i n (proj1 (Nat.lt_succ_r (S i) (S n)) Hi)) with (proj1 (Nat.lt_succ_r i n) l) by apply le_irrelevent. replace l1 with l0 by apply le_irrelevent. reflexivity. exfalso; lia. Qed. Lemma RaiseDegreeA : forall n i (H:i<=n), (nring (S n))[*]_X_[*]Bernstein H[=](nring (S i))[*]Bernstein (le_n_S _ _ H). Proof. induction n. intros [|i] H; [|exfalso; lia]. repeat split; ring. intros i H. change (nring (S (S n)):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R). rstepl (nring (S n)[*]_X_[*]Bernstein H[+]_X_[*]Bernstein H). destruct i as [|i]. simpl (Bernstein H) at 1. rstepl (([1][-]_X_)[*](nring (S n)[*]_X_[*]Bernstein (Nat.le_0_l n))[+] _X_[*]Bernstein H). rewrite -> IHn. rstepl ((([1][-]_X_)[*]Bernstein (le_n_S _ _ (Nat.le_0_l n))[+]_X_[*]Bernstein H)). rstepr (Bernstein (le_n_S 0 (S n) H)). set (le_n_S 0 n (Nat.le_0_l n)). rewrite (Bernstein_inv1 l). rewrite (le_irrelevent _ _ (proj1 (Nat.lt_succ_r 1 (S n)) (proj1 (Nat.succ_lt_mono 0 (S n)) l)) l). rewrite (le_irrelevent _ _ H (le_S_n 0 (S n) (le_n_S 0 (S n) H))). reflexivity. simpl (Bernstein H) at 1. destruct (le_lt_eq_dec _ _ H). rstepl (([1][-]_X_)[*](nring (S n)[*]_X_[*]Bernstein (proj1 (Nat.lt_succ_r (S i) n) l))[+] _X_[*](nring (S n)[*]_X_[*]Bernstein (le_S_n i n H))[+] _X_[*]Bernstein H). do 2 rewrite -> IHn. change (nring (S (S i)):cpoly_cring R) with (nring (S i)[+][1]:cpoly_cring R). set (l0:= (le_n_S (S i) n (proj1 (Nat.lt_succ_r (S i) n) l))). replace (le_n_S i n (le_S_n i n H)) with H by apply le_irrelevent. rstepl ((nring (S i)[+][1])[*](([1][-]_X_)[*]Bernstein l0[+]_X_[*]Bernstein H)). rewrite (Bernstein_inv1 l). replace (proj1 (Nat.lt_succ_r (S (S i)) (S n)) (proj1 (Nat.succ_lt_mono (S i) (S n)) l)) with l0 by apply le_irrelevent. replace (le_S_n (S i) (S n) (le_n_S (S i) (S n) H)) with H by apply le_irrelevent. reflexivity. rstepl (_X_[*](nring (S n)[*]_X_[*]Bernstein (proj1 (Nat.lt_succ_r _ _) H))[+] _X_[*]Bernstein H). rewrite IHn. replace (le_n_S i n (proj1 (Nat.lt_succ_r i n) H)) with H by apply le_irrelevent. revert H. inversion_clear e. intros H. rewrite -> (Bernstein_inv2 (le_n_S _ _ H)). replace (le_S_n (S n) (S n) (le_n_S (S n) (S n) H)) with H by apply le_irrelevent. change (nring (S (S n)):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R). ring. Qed. Lemma RaiseDegreeB : forall n i (H:i<=n), (nring (S n))[*]([1][-]_X_)[*]Bernstein H[=](nring (S n - i))[*]Bernstein (le_S _ _ H). Proof. induction n. intros [|i] H; [|exfalso; lia]. repeat split; ring. intros i H. change (nring (S (S n)):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R). set (X0:=([1][-](@cpoly_var R))) in *. rstepl (nring (S n)[*]X0[*]Bernstein H[+]X0[*]Bernstein H). destruct i as [|i]. simpl (Bernstein H) at 1. fold X0. rstepl (X0[*](nring (S n)[*]X0[*]Bernstein (Nat.le_0_l n))[+] X0[*]Bernstein H). rewrite -> IHn. replace (le_S 0 n (Nat.le_0_l n)) with H by apply le_irrelevent. simpl (S n - 0). change (nring (S (S n) - 0):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R). rstepl ((nring (S n))[*](X0[*]Bernstein H)[+]X0[*]Bernstein H). change (Bernstein (le_S _ _ H)) with (X0[*]Bernstein (Nat.le_0_l (S n))). replace (Nat.le_0_l (S n)) with H by apply le_irrelevent. ring. simpl (Bernstein H) at 1. destruct (le_lt_eq_dec _ _ H). fold X0. rstepl (X0[*](nring (S n)[*]X0[*]Bernstein (proj1 (Nat.lt_succ_r (S i) n) l))[+] _X_[*](nring (S n)[*]X0[*]Bernstein (le_S_n i n H))[+] X0[*]Bernstein H). do 2 rewrite -> IHn. rewrite (Nat.sub_succ_l i n) by auto with *. rewrite (Nat.sub_succ_l (S i) (S n)) by auto with *. replace (S n - S i) with (n - i) by auto with *. change (nring (S (n - i)):cpoly_cring R) with (nring (n - i)[+][1]:cpoly_cring R). replace (le_S (S i) n (proj1 (Nat.lt_succ_r (S i) n) l)) with H by apply le_irrelevent. set (l0:= (le_S i n (le_S_n i n H))). rstepl ((nring (n - i)[+][1])[*](X0[*]Bernstein H[+]_X_[*]Bernstein l0)). rewrite -> (Bernstein_inv1 H). fold X0. replace (proj1 (Nat.lt_succ_r _ _) (proj1 (Nat.succ_lt_mono _ _) H)) with H by apply le_irrelevent. replace (le_S_n _ _ (le_S (S i) (S n) H)) with l0 by apply le_irrelevent. reflexivity. revert H. inversion e. clear - IHn. intros H. assert (l:(n < (S n))) by auto. rewrite -> (Bernstein_inv1 l). fold X0. rstepl (_X_[*](nring (S n)[*]X0[*]Bernstein (proj1 (Nat.lt_succ_r _ _) H))[+] X0[*]Bernstein H). rewrite -> IHn. replace (S n - n) with 1 by auto with *. replace (S (S n) - S n) with 1 by auto with *. replace (le_S_n n (S n) (le_S (S n) (S n) H)) with (le_S n n (proj1 (Nat.lt_succ_r n n) H)) by apply le_irrelevent. replace (proj1 (Nat.lt_succ_r (S n) (S n)) (proj1 (Nat.succ_lt_mono n (S n)) l)) with H by apply le_irrelevent. ring. Qed. Lemma RaiseDegree : forall n i (H: i<=n), (nring (S n))[*]Bernstein H[=](nring (S n - i))[*]Bernstein (le_S _ _ H)[+](nring (S i))[*]Bernstein (le_n_S _ _ H). Proof. intros n i H. rstepl ((nring (S n))[*]([1][-]_X_)[*]Bernstein H[+](nring (S n))[*]_X_[*]Bernstein H). rewrite RaiseDegreeA, RaiseDegreeB. reflexivity. Qed. Opaque Bernstein. (** Given a vector of coefficents for a polynomial in the Bernstein basis, return the polynomial *) Arguments Vector.nil {A}. Arguments Vector.cons [A]. Fixpoint evalBernsteinBasisH (n i:nat) (v:Vector.t R i) : i <= n -> cpoly_cring R := match v in Vector.t _ i return i <= n -> cpoly_cring R with |Vector.nil => fun _ => [0] |Vector.cons a i' v' => match n as n return (S i' <= n) -> cpoly_cring R with | O => fun p => False_rect _ (Nat.nle_succ_0 _ p) | S n' => fun p => _C_ a[*]Bernstein (le_S_n _ _ p)[+]evalBernsteinBasisH v' (Nat.lt_le_incl _ _ p) end end. Definition evalBernsteinBasis (n:nat) (v:Vector.t R n) : cpoly_cring R := evalBernsteinBasisH v (Nat.le_refl n). (** The coefficents are linear *) Opaque polyconst. Section obsolute_stuff_from_Bvector. Variable A : Type. Variable (g : A -> A -> A). Lemma Vbinary : forall (n : nat), Vector.t A n -> Vector.t A n -> Vector.t A n. Proof. induction n as [| n h]; intros v v0. apply Vector.nil. inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3]. exact (Vector.cons (g a a0) n (h H0 H2)). Defined. Definition Vid n : Vector.t A n -> Vector.t A n := match n with | O => fun _ => Vector.nil | S n' => fun v : Vector.t A (S n') => Vector.cons (Vector.hd v) _ (Vector.tl v) end. Lemma Vid_eq : forall (n:nat) (v:Vector.t A n), v = Vid v. Proof. destruct v; auto. Qed. Lemma VSn_eq : forall (n : nat) (v : Vector.t A (S n)), v = Vector.cons (Vector.hd v) _ (Vector.tl v). Proof. intros. exact (Vid_eq v). Qed. Lemma V0_eq : forall (v : Vector.t A 0), v = Vector.nil. Proof. intros. exact (Vid_eq v). Qed. End obsolute_stuff_from_Bvector. Lemma evalBernsteinBasisPlus : forall n (v1 v2: Vector.t R n), evalBernsteinBasis (Vbinary (fun (x y:R)=>x[+]y) v1 v2)[=]evalBernsteinBasis v1[+]evalBernsteinBasis v2. Proof. unfold evalBernsteinBasis. intros n. generalize (Nat.le_refl n). generalize n at 1 3 4 6 7 9 11. intros i. induction i. intros l v1 v2. rewrite (V0_eq v1), (V0_eq v2). ring. intros l v1 v2. destruct n as [|n]. exfalso; auto with *. rewrite (VSn_eq v1), (VSn_eq v2). simpl. rewrite IHi. rewrite -> c_plus. ring. Qed. Lemma evalBernsteinBasisConst : forall n c, evalBernsteinBasis (Vector.const c (S n))[=]_C_ c. Proof. intros n c. stepr (evalBernsteinBasis (Vector.const c (S n))[+]_C_ c[*]Sum (S n) n (part_tot_nat_fun _ _ (fun (i : nat) (H : i < S n) => Bernstein (proj1 (Nat.lt_succ_r i n) H)))). rewrite -> Sum_empty by auto with *. ring. unfold evalBernsteinBasis. generalize (Nat.le_refl (S n)). generalize (S n) at 1 4 5 6. intros i l. induction i. rstepr (_C_ c[*][1]). rewrite <- (partitionOfUnity n). rewrite -> Sumx_to_Sum; auto with *. intros i j Hij. rewrite Hij. intros H H'. replace (proj1 (Nat.lt_succ_r j n) H) with (proj1 (Nat.lt_succ_r j n) H') by apply le_irrelevent. reflexivity. rstepl (evalBernsteinBasisH (Vector.const c i) (Nat.lt_le_incl i (S n) l)[+] _C_ c[*](Bernstein (le_S_n i n l)[+] Sum (S i) n (part_tot_nat_fun (cpoly_cring R) (S n) (fun (i0 : nat) (H : i0 < S n) => Bernstein (proj1 (Nat.lt_succ_r i0 n) H))))). replace (Bernstein (le_S_n _ _ l)) with (part_tot_nat_fun (cpoly_cring R) (S n) (fun (i0 : nat) (H : i0 < S n) => Bernstein (proj1 (Nat.lt_succ_r i0 n) H)) i). rewrite <- Sum_first. apply IHi. clear - i. unfold part_tot_nat_fun. destruct (le_lt_dec (S n) i). exfalso; auto with *. simpl. replace (proj1 (Nat.lt_succ_r _ _) l0) with (le_S_n _ _ l) by apply le_irrelevent. reflexivity. Qed. Variable eta : RingHom Q_as_CRing R. Opaque Qred. Opaque Q_as_CRing. Opaque Vbinary. Opaque Vector.const. (** To convert a polynomial to the Bernstein basis, we need to know how to multiply a bernstein basis element by [_X_] can convert it to the Bernstein basis. At this point we must work with rational coeffients. So we assume there is a ring homomorphism from [Q] to R *) Fixpoint BernsteinBasisTimesXH (n i:nat) (v:Vector.t R i) : i <= n -> Vector.t R (S i) := match v in Vector.t _ i return i <= n -> Vector.t R (S i) with | Vector.nil => fun _ => Vector.cons [0] _ Vector.nil | Vector.cons a i' v' => match n as n return S i' <= n -> Vector.t R (S (S i')) with | O => fun p => False_rect _ (Nat.nle_succ_0 _ p) | S n' => fun p => Vector.cons (eta(Qred (i#P_of_succ_nat n'))[*]a) _ (BernsteinBasisTimesXH v' (Nat.lt_le_incl _ _ p)) end end. Definition BernsteinBasisTimesX (n:nat) (v:Vector.t R n) : Vector.t R (S n) := BernsteinBasisTimesXH v (Nat.le_refl n). Lemma evalBernsteinBasisTimesX : forall n (v:Vector.t R n), evalBernsteinBasis (BernsteinBasisTimesX v)[=]_X_[*]evalBernsteinBasis v. Proof. intros n. unfold evalBernsteinBasis, BernsteinBasisTimesX. generalize (Nat.le_refl (S n)) (Nat.le_refl n). generalize n at 1 3 5 7 9 11. intros i. induction i. intros l l0 v. rewrite (V0_eq v). simpl. rewrite <- c_zero. ring. intros l l0 v. destruct n as [|n]. exfalso; auto with *. rewrite (VSn_eq v). simpl. rewrite -> IHi. rewrite -> c_mult. rewrite -> ring_dist_unfolded. apply csbf_wd; try reflexivity. set (A:= (_C_ (eta (Qred (Qmake (Zpos (P_of_succ_nat i)) (P_of_succ_nat n)))))). rstepl (_C_ (Vector.hd v)[*](A[*]Bernstein (le_S_n (S i) (S n) l))). rstepr (_C_ (Vector.hd v)[*](_X_[*]Bernstein (le_S_n i n l0))). apply mult_wdr. unfold A; clear A. assert (Hn : (nring (S n):Q)[#][0]). stepl (S n:Q). simpl. unfold Qap, Qeq. auto with *. symmetry; apply nring_Q. setoid_replace (Qred (P_of_succ_nat i # P_of_succ_nat n)) with (([1][/](nring (S n))[//]Hn)[*](nring (S i))). set (eta':=RHcompose _ _ _ _C_ eta). change (_C_ (eta (([1][/]nring (S n)[//]Hn)[*]nring (S i)))) with ((eta' (([1][/]nring (S n)[//]Hn)[*]nring (S i))):cpoly_cring R). rewrite -> rh_pres_mult. rewrite -> rh_pres_nring. rewrite <- mult_assoc_unfolded. replace (le_S_n (S i) (S n) l) with (le_n_S _ _ (le_S_n i n l0)) by apply le_irrelevent. rewrite <- RaiseDegreeA. rewrite <- (@rh_pres_nring _ _ eta'). rewrite <- mult_assoc_unfolded. rewrite -> mult_assoc_unfolded. rewrite <- rh_pres_mult. setoid_replace (eta' (([1][/]nring (S n)[//]Hn)[*]nring (S n))) with ([1]:cpoly_cring R). ring. rewrite <- (@rh_pres_unit _ _ eta'). apply csf_wd. apply (@div_1 Q_as_CField). rewrite -> Qred_correct. rewrite -> Qmake_Qdiv. change (Zpos (P_of_succ_nat n)) with ((S n):Z). rewrite <- (nring_Q (S n)). change (Zpos (P_of_succ_nat i)) with ((S i):Z). rewrite <- (nring_Q (S i)). change (nring (S i)/nring (S n) == (1/(nring (S n)))*nring (S i))%Q. field. apply Hn. Qed. (** Convert a polynomial to the Bernstein basis *) Fixpoint BernsteinCoefficents (p:cpoly_cring R) : sigT (Vector.t R) := match p with | cpoly_zero _ => existT _ _ Vector.nil | cpoly_linear _ c p' => let (n', b') := (BernsteinCoefficents p') in existT _ _ (Vbinary (fun (x y:R)=>x[+]y) (Vector.const c _) (BernsteinBasisTimesX b')) end. Lemma evalBernsteinCoefficents : forall p, (let (n,b) := BernsteinCoefficents p in evalBernsteinBasis b)[=]p. Proof. induction p. reflexivity. simpl. destruct (BernsteinCoefficents p). rewrite -> evalBernsteinBasisPlus. rewrite -> evalBernsteinBasisConst. rewrite -> evalBernsteinBasisTimesX. rewrite -> IHp. rewrite -> poly_linear. ring. Qed. End Bernstein. Section BernsteinOrdField. Variable F : COrdField. Opaque cpoly_cring. (** A second important property of the Bernstein polynomials is that they are all non-negative on the unit interval. *) Lemma BernsteinNonNeg : forall x:F, [0] [<=] x -> x [<=] [1] -> forall n i (p:Nat.le i n), [0][<=](Bernstein F p)!x. Proof. intros x Hx0 Hx1. induction n. intros i p. simpl (Bernstein F p). autorewrite with apply. auto with *. intros [|i] p; simpl (Bernstein F p). autorewrite with apply. auto with *. destruct (le_lt_eq_dec (S i) (S n) p); autorewrite with apply; auto with *. Qed. End BernsteinOrdField. corn-8.20.0/algebra/CAbGroups.v000066400000000000000000000351451473720167500161770ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CGroups. Section Abelian_Groups. (** * Abelian Groups Now we introduce commutativity and add some results. *) Definition is_CAbGroup (G : CGroup) := commutes (csg_op (c:=G)). Record CAbGroup : Type := {cag_crr : CGroup; cag_proof : is_CAbGroup cag_crr}. Local Coercion cag_crr : CAbGroup >-> CGroup. Section AbGroup_Axioms. Variable G : CAbGroup. (** %\begin{convention}% Let [G] be an Abelian Group. %\end{convention}% *) Lemma CAbGroup_is_CAbGroup : is_CAbGroup G. Proof. elim G; auto. Qed. Lemma cag_commutes : commutes (csg_op (c:=G)). Proof. exact CAbGroup_is_CAbGroup. Qed. Lemma cag_commutes_unfolded : forall x y : G, x[+]y [=] y[+]x. Proof cag_commutes. End AbGroup_Axioms. Section SubCAbGroups. (** ** Subgroups of an Abelian Group *) Variable G : CAbGroup. Variable P : G -> CProp. Variable Punit : P [0]. Variable op_pres_P : bin_op_pres_pred _ P csg_op. Variable inv_pres_P : un_op_pres_pred _ P cg_inv. (** %\begin{convention}% Let [G] be an Abelian Group and [P] be a ([CProp]-valued) predicate on [G] that contains [Zero] and is closed under [[+]] and [[--]]. %\end{convention}% *) Let subcrr : CGroup := Build_SubCGroup _ _ Punit op_pres_P inv_pres_P. Lemma isabgrp_scrr : is_CAbGroup subcrr. Proof. red in |- *. intros x y. case x. case y. intros. simpl in |- *. apply cag_commutes_unfolded. Qed. Definition Build_SubCAbGroup : CAbGroup := Build_CAbGroup subcrr isabgrp_scrr. End SubCAbGroups. Section Various. (** ** Basic properties of Abelian groups *) Hint Resolve cag_commutes_unfolded: algebra. Variable G : CAbGroup. (** %\begin{convention}% Let [G] be an Abelian Group. %\end{convention}% *) Lemma cag_op_inv : forall x y : G, [--] (x[+]y) [=] [--]x[+] [--]y. Proof. intros x y. astepr ([--]y[+] [--]x). apply cg_inv_op. Qed. Hint Resolve cag_op_inv: algebra. Lemma assoc_1 : forall x y z : G, x[-] (y[-]z) [=] x[-]y[+]z. Proof. intros x y z; unfold cg_minus in |- *. astepr (x[+]([--]y[+]z)). Step_final (x[+]([--]y[+] [--][--]z)). Qed. Lemma minus_plus : forall x y z : G, x[-] (y[+]z) [=] x[-]y[-]z. Proof. intros x y z. unfold cg_minus in |- *. Step_final (x[+]([--]y[+] [--]z)). Qed. Lemma op_lft_resp_ap : forall x y z : G, y [#] z -> x[+]y [#] x[+]z. Proof. intros x y z H. astepl (y[+]x). astepr (z[+]x). apply op_rht_resp_ap; assumption. Qed. Lemma cag_ap_cancel_lft : forall x y z : G, x[+]y [#] x[+]z -> y [#] z. Proof. intros x y z H. apply ap_symmetric_unfolded. apply cg_ap_cancel_rht with x. apply ap_symmetric_unfolded. astepl (x[+]y). astepr (x[+]z). auto. Qed. Lemma plus_cancel_ap_lft : forall x y z : G, z[+]x [#] z[+]y -> x [#] y. Proof. intros x y z H. apply cag_ap_cancel_lft with z. assumption. Qed. End Various. End Abelian_Groups. #[global] Hint Resolve cag_commutes_unfolded: algebra. #[global] Hint Resolve cag_op_inv assoc_1 zero_minus minus_plus op_lft_resp_ap: algebra. Module Export coercions. Export CGroups.coercions. Coercion cag_crr : CAbGroup >-> CGroup. End coercions. Section Nice_Char. (** ** Building an abelian group In order to actually define concrete abelian groups, it is not in general practical to construct first a semigroup, then a monoid, then a group and finally an abelian group. The presence of commutativity, for example, makes many of the monoid proofs trivial. In this section, we provide a constructor that will allow us to go directly from a setoid to an abelian group. We start from a setoid S with an element [unit], a commutative and associative binary operation [plus] which is strongly extensional in its first argument and has [unit] as a left unit, and a unary setoid function [inv] which inverts elements respective to [plus]. *) Variable S : CSetoid. Variable unit : S. Variable plus : S -> S -> S. (** %\begin{convention}% Let [S] be a Setoid and [unit:S], [plus:S->S->S] and [inv] a unary setoid operation on [S]. Assume that [plus] is commutative, associative and `left-strongly-extensional ([(plus x z) [#] (plus y z) -> x [#] y]), that [unit] is a left-unit for [plus] and [(inv x)] is a right-inverse of [x] w.r.t.%\% [plus]. %\end{convention}% *) Hypothesis plus_lext : forall x y z : S, plus x z [#] plus y z -> x [#] y. Hypothesis plus_lunit : forall x : S, plus unit x [=] x. Hypothesis plus_comm : forall x y : S, plus x y [=] plus y x. Hypothesis plus_assoc : associative plus. Variable inv : CSetoid_un_op S. Hypothesis inv_inv : forall x : S, plus x (inv x) [=] unit. Lemma plus_rext : forall x y z : S, plus x y [#] plus x z -> y [#] z. Proof. intros x y z H. apply plus_lext with x. astepl (plus x y). astepr (plus x z). auto. Qed. Lemma plus_runit : forall x : S, plus x unit [=] x. Proof. intro x. Step_final (plus unit x). Qed. Lemma plus_is_fun : bin_fun_strext _ _ _ plus. Proof. intros x x' y y' H. elim (ap_cotransitive_unfolded _ _ _ H (plus x y')); intro H'. right; apply plus_lext with x. astepl (plus x y); astepr (plus x y'); auto. left; eauto. Qed. Lemma inv_inv' : forall x : S, plus (inv x) x [=] unit. Proof. intro. Step_final (plus x (inv x)). Qed. Definition plus_fun : CSetoid_bin_op S := Build_CSetoid_bin_fun _ _ _ plus plus_is_fun. Definition Build_CSemiGroup' : CSemiGroup. Proof. apply Build_CSemiGroup with S plus_fun. exact plus_assoc. Defined. Definition Build_CMonoid' : CMonoid. Proof. apply Build_CMonoid with Build_CSemiGroup' unit. apply Build_is_CMonoid. exact plus_runit. exact plus_lunit. Defined. Definition Build_CGroup' : CGroup. Proof. apply Build_CGroup with Build_CMonoid' inv. split. auto. apply inv_inv'. Defined. Definition Build_CAbGroup' : CAbGroup. Proof. apply Build_CAbGroup with Build_CGroup'. exact plus_comm. Defined. End Nice_Char. (** ** Iteration For reflection the following is needed; hopefully it is also useful. *) Section Group_Extras. Variable G : CAbGroup. Fixpoint nmult (a:G) (n:nat) {struct n} : G := match n with | O => [0] | S p => a[+]nmult a p end. Lemma nmult_wd : forall (x y:G) (n m:nat), (x [=] y) -> n = m -> nmult x n [=] nmult y m. Proof. simple induction n; intros. rewrite <- H0; algebra. rewrite <- H1; simpl in |- *; algebra. Qed. Lemma nmult_one : forall x:G, nmult x 1 [=] x. Proof. simpl in |- *; algebra. Qed. Lemma nmult_Zero : forall n:nat, nmult [0] n [=] [0]. Proof. intro n. induction n. algebra. simpl in |- *; Step_final (([0]:G)[+][0]). Qed. Lemma nmult_plus : forall m n x, nmult x m[+]nmult x n [=] nmult x (m + n). Proof. simple induction m. simpl in |- *; algebra. clear m; intro m. intros. simpl in |- *. Step_final (x[+](nmult x m[+]nmult x n)). Qed. Lemma nmult_mult : forall n m x, nmult (nmult x m) n [=] nmult x (m * n). Proof. simple induction n. intro. rewrite Nat.mul_0_r. algebra. clear n; intros. simpl in |- *. rewrite Nat.mul_comm. simpl in |- *. eapply eq_transitive_unfolded. 2: apply nmult_plus. rewrite Nat.mul_comm. algebra. Qed. Lemma nmult_inv : forall n x, nmult [--]x n [=] [--] (nmult x n). Proof. intro; induction n; simpl in |- *. algebra. intros. Step_final ([--]x[+] [--](nmult x n)). Qed. Lemma nmult_plus' : forall n x y, nmult x n[+]nmult y n [=] nmult (x[+]y) n. Proof. intro; induction n; simpl in |- *; intros. algebra. astepr (x[+]y[+](nmult x n[+]nmult y n)). astepr (x[+](y[+](nmult x n[+]nmult y n))). astepr (x[+](y[+]nmult x n[+]nmult y n)). astepr (x[+](nmult x n[+]y[+]nmult y n)). Step_final (x[+](nmult x n[+](y[+]nmult y n))). Qed. Hint Resolve nmult_wd nmult_Zero nmult_inv nmult_plus nmult_plus': algebra. Definition zmult a z := caseZ_diff z (fun n m => nmult a n[-]nmult a m). (* Lemma Zeq_imp_nat_eq : forall m n:nat, m = n -> m = n. auto. intro m; induction m. intro n; induction n; auto. intro; induction n. intro. inversion H. intros. rewrite (IHm n). auto. repeat rewrite inj_S in H. auto with zarith. Qed. *) Lemma zmult_char : forall (m n:nat) z, z = (m - n)%Z -> forall x, zmult x z [=] nmult x m[-]nmult x n. Proof. simple induction z; intros. simpl in |- *. replace m with n. Step_final ([0]:G). auto with zarith. simpl in |- *. astepl (nmult x (nat_of_P p)). apply cg_cancel_rht with (nmult x n). astepr (nmult x m). astepl (nmult x (nat_of_P p + n)). apply nmult_wd; algebra. rewrite <- convert_is_POS in H. auto with zarith. simpl in |- *. astepl [--](nmult x (nat_of_P p)). unfold cg_minus in |- *. astepr ([--][--](nmult x m)[+] [--](nmult x n)). astepr [--]([--](nmult x m)[+]nmult x n). apply un_op_wd_unfolded. apply cg_cancel_lft with (nmult x m). astepr (nmult x m[+] [--](nmult x m)[+]nmult x n). astepr ([0][+]nmult x n). astepr (nmult x n). astepl (nmult x (m + nat_of_P p)). apply nmult_wd; algebra. rewrite <- min_convert_is_NEG in H. auto with zarith. Qed. Lemma zmult_wd : forall (x y:G) (n m:Z), (x [=] y) -> n = m -> zmult x n [=] zmult y m. Proof. do 3 intro. case n; intros; inversion H0. algebra. unfold zmult in |- *. simpl in |- *. astepl (nmult x (nat_of_P p)); Step_final (nmult y (nat_of_P p)). simpl in |- *. astepl [--](nmult x (nat_of_P p)). Step_final [--](nmult y (nat_of_P p)). Qed. Lemma zmult_one : forall x:G, zmult x 1 [=] x. Proof. simpl in |- *; algebra. Qed. Lemma zmult_min_one : forall x:G, zmult x (-1) [=] [--]x. Proof. intros; simpl in |- *; Step_final ([0][-]x). Qed. Lemma zmult_zero : forall x:G, zmult x 0 [=] [0]. Proof. simpl in |- *; algebra. Qed. Lemma zmult_Zero : forall k:Z, zmult [0] k [=] [0]. Proof. intro; induction k; simpl in |- *. algebra. Step_final (([0]:G)[-][0]). Step_final (([0]:G)[-][0]). Qed. Hint Resolve zmult_zero: algebra. Lemma zmult_plus : forall m n x, zmult x m[+]zmult x n [=] zmult x (m + n). Proof. intros; case m; case n; intros. simpl in |- *; Step_final ([0][+]([0][-][0]):G). simpl in |- *; Step_final ([0][+](nmult x (nat_of_P p)[-][0])). simpl in |- *; Step_final ([0][+]([0][-]nmult x (nat_of_P p))). simpl in |- *; Step_final (nmult x (nat_of_P p)[-][0][+][0]). simpl in |- *. astepl (nmult x (nat_of_P p0)[+]nmult x (nat_of_P p)). astepr (nmult x (nat_of_P (p0 + p))). rewrite nat_of_P_plus_morphism. apply nmult_plus. simpl (zmult x (Zpos p0)[+]zmult x (Zneg p)) in |- *. astepl (nmult x (nat_of_P p0)[+] [--](nmult x (nat_of_P p))). astepl (nmult x (nat_of_P p0)[-]nmult x (nat_of_P p)). apply eq_symmetric_unfolded; apply zmult_char with (z := (Zpos p0 + Zneg p)%Z). rewrite convert_is_POS. unfold Zminus in |- *. rewrite min_convert_is_NEG; auto. rewrite <- Zplus_0_r_reverse. Step_final (zmult x (Zneg p)[+][0]). simpl (zmult x (Zneg p0)[+]zmult x (Zpos p)) in |- *. astepl ([--](nmult x (nat_of_P p0))[+]nmult x (nat_of_P p)). astepl (nmult x (nat_of_P p)[+] [--](nmult x (nat_of_P p0))). astepl (nmult x (nat_of_P p)[-]nmult x (nat_of_P p0)). rewrite Zplus_comm. apply eq_symmetric_unfolded; apply zmult_char with (z := (Zpos p + Zneg p0)%Z). rewrite convert_is_POS. unfold Zminus in |- *. rewrite min_convert_is_NEG; auto. simpl in |- *. astepl ([--](nmult x (nat_of_P p0))[+] [--](nmult x (nat_of_P p))). astepl [--](nmult x (nat_of_P p0)[+]nmult x (nat_of_P p)). astepr [--](nmult x (nat_of_P (p0 + p))). apply un_op_wd_unfolded. rewrite nat_of_P_plus_morphism. apply nmult_plus. Qed. Lemma zmult_mult : forall m n x, zmult (zmult x m) n [=] zmult x (m * n). Proof. simple induction m; simple induction n; simpl in |- *; intros. Step_final ([0][-][0][+]([0]:G)). astepr ([0]:G). astepl (nmult ([0][-][0]) (nat_of_P p)). Step_final (nmult [0] (nat_of_P p)). astepr [--]([0]:G). astepl [--](nmult ([0][-][0]) (nat_of_P p)). Step_final [--](nmult [0] (nat_of_P p)). algebra. astepr (nmult x (nat_of_P (p * p0))). astepl (nmult (nmult x (nat_of_P p)) (nat_of_P p0)[-][0]). astepl (nmult (nmult x (nat_of_P p)) (nat_of_P p0)). rewrite nat_of_P_mult_morphism. apply nmult_mult. astepr [--](nmult x (nat_of_P (p * p0))). astepl ([0][-]nmult (nmult x (nat_of_P p)) (nat_of_P p0)). astepl [--](nmult (nmult x (nat_of_P p)) (nat_of_P p0)). rewrite nat_of_P_mult_morphism. apply un_op_wd_unfolded. apply nmult_mult. algebra. astepr [--](nmult x (nat_of_P (p * p0))). astepl (nmult [--](nmult x (nat_of_P p)) (nat_of_P p0)[-][0]). astepl (nmult [--](nmult x (nat_of_P p)) (nat_of_P p0)). rewrite nat_of_P_mult_morphism. eapply eq_transitive_unfolded. apply nmult_inv. apply un_op_wd_unfolded. apply nmult_mult. astepr (nmult x (nat_of_P (p * p0))). astepr [--][--](nmult x (nat_of_P (p * p0))). astepl ([0][-]nmult [--](nmult x (nat_of_P p)) (nat_of_P p0)). astepl [--](nmult [--](nmult x (nat_of_P p)) (nat_of_P p0)). rewrite nat_of_P_mult_morphism. apply un_op_wd_unfolded. eapply eq_transitive_unfolded. apply nmult_inv. apply un_op_wd_unfolded. apply nmult_mult. Qed. Lemma zmult_plus' : forall z x y, zmult x z[+]zmult y z [=] zmult (x[+]y) z. Proof. intro z; pattern z in |- *. apply nats_Z_ind. intro n; case n. intros; simpl in |- *. Step_final (([0]:G)[+]([0][-][0])). clear n; intros. rewrite POS_anti_convert; simpl in |- *. set (p := nat_of_P (P_of_succ_nat n)) in *. astepl (nmult x p[+]nmult y p). Step_final (nmult (x[+]y) p). intro n; case n. intros; simpl in |- *. Step_final (([0]:G)[+]([0][-][0])). clear n; intros. rewrite NEG_anti_convert; simpl in |- *. set (p := nat_of_P (P_of_succ_nat n)) in *. astepl ([--](nmult x p)[+] [--](nmult y p)). astepr [--](nmult (x[+]y) p). Step_final [--](nmult x p[+]nmult y p). Qed. End Group_Extras. #[global] Hint Resolve nmult_wd nmult_one nmult_Zero nmult_plus nmult_inv nmult_mult nmult_plus' zmult_wd zmult_one zmult_min_one zmult_zero zmult_Zero zmult_plus zmult_mult zmult_plus': algebra. Arguments nmult [G]. Arguments zmult [G]. corn-8.20.0/algebra/CAbMonoids.v000066400000000000000000000054261473720167500163270ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CMonoids. Require Import CoRN.util.SetoidPermutation Coq.Setoids.Setoid Coq.Classes.Morphisms. Section Abelian_Monoids. (** * Abelian Monoids Now we introduce commutativity and add some results. *) Definition is_CAbMonoid (G : CMonoid) := commutes (csg_op (c:=G)). Record CAbMonoid : Type := {cam_crr :> CMonoid; cam_proof : is_CAbMonoid cam_crr}. Section AbMonoid_Axioms. Variable M : CAbMonoid. (** %\begin{convention}% Let [M] be an abelian monoid. %\end{convention}% *) Lemma CAbMonoid_is_CAbMonoid : is_CAbMonoid M. Proof. elim M; auto. Qed. Lemma cam_commutes : commutes (csg_op (c:=M)). Proof. exact CAbMonoid_is_CAbMonoid. Qed. Lemma cam_commutes_unfolded : forall x y : M, x[+]y [=] y[+]x. Proof cam_commutes. End AbMonoid_Axioms. Global Instance cm_Sum_AbMonoid_Proper: forall {M: CAbMonoid}, Proper (SetoidPermutation (@st_eq M) ==> @st_eq M) cm_Sum. Proof. repeat intro. apply cm_Sum_Proper. apply cam_proof. assumption. Qed. Section SubCAbMonoids. (** ** Subgroups of an Abelian Monoid *) Variable M : CAbMonoid. Variable P : M -> CProp. Variable Punit : P [0]. Variable op_pres_P : bin_op_pres_pred _ P csg_op. (** %\begin{convention}% Let [M] be an Abelian Monoid and [P] be a ([CProp]-valued) predicate on [M] that contains [Zero] and is closed under [[+]] and [[--]]. %\end{convention}% *) Let subcrr : CMonoid := Build_SubCMonoid _ _ Punit op_pres_P. Lemma isabgrp_scrr : is_CAbMonoid subcrr. Proof. red in |- *. intros x y. case x. case y. intros. simpl in |- *. apply cam_commutes_unfolded. Qed. Definition Build_SubCAbMonoid : CAbMonoid := Build_CAbMonoid _ isabgrp_scrr. End SubCAbMonoids. End Abelian_Monoids. #[global] Hint Resolve cam_commutes_unfolded: algebra. corn-8.20.0/algebra/CFields.v000066400000000000000000000553271473720167500156670ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [/] %\ensuremath{/}% #/# *) (** printing [//] %\ensuremath\ddagger% #‡# *) (** printing {/} %\ensuremath{/}% #/# *) (** printing {1/} %\ensuremath{\frac1\cdot}% #1/# *) (** printing [/]?[//] %\ensuremath{/?\ddagger}% #/?‡# *) Require Export CoRN.algebra.CRings. Transparent sym_eq. Transparent f_equal. Transparent cs_crr. Transparent csg_crr. Transparent cm_crr. Transparent cg_crr. Transparent cr_crr. Transparent csf_fun. Transparent csbf_fun. Transparent csr_rel. Transparent cs_eq. Transparent cs_neq. Transparent cs_ap. Transparent cm_unit. Transparent csg_op. Transparent cg_inv. Transparent cg_minus. Transparent cr_one. Transparent cr_mult. Transparent nexp_op. (* Begin_SpecReals *) (* FIELDS *) (** * Fields %\label{section:fields}% ** Definition of the notion Field *) Definition is_CField (R : CRing) (cf_rcpcl : forall x : R, x [#] [0] -> R) : Prop := forall x Hx, is_inverse cr_mult [1] x (cf_rcpcl x Hx). Record CField : Type := {cf_crr :> CRing; cf_rcpcl : forall x : cf_crr, x [#] [0] -> cf_crr; cf_proof : is_CField cf_crr cf_rcpcl; cf_rcpsx : forall x y x_ y_, cf_rcpcl x x_ [#] cf_rcpcl y y_ -> x [#] y}. (* End_SpecReals *) Definition f_rcpcl' (F : CField) : PartFunct F. Proof. apply Build_PartFunct with (fun x : F => x [#] [0]) (cf_rcpcl F). red in |- *; intros; astepl x. auto. exact (cf_rcpsx F). Defined. Definition f_rcpcl F x x_ := f_rcpcl' F x x_. Arguments f_rcpcl [F]. (** [cf_div] is the division in a field. It is defined in terms of multiplication and the reciprocal. [x[/]y] is only defined if we have a proof of [y [#] [0]]. *) Definition cf_div (F : CField) (x y : F) y_ : F := x[*]f_rcpcl y y_. Arguments cf_div [F]. Notation "x [/] y [//] Hy" := (cf_div x y Hy) (at level 80). (** %\begin{convention}\label{convention:div-form}% - Division in fields is a (type dependent) ternary function: [(cf_div x y Hy)] is denoted infix by [x [/] y [//] Hy]. - In lemmas, a hypothesis that [t [#] [0]] will be named [t_]. - We do not use [Non[0]s], but write the condition [ [#] [0]] separately. - In each lemma, we use only variables for proof objects, and these variables are universally quantified. For example, the informal lemma $\frac{1}{x}\cdot\frac{1}{y} = \frac{1}{x\cdot y}$ #(1/x).(1/y) = 1/(x.y)# for all [x] and [y]is formalized as [[ forall (x y : F) x_ y_ xy_, (1[/]x[//]x_) [*] (1[/]y[//]y_) [=] 1[/] (x[*]y)[//]xy_ ]] and not as [[ forall (x y : F) x_ y_, (1[/]x[//]x_) [*] (1[/]y[//]y_) [=] 1[/] (x[*]y)[//](prod_nz x y x_ y_) ]] We have made this choice to make it easier to apply lemmas; this can be quite awkward if we would use the last formulation. - So every division occurring in the formulation of a lemma is of the form [e[/]e'[//]H] where [H] is a variable. Only exceptions: we may write [e[/] (Snring n)] and [e[/]TwoNZ], [e[/]ThreeNZ] and so on. (Constants like [TwoNZ] will be defined later on.) %\end{convention}% ** Field axioms %\begin{convention}% Let [F] be a field. %\end{convention}% *) Section Field_axioms. Variable F : CField. Lemma CField_is_CField : is_CField F (cf_rcpcl F). Proof. elim F; auto. Qed. Lemma rcpcl_is_inverse : forall x x_, is_inverse cr_mult [1] x (cf_rcpcl F x x_). Proof. apply CField_is_CField. Qed. End Field_axioms. Section Field_basics. (** ** Field basics %\begin{convention}% Let [F] be a field. %\end{convention}% *) Variable F : CField. Lemma rcpcl_is_inverse_unfolded : forall x x_, x[*]cf_rcpcl F x x_ [=] [1]. Proof. intros x x_. elim (rcpcl_is_inverse F x x_); auto. Qed. Lemma field_mult_inv : forall (x : F) x_, x[*]f_rcpcl x x_ [=] [1]. Proof rcpcl_is_inverse_unfolded. Hint Resolve field_mult_inv: algebra. Lemma field_mult_inv_op : forall (x : F) x_, f_rcpcl x x_[*]x [=] [1]. Proof. intros x x_. elim (rcpcl_is_inverse F x x_); auto. Qed. End Field_basics. #[global] Hint Resolve field_mult_inv field_mult_inv_op: algebra. Section Field_multiplication. (** ** Properties of multiplication %\begin{convention}% Let [F] be a field. %\end{convention}% *) Variable F : CField. Lemma mult_resp_ap_zero : forall x y : F, x [#] [0] -> y [#] [0] -> x[*]y [#] [0]. Proof. intros x y Hx Hy. apply cring_mult_ap_zero with (f_rcpcl y Hy). astepl x. auto. astepl (x[*][1]). eapply eq_transitive_unfolded. 2: apply CRings.mult_assoc. algebra. Qed. Lemma mult_lft_resp_ap : forall x y z : F, x [#] y -> z [#] [0] -> z[*]x [#] z[*]y. Proof. intros x y z H Hz. apply zero_minus_apart. unfold cg_minus in |- *. astepl (z[*]x[+]z[*][--]y). astepl (z[*] (x[+][--]y)). astepl (z[*] (x[-]y)). apply mult_resp_ap_zero; algebra. Qed. Lemma mult_rht_resp_ap : forall x y z : F, x [#] y -> z [#] [0] -> x[*]z [#] y[*]z. Proof. intros x y z H Hz. astepl (z[*]x). astepr (z[*]y). apply mult_lft_resp_ap; assumption. Qed. Lemma mult_resp_neq_zero : forall x y : F, x[~=][0] -> y[~=][0] -> x[*]y[~=][0]. Proof. intros x y Hx Hy. cut (~ Not (x [#] [0])). intro H. cut (~ Not (y [#] [0])). intro H0. apply notnot_ap_imp_neq. cut (x [#] [0] -> y [#] [0] -> x[*]y [#] [0]). intro H1. intro. apply H0; intro H3. apply H; intro H4. apply H2; auto. intros; apply mult_resp_ap_zero; auto. apply neq_imp_notnot_ap; auto. apply neq_imp_notnot_ap; auto. Qed. Lemma mult_resp_neq : forall x y z : F, x[~=]y -> z[~=][0] -> x[*]z[~=]y[*]z. Proof. intros x y z H Hz. generalize (neq_imp_notnot_ap _ _ _ H). generalize (neq_imp_notnot_ap _ _ _ Hz). generalize (mult_rht_resp_ap x y z). intros H1 H2 H3. apply notnot_ap_imp_neq. intro H4. apply H2; intro. apply H3; intro. apply H4. auto. Qed. Lemma mult_eq_zero : forall x y : F, x[~=][0] -> x[*]y [=] [0] -> y [=] [0]. Proof. intros x y Hx Hxy. apply not_ap_imp_eq. intro H. elim (eq_imp_not_neq _ _ _ Hxy). apply mult_resp_neq_zero. assumption. apply ap_imp_neq. assumption. Qed. Lemma mult_cancel_lft : forall x y z : F, z [#] [0] -> z[*]x [=] z[*]y -> x [=] y. Proof. intros x y z Hz H. apply not_ap_imp_eq. intro H2. elim (eq_imp_not_ap _ _ _ H). apply mult_lft_resp_ap; assumption. Qed. Lemma mult_cancel_rht : forall x y z : F, z [#] [0] -> x[*]z [=] y[*]z -> x [=] y. Proof. intros x y z Hz H. apply (mult_cancel_lft x y z). assumption. astepr (y[*]z). Step_final (x[*]z). Qed. Lemma square_eq_aux : forall x a : F, x[^]2 [=] a[^]2 -> (x[+]a) [*] (x[-]a) [=] [0]. Proof. intros x a H. astepl (x[^]2[-]a[^]2). Step_final (a[^]2[-]a[^]2). Qed. Lemma square_eq_weak : forall x a : F, x[^]2 [=] a[^]2 -> Not (x [#] a and x [#] [--]a). Proof. intros x a H. intro H0. elim H0; intros H1 H2. generalize (square_eq_aux _ _ H); intro H3. generalize (eq_imp_not_ap _ _ _ H3); intro H4. apply H4. apply mult_resp_ap_zero. astepr ([--]a[+]a). apply op_rht_resp_ap. auto. astepr (a[-]a). apply minus_resp_ap_rht. assumption. Qed. Lemma cond_square_eq : forall x a : F, (Two:F) [#] [0] -> a [#] [0] -> x[^]2 [=] a[^]2 -> x [=] a or x [=] [--]a. Proof. intros x a H Ha H0. cut (a [#] [--]a). intro H1. elim (ap_cotransitive_unfolded _ _ _ H1 x); intro H2. right. apply not_ap_imp_eq. intro H3. elim (square_eq_weak _ _ H0). split; auto. apply ap_symmetric_unfolded; auto. left. apply not_ap_imp_eq. intro H3. elim (square_eq_weak _ _ H0); auto. apply plus_cancel_ap_lft with a. astepr ([0]:F). astepl (Two[*]a). apply mult_resp_ap_zero; auto. Qed. End Field_multiplication. Section x_square. Lemma x_xminone : forall (F : CField) (x : F), x[^]2 [=] x -> x[*] (x[-][1]) [=] [0]. Proof. intros H x h. astepl (x[*]x[-]x[*][1]). astepl (x[*]x[-]x). apply cg_cancel_rht with x. astepl (x[*]x[+][--]x[+]x). astepl (x[*]x[+]([--]x[+]x)). astepl (x[*]x[+][0]). astepl (x[*]x). astepr x. astepl (x[^]2). exact h. Qed. Lemma square_id : forall (F : CField) (x : F), x[^]2 [=] x -> {x [=] [0]} + {x [=] [1]}. Proof. intros F x H. cut (([0]:F) [#] ([1]:F)). intro H0. elim (ap_cotransitive_unfolded _ _ _ H0 x). intro H1. right. apply not_ap_imp_eq. red in |- *. intro H2. set (H3 := minus_resp_ap_rht F x [1] [1] H2) in *. set (H4 := ap_wdr_unfolded F (x[-][1]) ([1][-][1]) [0] H3 (cg_minus_correct F [1])) in *. set (H5 := ap_symmetric_unfolded F [0] x H1) in *. set (H6 := mult_resp_ap_zero F x (x[-][1]) H5 H4) in *. simpl in |- *. set (H7 := x_xminone F x H) in *. set (H8 := eq_imp_not_ap F (x[*] (x[-][1])) [0] H7) in *. intuition. left. apply not_ap_imp_eq. red in |- *. intro H2. set (H3 := minus_resp_ap_rht F x [1] [1] b) in *. set (H4 := ap_wdr_unfolded F (x[-][1]) ([1][-][1]) [0] H3 (cg_minus_correct F [1])) in *. set (H6 := mult_resp_ap_zero F x (x[-][1]) H2 H4) in *. set (H7 := x_xminone F x H) in *. set (H8 := eq_imp_not_ap F (x[*] (x[-][1])) [0] H7) in *. intuition. apply ap_symmetric_unfolded. apply ring_non_triv. Qed. End x_square. #[global] Hint Resolve mult_resp_ap_zero: algebra. Section Rcpcl_properties. (** ** Properties of reciprocal %\begin{convention}% Let [F] be a field. %\end{convention}% *) Variable F : CField. Lemma inv_one : f_rcpcl [1] (ring_non_triv F) [=] [1]. Proof. astepl ([1][*]f_rcpcl [1] (ring_non_triv F)). apply field_mult_inv. Qed. Lemma f_rcpcl_wd : forall (x y : F) x_ y_, x [=] y -> f_rcpcl x x_ [=] f_rcpcl y y_. Proof. intros x y H. unfold f_rcpcl in |- *; algebra. Qed. Lemma f_rcpcl_mult : forall (y z : F) y_ z_ yz_, f_rcpcl (y[*]z) yz_ [=] f_rcpcl y y_[*]f_rcpcl z z_. Proof. intros y z nzy nzz nzyz. apply mult_cancel_lft with (y[*]z). assumption. astepl ([1]:F). astepr (y[*]z[*] (f_rcpcl z nzz[*]f_rcpcl y nzy)). astepr (y[*] (z[*] (f_rcpcl z nzz[*]f_rcpcl y nzy))). astepr (y[*] (z[*]f_rcpcl z nzz[*]f_rcpcl y nzy)). astepr (y[*] ([1][*]f_rcpcl y nzy)). astepr (y[*]f_rcpcl y nzy). Step_final ([1]:F). Qed. Lemma f_rcpcl_resp_ap_zero : forall (y : F) y_, f_rcpcl y y_ [#] [0]. Proof. intros y nzy. apply cring_mult_ap_zero_op with y. astepl ([1]:F). apply one_ap_zero. Qed. Lemma f_rcpcl_f_rcpcl : forall (x : F) x_ r_, f_rcpcl (f_rcpcl x x_) r_ [=] x. Proof. intros x nzx nzr. apply mult_cancel_rht with (f_rcpcl x nzx). assumption. astepr ([1]:F). Step_final (f_rcpcl x nzx[*]f_rcpcl (f_rcpcl x nzx) nzr). Qed. End Rcpcl_properties. Section MultipGroup. (** ** The multiplicative group of nonzeros of a field. %\begin{convention}% Let [F] be a field %\end{convention}% *) Variable F : CField. (** The multiplicative monoid of Non[0]s. *) Definition NonZeroMonoid : CMonoid := Build_SubCMonoid (Build_multCMonoid F) (nonZeroP (M:=F)) (one_ap_zero F) (mult_resp_ap_zero F). Definition fmg_cs_inv : CSetoid_un_op NonZeroMonoid. Proof. red in |- *. cut (forall x : NonZeroMonoid, nonZeroP (cf_rcpcl F (scs_elem _ _ x) (scs_prf _ _ x))). intro H. apply Build_CSetoid_fun with (fun x : NonZeroMonoid => Build_subcsetoid_crr _ _ (cf_rcpcl F (scs_elem _ _ x) (scs_prf _ _ x)) (H x)). red in |- *. simpl in |- *. simple destruct x; simple destruct y. intros scs_elem0 scs_prf0 H0. apply (cf_rcpsx _ _ _ _ _ H0). intro; simpl in |- *. red in |- *. astepl (f_rcpcl (scs_elem _ _ x) (scs_prf _ _ x)). apply f_rcpcl_resp_ap_zero. Defined. Lemma plus_nonzeros_eq_mult_dom : forall x y : NonZeroMonoid, scs_elem _ _ (x[+]y) [=] scs_elem _ _ x[*]scs_elem _ _ y. Proof. simple destruct x; simple destruct y; algebra. Qed. Lemma cfield_to_mult_cgroup : CGroup. Proof. apply (Build_CGroup NonZeroMonoid fmg_cs_inv). intro x. red in |- *. elim x; intros x_ Hx. simpl in |- *; apply cf_proof. Qed. End MultipGroup. Section Div_properties. (** ** Properties of division %\begin{convention}% Let [F] be a field. %\end{convention}% %\begin{nameconvention}% In the names of lemmas, we denote [[/]] by [div], and [[1][/]] by [recip]. %\end{nameconvention}% *) Variable F : CField. Lemma div_prop : forall (x : F) x_, ([0][/] x[//]x_) [=] [0]. Proof. unfold cf_div in |- *; algebra. Qed. Lemma div_1 : forall (x y : F) y_, (x[/] y[//]y_) [*]y [=] x. Proof. intros x y y_. astepl (x[*]f_rcpcl y y_[*]y). astepl (x[*] (f_rcpcl y y_[*]y)). Step_final (x[*][1]). Qed. Lemma div_1' : forall (x y : F) y_, y[*] (x[/] y[//]y_) [=] x. Proof. intros x y y_. astepl ((x[/] y[//]y_) [*]y). apply div_1. Qed. Lemma div_1'' : forall (x y : F) y_, (x[*]y[/] y[//]y_) [=] x. Proof. intros x y y_. unfold cf_div in |- *. astepl (y[*]x[*]f_rcpcl y y_). astepl (y[*] (x[*]f_rcpcl y y_)). change (y[*] (x[/] y[//]y_) [=] x) in |- *. apply div_1'. Qed. Hint Resolve div_1: algebra. Lemma x_div_x : forall (x : F) x_, (x[/] x[//]x_) [=] [1]. Proof. intros x x_. unfold cf_div in |- *. apply field_mult_inv. Qed. Hint Resolve x_div_x: algebra. Lemma x_div_one : forall x : F, (x[/] [1][//]ring_non_triv F) [=] x. Proof. intro x. unfold cf_div in |- *. generalize inv_one; intro H. astepl (x[*][1]). apply mult_one. Qed. (** The next lemma says $x\cdot\frac{y}{z} = \frac{x\cdot y}{z}$ #x.(y/z) = (x.y)/z#. *) Lemma x_mult_y_div_z : forall (x y z : F) z_, x[*] (y[/] z[//]z_) [=] (x[*]y[/] z[//]z_). Proof. unfold cf_div in |- *; algebra. Qed. Hint Resolve x_mult_y_div_z: algebra. Lemma div_wd : forall (x x' y y' : F) y_ y'_, x [=] x' -> y [=] y' -> (x[/] y[//]y_) [=] (x'[/] y'[//]y'_). Proof. intros x x' y y' nzy nzy' H H0. unfold cf_div in |- *. cut (f_rcpcl y nzy [=] f_rcpcl y' nzy'). intro H1. algebra. apply f_rcpcl_wd. assumption. Qed. Hint Resolve div_wd: algebra_c. (** The next lemma says $\frac{\frac{x}{y}}{z} = \frac{x}{y\cdot z}$ #[(x/y)/z = x/(y.z)]# *) Lemma div_div : forall (x y z : F) y_ z_ yz_, ((x[/] y[//]y_) [/] z[//]z_) [=] (x[/] y[*]z[//]yz_). Proof. intros x y z nzy nzz nzyz. unfold cf_div in |- *. astepl (x[*] (f_rcpcl y nzy[*]f_rcpcl z nzz)). apply mult_wdr. apply eq_symmetric_unfolded. apply f_rcpcl_mult. Qed. Lemma div_resp_ap_zero_rev : forall (x y : F) y_, x [#] [0] -> (x[/] y[//]y_) [#] [0]. Proof. intros x y nzy Hx. unfold cf_div in |- *. apply mult_resp_ap_zero. assumption. apply f_rcpcl_resp_ap_zero. Qed. Lemma div_resp_ap_zero : forall (x y : F) y_, (x[/] y[//]y_) [#] [0] -> x [#] [0]. Proof. intros x y nzy Hxy. astepl ((x[/] y[//]nzy) [*]y). algebra. Qed. (** The next lemma says $\frac{x}{\frac{y}{z}} = \frac{x\cdot z}{y}$ #[x/(y/z) = (x.z)/y]# *) Lemma div_div2 : forall (x y z : F) y_ z_ yz_, (x[/] y[/] z[//]z_[//]yz_) [=] (x[*]z[/] y[//]y_). Proof. intros x y z nzy nzz nzyz. unfold cf_div in |- *. astepr (x[*] (z[*]f_rcpcl y nzy)). apply mult_wdr. cut (f_rcpcl z nzz [#] [0]). intro nzrz. apply eq_transitive_unfolded with (f_rcpcl y nzy[*]f_rcpcl (f_rcpcl z nzz) nzrz). apply f_rcpcl_mult. astepr (f_rcpcl y nzy[*]z). apply mult_wdr. apply f_rcpcl_f_rcpcl. apply f_rcpcl_resp_ap_zero. Qed. (** The next lemma says $\frac{x\cdot p}{y\cdot q} = \frac{x}{y}\cdot \frac{p}{q}$ #[(x.p)/(y.q) = (x/y).(p/q)]# *) Lemma mult_of_divs : forall (x y p q : F) y_ q_ yq_, (x[*]p[/] y[*]q[//]yq_) [=] (x[/] y[//]y_) [*] (p[/] q[//]q_). Proof. intros x y p q nzy nzq nzyq. unfold cf_div in |- *. astepl (x[*] (p[*]f_rcpcl (y[*]q) nzyq)). astepr (x[*] (f_rcpcl y nzy[*] (p[*]f_rcpcl q nzq))). apply mult_wdr. astepr (f_rcpcl y nzy[*]p[*]f_rcpcl q nzq). astepr (p[*]f_rcpcl y nzy[*]f_rcpcl q nzq). astepr (p[*] (f_rcpcl y nzy[*]f_rcpcl q nzq)). apply mult_wdr. apply f_rcpcl_mult. Qed. Lemma div_dist : forall (x y z : F) z_, (x[+]y[/] z[//]z_) [=] (x[/] z[//]z_) [+] (y[/] z[//]z_). Proof. unfold cf_div in |- *; algebra. Qed. Lemma div_dist' : forall (x y z : F) z_, (x[-]y[/] z[//]z_) [=] (x[/] z[//]z_) [-] (y[/] z[//]z_). Proof. unfold cf_div in |- *; algebra. Qed. Lemma div_semi_sym : forall (x y z : F) y_ z_, ((x[/] y[//]y_) [/] z[//]z_) [=] ((x[/] z[//]z_) [/] y[//]y_). Proof. intros. unfold cf_div in |- *. astepl (x[*] ((f_rcpcl y y_) [*] (f_rcpcl z z_))). Step_final (x[*] ((f_rcpcl z z_) [*] (f_rcpcl y y_))). Qed. Hint Resolve div_semi_sym: algebra. Lemma eq_div : forall (x y u v : F) y_ v_, x[*]v [=] u[*]y -> (x[/] y[//]y_) [=] (u[/] v[//]v_). Proof. intros x y u v Hy Hv H. astepl (x[*][1][/] y[//]Hy). astepl (x[*] (v[/] v[//]Hv) [/] y[//]Hy). astepl ((x[*]v[/] v[//]Hv) [/] y[//]Hy). astepl ((u[*]y[/] v[//]Hv) [/] y[//]Hy). astepl ((u[*]y[/] y[//]Hy) [/] v[//]Hv). astepl (u[*] (y[/] y[//]Hy) [/] v[//]Hv). Step_final (u[*][1][/] v[//]Hv). Qed. Lemma div_strext : forall (x x' y y' : F) y_ y'_, (x[/] y[//]y_) [#] (x'[/] y'[//]y'_) -> x [#] x' or y [#] y'. Proof. intros x x' y y' Hy Hy' H. unfold cf_div in H. elim (cs_bin_op_strext F cr_mult _ _ _ _ H). auto. intro H1. right. unfold f_rcpcl in H1. exact (pfstrx _ _ _ _ _ _ H1). Qed. End Div_properties. #[global] Hint Resolve div_1 div_1' div_1'' div_wd x_div_x x_div_one div_div div_div2 mult_of_divs x_mult_y_div_z mult_of_divs div_dist div_dist' div_semi_sym div_prop: algebra. (** ** Cancellation laws for apartness and multiplication %\begin{convention}% Let [F] be a field %\end{convention}% *) Section Mult_Cancel_Ap_Zero. Variable F : CField. Lemma mult_cancel_ap_zero_lft : forall x y : F, x[*]y [#] [0] -> x [#] [0]. Proof. intros x y H. cut (x[*]y [#] [0][*][0]). intro H0. elim (bin_op_strext_unfolded _ _ _ _ _ _ H0); intro H1. 3: astepr ([0]:F); auto. assumption. astepl (x[*]y[/] y[//]H1). apply div_resp_ap_zero_rev. assumption. Qed. Lemma mult_cancel_ap_zero_rht : forall x y : F, x[*]y [#] [0] -> y [#] [0]. Proof. intros x y H. apply mult_cancel_ap_zero_lft with x. astepl (x[*]y). auto. Qed. Lemma recip_ap_zero : forall (x : F) x_, ([1][/] x[//]x_) [#] [0]. Proof. intros; apply cring_mult_ap_zero with x. astepl ([1]:F). algebra. Qed. Lemma recip_resp_ap : forall (x y : F) x_ y_, x [#] y -> ([1][/] x[//]x_) [#] ([1][/] y[//]y_). Proof. intros x y x_ y_ H. apply zero_minus_apart. apply mult_cancel_ap_zero_lft with (x[*]y). apply ap_wdl with (y[-]x). apply minus_ap_zero. apply ap_symmetric_unfolded; assumption. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply dist_2b. apply cg_minus_wd. astepr (x[*]y[*] ([1][/] x[//]x_)). astepr (x[*]y[*][1][/] x[//]x_). astepr (x[*]y[/] x[//]x_). astepr (y[*]x[/] x[//]x_). astepr (y[*] (x[/] x[//]x_)). Step_final (y[*][1]). astepr (x[*]y[*] ([1][/] y[//]y_)). astepr (x[*]y[*][1][/] y[//]y_). astepr (x[*]y[/] y[//]y_). astepr (x[*] (y[/] y[//]y_)). Step_final (x[*][1]). Qed. End Mult_Cancel_Ap_Zero. Section CField_Ops. (** ** Functional Operations We now move on to lifting these operations to functions. As we are dealing with %\emph{partial}% #partial# functions, we don't have to worry explicitly about the function by which we are dividing being non-zero everywhere; this will simply be encoded in its domain. %\begin{convention}% Let [X] be a Field and [F,G:(PartFunct X)] have domains respectively [P] and [Q]. %\end{convention}% *) Variable X : CField. Variables F G : PartFunct X. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Section Part_Function_Recip. (** Some auxiliary notions are helpful in defining the domain. *) Let R := extend Q (fun x Hx => G x Hx [#] [0]). Let Ext2R := ext2 (S:=X) (P:=Q) (R:=fun x Hx => G x Hx [#] [0]). Lemma part_function_recip_strext : forall x y Hx Hy, ([1][/] _[//]Ext2R x Hx) [#] ([1][/] _[//]Ext2R y Hy) -> x [#] y. Proof. intros x y Hx Hy H. elim (div_strext _ _ _ _ _ _ _ H); intro H1. exfalso; apply ap_irreflexive_unfolded with (x := [1]:X); auto. exact (pfstrx _ _ _ _ _ _ H1). Qed. Lemma part_function_recip_pred_wd : pred_wd X R. Proof. red in |- *; intros x y H H0. elim H; intros H1 H2; split. apply (dom_wd X G x y H1 H0). intro H3; astepl (G x H1). auto. Qed. Definition Frecip := Build_PartFunct X _ part_function_recip_pred_wd (fun x Hx => [1][/] _[//]Ext2R x Hx) part_function_recip_strext. End Part_Function_Recip. Section Part_Function_Div. (** For division things work out almost in the same way. *) Let R := Conj P (extend Q (fun x Hx => G x Hx [#] [0])). Let Ext2R := ext2 (S:=X) (P:=Q) (R:=fun x Hx => G x Hx [#] [0]). Lemma part_function_div_strext : forall x y Hx Hy, (F x (prj1 X _ _ _ Hx) [/] _[//]Ext2R x (prj2 X _ _ _ Hx)) [#] (F y (prj1 X _ _ _ Hy) [/] _[//]Ext2R y (prj2 X _ _ _ Hy)) -> x [#] y. Proof. intros x y Hx Hy H. elim (div_strext _ _ _ _ _ _ _ H); intro H1; exact (pfstrx _ _ _ _ _ _ H1). Qed. Lemma part_function_div_pred_wd : pred_wd X R. Proof. red in |- *; intros x y H H0. elim H; intros H1 H2; split. apply (dom_wd X F x y H1 H0). clear H1. elim H2; intros H1 H3; split. apply (dom_wd X G x y H1 H0). intro H4; astepl (G x H1). auto. Qed. Definition Fdiv := Build_PartFunct X _ part_function_div_pred_wd (fun x Hx => F x (Prj1 Hx) [/] _[//]Ext2R x (Prj2 Hx)) part_function_div_strext. End Part_Function_Div. (** %\begin{convention}% Let [R:X->CProp]. %\end{convention}% *) Variable R:X -> CProp. Lemma included_FRecip : included R Q -> (forall x, R x -> forall Hx, G x Hx [#] [0]) -> included R (Dom Frecip). Proof. intros H H0. simpl in |- *. unfold extend in |- *. split. apply H; assumption. intros; apply H0; assumption. Qed. Lemma included_FRecip' : included R (Dom Frecip) -> included R Q. Proof. intro H; simpl in H; eapply included_extend; apply H. Qed. Lemma included_FDiv : included R P -> included R Q -> (forall x, R x -> forall Hx, G x Hx [#] [0]) -> included R (Dom Fdiv). Proof. intros HP HQ Hx. simpl in |- *. apply included_conj. assumption. unfold extend in |- *. split. apply HQ; assumption. intros; apply Hx; assumption. Qed. Lemma included_FDiv' : included R (Dom Fdiv) -> included R P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. Lemma included_FDiv'' : included R (Dom Fdiv) -> included R Q. intro H; simpl in H; eapply included_extend; eapply included_conj_rht; apply H. Qed. End CField_Ops. Arguments Frecip [X]. Notation "{1/} x" := (Frecip x) (at level 4, right associativity). Arguments Fdiv [X]. Infix "{/}" := Fdiv (at level 41, no associativity). #[global] Hint Resolve included_FRecip included_FDiv : included. #[global] Hint Immediate included_FRecip' included_FDiv' included_FDiv'' : included. corn-8.20.0/algebra/CGroups.v000066400000000000000000000345221473720167500157320ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Cezary Kaliszyk * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [-] %\ensuremath-% #−# *) (** printing [--] %\ensuremath-% #−# *) (** printing {-} %\ensuremath-% #−# *) (** printing {--} %\ensuremath-% #−# *) Require Import CoRN.tactics.CornTac. Require Export CoRN.algebra.CMonoids. (* Begin_SpecReals *) (** * Groups ** Definition of the notion of Group *) Definition is_CGroup (G : CMonoid) (inv : CSetoid_un_op G) := forall x, is_inverse csg_op [0] x (inv x). Record CGroup : Type := {cg_crr : CMonoid; cg_inv : CSetoid_un_op cg_crr; cg_proof : is_CGroup cg_crr cg_inv}. Module Export coercions. Coercion cg_crr : CGroup >-> CMonoid. End coercions. (* End_SpecReals *) (* Begin_SpecReals *) Arguments cg_inv {c}. Notation "[--] x" := (cg_inv x) (at level 4, right associativity). Definition cg_minus (G : CGroup) (x y : G) := x[+] [--]y. (** %\begin{nameconvention}% In the names of lemmas, we will denote [[--] ] with [inv], and [ [-] ] with [minus]. %\end{nameconvention}% *) Arguments cg_minus [G]. Infix "[-]" := cg_minus (at level 50, left associativity). (* End_SpecReals *) (** ** Group axioms %\begin{convention}% Let [G] be a group. %\end{convention}% *) Section CGroup_axioms. Variable G : CGroup. Lemma cg_inverse : forall x : G, is_inverse csg_op [0] x [--] x. Proof cg_proof G. End CGroup_axioms. (** ** Group basics General properties of groups. %\begin{convention}% Let [G] be a group. %\end{convention}% *) Section CGroup_basics. Variable G : CGroup. Lemma cg_rht_inv_unfolded : forall x : G, x[+] [--] x [=] [0]. Proof. intro x; elim (cg_inverse G x); auto. Qed. Lemma cg_lft_inv_unfolded : forall x : G, [--] x[+]x [=] [0]. Proof. intro x; elim (cg_inverse G x); auto. Qed. Lemma cg_minus_correct : forall x : G, x [-] x [=] [0]. Proof. intro x. unfold cg_minus in |- *. apply cg_rht_inv_unfolded. Qed. Hint Resolve cg_rht_inv_unfolded cg_lft_inv_unfolded cg_minus_correct: algebra. Lemma cg_inverse' : forall x : G, is_inverse csg_op [0] [--] x x. Proof. intro x. split; algebra. Qed. (* Hints for Auto *) Lemma cg_minus_unfolded : forall x y : G, x [-] y [=] x[+] [--] y. Proof. algebra. Qed. Hint Resolve cg_minus_unfolded: algebra. Lemma cg_minus_wd : forall x x' y y' : G, x [=] x' -> y [=] y' -> x [-] y [=] x' [-] y'. Proof. intros x x' y y' H H0. unfold cg_minus in |- *. Step_final (x[+] [--] y'). Qed. Hint Resolve cg_minus_wd: algebra_c. Lemma cg_minus_strext : forall x x' y y' : G, x [-] y [#] x' [-] y' -> x [#] x' or y [#] y'. Proof. intros x x' y y' H. cut (x [#] x' or [--] y [#] [--] y'). intro H0. elim H0. left; trivial. intro H1. right; exact (cs_un_op_strext G cg_inv y y' H1). apply bin_op_strext_unfolded with (csg_op (c:=G)). trivial. Qed. Definition cg_minus_is_csetoid_bin_op : CSetoid_bin_op G := Build_CSetoid_bin_op G (cg_minus (G:=G)) cg_minus_strext. Lemma grp_inv_assoc : forall x y : G, x[+]y [-] y [=] x. Proof. intros x y; unfold cg_minus in |- *. astepl (x[+](y[+] [--] y)). Step_final (x[+][0]). Qed. Hint Resolve grp_inv_assoc: algebra. Lemma cg_inv_unique : forall x y : G, x[+]y [=] [0] -> y [=] [--] x. Proof. intros x y H. astepl ([0][+]y). astepl ([--] x[+]x[+]y). astepl ([--] x[+](x[+]y)). Step_final ([--] x[+][0]). Qed. Lemma cg_inv_inv : forall x : G, [--] [--] x [=] x. Proof. intro x. astepl ([0][+] [--] [--] x). astepl (x[+] [--] x[+] [--] [--] x). astepl (x[+]([--] x[+] [--] [--] x)). Step_final (x[+][0]). Qed. Hint Resolve cg_inv_inv: algebra. Lemma cg_cancel_lft : forall x y z : G, x[+]y [=] x[+]z -> y [=] z. Proof. intros x y z H. astepl ([0][+]y). astepl ([--] x[+]x[+]y). astepl ([--] x[+](x[+]y)). astepl ([--] x[+](x[+]z)). astepl ([--] x[+]x[+]z). Step_final ([0][+]z). Qed. Lemma cg_cancel_rht : forall x y z : G, y[+]x [=] z[+]x -> y [=] z. Proof. intros x y z H. astepl (y[+][0]). astepl (y[+](x[+] [--] x)). astepl (y[+]x[+] [--] x). astepl (z[+]x[+] [--] x). astepl (z[+](x[+] [--] x)). Step_final (z[+][0]). Qed. Lemma cg_inv_unique' : forall x y : G, x[+]y [=] [0] -> x [=] [--] y. Proof. intros x y H. astepl (x[+][0]). astepl (x[+](y[+] [--] y)). astepl (x[+]y[+] [--] y). Step_final ([0][+] [--] y). Qed. Lemma cg_inv_unique_2 : forall x y : G, x [-] y [=] [0] -> x [=] y. Proof. intros x y H. generalize (cg_inv_unique _ _ H); intro H0. astepl ([--] [--] x). Step_final ([--] [--] y). Qed. Lemma cg_zero_inv : [--] ([0]:G) [=] [0]. Proof. apply eq_symmetric_unfolded; apply cg_inv_unique; algebra. Qed. Hint Resolve cg_zero_inv: algebra. Lemma cg_inv_zero : forall x : G, x [-] [0] [=] x. Proof. intro x. unfold cg_minus in |- *. Step_final (x[+][0]). Qed. Lemma cg_inv_op : forall x y : G, [--] (x[+]y) [=] [--] y[+] [--] x. Proof. intros x y. apply (eq_symmetric G). apply cg_inv_unique. astepl (x[+]y[+] [--] y[+] [--] x). astepl (x[+](y[+] [--] y)[+] [--] x). astepl (x[+][0][+] [--] x). Step_final (x[+] [--] x). Qed. (** Useful for interactive proof development. *) Lemma x_minus_x : forall x y : G, x [=] y -> x [-] y [=] [0]. Proof. intros x y H; Step_final (x [-] x). Qed. (** ** Sub-groups %\begin{convention}% Let [P] be a predicate on [G] containing [Zero] and closed under [[+]] and [[--] ]. %\end{convention}% *) Section SubCGroups. Variable P : G -> CProp. Variable Punit : P [0]. Variable op_pres_P : bin_op_pres_pred _ P csg_op. Variable inv_pres_P : un_op_pres_pred _ P cg_inv. Let subcrr : CMonoid := Build_SubCMonoid _ _ Punit op_pres_P. Let subinv : CSetoid_un_op subcrr := Build_SubCSetoid_un_op _ _ _ inv_pres_P. Lemma isgrp_scrr : is_CGroup subcrr subinv. Proof. red in |- *. intro x. case x. intros. split; simpl in |- *; algebra. Qed. Definition Build_SubCGroup : CGroup := Build_CGroup subcrr _ isgrp_scrr. End SubCGroups. End CGroup_basics. Add Parametric Morphism c : (@cg_minus c) with signature (@cs_eq (cg_crr c)) ==> (@cs_eq c) ==> (@cs_eq c) as cg_minus_wd_morph. Proof. intros. apply cg_minus_wd; assumption. Qed. #[global] Hint Resolve cg_rht_inv_unfolded cg_lft_inv_unfolded: algebra. #[global] Hint Resolve cg_inv_inv cg_minus_correct cg_zero_inv cg_inv_zero: algebra. #[global] Hint Resolve cg_minus_unfolded grp_inv_assoc cg_inv_op: algebra. #[global] Hint Resolve cg_minus_wd: algebra_c. (** ** Associative properties of groups %\begin{convention}% Let [G] be a group. %\end{convention}% *) Section Assoc_properties. Variable G : CGroup. Lemma assoc_2 : forall x y z : G, x[+] (y [-] z) [=] x[+]y [-] z. Proof. intros x y z; unfold cg_minus in |- *; algebra. Qed. Lemma zero_minus : forall x : G, [0] [-] x [=] [--] x. Proof. intro x. unfold cg_minus in |- *. algebra. Qed. Lemma cg_cancel_mixed : forall x y : G, x [=] x [-] y[+]y. Proof. intros x y. unfold cg_minus in |- *. astepr (x[+]([--] y[+]y)). Step_final (x[+][0]). Qed. Lemma plus_resp_eq : forall x y z : G, y [=] z -> x[+]y [=] x[+]z. Proof. algebra. Qed. End Assoc_properties. #[global] Hint Resolve assoc_2 Nat.add_sub zero_minus cg_cancel_mixed plus_resp_eq: algebra. (** ** Apartness in Constructive Groups Specific properties of apartness. %\begin{convention}% Let [G] be a group. %\end{convention}% *) Section cgroups_apartness. Variable G : CGroup. Lemma cg_add_ap_zero : forall x y : G, x[+]y [#] [0] -> x [#] [0] or y [#] [0]. Proof. intros x y H. apply (cs_bin_op_strext _ csg_op x [0] y [0]). astepr ([0]:G). auto. Qed. Lemma op_rht_resp_ap : forall x y z : G, x [#] y -> x[+]z [#] y[+]z. Proof. intros x y z H. cut (x[+]z [-] z [#] y[+]z [-] z). intros h. case (cs_bin_op_strext _ _ _ _ _ _ h). auto. intro contra; elim (ap_irreflexive _ _ contra). astepl x; astepr y. auto. Qed. Lemma cg_ap_cancel_rht : forall x y z : G, x[+]z [#] y[+]z -> x [#] y. Proof. intros x y z H. apply ap_wdr_unfolded with (y[+]z [-] z). apply ap_wdl_unfolded with (x[+]z [-] z). apply (op_rht_resp_ap _ _ [--] z H). astepr (x[+][0]). Step_final (x[+](z [-] z)). astepr (y[+][0]). Step_final (y[+](z [-] z)). Qed. Lemma plus_cancel_ap_rht : forall x y z : G, x[+]z [#] y[+]z -> x [#] y. Proof cg_ap_cancel_rht. Lemma minus_ap_zero : forall x y : G, x [#] y -> x [-] y [#] [0]. Proof. intros x y H. astepr (y [-] y). unfold cg_minus in |- *. apply op_rht_resp_ap; assumption. Qed. Lemma zero_minus_apart : forall x y : G, x [-] y [#] [0] -> x [#] y. Proof. unfold cg_minus in |- *. intros x y H. cut (x[+] [--] y [#] y[+] [--] y). intros h. apply (cg_ap_cancel_rht _ _ _ h). astepr ([0]:G). auto. Qed. Lemma inv_resp_ap_zero : forall x : G, x [#] [0] -> [--] x [#] [0]. Proof. intros x H. astepl ([0][+] [--] x). astepl ([0] [-] x). apply minus_ap_zero. apply (ap_symmetric G). auto. Qed. Lemma inv_resp_ap : forall x y : G, x [#] y -> [--] x [#] [--] y. Proof. intros x y H. apply (csf_strext _ _ (cg_inv (c:=G))). astepl x. astepr y. auto. Qed. Lemma minus_resp_ap_rht : forall x y z : G, x [#] y -> x [-] z [#] y [-] z. Proof. intros x y z H. unfold cg_minus in |- *. apply op_rht_resp_ap. assumption. Qed. Lemma minus_resp_ap_lft : forall x y z : G, x [#] y -> z [-] x [#] z [-] y. Proof. intros x y z H. astepl ([--] (x [-] z)). 2: unfold cg_minus in |- *; Step_final ([--] [--] z[+] [--] x). astepr ([--] (y [-] z)). 2: unfold cg_minus in |- *; Step_final ([--] [--] z[+] [--] y). apply inv_resp_ap. apply minus_resp_ap_rht. auto. Qed. Lemma minus_cancel_ap_rht : forall x y z : G, x [-] z [#] y [-] z -> x [#] y. Proof. unfold cg_minus in |- *. intros x y z H. exact (plus_cancel_ap_rht _ _ _ H). Qed. End cgroups_apartness. #[global] Hint Resolve op_rht_resp_ap: algebra. #[global] Hint Resolve minus_ap_zero zero_minus_apart inv_resp_ap_zero: algebra. Section CGroup_Ops. (** ** The Group of bijective Setoid functions *) Definition PS_Inv (A : CSetoid) : PS_as_CMonoid A -> PS_as_CMonoid A. Proof. simpl in |- *. intros f. elim f. intros fo prfo. set (H0 := Inv fo prfo) in *. apply Build_subcsetoid_crr with H0. unfold H0 in |- *. apply Inv_bij. Defined. Definition Inv_as_un_op (A : CSetoid) : CSetoid_un_op (PS_as_CMonoid A). Proof. unfold CSetoid_un_op in |- *. apply Build_CSetoid_fun with (PS_Inv A). unfold fun_strext in |- *. intros x y. case x. case y. simpl in |- *. intros f H g H0. unfold ap_fun in |- *. intro H1. elim H1. clear H1. intros a H1. exists (Inv g H0 a). astepl a. 2: simpl in |- *. 2: apply eq_symmetric_unfolded. 2: apply inv1. unfold bijective in H. elim H. unfold injective in |- *. intros H2 H3. astepl (f (Inv f H a)). apply H2. apply ap_symmetric_unfolded. exact H1. simpl in |- *. apply inv1. Defined. Lemma PS_is_CGroup : forall A : CSetoid, is_CGroup (PS_as_CMonoid A) (Inv_as_un_op A). Proof. intro A. unfold is_CGroup in |- *. intro x. unfold is_inverse in |- *. simpl in |- *. split. case x. simpl in |- *. intros f H. unfold eq_fun in |- *. intro a. unfold comp in |- *. simpl in |- *. apply inv2. case x. simpl in |- *. intros f H. unfold eq_fun in |- *. intro a. unfold comp in |- *. simpl in |- *. apply inv1. Qed. Definition PS_as_CGroup (A : CSetoid) := Build_CGroup (PS_as_CMonoid A) (Inv_as_un_op A) (PS_is_CGroup A). (** ** Functional operations As before, we lift our group operations to the function space of the group. %\begin{convention}% Let [G] be a group and [F,F':(PartFunct G)] with domains given respectively by [P] and [Q]. %\end{convention}% *) Variable G : CGroup. Variables F F' : PartFunct G. (* begin hide *) Let P := Dom F. Let Q := Dom F'. (* end hide *) Section Part_Function_Inv. Lemma part_function_inv_strext : forall x y (Hx : P x) (Hy : P y), [--] (F x Hx) [#] [--] (F y Hy) -> x [#] y. Proof. intros x y Hx Hy H. apply pfstrx with F Hx Hy. apply un_op_strext_unfolded with (cg_inv (c:=G)); assumption. Qed. Definition Finv := Build_PartFunct _ _ (dom_wd _ F) (fun x Hx => [--] (F x Hx)) part_function_inv_strext. End Part_Function_Inv. Section Part_Function_Minus. Lemma part_function_minus_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y), F x (Prj1 Hx) [-] F' x (Prj2 Hx) [#] F y (Prj1 Hy) [-] F' y (Prj2 Hy) -> x [#] y. Proof. intros x y Hx Hy H. cut (F x (Prj1 Hx) [#] F y (Prj1 Hy) or F' x (Prj2 Hx) [#] F' y (Prj2 Hy)). intro H0. elim H0; intro H1; exact (pfstrx _ _ _ _ _ _ H1). apply cg_minus_strext; auto. Qed. Definition Fminus := Build_PartFunct G _ (conj_wd (dom_wd _ F) (dom_wd _ F')) (fun x Hx => F x (Prj1 Hx) [-] F' x (Prj2 Hx)) part_function_minus_strext. End Part_Function_Minus. (** %\begin{convention}% Let [R:G->CProp]. %\end{convention}% *) Variable R:G -> CProp. Lemma included_FInv : included R P -> included R (Dom Finv). Proof. intro; simpl in |- *; assumption. Qed. Lemma included_FInv' : included R (Dom Finv) -> included R P. Proof. intro; simpl in |- *; assumption. Qed. Lemma included_FMinus : included R P -> included R Q -> included R (Dom Fminus). Proof. intros; simpl in |- *; apply included_conj; assumption. Qed. Lemma included_FMinus' : included R (Dom Fminus) -> included R P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. Lemma included_FMinus'' : included R (Dom Fminus) -> included R Q. Proof. intro H; simpl in H; eapply included_conj_rht; apply H. Qed. End CGroup_Ops. Arguments Finv [G]. Notation "{--} x" := (Finv x) (at level 4, right associativity). Arguments Fminus [G]. Infix "{-}" := Fminus (at level 50, left associativity). #[global] Hint Resolve included_FInv included_FMinus : included. #[global] Hint Immediate included_FInv' included_FMinus' included_FMinus'' : included. corn-8.20.0/algebra/CMonoids.v000066400000000000000000000546241473720167500160700ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [0] %\ensuremath{\mathbf0}% #0# *) From Coq Require Export Euclid. Require Export CoRN.model.Zmod.Cmod. Require Export CoRN.algebra.CSemiGroups. Require Export CoRN.tactics.csetoid_rewrite. Require Export CoRN.model.structures.Nsec. Require Import CoRN.util.SetoidPermutation Coq.Setoids.Setoid Coq.Classes.Morphisms. (* Begin_SpecReals *) (** * Monoids %\label{section:monoids}% ** Definition of monoids *) Record is_CMonoid (M : CSemiGroup) (Zero : M) : Prop := {runit : is_rht_unit (csg_op (c:=M)) Zero; lunit : is_lft_unit (csg_op (c:=M)) Zero}. Record CMonoid : Type := {cm_crr :> CSemiGroup; cm_unit : cm_crr; cm_proof : is_CMonoid cm_crr cm_unit}. (** %\begin{nameconvention}% In the names of lemmas, we will denote [[0]] with [zero]. We denote [ [#] [0]] in the names of lemmas by [ap_zero] (and not, e.g.%\% [nonzero]). %\end{nameconvention}% *) (* Begin_SpecReals *) (** The predicate "non-zero" is defined. In lemmas we will continue to write [x [#] [0]], rather than [(nonZeroP x)], but the predicate is useful for some high-level definitions, e.g. for the setoid of non-zeros. *) Notation "[0]" := (cm_unit _). Definition nonZeroP (M : CMonoid) (x : M) : CProp := x [#] [0]. (* End_SpecReals *) Arguments nonZeroP [M]. (** ** Monoid axioms %\begin{convention}% Let [M] be a monoid. %\end{convention}% *) Section CMonoid_axioms. Variable M : CMonoid. Lemma CMonoid_is_CMonoid : is_CMonoid M (cm_unit M). Proof. elim M; auto. Qed. Lemma cm_rht_unit : is_rht_unit csg_op ([0]:M). Proof. elim CMonoid_is_CMonoid; auto. Qed. Lemma cm_lft_unit : is_lft_unit csg_op ([0]:M). Proof. elim CMonoid_is_CMonoid; auto. Qed. End CMonoid_axioms. (** ** Monoid basics %\begin{convention}% Let [M] be a monoid. %\end{convention}% *) Section CMonoid_basics. Variable M : CMonoid. Lemma cm_rht_unit_unfolded : forall x : M, x[+][0] [=] x. Proof cm_rht_unit M. Lemma cm_lft_unit_unfolded : forall x : M, [0][+]x [=] x. Proof cm_lft_unit M. Hint Resolve cm_rht_unit_unfolded cm_lft_unit_unfolded: algebra. Lemma cm_unit_unique_lft : forall x : M, is_lft_unit csg_op x -> x [=] [0]. Proof. intros x h. red in h. Step_final (x[+][0]). Qed. Lemma cm_unit_unique_rht : forall x : M, is_rht_unit csg_op x -> x [=] [0]. Proof. intros x h. red in h. Step_final ([0][+]x). Qed. (* Begin_SpecReals *) (** The proof component of the monoid is irrelevant. *) Lemma is_CMonoid_proof_irr : forall (S:CSetoid) (Zero:S) (plus : CSetoid_bin_op S) (p q : associative plus), is_CMonoid (Build_CSemiGroup S plus p) Zero -> is_CMonoid (Build_CSemiGroup S plus q) Zero. Proof. intros S one mult p q H. elim H; intros runit0 lunit0. simpl in runit0. simpl in lunit0. apply Build_is_CMonoid; simpl in |- *; assumption. Qed. (* End_SpecReals *) (** ** Submonoids %\begin{convention}% Let [P] a predicate on [M] containing [[0]] and closed under [[+]]. %\end{convention}% *) Section SubCMonoids. Variable P : M -> CProp. Variable Punit : P [0]. Variable op_pres_P : bin_op_pres_pred _ P csg_op. Let subcrr : CSemiGroup := Build_SubCSemiGroup _ _ op_pres_P. Lemma ismon_scrr : is_CMonoid subcrr (Build_subcsetoid_crr _ _ _ Punit). Proof. split; red in |- *. (* right unit *) intro x. case x. intros scs_elem scs_prf. apply (cm_rht_unit_unfolded scs_elem). (* left unit *) intro x. case x. intros scs_elem scs_prf. apply (cm_lft_unit_unfolded scs_elem). Qed. Definition Build_SubCMonoid : CMonoid := Build_CMonoid subcrr _ ismon_scrr. End SubCMonoids. End CMonoid_basics. Section Th13. (** ** Morphism, isomorphism and automorphism of Monoids %\begin{convention}% Let [M1 M2 M M':CMonoid]. %\end{convention}% *) Variable M1:CMonoid. Variable M2:CMonoid. Definition morphism (f:(CSetoid_fun M1 M2)):CProp:= (f ([0])[=][0] /\ forall (a b:M1), (f (a[+]b))[=] (f a)[+](f b)). Definition isomorphism (f:(CSetoid_fun M1 M2)):CProp:= (morphism f) and (bijective f). End Th13. Section p71E2b1. Definition isomorphic (M:CMonoid)(M':CMonoid): CProp:= {f:(CSetoid_fun M M')|(isomorphism M M' f)}. End p71E2b1. Section Th14. (** %\begin{convention}% Let [f:(CSetoid_fun M1 M2)] and [isof: (isomorphism M1 M2 f)]. %\end{convention}% *) Variable M1: CMonoid. Variable M2: CMonoid. Variable f: (CSetoid_fun M1 M2). Variable isof: (isomorphism M1 M2 f). Lemma iso_imp_bij: (bijective f). Proof. unfold isomorphism in isof. intuition. Qed. Lemma iso_inv: (isomorphism M2 M1 (Inv f (iso_imp_bij))). Proof. unfold isomorphism. split. unfold morphism. split. unfold isomorphism in isof. unfold morphism in isof. elim isof. intros H0 H1. elim H0. clear H0. intros H3 H4. astepl ((Inv f iso_imp_bij) (f [0])). unfold Inv. simpl. apply inv2. intros a b. elim isof. intros H0 H1. destruct H1 as [H1 H2]. destruct (H2 a) as [a' fa'a]. destruct (H2 b) as [b' fb'b]. unfold morphism in H0. astepl ((Inv f iso_imp_bij) (f a' [+] f b')). astepl ((Inv f iso_imp_bij) ( f ( a'[+] b'))). set (H3:= (inv2 M1 M2 f iso_imp_bij (a'[+]b'))). astepl (a'[+]b'). astepr (a'[+] b'). intuition. set (H4:=(inv2 M1 M2 f iso_imp_bij a')). apply csbf_wd. astepr (Inv f iso_imp_bij (f a')); intuition. astepr (Inv f iso_imp_bij (f b')). set (H5:= (inv2 M1 M2 f iso_imp_bij b')); intuition. intuition. apply Inv_bij. Qed. End Th14. Section p71R2. Variable M:CMonoid. Definition automorphism:= (isomorphism M M). End p71R2. Section p71E1. (** ** Power in a monoid %\begin{convention}% Let [M:CMonoid] and [c:M]. %\end{convention}% *) Variable M:CMonoid. Variable c:M. Fixpoint power_CMonoid (m:M)(n:nat){struct n}:M:= match n with |0 => (cm_unit M) |(S p) => m [+] (power_CMonoid m p) end. End p71E1. Arguments power_CMonoid [M]. Lemma power_plus:forall (M:CMonoid)(a:M)(m n:nat), (power_CMonoid a (m+n))[=] (power_CMonoid a m)[+](power_CMonoid a n). Proof. intros M a m n. induction m. simpl. apply eq_symmetric. apply cm_lft_unit. simpl. astepl (csbf_fun M M M (csg_op (c:=M)) a ((csbf_fun M M M (csg_op (c:=M)) (power_CMonoid a m) (power_CMonoid a n)))). algebra. Qed. (** ** Cyclicity *) Definition is_generator (M:CMonoid)(u:M):CProp:= forall (m:M),{n:nat | (power_CMonoid u n)[=]m}. Definition cyclic : CMonoid -> CProp := fun M => {u:M | (forall (m:M),{n:nat | (power_CMonoid u n)[=]m}):CProp}. Section gen_cyc. Lemma power_k:forall (M:CMonoid)(u:M)(k l s:nat),(is_generator M u)-> ((kl0 and (k0 (power_CMonoid u k0 [#] power_CMonoid u l0)))):CProp)-> (power_CMonoid u k)[=](power_CMonoid u (k+(s*(l-k)))). Proof. intros M u k l s H. unfold is_generator in H. intros H0. induction s. simpl. replace (k+0) with k. intuition. intuition. simpl. replace (k+((l-k)+s*(l-k))) with (l + s*(l-k)). 2:intuition. set (H1:= (power_plus M u l (s*(l-k)))). astepr (csbf_fun (csg_crr (cm_crr M)) (csg_crr (cm_crr M)) (csg_crr (cm_crr M)) (csg_op (c:=cm_crr M)) (power_CMonoid u l) (power_CMonoid u (s * (l - k)))). elim H0. clear H0. intros H0 H0'. elim H0'. clear H0'. intros H0' H0''. cut ( power_CMonoid u l[=]power_CMonoid u k). intro H4. rewrite -> H4. 2: now apply eq_symmetric. set (H5:=(power_plus M u k (s*(l-k)))). cut (csbf_fun M M M (csg_op (c:=M)) (power_CMonoid u k) (power_CMonoid u (s * (l - k)))[=]power_CMonoid u (k + s * (l - k))). intros H6. now rewrite -> H6. now symmetry. Qed. Lemma power_k_n:forall (M:CMonoid)(u:M)(k l n :nat) (H2:((Z_of_nat (l-k)>0)%Z)),(is_generator M u)->(k ((k l0 and (k0 (power_CMonoid u k0 [#] power_CMonoid u l0)))):CProp)-> (power_CMonoid u n)[=](power_CMonoid u (k+(mod_nat (n-k) (l-k) H2))). Proof. intros M u k l n H2 H H15. set (H13:=(power_k M u k l)). intros H4. set (H6:=(Z_div_mod_eq_full (n-k)(l-k))). cut (((n - k) mod (l - k))= (n-k)%Z -((l - k) * ((n - k) / (l - k))))%Z. 2:intuition. set (H7:=(mod_nat_correct (n-k) (l-k) H2)). intro H8. cut {s:nat | (mod_nat (n-k)(l-k) H2)=(n-k)-s*(l-k) and s*(l-k)<=(n-k)}. intro H9. elim H9. clear H9. intros s H9. elim H9. clear H9. intros H9 H9'. rewrite H9. replace (power_CMonoid u n) with (power_CMonoid u ((k+s*(l-k))+((n-k)-s*(l-k)))). 2: (replace ((k + s * (l - k))+((n - k) - s * (l - k))) with n). 2:reflexivity. rewrite -> (power_plus M u (k+(s*(l-k))) ((n-k)-s*(l-k))). rewrite -> (power_plus M u k (n-k-s*(l-k))). setoid_replace (power_CMonoid u (k + s * (l - k))) with (power_CMonoid u k). now reflexivity. unfold canonical_names.equiv. now intuition. cut (n=k+(n-k)). intro H10. cut (n=((k+(n-k))+(s*(l-k)-s*(l-k)))). intro H11. cut ((k+(n-k))+(s*(l-k)-s*(l-k)) = (k + s * (l - k) + (n - k - s * (l - k)))). intro H12. now rewrite<- H11 in H12. apply minus4. split. now intuition. exact H9'. rewrite<- H10. cut ((s*(l-k)-s*(l-k))=0). intro H11. rewrite H11. now intuition. now intuition. cut (n=n+(k-k)). intro H10. cut (n+(k-k)=k+(n-k)). intro H11. now rewrite<- H10 in H11. apply minus3. split; now intuition. cut ((k-k)=0). intro H10. now rewrite H10. now intuition. simpl. cut (l-k>0). intro H9. set (H10:=(quotient (l-k) H9 (n-k))). elim H10. clear H10. intros q H10. exists q. split. elim H10. clear H10. intros r H10'. elim H10'. clear H10'. intros H10' H10''. 3:intuition. cut ((n-k)= q*(l-k)+ (mod_nat (n-k)(l-k) H2)). intro H11. intuition. cut (r= (mod_nat (n-k)(l-k)H2)). intro H11. now rewrite<- H11. simpl. cut ((Z_of_nat r)=(mod_nat (n - k) (l - k) H2)). intro H11. intuition. rewrite<- H7. apply nat_Z_div with (n-k) q (l-k) ((Z_of_nat n - Z_of_nat k) / (Z_of_nat l - Z_of_nat k))%Z. exact H10'. intuition. cut (k<=l). intro H11. set (H12:=(inj_minus1 l k H11)). rewrite H12. cut (k<=n). intro H14. set (H16:=(inj_minus1 n k H14)). rewrite H16. exact H6. intuition. intuition. set (H17:=(Z_mod_lt (Z_of_nat (n-k)) (Z_of_nat (l-k)))). intuition. elim H10. clear H10. intros r H10. elim H10. clear H10. intros H10 H10'. intuition. Qed. Lemma cyc_imp_comm: forall (M:CMonoid)(H:(cyclic M)), (commutes (@csg_op M)). Proof. intros M H. unfold commutes. intros x y. unfold cyclic in H. elim H. clear H. intros c0 H. elim (H x). intros nx Hx. elim (H y). intros ny Hy. rewrite <- Hx. rewrite <- Hy. rewrite <- (power_plus M c0 nx ny). replace (nx+ny) with (ny+nx). rewrite -> (power_plus M c0 ny nx). now apply eq_reflexive. intuition. Qed. Lemma weakly_inj1: forall (M:CMonoid)(u:M)(k l a b:nat),(is_generator M u)->(a(b (kl0 and (k0 (power_CMonoid u k0 [#] power_CMonoid u l0)))-> (power_CMonoid u a)[=](power_CMonoid u b) -> a=b. Proof. intros M u k l a b H H0 H1. unfold is_generator in H. intros H3 H4. elim (eq_nat_dec a b). tauto. intro H5. elim (not_or a b H5). clear H5. intro H5. cut False. intuition. set (H6:= (eq_imp_not_ap M (power_CMonoid u a)(power_CMonoid u b) H4)). unfold Not in H6. cut (k<>a+(l-b) or k=a+(l-b)). intro orex. elim orex. clear orex. intro orex. cut ((power_CMonoid u a[#]power_CMonoid u b) or (power_CMonoid u (l-b)[#]power_CMonoid u (l-b))). intro H7. elim H7. tauto. clear H7. intro H7. set (H8:= (ap_irreflexive_unfolded M (power_CMonoid u (l-b)) H7)). intuition. apply bin_op_strext_unfolded with (@csg_op M). csetoid_rewrite_rev (power_plus M u b (l-b)). csetoid_rewrite_rev (power_plus M u a (l-b)). elim H3. clear H3. intros H3 H7. elim H7. clear H7. intros H7 H8. replace (b+(l-b)) with l. csetoid_rewrite_rev H7. apply: ap_symmetric. apply H8. split. intuition. right. intuition. intuition. clear orex. intro orex. intuition. intuition. clear H5. intro H5. cut False. intuition. cut (power_CMonoid (M:=M) u b[=]power_CMonoid (M:=M) u a). intro H4'. set (H6:= (eq_imp_not_ap M (power_CMonoid u a)(power_CMonoid u b) H4)). set (H6':= (eq_imp_not_ap M (power_CMonoid u b)(power_CMonoid u a) H4')). unfold Not in H6. cut (k<>b+(l-a) or k=b+(l-a)). intro orex. elim orex. clear orex. intro orex. cut ((power_CMonoid u a[#]power_CMonoid u b) or (power_CMonoid u (l-a)[#]power_CMonoid u (l-a))). intro H7. elim H7. tauto. clear H7. intro H7. set (H8:= (ap_irreflexive_unfolded M (power_CMonoid u (l-a)) H7)). intuition. apply bin_op_strext_unfolded with (@csg_op M). csetoid_rewrite_rev (power_plus M u b (l-a)). csetoid_rewrite_rev (power_plus M u a (l-a)). elim H3. clear H3. intros H3 H7. elim H7. clear H7. intros H7 H8. replace (a+(l-a)) with l. csetoid_rewrite_rev H7. apply H8. split. intuition. right. intuition. intuition. clear orex. intro orex. intuition. intuition. intuition. Qed. (** %\begin{convention}% Let [M:CMonoid]. %\end{convention}% *) Variable M:CMonoid. Lemma generator_imp_cyclic: (forall (u:M), (is_generator M u)-> (cyclic M)):CProp. Proof. intros u H. unfold is_generator in H. exists u. exact H. Qed. End gen_cyc. (** ** Invertability *) Definition is_inverse S (op : CSetoid_bin_op S) Zero x x_inv : Prop := op x x_inv [=] Zero /\ op x_inv x [=] Zero. Arguments is_inverse [S]. Definition invertible (M:CMonoid): M -> CProp := fun m =>{inv: (CSetoid_un_op M) | (is_inverse csg_op (@cm_unit M) m (inv m))}. Section D9M. (** ** Direct Product %\begin{convention}% Let [M1 M2:CMonoid] %\end{convention}% *) Variable M1 M2: CMonoid. Lemma e1e2_is_rht_unit: (is_rht_unit (dprod_as_csb_fun M1 M2)(pairT (@cm_unit M1)(@cm_unit M2))). Proof. unfold is_rht_unit. intro x. case x. intros x1 x2. simpl. split. apply cm_rht_unit_unfolded. apply cm_rht_unit_unfolded. Qed. Lemma e1e2_is_lft_unit: (is_lft_unit (dprod_as_csb_fun M1 M2)(pairT (@cm_unit M1)(@cm_unit M2))). Proof. intro x. case x. intros x1 x2. simpl. split. apply cm_lft_unit_unfolded. apply cm_lft_unit_unfolded. Qed. Definition direct_product_is_CMonoid:= (Build_is_CMonoid (direct_product_as_CSemiGroup M1 M2) (pairT (@cm_unit M1)(@cm_unit M2)) e1e2_is_rht_unit e1e2_is_lft_unit). Definition direct_product_as_CMonoid := (Build_CMonoid (direct_product_as_CSemiGroup M1 M2) (pairT (@cm_unit M1)(@cm_unit M2)) direct_product_is_CMonoid). End D9M. Section p71E2b2. Variable M1:CMonoid. Variable M2:CMonoid. Let f: (direct_product_as_CMonoid M1 M2)-> (direct_product_as_CMonoid M2 M1). Proof. simpl. intro x. elim x. intros x1 x2. exact (pairT x2 x1). Defined. Lemma f_strext': (fun_strext f ). Proof. unfold fun_strext. simpl. intros x y. case x. intros x1 x2. case y. intros y1 y2. simpl. intuition. Qed. Definition f_as_CSetoid_fun_:= (Build_CSetoid_fun _ _ f f_strext'). Lemma isomorphic_PM1M2_PM2M1: (isomorphic (direct_product_as_CMonoid M1 M2) (direct_product_as_CMonoid M2 M1)):CProp. Proof. unfold isomorphic. simpl. exists f_as_CSetoid_fun_. unfold isomorphism. unfold morphism. simpl. split. split. intuition. intros a b. case a. intros a0 a1. case b. intros b0 b1. simpl. intuition. unfold bijective. split. unfold injective. simpl. intros a0 a1. elim a0. intros b0 b1. elim a1. intros c0 c1. simpl. intuition. unfold surjective. intro b. elim b. intros a0 a1. exists (pairT a1 a0). simpl. intuition. Qed. End p71E2b2. (** ** The Monoids of Setoid functions and bijective Setoid functions. *) Definition FS_id (A : CSetoid) : FS_as_CSetoid A A. Proof. unfold FS_as_CSetoid in |- *. simpl in |- *. exact (id_un_op A). Defined. Lemma id_is_rht_unit : forall A : CSetoid, is_rht_unit (comp_as_bin_op A) (FS_id A). Proof. unfold is_rht_unit in |- *. unfold comp_as_bin_op in |- *. unfold FS_id in |- *. simpl in |- *. unfold eq_fun in |- *. unfold id_un_op in |- *. simpl in |- *. intuition. Qed. Lemma id_is_lft_unit : forall A : CSetoid, is_lft_unit (comp_as_bin_op A) (FS_id A). Proof. unfold is_lft_unit in |- *. unfold comp_as_bin_op in |- *. unfold FS_id in |- *. simpl in |- *. unfold eq_fun in |- *. unfold id_un_op in |- *. simpl in |- *. intuition. Qed. Definition FS_is_CMonoid (A : CSetoid) := Build_is_CMonoid (FS_as_CSemiGroup A) (FS_id A) ( id_is_rht_unit A) (id_is_lft_unit A). Definition FS_as_CMonoid (A : CSetoid) := Build_CMonoid (FS_as_CSemiGroup A) (FS_id A) (FS_is_CMonoid A). Definition PS_as_CMonoid (A : CSetoid) := Build_SubCMonoid (FS_as_CMonoid A) (bijective (A:=A) (B:=A)) ( id_is_bij A) (comp_resp_bij A A A). (** ** The free Monoid *) Lemma is_unit_Astar_empty_word: forall (A:CSetoid), (is_unit (Astar_as_CSemiGroup A)(empty_word A)). Proof. intro A. unfold is_unit. simpl. intro a. split. apply eq_fm_reflexive. unfold empty_word. induction a. apply eq_fm_reflexive. simpl. intuition. Qed. Section Th12. (** %\begin{convention}% Let [A:CSetoid]. %\end{convention}% *) Variable A:CSetoid. Lemma nil_is_rht_unit: (is_rht_unit (app_as_csb_fun A) (empty_word A)). Proof. unfold is_rht_unit. simpl. intro x. induction x. simpl. intuition. simpl. intuition. Qed. Lemma nil_is_lft_unit: (is_lft_unit (app_as_csb_fun A) (empty_word A)). Proof. unfold is_lft_unit. simpl. intro x. induction x. simpl. intuition. simpl. intuition. Qed. Definition free_monoid_is_CMonoid: is_CMonoid (Astar_as_CSemiGroup A) (empty_word A):= (Build_is_CMonoid (Astar_as_CSemiGroup A) (empty_word A) nil_is_rht_unit nil_is_lft_unit). Definition free_monoid_as_CMonoid:CMonoid:= (Build_CMonoid (Astar_as_CSemiGroup A)(empty_word A) free_monoid_is_CMonoid). End Th12. (** ** The unit in the setoid of Setoid functions %\begin{convention}% Let [X:CSetoid]. %\end{convention}% *) Section p67R2. Variable X: CSetoid. Lemma is_unit_FS_id:(is_unit (FS_as_CSemiGroup X) (FS_id X)). Proof. unfold is_unit. intros a. set (H:= (id_is_rht_unit X a)). set (H0:= (id_is_lft_unit X a)). split. exact H0. exact H. Qed. End p67R2. Section Th11. (** ** Intersection The intersection of a collection of monoids is again a monoid. %\begin{convention}% Let [M:CMonoid], [I:type], [C:I->(M->CProp)], [Cunit: (C i [0])] and [op_pres_C:forall (i:I), (bin_op_pres_pred _ (C i) csg_op)]. %\end{convention}% *) Variable M:CMonoid. Variable I:Type. Variable C:I->(M->CProp). Variable Cunit: forall (i:I), (C i [0]). Variable op_pres_C: forall (i:I),(bin_op_pres_pred _ (C i) csg_op). Definition K : M -> CProp := (fun m => forall (i:I), (C i m)). Lemma op_pres_K: bin_op_pres_pred (cm_crr M) K (csg_op (c:=M)). Proof. unfold K. unfold bin_op_pres_pred. unfold bin_op_pres_pred in op_pres_C. intros x y Cx Cy i. apply op_pres_C. apply Cx. apply Cy. Qed. Definition K_is_Monoid :CMonoid := (Build_SubCMonoid M K Cunit op_pres_K). End Th11. Section Th15. (** The Monoid generated by a Subset %\begin{convention}% Let [M:CMonoid] and [D:M->CProp]. %\end{convention}% *) Context {M:CMonoid}. Fixpoint cm_Sum (l: list M) {struct l}: M := match l with |nil => [0] |cons a k => a [+] (cm_Sum k) end. Variable D : M -> CProp. Definition Dbrack : M -> CProp := fun m => {l: (list M)| (forall (a:M) , member a l -> (D a)) and (cm_Sum l)[=]m}. Lemma Dbrack_unit: (Dbrack [0]). Proof. unfold Dbrack. exists (@nil M). simpl. intuition. Qed. Lemma cm_Sum_app: forall (k l : (list M)), (cm_Sum (app k l))[=] (cm_Sum k)[+](cm_Sum l). Proof. intros k l. induction k. simpl. apply eq_symmetric. apply cm_lft_unit_unfolded. simpl. astepr (a [+] ( (cm_Sum k)[+](cm_Sum l))). apply csbf_wd_unfolded. intuition. exact IHk. Qed. Lemma cm_Sum_eq {A} (a: list A) (f g: A -> M): (forall x, f x [=] g x) -> cm_Sum (map f a) [=] cm_Sum (map g a). (* This is just a specialization of Proper-ness for cm_Sum which I'm not doing right now because I don't want to involve the list setoid (parameterized by the element setoid) right now. *) Proof with try reflexivity. intro E. induction a... simpl. rewrite E, IHa... Qed. Global Instance cm_Sum_Proper: commutes (@csg_op M) -> Proper (SetoidPermutation (@st_eq M) ==> @st_eq M) cm_Sum. Proof with auto; try reflexivity. intros E x y H. induction H; simpl... rewrite IHSetoidPermutation, H... rewrite plus_assoc_unfolded, plus_assoc_unfolded, (E _ y)... transitivity (cm_Sum l')... Qed. Lemma cm_Sum_units (a: list M): (forall x, In x a -> x [=] [0]) -> cm_Sum a [=] [0]. Proof with intuition. clear D. induction a. intuition. intros E. simpl. rewrite IHa... rewrite (E a)... apply cm_lft_unit_unfolded. Qed. Lemma op_pres_Dbrack : bin_op_pres_pred _ Dbrack csg_op. Proof. unfold bin_op_pres_pred. intros x y. unfold Dbrack. intros Hx Hy. elim Hx. clear Hx. intros lx Hx. elim Hy. clear Hy. intros ly Hy. exists (app lx ly). split. intro a. set (H:= (member_app M a ly lx)). elim H. intros H0 H1. intros H2. set (H3:= (H0 H2)). elim H3. (generalize Hx). intuition. (generalize Hy). intuition. elim Hx. clear Hx. intros Hx1 Hx2. astepr ((cm_Sum lx)[+] y). elim Hy. clear Hy. intros Hy1 Hy2. astepr ( (cm_Sum lx)[+](cm_Sum ly) ). apply cm_Sum_app. Qed. Definition Dbrack_as_CMonoid : CMonoid := (Build_SubCMonoid M Dbrack Dbrack_unit op_pres_Dbrack). End Th15. #[global] Hint Resolve cm_rht_unit_unfolded cm_lft_unit_unfolded: algebra. corn-8.20.0/algebra/COrdAbs.v000066400000000000000000000377551473720167500156400ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Cezary Kaliszyk * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.COrdFields2. (** ** Properties of [AbsSmall] *) (* Begin_SpecReals *) Definition AbsSmall (R : COrdField) (e x : R) : Prop := [--]e [<=] x /\ x [<=] e. Arguments AbsSmall [R]. (* End_SpecReals *) Section AbsSmall_properties. (** %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. Lemma AbsSmall_wdr : rel_wdr R (AbsSmall (R:=R)). Proof. unfold rel_wdr in |- *. unfold AbsSmall in |- *. intros. elim H; intros. split. astepr y. assumption. astepl y. assumption. Qed. Lemma AbsSmall_wdr_unfolded : forall x y z : R, AbsSmall x y -> y [=] z -> AbsSmall x z. Proof AbsSmall_wdr. Lemma AbsSmall_wdl : rel_wdl R (AbsSmall (R:=R)). Proof. unfold rel_wdl in |- *. unfold AbsSmall in |- *. intros. elim H; intros. split. astepl ([--]x). assumption. astepr x. assumption. Qed. Lemma AbsSmall_wdl_unfolded : forall x y z : R, AbsSmall x y -> x [=] z -> AbsSmall z y. Proof AbsSmall_wdl. Declare Left Step AbsSmall_wdl_unfolded. Declare Right Step AbsSmall_wdr_unfolded. (* begin hide *) Notation ZeroR := ([0]:R). (* end hide *) Lemma AbsSmall_leEq_trans : forall e1 e2 d : R, e1 [<=] e2 -> AbsSmall e1 d -> AbsSmall e2 d. Proof. unfold AbsSmall in |- *. intros. elim H0; intros. split. apply leEq_transitive with ([--]e1). apply inv_resp_leEq. assumption. assumption. apply leEq_transitive with e1. assumption. assumption. Qed. Lemma zero_AbsSmall : forall e : R, [0] [<=] e -> AbsSmall e [0]. Proof. intros. unfold AbsSmall in |- *. split. astepr ([--]ZeroR). apply inv_resp_leEq. assumption. assumption. Qed. Lemma AbsSmall_reflexive : forall (e : R), [0] [<=] e -> AbsSmall e e. Proof. intros. unfold AbsSmall. split. apply leEq_transitive with ([0]:R); auto. astepr ([--][0]:R). apply inv_resp_leEq. auto. apply leEq_reflexive. Qed. Lemma AbsSmall_trans : forall e1 e2 d : R, e1 [<] e2 -> AbsSmall e1 d -> AbsSmall e2 d. Proof. intros. apply AbsSmall_leEq_trans with e1. apply less_leEq. assumption. assumption. Qed. Lemma leEq_imp_AbsSmall : forall e d : R, [0] [<=] e -> e [<=] d -> AbsSmall d e. Proof. intros. unfold AbsSmall in |- *. split; try assumption. apply leEq_transitive with ZeroR; try assumption. astepr ([--]ZeroR). apply inv_resp_leEq. apply leEq_transitive with e; assumption. Qed. Lemma inv_resp_AbsSmall : forall x y : R, AbsSmall x y -> AbsSmall x [--]y. Proof. unfold AbsSmall in |- *. intros. elim H; intros. split. apply inv_resp_leEq. assumption. astepr ([--][--]x). apply inv_resp_leEq. assumption. Qed. Lemma mult_resp_AbsSmall: forall (R: COrdField) (x y e : R) (H: [0][<=]y), AbsSmall e x -> AbsSmall (y[*]e) (y[*]x). Proof. unfold AbsSmall. intros. destruct H0. split. rstepl (y[*]([--]e)). apply mult_resp_leEq_lft; auto. apply mult_resp_leEq_lft; auto. Qed. Lemma div_resp_AbsSmall: forall (R: COrdField) (x y e : R) (H: [0][<]y), AbsSmall e x -> AbsSmall (e[/]y[//]pos_ap_zero _ _ H) (x[/]y[//]pos_ap_zero _ _ H). Proof. unfold AbsSmall. intros. destruct H0. split. rstepl (([--]e)[/]y[//]pos_ap_zero _ _ H). apply div_resp_leEq; auto. apply div_resp_leEq; auto. Qed. Lemma sum_resp_AbsSmall : forall (x y : nat -> R) (n m: nat) (H1 : m <= n) (H2 : forall i : nat, m <= i -> i <= n -> AbsSmall (y i) (x i)), AbsSmall (Sum m n y) (Sum m n x). Proof. unfold AbsSmall. intros. assert (H3 : forall i : nat, m <= i -> i <= n -> [--](y i)[<=]x i). intros. elim (H2 i H H0). auto. assert (H4 : forall i : nat, m <= i -> i <= n -> x i[<=]y i). intros. elim (H2 i H H0). auto. split. astepl (Sum m n (fun k: nat => [--](y k))). apply Sum_resp_leEq . auto with arith. intros. auto. apply Sum_resp_leEq . auto with arith. intros. auto. Qed. Lemma AbsSmall_minus : forall e x1 x2 : R, AbsSmall e (x1[-]x2) -> AbsSmall e (x2[-]x1). Proof. intros. rstepr ([--](x1[-]x2)). apply inv_resp_AbsSmall. assumption. Qed. Lemma AbsSmall_plus : forall e1 e2 x1 x2 : R, AbsSmall e1 x1 -> AbsSmall e2 x2 -> AbsSmall (e1[+]e2) (x1[+]x2). Proof. unfold AbsSmall in |- *. intros. elim H; intros. elim H0; intros. split. rstepl ([--]e1[+][--]e2). apply plus_resp_leEq_both; assumption. apply plus_resp_leEq_both; assumption. Qed. Lemma AbsSmall_eps_div_two : forall e x1 x2 : R, AbsSmall (e [/]TwoNZ) x1 -> AbsSmall (e [/]TwoNZ) x2 -> AbsSmall e (x1[+]x2). Proof. intros. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. assumption. assumption. Qed. Lemma AbsSmall_x_plus_delta : forall x eps delta : R, [0] [<=] eps -> [0] [<=] delta -> delta [<=] eps -> AbsSmall eps (x[-] (x[+]delta)). Proof. intros. (* astepr ((x[-]x)[-]delta). astepr ([0][-]delta). *) rstepr ([--]delta). apply inv_resp_AbsSmall. apply leEq_imp_AbsSmall. assumption. assumption. Qed. Lemma AbsSmall_x_minus_delta : forall x eps delta : R, [0] [<=] eps -> [0] [<=] delta -> delta [<=] eps -> AbsSmall eps (x[-] (x[-]delta)). Proof. intros. (* astepr ((x[-]x)[+]delta). astepr ([0][+]delta). *) rstepr delta. apply leEq_imp_AbsSmall. assumption. assumption. Qed. Lemma AbsSmall_x_plus_eps_div2 : forall x eps : R, [0] [<=] eps -> AbsSmall eps (x[-] (x[+]eps [/]TwoNZ)). Proof. intros. apply AbsSmall_x_plus_delta. assumption. apply nonneg_div_two. assumption. apply nonneg_div_two'. assumption. Qed. Lemma AbsSmall_x_minus_eps_div2 : forall x eps : R, [0] [<=] eps -> AbsSmall eps (x[-] (x[-]eps [/]TwoNZ)). Proof. intros. apply AbsSmall_x_minus_delta. assumption. apply nonneg_div_two. assumption. apply eps_div_leEq_eps. assumption. apply less_leEq. apply one_less_two. Qed. Lemma AbsSmall_intermediate : forall x y z eps : R, x [<=] y -> y [<=] z -> AbsSmall eps (z[-]x) -> AbsSmall eps (z[-]y). Proof. intros. apply leEq_imp_AbsSmall. apply shift_leEq_minus; astepl y. assumption. unfold AbsSmall in H1. elim H1; intros. apply leEq_transitive with (z[-]x); try assumption. apply minus_resp_leEq_rht. assumption. Qed. Lemma AbsSmall_eps_div2 : forall eps : R, [0] [<=] eps -> AbsSmall eps (eps [/]TwoNZ). Proof. intros. apply leEq_imp_AbsSmall. apply nonneg_div_two. assumption. apply eps_div_leEq_eps. assumption. apply less_leEq. apply one_less_two. Qed. Lemma AbsSmall_nonneg : forall e x : R, AbsSmall e x -> [0] [<=] e. Proof. unfold AbsSmall in |- *. intros. elim H. intros. cut ([--]e [<=] e). intros. apply mult_cancel_leEq with (z := Two:R). apply pos_two. apply plus_cancel_leEq_rht with (z := [--]e). rstepl ([--]e). rstepr e. assumption. apply leEq_transitive with (y := x). assumption. assumption. Qed. Lemma AbsSmall_mult : forall e1 e2 x1 x2 : R, AbsSmall e1 x1 -> AbsSmall e2 x2 -> AbsSmall (Three[*] (e1[*]e2)) (x1[*]x2). Proof. unfold AbsSmall in |- *. intros. elim H. intros. elim H0. intros. cut ([0] [<=] e1). intro. cut ([0] [<=] e2). intro. split. apply plus_cancel_leEq_rht with (z := Three[*] (e1[*]e2)). rstepl ZeroR. rstepr (x1[*]x2[+]e1[*]e2[+]e1[*]e2[+]e1[*]e2). apply leEq_transitive with (y := x1[*]x2[+]e1[*]e2[+]x1[*]e2[+]e1[*]x2). rstepr ((e1[+]x1)[*](e2[+]x2)). apply mult_resp_nonneg. apply plus_cancel_leEq_rht with (z := [--]x1). rstepl ([--]x1). rstepr ([--][--]e1). apply inv_resp_leEq. assumption. apply plus_cancel_leEq_rht with (z := [--]x2). rstepl ([--]x2). rstepr ([--][--]e2). apply inv_resp_leEq. assumption. rstepl (x1[*]x2[+]e1[*]e2[+](x1[*]e2[+]e1[*]x2)). rstepr (x1[*]x2[+]e1[*]e2[+](e1[*]e2[+]e1[*]e2)). apply plus_resp_leEq_lft. apply plus_resp_leEq_both. apply mult_resp_leEq_rht. assumption. assumption. apply mult_resp_leEq_lft. assumption. assumption. apply plus_cancel_leEq_rht with (z := [--](x1[*]x2)). rstepl ZeroR. rstepr ([--](x1[*]x2)[+]e1[*]e2[+](e1[*]e2[+]e1[*]e2)). apply leEq_transitive with (y := [--](x1[*]x2)[+]e1[*]e2[+](x1[*]e2[-]e1[*]x2)). rstepr ((e1[+]x1)[*](e2[-]x2)). apply mult_resp_nonneg. apply plus_cancel_leEq_rht with (z := [--]x1). rstepl ([--]x1). rstepr ([--][--]e1). apply inv_resp_leEq. assumption. apply plus_cancel_leEq_rht with (z := x2). rstepl x2. rstepr e2. assumption. apply plus_resp_leEq_lft. rstepl (x1[*]e2[+][--]e1[*]x2). apply plus_resp_leEq_both. apply mult_resp_leEq_rht. assumption. assumption. rstepl (e1[*][--]x2). apply mult_resp_leEq_lft. rstepr ([--][--]e2). apply inv_resp_leEq. assumption. assumption. apply AbsSmall_nonneg with (e := e2) (x := x2). assumption. apply AbsSmall_nonneg with (e := e1) (x := x1). assumption. Qed. Lemma AbsSmall_cancel_mult : forall e x z : R, [0] [<] z -> AbsSmall (e[*]z) (x[*]z) -> AbsSmall e x. Proof. unfold AbsSmall in |- *. intros. elim H. intros. split. apply mult_cancel_leEq with (z := z). assumption. rstepl ([--](e[*]z)). assumption. apply mult_cancel_leEq with (z := z). assumption. assumption. Qed. Lemma AbsSmall_approach_zero : forall x : R, (forall e, [0] [<] e -> AbsSmall e x) -> x [=] [0]. Proof. intros. apply not_ap_imp_eq. intro H0. elim (ap_imp_less _ _ _ H0). change (Not (x [<] [0])). rewrite <- leEq_def. apply inv_cancel_leEq. astepr ZeroR. apply approach_zero_weak. intros. apply inv_cancel_leEq; astepr x. elim (H e); auto. change (Not ([0] [<] x)). rewrite <- leEq_def. apply approach_zero_weak. intros. elim (H e); auto. Qed. Lemma mult_AbsSmall'_rht : forall x y C : R, [0] [<=] C -> [--]C [<=] x -> x [<=] C -> [--]C [<=] y -> y [<=] C -> x[*]y [<=] Three[*]C[^]2. Proof. intros. astepl ([0][+]x[*]y). apply shift_plus_leEq. apply leEq_transitive with ((C[+]x)[*](C[-]y)). apply mult_resp_nonneg. apply shift_leEq_plus. astepl ([--]x). astepr ([--][--]C). apply inv_resp_leEq. auto. apply shift_leEq_minus. astepl y. auto. rstepl (C[^]2[-]x[*]y[+]C[*](x[-]y)). rstepr (C[^]2[-]x[*]y[+]C[*](C[-][--]C)). apply plus_resp_leEq_lft. apply mult_resp_leEq_lft. apply minus_resp_leEq_both. auto. auto. auto. Qed. Lemma mult_AbsSmall_rht : forall x y X Y : R, [0] [<=] X -> [0] [<=] Y -> [--]X [<=] x -> x [<=] X -> [--]Y [<=] y -> y [<=] Y -> x[*]y [<=] X[*]Y. Proof. intros. rewrite -> leEq_def. intro. cut ([0] [<] x[*]y); intros. 2: apply leEq_less_trans with (X[*]Y); auto. rewrite -> leEq_def in *. cut (x[*]y [#] [0]); intros. 2: apply pos_ap_zero; auto. cut (x [#] [0]); intros. 2: apply mult_cancel_ap_zero_lft with y; auto. elim (ap_imp_less _ _ _ X3); intro. cut (y [<] [0]); intros. 2: astepl ([--][--]y); astepr ([--]([0]:R)); apply inv_resp_less. 2: apply mult_cancel_pos_rht with ([--]x). 2: astepr (x[*]y); auto. 2: astepl ([--]([0]:R)); apply less_leEq; apply inv_resp_less; auto. apply (less_irreflexive_unfolded R [1]). apply leEq_less_trans with (X[*]Y[/] _[//]X2). rstepr ((X[/] [--]x[//]inv_resp_ap_zero _ _ X3)[*] (Y[/] [--]y[//]inv_resp_ap_zero _ _ (less_imp_ap _ _ _ X4))). astepl ([1][*]([1]:R)). apply mult_resp_leEq_both. apply less_leEq; apply pos_one. apply less_leEq; apply pos_one. apply shift_leEq_div. astepl ([--]([0]:R)); apply inv_resp_less; auto. astepl ([--]x); astepr ([--][--]X); apply inv_resp_leEq; firstorder using leEq_def. apply shift_leEq_div. astepl ([--]([0]:R)); apply inv_resp_less; auto. astepl ([--]y); astepr ([--][--]Y); apply inv_resp_leEq; firstorder using leEq_def. apply shift_div_less; auto. astepr (x[*]y); auto. cut ([0] [<] y); intros. 2: apply mult_cancel_pos_rht with x; try apply less_leEq; auto. apply (less_irreflexive_unfolded R [1]). apply leEq_less_trans with (X[*]Y[/] _[//]X2). rstepr ((X[/] x[//]X3)[*](Y[/] y[//]pos_ap_zero _ _ X4)). astepl ([1][*]([1]:R)). apply mult_resp_leEq_both. apply less_leEq; apply pos_one. apply less_leEq; apply pos_one. apply shift_leEq_div; auto. astepl x; firstorder using leEq_def. apply shift_leEq_div; auto. astepl y; firstorder using leEq_def. apply shift_div_less; auto. astepr (x[*]y); firstorder using leEq_def. Qed. Lemma mult_AbsSmall_lft : forall x y X Y : R, [0] [<=] X -> [0] [<=] Y -> [--]X [<=] x -> x [<=] X -> [--]Y [<=] y -> y [<=] Y -> [--](X[*]Y) [<=] x[*]y. Proof. intros. rstepr ([--]([--]x[*]y)). apply inv_resp_leEq. apply mult_AbsSmall_rht; auto. apply inv_resp_leEq. auto. rstepr ([--][--]X). apply inv_resp_leEq. auto. Qed. Lemma mult_AbsSmall : forall x y X Y : R, AbsSmall X x -> AbsSmall Y y -> AbsSmall (X[*]Y) (x[*]y). Proof. unfold AbsSmall in |- *. intros. elim H. intros. elim H0. intros. cut ([0] [<=] X). intro. cut ([0] [<=] Y). intro. split. apply mult_AbsSmall_lft; auto. apply mult_AbsSmall_rht; auto. apply AbsSmall_nonneg with y; auto. apply AbsSmall_nonneg with x; auto. Qed. End AbsSmall_properties. Declare Left Step AbsSmall_wdl_unfolded. Declare Right Step AbsSmall_wdr_unfolded. (** ** Properties of [AbsBig] *) Definition absBig (R : COrdField) (e x : R) : CProp := [0] [<] e and (e [<=] x or x [<=] [--]e). Notation AbsBig := (absBig _). Lemma AbsBigSmall_minus : forall (R : COrdField) (e1 e2 x1 x2 : R), e2 [<] e1 -> AbsBig e1 x1 -> AbsSmall e2 x2 -> AbsBig (e1[-]e2) (x1[-]x2). Proof. intros. unfold absBig in |- *. split. apply plus_cancel_less with (z := e2). rstepl e2. rstepr e1. assumption. unfold absBig in X0. elim X0. intros H2 H3. case H3. intro H4. left. unfold AbsSmall in H. elim H. intros. rstepl (e1[+][--]e2). rstepr (x1[+][--]x2). apply plus_resp_leEq_both. assumption. apply inv_cancel_leEq. rstepl x2. rstepr e2. assumption. intro H4. right. unfold AbsSmall in H. elim H. intros H5 H6. rstepr ([--]e1[+]e2). rstepl (x1[+][--]x2). apply plus_resp_leEq_both. assumption. apply inv_cancel_leEq. rstepr x2. rstepl ([--]e2). assumption. Qed. Section absBig_wd_properties. (** %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. Lemma AbsBig_wdr : Crel_wdr R AbsBig. Proof. red in |- *. intros. unfold absBig in |- *. unfold absBig in H. elim X. intros H1 H2. split. assumption. case H2. intro H3. left. apply leEq_wdr with y. assumption. assumption. intro H3. right. apply leEq_wdl with y. assumption. assumption. Qed. Lemma AbsBig_wdl : Crel_wdl R AbsBig. Proof. red in |- *. unfold absBig in |- *. intros. elim X. intros H1 H2. split. astepr x. assumption. case H2. intro H3. left. astepl x. assumption. intro H3. right. astepr ([--]x). assumption. Qed. Lemma AbsBig_wdr_unfolded : forall x y z : R, AbsBig x y -> y [=] z -> AbsBig x z. Proof AbsBig_wdr. Lemma AbsBig_wdl_unfolded : forall x y z : R, AbsBig x y -> x [=] z -> AbsBig z y. Proof AbsBig_wdl. End absBig_wd_properties. Declare Left Step AbsBig_wdl_unfolded. Declare Right Step AbsBig_wdr_unfolded. Add Parametric Morphism c : (@AbsSmall c) with signature (@cs_eq (cof_crr c)) ==> (@cs_eq c) ==> iff as AbsSmall_morph_wd. Proof with try assumption. intros x1 x2 xeq y1 y2 yeq. split; intro H. stepr y1... stepl x1... symmetry in xeq, yeq. stepr y2... stepl x2... Qed. corn-8.20.0/algebra/COrdCauchy.v000066400000000000000000000563511473720167500163400ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.COrdAbs. From Coq Require Import Lia. (* Begin_SpecReals *) Section OrdField_Cauchy. (** ** Cauchy sequences %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. (* begin hide *) Set Implicit Arguments. Unset Strict Implicit. (* end hide *) Definition Cauchy_prop (g : nat -> R) : CProp := forall e : R, [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (g m[-]g N)}. (* begin hide *) Set Strict Implicit. Unset Implicit Arguments. (* end hide *) (* Def. CauchyP, Build_CauchyP *) (* Should be defined in terms of CauchyP *) (** Implicit arguments turned off, because Coq makes a mess of it in combination with the coercions *) Record CauchySeq : Type := {CS_seq :> nat -> R; CS_proof : Cauchy_prop CS_seq}. Definition SeqLimit (seq : nat -> R) (lim : R) : CProp := forall e : R, [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (seq m[-]lim)}. (* End_SpecReals *) (** We now prove that the property of being a Cauchy sequence is preserved through the usual algebraic operations (addition, subtraction and multiplication -- and division, provided some additional conditions hold). %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Theorem CS_seq_bounded : forall g : nat -> R, Cauchy_prop g -> {K : R | [0] [<] K | {N : nat | forall m, N <= m -> AbsSmall K (g m)}}. Proof. intros g Hg. unfold Cauchy_prop in |- *. elim (Hg _ (pos_one _)). intros N H1. exists (g N[^]2[-]g N[+]Two). apply less_leEq_trans with (nring (R:=R) 7 [/]FourNZ). apply pos_div_four; apply nring_pos; auto with arith. astepl ([0][+]nring (R:=R) 7 [/]FourNZ). apply shift_plus_leEq. rstepr ((g N[-][1] [/]TwoNZ)[^]2). apply sqr_nonneg. exists N. intros m Hm. elim (H1 m Hm); intros. split. apply plus_cancel_leEq_rht with (z := [--](g N)). rstepr (g m[-]g N). rstepl ([--](g N[^]2[+]Two)). apply leEq_transitive with ([--]([1]:R)). apply inv_cancel_leEq. rstepl ([1]:R). rstepr (g N[^]2[+]Two). apply plus_cancel_leEq_rht with ([--][1]:R). rstepl ([0]:R). rstepr (g N[^]2[+][1]). apply leEq_transitive with (y := g N[^]2). apply sqr_nonneg. apply less_leEq; apply less_plusOne. assumption. apply plus_cancel_leEq_rht with (g N[-]Two). rstepr (g N[^]2). astepr (g N[*]g N). apply plus_cancel_leEq_rht with ([--](Two[*]g N)[+]Two). rstepl (g m[-]g N). rstepr (g N[*]g N[+][1][-]Two[*]g N[+][1]). apply leEq_transitive with (y := [1]:R). assumption. rstepl ([0][+]([1]:R)). apply plus_resp_leEq with (z := [1]:R). rstepr ((g N[-][1])[*](g N[-][1])). apply leEq_wdr with (y := (g N[-][1])[^]2). apply sqr_nonneg. algebra. Qed. Lemma CS_seq_const : forall c : R, Cauchy_prop (fun n => c). Proof. exists 0. intros; astepr ([0]:R); apply zero_AbsSmall. apply less_leEq; auto. Qed. (** %\begin{convention}% Assume [f] and [g] are Cauchy sequences on [R]. %\end{convention}% *) Variables f g : nat -> R. Hypothesis Hf : Cauchy_prop f. Hypothesis Hg : Cauchy_prop g. Lemma CS_seq_plus : Cauchy_prop (fun m => f m[+]g m). Proof. unfold Cauchy_prop in |- *. intros. set (e_div_4 := e [/]FourNZ) in *. cut ([0] [<] e_div_4); [ intro Heps | unfold e_div_4 in |- *; apply pos_div_four; auto ]. unfold Cauchy_prop in Hf. unfold Cauchy_prop in Hg. elim (Hf e_div_4 Heps); intros N1 H21. elim (Hg e_div_4 Heps); intros N2 H31. exists (Nat.max N1 N2). intros. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). rstepr (f m[-]f (Nat.max N1 N2)[+](g m[-]g (Nat.max N1 N2))). apply AbsSmall_plus. rstepr (f m[-]f N1[+](f N1[-]f (Nat.max N1 N2))). rstepl (e [/]FourNZ[+]e [/]FourNZ). apply AbsSmall_plus. apply H21; eauto with arith. apply AbsSmall_minus. apply H21; eauto with arith. rstepr (g m[-]g N2[+](g N2[-]g (Nat.max N1 N2))). rstepl (e [/]FourNZ[+]e [/]FourNZ). apply AbsSmall_plus. apply H31; eauto with arith. apply AbsSmall_minus. apply H31; eauto with arith. Qed. Lemma CS_seq_inv : Cauchy_prop (fun n => [--] (f n)). Proof. red in |- *; intros e H. elim (Hf e H); intros N Hn. exists N; intros m Hm. apply AbsSmall_minus. rstepr (f m[-]f N). auto. Qed. Lemma CS_seq_mult : Cauchy_prop (fun n => f n[*]g n). Proof. red in |- *; intros e He. elim (CS_seq_bounded f Hf); intros Mf HMf H. elim (CS_seq_bounded g Hg); intros Mg HMg H'. elim H; clear H; intros Nf HNf. elim H'; clear H'; intros Ng HNg. set (Mf_ap_zero := pos_ap_zero _ _ HMf) in *. set (Mg_ap_zero := pos_ap_zero _ _ HMg) in *. set (ef := e[/] _[//]mult_resp_ap_zero _ _ _ (twelve_ap_zero _) Mf_ap_zero) in *. set (eg := e[/] _[//]mult_resp_ap_zero _ _ _ (twelve_ap_zero _) Mg_ap_zero) in *. cut ([0] [<] ef); [ intro Hef | unfold ef in |- *; apply div_resp_pos; try apply mult_resp_pos; auto; apply pos_twelve ]. cut ([0] [<] eg); [ intro Heg | unfold eg in |- *; apply div_resp_pos; try apply mult_resp_pos; auto; apply pos_twelve ]. elim (Hf eg Heg); intros Pf HPf. elim (Hg ef Hef); intros Pg HPg. set (N := Nat.max (Nat.max Nf Pf) (Nat.max Ng Pg)) in *; exists N; intros m Hm. rstepr ((f m[-]f Pf[+][--](f N[-]f Pf))[*]g m[+] (g m[-]g Pg[+][--](g N[-]g Pg))[*]f N). apply AbsSmall_wdl_unfolded with (Three[*]((eg[+]eg)[*]Mg)[+]Three[*]((ef[+]ef)[*]Mf)). 2: unfold eg, ef in |- *; rational. apply AbsSmall_plus; apply AbsSmall_mult; try apply AbsSmall_plus; try apply inv_resp_AbsSmall. apply HPf; apply Nat.le_trans with N; auto; unfold N in |- *; eauto with arith. apply HPf; apply Nat.le_trans with N; auto; unfold N in |- *; eauto with arith. apply HNg; auto; apply Nat.le_trans with N; auto; unfold N in |- *; eauto with arith. apply HPg; apply Nat.le_trans with N; auto; unfold N in |- *; eauto with arith. apply HPg; apply Nat.le_trans with N; auto; unfold N in |- *; eauto with arith. apply HNf; auto; apply Nat.le_trans with N; auto; unfold N in |- *; eauto with arith. Qed. (** We now assume that [f] is, from some point onwards, greater than some positive number. The sequence of reciprocals is defined as being constantly one up to that point, and the sequence of reciprocals from then onwards. %\begin{convention}% Let [e] be a postive element of [R] and let [N:nat] be such that from [N] onwards, [(f n) [#] [0]] %\end{convention}% *) Variable e : R. Hypothesis He : [0] [<] e. Variable N : nat. Hypothesis f_bnd : forall n : nat, N <= n -> e [<=] f n. Lemma CS_seq_recip_def : forall n : nat, N <= n -> f n [#] [0]. Proof. intros. apply pos_ap_zero. apply less_leEq_trans with e; auto with arith. Qed. Definition CS_seq_recip_seq (n : nat) : R. Proof. elim (lt_le_dec n N); intro Hdec. apply ([1]:R). apply ([1][/] _[//]CS_seq_recip_def n Hdec). Defined. Lemma CS_seq_recip : Cauchy_prop CS_seq_recip_seq. Proof. red in |- *; intros d Hd. elim (Hf ((d[*]e[*]e) [/]TwoNZ)); [ intros K HK | apply pos_div_two; repeat apply mult_resp_pos; auto ]. exists (Nat.max K N); intros n Hn. apply AbsSmall_cancel_mult with (f (Nat.max K N)). apply less_leEq_trans with e; auto with arith. apply AbsSmall_cancel_mult with (f n). apply less_leEq_trans with e; eauto with arith. unfold CS_seq_recip_seq in |- *. elim lt_le_dec; intro; simpl in |- *. exfalso; apply Nat.le_ngt with N n; eauto with arith. elim lt_le_dec; intro; simpl in |- *. exfalso; apply Nat.le_ngt with N (Nat.max K N); eauto with arith. rstepr (f (Nat.max K N)[-]f n). apply AbsSmall_leEq_trans with (d[*]e[*]e). apply mult_resp_leEq_both. apply less_leEq; apply mult_resp_pos; auto. apply less_leEq; auto. apply mult_resp_leEq_lft. auto with arith. apply less_leEq; auto. auto with arith. auto with arith. rstepr (f (Nat.max K N)[-]f K[+](f K[-]f n)). apply AbsSmall_eps_div_two. auto with arith. apply AbsSmall_minus; apply HK. eauto with arith. Qed. End OrdField_Cauchy. Arguments SeqLimit [R]. (** The following lemma does not require the sequence to be Cauchy, but it fits well here anyway. *) Lemma maj_upto_eps : forall (F : COrdField) (a : nat -> F) (n : nat) (eps : F), 0 < n -> [0] [<] eps -> {k : nat | 1 <= k /\ k <= n /\ (forall i : nat, 1 <= i -> i <= n -> a i[-]eps [<=] a k)}. Proof. intros F a n eps Hn Heps. induction n as [| n Hrecn]. elim (Nat.lt_irrefl _ Hn). clear Hrecn Hn. induction n as [| n Hrecn]. exists 1. repeat split. 1-2: reflexivity. intros. rewrite <- (Nat.le_antisymm _ _ H H0). astepr (a 1[+][0]). unfold cg_minus in |- *. apply plus_resp_leEq_lft. astepr ([--]([0]:F)). apply less_leEq; apply inv_resp_less; auto. elim Hrecn; intros k Hk. cut (a (S (S n))[-]eps [<] a (S (S n))). intro H. elim (less_cotransitive_unfolded _ _ _ H (a k)); intro H4. exists k. elim Hk; intros H0 H2. elim H2; clear H2; intros H1 H2. repeat split. assumption. auto with arith. intros i H3 H5. elim (Cle_le_S_eq _ _ H5); intro H6. auto with arith. rewrite H6. apply less_leEq; assumption. exists (S (S n)). repeat split; auto with arith. intros i H0 H1. elim (Cle_le_S_eq _ _ H1); intro H2. apply leEq_transitive with (a k). elim Hk; intros H3 H5. elim H5; clear H5; intros H6 H7. auto with arith. apply less_leEq; assumption. rewrite H2; apply less_leEq; auto. rstepr (a (S (S n))[-][0]). apply minus_resp_less_rht. assumption. Qed. Section Mult_Continuous. Variable R : COrdField. (** ** Multiplication is continuous %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Lemma smaller : forall x y : R, [0] [<] x -> [0] [<] y -> {z : R | [0] [<] z | z [<=] x /\ z [<=] y}. Proof. intros x y H H0. elim (less_cotransitive_unfolded _ _ _ (half_3 _ _ H) y); intro. exists (Half[*]x). apply mult_resp_pos. apply pos_half. auto. split; apply less_leEq. apply half_3. auto. auto. cut (Half[*]y [<] y). intro. exists (Half[*]y). apply mult_resp_pos. apply pos_half. auto. split; apply less_leEq. apply less_transitive_unfolded with y. auto. auto. auto. apply half_3. auto. Qed. Lemma estimate_abs : forall x : R, {X : R | [0] [<] X | AbsSmall X x}. Proof. intros. unfold AbsSmall in |- *. cut (x [<] x[+][1]). intro H. elim (less_cotransitive_unfolded _ x (x[+][1]) H [--]x); intro. exists ([--]x[+][1]). apply leEq_less_trans with ([--]x). 2: apply less_plusOne. apply less_leEq; apply mult_cancel_less with (Two:R). apply pos_two. astepl ([0]:R); rstepr ([--]x[-]x). apply shift_less_minus. astepl x; auto. split; apply less_leEq. astepr ([--][--]x). apply inv_resp_less. apply less_plusOne. apply less_transitive_unfolded with ([--]x). auto. apply less_plusOne. exists (x[+][1]). apply less_leEq_trans with (([1]:R) [/]TwoNZ). apply pos_div_two; apply pos_one. apply shift_leEq_plus; rstepl (([--][1]:R) [/]TwoNZ). apply shift_div_leEq. apply pos_two. rstepr (x[+]x); apply shift_leEq_plus. unfold cg_minus in |- *; apply shift_plus_leEq'. rstepr (x[+][1]); apply less_leEq; auto. split; apply less_leEq. astepr ([--][--]x). apply inv_resp_less. auto. auto. apply less_plusOne. Qed. Lemma mult_contin : forall x y e : R, [0] [<] e -> {c : R | [0] [<] c | {d : R | [0] [<] d | forall x' y' : R, AbsSmall c (x[-]x') -> AbsSmall d (y[-]y') -> AbsSmall e (x[*]y[-]x'[*]y')}}. Proof. intros x y e H. set (e2 := e [/]TwoNZ) in *. cut ([0] [<] e2). intro H0. 2: unfold e2 in |- *; apply pos_div_two; auto. elim (estimate_abs x). intro X. intros H1a H1b. elim (estimate_abs y). intro Y. intros H2 H3. cut (Y [#] [0]). intro H4. set (eY := e2[/] Y[//]H4) in *; exists eY. unfold eY in |- *. apply div_resp_pos. auto. auto. cut ([0] [<] X[+]eY). intro H5. cut (X[+]eY [#] [0]). intro H6. exists (e2[/] X[+]eY[//]H6). apply div_resp_pos. auto. auto. intros. apply AbsSmall_wdr_unfolded with ((x[-]x')[*]y[+]x'[*](y[-]y')). apply AbsSmall_eps_div_two. apply AbsSmall_wdl_unfolded with ((e [/]TwoNZ[/] Y[//]H4)[*]Y). apply mult_AbsSmall; auto. rational. apply AbsSmall_wdl_unfolded with ((X[+](e [/]TwoNZ[/] Y[//]H4))[*] (e [/]TwoNZ[/] X[+](e [/]TwoNZ[/] Y[//]H4)[//]H6)). apply mult_AbsSmall; auto. apply AbsSmall_wdr_unfolded with (x[+](x'[-]x)). apply AbsSmall_plus; auto. apply AbsSmall_minus. auto. rational. rational. rational. apply Greater_imp_ap. auto. apply plus_resp_pos; auto. unfold eY in |- *; apply div_resp_pos; auto. apply Greater_imp_ap. auto. Qed. (** Addition is also continuous. *) Lemma plus_contin : forall (x y e : R), [0] [<] e -> {c : R | [0] [<] c | {d : R | [0] [<] d | forall x' y', AbsSmall c (x[-]x') -> AbsSmall d (y[-]y') -> AbsSmall e (x[+]y[-] (x'[+]y'))}}. Proof. intros. cut ([0] [<] e [/]TwoNZ). intro. exists (e [/]TwoNZ). auto. exists (e [/]TwoNZ). auto. intros. apply AbsSmall_wdr_unfolded with (x[-]x'[+](y[-]y')). apply AbsSmall_eps_div_two; auto. rational. apply div_resp_pos. apply pos_two. auto. Qed. End Mult_Continuous. Section Monotonous_functions. (** ** Monotonous Functions Finally, we study several properties of monotonous functions and characterize them in some way. %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. (** We begin by characterizing the preservation of less (less or equal) in terms of preservation of less or equal (less). *) Lemma resp_less_char' : forall (P : R -> CProp) (f : forall x, P x -> R) x y Hx Hy, (x [#] y -> f x Hx [#] f y Hy) -> (x [<=] y -> f x Hx [<=] f y Hy) -> x [<] y -> f x Hx [<] f y Hy. Proof. intros. elim (ap_imp_less _ _ _ (X (less_imp_ap _ _ _ X0))); intros. auto. exfalso. apply less_irreflexive_unfolded with (x := f x Hx). apply leEq_less_trans with (f y Hy); auto. apply H; apply less_leEq; auto. Qed. Lemma resp_less_char : forall (f : R -> R) x y, (x [#] y -> f x [#] f y) -> (x [<=] y -> f x [<=] f y) -> x [<] y -> f x [<] f y. Proof. intros. set (f' := fun (x : R) (H : True) => f x) in *. change (f' x I [<] f' y I) in |- *. apply resp_less_char' with (P := fun x : R => True); auto. Qed. Lemma resp_leEq_char' : forall (P : R -> CProp) (f : forall x : R, P x -> R) x y Hx Hy, (x [=] y -> f x Hx [=] f y Hy) -> (x [<] y -> f x Hx [<] f y Hy) -> x [<=] y -> f x Hx [<=] f y Hy. Proof. intros. rewrite -> leEq_def. intro. cut (Not (x [<] y) /\ ~ x [=] y); intros. inversion_clear H1. apply H3. apply leEq_imp_eq; firstorder using leEq_def. split; intro. apply less_irreflexive_unfolded with (x := f y Hy). apply less_transitive_unfolded with (f x Hx); auto. apply less_irreflexive_unfolded with (x := f y Hy). apply less_leEq_trans with (f x Hx); auto. apply eq_imp_leEq; auto. Qed. Lemma resp_leEq_char : forall (f : R -> R) x y, (x [=] y -> f x [=] f y) -> (x [<] y -> f x [<] f y) -> x [<=] y -> f x [<=] f y. Proof. intros. set (f' := fun (x : R) (H : True) => f x) in *. change (f' x I [<=] f' y I) in |- *. apply resp_leEq_char' with (P := fun x : R => True); auto. Qed. (** Next, we see different characterizations of monotonous functions from some subset of the natural numbers into [R]. Mainly, these amount (for different types of functions) to proving that a function is monotonous iff [f(i) [<] f(i+1)] for every [i]. Also, strictly monotonous functions are injective. *) Lemma local_mon_imp_mon : forall f : nat -> R, (forall i, f i [<] f (S i)) -> forall i j, i < j -> f i [<] f j. Proof. simple induction j. intros H0; exfalso; inversion H0. clear j; intro j; intros H0 H1. elim (le_lt_eq_dec _ _ H1); intro. apply leEq_less_trans with (f j). apply less_leEq; apply H0; auto with arith. auto. rewrite <- b; apply X. Qed. Lemma local_mon_imp_mon' : forall f : nat -> R, (forall i, f i [<] f (S i)) -> forall i j, i <= j -> f i [<=] f j. Proof. intros f H i j H0. elim (le_lt_eq_dec _ _ H0); intro. apply less_leEq; apply local_mon_imp_mon with (f := f); assumption. apply eq_imp_leEq; rewrite b; algebra. Qed. Lemma local_mon'_imp_mon' : forall f : nat -> R, (forall i, f i [<=] f (S i)) -> forall i j, i <= j -> f i [<=] f j. Proof. intros; induction j as [| j Hrecj]. cut (i = 0); [ intro | auto with arith ]. rewrite H1; apply leEq_reflexive. elim (le_lt_eq_dec _ _ H0); intro. apply leEq_transitive with (f j). apply Hrecj; auto with arith. apply H. rewrite b; apply leEq_reflexive. Qed. Lemma mon_imp_mon' : forall f : nat -> R, (forall i j, i < j -> f i [<] f j) -> forall i j, i <= j -> f i [<=] f j. Proof. intros f H i j H0. elim (le_lt_eq_dec _ _ H0); intro. apply less_leEq; apply H; assumption. rewrite b; apply leEq_reflexive. Qed. Lemma mon_imp_inj : forall f : nat -> R, (forall i j, i < j -> f i [<] f j) -> forall i j, f i [=] f j -> i = j. Proof. intros. cut (~ i <> j); [ lia | intro ]. cut (i < j \/ j < i); [ intro | apply not_eq; auto ]. inversion_clear H1; (exfalso; cut (f i [#] f j); [ apply eq_imp_not_ap; assumption | idtac ]). apply less_imp_ap; apply X; assumption. apply Greater_imp_ap; apply X; assumption. Qed. Lemma local_mon_imp_mon_lt : forall n (f : forall i, i < n -> R), (forall i H H', f i H [<] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<] f j Hj. Proof. simple induction j. intros Hi Hj H0; exfalso; inversion H0. clear j; intro j; intros. elim (le_lt_eq_dec _ _ H); intro. cut (j < n); [ intro | auto with arith ]. apply leEq_less_trans with (f j H0). apply less_leEq; apply X0; auto with arith. apply X. generalize Hj; rewrite <- b. intro; apply X. Qed. Lemma local_mon_imp_mon'_lt : forall n (f : forall i, i < n -> R), (forall i H H', f i H [<] f (S i) H') -> nat_less_n_fun f -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj. Proof. intros. elim (le_lt_eq_dec _ _ H0); intros. apply less_leEq; apply local_mon_imp_mon_lt with n; auto. apply eq_imp_leEq; apply H; assumption. Qed. Lemma local_mon'_imp_mon'_lt : forall n (f : forall i, i < n -> R), (forall i H H', f i H [<=] f (S i) H') -> nat_less_n_fun f -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj. Proof. simple induction j. intros. cut (i = 0); [ intro | auto with arith ]. apply eq_imp_leEq; apply H0; auto. intro m; intros. elim (le_lt_eq_dec _ _ H2); intro. cut (m < n); [ intro | auto with arith ]. apply leEq_transitive with (f m H3); auto. apply H1; auto with arith. apply eq_imp_leEq; apply H0; assumption. Qed. Lemma local_mon'_imp_mon'2_lt : forall n (f : forall i, i < n -> R), (forall i H H', f i H [<=] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<=] f j Hj. Proof. intros; induction j as [| j Hrecj]. exfalso; inversion H0. elim (le_lt_eq_dec _ _ H0); intro. cut (j < n); [ intro | auto with arith ]. apply leEq_transitive with (f j H1). apply Hrecj; auto with arith. apply H. generalize Hj; rewrite <- b. intro; apply H. Qed. Lemma mon_imp_mon'_lt : forall n (f : forall i, i < n -> R), nat_less_n_fun f -> (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj. Proof. intros. elim (le_lt_eq_dec _ _ H0); intro. apply less_leEq; auto. apply eq_imp_leEq; auto. Qed. Lemma mon_imp_inj_lt : forall n (f : forall i, i < n -> R), (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, f i Hi [=] f j Hj -> i = j. Proof. intros. cut (~ i <> j); intro. clear X H Hj Hi; lia. cut (i < j \/ j < i); [ intro | apply not_eq; auto ]. inversion_clear H1; (exfalso; cut (f i Hi [#] f j Hj); [ apply eq_imp_not_ap; assumption | idtac ]). apply less_imp_ap; auto. apply Greater_imp_ap; auto. Qed. Lemma local_mon_imp_mon_le : forall n (f : forall i, i <= n -> R), (forall i H H', f i H [<] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<] f j Hj. Proof. simple induction j. intros Hi Hj H0; exfalso; inversion H0. clear j; intro j; intros. elim (le_lt_eq_dec _ _ H); intro. cut (j <= n); [ intro | auto with arith ]. apply leEq_less_trans with (f j H0). apply less_leEq; auto with arith. apply X. generalize Hj; rewrite <- b. auto. Qed. Lemma local_mon_imp_mon'_le : forall n (f : forall i, i <= n -> R), (forall i H H', f i H [<] f (S i) H') -> nat_less_n_fun' f -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj. Proof. intros. elim (le_lt_eq_dec _ _ H0); intros. apply less_leEq; apply local_mon_imp_mon_le with n; auto. apply eq_imp_leEq; auto. Qed. Lemma local_mon'_imp_mon'_le : forall n (f : forall i, i <= n -> R), (forall i H H', f i H [<=] f (S i) H') -> nat_less_n_fun' f -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj. Proof. simple induction j. intros. cut (i = 0); [ intro | auto with arith ]. apply eq_imp_leEq; apply H0; auto. intro m; intros. elim (le_lt_eq_dec _ _ H2); intro. cut (m <= n); [ intro | auto with arith ]. apply leEq_transitive with (f m H3); auto. apply H1; auto with arith. apply eq_imp_leEq; apply H0; assumption. Qed. Lemma local_mon'_imp_mon'2_le : forall n (f : forall i, i <= n -> R), (forall i H H', f i H [<=] f (S i) H') -> forall i j Hi Hj, i < j -> f i Hi [<=] f j Hj. Proof. intros; induction j as [| j Hrecj]. exfalso; inversion H0. elim (le_lt_eq_dec _ _ H0); intro. cut (j <= n); [ intro | auto with arith ]. apply leEq_transitive with (f j H1). apply Hrecj; auto with arith. apply H. generalize Hj; rewrite <- b. intro; apply H. Qed. Lemma mon_imp_mon'_le : forall n (f : forall i, i <= n -> R), nat_less_n_fun' f -> (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, i <= j -> f i Hi [<=] f j Hj. Proof. intros. elim (le_lt_eq_dec _ _ H0); intro. apply less_leEq; auto. apply eq_imp_leEq; auto. Qed. Lemma mon_imp_inj_le : forall n (f : forall i, i <= n -> R), (forall i j Hi Hj, i < j -> f i Hi [<] f j Hj) -> forall i j Hi Hj, f i Hi [=] f j Hj -> i = j. Proof. intros. cut (~ i <> j); intro. clear H X Hj Hi; lia. cut (i < j \/ j < i); [ intro | apply not_eq; auto ]. inversion_clear H1; (exfalso; cut (f i Hi [#] f j Hj); [ apply eq_imp_not_ap; assumption | idtac ]). apply less_imp_ap; auto. apply Greater_imp_ap; auto. Qed. (** A similar result for %{\em %partial%}% functions. *) Lemma part_mon_imp_mon' : forall F (I : R -> CProp), (forall x, I x -> Dom F x) -> (forall x y Hx Hy, I x -> I y -> x [<] y -> F x Hx [<] F y Hy) -> forall x y Hx Hy, I x -> I y -> x [<=] y -> F x Hx [<=] F y Hy. Proof. intros. rewrite -> leEq_def. intro. cut (x [=] y); intros. apply (less_irreflexive_unfolded _ (F x Hx)). astepl (F y Hy); auto. apply leEq_imp_eq. firstorder using leEq_def. rewrite -> leEq_def. intro. apply (less_irreflexive_unfolded _ (F x Hx)). apply less_transitive_unfolded with (F y Hy); firstorder using leEq_def. Qed. End Monotonous_functions. corn-8.20.0/algebra/COrdFields.v000066400000000000000000001142061473720167500163240ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Cezary Kaliszyk * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [<] %\ensuremath<% #<# *) (** printing [<=] %\ensuremath{\leq}% #≤# *) (** printing [>] %\ensuremath>% #># *) (** printing [1]NZ %\ensuremath{\mathbf1}% #1# *) (** printing TwoNZ %\ensuremath{\mathbf2}% #2# *) (** printing ThreeNZ %\ensuremath{\mathbf3}% #3# *) (** printing FourNZ %\ensuremath{\mathbf4}% #4# *) (** printing SixNZ %\ensuremath{\mathbf6}% #6# *) (** printing EightNZ %\ensuremath{\mathbf8}% #8# *) (** printing NineNZ %\ensuremath{\mathbf9}% #9# *) (** printing TwelveNZ %\ensuremath{\mathbf{12}}% #12# *) (** printing SixteenNZ %\ensuremath{\mathbf{16}}% #16# *) (** printing EighteenNZ %\ensuremath{\mathbf{18}}% #18# *) (** printing TwentyFourNZ %\ensuremath{\mathbf{24}}% #24# *) (** printing FortyEightNZ %\ensuremath{\mathbf{48}}% #48# *) Require Export CoRN.tactics.FieldReflection. Require Export CoRN.tactics.Rational. Require Export CoRN.algebra.CSetoids. From Coq Require Import Lia. (* ORDERED FIELDS *) (** * Ordered Fields ** Definition of the notion of ordered field *) (* Begin_SpecReals *) Record strictorder (A : Type)(R : A -> A -> CProp) : CProp := {so_trans : Ctransitive R; so_asym : antisymmetric R}. Arguments strictorder [A]. Arguments Build_strictorder [A R]. Arguments so_trans [A R]. Arguments so_asym [A R]. Record is_COrdField (F : CField) (less : CCSetoid_relation F) (leEq : Relation F) (greater : CCSetoid_relation F) (grEq : Relation F) : CProp := {ax_less_strorder : strictorder less; ax_plus_resp_less : forall x y, less x y -> forall z, less (x[+]z) (y[+]z); ax_mult_resp_pos : forall x y, less [0] x -> less [0] y -> less [0] (x[*]y); ax_less_conf_ap : forall x y, Iff (x [#] y) (less x y or less y x); def_leEq : forall x y, (leEq x y) <-> (Not (less y x)); def_greater : forall x y, Iff (greater x y) (less y x); def_grEq : forall x y, (grEq x y) <-> (leEq y x)}. Record COrdField : Type := {cof_crr :> CField; cof_less : CCSetoid_relation cof_crr; cof_leEq : cof_crr -> cof_crr -> Prop; cof_greater : CCSetoid_relation cof_crr; cof_grEq : cof_crr -> cof_crr -> Prop; cof_proof : is_COrdField cof_crr cof_less cof_leEq cof_greater cof_grEq}. (** %\begin{nameconvention}% In the names of lemmas, [ [<] ] is written as [less] and "[[0] [<] ]" is written as [pos]. %\end{nameconvention}% *) Arguments cof_less {c}. Infix "[<]" := cof_less (at level 70, no associativity). Arguments cof_greater {c}. Infix "[>]" := cof_greater (at level 70, no associativity). Arguments cof_leEq {c}. Infix "[<=]" := cof_leEq (at level 70, no associativity). Arguments cof_grEq {c}. Infix "[>=]" := cof_grEq (at level 70, no associativity). Definition default_greater (X:CField) (lt:CCSetoid_relation X) : CCSetoid_relation X. Proof. intros. exists (fun x y => lt y x). destruct lt. unfold Crel_strext in *. simpl. intros. pose (Ccsr_strext _ y2 _ x2 X0). tauto. Defined. Definition default_leEq (X:CField) (lt:CCSetoid_relation X) : Relation X := (fun x y => (Not (lt y x))). Definition default_grEq (X:CField) (le:Relation X) : Relation X := (fun x y => (le y x)). (** %\begin{nameconvention}% In the names of lemmas, [ [<=] ] is written as [leEq] and [[0] [<=] ] is written as [nonneg]. %\end{nameconvention}% *) Section COrdField_axioms. (** ** Ordered field axioms %\begin{convention}% Let [F] be a field. %\end{convention}% *) Variable F : COrdField. Lemma COrdField_is_COrdField : is_COrdField F cof_less (@cof_leEq F) cof_greater (@cof_grEq F). Proof. elim F; auto. Qed. Lemma less_strorder : strictorder (cof_less (c:=F)). Proof. elim COrdField_is_COrdField; auto. Qed. Lemma less_transitive_unfolded : forall x y z : F, x [<] y -> y [<] z -> x [<] z. Proof. elim less_strorder; auto. Qed. Lemma less_antisymmetric_unfolded : forall x y : F, x [<] y -> Not (y [<] x). Proof. elim less_strorder. intros H1 H2 x y H. intro H0. elim (H2 _ _ H). assumption. Qed. Lemma less_irreflexive : irreflexive (cof_less (c:=F)). Proof. red in |- *. intro x; intro H. elim (less_antisymmetric_unfolded _ _ H H). Qed. Lemma less_irreflexive_unfolded : forall x : F, Not (x [<] x). Proof less_irreflexive. Lemma plus_resp_less_rht : forall x y z : F, x [<] y -> x[+]z [<] y[+]z. Proof. elim COrdField_is_COrdField; auto. Qed. Lemma mult_resp_pos : forall x y : F, [0] [<] x -> [0] [<] y -> [0] [<] x[*]y. Proof. elim COrdField_is_COrdField; auto. Qed. Lemma less_conf_ap : forall x y : F, Iff (x [#] y) (x [<] y or y [<] x). Proof. elim COrdField_is_COrdField; auto. Qed. Lemma leEq_def : forall x y : F, (x [<=] y) <-> (Not (y [<] x)). Proof. elim COrdField_is_COrdField; auto. Qed. Lemma greater_def : forall x y : F, Iff (x [>] y) (y [<] x). Proof. elim COrdField_is_COrdField; auto. Qed. Lemma grEq_def : forall x y : F, (x [>=] y) <-> (y [<=] x). Proof. elim COrdField_is_COrdField; auto. Qed. Lemma less_wdr : forall x y z : F, x [<] y -> y [=] z -> x [<] z. Proof Ccsr_wdr F cof_less. Lemma less_wdl : forall x y z : F, x [<] y -> x [=] z -> z [<] y. Proof Ccsr_wdl F cof_less. End COrdField_axioms. Declare Left Step less_wdl. Declare Right Step less_wdr. Section OrdField_basics. (** ** Basics *) (** %\begin{convention}% Let in the rest of this section (and all subsections) [R] be an ordered field %\end{convention}% *) Variable R : COrdField. Lemma less_imp_ap : forall x y : R, x [<] y -> x [#] y. Proof. intros x y H. elim (less_conf_ap _ x y); intros. apply b. left. auto. Qed. Lemma Greater_imp_ap : forall x y : R, y [<] x -> x [#] y. Proof. intros x y H. elim (less_conf_ap _ x y); intros. apply b. right. auto. Qed. Lemma ap_imp_less : forall x y : R, x [#] y -> x [<] y or y [<] x. Proof. intros x y. elim (less_conf_ap _ x y); auto. Qed. (** Now properties which can be derived. *) Lemma less_cotransitive : cotransitive (cof_less (c:=R)). Proof. red in |- *. intros x y H z. generalize (less_imp_ap _ _ H); intro H0. elim (ap_cotransitive_unfolded _ _ _ H0 z); intro H1. elim (ap_imp_less _ _ H1). auto. intro H2. right. apply (less_transitive_unfolded _ _ _ _ H2 H). elim (ap_imp_less _ _ H1). auto. intro H2. left. apply (less_transitive_unfolded _ _ _ _ H H2). Qed. Lemma less_cotransitive_unfolded : forall x y : R, x [<] y -> forall z, x [<] z or z [<] y. Proof less_cotransitive. Lemma pos_ap_zero : forall x : R, [0] [<] x -> x [#] [0]. Proof. intros x H. apply Greater_imp_ap. assumption. Defined. (* Main characterization of less *) Lemma leEq_not_eq : forall x y : R, x [<=] y -> x [#] y -> x [<] y. Proof. intros x y H H0. elim (ap_imp_less _ _ H0); intro H1; auto. rewrite -> leEq_def in H. elim (H H1). Qed. End OrdField_basics. (*---------------------------------*) Section Basic_Properties_of_leEq. (*---------------------------------*) (** ** Basic properties of [ [<=] ] *) Variable R : COrdField. Lemma leEq_wdr : forall x y z : R, x [<=] y -> y [=] z -> x [<=] z. Proof. intros x y z H H0. rewrite -> leEq_def in *. intro H1. apply H. astepl z; assumption. Qed. Lemma leEq_wdl : forall x y z : R, x [<=] y -> x [=] z -> z [<=] y. Proof. intros x y z H H0. rewrite -> leEq_def in *. intro H1. apply H. astepr z;auto. Qed. Lemma leEq_reflexive : forall x : R, x [<=] x. Proof. intro x. rewrite -> leEq_def. apply less_irreflexive_unfolded. Qed. Declare Left Step leEq_wdl. Declare Right Step leEq_wdr. Lemma eq_imp_leEq : forall x y : R, x [=] y -> x [<=] y. Proof. intros x y H. astepr x. exact (leEq_reflexive _). Qed. Lemma leEq_imp_eq : forall x y : R, x [<=] y -> y [<=] x -> x [=] y. Proof. intros x y H H0. rewrite -> leEq_def in *|-. apply not_ap_imp_eq. intro H1. apply H0. elim (ap_imp_less _ _ _ H1); intro H2. auto. elim (H H2). Qed. Lemma lt_equiv_imp_eq : forall x x' : R, (forall y, x [<] y -> x' [<] y) -> (forall y, x' [<] y -> x [<] y) -> x [=] x'. Proof. intros x x' H H0. apply leEq_imp_eq; rewrite -> leEq_def in |- *; intro H1. apply (less_irreflexive_unfolded _ x); auto. apply (less_irreflexive_unfolded _ x'); auto. Qed. Lemma less_leEq_trans : forall x y z : R, x [<] y -> y [<=] z -> x [<] z. Proof. intros x y z. intros H H0. elim (less_cotransitive_unfolded _ _ _ H z); intro H1. assumption. destruct (leEq_def _ y z). elim ((H2 H0) H1). Qed. Lemma leEq_less_trans : forall x y z : R, x [<=] y -> y [<] z -> x [<] z. Proof. intros x y z. intros H H0. elim (less_cotransitive_unfolded _ _ _ H0 x); intro H1; try assumption. destruct (leEq_def _ x y) as [H2 H3]. elim ((H2 H) H1). Qed. Lemma leEq_transitive : forall x y z : R, x [<=] y -> y [<=] z -> x [<=] z. Proof. intros x y z. repeat rewrite -> leEq_def. intros H H0 H1. apply H. apply leEq_less_trans with (y := z); firstorder using leEq_def. Qed. Lemma less_leEq : forall x y : R, x [<] y -> x [<=] y. Proof. intros. rewrite -> leEq_def. apply less_antisymmetric_unfolded. assumption. Qed. Lemma leEq_or_leEq : forall x y:R, Not (Not (x[<=]y or y[<=]x)). Proof. intros x y H. apply H. right. rewrite -> leEq_def. intros H0. apply H. left. apply less_leEq. assumption. Qed. Lemma leEq_less_or_equal : forall x y:R, x[<=]y -> Not (Not (x[<]y or x[=]y)). Proof. intros x y Hxy H. revert Hxy. rewrite -> leEq_def. intro Hxy. apply H. right. apply (not_ap_imp_eq). intros H0. destruct (ap_imp_less _ _ _ H0). apply H. left. assumption. apply Hxy. assumption. Qed. End Basic_Properties_of_leEq. #[global] Hint Resolve less_leEq : algebra. Declare Left Step leEq_wdl. Declare Right Step leEq_wdr. Section infinity_of_cordfields. (** ** Infinity of ordered fields In an ordered field we have that [[1][+][1]] and [[1][+][1][+][1]] and so on are all apart from zero. We first show this, so that we can define [TwoNZ], [ThreeNZ] and so on. These are elements of [Non[0]s], so that we can write e.g.%\% [x[/]TwoNZ]. *) Variable R : COrdField. Lemma pos_one : ([0]:R) [<] [1]. Proof. (* 0 [#] 1, so 0<1 (and we are done) or 1<0; so assume 1<0. *) elim (ap_imp_less _ _ _ (ring_non_triv R)). 2: auto. intro H. exfalso. apply (less_irreflexive_unfolded R [1]). apply less_transitive_unfolded with ([0]:R). auto. (* By plus_resp_less, 0=(1-1)<(0-1)=-1. *) cut (([0]:R) [<] [--][1]). 2: astepl (([1]:R)[+][--][1]). 2: astepr (([0]:R)[+][--][1]). 2: apply plus_resp_less_rht; auto. intro H0. (* By mult_resp_pos, 0<(-1).(-1)=1. *) rstepr ([--]([1]:R)[*][--][1]). apply (mult_resp_pos _ _ _ H0 H0). Qed. Lemma nring_less_succ : forall m : nat, (nring m:R) [<] nring (S m). Proof. intro m. simpl in |- *. astepr ([1][+]nring (R:=R) m). astepl ([0][+]nring (R:=R) m). apply plus_resp_less_rht. apply pos_one. Qed. Lemma nring_less : forall m n : nat, m < n -> (nring m:R) [<] nring n. Proof. intros m n H. generalize (toCProp_lt _ _ H); intro H0. elim H0. apply nring_less_succ. clear H0 H n; intros n H H0. apply less_transitive_unfolded with (nring (R:=R) n). assumption. apply nring_less_succ. Qed. Lemma nring_leEq : forall m n : nat, m <= n -> (nring m:R) [<=] nring n. Proof. intros m n H. elim (le_lt_eq_dec _ _ H); intro H1. rewrite -> leEq_def in |- *. apply less_antisymmetric_unfolded. apply nring_less. auto. rewrite H1. rewrite -> leEq_def in |- *. apply less_irreflexive_unfolded. Qed. Lemma nring_apart : forall m n : nat, m <> n -> (nring m:R) [#] nring n. Proof. intros m n H. elim (lt_eq_lt_dec m n); intro H0. elim H0; intro H1. apply less_imp_ap. apply nring_less. assumption. elim (H H1). apply Greater_imp_ap. apply nring_less. assumption. Qed. Lemma nring_ap_zero : forall n : nat, n <> 0 -> nring (R:=R) n [#] [0]. Proof. intros n H. exact (nring_apart _ _ H). Qed. Lemma nring_ap_zero' : forall n : nat, 0 <> n -> nring (R:=R) n [#] [0]. Proof. intros. apply nring_ap_zero; auto. Qed. Lemma nring_ap_zero_imp : forall n : nat, nring (R:=R) n [#] [0] -> 0 <> n. Proof. intros n H. induction n as [| n Hrecn]. simpl in H. elim (ap_irreflexive_unfolded _ _ H). apply O_S. Qed. Definition Snring (n : nat) := nring (R:=R) (S n). Load "Transparent_algebra". Lemma pos_Snring : forall n : nat, ([0]:R) [<] Snring n. Proof. intro n. apply less_leEq_trans with ([1]:R). apply pos_one. stepl (nring (R:=R) 1). 2: simpl in |- *; algebra. unfold Snring in |- *. apply nring_leEq. auto with arith. Qed. Lemma nringS_ap_zero : forall m : nat, nring (R:=R) (S m) [#] [0]. Proof. intros. apply pos_ap_zero. exact (pos_Snring m). Qed. Lemma nring_fac_ap_zero : forall n : nat, nring (R:=R) (fact n) [#] [0]. Proof. intro n; apply nring_ap_zero. cut (0 < fact n). lia. apply lt_O_fact. Qed. Load "Opaque_algebra". Section up_to_four. (** *** Properties of one up to four %\begin{nameconvention}% In the names of lemmas, we denote the numbers 0,1,2,3,4 and so on, by [zero], [one], [two] etc. %\end{nameconvention}% *) Lemma less_plusOne : forall x : R, x [<] x[+][1]. Proof. (* by plus_resp_less_rht and pos_one *) intros x. astepl ([0][+]x); astepr ([1][+]x). apply plus_resp_less_rht. exact pos_one. Qed. Lemma zero_lt_posplus1 : forall x : R, [0] [<=] x -> [0] [<] x[+][1]. Proof. intros x zltx. apply leEq_less_trans with x. assumption. exact (less_plusOne x). Qed. Lemma plus_one_ext_less : forall x y : R, x [<] y -> x [<] y[+][1]. Proof. (* By transitivity of less and less_plus[1] *) intros x y H. apply less_leEq_trans with y. assumption. apply less_leEq; apply less_plusOne. Qed. Lemma one_less_two : ([1]:R) [<] Two. Proof. simpl in |- *. astepr (([1]:R)[+][1]). apply less_plusOne. Qed. Lemma two_less_three : (Two:R) [<] Three. Proof. simpl in |- *. apply less_plusOne. Qed. Lemma three_less_four : (Three:R) [<] Four. Proof. simpl in |- *. apply less_plusOne. Qed. Lemma pos_two : ([0]:R) [<] Two. Proof. apply less_leEq_trans with ([1]:R). exact pos_one. apply less_leEq; exact one_less_two. Qed. Lemma one_less_three : ([1]:R) [<] Three. Proof. apply less_leEq_trans with (Two:R). exact one_less_two. apply less_leEq; exact two_less_three. Qed. Lemma two_less_four : (Two:R) [<] Four. Proof. apply less_leEq_trans with (Three:R). exact two_less_three. apply less_leEq; exact three_less_four. Qed. Lemma pos_three : ([0]:R) [<] Three. Proof. apply less_leEq_trans with ([1]:R). exact pos_one. apply less_leEq; exact one_less_three. Qed. Lemma one_less_four : ([1]:R) [<] Four. Proof. apply less_leEq_trans with (Three:R). exact one_less_three. apply less_leEq; exact three_less_four. Qed. Lemma pos_four : ([0]:R) [<] Four. Proof. apply less_leEq_trans with ([1]:R). exact pos_one. apply less_leEq; exact one_less_four. Qed. Lemma two_ap_zero : Two [#] ([0]:R). Proof. apply pos_ap_zero. apply pos_two. Qed. Lemma three_ap_zero : Three [#] ([0]:R). Proof. apply pos_ap_zero. apply pos_three. Qed. Lemma four_ap_zero : Four [#] ([0]:R). Proof. apply pos_ap_zero. apply pos_four. Qed. End up_to_four. Section More_than_four. (** *** Properties of some other numbers *) Lemma pos_six : ([0]:R) [<] Six. Proof. exact (pos_Snring 5). Qed. Lemma pos_eight : ([0]:R) [<] Eight. Proof. exact (pos_Snring 7). Qed. Lemma pos_nine : ([0]:R) [<] Nine. Proof. exact (pos_Snring 8). Qed. Lemma pos_twelve : ([0]:R) [<] Twelve. Proof. exact (pos_Snring 11). Qed. Lemma pos_sixteen : ([0]:R) [<] Sixteen. Proof. exact (pos_Snring 15). Qed. Lemma pos_eighteen : ([0]:R) [<] Eighteen. Proof. exact (pos_Snring 17). Qed. Lemma pos_twentyfour : ([0]:R) [<] TwentyFour. Proof. exact (pos_Snring 23). Qed. Lemma pos_fortyeight : ([0]:R) [<] FortyEight. Proof. exact (pos_Snring 47). Qed. Lemma six_ap_zero : Six [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_six. Qed. Lemma eight_ap_zero : Eight [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_eight. Qed. Lemma nine_ap_zero : Nine [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_nine. Qed. Lemma twelve_ap_zero : Twelve [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_twelve. Qed. Lemma sixteen_ap_zero : Sixteen [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_sixteen. Qed. Lemma eighteen_ap_zero : Eighteen [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_eighteen. Qed. Lemma twentyfour_ap_zero : TwentyFour [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_twentyfour. Qed. Lemma fortyeight_ap_zero : FortyEight [#] ([0]:R). Proof. apply pos_ap_zero; apply pos_fortyeight. Qed. End More_than_four. End infinity_of_cordfields. #[global] Hint Resolve pos_one : algebra. Declare Left Step leEq_wdl. Declare Right Step leEq_wdr. Notation " x [/]OneNZ" := (x[/] [1][//]ring_non_triv _) (at level 20). Notation " x [/]TwoNZ" := (x[/] Two[//]two_ap_zero _) (at level 20). Notation " x [/]ThreeNZ" := (x[/] Three[//]three_ap_zero _) (at level 20). Notation " x [/]FourNZ" := (x[/] Four[//]four_ap_zero _) (at level 20). Notation " x [/]SixNZ" := (x[/] Six[//]six_ap_zero _) (at level 20). Notation " x [/]EightNZ" := (x[/] Eight[//]eight_ap_zero _) (at level 20). Notation " x [/]NineNZ" := (x[/] Nine[//]nine_ap_zero _) (at level 20). Notation " x [/]TwelveNZ" := (x[/] Twelve[//]twelve_ap_zero _) (at level 20). Notation " x [/]SixteenNZ" := (x[/] Sixteen[//]sixteen_ap_zero _) (at level 20). Notation " x [/]EighteenNZ" := (x[/] Eighteen[//]eighteen_ap_zero _) (at level 20). Notation " x [/]TwentyFourNZ" := (x[/] TwentyFour[//]twentyfour_ap_zero _) (at level 20). Notation " x [/]FortyEightNZ" := (x[/] FortyEight[//]fortyeight_ap_zero _) (at level 20). Section consequences_of_infinity. (** *** Consequences of infinity *) Variable F : COrdField. Lemma square_eq : forall x a : F, a [#] [0] -> x[^]2 [=] a[^]2 -> {x [=] a} + {x [=] [--]a}. Proof. intros x a a_ H. elim (cond_square_eq F x a); auto. apply two_ap_zero. Qed. (** Ordered fields have characteristic zero. *) Lemma char0_OrdField : Char0 F. Proof. unfold Char0 in |- *. intros. apply nring_ap_zero. lia. Qed. End consequences_of_infinity. (*---------------------------------*) Section Properties_of_Ordering. (*---------------------------------*) (** ** Properties of [[<]] *) Variable R : COrdField. (** We do not use a special predicate for positivity, (e.g.%\% [PosP]), but just write [[0] [<] x]. Reasons: it is more natural; in ordinary mathematics we also write [[0] [<] x] (or [x [>] [0]]). *) Section addition. (** *** Addition and subtraction%\label{section:less_plus_minus}% *) Lemma plus_resp_less_lft : forall x y z : R, x [<] y -> z[+]x [<] z[+]y. Proof. intros x y z H. astepl (x[+]z). astepr (y[+]z). apply plus_resp_less_rht. assumption. Qed. Lemma inv_resp_less : forall x y : R, x [<] y -> [--]y [<] [--]x. Proof. intros x y H. rstepl (x[+]([--]x[+][--]y)). rstepr (y[+]([--]x[+][--]y)). apply plus_resp_less_rht. assumption. Qed. Lemma minus_resp_less : forall x y z : R, x [<] y -> x[-]z [<] y[-]z. Proof. Transparent cg_minus. unfold cg_minus in |- *. intros x y z H. apply plus_resp_less_rht. assumption. Qed. Lemma minus_resp_less_rht : forall x y z : R, y [<] x -> z[-]x [<] z[-]y. Proof. intros. Transparent cg_minus. unfold cg_minus in |- *. apply plus_resp_less_lft. apply inv_resp_less. assumption. Qed. Lemma plus_resp_less_both : forall a b c d : R, a [<] b -> c [<] d -> a[+]c [<] b[+]d. Proof. intros. apply less_leEq_trans with (a[+]d). apply plus_resp_less_lft. assumption. apply less_leEq. apply plus_resp_less_rht. assumption. Qed. (** For versions of [plus_resp_less_both] where one [ [<] ] in the assumption is replaced by [ [<=] ]%, see Section~\ref{section:leEq-plus-minus}%. Cancellation laws *) Lemma plus_cancel_less : forall x y z : R, x[+]z [<] y[+]z -> x [<] y. Proof. intros. (* astepl (x[+][0]). astepl (x[+](z[+]([--] z))). *) rstepl (x[+]z[+][--]z). (* astepr (y[+][0]). astepr (y[+](z[+]([--] z))). *) rstepr (y[+]z[+][--]z). apply plus_resp_less_rht. assumption. Qed. Lemma inv_cancel_less : forall x y : R, [--]x [<] [--]y -> y [<] x. Proof. intros. apply plus_cancel_less with ([--]x[-]y). rstepl ([--]x). rstepr ([--]y). assumption. Qed. (** Lemmas where an operation is transformed into the inverse operation on the other side of an inequality are called laws for shifting. %\begin{nameconvention}% The names of laws for shifting start with [shift_], and then come the operation and the inequality, in the order in which they occur in the conclusion. If the shifted operand changes sides w.r.t.%\% the operation and its inverse, the name gets a prime. %\end{nameconvention}% It would be nicer to write the laws for shifting as bi-implications, However, it is impractical to use these in Coq%(see the Coq shortcoming in Section~\ref{section:setoid-basics})%. *) Lemma shift_less_plus : forall x y z : R, x[-]z [<] y -> x [<] y[+]z. Proof. intros. rstepl (x[-]z[+]z). apply plus_resp_less_rht. assumption. Qed. Lemma shift_less_plus' : forall x y z : R, x[-]y [<] z -> x [<] y[+]z. Proof. intros. astepr (z[+]y). apply shift_less_plus. assumption. Qed. Lemma shift_less_minus : forall x y z : R, x[+]z [<] y -> x [<] y[-]z. Proof. intros. rstepl (x[+]z[-]z). apply minus_resp_less. assumption. Qed. Lemma shift_less_minus' : forall x y z : R, z[+]x [<] y -> x [<] y[-]z. Proof. intros. apply shift_less_minus. astepl (z[+]x). assumption. Qed. Lemma shift_plus_less : forall x y z : R, x [<] z[-]y -> x[+]y [<] z. Proof. intros. rstepr (z[-]y[+]y). apply plus_resp_less_rht. assumption. Qed. Lemma shift_plus_less' : forall x y z : R, y [<] z[-]x -> x[+]y [<] z. Proof. intros. astepl (y[+]x). apply shift_plus_less. assumption. Qed. Lemma shift_minus_less : forall x y z : R, x [<] z[+]y -> x[-]y [<] z. Proof. intros. astepr (z[+]y[-]y). apply minus_resp_less. assumption. Qed. Lemma shift_minus_less' : forall x y z : R, x [<] y[+]z -> x[-]y [<] z. Proof. intros. apply shift_minus_less. astepr (y[+]z). assumption. Qed. (** Some special cases of laws for shifting. *) Lemma shift_zero_less_minus : forall x y : R, x [<] y -> [0] [<] y[-]x. Proof. intros. rstepl (x[-]x). apply minus_resp_less. assumption. Qed. Lemma shift_zero_less_minus' : forall x y : R, [0] [<] y[-]x -> x [<] y. Proof. intros. apply plus_cancel_less with ([--]x). rstepl ([0]:R). assumption. Qed. Lemma qltone : forall q : R, q [<] [1] -> q[-][1] [#] [0]. Proof. intros. apply less_imp_ap. apply shift_minus_less. astepr ([1]:R). auto. Qed. End addition. Section multiplication. (** *** Multiplication and division By Convention%~\ref{convention:div-form}% in CFields% (Section~\ref{section:fields})%, we often have redundant premises in lemmas. E.g.%\% the informal statement ``for all [x,y : R] with [[0] [<] x] and [[0] [<] y] we have [[0] [<] y[/]x]'' is formalized as follows. [[ forall (x y : R) x_, ([0] [<] x) -> ([0] [<] y) -> ([0] [<] y[/]x[//]H) ]] We do this to keep it easy to use such lemmas. *) Lemma mult_resp_less : forall x y z : R, x [<] y -> [0] [<] z -> x[*]z [<] y[*]z. Proof. intros. apply plus_cancel_less with ([--](x[*]z)). astepl ([0]:R). (* astepr ((y[*]z)[-](x[*]z)). *) rstepr ((y[-]x)[*]z). apply mult_resp_pos. astepl (x[-]x). apply minus_resp_less. assumption. assumption. Qed. Lemma recip_resp_pos : forall (y : R) y_, [0] [<] y -> [0] [<] ([1][/] y[//]y_). Proof. intros. cut ([0] [<] ([1][/] y[//]y_) or ([1][/] y[//]y_) [<] [0]). intros H0. elim H0; clear H0; intros H0. auto. exfalso. apply (less_irreflexive_unfolded R [0]). eapply less_transitive_unfolded. 2: apply H0. cut ([1] [<] ([0]:R)). intro H1. elim (less_antisymmetric_unfolded _ _ _ (pos_one _) H1). astepl ([--]([--][1]:R)). astepr ([--]([0]:R)). apply inv_resp_less. rstepr (y[*][--]([1][/] y[//]y_)). apply mult_resp_pos. auto. astepl ([--]([0]:R)). apply inv_resp_less. auto. apply ap_imp_less. apply ap_symmetric_unfolded. apply div_resp_ap_zero_rev. apply ring_non_triv. Qed. Lemma div_resp_less_rht : forall (x y z : R) z_, x [<] y -> [0] [<] z -> (x[/] z[//]z_) [<] (y[/] z[//]z_). Proof. intros. rstepl (x[*]([1][/] z[//]z_)). rstepr (y[*]([1][/] z[//]z_)). apply mult_resp_less. auto. apply recip_resp_pos. auto. Qed. Lemma div_resp_pos : forall (x y : R) x_, [0] [<] x -> [0] [<] y -> [0] [<] (y[/] x[//]x_). Proof. intros. astepl ([0][/] x[//]x_). apply div_resp_less_rht; auto. Qed. Lemma mult_resp_less_lft : forall x y z : R, x [<] y -> [0] [<] z -> z[*]x [<] z[*]y. Proof. intros. astepl (x[*]z). astepr (y[*]z). apply mult_resp_less. assumption. assumption. Qed. Lemma mult_resp_less_both : forall x y u v : R, [0] [<=] x -> x [<] y -> [0] [<=] u -> u [<] v -> x[*]u [<] y[*]v. Proof. cut (forall x y z : R, x [<=] y -> [0] [<=] z -> x[*]z [<=] y[*]z). intro resp_leEq. intros. apply leEq_less_trans with (y[*]u). apply resp_leEq; auto. apply less_leEq; auto. apply mult_resp_less_lft; auto. apply leEq_less_trans with x; auto. (* Cut *) intros x y z. repeat rewrite -> leEq_def in |- *. intros H H0 H1. generalize (shift_zero_less_minus _ _ H1); intro H2. cut ([0] [<] (x[-]y)[*]z). intro H3. 2: rstepr (x[*]z[-]y[*]z); auto. cut (forall a b : R, [0] [<] a[*]b -> [0] [<] a and [0] [<] b or a [<] [0] and b [<] [0]). intro H4. generalize (H4 _ _ H3); intro H5. elim H5; intro H6; elim H6; intros H7 H8. apply H. astepl ([0][+]y). apply shift_plus_less. assumption. apply H0. assumption. intros a b H4. generalize (Greater_imp_ap _ _ _ H4); intro H5. generalize (mult_cancel_ap_zero_lft _ _ _ H5); intro H6. generalize (mult_cancel_ap_zero_rht _ _ _ H5); intro H7. elim (ap_imp_less _ _ _ H6); intro H8. right. split; auto. elim (ap_imp_less _ _ _ H7); auto. intro H9. exfalso. apply (less_irreflexive_unfolded R [0]). apply less_leEq_trans with (a[*]b); auto. apply less_leEq. apply inv_cancel_less. astepl ([0]:R). astepr ([--]a[*]b). apply mult_resp_pos; auto. astepl ([--]([0]:R)). apply inv_resp_less; auto. left. split; auto. elim (ap_imp_less _ _ _ H7); auto. intro H9. exfalso. apply (less_irreflexive_unfolded R [0]). apply less_leEq_trans with (a[*]b); auto. apply less_leEq. apply inv_cancel_less. astepl ([0]:R). astepr (a[*][--]b). apply mult_resp_pos; auto. astepl ([--]([0]:R)). apply inv_resp_less; auto. Qed. Lemma recip_resp_less : forall (x y : R) x_ y_, [0] [<] x -> x [<] y -> ([1][/] y[//]y_) [<] ([1][/] x[//]x_). Proof. intros. cut ([0] [<] x[*]y). intro. cut (x[*]y [#] [0]). intro H2. rstepl (x[*]([1][/] x[*]y[//]H2)). rstepr (y[*]([1][/] x[*]y[//]H2)). apply mult_resp_less. auto. apply recip_resp_pos. auto. apply Greater_imp_ap. auto. apply mult_resp_pos. auto. apply less_leEq_trans with x; try apply less_leEq; auto. Qed. Lemma div_resp_less : forall (x y z : R) z_, [0] [<] z -> x [<] y -> (x[/] z[//]z_) [<] (y[/] z[//]z_). Proof. intros. rstepl (x[*]([1][/] z[//]z_)). rstepr (y[*]([1][/] z[//]z_)). apply mult_resp_less. assumption. apply recip_resp_pos. auto. Qed. (** Cancellation laws *) Lemma mult_cancel_less : forall x y z : R, [0] [<] z -> x[*]z [<] y[*]z -> x [<] y. Proof. intros x y z H H0. generalize (Greater_imp_ap _ _ _ H); intro H1. rstepl (x[*]z[*]([1][/] z[//]H1)). rstepr (y[*]z[*]([1][/] z[//]H1)). apply mult_resp_less. assumption. rstepl ([0][/] z[//]H1). apply div_resp_less_rht. apply pos_one. assumption. Qed. (** Laws for shifting %For namegiving, see the Section~\ref{section:less_plus_minus} on plus and minus.% *) Lemma shift_div_less : forall (x y z : R) y_, [0] [<] y -> x [<] z[*]y -> (x[/] y[//]y_) [<] z. Proof. intros. apply mult_cancel_less with y. auto. astepl x. auto. Qed. Lemma shift_div_less' : forall (x y z : R) y_, [0] [<] y -> x [<] y[*]z -> (x[/] y[//]y_) [<] z. Proof. intros. apply shift_div_less; auto. astepr (y[*]z). auto. Qed. Lemma shift_less_div : forall (x y z : R) y_, [0] [<] y -> x[*]y [<] z -> x [<] (z[/] y[//]y_). Proof. intros. apply mult_cancel_less with y. auto. astepr z. auto. Qed. Lemma shift_less_mult : forall (x y z : R) z_, [0] [<] z -> (x[/] z[//]z_) [<] y -> x [<] y[*]z. Proof. intros. astepl ((x[/] z[//]z_)[*]z). apply mult_resp_less; auto. Qed. Lemma shift_less_mult' : forall (x y z : R) y_, [0] [<] y -> (x[/] y[//]y_) [<] z -> x [<] y[*]z. Proof. intros. astepl (y[*](x[/] y[//]y_)). apply mult_resp_less_lft; auto. Qed. Lemma shift_mult_less : forall (x y z : R) y_, [0] [<] y -> x [<] (z[/] y[//]y_) -> x[*]y [<] z. Proof. intros. astepr ((z[/] y[//]y_)[*]y). apply mult_resp_less; auto. Qed. (** Other properties of multiplication and division *) Lemma minusOne_less : forall x : R, x[-][1] [<] x. Proof. intros; apply shift_minus_less; apply less_plusOne. Qed. Lemma swap_div : forall (x y z : R) y_ z_, [0] [<] y -> [0] [<] z -> (x[/] z[//]z_) [<] y -> (x[/] y[//]y_) [<] z. Proof. intros. rstepl ((x[/] z[//]z_)[*](z[/] y[//]y_)). astepr (y[*](z[/] y[//]y_)). apply mult_resp_less. auto. apply div_resp_pos; auto. Qed. Lemma eps_div_less_eps : forall (eps d : R) d_, [0] [<] eps -> [1] [<] d -> (eps[/] d[//]d_) [<] eps. Proof. intros. apply shift_div_less'. apply leEq_less_trans with ([1]:R). apply less_leEq; apply pos_one. assumption. astepl ([1][*]eps). apply mult_resp_less. assumption. assumption. Qed. Lemma pos_div_two : forall eps : R, [0] [<] eps -> [0] [<] eps [/]TwoNZ. Proof. intros. apply shift_less_div. apply pos_two. astepl ([0]:R). assumption. Qed. Lemma pos_div_two' : forall eps : R, [0] [<] eps -> eps [/]TwoNZ [<] eps. Proof. intros. apply plus_cancel_less with ([--](eps [/]TwoNZ)). astepl ([0]:R). rstepr (eps [/]TwoNZ). apply pos_div_two; assumption. Qed. (* Apply mult_cancel_less with (Two::R). Apply pos_two. rstepl eps[+][0]; rstepr eps[+]eps. Apply plus_resp_less_lft. Auto. Qed. *) Lemma pos_div_three : forall eps : R, [0] [<] eps -> [0] [<] eps [/]ThreeNZ. Proof. intros. apply mult_cancel_less with (Three:R). apply pos_three. astepl ([0]:R); rstepr eps. assumption. Qed. Lemma pos_div_three' : forall eps : R, [0] [<] eps -> eps [/]ThreeNZ [<] eps. Proof. intros. apply mult_cancel_less with (Three:R). apply pos_three. rstepl (eps[+][0]); rstepr (eps[+]Two[*]eps). apply plus_resp_less_lft. apply mult_resp_pos; auto. apply pos_two. Qed. Lemma pos_div_four : forall eps : R, [0] [<] eps -> [0] [<] eps [/]FourNZ. Proof. intros. rstepr ((eps [/]TwoNZ) [/]TwoNZ). apply pos_div_two; apply pos_div_two; assumption. Qed. Lemma pos_div_four' : forall eps : R, [0] [<] eps -> eps [/]FourNZ [<] eps. Proof. intros. rstepl ((eps [/]TwoNZ) [/]TwoNZ). apply leEq_less_trans with (eps [/]TwoNZ). 2: apply pos_div_two'; assumption. apply less_leEq. apply pos_div_two'. apply pos_div_two. assumption. Qed. Lemma pos_div_six : forall eps : R, [0] [<] eps -> [0] [<] eps [/]SixNZ. Proof. intros. apply shift_less_div. apply pos_six. astepl ([0]:R). assumption. Qed. Lemma pos_div_eight : forall eps : R, [0] [<] eps -> [0] [<] eps [/]EightNZ. Proof. intros. apply shift_less_div. apply pos_eight. astepl ([0]:R). assumption. Qed. Lemma pos_div_nine : forall eps : R, [0] [<] eps -> [0] [<] eps [/]NineNZ. Proof. intros. apply shift_less_div. apply pos_nine. astepl ([0]:R). assumption. Qed. Lemma pos_div_twelve : forall eps : R, [0] [<] eps -> [0] [<] eps [/]TwelveNZ. Proof. intros. apply shift_less_div. apply pos_twelve. astepl ([0]:R). assumption. Qed. Lemma pos_div_sixteen : forall eps : R, [0] [<] eps -> [0] [<] eps [/]SixteenNZ. Proof. intros. apply shift_less_div. apply pos_sixteen. astepl ([0]:R). assumption. Qed. Lemma pos_div_eighteen : forall eps : R, [0] [<] eps -> [0] [<] eps [/]EighteenNZ. Proof. intros. apply shift_less_div. apply pos_eighteen. astepl ([0]:R). assumption. Qed. Lemma pos_div_twentyfour : forall eps : R, [0] [<] eps -> [0] [<] eps [/]TwentyFourNZ. Proof. intros. apply shift_less_div. apply pos_twentyfour. astepl ([0]:R). assumption. Qed. Lemma pos_div_fortyeight : forall eps : R, [0] [<] eps -> [0] [<] eps [/]FortyEightNZ. Proof. intros. apply shift_less_div. apply pos_fortyeight. astepl ([0]:R). assumption. Qed. End multiplication. Section misc. (** *** Miscellaneous properties *) Lemma nring_pos : forall m : nat, 0 < m -> [0] [<] nring (R:=R) m. Proof. intro m. elim m. intro; elim (Nat.lt_irrefl 0 H). clear m; intros. apply leEq_less_trans with (nring (R:=R) n). astepl (nring (R:=R) 0). apply nring_leEq; auto with arith. simpl in |- *; apply less_plusOne. Qed. Lemma less_nring : forall n m : nat, nring (R:=R) n [<] nring m -> n < m. Proof. intro n; induction n as [| n Hrecn]. intros m H. induction m as [| m Hrecm]. exfalso; generalize H; apply less_irreflexive_unfolded. auto with arith. intros m H. induction m as [| m Hrecm]. exfalso. cut (nring (R:=R) 0 [<] nring (S n)). apply less_antisymmetric_unfolded; assumption. apply nring_less; auto with arith. cut (n < m). auto with arith. apply Hrecn. rstepr (nring (R:=R) m[+][1][-][1]). apply shift_less_minus. apply H. Qed. Lemma pos_nring_fac : forall n : nat, [0] [<] nring (R:=R) (fact n). Proof. intro. astepl (nring (R:=R) 0). apply nring_less. apply lt_O_fact. Qed. Lemma Smallest_less_Average : forall a b : R, a [<] b -> a [<] (a[+]b) [/]TwoNZ. Proof. intros. apply shift_less_div. apply pos_two. rstepl (a[+]a). apply plus_resp_less_lft. assumption. Qed. Lemma Average_less_Greatest : forall a b : R, a [<] b -> (a[+]b) [/]TwoNZ [<] b. Proof. intros. apply shift_div_less'. apply pos_two. rstepr (b[+]b). apply plus_resp_less_rht. assumption. Qed. Lemma Sum_resp_less : forall (f g : nat -> R) a b, a <= b -> (forall i, a <= i -> i <= b -> f i [<] g i) -> Sum a b f [<] Sum a b g. Proof. intros. induction b as [| b Hrecb]; intros. replace a with 0. astepl (f 0). astepr (g 0). auto. inversion H. auto. elim (le_lt_eq_dec _ _ H); intro H1. apply less_wdl with (Sum a b f[+]f (S b)). apply less_wdr with (Sum a b g[+]g (S b)). apply plus_resp_less_both. apply Hrecb. auto with arith. auto. apply X; auto. apply eq_symmetric_unfolded. apply Sum_last. apply eq_symmetric_unfolded. apply Sum_last. rewrite H1. astepl (f (S b)). astepr (g (S b)). apply X; auto. Qed. Lemma Sumx_resp_less : forall n, 0 < n -> forall f g : forall i, i < n -> R, (forall i H, f i H [<] g i H) -> Sumx f [<] Sumx g. Proof. simple induction n. intros; simpl in |- *; exfalso; inversion H. simple induction n0. intros. clear H. simpl in |- *; apply plus_resp_less_lft. apply X0. intros. simpl in |- *. apply plus_resp_less_both. astepl (Sumx (fun (i : nat) (l : i < S n1) => f i (Nat.lt_lt_succ_r _ _ l))). astepr (Sumx (fun (i : nat) (l : i < S n1) => g i (Nat.lt_lt_succ_r _ _ l))). apply X0. auto with arith. intros. apply X1. apply X1. Qed. Lemma positive_Sum_two : forall x y : R, [0] [<] x[+]y -> [0] [<] x or [0] [<] y. Proof. intros. cut ([--]x [<] [0] or [0] [<] y). intro; inversion_clear X0. left; astepl ([--]([0]:R)); astepr ([--][--]x); apply inv_resp_less; assumption. right; assumption. apply less_cotransitive_unfolded. astepl ([0][-]x); apply shift_minus_less'; assumption. Qed. Lemma positive_Sumx : forall n (f : forall i, i < n -> R), nat_less_n_fun f -> [0] [<] Sumx f -> {i : nat | {H : i < n | [0] [<] f i H}}. Proof. simple induction n. simpl in |- *. intros; exfalso; generalize X; apply less_irreflexive_unfolded. simple induction n0. simpl in |- *. intros. exists 0. exists (Nat.lt_succ_diag_r 0). eapply less_wdr. apply X0. astepl (f _ (Nat.lt_succ_diag_r 0)). apply H; auto. simpl in |- *; intros. clear X. cut ([0] [<] f _ (Nat.lt_succ_diag_r (S n1)) or [0] [<] Sumx (fun (i : nat) (l : i < n1) => f i (Nat.lt_lt_succ_r i (S n1) (Nat.lt_lt_succ_r i n1 l)))[+] f n1 (Nat.lt_lt_succ_r n1 (S n1) (Nat.lt_succ_diag_r n1))). intro X. inversion_clear X. exists (S n1). exists (Nat.lt_succ_diag_r (S n1)). eapply less_wdr. apply X2. apply H; auto. set (f' := fun (i : nat) (H : i < S n1) => f i (Nat.lt_lt_succ_r _ _ H)) in *. cut {i : nat | {H : i < S n1 | [0] [<] f' i H}}; intros. elim X; intros i Hi; elim Hi; clear X2 Hi; intros Hi Hi'. exists i. exists (Nat.lt_lt_succ_r _ _ Hi). eapply less_wdr. apply Hi'. unfold f' in |- *; simpl in |- *. apply H; auto. apply X0. red in |- *. intros i j Hij. rewrite Hij. unfold f' in |- *. intros H0 H'. apply H; auto. apply X2; assumption. apply positive_Sum_two. eapply less_wdr. 2: apply cag_commutes_unfolded. assumption. Qed. Lemma negative_Sumx : forall n (f : forall i, i < n -> R), nat_less_n_fun f -> Sumx f [<] [0] -> {i : nat | {H : i < n | f i H [<] [0]}}. Proof. intros. cut {i : nat | {H : i < n | [0] [<] [--](f i H)}}. intro H1. elim H1; intros i Hi; elim Hi; clear X Hi; intros Hi Hi'. exists i; exists Hi. astepl ([--][--](f i Hi)); astepr ([--]([0]:R)); apply inv_resp_less; assumption. apply positive_Sumx with (f := fun (i : nat) (H : i < n) => [--](f i H)). red in |- *; intros. apply un_op_wd_unfolded; apply H; assumption. astepl ([--]([0]:R)); apply less_wdr with ([--](Sumx f)). apply inv_resp_less; assumption. generalize f H; clear X H f. induction n as [| n Hrecn]. simpl in |- *. intros; algebra. intros. simpl in |- *. rstepl ([--](Sumx (fun (i : nat) (l : i < n) => f i (Nat.lt_lt_succ_r i n l)))[+] [--](f n (Nat.lt_succ_diag_r n))). apply bin_op_wd_unfolded. 2: algebra. apply Hrecn with (f := fun (i : nat) (l : i < n) => f i (Nat.lt_lt_succ_r i n l)). red in |- *; intros; apply H; auto. Qed. End misc. End Properties_of_Ordering. Add Parametric Morphism c : (@cof_leEq c) with signature (@cs_eq (cof_crr c)) ==> (@cs_eq c) ==> iff as cof_leEq_wd. Proof with try assumption. intros x1 x2 Hx y1 y2 Hy. split; intros. stepl x1... stepr y1... symmetry in Hx, Hy. stepl x2... stepr y2... Qed. corn-8.20.0/algebra/COrdFields2.v000066400000000000000000000704641473720167500164150ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.COrdFields. From Coq Require Import Lia. (** printing one_div_succ %\ensuremath{\frac1{\cdot+1}}% *) (** printing Half %\ensuremath{\frac12}% #½# *) (*---------------------------------*) Section Properties_of_leEq. (*---------------------------------*) (** ** Properties of [[<=]] %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. Section addition. (** *** Addition and subtraction%\label{section:leEq-plus-minus}% *) Lemma plus_resp_leEq : forall x y z : R, x [<=] y -> x[+]z [<=] y[+]z. Proof. intros x y z. do 2 rewrite -> leEq_def. intros. intro. apply H. apply (plus_cancel_less _ _ _ _ X). Qed. Lemma plus_resp_leEq_lft : forall x y z : R, x [<=] y -> z[+]x [<=] z[+]y. Proof. intros. astepl (x[+]z). astepr (y[+]z). apply plus_resp_leEq; auto. Qed. Lemma minus_resp_leEq : forall x y z : R, x [<=] y -> x[-]z [<=] y[-]z. Proof. intros. astepl (x[+][--]z). astepr (y[+][--]z). apply plus_resp_leEq; auto. Qed. Lemma inv_resp_leEq : forall x y : R, x [<=] y -> [--]y [<=] [--]x. Proof. intros x y. repeat rewrite -> leEq_def. do 2 intro. apply H. apply inv_cancel_less. assumption. Qed. Lemma minus_resp_leEq_rht : forall x y z : R, y [<=] x -> z[-]x [<=] z[-]y. Proof. intros. Transparent cg_minus. unfold cg_minus in |- *. apply plus_resp_leEq_lft. apply inv_resp_leEq. assumption. Qed. Lemma plus_resp_leEq_both : forall x y a b : R, x [<=] y -> a [<=] b -> x[+]a [<=] y[+]b. Proof. intros. apply leEq_transitive with (y := x[+]b). rstepl (a[+]x). rstepr (b[+]x). apply plus_resp_leEq. assumption. apply plus_resp_leEq. assumption. Qed. Lemma plus_resp_less_leEq : forall a b c d : R, a [<] b -> c [<=] d -> a[+]c [<] b[+]d. Proof. intros. apply leEq_less_trans with (a[+]d). apply plus_resp_leEq_lft. auto. apply plus_resp_less_rht. auto. Qed. Lemma plus_resp_leEq_less : forall a b c d : R, a [<=] b -> c [<] d -> a[+]c [<] b[+]d. Proof. intros. astepl (c[+]a). astepr (d[+]b). apply plus_resp_less_leEq; auto. Qed. Lemma plus_resp_nonneg : forall x y : R, [0] [<=] x -> [0] [<=] y -> [0] [<=] x[+]y. Proof. intros. astepl ([0][+][0]:R). apply plus_resp_leEq_both; auto. Qed. Lemma minus_resp_less_leEq : forall x y x' y' : R, x [<=] y -> y' [<] x' -> x[-]x' [<] y[-]y'. Proof. intros. astepl (x[+][--]x'). astepr (y[+][--]y'). apply plus_resp_leEq_less. auto. apply inv_resp_less. auto. Qed. Lemma minus_resp_leEq_both : forall x y x' y' : R, x [<=] y -> y' [<=] x' -> x[-]x' [<=] y[-]y'. Proof. intros. astepl (x[+][--]x'). astepr (y[+][--]y'). apply plus_resp_leEq_both. auto. apply inv_resp_leEq. auto. Qed. (** Cancellation properties *) Lemma plus_cancel_leEq_rht : forall x y z : R, x[+]z [<=] y[+]z -> x [<=] y. Proof. intros. rstepl (x[+]z[+][--]z). rstepr (y[+]z[+][--]z). apply plus_resp_leEq. assumption. Qed. Lemma inv_cancel_leEq : forall x y : R, [--]y [<=] [--]x -> x [<=] y. Proof. intros. rstepl ([--][--]x). rstepr ([--][--]y). apply inv_resp_leEq. assumption. Qed. (** Laws for shifting *) Lemma shift_plus_leEq : forall a b c : R, a [<=] c[-]b -> a[+]b [<=] c. Proof. intros. rstepr (c[-]b[+]b). apply plus_resp_leEq. assumption. Qed. Lemma shift_leEq_plus : forall a b c : R, a[-]b [<=] c -> a [<=] c[+]b. Proof. intros. rstepl (a[-]b[+]b). apply plus_resp_leEq. assumption. Qed. Lemma shift_plus_leEq' : forall a b c : R, b [<=] c[-]a -> a[+]b [<=] c. Proof. intros. rstepr (a[+] (c[-]a)). apply plus_resp_leEq_lft. assumption. Qed. Lemma shift_leEq_plus' : forall a b c : R, a[-]b [<=] c -> a [<=] b[+]c. Proof. intros. rstepl (b[+] (a[-]b)). apply plus_resp_leEq_lft. auto. Qed. Lemma shift_leEq_rht : forall a b : R, [0] [<=] b[-]a -> a [<=] b. Proof. intros. astepl ([0][+]a). rstepr (b[-]a[+]a). apply plus_resp_leEq. auto. Qed. Lemma shift_leEq_lft : forall a b : R, a [<=] b -> [0] [<=] b[-]a. Proof. intros. astepl (a[-]a). apply minus_resp_leEq. auto. Qed. Lemma shift_minus_leEq : forall a b c : R, a [<=] c[+]b -> a[-]b [<=] c. Proof. intros. rstepr (c[+]b[-]b). apply minus_resp_leEq. assumption. Qed. Lemma shift_leEq_minus : forall a b c : R, a[+]c [<=] b -> a [<=] b[-]c. Proof. intros. rstepl (a[+]c[-]c). apply minus_resp_leEq. assumption. Qed. Lemma shift_leEq_minus' : forall a b c : R, c[+]a [<=] b -> a [<=] b[-]c. Proof. intros. rstepl (c[+]a[-]c). apply minus_resp_leEq. assumption. Qed. Lemma shift_zero_leEq_minus : forall x y : R, x [<=] y -> [0] [<=] y[-]x. Proof. intros. rstepl (x[-]x). apply minus_resp_leEq. assumption. Qed. Lemma shift_zero_leEq_minus' : forall x y : R, [0] [<=] y[-]x -> x [<=] y. Proof. intros. apply plus_cancel_leEq_rht with ([--]x). rstepl ([0]:R). assumption. Qed. End addition. Section multiplication. (** *** Multiplication and division Multiplication and division respect [[<=]] *) Lemma mult_resp_leEq_rht : forall x y z : R, x [<=] y -> [0] [<=] z -> x[*]z [<=] y[*]z. Proof. intros x y z . repeat rewrite -> leEq_def. intros H H0 H1. generalize (shift_zero_less_minus _ _ _ H1); intro H2. cut ([0] [<] (x[-]y) [*]z). intro H3. 2: rstepr (x[*]z[-]y[*]z). 2: assumption. cut (forall a b : R, [0] [<] a[*]b -> [0] [<] a and [0] [<] b or a [<] [0] and b [<] [0]). intro H4. generalize (H4 _ _ H3); intro H5. elim H5; intro H6. elim H6; intros. elim H. astepl ([0][+]y). apply shift_plus_less. assumption. elim H6; intros. elim H0. assumption. intros a b H4. generalize (Greater_imp_ap _ _ _ H4); intro H5. generalize (mult_cancel_ap_zero_lft _ _ _ H5); intro H6. generalize (mult_cancel_ap_zero_rht _ _ _ H5); intro H7. elim (ap_imp_less _ _ _ H6); intro H8. right. split. assumption. elim (ap_imp_less _ _ _ H7); intro H9. assumption. exfalso. elim (less_irreflexive_unfolded R [0]). apply less_leEq_trans with (a[*]b). assumption. apply less_leEq. apply inv_cancel_less. astepl ([0]:R). astepr ([--]a[*]b). apply mult_resp_pos. astepl ([--]([0]:R)). apply inv_resp_less. assumption. assumption. left. split. assumption. elim (ap_imp_less _ _ _ H7); intro H9. exfalso. elim (less_irreflexive_unfolded R [0]). apply less_leEq_trans with (a[*]b). assumption. apply less_leEq. apply inv_cancel_less. astepl ([0]:R). astepr (a[*][--]b). apply mult_resp_pos. assumption. astepl ([--]([0]:R)). apply inv_resp_less. assumption. assumption. Qed. Lemma mult_resp_leEq_lft : forall x y z : R, x [<=] y -> [0] [<=] z -> z[*]x [<=] z[*]y. Proof. intros. astepl (x[*]z). astepr (y[*]z). apply mult_resp_leEq_rht. assumption. assumption. Qed. Lemma mult_resp_leEq_both : forall x x' y y' : R, [0] [<=] x -> [0] [<=] y -> x [<=] x' -> y [<=] y' -> x[*]y [<=] x'[*]y'. Proof. intros. apply leEq_transitive with (x[*]y'). apply mult_resp_leEq_lft; assumption. apply mult_resp_leEq_rht. assumption. apply leEq_transitive with y; assumption. Qed. Lemma recip_resp_leEq : forall (x y : R) x_ y_, [0] [<] y -> y [<=] x -> ([1][/] x[//]x_) [<=] ([1][/] y[//]y_). Proof. intros x y x_ y_ H. do 2 rewrite -> leEq_def. intros H0 H1. apply H0. cut (([1][/] x[//]x_) [#] [0]). intro x'_. cut (([1][/] y[//]y_) [#] [0]). intro y'_. rstepl ([1][/] [1][/] x[//]x_[//]x'_). rstepr ([1][/] [1][/] y[//]y_[//]y'_). apply recip_resp_less. apply recip_resp_pos; auto. auto. apply div_resp_ap_zero_rev. apply ring_non_triv. apply div_resp_ap_zero_rev. apply ring_non_triv. Qed. Lemma div_resp_leEq : forall (x y z : R) z_, [0] [<] z -> x [<=] y -> (x[/] z[//]z_) [<=] (y[/] z[//]z_). Proof. intros. rstepl (x[*] ([1][/] z[//]z_)). rstepr (y[*] ([1][/] z[//]z_)). apply mult_resp_leEq_rht. assumption. apply less_leEq. apply recip_resp_pos. auto. Qed. Hint Resolve recip_resp_leEq: algebra. (** Cancellation properties *) Lemma mult_cancel_leEq : forall x y z : R, [0] [<] z -> x[*]z [<=] y[*]z -> x [<=] y. Proof. intros x y z H. do 2 rewrite -> leEq_def. intros H0 H1. apply H0. apply mult_resp_less. assumption. assumption. Qed. (** Laws for shifting *) Lemma shift_mult_leEq : forall (x y z : R) z_, [0] [<] z -> x [<=] (y[/] z[//]z_) -> x[*]z [<=] y. Proof. intros. rstepr ((y[/] z[//]z_) [*]z). apply mult_resp_leEq_rht; [ assumption | apply less_leEq; assumption ]. Qed. Lemma shift_mult_leEq' : forall (x y z : R) z_, [0] [<] z -> x [<=] (y[/] z[//]z_) -> z[*]x [<=] y. Proof. intros. rstepr (z[*] (y[/] z[//]z_)). apply mult_resp_leEq_lft; [ assumption | apply less_leEq; assumption ]. Qed. Lemma shift_leEq_mult' : forall (x y z : R) y_, [0] [<] y -> (x[/] y[//]y_) [<=] z -> x [<=] y[*]z. Proof. intros x y z H H0. repeat rewrite -> leEq_def. intros H1 H2. apply H1. apply shift_less_div. auto. astepl (y[*]z). auto. Qed. Lemma shift_div_leEq : forall x y z : R, [0] [<] z -> forall z_ : z [#] [0], x [<=] y[*]z -> (x[/] z[//]z_) [<=] y. Proof. intros. rstepr (y[*]z[/] z[//]z_). apply div_resp_leEq. assumption. assumption. Qed. Lemma shift_div_leEq' : forall (x y z : R) z_, [0] [<] z -> x [<=] z[*]y -> (x[/] z[//]z_) [<=] y. Proof. intros. rstepr (z[*]y[/] z[//]z_). apply div_resp_leEq. assumption. assumption. Qed. Lemma shift_leEq_div : forall (x y z : R) y_, [0] [<] y -> x[*]y [<=] z -> x [<=] (z[/] y[//]y_). Proof. intros x y z H X. repeat rewrite -> leEq_def. intros H0 H1. apply H0. astepr (y[*]x). apply shift_less_mult' with H; auto. Qed. Hint Resolve shift_leEq_div: algebra. Lemma eps_div_leEq_eps : forall (eps d : R) d_, [0] [<=] eps -> [1] [<=] d -> (eps[/] d[//]d_) [<=] eps. Proof. intros. apply shift_div_leEq'. apply less_leEq_trans with ([1]:R). apply pos_one. assumption. astepl ([1][*]eps). apply mult_resp_leEq_rht. assumption. assumption. Qed. Lemma nonneg_div_two : forall eps : R, [0] [<=] eps -> [0] [<=] eps [/]TwoNZ. Proof. intros. apply shift_leEq_div. apply pos_two. astepl ([0]:R). assumption. Qed. Lemma nonneg_div_two' : forall eps : R, [0] [<=] eps -> eps [/]TwoNZ [<=] eps. Proof. intros. apply shift_div_leEq. apply pos_two. astepl (eps[+][0]); rstepr (eps[+]eps). apply plus_resp_leEq_lft; auto. Qed. Lemma nonneg_div_three : forall eps : R, [0] [<=] eps -> [0] [<=] eps [/]ThreeNZ. Proof. intros. apply mult_cancel_leEq with (Three:R). apply pos_three. astepl ([0]:R); rstepr eps. assumption. Qed. Lemma nonneg_div_three' : forall eps : R, [0] [<=] eps -> eps [/]ThreeNZ [<=] eps. Proof. intros. apply shift_div_leEq. apply pos_three. rstepl (eps[+][0][+][0]); rstepr (eps[+]eps[+]eps). repeat apply plus_resp_leEq_both; auto. apply leEq_reflexive. Qed. Lemma nonneg_div_four : forall eps : R, [0] [<=] eps -> [0] [<=] eps [/]FourNZ. Proof. intros. rstepr ((eps [/]TwoNZ) [/]TwoNZ). apply nonneg_div_two; apply nonneg_div_two; assumption. Qed. Lemma nonneg_div_four' : forall eps : R, [0] [<=] eps -> eps [/]FourNZ [<=] eps. Proof. intros. rstepl ((eps [/]TwoNZ) [/]TwoNZ). apply leEq_transitive with (eps [/]TwoNZ). 2: apply nonneg_div_two'; assumption. apply nonneg_div_two'. apply nonneg_div_two. assumption. Qed. End multiplication. Section misc. (** *** Miscellaneous Properties *) Lemma sqr_nonneg : forall x : R, [0] [<=] x[^]2. Proof. intros. rewrite -> leEq_def in |- *. intro H. cut ([0] [<] x[^]2). intro H0. elim (less_antisymmetric_unfolded _ _ _ H H0). cut (x [<] [0] or [0] [<] x). intro H0. elim H0; clear H0; intros H0. rstepr ([--]x[*][--]x). cut ([0] [<] [--]x). intro H1. apply mult_resp_pos; auto. astepl ([--]([0]:R)). apply inv_resp_less. auto. rstepr (x[*]x). apply mult_resp_pos; auto. apply ap_imp_less. apply cring_mult_ap_zero with x. astepl (x[^]2). apply less_imp_ap. auto. Qed. Lemma nring_nonneg : forall n : nat, [0] [<=] nring (R:=R) n. Proof. intro; induction n as [| n Hrecn]. apply leEq_reflexive. apply leEq_transitive with (nring (R:=R) n); [ assumption | apply less_leEq; simpl in |- *; apply less_plusOne ]. Qed. Lemma suc_leEq_dub : forall n, nring (R:=R) (S (S n)) [<=] Two[*]nring (S n). Proof. intro n. induction n as [| n Hrecn]. apply eq_imp_leEq. rational. astepl (nring (R:=R) (S (S n)) [+]nring 1). apply leEq_transitive with (nring (R:=R) 2[*]nring (S n) [+]nring 1). apply plus_resp_leEq. astepr ((Two:R) [*]nring (S n)). exact Hrecn. simpl in |- *. astepr ((([0]:R) [+][1][+][1]) [*] (nring n[+][1]) [+] (([0]:R) [+][1][+][1]) [*][1]). apply plus_resp_leEq_lft. astepr (([0]:R) [+][1][+][1]). astepr (([0]:R) [+] ([1][+][1])). apply plus_resp_leEq_lft. astepr (Two:R). apply less_leEq. apply one_less_two. simpl in |- *. astepl (nring (R:=R) n[+][1][+] ([1][+] ([0][+][1]))). astepl (nring (R:=R) n[+] ([1][+] ([1][+] ([0][+][1])))). astepr (nring (R:=R) n[+][1][+] ([1][+][1])). astepr (nring (R:=R) n[+] ([1][+] ([1][+][1]))). rational. Qed. Lemma leEq_nring : forall n m, nring (R:=R) n [<=] nring m -> n <= m. Proof. intro n; induction n as [| n Hrecn]. intros. auto with arith. intros. induction m as [| m Hrecm]. exfalso. cut (nring (R:=R) n [<] [0]). change (Not (nring (R:=R) n[<](nring 0))). rewrite <- leEq_def. apply nring_leEq. auto with arith. change (nring n [<] nring (R:=R) 0) in |- *. apply nring_less. apply Nat.lt_le_trans with (S n). auto with arith. exfalso. revert H; rewrite -> leEq_def. intro H; destruct H. apply nring_less; auto with arith. cut (n <= m). auto with arith. apply Hrecn. rstepr (nring (R:=R) m[+][1][-][1]). apply shift_leEq_minus. apply H. Qed. Lemma cc_abs_aid : forall x y : R, [0] [<=] x[^]2[+]y[^]2. Proof. intros. astepl ([0][+] ([0]:R)). apply plus_resp_leEq_both; apply sqr_nonneg. Qed. Load "Transparent_algebra". Lemma nexp_resp_pos : forall (x : R) k, [0] [<] x -> [0] [<] x[^]k. Proof. intros. elim k. simpl in |- *. apply pos_one. intros. simpl in |- *. apply mult_resp_pos. assumption. assumption. Qed. Load "Opaque_algebra". Lemma mult_resp_nonneg : forall x y : R, [0] [<=] x -> [0] [<=] y -> [0] [<=] x[*]y. Proof. intros x y. repeat rewrite -> leEq_def. intros H H0 H1. apply H0. cut (x[*]y [#] [0]). intro H2. cut (x [#] [0]). intro H3. cut (y [#] [0]). intro H4. elim (ap_imp_less _ _ _ H4); intro H5. auto. elim (ap_imp_less _ _ _ H3); intro H6. elim (H H6). elim (less_antisymmetric_unfolded _ _ _ H1 (mult_resp_pos _ _ _ H6 H5)). apply cring_mult_ap_zero_op with x. auto. apply cring_mult_ap_zero with y. auto. apply less_imp_ap. auto. Qed. Load "Transparent_algebra". Lemma nexp_resp_nonneg : forall (x : R) (k : nat), [0] [<=] x -> [0] [<=] x[^]k. Proof. intros. induction k as [| k Hreck]. intros. astepr ([1]:R). apply less_leEq. apply pos_one. astepr (x[^]k[*]x). apply mult_resp_nonneg; auto. Qed. Lemma power_resp_leEq : forall (x y : R) k, [0] [<=] x -> x [<=] y -> x[^]k [<=] y[^]k. Proof. intros. induction k as [| k Hreck]; intros. astepl ([1]:R). astepr ([1]:R). apply leEq_reflexive. astepl (x[^]k[*]x). astepr (y[^]k[*]y). apply leEq_transitive with (x[^]k[*]y). apply mult_resp_leEq_lft. auto. apply nexp_resp_nonneg; auto. apply mult_resp_leEq_rht. auto. apply leEq_transitive with x; auto. Qed. Lemma nexp_resp_less : forall (x y : R) n, 1 <= n -> [0] [<=] x -> x [<] y -> x[^]n [<] y[^]n. Proof. intros. induction n as [| n Hrecn]. exfalso. inversion H. elim n. simpl in |- *. astepl x. astepr y. assumption. intros. change (x[^]S n0[*]x [<] y[^]S n0[*]y) in |- *. apply mult_resp_less_both. apply nexp_resp_nonneg. assumption. assumption. assumption. assumption. Qed. Lemma power_cancel_leEq : forall (x y : R) k, 0 < k -> [0] [<=] y -> x[^]k [<=] y[^]k -> x [<=] y. Proof. intros x y k H. repeat rewrite -> leEq_def. intros H0 H1 H2. apply H1. apply nexp_resp_less; try rewrite -> leEq_def; auto. Qed. Lemma power_cancel_less : forall (x y : R) k, [0] [<=] y -> x[^]k [<] y[^]k -> x [<] y. Proof. intros x y k H H0. elim (zerop k); intro y0. rewrite y0 in H0. cut ([1] [<] ([1]:R)). intro H1. elim (less_irreflexive_unfolded _ _ H1). astepl (x[^]0). astepr (y[^]0). auto. cut (x [<] y or y [<] x). intro H1. elim H1; clear H1; intros H1. auto. cut (x [<=] y). intro. destruct (leEq_def _ x y) as [H3 _]. elim ((H3 H2) H1). apply power_cancel_leEq with k; auto. apply less_leEq. auto. apply ap_imp_less. apply un_op_strext_unfolded with (nexp_op (R:=R) k). apply less_imp_ap. auto. Qed. Lemma nat_less_bin_nexp : forall p : nat, Snring R p [<] Two[^]S p. Proof. intro n. unfold Snring in |- *. induction n as [| n Hrecn]. simpl in |- *. astepl ([1]:R). astepr (([0]:R) [+][1][+][1]). astepr (([1]:R) [+][1]). astepr (Two:R). apply one_less_two. astepl (nring (R:=R) (S n) [+][1]). astepr ((Two:R)[^]S n[*]Two). astepr ((Two:R)[^]S n[*][1][+]Two[^]S n[*][1]). apply plus_resp_less_both. astepr ((Two:R)[^]S n). exact Hrecn. astepr ((Two:R)[^]S n). astepl (([1]:R)[^]S n). apply nexp_resp_less. intuition. apply less_leEq. apply pos_one. apply one_less_two. rational. Qed. Lemma Sum_resp_leEq : forall (f g : nat -> R) a b, a <= S b -> (forall i, a <= i -> i <= b -> f i [<=] g i) -> Sum a b f [<=] Sum a b g. Proof. intros. induction b as [| b Hrecb]; intros. unfold Sum in |- *. unfold Sum1 in |- *. generalize (toCle _ _ H); clear H; intro H. inversion H as [|m X H2]. astepl ([0]:R). astepr ([0]:R). apply leEq_reflexive. inversion X. simpl in |- *. rstepl (f 0). rstepr (g 0). apply H0; auto. rewrite H1. auto. elim (le_lt_eq_dec _ _ H); intro H1. apply leEq_wdl with (Sum a b f[+]f (S b)). apply leEq_wdr with (Sum a b g[+]g (S b)). apply plus_resp_leEq_both. apply Hrecb. auto with arith. auto. apply H0. auto with arith. auto. apply eq_symmetric_unfolded. apply Sum_last. apply eq_symmetric_unfolded. apply Sum_last. unfold Sum in |- *. unfold Sum1 in |- *. rewrite H1. simpl in |- *. astepl ([0]:R). astepr ([0]:R). apply leEq_reflexive. Qed. Lemma Sumx_resp_leEq : forall n (f g : forall i, i < n -> R), (forall i H, f i H [<=] g i H) -> Sumx f [<=] Sumx g. Proof. simple induction n. intros; simpl in |- *; apply leEq_reflexive. clear n; intros; simpl in |- *. apply plus_resp_leEq_both. apply H; intros; apply H0. apply H0. Qed. Lemma Sum2_resp_leEq : forall m n, m <= S n -> forall f g : forall i, m <= i -> i <= n -> R, (forall i Hm Hn, f i Hm Hn [<=] g i Hm Hn) -> Sum2 f [<=] Sum2 g. Proof. intros. unfold Sum2 in |- *. apply Sum_resp_leEq. assumption. intros. elim (le_lt_dec m i); intro; [ simpl in |- * | exfalso; apply (Nat.le_ngt m i); auto with arith ]. elim (le_lt_dec i n); intro; [ simpl in |- * | exfalso; apply (Nat.le_ngt i n); auto with arith ]. apply H0. Qed. Lemma approach_zero : forall x : R, (forall e, [0] [<] e -> x [<] e) -> x [<=] [0]. Proof. intros. rewrite -> leEq_def; intro. cut (x [<] x [/]TwoNZ). change (Not (x [<] x [/]TwoNZ)) in |- *. apply less_antisymmetric_unfolded. apply plus_cancel_less with (z := [--](x [/]TwoNZ)). apply mult_cancel_less with (z := Two:R). apply pos_two. rstepl ([0]:R). rstepr x. assumption. apply X. apply pos_div_two. assumption. Qed. Lemma approach_zero_weak : forall x : R, (forall e, [0] [<] e -> x [<=] e) -> x [<=] [0]. Proof. intros. rewrite -> leEq_def; intro. cut (x [<=] x [/]TwoNZ). rewrite -> leEq_def. change (~ Not (x [/]TwoNZ [<] x)) in |- *. intro H1. apply H1. apply plus_cancel_less with (z := [--](x [/]TwoNZ)). apply mult_cancel_less with (z := Two:R). apply pos_two. rstepl ([0]:R). rstepr x. assumption. apply H. apply pos_div_two. assumption. Qed. End misc. Lemma equal_less_leEq : forall a b x y : R, (a [<] b -> x [<=] y) -> (a [=] b -> x [<=] y) -> a [<=] b -> x [<=] y. Proof. intros. rewrite -> leEq_def. red in |- *. apply CNot_Not_or with (a [<] b) (a [=] b). firstorder using leEq_def. firstorder using leEq_def. intro. cut (a [=] b); intros. 2: apply leEq_imp_eq; auto. auto. rewrite -> leEq_def. intro; auto. Qed. Lemma power_plus_leEq : forall n (x y:R), (0 < n) -> ([0][<=]x) -> ([0][<=]y) -> (x[^]n [+] y[^]n)[<=](x[+]y)[^]n. Proof. intros [|n] x y Hn Hx Hy. exfalso; auto with *. induction n. simpl. rstepl ([1][*](x[+]y)). apply leEq_reflexive. rename n into m. set (n:=(S m)) in *. apply leEq_transitive with ((x[^]n[+]y[^]n)[*](x[+]y)). apply shift_zero_leEq_minus'. change (x[^]S n) with (x[^]n[*]x). change (y[^]S n) with (y[^]n[*]y). rstepr (y[*]x[^]n[+]x[*]y[^]n). apply plus_resp_nonneg; apply mult_resp_nonneg; try apply nexp_resp_nonneg; try assumption. change ((x[+]y)[^]S n) with ((x[+]y)[^]n[*](x[+]y)). apply mult_resp_leEq_rht. apply IHn. unfold n; auto with *. apply plus_resp_nonneg; assumption. Qed. End Properties_of_leEq. #[global] Hint Resolve shift_leEq_lft mult_resp_nonneg plus_resp_nonneg: algebra. (*---------------------------------*) Section PosP_properties. (*---------------------------------*) (** ** Properties of positive numbers %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. (* begin hide *) Notation ZeroR := ([0]:R). Notation OneR := ([1]:R). (* end hide *) Lemma mult_pos_imp : forall a b : R, [0] [<] a[*]b -> [0] [<] a and [0] [<] b or a [<] [0] and b [<] [0]. Proof. generalize I; intro. generalize I; intro. generalize I; intro. generalize I; intro. generalize I; intro. intros a b H4. generalize (Greater_imp_ap _ _ _ H4); intro H5. generalize (mult_cancel_ap_zero_lft _ _ _ H5); intro H6. generalize (mult_cancel_ap_zero_rht _ _ _ H5); intro H7. elim (ap_imp_less _ _ _ H6); intro H8. right. split. assumption. elim (ap_imp_less _ _ _ H7); intro. assumption. exfalso. elim (less_irreflexive_unfolded R [0]). apply less_leEq_trans with (a[*]b). assumption. apply less_leEq. apply inv_cancel_less. astepl ZeroR. astepr ([--]a[*]b). apply mult_resp_pos. astepl ([--]ZeroR). apply inv_resp_less. assumption. assumption. left. split. assumption. elim (ap_imp_less _ _ _ H7); intro. exfalso. elim (less_irreflexive_unfolded R [0]). apply less_leEq_trans with (a[*]b). assumption. apply less_leEq. apply inv_cancel_less. astepl ZeroR. astepr (a[*][--]b). apply mult_resp_pos. assumption. astepl ([--]ZeroR). apply inv_resp_less. assumption. assumption. Qed. Lemma plus_resp_pos_nonneg : forall x y : R, [0] [<] x -> [0] [<=] y -> [0] [<] x[+]y. Proof. intros. apply less_leEq_trans with x. auto. astepl (x[+][0]). apply plus_resp_leEq_lft. auto. Qed. Lemma plus_resp_nonneg_pos : forall x y : R, [0] [<=] x -> [0] [<] y -> [0] [<] x[+]y. Proof. intros. astepr (y[+]x). apply plus_resp_pos_nonneg; auto. Qed. Lemma pos_square : forall x : R, x [#] [0] -> [0] [<] x[^]2. Proof. intros x H. elim (ap_imp_less _ _ _ H); intro H1. rstepr ([--]x[*][--]x). cut ([0] [<] [--]x). intro. apply mult_resp_pos; auto. astepl ([--]ZeroR). apply inv_resp_less. auto. rstepr (x[*]x). apply mult_resp_pos; auto. Qed. Lemma mult_cancel_pos_rht : forall x y : R, [0] [<] x[*]y -> [0] [<=] x -> [0] [<] y. Proof. intros x y H. destruct (leEq_def _ [0] x) as [H0 _]. intro H2. pose (H3:=(H0 H2)). elim (mult_pos_imp _ _ H); intro H1. elim H1; auto. elim H1; intros. contradiction. Qed. Lemma mult_cancel_pos_lft : forall x y : R, [0] [<] x[*]y -> [0] [<=] y -> [0] [<] x. Proof. intros. apply mult_cancel_pos_rht with y. astepr (x[*]y). auto. auto. Qed. Lemma pos_wd : forall x y : R, x [=] y -> [0] [<] y -> [0] [<] x. Proof. intros. astepr y. auto. Qed. Lemma even_power_pos : forall n, Nat.Even n -> forall x : R, x [#] [0] -> [0] [<] x[^]n. Proof. intros n Hn x Hx. destruct (even_or_odd_plus n) as [k [Hk | Hk]]. - astepr ((x[^]2)[^](k)). apply nexp_resp_pos, pos_square; exact Hx. astepr ((x[^]2)[^](k)); [reflexivity |]. now rewrite nexp_mult, Hk; replace (2 * k) with (k + k) by lia. - exfalso; apply (Nat.Even_Odd_False n); [exact Hn |]. exists k; lia. Qed. Lemma odd_power_cancel_pos : forall n, Nat.Odd n -> forall x : R, [0] [<] x[^]n -> [0] [<] x. Proof. intros n [m Hm]%to_Codd x. simpl. intros H. apply mult_pos_imp in H as [[H1 H2] | [H1 H2]]. - exact H2. - exfalso. apply less_imp_ap in H2. apply (even_power_pos m) in H2; [| now apply Ceven_to]. apply less_antisymmetric_unfolded with (1 := H1). exact H2. Qed. Lemma plus_resp_pos : forall x y : R, [0] [<] x -> [0] [<] y -> [0] [<] x[+]y. Proof. intros. apply plus_resp_pos_nonneg. auto. apply less_leEq. auto. Qed. Lemma pos_nring_S : forall n, ZeroR [<] nring (S n). Proof. simple induction n; simpl in |- *; intros. (* base *) astepr OneR; apply pos_one. (* step *) apply less_leEq_trans with (nring (R:=R) n0[+][1]). assumption. apply less_leEq. apply less_plusOne. Qed. Lemma square_eq_pos : forall x a : R, [0] [<] a -> [0] [<] x -> x[^]2 [=] a[^]2 -> x [=] a. Proof. intros. elim (square_eq _ x a); intros; auto. exfalso. apply less_irreflexive_unfolded with (x := ZeroR). apply less_leEq_trans with x. auto. apply less_leEq. astepl ([--]a); apply inv_cancel_less. astepl ZeroR; astepr a; auto. apply Greater_imp_ap; auto. Qed. Lemma square_eq_neg : forall x a : R, [0] [<] a -> x [<] [0] -> x[^]2 [=] a[^]2 -> x [=] [--]a. Proof. intros. elim (square_eq _ x a); intros; auto. exfalso. apply less_irreflexive_unfolded with (x := ZeroR). apply leEq_less_trans with x. astepr a; apply less_leEq; auto. auto. apply Greater_imp_ap; auto. Qed. End PosP_properties. #[global] Hint Resolve mult_resp_nonneg. (** ** Properties of one over successor %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Definition one_div_succ (R : COrdField) i : R := [1][/] Snring R i[//]nringS_ap_zero _ i. Arguments one_div_succ [R]. Section One_div_succ_properties. Variable R : COrdField. Lemma one_div_succ_resp_leEq : forall m n, m <= n -> one_div_succ (R:=R) n [<=] one_div_succ m. Proof. unfold one_div_succ in |- *. unfold Snring in |- *. intros. apply recip_resp_leEq. apply pos_nring_S. apply nring_leEq. auto with arith. Qed. Lemma one_div_succ_pos : forall i, ([0]:R) [<] one_div_succ i. Proof. intro. unfold one_div_succ in |- *. unfold Snring in |- *. apply recip_resp_pos. apply nring_pos. auto with arith. Qed. Lemma one_div_succ_resp_less : forall i j, i < j -> one_div_succ j [<] one_div_succ (R:=R) i. Proof. intros. unfold one_div_succ in |- *. unfold Snring in |- *. intros. apply recip_resp_less. apply pos_nring_S. apply nring_less. auto with arith. Qed. End One_div_succ_properties. (** ** Properties of [Half] *) Definition Half (R : COrdField) := ([1]:R) [/]TwoNZ. Arguments Half {R}. Section Half_properties. (** %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. Lemma half_1 : (Half:R) [*]Two [=] [1]. Proof. unfold Half in |- *. apply div_1. Qed. Hint Resolve half_1: algebra. Lemma pos_half : ([0]:R) [<] Half. Proof. apply mult_cancel_pos_lft with (Two:R). apply (pos_wd R (Half[*]Two) [1]). exact half_1. apply pos_one. apply less_leEq; apply pos_two. Qed. Lemma half_1' : forall x : R, x[*]Half[*]Two [=] x. Proof. intros. unfold Half in |- *. rational. Qed. Lemma half_2 : (Half:R) [+]Half [=] [1]. Proof. unfold Half in |- *. rational. Qed. Lemma half_lt1 : (Half:R) [<] [1]. Proof. astepr (Half[+] (Half:R)). rstepl ((Half:R) [+][0]). apply plus_resp_less_lft. exact pos_half. exact half_2. Qed. Lemma half_3 : forall x : R, [0] [<] x -> Half[*]x [<] x. Proof. intros. astepr ([1][*]x). apply mult_resp_less; auto. exact half_lt1. Qed. End Half_properties. #[global] Hint Resolve half_1 half_1' half_2: algebra. corn-8.20.0/algebra/CPoly_ApZero.v000066400000000000000000000440241473720167500166540ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CPoly_Degree. Require Export CoRN.algebra.COrdFields2. Require Import Coq.Classes.Morphisms Coq.Sorting.Permutation. Require MathClasses.implementations.ne_list. Import CRing_Homomorphisms.coercions. Import ne_list.notations ne_list.coercions. (** * Polynomials apart from zero *) Definition distinct1 (A : CSetoid) (f : nat -> A) := forall i j, i <> j -> f i [#] f j. Arguments distinct1 [A]. Section Poly_Representation. (** ** Representation of polynomials %\begin{convention}% Let [R] be a field, [RX] the ring of polynomials over [R], [a_ : nat->R] with [(distinct1 a_)] and let [f] be a polynomial over [R], [n] a natural with [(degree_le n f)], i.e. [f] has degree at most [n]. %\end{convention}% *) Variable R : CField. Variable a_ : nat -> R. Hypothesis distinct_a_ : distinct1 a_. Variable f : cpoly_cring R. Variable n : nat. Hypothesis degree_f : degree_le n f. Add Ring cpolycring_th : (cpoly_ring_th R). (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) Load "Transparent_algebra". Lemma poly_linear_shifted : forall (a : R) (f : RX), {f' : RX | {f'' : R | f [=] (_X_[-]_C_ a) [*]f'[+]_C_ f''}}. Proof. intros. induction f0 as [| s f0 Hrecf0]; intros. exists (cpoly_zero R). exists ([0]:R). simpl in |- *. algebra. elim Hrecf0. intro g'. intros H. elim H. intro g''. intros H0. exists (_X_[*]g'[+]_C_ g''). exists (a[*]g''[+]s). astepl (_X_[*]f0[+]_C_ s). astepl (_X_[*] ((_X_[-]_C_ a) [*]g'[+]_C_ g'') [+]_C_ s). apply eq_symmetric_unfolded. cut (_C_ (a[*]g''[+]s) [=] _C_ a[*]_C_ g''[+]_C_ s). intro. astepl ((_X_[-]_C_ a) [*] (_X_[*]g'[+]_C_ g'') [+] (_C_ a[*]_C_ g''[+]_C_ s)). unfold cg_minus. ring. Step_final (_C_ (a[*]g'') [+]_C_ s). Qed. Load "Opaque_algebra". Lemma poly_linear_factor : forall (f : RX) a, f ! a [=] [0] -> {f' : RX | f [=] (_X_[-]_C_ a) [*]f'}. Proof. intros. elim (poly_linear_shifted a f0). intro f'. intros H0. elim H0. intro f''. intros H1. exists f'. cut (_C_ f'' [=] [0]). intro. astepl ((_X_[-]_C_ a) [*]f'[+]_C_ f''). Step_final ((_X_[-]_C_ a) [*]f'[+][0]). astepr (_C_ ([0]:R)). apply cpoly_const_eq. astepl ([0][+]f''). astepl ([0][*]f' ! a[+]f''). astepl ((a[-]a) [*]f' ! a[+]f''). astepl ((_X_ ! a[-] (_C_ a) ! a) [*]f' ! a[+]f''). astepl ((_X_[-]_C_ a) ! a[*]f' ! a[+]f''). astepl (((_X_[-]_C_ a) [*]f') ! a[+]f''). astepl (((_X_[-]_C_ a) [*]f') ! a[+] (_C_ f'') ! a). astepl ((_X_[-]_C_ a) [*]f'[+]_C_ f'') ! a. Step_final f0 ! a. Qed. Lemma zero_poly : forall n, (forall i j: nat, i <= n -> j <= n -> i <> j -> a_ i[#]a_ j) -> forall (f : RX), degree_le n f -> (forall i, i <= n -> f ! (a_ i) [=] [0]) -> f [=] [0]. Proof with auto. intro. clear degree_f n distinct_a_. intro distinct_a_. induction n0 as [| n0 Hrecn0]; intros. elim (degree_le_zero _ _ H). intros. astepl (_C_ x). astepr (_C_ ([0]:R)). apply cpoly_const_eq. apply eq_transitive_unfolded with f0 ! (a_ 0). Step_final (_C_ x) ! (a_ 0). apply H0... cut (f0 ! (a_ (S n0)) [=] [0])... intro. elim (poly_linear_factor f0 (a_ (S n0)) H1). intro f'. intros. astepl ((_X_[-]_C_ (a_ (S n0))) [*]f'). cut (f' [=] [0]). intro. Step_final ((_X_[-]_C_ (a_ (S n0))) [*][0]). apply Hrecn0. intuition. apply degree_le_mult_imp with (_X_[-]_C_ (a_ (S n0))) 1. apply degree_minus_lft with 0... apply degree_le_c_. apply degree_x_. apply degree_le_wd with f0... intros. apply mult_cancel_lft with (a_ i[-]a_ (S n0)). apply minus_ap_zero. apply distinct_a_... intro; rewrite H3 in H2; exact (Nat.nle_succ_diag_l _ H2). astepr ([0]:R). cut (a_ i[-]a_ (S n0) [=] (_X_[-]_C_ (a_ (S n0))) ! (a_ i)). intro. astepl ((_X_[-]_C_ (a_ (S n0))) ! (a_ i) [*]f' ! (a_ i)). astepl ((_X_[-]_C_ (a_ (S n0))) [*]f') ! (a_ i). astepl f0 ! (a_ i)... Step_final (_X_ ! (a_ i) [-] (_C_ (a_ (S n0))) ! (a_ i)). Qed. Lemma identical_poly : (forall i j: nat, i <= n -> j <= n -> i <> j -> a_ i[#]a_ j) -> forall f g : RX, degree_le n f -> degree_le n g -> (forall i, i <= n -> f ! (a_ i) [=] g ! (a_ i)) -> f [=] g. Proof. intros. apply cg_inv_unique_2. apply zero_poly with n. assumption. apply degree_le_minus; auto. intros. astepl (f0 ! (a_ i) [-]g ! (a_ i)). Step_final (f0 ! (a_ i) [-]f0 ! (a_ i)). Qed. Definition poly_01_factor' (n : nat) := _X_[-]_C_ (a_ n). Lemma poly_01_factor'_degree : forall n, degree_le 1 (poly_01_factor' n). Proof. intros. unfold poly_01_factor' in |- *. apply degree_imp_degree_le. apply degree_minus_lft with 0. apply degree_le_c_. apply degree_x_. auto. Qed. Lemma poly_01_factor'_zero : forall n, (poly_01_factor' n) ! (a_ n) [=] [0]. Proof. intros. unfold poly_01_factor' in |- *. astepl (_X_ ! (a_ n0) [-] (_C_ (a_ n0)) ! (a_ n0)). Step_final (a_ n0[-]a_ n0). Qed. Lemma poly_01_factor'_apzero : forall n i, i <> n -> (poly_01_factor' n) ! (a_ i) [#] [0]. Proof. intros. unfold poly_01_factor' in |- *. astepl (_X_ ! (a_ i) [-] (_C_ (a_ n0)) ! (a_ i)). astepl (a_ i[-]a_ n0). algebra. Qed. Hint Resolve poly_01_factor'_zero. Definition poly_01_factor n i (H : i <> n) := poly_01_factor' n[*] _C_ ([1][/] (poly_01_factor' n) ! (a_ i) [//]poly_01_factor'_apzero n i H). Lemma poly_01_factor_degree : forall n i H, degree_le 1 (poly_01_factor n i H). Proof. intros. unfold poly_01_factor in |- *. replace 1 with (1 + 0). apply degree_le_mult. apply poly_01_factor'_degree. apply degree_le_c_. auto. Qed. Lemma poly_01_factor_zero : forall n i H, (poly_01_factor n i H) ! (a_ n) [=] [0]. Proof. intros. unfold poly_01_factor in |- *. astepl ((poly_01_factor' n0) ! (a_ n0) [*] (_C_ ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)) ! (a_ n0)). Step_final ([0][*] (_C_ ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)) ! (a_ n0)). Qed. Lemma poly_01_factor_one : forall n i H, (poly_01_factor n i H) ! (a_ i) [=] [1]. Proof. intros. unfold poly_01_factor in |- *. astepl ((poly_01_factor' n0) ! (a_ i) [*] (_C_ ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)) ! (a_ i)). astepl ((poly_01_factor' n0) ! (a_ i) [*] ([1][/] (poly_01_factor' n0) ! (a_ i) [//]poly_01_factor'_apzero n0 i H)). apply div_1'. Qed. Hint Resolve poly_01_factor_zero poly_01_factor_one: algebra. Fixpoint poly_01 (i n : nat) {struct n} : cpoly_cring R := match eq_nat_dec i n with | left _ => [1] | right ne => poly_01_factor n i ne end [*] match n with | O => [1] | S m => poly_01 i m end. Lemma poly_01_degree' : forall n i, degree_le (S n) (poly_01 i n). Proof. intros. induction n0 as [| n0 Hrecn0]. intros. simpl in |- *. elim (eq_nat_dec i 0); intro y. apply degree_le_wd with (_C_ ([1]:R)). Step_final ([1]:cpoly_cring R). apply degree_le_mon with 0. auto with arith. apply degree_le_c_. apply degree_le_wd with (poly_01_factor 0 i y). algebra. apply poly_01_factor_degree. simpl in |- *. elim (eq_nat_dec i (S n0)); intro. apply degree_le_mon with (S n0). auto. apply degree_le_wd with (poly_01 i n0). algebra. auto. replace (S (S n0)) with (1 + S n0). apply degree_le_mult. apply poly_01_factor_degree. auto. auto. Qed. Lemma poly_01_degree : forall n i, i <= n -> degree_le n (poly_01 i n). Proof. intros. induction n0 as [| n0 Hrecn0]; intros. simpl in |- *. elim (eq_nat_dec i 0); intro y. apply degree_le_wd with (_C_ ([1]:R)). Step_final ([1]:cpoly_cring R). apply degree_le_c_. cut (i = 0). intro. elim (y H0). auto with arith. simpl in |- *. elim (eq_nat_dec i (S n0)); intro. apply degree_le_wd with (poly_01 i n0). algebra. apply poly_01_degree'. pattern (S n0) at 1 in |- *. replace (S n0) with (1 + n0). apply degree_le_mult. apply poly_01_factor_degree. apply Hrecn0. elim (le_lt_eq_dec _ _ H); auto with arith. intro; elim (b b0). auto. Qed. Lemma poly_01_zero : forall n i j, j <= n -> j <> i -> (poly_01 i n) ! (a_ j) [=] [0]. Proof. intros. induction n0 as [| n0 Hrecn0]; intros. rewrite (proj1 (Nat.le_0_r j) H). rewrite (proj1 (Nat.le_0_r j) H) in H0. simpl in |- *. elim (eq_nat_dec i 0); intro y. rewrite y in H0. elim (H0 (refl_equal 0)). astepl ((poly_01_factor 0 i y) ! (a_ 0) [*][1] ! (a_ 0)). astepl ((poly_01_factor 0 i y) ! (a_ 0) [*][1]). astepl (poly_01_factor 0 i y) ! (a_ 0). apply poly_01_factor_zero. elim (eq_nat_dec j (S n0)); intro y. simpl in |- *. rewrite <- y. elim (eq_nat_dec i j); intro y0. rewrite y0 in H0. elim (H0 (refl_equal j)). astepl ((poly_01_factor j i y0) ! (a_ j) [*] (poly_01 i n0) ! (a_ j)). Step_final ([0][*] (poly_01 i n0) ! (a_ j)). cut (j <= n0). intro. simpl in |- *. elim (eq_nat_dec i (S n0)); intro y0. astepl ([1] ! (a_ j) [*] (poly_01 i n0) ! (a_ j)). Step_final ([1] ! (a_ j) [*][0]). astepl ((poly_01_factor (S n0) i y0) ! (a_ j) [*] (poly_01 i n0) ! (a_ j)). Step_final ((poly_01_factor (S n0) i y0) ! (a_ j) [*][0]). elim (le_lt_eq_dec _ _ H); auto with arith. intro; elim (y b). Qed. Lemma poly_01_one : forall n i, (poly_01 i n) ! (a_ i) [=] [1]. Proof. intros. induction n0 as [| n0 Hrecn0]; intros. simpl in |- *. elim (eq_nat_dec i 0); intro y. astepl ([1] ! (a_ i) [*][1] ! (a_ i)). Step_final ([1][*] ([1]:R)). astepl ((poly_01_factor 0 i y) ! (a_ i) [*][1] ! (a_ i)). astepl ((poly_01_factor 0 i y) ! (a_ i) [*][1]). astepl (poly_01_factor 0 i y) ! (a_ i). apply poly_01_factor_one. simpl in |- *. elim (eq_nat_dec i (S n0)); intro y. astepl ([1] ! (a_ i) [*] (poly_01 i n0) ! (a_ i)). astepl ([1][*] (poly_01 i n0) ! (a_ i)). Step_final ([1][*] ([1]:R)). astepl ((poly_01_factor (S n0) i y) ! (a_ i) [*] (poly_01 i n0) ! (a_ i)). astepl ((poly_01_factor (S n0) i y) ! (a_ i) [*][1]). astepl (poly_01_factor (S n0) i y) ! (a_ i). apply poly_01_factor_one. Qed. Hint Resolve poly_01_zero poly_01_one: algebra. Lemma poly_representation'' : forall (a : nat -> R) i, i <= n -> (forall j, j <> i -> a j [=] [0]) -> Sum 0 n a [=] a i. Proof. intro. intro. elim i. intros. astepl (a 0[+]Sum 1 n a). astepr (a 0[+][0]). apply bin_op_wd_unfolded. algebra. apply Sum_zero. auto with arith. intros. apply H0. intro; rewrite H3 in H1; inversion H1. intro i'. intros. astepl (Sum 0 i' a[+]Sum (S i') n a). astepr ([0][+]a (S i')). apply bin_op_wd_unfolded. apply Sum_zero. auto with arith. intros. apply H1. intro; rewrite H4 in H3; exact (Nat.nle_succ_diag_l _ H3). astepl (a (S i') [+]Sum (S (S i')) n a). astepr (a (S i') [+][0]). apply bin_op_wd_unfolded. algebra. apply Sum_zero. auto with arith. intros. apply H1. intro; rewrite H4 in H2; exact (Nat.nle_succ_diag_l _ H2). Qed. Lemma poly_representation' : forall (f_ : nat -> RX) k, k <= n -> (Sum 0 n (fun i => f_ i[*]poly_01 i n)) ! (a_ k) [=] (f_ k) ! (a_ k). Proof. intros. apply eq_transitive_unfolded with (Sum 0 n (fun i : nat => (f_ i[*]poly_01 i n) ! (a_ k))). apply Sum_cpoly_ap with (f := fun i : nat => f_ i[*]poly_01 i n). astepl (Sum 0 n (fun i : nat => (f_ i) ! (a_ k) [*] (poly_01 i n) ! (a_ k))). astepr ((f_ k) ! (a_ k) [*][1]). astepr ((f_ k) ! (a_ k) [*] (poly_01 k n) ! (a_ k)). apply poly_representation'' with (a := fun i : nat => (f_ i) ! (a_ k) [*] (poly_01 i n) ! (a_ k)). auto. intros. Step_final ((f_ j) ! (a_ k) [*][0]). Qed. Lemma poly_representation : f [=] Sum 0 n (fun i => _C_ f ! (a_ i) [*]poly_01 i n). Proof. apply identical_poly; auto. apply Sum_degree_le. auto with arith. intros. replace n with (0 + n). apply degree_le_mult. apply degree_le_c_. apply poly_01_degree. auto. auto with arith. intros. apply eq_symmetric_unfolded. astepr (_C_ f ! (a_ i)) ! (a_ i). apply poly_representation' with (f_ := fun i : nat => _C_ f ! (a_ i)). auto. Qed. Hint Resolve poly_representation: algebra. Lemma Cpoly_choose_apzero : f [#] [0] -> {i : nat | i <= n | f ! (a_ i) [#] [0]}. Proof. intros H. cut (Sum 0 n (fun i : nat => _C_ f ! (a_ i) [*]poly_01 i n) [#] [0]). intros H0. elim (Sum_apzero _ (fun i : nat => _C_ f ! (a_ i) [*]poly_01 i n) 0 n ( Nat.le_0_l n) H0). intro i. intro H1. elim H1. intros H2 H3. intro H4. exists i. auto. apply poly_c_apzero. apply cring_mult_ap_zero with (poly_01 i n). auto. astepl f. auto. Qed. End Poly_Representation. Section Characteristic_zero. (** If we are in a field of characteristic zero, the previous result can be strengthened. *) Variable R:CField. (* begin show *) Hypothesis H : (Char0 R). (* end show *) (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) Lemma poly_apzero : forall f : RX, f [#] [0] -> {c : R | f ! c [#] [0]}. Proof. intros f H0. elim (Cpoly_ex_degree _ f). intro n. intro H1. (* Set_ not necessary *) cut (distinct1 (fun i : nat => nring i:R)). intro H2. elim (Cpoly_choose_apzero _ (fun i : nat => nring i:R) H2 f n H1 H0). (* Set_ not necessary *) intro i. intros. exists (nring i:R). auto. unfold distinct1 in |- *. intros. apply nring_different; auto. Qed. (** Also, in this situation polynomials are extensional functions. *) Lemma poly_extensional : forall p q : RX, (forall x, p ! x [=] q ! x) -> p [=] q. Proof. intros p q H0. apply cg_inv_unique_2. apply not_ap_imp_eq. unfold Not in |- *. intros H1. elim (poly_apzero (p[-]q)). intros x H2. cut ((p[-]q) ! x [=] [0]). intro. elim (eq_imp_not_ap _ _ _ H3 H2). astepl (p ! x[-]q ! x). Step_final (p ! x[-]p ! x). auto. Qed. End Characteristic_zero. (** ** Polynomials are nonzero on any interval *) Section Poly_ApZero_Interval. Variable R : COrdField. (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) Lemma Cpoly_apzero_interval : forall f : RX, f [#] [0] -> forall a b, a [<] b -> {c : R | a [<=] c /\ c [<=] b | f ! c [#] [0]}. Proof. intros f H a b H0. assert (H1 := poly_degree_lth _ f). set (n := lth_of_poly f) in *. cut ([0] [<] (nring n:R)). intros H2. cut (nring n [#] ([0]:R)). intros H3. cut (distinct1 (fun i : nat => nring i[*]a[+] (nring n[-]nring i) [*]b[/] nring n[//]H3)). intro H4. elim (Cpoly_choose_apzero _ (fun i : nat => nring i[*]a[+] (nring n[-]nring i) [*]b[/] nring n[//]H3) H4 f n H1 H). intro i. intros H6 H7. exists (nring i[*]a[+] (nring n[-]nring i) [*]b[/] nring n[//]H3). split. apply shift_leEq_div. auto. rstepl (nring i[*]a[+] (nring n[-]nring i) [*]a). apply plus_resp_leEq_lft. apply mult_resp_leEq_lft. apply less_leEq. auto. apply shift_leEq_minus. astepl (nring (R:=R) i). apply nring_leEq. auto. apply shift_div_leEq. auto. rstepr (nring i[*]b[+] (nring n[-]nring i) [*]b). apply plus_resp_leEq. apply mult_resp_leEq_lft. apply less_leEq. auto. astepl (nring 0:R). apply nring_leEq. auto with arith. auto. unfold distinct1 in |- *. intros. unfold cf_div in |- *. apply mult_rht_resp_ap. apply zero_minus_apart. rstepl ((nring i[-]nring j) [*] (a[-]b)). apply mult_resp_ap_zero. apply minus_ap_zero. apply nring_apart. auto. apply minus_ap_zero. apply less_imp_ap. auto. apply f_rcpcl_resp_ap_zero. apply pos_ap_zero. auto. astepl (nring 0:R). apply nring_less. unfold n in |- *. generalize H; clear H1 H; case f. intro H; inversion H. intros; simpl in |- *. auto with arith. Qed. End Poly_ApZero_Interval. Global Instance: forall {R: CRing} (n: nat), Proper (@st_eq _ ==> iff) (@degree_le R n). Proof. split; apply degree_le_wd; [| symmetry]; assumption. Qed. Section interpolation. Context {F: CField}. Definition interpolates (l: list (F * F)) (p: cpoly F): Prop := forall xy, In xy l -> p ! (fst xy) [=] snd xy. Definition interpolates_economically (l: ne_list (F * F)) (p: cpoly F): Prop := interpolates l p /\ degree_le (length (tl l)) p. Global Instance: Proper (@Permutation _ ==> @st_eq _ ==> iff) interpolates. Proof with auto. cut (forall x y: list (F * F), Permutation x y -> forall p q: cpoly F, p [=] q -> interpolates x p -> interpolates y q). split; apply H; auto; symmetry... unfold interpolates. intros ?? E ?? G ??. rewrite <- E, <- G... Qed. Global Instance: Proper (ne_list.Permutation ==> @st_eq _ ==> iff) interpolates_economically. Proof with auto. intros ?? E ?? U. unfold interpolates_economically. rewrite U. rewrite (ne_list.Permutation_ne_tl_length x y)... rewrite E. reflexivity. Qed. Lemma interpolation_unique (l: ne_list (F * F)): CNoDup (@cs_ap _) (map (@fst _ _) l) -> forall p q: cpoly F, interpolates_economically l p -> interpolates_economically l q -> p [=] q. Proof with auto with arith. intros ??? [A ?] [B ?]. apply (identical_poly F (fun i => fst (nth i l ([0], [0]))) (length (tl l)))... repeat intro. rewrite <- map_nth. rewrite <- (map_nth (@fst _ _) l). simpl @fst. apply CNoDup_indexed... intros. apply ap_symmetric. rewrite map_length. rewrite <- ne_list.tl_length... rewrite map_length. rewrite <- ne_list.tl_length... intros. transitivity (snd (nth i l ([0], [0]))). apply A, nth_In... rewrite <- ne_list.tl_length... symmetry. apply B, nth_In... rewrite <- ne_list.tl_length... Qed. End interpolation. corn-8.20.0/algebra/CPoly_Degree.v000066400000000000000000000513071473720167500166510ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CPoly_NthCoeff. Require Export CoRN.algebra.CFields. Require Export CoRN.tactics.Rational. Require Import Lia. Import CRing_Homomorphisms.coercions. (** * Degrees of Polynomials ** Degrees of polynomials over a ring %\begin{convention}% Let [R] be a ring and write [RX] for the ring of polynomials over [R]. %\end{convention}% *) Section Degree_def. Variable R : CRing. (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) (** The length of a polynomial is the number of its coefficients. This is a syntactical property, as the highest coefficient may be [0]. Note that the `zero' polynomial [cpoly_zero] has length [0], a constant polynomial has length [1] and so forth. So the length is always [1] higher than the `degree' (assuming that the highest coefficient is [[#][0]])! *) Arguments cpoly_zero {CR}. Arguments cpoly_linear [CR]. Fixpoint lth_of_poly (p : RX) : nat := match p with | cpoly_zero => 0 | cpoly_linear d q => S (lth_of_poly q) end. (** When dealing with constructive polynomials, notably over the reals or complex numbers, the degree may be unknown, as we can not decide whether the highest coefficient is [[#][0]]. Hence, degree is a relation between polynomials and natural numbers; if the degree is unknown for polynomial [p], degree(n,p) doesn't hold for any [n]. If we don't know the degree of [p], we may still know it to be below or above a certain number. E.g. for the polynomial $p_0 +p_1 X +\cdots + p_{n-1} X^{n-1}$#p0 +p1 X + ... + p(n-1) X^(n-1)#, if $p_i \mathrel{\#}0$#pi apart from 0#, we can say that the `degree is at least [i]' and if $p_{j+1} = \ldots =p_n =0$#p(j+1) = ... =pn =0# (with [n] the length of the polynomial), we can say that the `degree is at most [j]'. *) Definition degree_le n (p : RX) : Prop := forall m, n < m -> nth_coeff m p [=] [0]. Definition degree n (p : RX) : CProp := nth_coeff n p [#] [0] and degree_le n p. Definition monic n (p : RX) : Prop := nth_coeff n p [=] [1] /\ degree_le n p. Definition odd_cpoly (p : RX) : CProp := {n : nat | Codd n | degree n p}. Definition even_cpoly (p : RX) : CProp := {n : nat | Ceven n | degree n p}. Definition regular (p : RX) : CProp := {n : nat | degree n p}. End Degree_def. Arguments degree_le [R]. Arguments degree [R]. Arguments monic [R]. Arguments lth_of_poly [R]. Section Degree_props. Variable R : CRing. Add Ring R: (CRing_Ring R). (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) Lemma degree_le_wd : forall (p p' : RX) n, p [=] p' -> degree_le n p -> degree_le n p'. Proof. unfold degree_le in |- *. intros. Step_final (nth_coeff m p). Qed. Lemma degree_wd : forall (p p' : RX) n, p [=] p' -> degree n p -> degree n p'. Proof. unfold degree in |- *. intros p p' n H H0. elim H0. clear H0. intros. split. astepl (nth_coeff n p). auto. apply degree_le_wd with p; auto. Qed. Lemma monic_wd : forall (p p' : RX) n, p [=] p' -> monic n p -> monic n p'. Proof. unfold monic in |- *. intros. elim H0. clear H0. intros. split. Step_final (nth_coeff n p). apply degree_le_wd with p; auto. Qed. Lemma degree_imp_degree_le : forall (p : RX) n, degree n p -> degree_le n p. Proof. unfold degree in |- *. intros p n H. elim H. auto. Qed. Lemma degree_le_cpoly_zero n: degree_le n (cpoly_zero R). Proof. intro. reflexivity. Qed. Lemma degree_le_c_ : forall c : R, degree_le 0 (_C_ c). Proof. unfold degree_le in |- *. intros c m. elim m; intros. elim (Nat.lt_irrefl _ H). simpl in |- *. algebra. Qed. Lemma degree_c_ : forall c : R, c [#] [0] -> degree 0 (_C_ c). Proof. unfold degree in |- *. intros. split. simpl in |- *. auto. apply degree_le_c_. Qed. Lemma monic_c_one : monic 0 (_C_ ([1]:R)). Proof. unfold monic in |- *. intros. split. simpl in |- *. algebra. apply degree_le_c_. Qed. Lemma degree_le_x_ : degree_le 1 (_X_:RX). Proof. unfold degree_le in |- *. intro. elim m. intros. elim (Nat.nlt_0_r _ H). intro. elim n. intros. elim (Nat.lt_irrefl _ H0). intros. simpl in |- *. algebra. Qed. Lemma degree_x_ : degree 1 (_X_:RX). Proof. unfold degree in |- *. split. simpl in |- *. algebra. exact degree_le_x_. Qed. Lemma monic_x_ : monic 1 (_X_:RX). Proof. unfold monic in |- *. split. simpl in |- *. algebra. exact degree_le_x_. Qed. Lemma degree_le_mon : forall (p : RX) m n, m <= n -> degree_le m p -> degree_le n p. Proof. unfold degree_le in |- *. intros. apply H0. apply Nat.le_lt_trans with n; auto with arith. Qed. Lemma degree_le_inv : forall (p : RX) n, degree_le n p -> degree_le n [--]p. Proof. unfold degree_le in |- *. intros. astepl ( [--] (nth_coeff m p)). Step_final ( [--] ([0]:R)). Qed. Lemma degree_le_plus : forall (p q : RX) n, degree_le n p -> degree_le n q -> degree_le n (p[+]q). Proof. unfold degree_le in |- *. intros. astepl (nth_coeff m p[+]nth_coeff m q). Step_final ([0][+] ([0]:R)). Qed. Lemma degree_le_minus : forall (p q : RX) n, degree_le n p -> degree_le n q -> degree_le n (p[-]q). Proof. unfold degree_le in |- *. intros. astepl (nth_coeff m p[-]nth_coeff m q). Step_final ([0][-] ([0]:R)). Qed. Lemma Sum_degree_le : forall (f : nat -> RX) (n k l : nat), k <= S l -> (forall i, k <= i -> i <= l -> degree_le n (f i)) -> degree_le n (Sum k l f). Proof. unfold degree_le in |- *. intros. induction l as [| l Hrecl]; intros. generalize (toCle _ _ H); clear H; intro H. inversion H as [|m0 X]. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. apply eq_transitive with (nth_coeff m ([0]:RX)). apply nth_coeff_wd. algebra. algebra. inversion X. rename H3 into kis0. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. apply eq_transitive with (nth_coeff m (f 0)). apply nth_coeff_wd. cut (f 0[-][0] [=] f 0). auto. algebra. apply H0; try auto. rewrite kis0; auto. elim (le_lt_eq_dec _ _ H); intro y. apply eq_transitive_unfolded with (nth_coeff m (Sum k l f[+]f (S l))). apply nth_coeff_wd. algebra. astepl (nth_coeff m (Sum k l f) [+]nth_coeff m (f (S l))). astepr ([0][+] ([0]:R)). apply bin_op_wd_unfolded. apply Hrecl. auto with arith. intros. apply H0. auto. auto. auto. apply H0. auto with arith. auto. auto. rewrite y. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. apply eq_transitive_unfolded with (nth_coeff m ([0]:RX)). apply nth_coeff_wd. algebra. algebra. Qed. Lemma degree_le_Sum (l: list (cpoly R)) n: (forall p, In p l -> degree_le n p) -> degree_le n (cm_Sum l). Proof. induction l; intros. apply degree_le_cpoly_zero. change (degree_le n (a [+] cm_Sum l)). apply degree_le_plus; intuition. Qed. Lemma degree_inv : forall (p : RX) (n : nat), degree n p -> degree n [--]p. Proof. unfold degree in |- *. intros p n H. elim H. clear H. intros. split. astepl ( [--] (nth_coeff n p)). algebra. apply degree_le_inv; auto. Qed. Lemma degree_plus_rht : forall (p q : RX) m n, degree_le m p -> degree n q -> m < n -> degree n (p[+]q). Proof. unfold degree in |- *. unfold degree_le in |- *. intros. elim X. clear X. intros. split. astepl (nth_coeff n p[+]nth_coeff n q). astepl ([0][+]nth_coeff n q). astepl (nth_coeff n q). auto. intros. astepl (nth_coeff m0 p[+]nth_coeff m0 q). cut (m < m0). intro. Step_final ([0][+] ([0]:R)). apply Nat.lt_trans with n; auto. Qed. Lemma degree_minus_lft : forall (p q : RX) m n, degree_le m p -> degree n q -> m < n -> degree n (q[-]p). Proof. intros. apply degree_wd with ( [--]p[+]q). Step_final (q[+][--]p). apply degree_plus_rht with m. apply degree_le_inv. auto. auto. auto. Qed. Lemma monic_plus : forall (p q : RX) m n, degree_le m p -> monic n q -> m < n -> monic n (p[+]q). Proof. unfold monic in |- *. unfold degree_le in |- *. intros. elim H0. clear H0. intros. split. astepl (nth_coeff n p[+]nth_coeff n q). astepl ([0][+]nth_coeff n q). Step_final (nth_coeff n q). intros. astepl (nth_coeff m0 p[+]nth_coeff m0 q). cut (m < m0). intro. Step_final ([0][+] ([0]:R)). apply Nat.lt_trans with n; auto. Qed. Lemma monic_minus : forall (p q : RX) m n, degree_le m p -> monic n q -> m < n -> monic n (q[-]p). Proof. intros. apply monic_wd with ( [--]p[+]q). Step_final (q[+][--]p). apply monic_plus with m. apply degree_le_inv. auto. auto. auto. Qed. Lemma degree_le_mult : forall (p q : RX) m n, degree_le m p -> degree_le n q -> degree_le (m + n) (p[*]q). Proof. unfold degree_le in |- *. intros. astepl (Sum 0 m0 (fun i : nat => nth_coeff i p[*]nth_coeff (m0 - i) q)). apply Sum_zero. auto with arith. intros. cut ({m < i} + {n < m0 - i}). intro. elim H4; clear H4; intros. Step_final ([0][*]nth_coeff (m0 - i) q). Step_final (nth_coeff i p[*][0]). elim (lt_eq_lt_dec m i); intro. elim a; intro. auto. right. lia. right. lia. Qed. Lemma degree_le_Product (l: list (cpoly R)) n: (forall p, In p l -> degree_le n p) -> degree_le (length l * n) (cr_Product l). Proof. induction l; intros. apply (degree_le_c_ [1]). change (degree_le (n + length l * n) (a [*] cr_Product l)). apply degree_le_mult; intuition. Qed. Lemma degree_le_mult_constant_l (p: cpoly R) (x: R) (n: nat): degree_le n p -> degree_le n (_C_ x [*] p). Proof with auto. intros. replace n with (0 + n)%nat... apply degree_le_mult... apply degree_le_c_. Qed. Lemma degree_le_mult_constant_r (p: cpoly R) (x: R) (n: nat): degree_le n p -> degree_le n (p [*] _C_ x). Proof with auto. intros. replace n with (n + 0)%nat... apply degree_le_mult... apply degree_le_c_. Qed. Lemma degree_mult_aux : forall (p q : RX) m n, degree_le m p -> degree_le n q -> nth_coeff (m + n) (p[*]q) [=] nth_coeff m p[*]nth_coeff n q. Proof. unfold degree_le in |- *. intros. astepl (Sum 0 (m + n) (fun i : nat => nth_coeff i p[*]nth_coeff (m + n - i) q)). astepl (Sum 0 m (fun i : nat => nth_coeff i p[*]nth_coeff (m + n - i) q) [+] Sum (S m) (m + n) (fun i : nat => nth_coeff i p[*]nth_coeff (m + n - i) q)). astepr (nth_coeff m p[*]nth_coeff n q[+][0]). apply bin_op_wd_unfolded. elim (O_or_S m); intro y. elim y. clear y. intros x y. rewrite <- y in H. rewrite <- y. apply eq_transitive_unfolded with (Sum 0 x (fun i : nat => nth_coeff i p[*]nth_coeff (S x + n - i) q) [+] nth_coeff (S x) p[*]nth_coeff (S x + n - S x) q). apply Sum_last with (f := fun i : nat => nth_coeff i p[*]nth_coeff (S x + n - i) q). astepr ([0][+]nth_coeff (S x) p[*]nth_coeff n q). apply bin_op_wd_unfolded. apply Sum_zero. auto with arith. intros. cut (n < S x + n - i). intro. Step_final (nth_coeff i p[*][0]). lia. replace (S x + n - S x) with n. algebra. auto with arith. rewrite <- y in H. rewrite <- y. pattern n at 2 in |- *. replace n with (0 + n - 0). apply Sum_one with (f := fun i : nat => nth_coeff i p[*]nth_coeff (0 + n - i) q). auto with arith. apply Sum_zero. auto with arith. intros. cut (m < i). intro. Step_final ([0][*]nth_coeff (m + n - i) q). auto. Qed. Lemma lead_coeff_product_1 (n: nat) (l: list (cpoly R)): (forall p, In p l -> (nth_coeff n p [=] [1] /\ degree_le n p)) -> nth_coeff (length l * n) (cr_Product l) [=] [1]. Proof with auto. intro H. induction l. simpl. reflexivity. change (nth_coeff (n + length l * n) (a [*] cr_Product l)[=][1]). rewrite degree_mult_aux. setoid_replace (nth_coeff n a) with ([1]:R). rewrite IHl. apply mult_one. intros. apply H... apply H... apply H... apply degree_le_Product. intros. apply H... Qed. Hint Resolve degree_mult_aux: algebra. Lemma monic_mult : forall (p q : RX) m n, monic m p -> monic n q -> monic (m + n) (p[*]q). Proof. unfold monic in |- *. intros. elim H. clear H. intros. elim H0. clear H0. intros. split. astepl (nth_coeff m p[*]nth_coeff n q). Step_final ([1][*] ([1]:R)). apply degree_le_mult; auto. Qed. Lemma degree_le_nexp : forall (p : RX) m n, degree_le m p -> degree_le (m * n) (p[^]n). Proof. intros. induction n as [| n Hrecn]; intros. replace (m * 0) with 0. apply degree_le_wd with (_C_ ([1]:R)). algebra. apply degree_le_c_. auto. replace (m * S n) with (m * n + m). apply degree_le_wd with (p[^]n[*]p). algebra. apply degree_le_mult; auto. auto. Qed. Lemma monic_nexp : forall (p : RX) m n, monic m p -> monic (m * n) (p[^]n). Proof. intros. induction n as [| n Hrecn]; intros. replace (m * 0) with 0. apply monic_wd with (_C_ ([1]:R)). algebra. apply monic_c_one. auto. replace (m * S n) with (m * n + m). apply monic_wd with (p[^]n[*]p). algebra. apply monic_mult; auto. auto. Qed. Lemma lt_i_lth_of_poly : forall i (p : RX), nth_coeff i p [#] [0] -> i < lth_of_poly p. Proof. intros i. induction i as [| i Hreci]; intros; rename X into H. induction p as [| s p Hrecp]; intros. simpl in H. elim (ap_irreflexive_unfolded _ _ H). simpl in |- *. auto with arith. induction p as [| s p Hrecp]; intros. simpl in H. elim (ap_irreflexive_unfolded _ _ H). simpl in |- *. simpl in H. apply -> Nat.succ_lt_mono. auto. Qed. Lemma poly_degree_lth : forall p : RX, degree_le (lth_of_poly p) p. Proof. unfold degree_le in |- *. intros. apply not_ap_imp_eq. intro. elim (proj1 (Nat.lt_nge _ _) H). apply Nat.lt_le_incl. apply lt_i_lth_of_poly. auto. Qed. Lemma Cpoly_ex_degree : forall p : RX, {n : nat | degree_le n p}. Proof. intros. exists (lth_of_poly p). apply poly_degree_lth. Qed. Lemma poly_as_sum'' : forall (p : RX) n, degree_le n p -> p [=] Sum 0 n (fun i => _C_ (nth_coeff i p) [*]_X_[^]i). Proof. unfold degree_le in |- *. intros. apply all_nth_coeff_eq_imp. intros. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (Sum 0 n (fun i0 : nat => nth_coeff i (_C_ (nth_coeff i0 p) [*]_X_[^]i0))). apply nth_coeff_sum with (p_ := fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i). apply eq_transitive_unfolded with (Sum 0 n (fun i0 : nat => nth_coeff i0 p[*]nth_coeff i (_X_[^]i0))). apply Sum_wd. intros. algebra. elim (le_lt_dec i n); intros. astepr (nth_coeff i p[*][1]). astepr (nth_coeff i p[*]nth_coeff i (_X_[^]i)). apply Sum_term with (i := i) (f := fun i0 : nat => nth_coeff i0 p[*]nth_coeff i (_X_[^]i0)). auto with arith. auto. intros. Step_final (nth_coeff j p[*][0]). astepr ([0]:R). apply Sum_zero. auto with arith. intros. cut (i <> i0). intro. Step_final (nth_coeff i0 p[*][0]). intro; rewrite <- H2 in H1. apply (Nat.le_ngt i n); auto. Qed. Hint Resolve poly_as_sum'': algebra. Lemma poly_as_sum' : forall p : RX, p [=] Sum 0 (lth_of_poly p) (fun i => _C_ (nth_coeff i p) [*]_X_[^]i). Proof. intros. apply poly_as_sum''. apply poly_degree_lth. Qed. Lemma poly_as_sum : forall (p : RX) n, degree_le n p -> forall x, p ! x [=] Sum 0 n (fun i => nth_coeff i p[*]x[^]i). Proof. intros. astepl (Sum 0 n (fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i)) ! x. apply eq_transitive_unfolded with (Sum 0 n (fun i : nat => (_C_ (nth_coeff i p) [*]_X_[^]i) ! x)). apply Sum_cpoly_ap with (f := fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i). apply Sum_wd. intros. astepl ((_C_ (nth_coeff i p)) ! x[*] (_X_[^]i) ! x). Step_final (nth_coeff i p[*]_X_ ! x[^]i). Qed. Lemma degree_le_zero : forall p : RX, degree_le 0 p -> {a : R | p [=] _C_ a}. Proof. unfold degree_le in |- *. intros. exists (nth_coeff 0 p). apply all_nth_coeff_eq_imp. intros. elim (O_or_S i); intro y. elim y. clear y. intros x y. rewrite <- y. cut (0 < S x). intro. Step_final ([0]:R). auto with arith. rewrite <- y. algebra. Qed. Lemma degree_le_1_imp : forall p : RX, degree_le 1 p -> {a : R | {b : R | p [=] _C_ a[*]_X_[+]_C_ b}}. Proof. unfold degree_le in |- *. intros. exists (nth_coeff 1 p). exists (nth_coeff 0 p). apply all_nth_coeff_eq_imp. intros. elim i; intros. simpl in |- *. ring. elim n; intros. simpl in |- *. algebra. simpl in |- *. apply H. auto with arith. Qed. Lemma degree_le_cpoly_linear : forall (p : cpoly R) c n, degree_le (S n) (c[+X*]p) -> degree_le n p. Proof. unfold degree_le in |- *. intros. change (nth_coeff (S m) (cpoly_linear _ c p) [=] [0]) in |- *. apply H. auto with arith. Qed. Lemma degree_le_cpoly_linear_inv (p: cpoly R) (c: R) (n: nat): degree_le n p -> degree_le (S n) (c[+X*]p). Proof. intros H [|m] E. inversion E. apply (H m). auto with arith. Qed. Lemma monic_cpoly_linear : forall (p : cpoly R) c n, monic (S n) (c[+X*]p) -> monic n p. Proof. unfold monic in |- *. intros. elim H. clear H. intros. split. auto. apply degree_le_cpoly_linear with c. auto. Qed. Lemma monic_one : forall (p : cpoly R) c, monic 1 (c[+X*]p) -> forall x, p ! x [=] [1]. Proof. intros. cut (monic 0 p). unfold monic in |- *. intros. elim H0. clear H0. intros H0 H1. elim (degree_le_zero _ H1). intro d. intros. astepl (_C_ d) ! x. astepl d. astepl (nth_coeff 0 (_C_ d)). Step_final (nth_coeff 0 p). apply monic_cpoly_linear with c. auto. Qed. Lemma monic_apzero : forall (p : RX) n, monic n p -> p [#] [0]. Proof. unfold monic in |- *. intros. elim H. clear H. intros. apply nth_coeff_ap_zero_imp with n. astepl ([1]:R). apply one_ap_zero. Qed. End Degree_props. #[global] Hint Resolve poly_as_sum'' poly_as_sum' poly_as_sum: algebra. #[global] Hint Resolve degree_mult_aux: algebra. Section degree_props_Field. (** ** Degrees of polynomials over a field %\begin{convention}% Let [F] be a field and write [FX] for the ring of polynomials over [F]. %\end{convention}% *) Variable F : CField. (* begin hide *) Notation FX := (cpoly_cring F). (* end hide *) Lemma degree_mult : forall (p q : FX) m n, degree m p -> degree n q -> degree (m + n) (p[*]q). Proof. unfold degree in |- *. intros. rename X into H. rename X0 into H0. elim H. clear H. intros H1 H2. elim H0. clear H0. intros H3 H4. split. astepl (nth_coeff m p[*]nth_coeff n q). algebra. apply degree_le_mult; auto. Qed. Lemma degree_nexp : forall (p : FX) m n, degree m p -> degree (m * n) (p[^]n). Proof. intros. induction n as [| n Hrecn]; intros. replace (m * 0) with 0. apply degree_wd with (_C_ ([1]:F)). algebra. apply degree_c_. algebra. auto. replace (m * S n) with (m * n + m). apply degree_wd with (p[^]n[*]p). algebra. apply degree_mult; auto. auto. Qed. Lemma degree_le_mult_imp : forall (p q : FX) m n, degree m p -> degree_le (m + n) (p[*]q) -> degree_le n q. Proof. unfold degree in |- *. unfold degree_le in |- *. intros. rename H0 into H1. rename H into H0. rename X into H. elim H. clear H. intros H2 H3. elim (Cpoly_ex_degree _ q). unfold degree_le in |- *. intro N. intro H4. (* Set_ not necessary *) cut (forall k i : nat, n < i -> N - k < i -> nth_coeff i q [=] [0]). intro H5. elim (le_lt_dec m0 N); intros H6. replace m0 with (N - (N - m0)). apply H5 with (N - n). lia. lia. lia. apply H4; auto. intro. induction k as [| k Hreck]; intros. apply H4. rewrite Nat.sub_0_r in H5; auto. elim (le_lt_eq_dec (N - k) i); try intro y. auto. rewrite y in Hreck. apply mult_cancel_lft with (nth_coeff m p). auto. astepr ([0]:F). apply eq_transitive_unfolded with (Sum 0 (m + i) (fun j : nat => nth_coeff j p[*]nth_coeff (m + i - j) q)). pattern i at 1 in |- *. replace i with (m + i - m). apply eq_symmetric_unfolded. apply Sum_term with (f := fun j : nat => nth_coeff j p[*]nth_coeff (m + i - j) q). auto with arith. auto with arith. intros. elim (le_lt_dec j m); intros. cut (i < m + i - j). intro. cut (n < m + i - j). intro. Step_final (nth_coeff j p[*][0]). lia. lia. Step_final ([0][*]nth_coeff (m + i - j) q). auto with arith. astepl (nth_coeff (m + i) (p[*]q)). cut (m + n < m + i). intro. auto. auto with arith. lia. Qed. Lemma degree_mult_imp : forall (p q : FX) m n, degree m p -> degree (m + n) (p[*]q) -> degree n q. Proof. unfold degree in |- *. intros. rename X into H. rename X0 into H0. elim H. clear H. intros H H1. elim H0. clear H0. intros H0 H2. cut (degree_le n q). intro H3. split. apply mult_cancel_ap_zero_rht with (nth_coeff m p). astepl (nth_coeff (m + n) (p[*]q)). auto. assumption. apply degree_le_mult_imp with p m; auto. unfold degree in |- *. split. auto. assumption. Qed. End degree_props_Field. corn-8.20.0/algebra/CPoly_Newton.v000066400000000000000000000430041473720167500167230ustar00rootroot00000000000000Require Import CoRN.model.totalorder.QposMinMax. Require Import Unicode.Utf8 Setoid Arith List Program Permutation metric2.Classified CSetoids CPoly_ApZero CPoly_Degree CRArith CRArith_alg Qmetric Qring CReals Ranges stdlib_omissions.Pair stdlib_omissions.Q list_separates SetoidPermutation CRings. Require MathClasses.implementations.ne_list. Import CRing_Homomorphisms.coercions. Import ne_list.notations ne_list.coercions. Coercion Vector.to_list: Vector.t >-> list. Local Open Scope CR_scope. Local Notation Σ := cm_Sum. Local Notation Π := cr_Product. Section continuous_vector_operations. Context `{MetricSpaceClass X} (n: nat). Definition uncurry_Vector_cons: X * Vector.t X n → Vector.t X (S n) := λ p, Vector.cons _ (fst p) _ (snd p). Global Instance Vector_cons_mu: UniformlyContinuous_mu uncurry_Vector_cons := { uc_mu := Qpos2QposInf }. End continuous_vector_operations. Section contents. Notation QPoint := (Q * CR)%type. Notation CRPoint := (CR * CR)%type. (** Definition of the Newton polynomial: *) Fixpoint divdiff_l (a: QPoint) (xs: list QPoint) {struct xs} : CR := match xs with | nil => snd a | cons b l => (divdiff_l a l - divdiff_l b l) * ' / (fst a - fst b) end. Definition divdiff (l: ne_list QPoint): CR := divdiff_l (ne_list.head l) (ne_list.tail l). Lemma divdiff_e (l: ne_list QPoint): divdiff l = match l with | ne_list.one a => snd a | a ::: ne_list.one b => (snd a - snd b) * ' / (fst a - fst b) | a ::: b ::: l => (divdiff (ne_list.cons a l) - divdiff (ne_list.cons b l)) * ' / (fst a - fst b) end. Proof. induction l as [|?[|]]; auto. Qed. Definition divdiff_ind {T} (P: ne_list T → Prop) (Pone: ∀ p, P (ne_list.one p)) (Ptwo: ∀ p q, P (p ::: ne_list.one q)) (Pmore: ∀ a b l, P (a ::: l) → P (b ::: l) → P (a ::: b ::: l)): forall l, P l. Proof with simpl; auto. cut (forall t h, P (ne_list.from_list h t)). intros. rewrite (ne_list.decomp_eq l)... induction t... destruct t; simpl... intros. apply Pmore; apply IHt. Qed. Opaque CR. Lemma divdiff_sum (xs: ne_list (Q * (CR * CR))): divdiff (ne_list.map (second fst) xs) + divdiff (ne_list.map (second snd) xs) == divdiff (ne_list.map (second (λ x: CR * CR, fst x + snd x)) xs). Proof with auto. induction xs using divdiff_ind; do 3 rewrite divdiff_e; simpl in *. reflexivity. generalize (' (/ (fst p - fst q))). intro. simpl. ring. generalize (' (/ (fst a - fst b))). intro. simpl. rewrite <- IHxs, <- IHxs0. simpl. ring. Qed. Lemma divdiff_scalar_mult (c: CR) (xs: ne_list QPoint): c * divdiff xs == divdiff (ne_list.map (second (CRmult c)) xs). Proof with auto. induction xs using divdiff_ind; simpl. reflexivity. change ((c * ((snd p - snd q) * ' (/ (fst p - fst q)))) == (c * snd p - c * snd q) * ' (/ (fst p - fst q))). set (/ (fst p - fst q)). ring. rewrite divdiff_e. set (' (/ (fst a - fst b))). transitivity ((c * divdiff (a ::: xs) - c * divdiff (b ::: xs)) * m). ring. rewrite IHxs, IHxs0. symmetry. rewrite divdiff_e. simpl. fold m. ring. Qed. Lemma divdiff_product (xs: ne_list (Q * (CR * CR))): divdiff (ne_list.map (second (λ x: CR * CR, fst x * snd x)) xs) == @cm_Sum CRasCMonoid (map (λ p, divdiff (ne_list.map (second fst) (fst p)) * divdiff (ne_list.map (second snd) (snd p))) (zip (ne_list.tails xs) (ne_list.inits xs))). Proof with simpl in *; auto. intros. induction xs using divdiff_ind. unfold divdiff... ring. unfold divdiff... set (' (/ (fst p - fst q))). ring. rewrite divdiff_e. set (λ p : ne_list (Q and CR and CR) and ne_list (Q and CR and CR), divdiff (ne_list.map (second fst) (fst p)) * divdiff (ne_list.map (second snd) (snd p))) as s in *. simpl in *. rewrite IHxs, IHxs0. repeat rewrite ne_list.list_map. repeat rewrite zip_map_snd. repeat rewrite map_map_comp. generalize (zip (ne_list.tails xs) (ne_list.inits xs)). intro. set (s0 := ' (/ (fst a - fst b))). transitivity ((s (a ::: xs, ne_list.one a) - s (b ::: xs, ne_list.one b)) * s0 + (@Σ CRasCMonoid (map (s ∘ second (ne_list.cons a))%prg l) - @Σ CRasCMonoid (map (s ∘ second (ne_list.cons b))%prg l)) * s0)... ring. setoid_replace ((s (a ::: xs, ne_list.one a) - s (b ::: xs, ne_list.one b)) * s0) with (s (a ::: b ::: xs, ne_list.one a) + (s (b ::: xs, a ::: ne_list.one b))). setoid_replace ((@Σ CRasCMonoid (map (s ∘ second (ne_list.cons a))%prg l) - @Σ CRasCMonoid (map (s ∘ second (ne_list.cons b))%prg l)) * s0) with (@Σ CRasCMonoid (map (s ∘ second (ne_list.cons a) ∘ second (ne_list.cons b))%prg l))... ring. induction l... ring. rewrite <- IHl. unfold Basics.compose at 1 3 5 6... subst s... rewrite (divdiff_e (second snd a ::: second snd b ::: ne_list.map (second snd) (snd a0)))... fold s0. ring. subst s... unfold divdiff at 2 4 6... rewrite (divdiff_e (second fst a ::: second fst b ::: ne_list.map (second fst) xs)). generalize (divdiff (second fst a ::: ne_list.map (second fst) xs)). intro. generalize (divdiff (second fst b ::: ne_list.map (second fst) xs)). intro. rewrite divdiff_e... fold s0. ring. Qed. Lemma divdiff_chain (f : Q ->CR) (x y u v: Q): let l:=(x,u):::ne_list.one (y,v) in let sndl:=(ne_list.map snd l) in ¬(u-v == 0)%Q -> (divdiff (ne_list.map (second f ) l)) == (divdiff (ne_zip sndl (ne_list.map f sndl))) * (divdiff (ne_list.map (second inject_Q_CR) l)). Proof with auto;simpl. intros. do 3 rewrite divdiff_e... (* want a combination of ring and a rewrite database for inject_Q ? *) set (s:=f u - f v). set (t:='(/ (x - y))). rewrite CRminus_Qminus. set (a:=(u-v)%Q). transitivity (s * ' (/ (a) * (a))%Q * t). rewrite <- (Qmult_comm a). rewrite Qmult_inv_r... ring. rewrite <- (@CRmult_Qmult (/a) a). set (' (/a)). ring. Qed. Let an (xs: ne_list QPoint): cpoly CRasCRing := (polyconst CRasCRing (divdiff xs)) [*] Π (map (fun x => @cpoly_linear_fun' CRasCRing (' (- fst x)%Q) [1]) (tl xs)). Section with_qpoints. Variable qpoints: ne_list QPoint. Definition N: cpoly CRasCRing := Σ (map an (ne_list.tails qpoints)). (** Degree: *) Let an_degree (xs: ne_list QPoint): degree_le (length (tl xs)) (an xs). Proof with auto. intros. unfold an. replace (length (tl xs)) with (0 + length (tl xs))%nat by reflexivity. apply degree_le_mult. apply degree_le_c_. replace (length (tl xs)) with (length (map (fun x => @cpoly_linear_fun' CRasCRing (' (-fst x)%Q) [1]) (tl xs)) * 1)%nat. apply degree_le_Product. intros. apply in_map_iff in H. destruct H. destruct H. rewrite <- H. apply degree_le_cpoly_linear_inv. apply (degree_le_c_ CRasCRing [1]). ring_simplify. rewrite map_length. destruct xs; reflexivity. Qed. Lemma degree: degree_le (length (tl qpoints)) N. Proof with auto. intros. unfold N. apply degree_le_Sum. intros. apply in_map_iff in H. destruct H as [x [H H0]]. subst p. apply degree_le_mon with (length (tl x)). pose proof (ne_list.tails_are_shorter qpoints x H0). destruct x, qpoints; auto with arith. apply an_degree. Qed. (** Applying this polynomial gives what you'd expect: *) Definition an_applied (x: Q) (txs: ne_list QPoint) : CR := divdiff txs * ' @cr_Product Q_as_CRing (map (Qminus x ∘ fst)%prg (tail txs)). Definition applied (x: Q) := @Σ CRasCMonoid (map (an_applied x) (ne_list.tails qpoints)). Lemma apply x: (N ! ' x) [=] applied x. Proof. unfold N, applied, an, an_applied. rewrite cm_Sum_apply, map_map. apply (@cm_Sum_eq CRasCMonoid). intro. autorewrite with apply. apply mult_wd. reflexivity. rewrite inject_Q_product. rewrite cr_Product_apply. do 2 rewrite map_map. apply (@cm_Sum_eq (Build_multCMonoid CRasCRing)). intro. unfold Basics.compose. rewrite <- CRminus_Qminus. change ((' (- fst x1)%Q + ' x * (1 + ' x * 0)) == (' x - ' fst x1)). ring. Qed. End with_qpoints. (** Next, some lemmas leading up to the proof that the polynomial does indeed interpolate the given points: *) Let applied_cons (y: Q) (x: QPoint) (xs: ne_list QPoint): applied (x ::: xs) y = an_applied y (x ::: xs) + applied xs y. Proof. reflexivity. Qed. Let N_cons (x: QPoint) (xs: ne_list QPoint): N (x ::: xs) = an (x ::: xs) [+] N xs. Proof. reflexivity. Qed. Lemma an_applied_0 (t: QPoint) (x: Q) (xs: ne_list QPoint): In x (map fst xs) -> an_applied x (t ::: xs) == 0. Proof with auto. intros. unfold an_applied. simpl @tl. rewrite (@cr_Product_0 Q_as_CRing (x - x))%Q. change (divdiff (t ::: xs) * 0 == 0). apply (cring_mult_zero CRasCRing). change (x - x == 0)%Q. ring. unfold Basics.compose. rewrite <- map_map. apply in_map... Qed. Lemma applied_head (x y: QPoint) (xs: ne_list QPoint): Qred (fst x) <> Qred (fst y) -> applied (x ::: y ::: xs) (fst x) [=] applied (x ::: xs) (fst x). Proof with auto. intro E. repeat rewrite applied_cons. cut (an_applied (fst x) (x ::: y ::: xs) + (an_applied (fst x) (y ::: xs)) == an_applied (fst x) (x ::: xs)). intro H. rewrite <- H. change (an_applied (fst x) (x ::: y ::: xs) + (an_applied (fst x) (y ::: xs) + applied xs (fst x)) == an_applied (fst x) (x ::: y ::: xs)+an_applied (fst x) (y ::: xs) + applied xs (fst x))%CR. ring. change ((divdiff_l x xs - divdiff_l y xs) * ' (/ (fst x - fst y)) * ' (Qminus (fst x) (fst y) * @cr_Product Q_as_CRing (map (Qminus (fst x) ∘ fst)%prg xs))%Q+ divdiff_l y xs * ' @cr_Product Q_as_CRing (map (Qminus (fst x) ∘ fst)%prg xs) == divdiff_l x xs * ' @cr_Product Q_as_CRing (map (Qminus (fst x) ∘ fst)%prg xs)). generalize (@cr_Product Q_as_CRing (map (Qminus (fst x) ∘ fst)%prg xs)). intros. rewrite CRmult_assoc. change ((((divdiff_l x xs - divdiff_l y xs)*(' (/ (fst x - fst y))%Q*' ((fst x - fst y)*s)%Q) + divdiff_l y xs * ' s)) == divdiff_l x xs*' s)%CR. rewrite CRmult_Qmult. setoid_replace ((/ (fst x - fst y) * ((fst x - fst y) * s)))%Q with s. ring. rewrite Qmult_assoc. change ((/ (fst x - fst y) * (fst x - fst y) * s)==s)%Q. field. intro. apply -> Q.Qminus_eq in H. apply E. apply Qred_complete... Qed. Section again_with_qpoints. Variables (qpoints: ne_list QPoint) (H: QNoDup (map fst qpoints)). Let crpoints := ne_list.map (first inject_Q_CR) qpoints. Lemma interpolates: @interpolates CRasCField crpoints (N qpoints). Proof with simpl; auto. unfold interpolates. unfold crpoints. rewrite ne_list.list_map. intros xy H0. destruct (proj1 (in_map_iff _ _ _) H0) as [[x y] [? B]]. clear H0. subst xy. unfold first. simpl @fst. simpl @snd. rewrite apply. revert x y B. induction qpoints using ne_list.two_level_rect. intros u v [? | []]. subst x. change (v * 1 + 0 == v)%CR. ring. intros. rewrite applied_cons. change (((snd x - snd y) * ' (/ (fst x - fst y)) * ' ((x0 - fst y) * 1)%Q + (snd y * 1 + 0)) == y0)%CR. rewrite Qmult_1_r. destruct B. subst. rewrite CRmult_assoc. change ((y0 - snd y)*(' (/ (x0 - fst y))* '(x0 - fst y)%Q) + (snd y * 1 + 0)==y0)%CR. rewrite CRmult_Qmult. setoid_replace (/ (x0 - fst y) * (x0 - fst y))%Q with 1%Q. ring. simpl. field. intro. apply -> Q.Qminus_eq in H0. inversion_clear H. apply H1. simpl. left. apply Q.Proper_instance_0. (* For some reason using [rewrite] here is crazy slow. Todo: Investigate. *) symmetry. assumption. destruct H0. subst. simpl @fst. simpl @snd. rewrite (proj2 (Q.Qminus_eq x0 x0)). rewrite (cring_mult_zero CRasCRing). change (0 + (y0 * 1 + 0) == y0)%CR. ring. reflexivity. exfalso... clear qpoints. simpl @In. intros x0 y0 [H1 | H1]. subst. rewrite applied_head. apply H0... inversion_clear H. unfold QNoDup. simpl. apply NoDup_cons. intuition. inversion_clear H2. intuition. intro. inversion_clear H. apply H2. simpl in H1. rewrite H1... rewrite applied_cons. assert (QNoDup (map fst (y :: l))). inversion_clear H... rewrite (H0 y H2 x0 y0). rewrite an_applied_0... change (0 + y0 == y0). ring. destruct H1. subst... right... apply (in_map fst l (x0, y0))... destruct H1... Qed. (* Todo: Clean up more. *) Lemma interpolates_economically: @interpolates_economically CRasCField crpoints (N qpoints). Proof. split. apply interpolates. unfold crpoints. rewrite ne_list.list_map, tl_map, map_length. apply degree. Qed. (** Uniqueness of interpolating polynomials of minimal degree now lets us prove some things about any such polynomial based on what we know about this Newton polynomial: *) Lemma coincides_with_polynomial_interpolators (p: cpoly CRasCRing): @CPoly_ApZero.interpolates_economically CRasCField crpoints p → N qpoints [=] p. Proof with auto. apply (@interpolation_unique CRasCField crpoints). unfold crpoints. rewrite ne_list.list_map, map_fst_map_first. apply (CNoDup_map _ inject_Q_CR). apply CNoDup_weak with Qap... intros. apply Qap_CRap... apply QNoDup_CNoDup_Qap... apply interpolates_economically. Qed. Lemma N_leading_coefficient: nth_coeff (length (tl qpoints)) (N qpoints) == divdiff qpoints. Proof with try ring. destruct qpoints. change (divdiff (ne_list.one p) * 1 + 0 == divdiff (ne_list.one p))... simpl @length. rewrite N_cons. rewrite nth_coeff_plus. rewrite (degree l (length l)). 2: destruct l; simpl; auto. change (nth_coeff (length l) (an (p ::: l))+0==divdiff (p ::: l)). (* to change [+] into + *) ring_simplify. unfold an. rewrite nth_coeff_c_mult_p. simpl tl. set (f := fun x: Q and CR => @cpoly_linear_fun' CRasCRing (' (- fst x)%Q) [1]). replace (length l) with (length (map f l) * 1)%nat. rewrite lead_coeff_product_1. change (divdiff (p ::: l)*1 == divdiff (p ::: l))... (* to change [*] into * *) intros q. rewrite in_map_iff. intros [x [[] B]]. split. reflexivity. apply degree_le_cpoly_linear_inv. apply (degree_le_c_ CRasCRing [1]). rewrite map_length... Qed. (** So now we know that the divided difference is the leading coefficient of /any/ economically interpolating polynomial: *) Lemma leading_coefficient (p: cpoly CRasCRing): @CPoly_ApZero.interpolates_economically CRasCField crpoints p → nth_coeff (length (tl qpoints)) p == divdiff qpoints. Proof with auto. intros. rewrite <- coincides_with_polynomial_interpolators... apply N_leading_coefficient. Qed. End again_with_qpoints. Fixpoint ne_list_zip {X Y} (xs: ne_list X) (ys: ne_list Y): ne_list (X * Y) := match xs, ys with | ne_list.cons x xs', ne_list.cons y ys' => ne_list.cons (x, y) (ne_list_zip xs' ys') | _, _ => ne_list.one (ne_list.head xs, ne_list.head ys) end. Definition Q01 := sig (λ x: Q, 0 <= x <= 1). Definition Range (T: Type) := prod T T. Class Container (Elem C: Type) := In: C → Elem → Prop. Hint Unfold In. Notation "x ∈ y" := (In y x) (at level 40). Notation "(∈ y )" := (In y) (at level 40). Notation "x ∉ y" := (In y x → False) (at level 40). Instance in_QRange: Container Q (Range Q) := λ r x, fst r <= x <= snd r. Arguments proj1_sig {A P}. Program Instance in_sig_QRange (P: Q → Prop): Container (sig P) (Range (sig P)) := λ r x, fst r <= x <= snd r. Definition B01: Ball Q Qpos := (1#2, (1#2)%Qpos). Section divdiff_as_repeated_integral. Context (n: nat) (points: Vector.t Q (S n)) (lo hi: Q). Definition lohi (q: Q): Prop := lo <= q <= hi. Definition Qbp: Type := sig lohi. (* Context (points_lohi: Vector.Forall lohi points) (upper: CR) (nth_deriv: Q → CR (*sig (λ x: CR, x <= upper)*)) `{!UniformlyContinuous_mu nth_deriv} `{!UniformlyContinuous nth_deriv} (* Todo: This should be replaced with some "n times differentiable" requirement on a subject function. *) (integrate: Range Q01 * UCFunction Q01 CR → CR) `{!UniformlyContinuous_mu integrate} `{!UniformlyContinuous integrate}. (* Todo: The integration function should not be a parameter. We should just use SimpleIntegration's implementation. *) *) (* Require Import CRabs. Import QnonNeg.notations. Definition ZeroRangeToBall (q: QnonNeg.T): Ball Q QnonNeg.T := (0, ((1#2) * q)%Qnn). Variable integrate_on_01: ∀ (u: QnonNeg.T) (f: sig (contains (ZeroRangeToBall u)) → CR) c, (∀ x, CRabs (f x) <= c) → CRabs (integrate _ f) <= c. *) Opaque Qmult Qplus Qminus. (* Without these, instance resolution gets a little too enthusiastic and breaks these operations open when looking for PointFree instances below. It's actually kinda neat that it can put these in PointFree form though. *) Notation SomeWeights n := ((*sig (λ ts:*) Vector.t Q01 n (*, cm_Sum (map proj1_sig ts) <= 1)%Q*)). Notation Weights := ((*sig (λ ts:*) Vector.t Q01 (S n) (*, cm_Sum (map proj1_sig ts) == 1)%Q*)). (** apply_weights: *) Obligation Tactic := idtac. (** "inner", the function of n weights: *) (* Next up is "reduce", which *) End divdiff_as_repeated_integral. End contents. corn-8.20.0/algebra/CPoly_NthCoeff.v000066400000000000000000000316061473720167500171520ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CPolynomials. Require Import Coq.Classes.Morphisms. Require Import CoRN.algebra.CRings. Import CRing_Homomorphisms.coercions. (** * Polynomials: Nth Coefficient %\begin{convention}% Let [R] be a ring and write [RX] for the ring of polynomials over [R]. %\end{convention}% ** Definitions *) Section NthCoeff_def. Variable R : CRing. (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) (** The [n]-th coefficient of a polynomial. The default value is [Zero:CR] e.g. if the [n] is higher than the length. For the polynomial $a_0 +a_1 X +a_2 X^2 + \cdots + a_n X^n$ #a0 +a1 X +a2 X^2 + ... + an X^n#, the [Zero]-th coefficient is $a_0$#a0#, the first is $a_1$#a1# etcetera. *) Arguments cpoly_zero {CR}. Arguments cpoly_linear [CR]. Fixpoint nth_coeff (n : nat) (p : RX) {struct p} : R := match p with | cpoly_zero => [0] | cpoly_linear c q => match n with | O => c | S m => nth_coeff m q end end. Lemma nth_coeff_strext : forall n p p', nth_coeff n p [#] nth_coeff n p' -> p [#] p'. Proof. do 3 intro. generalize n. clear n. pattern p, p' in |- *. apply Ccpoly_double_sym_ind. unfold Csymmetric in |- *. intros. apply ap_symmetric_unfolded. apply X with n. apply ap_symmetric_unfolded. assumption. intro p0. pattern p0 in |- *. apply Ccpoly_induc. simpl in |- *. intros. elim (ap_irreflexive_unfolded _ _ X). do 4 intro. elim n. simpl in |- *. auto. intros. cut (c [#] [0] or p1 [#] [0]). intro; apply _linear_ap_zero. auto. right. apply X with n0. astepr ([0]:R). auto. intros. induction n as [| n Hrecn]. simpl in X0. cut (c [#] d or p0 [#] q). auto. auto. cut (c [#] d or p0 [#] q). auto. right. apply X with n. exact X0. Qed. Lemma nth_coeff_wd : forall n p p', p [=] p' -> nth_coeff n p [=] nth_coeff n p'. Proof. intros. generalize (fun_strext_imp_wd _ _ (nth_coeff n)); intro. unfold fun_wd in H0. apply H0. unfold fun_strext in |- *. intros. apply nth_coeff_strext with n. assumption. assumption. Qed. Global Instance: forall n, Proper (@st_eq _ ==> @st_eq _) (nth_coeff n). Proof. intros n ??. apply (nth_coeff_wd n). Qed. Definition nth_coeff_fun n := Build_CSetoid_fun _ _ _ (nth_coeff_strext n). (** %\begin{shortcoming}% We would like to use [nth_coeff_fun n] all the time. However, Coq's coercion mechanism doesn't support this properly: the term [(nth_coeff_fun n p)] won't get parsed, and has to be written as [((nth_coeff_fun n) p)] instead. So, in the names of lemmas, we write [(nth_coeff n p)], which always (e.g. in proofs) can be converted to [((nth_coeff_fun n) p)]. %\end{shortcoming}% *) Definition nonConst p : CProp := {n : nat | 0 < n | nth_coeff n p [#] [0]}. (** The following is probably NOT needed. These functions are NOT extensional, that is, they are not CSetoid functions. *) Fixpoint nth_coeff_ok (n : nat) (p : RX) {struct p} : bool := match n, p with | O, cpoly_zero => false | O, cpoly_linear c q => true | S m, cpoly_zero => false | S m, cpoly_linear c q => nth_coeff_ok m q end. (* The in_coeff predicate*) Fixpoint in_coeff (c : R) (p : RX) {struct p} : Prop := match p with | cpoly_zero => False | cpoly_linear d q => c [=] d \/ in_coeff c q end. (** The [cpoly_zero] case should be [c [=] [0]] in order to be extensional. *) Lemma nth_coeff_S : forall m p c, in_coeff (nth_coeff m p) p -> in_coeff (nth_coeff (S m) (c[+X*]p)) (c[+X*]p). Proof. simpl in |- *; auto. Qed. End NthCoeff_def. Arguments nth_coeff [R]. Arguments nth_coeff_fun [R]. #[global] Hint Resolve nth_coeff_wd: algebra_c. Section NthCoeff_props. (** ** Properties of [nth_coeff] *) Variable R : CRing. (* begin hide *) Notation RX := (cpoly_cring R). (* end hide *) Lemma nth_coeff_zero : forall n, nth_coeff n ([0]:RX) [=] [0]. Proof. intros. simpl in |- *. algebra. Qed. Lemma coeff_O_lin : forall p (c : R), nth_coeff 0 (c[+X*]p) [=] c. Proof. intros. simpl in |- *. algebra. Qed. Lemma coeff_Sm_lin : forall p (c : R) m, nth_coeff (S m) (c[+X*]p) [=] nth_coeff m p. Proof. intros. simpl in |- *. algebra. Qed. Lemma coeff_O_c_ : forall c : R, nth_coeff 0 (_C_ c) [=] c. Proof. intros. simpl in |- *. algebra. Qed. Lemma coeff_O_x_mult : forall p : RX, nth_coeff 0 (_X_[*]p) [=] [0]. Proof. intros. astepl (nth_coeff 0 ([0][+]_X_[*]p)). astepl (nth_coeff 0 (_C_ [0][+]_X_[*]p)). astepl (nth_coeff 0 ([0][+X*]p)). simpl in |- *. algebra. Qed. Lemma coeff_Sm_x_mult : forall (p : RX) m, nth_coeff (S m) (_X_[*]p) [=] nth_coeff m p. Proof. intros. astepl (nth_coeff (S m) ([0][+]_X_[*]p)). astepl (nth_coeff (S m) (_C_ [0][+]_X_[*]p)). astepl (nth_coeff (S m) ([0][+X*]p)). simpl in |- *. algebra. Qed. Lemma coeff_Sm_mult_x_ : forall (p : RX) m, nth_coeff (S m) (p[*]_X_) [=] nth_coeff m p. Proof. intros. astepl (nth_coeff (S m) (_X_[*]p)). apply coeff_Sm_x_mult. Qed. Hint Resolve nth_coeff_zero coeff_O_lin coeff_Sm_lin coeff_O_c_ coeff_O_x_mult coeff_Sm_x_mult coeff_Sm_mult_x_: algebra. Lemma nth_coeff_ap_zero_imp : forall (p : RX) n, nth_coeff n p [#] [0] -> p [#] [0]. Proof. intros. cut (nth_coeff n p [#] nth_coeff n [0]). intro H0. apply (nth_coeff_strext _ _ _ _ H0). algebra. Qed. Lemma nth_coeff_plus : forall (p q : RX) n, nth_coeff n (p[+]q) [=] nth_coeff n p[+]nth_coeff n q. Proof. do 2 intro. pattern p, q in |- *. apply poly_double_comp_ind. intros. astepl (nth_coeff n (p1[+]q1)). astepr (nth_coeff n p1[+]nth_coeff n q1). apply H1. intros. simpl in |- *. algebra. intros. elim n. simpl in |- *. algebra. intros. astepl (nth_coeff n0 (p0[+]q0)). generalize (H n0); intro. astepl (nth_coeff n0 p0[+]nth_coeff n0 q0). algebra. Qed. Lemma nth_coeff_inv : forall (p : RX) n, nth_coeff n [--]p [=] [--] (nth_coeff n p). Proof. intro. pattern p in |- *. apply cpoly_induc. intros. simpl in |- *. algebra. intros. elim n. simpl in |- *. algebra. intros. simpl in |- *. apply H. Qed. Hint Resolve nth_coeff_inv: algebra. Lemma nth_coeff_c_mult_p : forall (p : RX) c n, nth_coeff n (_C_ c[*]p) [=] c[*]nth_coeff n p. Proof. do 2 intro. pattern p in |- *. apply cpoly_induc. intros. astepl (nth_coeff n ([0]:RX)). astepr (c[*][0]). astepl ([0]:R). algebra. intros. elim n. simpl in |- *. algebra. intros. astepl (nth_coeff (S n0) (c[*]c0[+X*]_C_ c[*]p0)). astepl (nth_coeff n0 (_C_ c[*]p0)). astepl (c[*]nth_coeff n0 p0). algebra. Qed. Lemma nth_coeff_p_mult_c_ : forall (p : RX) c n, nth_coeff n (p[*]_C_ c) [=] nth_coeff n p[*]c. Proof. intros. astepl (nth_coeff n (_C_ c[*]p)). astepr (c[*]nth_coeff n p). apply nth_coeff_c_mult_p. Qed. Hint Resolve nth_coeff_c_mult_p nth_coeff_p_mult_c_ nth_coeff_plus: algebra. Lemma nth_coeff_complicated : forall a b (p : RX) n, nth_coeff (S n) ((_C_ a[*]_X_[+]_C_ b) [*]p) [=] a[*]nth_coeff n p[+]b[*]nth_coeff (S n) p. Proof. intros. astepl (nth_coeff (S n) (_C_ a[*]_X_[*]p[+]_C_ b[*]p)). astepl (nth_coeff (S n) (_C_ a[*]_X_[*]p) [+]nth_coeff (S n) (_C_ b[*]p)). astepl (nth_coeff (S n) (_C_ a[*] (_X_[*]p)) [+]b[*]nth_coeff (S n) p). astepl (a[*]nth_coeff (S n) (_X_[*]p) [+]b[*]nth_coeff (S n) p). algebra. Qed. Lemma all_nth_coeff_eq_imp : forall p p' : RX, (forall i, nth_coeff i p [=] nth_coeff i p') -> p [=] p'. Proof. intro. induction p as [| s p Hrecp]; intros; [ induction p' as [| s p' Hrecp'] | induction p' as [| s0 p' Hrecp'] ]; intros. algebra. simpl in |- *. simpl in H. simpl in Hrecp'. split. apply eq_symmetric_unfolded. apply (H 0). apply Hrecp'. intros. apply (H (S i)). simpl in |- *. simpl in H. simpl in Hrecp. split. apply (H 0). change ([0] [=] (p:RX)) in |- *. apply eq_symmetric_unfolded. simpl in |- *. apply Hrecp. intros. apply (H (S i)). simpl in |- *. simpl in H. split. apply (H 0). change ((p:RX) [=] (p':RX)) in |- *. apply Hrecp. intros. apply (H (S i)). Qed. Lemma poly_at_zero : forall p : RX, p ! [0] [=] nth_coeff 0 p. Proof. intros. induction p as [| s p Hrecp]; intros. simpl in |- *. algebra. simpl in |- *. Step_final (s[+][0]). Qed. Lemma nth_coeff_inv' : forall (p : RX) i, nth_coeff i (cpoly_inv _ p) [=] [--] (nth_coeff i p). Proof. intros. change (nth_coeff i [--] (p:RX) [=] [--] (nth_coeff i p)) in |- *. algebra. Qed. Lemma nth_coeff_minus : forall (p q : RX) i, nth_coeff i (p[-]q) [=] nth_coeff i p[-]nth_coeff i q. Proof. intros. astepl (nth_coeff i (p[+][--]q)). astepl (nth_coeff i p[+]nth_coeff i [--]q). Step_final (nth_coeff i p[+][--] (nth_coeff i q)). Qed. Hint Resolve nth_coeff_minus: algebra. Lemma nth_coeff_sum0 : forall (p_ : nat -> RX) k n, nth_coeff k (Sum0 n p_) [=] Sum0 n (fun i => nth_coeff k (p_ i)). Proof. intros. induction n as [| n Hrecn]; intros. simpl in |- *. algebra. change (nth_coeff k (Sum0 n p_[+]p_ n) [=] Sum0 n (fun i : nat => nth_coeff k (p_ i)) [+]nth_coeff k (p_ n)) in |- *. Step_final (nth_coeff k (Sum0 n p_) [+]nth_coeff k (p_ n)). Qed. Lemma nth_coeff_sum : forall (p_ : nat -> RX) k m n, nth_coeff k (Sum m n p_) [=] Sum m n (fun i => nth_coeff k (p_ i)). Proof. unfold Sum in |- *. unfold Sum1 in |- *. intros. astepl (nth_coeff k (Sum0 (S n) p_) [-]nth_coeff k (Sum0 m p_)). apply cg_minus_wd; apply nth_coeff_sum0. Qed. Lemma nth_coeff_nexp_eq : forall i, nth_coeff i (_X_[^]i) [=] ([1]:R). Proof. intros. induction i as [| i Hreci]; intros. simpl in |- *. algebra. change (nth_coeff (S i) (_X_[^]i[*]_X_) [=] ([1]:R)) in |- *. Step_final (nth_coeff i (_X_[^]i):R). Qed. Lemma nth_coeff_nexp_neq : forall i j, i <> j -> nth_coeff i (_X_[^]j) [=] ([0]:R). Proof. intro; induction i as [| i Hreci]; intros; [ induction j as [| j Hrecj] | induction j as [| j Hrecj] ]; intros. elim (H (refl_equal _)). Step_final (nth_coeff 0 (_X_[*]_X_[^]j):R). simpl in |- *. algebra. change (nth_coeff (S i) (_X_[^]j[*]_X_) [=] ([0]:R)) in |- *. astepl (nth_coeff i (_X_[^]j):R). apply Hreci. auto. Qed. Lemma nth_coeff_mult : forall (p q : RX) n, nth_coeff n (p[*]q) [=] Sum 0 n (fun i => nth_coeff i p[*]nth_coeff (n - i) q). Proof. intro; induction p as [| s p Hrecp]. intros. stepl (nth_coeff n ([0]:RX)). simpl in |- *. apply eq_symmetric_unfolded. apply Sum_zero. auto with arith. intros. algebra. apply nth_coeff_wd. change ([0][=][0][*]q). algebra. intros. apply eq_transitive_unfolded with (nth_coeff n (_C_ s[*]q[+]_X_[*] ((p:RX) [*]q))). apply nth_coeff_wd. change ((s[+X*]p) [*]q [=] _C_ s[*]q[+]_X_[*] ((p:RX) [*]q)) in |- *. astepl ((_C_ s[+]_X_[*]p) [*]q). Step_final (_C_ s[*]q[+]_X_[*]p[*]q). astepl (nth_coeff n (_C_ s[*]q) [+]nth_coeff n (_X_[*] ((p:RX) [*]q))). astepl (s[*]nth_coeff n q[+]nth_coeff n (_X_[*] ((p:RX) [*]q))). induction n as [| n Hrecn]; intros. astepl (s[*]nth_coeff 0 q[+][0]). astepl (s[*]nth_coeff 0 q). astepl (nth_coeff 0 (cpoly_linear _ s p) [*]nth_coeff 0 q). pattern 0 at 2 in |- *. replace 0 with (0 - 0). apply eq_symmetric_unfolded. apply Sum_one with (f := fun i : nat => nth_coeff i (cpoly_linear _ s p) [*]nth_coeff (0 - i) q). auto. astepl (s[*]nth_coeff (S n) q[+]nth_coeff n ((p:RX) [*]q)). apply eq_transitive_unfolded with (nth_coeff 0 (cpoly_linear _ s p) [*]nth_coeff (S n - 0) q[+] Sum 1 (S n) (fun i : nat => nth_coeff i (cpoly_linear _ s p) [*]nth_coeff (S n - i) q)). apply bin_op_wd_unfolded. algebra. astepl (Sum 0 n (fun i : nat => nth_coeff i p[*]nth_coeff (n - i) q)). apply Sum_shift. intros. simpl in |- *. algebra. apply eq_symmetric_unfolded. apply Sum_first with (f := fun i : nat => nth_coeff i (cpoly_linear _ s p) [*]nth_coeff (S n - i) q). Qed. End NthCoeff_props. #[global] Hint Resolve nth_coeff_wd: algebra_c. #[global] Hint Resolve nth_coeff_complicated poly_at_zero nth_coeff_inv: algebra. #[global] Hint Resolve nth_coeff_inv' nth_coeff_c_mult_p nth_coeff_mult: algebra. #[global] Hint Resolve nth_coeff_zero nth_coeff_plus nth_coeff_minus: algebra. #[global] Hint Resolve nth_coeff_nexp_eq nth_coeff_nexp_neq: algebra. corn-8.20.0/algebra/CPolynomials.v000066400000000000000000002227411473720167500167630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing _X_ %\ensuremath{x}% *) (** printing _C_ %\ensuremath\diamond% *) (** printing [+X*] %\ensuremath{+x\times}% #+x×# *) (** printing RX %\ensuremath{R[x]}% #R[x]# *) (** printing FX %\ensuremath{F[x]}% #F[x]# *) Require Import CoRN.algebra.CRing_Homomorphisms. Require Import CoRN.tactics.Rational. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". (** * Polynomials The first section only proves the polynomials form a ring. Section%~\ref{section:poly-equality}% gives some basic properties of equality and induction of polynomials. ** Definition of polynomials; they form a ring %\label{section:poly-ring}% *) Section CPoly_CRing. (** %\begin{convention}% Let [CR] be a ring. %\end{convention}% *) Variable CR : CRing. (** The intuition behind the type [cpoly] is the following - [(cpoly CR)] is $CR[X]$ #CR[X]#; - [cpoly_zero] is the `empty' polynomial with no coefficients; - [(cpoly_linear c p)] is [c[+]X[*]p] *) Inductive cpoly : Type := | cpoly_zero : cpoly | cpoly_linear : CR -> cpoly -> cpoly. Definition cpoly_constant (c : CR) : cpoly := cpoly_linear c cpoly_zero. Definition cpoly_one : cpoly := cpoly_constant [1]. (** Some useful induction lemmas for doubly quantified propositions. *) Lemma Ccpoly_double_ind0 : forall P : cpoly -> cpoly -> CProp, (forall p, P p cpoly_zero) -> (forall p, P cpoly_zero p) -> (forall p q c d, P p q -> P (cpoly_linear c p) (cpoly_linear d q)) -> forall p q, P p q. Proof. simple induction p; auto. simple induction q; auto. Qed. Lemma Ccpoly_double_sym_ind0 : forall P : cpoly -> cpoly -> CProp, Csymmetric P -> (forall p, P p cpoly_zero) -> (forall p q c d, P p q -> P (cpoly_linear c p) (cpoly_linear d q)) -> forall p q, P p q. Proof. intros. apply Ccpoly_double_ind0; auto. Qed. Lemma Ccpoly_double_ind0' : forall P : cpoly -> cpoly -> CProp, (forall p, P cpoly_zero p) -> (forall p c, P (cpoly_linear c p) cpoly_zero) -> (forall p q c d, P p q -> P (cpoly_linear c p) (cpoly_linear d q)) -> forall p q, P p q. Proof. simple induction p; auto. simple induction q; auto. Qed. Lemma cpoly_double_ind0 : forall P : cpoly -> cpoly -> Prop, (forall p, P p cpoly_zero) -> (forall p, P cpoly_zero p) -> (forall p q c d, P p q -> P (cpoly_linear c p) (cpoly_linear d q)) -> forall p q, P p q. Proof. simple induction p; auto. simple induction q; auto. Qed. Lemma cpoly_double_sym_ind0 : forall P : cpoly -> cpoly -> Prop, Tsymmetric P -> (forall p, P p cpoly_zero) -> (forall p q c d, P p q -> P (cpoly_linear c p) (cpoly_linear d q)) -> forall p q, P p q. Proof. intros. apply cpoly_double_ind0; auto. Qed. Lemma cpoly_double_ind0' : forall P : cpoly -> cpoly -> Prop, (forall p, P cpoly_zero p) -> (forall p c, P (cpoly_linear c p) cpoly_zero) -> (forall p q c d, P p q -> P (cpoly_linear c p) (cpoly_linear d q)) -> forall p q, P p q. Proof. simple induction p; auto. simple induction q; auto. Qed. (** *** The polynomials form a setoid *) Fixpoint cpoly_eq_zero (p : cpoly) : Prop := match p with | cpoly_zero => True | cpoly_linear c p1 => c [=] [0] /\ cpoly_eq_zero p1 end. Fixpoint cpoly_eq (p q : cpoly) {struct p} : Prop := match p with | cpoly_zero => cpoly_eq_zero q | cpoly_linear c p1 => match q with | cpoly_zero => cpoly_eq_zero p | cpoly_linear d q1 => c [=] d /\ cpoly_eq p1 q1 end end. Lemma cpoly_eq_p_zero : forall p, cpoly_eq p cpoly_zero = cpoly_eq_zero p. Proof. simple induction p; auto. Qed. Fixpoint cpoly_ap_zero (p : cpoly) : CProp := match p with | cpoly_zero => False | cpoly_linear c p1 => c [#] [0] or cpoly_ap_zero p1 end. Fixpoint cpoly_ap (p q : cpoly) {struct p} : CProp := match p with | cpoly_zero => cpoly_ap_zero q | cpoly_linear c p1 => match q with | cpoly_zero => cpoly_ap_zero p | cpoly_linear d q1 => c [#] d or cpoly_ap p1 q1 end end. Lemma cpoly_ap_p_zero : forall p, cpoly_ap_zero p = cpoly_ap p cpoly_zero. Proof. simple induction p; auto. Qed. Lemma irreflexive_cpoly_ap : irreflexive cpoly_ap. Proof. red in |- *. intro p; induction p as [| s p Hrecp]. intro H; elim H. intro H. elim H. apply ap_irreflexive_unfolded. assumption. Qed. Lemma symmetric_cpoly_ap : Csymmetric cpoly_ap. Proof. red in |- *. intros x y. pattern x, y in |- *. apply Ccpoly_double_ind0'. simpl in |- *; simple induction p; auto. simpl in |- *; auto. simpl in |- *. intros p q c d H H0. elim H0; intro H1. left. apply ap_symmetric_unfolded. assumption. auto. Qed. Lemma cotransitive_cpoly_ap : cotransitive cpoly_ap. Proof. red in |- *. intros x y. pattern x, y in |- *. apply Ccpoly_double_sym_ind0. red in |- *; intros p q H H0 r. generalize (symmetric_cpoly_ap _ _ H0); intro H1. elim (H H1 r); intro H2; [ right | left ]; apply symmetric_cpoly_ap; assumption. simpl in |- *; intros p H z. generalize H. pattern p, z in |- *. apply Ccpoly_double_ind0'. simpl in |- *; intros q H0; elim H0. simpl in |- *; auto. simpl in |- *; intros r q c d H0 H1. elim H1; intro H2. generalize (ap_cotransitive_unfolded _ _ _ H2 d); intro H3. elim H3; auto. rewrite cpoly_ap_p_zero in H2. elim (H0 H2); auto. right; right; rewrite cpoly_ap_p_zero; assumption. intros p q c d H H0 r. simpl in H0. elim H0; intro H1. induction r as [| s r Hrecr]. simpl in |- *. generalize (ap_cotransitive_unfolded _ _ _ H1 [0]); intro H2. elim H2; auto. intro H3. right; left; apply ap_symmetric_unfolded; assumption. simpl in |- *. generalize (ap_cotransitive_unfolded _ _ _ H1 s); intro H2. elim H2; auto. induction r as [| s r Hrecr]. simpl in |- *. cut (cpoly_ap_zero p or cpoly_ap_zero q). intro H2; elim H2; auto. generalize H1; pattern p, q in |- *; apply Ccpoly_double_ind0. simpl in |- *. intros r H2. left; rewrite cpoly_ap_p_zero; assumption. auto. simpl in |- *. intros p0 q0 c0 d0 H2 H3. elim H3; intro H4. elim (ap_cotransitive_unfolded _ _ _ H4 [0]); intro H5. auto. right; left; apply ap_symmetric_unfolded; assumption. elim (H2 H4); auto. simpl in |- *. elim (H H1 r); auto. Qed. Lemma tight_apart_cpoly_ap : tight_apart cpoly_eq cpoly_ap. Proof. red in |- *. intros x y. pattern x, y in |- *. apply cpoly_double_ind0'. simple induction p. simpl in |- *. unfold iff in |- *. unfold Not in |- *. split. auto. intros H H0; inversion H0. simpl in |- *. intros s c H. cut (Not (s [#] [0]) <-> s [=] [0]). unfold Not in |- *. intro H0. elim H0; intros H1 H2. split. intro H3. split; auto. elim H; intros H4 H5. apply H4. intro H6. auto. intros H3 H4. elim H3; intros H5 H6. elim H4; intros H7. auto. elim H; intros H8 H9. unfold Not in H8. elim H9; assumption. apply (ap_tight CR). simple induction p. simpl in |- *. intro c. cut (Not (c [#] [0]) <-> c [=] [0]). unfold Not in |- *. intro H. elim H; intros H0 H1. split. auto. intros H2 H3. elim H3; intro H4. tauto. elim H4. apply (ap_tight CR). simpl in |- *. intros s c H d. generalize (H d). generalize (ap_tight CR d [0]). generalize (ap_tight CR s [0]). unfold Not in |- *. intros H0 H1 H2. elim H0; clear H0; intros H3 H4. elim H1; clear H1; intros H0 H5. elim H2; clear H2; intros H1 H6. tauto. simpl in |- *. unfold Not in |- *. intros p q c d H. elim H; intros H0 H1. split. intro H2. split. generalize (ap_tight CR c d). unfold Not in |- *; tauto. tauto. intros H2 H3. elim H3. elim H2. intros H4 H5 H6. generalize (ap_tight CR c d). unfold Not in |- *. tauto. elim H2. auto. Qed. Lemma cpoly_is_CSetoid : is_CSetoid _ cpoly_eq cpoly_ap. Proof. apply Build_is_CSetoid. exact irreflexive_cpoly_ap. exact symmetric_cpoly_ap. exact cotransitive_cpoly_ap. exact tight_apart_cpoly_ap. Qed. Definition cpoly_csetoid := Build_CSetoid _ _ _ cpoly_is_CSetoid. Canonical Structure cpoly_csetoid. Canonical Structure cpoly_setoid := cs_crr cpoly_csetoid. (** Now that we know that the polynomials form a setoid, we can use the notation with [ [#] ] and [ [=] ]. In order to use this notation, we introduce [cpoly_zero_cs] and [cpoly_linear_cs], so that Coq recognizes we are talking about a setoid. We formulate the induction properties and the most basic properties of equality and apartness in terms of these generators. *) Let cpoly_zero_cs : cpoly_csetoid := cpoly_zero. Let cpoly_linear_cs c (p : cpoly_csetoid) : cpoly_csetoid := cpoly_linear c p. Lemma Ccpoly_ind_cs : forall P : cpoly_csetoid -> CProp, P cpoly_zero_cs -> (forall p c, P p -> P (cpoly_linear_cs c p)) -> forall p, P p. Proof. simple induction p; auto. Qed. Lemma Ccpoly_double_ind0_cs : forall P : cpoly_csetoid -> cpoly_csetoid -> CProp, (forall p, P p cpoly_zero_cs) -> (forall p, P cpoly_zero_cs p) -> (forall p q c d, P p q -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q)) -> forall p q, P p q. Proof. simple induction p. auto. simple induction q. auto. simpl in X1. unfold cpoly_linear_cs in X1. auto. Qed. Lemma Ccpoly_double_sym_ind0_cs : forall P : cpoly_csetoid -> cpoly_csetoid -> CProp, Csymmetric P -> (forall p, P p cpoly_zero_cs) -> (forall p q c d, P p q -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q)) -> forall p q, P p q. Proof. intros. apply Ccpoly_double_ind0; auto. Qed. Lemma cpoly_ind_cs : forall P : cpoly_csetoid -> Prop, P cpoly_zero_cs -> (forall p c, P p -> P (cpoly_linear_cs c p)) -> forall p, P p. Proof. simple induction p; auto. Qed. Lemma cpoly_double_ind0_cs : forall P : cpoly_csetoid -> cpoly_csetoid -> Prop, (forall p, P p cpoly_zero_cs) -> (forall p, P cpoly_zero_cs p) -> (forall p q c d, P p q -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q)) -> forall p q, P p q. Proof. simple induction p. auto. simple induction q. auto. simpl in H1. unfold cpoly_linear_cs in H1. auto. Qed. Lemma cpoly_double_sym_ind0_cs : forall P : cpoly_csetoid -> cpoly_csetoid -> Prop, Tsymmetric P -> (forall p, P p cpoly_zero_cs) -> (forall p q c d, P p q -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q)) -> forall p q, P p q. Proof. intros. apply cpoly_double_ind0; auto. Qed. Lemma cpoly_lin_eq_zero_ : forall p c, cpoly_linear_cs c p [=] cpoly_zero_cs -> c [=] [0] /\ p [=] cpoly_zero_cs. Proof. unfold cpoly_linear_cs in |- *. unfold cpoly_zero_cs in |- *. simpl in |- *. intros p c H. elim H; intros. split; auto. rewrite cpoly_eq_p_zero. assumption. Qed. Lemma _cpoly_lin_eq_zero : forall p c, c [=] [0] /\ p [=] cpoly_zero_cs -> cpoly_linear_cs c p [=] cpoly_zero_cs. Proof. unfold cpoly_linear_cs in |- *. unfold cpoly_zero_cs in |- *. simpl in |- *. intros p c H. elim H; intros. split; auto. rewrite <- cpoly_eq_p_zero. assumption. Qed. Lemma cpoly_zero_eq_lin_ : forall p c, cpoly_zero_cs [=] cpoly_linear_cs c p -> c [=] [0] /\ cpoly_zero_cs [=] p. Proof. auto. Qed. Lemma _cpoly_zero_eq_lin : forall p c, c [=] [0] /\ cpoly_zero_cs [=] p -> cpoly_zero_cs [=] cpoly_linear_cs c p. Proof. auto. Qed. Lemma cpoly_lin_eq_lin_ : forall p q c d, cpoly_linear_cs c p [=] cpoly_linear_cs d q -> c [=] d /\ p [=] q. Proof. auto. Qed. Lemma _cpoly_lin_eq_lin : forall p q c d, c [=] d /\ p [=] q -> cpoly_linear_cs c p [=] cpoly_linear_cs d q. Proof. auto. Qed. Lemma cpoly_lin_ap_zero_ : forall p c, cpoly_linear_cs c p [#] cpoly_zero_cs -> c [#] [0] or p [#] cpoly_zero_cs. Proof. unfold cpoly_zero_cs in |- *. intros p c H. cut (cpoly_ap (cpoly_linear c p) cpoly_zero); auto. intro H0. simpl in H0. elim H0; auto. right. rewrite <- cpoly_ap_p_zero. assumption. Qed. Lemma _cpoly_lin_ap_zero : forall p c, c [#] [0] or p [#] cpoly_zero_cs -> cpoly_linear_cs c p [#] cpoly_zero_cs. Proof. unfold cpoly_zero_cs in |- *. intros. simpl in |- *. elim X; try auto. intros. right. rewrite cpoly_ap_p_zero. assumption. Qed. Lemma cpoly_lin_ap_zero : forall p c, (cpoly_linear_cs c p [#] cpoly_zero_cs) = (c [#] [0] or p [#] cpoly_zero_cs). Proof. intros. simpl in |- *. unfold cpoly_zero_cs in |- *. rewrite cpoly_ap_p_zero. reflexivity. Qed. Lemma cpoly_zero_ap_lin_ : forall p c, cpoly_zero_cs [#] cpoly_linear_cs c p -> c [#] [0] or cpoly_zero_cs [#] p. Proof. intros. simpl in |- *. assumption. Qed. Lemma _cpoly_zero_ap_lin : forall p c, c [#] [0] or cpoly_zero_cs [#] p -> cpoly_zero_cs [#] cpoly_linear_cs c p. Proof. intros. simpl in |- *. assumption. Qed. Lemma cpoly_zero_ap_lin : forall p c, (cpoly_zero_cs [#] cpoly_linear_cs c p) = (c [#] [0] or cpoly_zero_cs [#] p). Proof. reflexivity. Qed. Lemma cpoly_lin_ap_lin_ : forall p q c d, cpoly_linear_cs c p [#] cpoly_linear_cs d q -> c [#] d or p [#] q. Proof. auto. Qed. Lemma _cpoly_lin_ap_lin : forall p q c d, c [#] d or p [#] q -> cpoly_linear_cs c p [#] cpoly_linear_cs d q. Proof. auto. Qed. Lemma cpoly_lin_ap_lin : forall p q c d, (cpoly_linear_cs c p [#] cpoly_linear_cs d q) = (c [#] d or p [#] q). Proof. reflexivity. Qed. Lemma cpoly_linear_strext : bin_fun_strext _ _ _ cpoly_linear_cs. Proof. unfold bin_fun_strext in |- *. intros until 1. apply cpoly_lin_ap_lin_;assumption. Qed. Lemma cpoly_linear_wd : bin_fun_wd _ _ _ cpoly_linear_cs. Proof. apply bin_fun_strext_imp_wd. now repeat intro. Qed. Definition cpoly_linear_fun := Build_CSetoid_bin_fun _ _ _ _ cpoly_linear_strext. Lemma Ccpoly_double_comp_ind : forall P : cpoly_csetoid -> cpoly_csetoid -> CProp, (forall p1 p2 q1 q2, p1 [=] p2 -> q1 [=] q2 -> P p1 q1 -> P p2 q2) -> P cpoly_zero_cs cpoly_zero_cs -> (forall p q c d, P p q -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q)) -> forall p q, P p q. Proof. intros. apply Ccpoly_double_ind0_cs. intro p0; pattern p0 in |- *; apply Ccpoly_ind_cs;[assumption|]. intros p1 c. intros. apply X with (cpoly_linear_cs c p1) (cpoly_linear_cs [0] cpoly_zero_cs). algebra. apply _cpoly_lin_eq_zero. split; algebra. apply X1; assumption. intro p0; pattern p0 in |- *; apply Ccpoly_ind_cs. assumption. intros. apply X with (cpoly_linear_cs [0] cpoly_zero_cs) (cpoly_linear_cs c p1). apply _cpoly_lin_eq_zero;split; algebra. algebra. apply X1; assumption. now apply X1. Qed. Lemma Ccpoly_triple_comp_ind : forall P : cpoly_csetoid -> cpoly_csetoid -> cpoly_csetoid -> CProp, (forall p1 p2 q1 q2 r1 r2, p1 [=] p2 -> q1 [=] q2 -> r1 [=] r2 -> P p1 q1 r1 -> P p2 q2 r2) -> P cpoly_zero_cs cpoly_zero_cs cpoly_zero_cs -> (forall p q r c d e, P p q r -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q) (cpoly_linear_cs e r)) -> forall p q r, P p q r. Proof. do 6 intro. pattern p, q in |- *. apply Ccpoly_double_comp_ind. intros. apply X with p1 q1 r. assumption. assumption. algebra. apply X2. intro r; pattern r in |- *; apply Ccpoly_ind_cs. assumption. intros. apply X with (cpoly_linear_cs [0] cpoly_zero_cs) (cpoly_linear_cs [0] cpoly_zero_cs) (cpoly_linear_cs c p0). apply _cpoly_lin_eq_zero; split; algebra. apply _cpoly_lin_eq_zero; split; algebra. algebra. apply X1. assumption. do 6 intro. pattern r in |- *; apply Ccpoly_ind_cs. apply X with (cpoly_linear_cs c p0) (cpoly_linear_cs d q0) (cpoly_linear_cs [0] cpoly_zero_cs). algebra. algebra. apply _cpoly_lin_eq_zero; split; algebra. apply X1. apply X2. intros. apply X1. apply X2. Qed. Lemma cpoly_double_comp_ind : forall P : cpoly_csetoid -> cpoly_csetoid -> Prop, (forall p1 p2 q1 q2, p1 [=] p2 -> q1 [=] q2 -> P p1 q1 -> P p2 q2) -> P cpoly_zero_cs cpoly_zero_cs -> (forall p q c d, P p q -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q)) -> forall p q, P p q. Proof. intros. apply cpoly_double_ind0_cs. intro p0; pattern p0 in |- *; apply cpoly_ind_cs. assumption. intros. apply H with (cpoly_linear_cs c p1) (cpoly_linear_cs [0] cpoly_zero_cs). algebra. apply _cpoly_lin_eq_zero. split; algebra. apply H1. assumption. intro p0; pattern p0 in |- *; apply cpoly_ind_cs. assumption. intros. apply H with (cpoly_linear_cs [0] cpoly_zero_cs) (cpoly_linear_cs c p1). apply _cpoly_lin_eq_zero. split; algebra. algebra. now apply H1. now apply H1. Qed. Lemma cpoly_triple_comp_ind : forall P : cpoly_csetoid -> cpoly_csetoid -> cpoly_csetoid -> Prop, (forall p1 p2 q1 q2 r1 r2, p1 [=] p2 -> q1 [=] q2 -> r1 [=] r2 -> P p1 q1 r1 -> P p2 q2 r2) -> P cpoly_zero_cs cpoly_zero_cs cpoly_zero_cs -> (forall p q r c d e, P p q r -> P (cpoly_linear_cs c p) (cpoly_linear_cs d q) (cpoly_linear_cs e r)) -> forall p q r, P p q r. Proof. do 6 intro. pattern p, q in |- *. apply cpoly_double_comp_ind. intros. apply H with p1 q1 r. assumption. assumption. algebra. apply H4. intro r; pattern r in |- *; apply cpoly_ind_cs. assumption. intros. apply H with (cpoly_linear_cs [0] cpoly_zero_cs) (cpoly_linear_cs [0] cpoly_zero_cs) (cpoly_linear_cs c p0). apply _cpoly_lin_eq_zero; split; algebra. apply _cpoly_lin_eq_zero; split; algebra. algebra. apply H1. assumption. do 6 intro. pattern r in |- *; apply cpoly_ind_cs. apply H with (cpoly_linear_cs c p0) (cpoly_linear_cs d q0) (cpoly_linear_cs [0] cpoly_zero_cs). algebra. algebra. apply _cpoly_lin_eq_zero; split; algebra. apply H1. apply H2. intros. apply H1. apply H2. Qed. (** *** The polynomials form a semi-group and a monoid *) Fixpoint cpoly_plus (p q : cpoly) {struct p} : cpoly := match p with | cpoly_zero => q | cpoly_linear c p1 => match q with | cpoly_zero => p | cpoly_linear d q1 => cpoly_linear (c[+]d) (cpoly_plus p1 q1) end end. Definition cpoly_plus_cs (p q : cpoly_csetoid) : cpoly_csetoid := cpoly_plus p q. Lemma cpoly_zero_plus : forall p, cpoly_plus_cs cpoly_zero_cs p = p. Proof. auto. Qed. Lemma cpoly_plus_zero : forall p, cpoly_plus_cs p cpoly_zero_cs = p. Proof. simple induction p. auto. auto. Qed. Lemma cpoly_lin_plus_lin : forall p q c d, cpoly_plus_cs (cpoly_linear_cs c p) (cpoly_linear_cs d q) = cpoly_linear_cs (c[+]d) (cpoly_plus_cs p q). Proof. auto. Qed. Lemma cpoly_plus_commutative : forall p q, cpoly_plus_cs p q [=] cpoly_plus_cs q p. Proof. intros. pattern p, q in |- *. apply cpoly_double_sym_ind0_cs. unfold Tsymmetric in |- *. intros. algebra. intro p0. rewrite cpoly_zero_plus. rewrite cpoly_plus_zero. algebra. intros. repeat rewrite cpoly_lin_plus_lin. apply _cpoly_lin_eq_lin. split. algebra. assumption. Qed. Lemma cpoly_plus_q_ap_q : forall p q, cpoly_plus_cs p q [#] q -> p [#] cpoly_zero_cs. Proof. intro p; pattern p in |- *; apply Ccpoly_ind_cs. intro. rewrite cpoly_zero_plus. intro H. exfalso. apply (ap_irreflexive _ _ H). do 4 intro. pattern q in |- *; apply Ccpoly_ind_cs. rewrite cpoly_plus_zero. auto. do 3 intro. rewrite cpoly_lin_plus_lin. intros. cut (c[+]c0 [#] c0 or cpoly_plus_cs p0 p1 [#] p1). intros. 2: apply cpoly_lin_ap_lin_. 2: assumption. cut (c [#] [0] or p0 [#] cpoly_zero_cs). intro. apply _cpoly_lin_ap_zero. assumption. elim X1; intro. left. apply cg_ap_cancel_rht with c0. astepr c0. auto. right. generalize (X _ b); intro. assumption. Qed. Lemma cpoly_p_plus_ap_p : forall p q, cpoly_plus_cs p q [#] p -> q [#] cpoly_zero. Proof. intros. apply cpoly_plus_q_ap_q with p. apply ap_wdl_unfolded with (cpoly_plus_cs p q). assumption. apply cpoly_plus_commutative. Qed. Lemma cpoly_ap_zero_plus : forall p q, cpoly_plus_cs p q [#] cpoly_zero_cs -> p [#] cpoly_zero_cs or q [#] cpoly_zero_cs. Proof. intros p q; pattern p, q in |- *; apply Ccpoly_double_sym_ind0_cs. unfold Csymmetric in |- *. intros x y H H0. elim H. auto. auto. astepl (cpoly_plus_cs y x). auto. apply cpoly_plus_commutative. intros p0 H. left. rewrite cpoly_plus_zero in H. assumption. intros p0 q0 c d. rewrite cpoly_lin_plus_lin. intros. cut (c[+]d [#] [0] or cpoly_plus_cs p0 q0 [#] cpoly_zero_cs). 2: apply cpoly_lin_ap_zero_. 2: assumption. clear X0. intros H0. elim H0; intro H1. cut (c[+]d [#] [0][+][0]). intro H2. elim (cs_bin_op_strext _ _ _ _ _ _ H2); intro H3. left. simpl in |- *. left. assumption. right. cut (d [#] [0] or q0 [#] cpoly_zero_cs). intro H4. apply _cpoly_lin_ap_zero. auto. left. assumption. astepr ([0]:CR). auto. elim (X H1); intro. left. cut (c [#] [0] or p0 [#] cpoly_zero_cs). intro; apply _cpoly_lin_ap_zero. auto. right. assumption. right. cut (d [#] [0] or q0 [#] cpoly_zero_cs). intro. apply _cpoly_lin_ap_zero. auto. right. assumption. Qed. Lemma cpoly_plus_op_strext : bin_op_strext cpoly_csetoid cpoly_plus_cs. Proof. unfold bin_op_strext in |- *. unfold bin_fun_strext in |- *. intros x1 x2. pattern x1, x2 in |- *. apply Ccpoly_double_sym_ind0_cs. unfold Csymmetric in |- *. intros. generalize (ap_symmetric_unfolded _ _ _ X0); intro H1. generalize (X _ _ H1); intro H2. elim H2; intro H3; generalize (ap_symmetric_unfolded _ _ _ H3); auto. intro p; pattern p in |- *; apply Ccpoly_ind_cs. intro; intro H. simpl in |- *; auto. intros s c H y1 y2. pattern y1, y2 in |- *. apply Ccpoly_double_ind0_cs. intros p0 H0. apply cpoly_ap_zero_plus. apply H0. intro p0. intro H0. elim (ap_cotransitive _ _ _ H0 cpoly_zero_cs); auto. do 4 intro. intros. cut (c[+]c0 [#] d or cpoly_plus_cs s p0 [#] q). 2: apply cpoly_lin_ap_lin_; assumption. clear X0; intro H1. elim H1; intro H2. cut (c[+]c0 [#] [0][+]d). intro H3. elim (cs_bin_op_strext _ _ _ _ _ _ H3). intro H4. left. apply _cpoly_lin_ap_zero. auto. intro. right. apply _cpoly_lin_ap_lin. auto. astepr d. auto. elim (H _ _ H2); auto. intro. left. apply _cpoly_lin_ap_zero. auto. right. apply _cpoly_lin_ap_lin. auto. do 7 intro. pattern y1, y2 in |- *. apply Ccpoly_double_ind0_cs. intro p0; pattern p0 in |- *; apply Ccpoly_ind_cs. auto. intros. cut (c[+]c0 [#] d or cpoly_plus_cs p p1 [#] q). intro H2. 2: apply cpoly_lin_ap_lin_. 2: auto. elim H2; intro H3. cut (c[+]c0 [#] d[+][0]). intro H4. elim (cs_bin_op_strext _ _ _ _ _ _ H4). intro. left. apply _cpoly_lin_ap_lin. auto. intro. right. apply _cpoly_lin_ap_zero. auto. astepr d. auto. elim X with p1 cpoly_zero_cs. intro. left. apply _cpoly_lin_ap_lin. auto. right. apply _cpoly_lin_ap_zero. auto. rewrite cpoly_plus_zero. assumption. intro p0; pattern p0 in |- *; apply Ccpoly_ind_cs. auto. intros. cut (c [#] d[+]c0 or p [#] cpoly_plus_cs q p1). 2: apply cpoly_lin_ap_lin_. 2: assumption. clear X1; intro H1. elim H1; intro H2. cut (c[+][0] [#] d[+]c0). intro H3. elim (cs_bin_op_strext _ _ _ _ _ _ H3). intro. left. unfold cpoly_linear_cs in |- *; simpl in |- *; auto. intro. right. left. apply ap_symmetric_unfolded. assumption. astepl c. auto. elim X with cpoly_zero_cs p1. intro. left. unfold cpoly_linear_cs in |- *; simpl in |- *; auto. intro. right. right; auto. rewrite cpoly_plus_zero. assumption. intros. elim X1; intro H2. elim (cs_bin_op_strext _ _ _ _ _ _ H2); auto. intro. left. left; auto. intro. right. left; auto. simpl in H2. elim (X _ _ H2). intro. left; right; auto. right; right; auto. Qed. Lemma cpoly_plus_op_wd : bin_op_wd cpoly_csetoid cpoly_plus_cs. Proof. unfold bin_op_wd in |- *. apply bin_fun_strext_imp_wd. exact cpoly_plus_op_strext. Qed. Definition cpoly_plus_op := Build_CSetoid_bin_op _ _ cpoly_plus_op_strext. Lemma cpoly_plus_associative : associative cpoly_plus_op. Proof. unfold associative in |- *. intros p q r. change (cpoly_plus_cs p (cpoly_plus_cs q r) [=] cpoly_plus_cs (cpoly_plus_cs p q) r) in |- *. pattern p, q, r in |- *; apply cpoly_triple_comp_ind. intros. apply eq_transitive_unfolded with (cpoly_plus_cs p1 (cpoly_plus_cs q1 r1)). apply eq_symmetric_unfolded. apply cpoly_plus_op_wd. assumption. apply cpoly_plus_op_wd. assumption. assumption. astepl (cpoly_plus_cs (cpoly_plus_cs p1 q1) r1). apply cpoly_plus_op_wd. apply cpoly_plus_op_wd. assumption. assumption. assumption. simpl in |- *. auto. intros. repeat rewrite cpoly_lin_plus_lin. apply _cpoly_lin_eq_lin. split. algebra. assumption. Qed. Definition cpoly_csemi_grp := Build_CSemiGroup _ _ cpoly_plus_associative. Canonical Structure cpoly_csemi_grp. Lemma cpoly_cm_proof : is_CMonoid cpoly_csemi_grp cpoly_zero. Proof. apply Build_is_CMonoid. intro; rewrite -> cpoly_plus_zero;algebra. intro x. eapply eq_transitive_unfolded. apply cpoly_plus_commutative. rewrite cpoly_plus_zero;algebra. Qed. Definition cpoly_cmonoid := Build_CMonoid _ _ cpoly_cm_proof. Canonical Structure cpoly_cmonoid. (** *** The polynomials form a group *) Fixpoint cpoly_inv (p : cpoly) : cpoly := match p with | cpoly_zero => cpoly_zero | cpoly_linear c p1 => cpoly_linear [--]c (cpoly_inv p1) end. Definition cpoly_inv_cs (p : cpoly_csetoid) : cpoly_csetoid := cpoly_inv p. Lemma cpoly_inv_zero : cpoly_inv_cs cpoly_zero_cs = cpoly_zero_cs. Proof. auto. Qed. Lemma cpoly_inv_lin : forall p c, cpoly_inv_cs (cpoly_linear_cs c p) = cpoly_linear_cs [--]c (cpoly_inv_cs p). Proof. simple induction p; auto. Qed. Lemma cpoly_inv_op_strext : un_op_strext cpoly_csetoid cpoly_inv_cs. Proof. unfold un_op_strext in |- *. unfold fun_strext in |- *. intros x y. pattern x, y in |- *. apply Ccpoly_double_sym_ind0_cs. unfold Csymmetric in |- *. intros. apply ap_symmetric_unfolded. apply X. apply ap_symmetric_unfolded. assumption. intro p; pattern p in |- *; apply Ccpoly_ind_cs. auto. intros. cut ( [--]c [#] [0] or cpoly_inv_cs p0 [#] cpoly_zero_cs). 2: apply cpoly_lin_ap_zero_. 2: auto. clear X0; intro H0. apply _cpoly_lin_ap_zero. auto. elim H0. left. astepl ( [--][--]c). algebra. right. apply X. assumption. intros. cut ( [--]c [#] [--]d or cpoly_inv_cs p [#] cpoly_inv_cs q). 2: apply cpoly_lin_ap_lin_. 2: auto. clear X0; intro H0. auto. elim H0; intro. left. astepl ( [--][--]c). astepr ( [--][--]d). apply inv_resp_ap. assumption. right. apply X. assumption. Qed. Lemma cpoly_inv_op_wd : un_op_wd cpoly_csetoid cpoly_inv_cs. Proof. apply fun_strext_imp_wd. exact cpoly_inv_op_strext. Qed. Definition cpoly_inv_op := Build_CSetoid_un_op _ _ cpoly_inv_op_strext. Lemma cpoly_cg_proof : is_CGroup cpoly_cmonoid cpoly_inv_op. Proof. intro x. unfold is_inverse in |- *. assert (x[+]cpoly_inv_cs x [=] [0]). pattern x in |- *; apply cpoly_ind_cs. rewrite cpoly_inv_zero. rewrite -> cpoly_plus_zero. simpl; auto. intros. rewrite cpoly_inv_lin. rewrite -> cpoly_lin_plus_lin. apply _cpoly_lin_eq_zero. split;[algebra|assumption]. split; auto. eapply eq_transitive_unfolded. apply cpoly_plus_commutative. auto. Qed. Definition cpoly_cgroup := Build_CGroup _ _ cpoly_cg_proof. Canonical Structure cpoly_cgroup. Lemma cpoly_cag_proof : is_CAbGroup cpoly_cgroup. Proof. repeat intro. apply: cpoly_plus_commutative. Qed. Definition cpoly_cabgroup := Build_CAbGroup _ cpoly_cag_proof. Canonical Structure cpoly_cabgroup. (** *** The polynomials form a ring *) Fixpoint cpoly_mult_cr (q : cpoly) (c : CR) {struct q} : cpoly := match q with | cpoly_zero => cpoly_zero | cpoly_linear d q1 => cpoly_linear (c[*]d) (cpoly_mult_cr q1 c) end. Fixpoint cpoly_mult (p q : cpoly) {struct p} : cpoly := match p with | cpoly_zero => cpoly_zero | cpoly_linear c p1 => cpoly_plus (cpoly_mult_cr q c) (cpoly_linear [0] (cpoly_mult p1 q)) end. Definition cpoly_mult_cr_cs (p : cpoly_csetoid) c : cpoly_csetoid := cpoly_mult_cr p c. Lemma cpoly_zero_mult_cr : forall c, cpoly_mult_cr_cs cpoly_zero_cs c = cpoly_zero_cs. Proof. auto. Qed. Lemma cpoly_lin_mult_cr : forall c d q, cpoly_mult_cr_cs (cpoly_linear_cs d q) c = cpoly_linear_cs (c[*]d) (cpoly_mult_cr_cs q c). Proof. auto. Qed. Lemma cpoly_mult_cr_zero : forall p, cpoly_mult_cr_cs p [0] [=] cpoly_zero_cs. Proof. intro; pattern p in |- *; apply cpoly_ind_cs. rewrite cpoly_zero_mult_cr. algebra. intros. rewrite cpoly_lin_mult_cr. apply _cpoly_lin_eq_zero. split. algebra. assumption. Qed. Lemma cpoly_mult_cr_strext : bin_fun_strext _ _ _ cpoly_mult_cr_cs. Proof. unfold bin_fun_strext in |- *. do 4 intro. pattern x1, x2 in |- *. apply Ccpoly_double_ind0_cs. intro. rewrite cpoly_zero_mult_cr. intro H. left. generalize H. pattern p in |- *. apply Ccpoly_ind_cs. rewrite cpoly_zero_mult_cr. auto. do 2 intro. rewrite cpoly_lin_mult_cr. intros. cut (y1[*]c [#] [0] or cpoly_mult_cr_cs p0 y1 [#] cpoly_zero_cs). 2: apply cpoly_lin_ap_zero_. 2: auto. clear H0; intro H1. cut (c [#] [0] or p0 [#] cpoly_zero_cs). intro; apply _cpoly_lin_ap_zero. auto. elim H1; intro H2. generalize (cring_mult_ap_zero_op _ _ _ H2); intro. auto. right. auto. rewrite cpoly_zero_mult_cr. intros. left. generalize X. pattern p in |- *; apply Ccpoly_ind_cs. rewrite cpoly_zero_mult_cr. auto. do 2 intro. rewrite cpoly_lin_mult_cr. intros. cut (y2[*]c [#] [0] or cpoly_zero_cs [#] cpoly_mult_cr_cs p0 y2). 2: apply cpoly_zero_ap_lin_. 2: auto. clear X1; intro H1. cut (c [#] [0] or cpoly_zero_cs [#] p0). intro. apply _cpoly_zero_ap_lin. auto. elim H1; intro H2. generalize (cring_mult_ap_zero_op _ _ _ H2); auto. right. auto. do 4 intro. repeat rewrite cpoly_lin_mult_cr. intros. cut (y1[*]c [#] y2[*]d or cpoly_mult_cr_cs p y1 [#] cpoly_mult_cr_cs q y2). 2: apply cpoly_lin_ap_lin_. 2: auto. clear X0; intro H0. cut ((c [#] d or p [#] q) or y1 [#] y2). intro. elim X0; try auto. elim H0; intro H1. generalize (cs_bin_op_strext _ _ _ _ _ _ H1); tauto. elim X; auto. Qed. Lemma cpoly_mult_cr_wd : bin_fun_wd _ _ _ cpoly_mult_cr_cs. Proof. apply bin_fun_strext_imp_wd. exact cpoly_mult_cr_strext. Qed. Definition cpoly_mult_cs (p q : cpoly_csetoid) : cpoly_csetoid := cpoly_mult p q. Lemma cpoly_zero_mult : forall q, cpoly_mult_cs cpoly_zero_cs q = cpoly_zero_cs. Proof. auto. Qed. Lemma cpoly_lin_mult : forall c p q, cpoly_mult_cs (cpoly_linear_cs c p) q = cpoly_plus_cs (cpoly_mult_cr_cs q c) (cpoly_linear_cs [0] (cpoly_mult_cs p q)). Proof. auto. Qed. Lemma cpoly_mult_op_strext : bin_op_strext cpoly_csetoid cpoly_mult_cs. Proof. do 4 intro. pattern x1, x2 in |- *. apply Ccpoly_double_ind0_cs. rewrite cpoly_zero_mult. intro; pattern p in |- *; apply Ccpoly_ind_cs. rewrite cpoly_zero_mult. auto. do 2 intro. rewrite cpoly_lin_mult. intros. cut ((c [#] [0] or p0 [#] cpoly_zero_cs) or y1 [#] y2). intro H1. elim H1. intro; left; apply _cpoly_lin_ap_zero; assumption. auto. cut (cpoly_plus_cs (cpoly_mult_cr_cs y1 c) (cpoly_linear_cs [0] (cpoly_mult_cs p0 y1)) [#] cpoly_plus_cs (cpoly_mult_cr_cs y2 [0]) (cpoly_linear_cs [0] (cpoly_mult_cs cpoly_zero_cs y2))). intro H1. elim (cpoly_plus_op_strext _ _ _ _ H1); intro H2. elim (cpoly_mult_cr_strext _ _ _ _ H2); auto. elim H2; intro H3. elim (ap_irreflexive _ _ H3). rewrite cpoly_zero_mult in H3. elim X; auto. rewrite cpoly_zero_mult. apply ap_wdr_unfolded with cpoly_zero_cs. assumption. astepl (cpoly_plus_cs cpoly_zero_cs cpoly_zero_cs). apply cpoly_plus_op_wd. apply eq_symmetric_unfolded. apply cpoly_mult_cr_zero. apply _cpoly_zero_eq_lin. split; algebra. intro; pattern p in |- *; apply Ccpoly_ind_cs. auto. intros. cut ((c [#] [0] or cpoly_zero_cs [#] p0) or y1 [#] y2). intro. elim X1; try auto. cut (cpoly_plus_cs (cpoly_mult_cr_cs y1 [0]) (cpoly_linear_cs [0] (cpoly_mult_cs cpoly_zero_cs y1)) [#] cpoly_plus_cs (cpoly_mult_cr_cs y2 c) (cpoly_linear_cs [0] (cpoly_mult_cs p0 y2))). intro H1. elim (cpoly_plus_op_strext _ _ _ _ H1); intro H2. elim (cpoly_mult_cr_strext _ _ _ _ H2); auto. intro. left. left. apply ap_symmetric_unfolded. assumption. cut (([0]:CR) [#] [0] or cpoly_mult_cs cpoly_zero_cs y1 [#] cpoly_mult_cs p0 y2). 2: apply cpoly_lin_ap_lin_; auto. clear H2; intro H2. elim H2; intro H3. elim (ap_irreflexive _ _ H3). rewrite cpoly_zero_mult in H3. elim X; auto. rewrite cpoly_zero_mult. apply ap_wdl_unfolded with cpoly_zero_cs. assumption. astepl (cpoly_plus_cs cpoly_zero_cs cpoly_zero_cs). apply cpoly_plus_op_wd. apply eq_symmetric_unfolded. apply cpoly_mult_cr_zero. apply _cpoly_zero_eq_lin. split; algebra. intros. cut ((c [#] d or p [#] q) or y1 [#] y2). intro. auto. elim (cpoly_plus_op_strext _ _ _ _ X0); intro H1. elim (cpoly_mult_cr_strext _ _ _ _ H1); auto. elim H1; intro H2. elim (ap_irreflexive _ _ H2). elim X; auto. Qed. Lemma cpoly_mult_op_wd : bin_op_wd cpoly_csetoid cpoly_mult. Proof. apply bin_fun_strext_imp_wd. exact cpoly_mult_op_strext. Qed. Definition cpoly_mult_op := Build_CSetoid_bin_op _ _ cpoly_mult_op_strext. Lemma cpoly_mult_cr_dist : forall p q c, cpoly_mult_cr_cs (cpoly_plus_cs p q) c [=] cpoly_plus_cs (cpoly_mult_cr_cs p c) (cpoly_mult_cr_cs q c). Proof. intros. pattern p, q in |- *. apply cpoly_double_comp_ind. intros. apply eq_transitive_unfolded with (cpoly_mult_cr_cs (cpoly_plus_cs p1 q1) c). apply eq_symmetric_unfolded. apply cpoly_mult_cr_wd. apply cpoly_plus_op_wd. assumption. assumption. algebra. astepl (cpoly_plus_cs (cpoly_mult_cr_cs p1 c) (cpoly_mult_cr_cs q1 c)). apply cpoly_plus_op_wd. apply cpoly_mult_cr_wd; algebra. apply cpoly_mult_cr_wd; algebra. repeat rewrite cpoly_zero_plus. algebra. intros. repeat rewrite cpoly_lin_mult_cr. repeat rewrite cpoly_lin_plus_lin. apply: _cpoly_lin_eq_lin. split; algebra. Qed. Lemma cpoly_cr_dist : distributive cpoly_mult_op cpoly_plus_op. Proof. unfold distributive in |- *. intros p q r. change (cpoly_mult_cs p (cpoly_plus_cs q r) [=] cpoly_plus_cs (cpoly_mult_cs p q) (cpoly_mult_cs p r)) in |- *. pattern p in |- *. apply cpoly_ind_cs. repeat rewrite cpoly_zero_mult. rewrite cpoly_zero_plus. algebra. intros. repeat rewrite cpoly_lin_mult. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_plus_cs (cpoly_mult_cr_cs q c) (cpoly_mult_cr_cs r c)) (cpoly_plus_cs (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)) (cpoly_linear_cs [0] (cpoly_mult_cs p0 r)))). apply cpoly_plus_op_wd. apply cpoly_mult_cr_dist. rewrite cpoly_lin_plus_lin. apply _cpoly_lin_eq_lin. split. algebra. assumption. clear H. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cr_cs q c) (cpoly_plus_cs (cpoly_mult_cr_cs r c) (cpoly_plus_cs (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)) (cpoly_linear_cs [0] (cpoly_mult_cs p0 r))))). apply eq_symmetric_unfolded. apply cpoly_plus_associative. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cr_cs q c) (cpoly_plus_cs (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)) (cpoly_plus_cs (cpoly_mult_cr_cs r c) (cpoly_linear_cs [0] (cpoly_mult_cs p0 r))))). apply cpoly_plus_op_wd. algebra. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_plus_cs (cpoly_mult_cr_cs r c) (cpoly_linear_cs [0] (cpoly_mult_cs p0 q))) (cpoly_linear_cs [0] (cpoly_mult_cs p0 r))). apply cpoly_plus_associative. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_plus_cs (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)) (cpoly_mult_cr_cs r c)) (cpoly_linear_cs [0] (cpoly_mult_cs p0 r))). apply cpoly_plus_op_wd. apply cpoly_plus_commutative. algebra. apply eq_symmetric_unfolded. apply cpoly_plus_associative. apply cpoly_plus_associative. Qed. Lemma cpoly_mult_cr_assoc_mult_cr : forall p c d, cpoly_mult_cr_cs (cpoly_mult_cr_cs p c) d [=] cpoly_mult_cr_cs p (d[*]c). Proof. intros. pattern p in |- *; apply cpoly_ind_cs. repeat rewrite cpoly_zero_mult_cr. algebra. intros. repeat rewrite cpoly_lin_mult_cr. apply _cpoly_lin_eq_lin. split. algebra. assumption. Qed. Lemma cpoly_mult_cr_assoc_mult : forall p q c, cpoly_mult_cr_cs (cpoly_mult_cs p q) c [=] cpoly_mult_cs (cpoly_mult_cr_cs p c) q. Proof. intros. pattern p in |- *; apply cpoly_ind_cs. rewrite cpoly_zero_mult. rewrite -> cpoly_zero_mult_cr; reflexivity. intros. rewrite cpoly_lin_mult. repeat rewrite cpoly_lin_mult_cr. rewrite cpoly_lin_mult. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cr_cs (cpoly_mult_cr_cs q c0) c) (cpoly_mult_cr_cs (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)) c)). apply cpoly_mult_cr_dist. apply cpoly_plus_op_wd. apply cpoly_mult_cr_assoc_mult_cr. rewrite cpoly_lin_mult_cr. apply _cpoly_lin_eq_lin. split;algebra. Qed. Lemma cpoly_mult_zero : forall p, cpoly_mult_cs p cpoly_zero_cs [=] cpoly_zero_cs. Proof. intros. pattern p in |- *; apply cpoly_ind_cs. algebra. intros. rewrite cpoly_lin_mult. rewrite cpoly_zero_mult_cr. rewrite cpoly_zero_plus. apply _cpoly_lin_eq_zero. split;algebra. Qed. Lemma cpoly_mult_lin : forall c p q, cpoly_mult_cs p (cpoly_linear_cs c q) [=] cpoly_plus_cs (cpoly_mult_cr_cs p c) (cpoly_linear_cs [0] (cpoly_mult_cs p q)). Proof. intros. pattern p in |- *; apply cpoly_ind_cs. repeat rewrite cpoly_zero_mult. rewrite cpoly_zero_mult_cr. rewrite cpoly_zero_plus. apply _cpoly_zero_eq_lin. algebra. intros. repeat rewrite cpoly_lin_mult. repeat rewrite cpoly_lin_mult_cr. repeat rewrite cpoly_lin_plus_lin. apply _cpoly_lin_eq_lin. split. algebra. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_plus_cs (cpoly_mult_cr_cs p0 c) (cpoly_mult_cr_cs q c0)) (cpoly_linear_cs [0] (cpoly_mult_cs p0 q))). 2: apply eq_symmetric_unfolded. 2: apply cpoly_plus_associative. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_plus_cs (cpoly_mult_cr_cs q c0) (cpoly_mult_cr_cs p0 c)) (cpoly_linear_cs [0] (cpoly_mult_cs p0 q))). 2: apply cpoly_plus_op_wd. 3: algebra. 2: apply cpoly_plus_commutative. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cr_cs q c0) (cpoly_plus_cs (cpoly_mult_cr_cs p0 c) (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)))). 2: apply cpoly_plus_associative. apply cpoly_plus_op_wd. algebra. assumption. Qed. Lemma cpoly_mult_commutative : forall p q : cpoly_csetoid, cpoly_mult_cs p q [=] cpoly_mult_cs q p. Proof. intros. pattern p in |- *. apply cpoly_ind_cs. rewrite cpoly_zero_mult. apply eq_symmetric_unfolded. apply cpoly_mult_zero. intros. rewrite cpoly_lin_mult. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cr_cs q c) (cpoly_linear_cs [0] (cpoly_mult_cs q p0))). 2: apply eq_symmetric_unfolded; apply cpoly_mult_lin. apply cpoly_plus_op_wd. algebra. apply cpoly_linear_wd. algebra. assumption. Qed. Lemma cpoly_mult_dist_rht : forall p q r, cpoly_mult_cs (cpoly_plus_cs p q) r [=] cpoly_plus_cs (cpoly_mult_cs p r) (cpoly_mult_cs q r). Proof. intros. apply eq_transitive_unfolded with (cpoly_mult_cs r (cpoly_plus_cs p q)). apply cpoly_mult_commutative. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cs r p) (cpoly_mult_cs r q)). generalize cpoly_cr_dist; intro. unfold distributive in H. simpl in H. simpl in |- *. apply H. apply cpoly_plus_op_wd. apply cpoly_mult_commutative. apply cpoly_mult_commutative. Qed. Lemma cpoly_mult_assoc : associative cpoly_mult_op. Proof. unfold associative in |- *. intros p q r. change (cpoly_mult_cs p (cpoly_mult_cs q r) [=] cpoly_mult_cs (cpoly_mult_cs p q) r) in |- *. pattern p in |- *; apply cpoly_ind_cs. repeat rewrite cpoly_zero_mult. algebra. intros. repeat rewrite cpoly_lin_mult. apply eq_transitive_unfolded with (cpoly_plus_cs (cpoly_mult_cs (cpoly_mult_cr_cs q c) r) (cpoly_mult_cs (cpoly_linear_cs [0] (cpoly_mult_cs p0 q)) r)). apply cpoly_plus_op_wd. apply cpoly_mult_cr_assoc_mult. rewrite cpoly_lin_mult. apply eq_transitive_unfolded with (cpoly_plus_cs cpoly_zero_cs (cpoly_linear_cs [0] (cpoly_mult_cs (cpoly_mult_cs p0 q) r))). rewrite cpoly_zero_plus. apply _cpoly_lin_eq_lin. split. algebra. assumption. apply cpoly_plus_op_wd. apply eq_symmetric_unfolded. apply cpoly_mult_cr_zero. apply _cpoly_lin_eq_lin. split. algebra. algebra. apply eq_symmetric_unfolded. apply cpoly_mult_dist_rht. Qed. Lemma cpoly_mult_cr_one : forall p, cpoly_mult_cr_cs p [1] [=] p. Proof. intro. pattern p in |- *; apply cpoly_ind_cs. algebra. intros. rewrite cpoly_lin_mult_cr. apply _cpoly_lin_eq_lin. algebra. Qed. Lemma cpoly_one_mult : forall p, cpoly_mult_cs cpoly_one p [=] p. Proof. intro. unfold cpoly_one in |- *. unfold cpoly_constant in |- *. replace (cpoly_linear [1] cpoly_zero) with (cpoly_linear_cs [1] cpoly_zero). 2: reflexivity. rewrite cpoly_lin_mult. rewrite cpoly_zero_mult. apply eq_transitive_unfolded with (cpoly_plus_cs p cpoly_zero_cs). apply cpoly_plus_op_wd. apply cpoly_mult_cr_one. apply _cpoly_lin_eq_zero; algebra. rewrite cpoly_plus_zero; algebra. Qed. Lemma cpoly_mult_one : forall p, cpoly_mult_cs p cpoly_one [=] p. Proof. intro. apply eq_transitive_unfolded with (cpoly_mult_cs cpoly_one p). apply cpoly_mult_commutative. apply cpoly_one_mult. Qed. Lemma cpoly_mult_monoid : is_CMonoid (Build_CSemiGroup _ _ cpoly_mult_assoc) cpoly_one. Proof. apply Build_is_CMonoid. exact cpoly_mult_one. exact cpoly_one_mult. Qed. Lemma cpoly_cr_non_triv : cpoly_ap cpoly_one cpoly_zero. Proof. change (cpoly_linear_cs [1] cpoly_zero_cs [#] cpoly_zero_cs) in |- *. cut (([1]:CR) [#] [0] or cpoly_zero_cs [#] cpoly_zero_cs). auto. left. algebra. Qed. (** cring_old uses the original definition of polynomial multiplication *) Lemma cpoly_is_CRing_old : is_CRing cpoly_cabgroup cpoly_one cpoly_mult_op. Proof. apply Build_is_CRing with cpoly_mult_assoc. exact cpoly_mult_monoid. exact cpoly_mult_commutative. exact cpoly_cr_dist. exact cpoly_cr_non_triv. Qed. Definition cpoly_cring_old : CRing := Build_CRing _ _ _ cpoly_is_CRing_old. (** [cpoly_mult_fast] produces smaller lengthed polynomials when multiplying by zero. For example [Eval simpl in cpoly_mult_cs _ _X_ ([0]:cpoly_cring Q_as_CRing)] returns [cpoly_linear Q_as_CRing QZERO (cpoly_linear Q_as_CRing QZERO (cpoly_zero Q_as_CRing))] while [Eval simpl in cpoly_mult_fast_cs _ _X_ ([0]:cpoly_cring Q_as_CRing)] returns [cpoly_zero Q_as_CRing]. Smaller lengthed polynomials means faster operations, and better estimates of the degree of a polynomial. *) Definition cpoly_mult_fast (p q : cpoly) : cpoly := match q with | cpoly_zero => cpoly_zero | _ => cpoly_mult p q end. Definition cpoly_mult_fast_cs (p q : cpoly_csetoid) : cpoly_csetoid := cpoly_mult_fast p q. (** cpoly_mult_fast is proven correct with respect the the original multiplication in cpoly_cring_old *) Lemma cpoly_mult_fast_ap_equiv : forall p1 p2 q1 q2, (cpoly_mult_fast_cs p1 q1)[#](cpoly_mult_cs p2 q2) -> p1[#]p2 or q1[#]q2. destruct q1 as [|c q1]; destruct q2 as [|c0 q2]; intros X; simpl in X. Proof. rewrite cpoly_ap_p_zero in X. elim (ap_irreflexive cpoly_csetoid cpoly_zero). stepl (cpoly_mult_cs p2 cpoly_zero). assumption. apply cpoly_mult_zero. rewrite cpoly_ap_p_zero in X. right. apply ap_symmetric. eapply cring_mult_ap_zero_op with (R:=cpoly_cring_old). apply X. right. eapply cring_mult_ap_zero_op with (R:=cpoly_cring_old). change (cpoly_mult p1 (cpoly_linear c q1)) with (cpoly_mult_cs p1 (cpoly_linear c q1)) in X. stepr (cpoly_mult_cs p2 cpoly_zero). apply X. apply cpoly_mult_zero. apply cpoly_mult_op_strext. apply X. Qed. Lemma cpoly_mult_fast_equiv : forall p q, (cpoly_mult_fast_cs p q)[=](cpoly_mult_cs p q). Proof. intros p q. apply not_ap_imp_eq. intro H. assert (p[#]p or q[#]q). apply cpoly_mult_fast_ap_equiv. assumption. destruct X as [X|X]; apply (ap_irreflexive _ _ X). Qed. Lemma cpoly_mult_fast_op_strext : bin_op_strext cpoly_csetoid cpoly_mult_fast_cs. Proof. intros x1 x2 y1 y2 H. apply cpoly_mult_op_strext. stepl (cpoly_mult_fast_cs x1 y1). stepr (cpoly_mult_fast_cs x2 y2). assumption. apply cpoly_mult_fast_equiv. apply cpoly_mult_fast_equiv. Qed. Definition cpoly_mult_fast_op := Build_CSetoid_bin_op _ _ cpoly_mult_fast_op_strext. Lemma cpoly_is_CRing : is_CRing cpoly_cabgroup cpoly_one cpoly_mult_fast_op. Proof. assert (mult_assoc:(associative cpoly_mult_fast_op)). intros p q r. stepl (cpoly_mult_op p (cpoly_mult_op q r)). stepr (cpoly_mult_op (cpoly_mult_op p q) r). apply cpoly_mult_assoc. stepl (cpoly_mult_op (cpoly_mult_fast_op p q) r). apply eq_symmetric; apply cpoly_mult_fast_equiv. apply bin_op_wd_unfolded. apply cpoly_mult_fast_equiv. apply eq_reflexive. stepl (cpoly_mult_op p (cpoly_mult_fast_op q r)). apply eq_symmetric; apply cpoly_mult_fast_equiv. apply bin_op_wd_unfolded. apply eq_reflexive. apply cpoly_mult_fast_equiv. eapply Build_is_CRing with mult_assoc. split. intro p. stepl (cpoly_mult_op p cpoly_one). apply cpoly_mult_one. apply eq_symmetric; apply cpoly_mult_fast_equiv. intro p. stepl (cpoly_mult_op cpoly_one p). apply cpoly_one_mult. apply eq_symmetric; apply cpoly_mult_fast_equiv. intros p q. stepl (cpoly_mult_op p q). stepr (cpoly_mult_op q p). apply cpoly_mult_commutative. apply eq_symmetric; apply cpoly_mult_fast_equiv. apply eq_symmetric; apply cpoly_mult_fast_equiv. intros p q r. stepl (cpoly_mult_op p (q[+]r)). stepr (cpoly_plus_op (cpoly_mult_op p q) (cpoly_mult_op p r)). apply cpoly_cr_dist. apply bin_op_wd_unfolded; apply eq_symmetric; apply cpoly_mult_fast_equiv. apply eq_symmetric; apply cpoly_mult_fast_equiv. exact cpoly_cr_non_triv. Qed. Definition cpoly_cring : CRing := Build_CRing _ _ _ cpoly_is_CRing. Canonical Structure cpoly_cring. Lemma cpoly_constant_strext : fun_strext (S1:=CR) (S2:=cpoly_cring) cpoly_constant. Proof. unfold fun_strext in |- *. unfold cpoly_constant in |- *. simpl in |- *. intros x y H. elim H. auto. intro. elim b. Qed. Lemma cpoly_constant_wd : fun_wd (S1:=CR) (S2:=cpoly_cring) cpoly_constant. Proof. apply fun_strext_imp_wd. exact cpoly_constant_strext. Qed. Definition cpoly_constant_fun := Build_CSetoid_fun _ _ _ cpoly_constant_strext. Definition cpoly_var : cpoly_cring := cpoly_linear_cs [0] ([1]:cpoly_cring). Notation "'_X_'" := cpoly_var. Definition cpoly_x_minus_c c : cpoly_cring := cpoly_linear_cs [--]c ([1]:cpoly_cring). Lemma cpoly_x_minus_c_strext : fun_strext (S1:=CR) (S2:=cpoly_cring) cpoly_x_minus_c. Proof. unfold fun_strext in |- *. unfold cpoly_x_minus_c in |- *. simpl in |- *. intros x y H. elim H; intro H0. apply (cs_un_op_strext _ _ _ _ H0). elim H0; intro H1. elim (ap_irreflexive_unfolded _ _ H1). elim H1. Qed. Lemma cpoly_x_minus_c_wd : fun_wd (S1:=CR) (S2:=cpoly_cring) cpoly_x_minus_c. Proof. apply fun_strext_imp_wd. exact cpoly_x_minus_c_strext. Qed. Definition cpoly_ring_th:= (CRing_Ring cpoly_cring). End CPoly_CRing. Canonical Structure cpoly_cring. Notation "'_X_'" := (@cpoly_var _). Definition cpoly_linear_fun' (CR : CRing) : CSetoid_bin_fun CR (cpoly_cring CR) (cpoly_cring CR) := cpoly_linear_fun CR. Arguments cpoly_linear_fun' {CR}. Infix "[+X*]" := cpoly_linear_fun' (at level 50, left associativity). (** ** Apartness, equality, and induction %\label{section:poly-equality}% *) Section CPoly_CRing_ctd. (** %\begin{convention}% Let [CR] be a ring, [p] and [q] polynomials over that ring, and [c] and [d] elements of the ring. %\end{convention}% *) Variable CR : CRing. Add Ring cpolycring_th : (CRing_Ring (cpoly_cring CR)). Notation RX := (cpoly_cring CR). Section helpful_section. Variables p q : RX. Variables c d : CR. (** It should be possible to merge most of this section using the new apply *) Lemma linear_eq_zero_ : c[+X*]p [=] [0] -> c [=] [0] /\ p [=] [0]. Proof cpoly_lin_eq_zero_ CR p c. Lemma _linear_eq_zero : c [=] [0] /\ p [=] [0] -> c[+X*]p [=] [0]. Proof _cpoly_lin_eq_zero CR p c. Lemma zero_eq_linear_ : [0] [=] c[+X*]p -> c [=] [0] /\ [0] [=] p. Proof cpoly_zero_eq_lin_ CR p c. Lemma _zero_eq_linear : c [=] [0] /\ [0] [=] p -> [0] [=] c[+X*]p. Proof _cpoly_zero_eq_lin CR p c. Lemma linear_eq_linear_ : c[+X*]p [=] d[+X*]q -> c [=] d /\ p [=] q. Proof cpoly_lin_eq_lin_ CR p q c d. Lemma _linear_eq_linear : c [=] d /\ p [=] q -> c[+X*]p [=] d[+X*]q. Proof _cpoly_lin_eq_lin CR p q c d. Lemma linear_ap_zero_ : c[+X*]p [#] [0] -> c [#] [0] or p [#] [0]. Proof cpoly_lin_ap_zero_ CR p c. Lemma _linear_ap_zero : c [#] [0] or p [#] [0] -> c[+X*]p [#] [0]. Proof _cpoly_lin_ap_zero CR p c. Lemma linear_ap_zero : (c[+X*]p [#] [0]) = (c [#] [0] or p [#] [0]). Proof cpoly_lin_ap_zero CR p c. Lemma zero_ap_linear_ : [0] [#] c[+X*]p -> c [#] [0] or [0] [#] p. Proof cpoly_zero_ap_lin_ CR p c. Lemma _zero_ap_linear : c [#] [0] or [0] [#] p -> [0] [#] c[+X*]p. Proof _cpoly_zero_ap_lin CR p c. Lemma zero_ap_linear : ([0] [#] c[+X*]p) = (c [#] [0] or [0] [#] p). Proof cpoly_zero_ap_lin CR p c. Lemma linear_ap_linear_ : c[+X*]p [#] d[+X*]q -> c [#] d or p [#] q. Proof cpoly_lin_ap_lin_ CR p q c d. Lemma _linear_ap_linear : c [#] d or p [#] q -> c[+X*]p [#] d[+X*]q. Proof _cpoly_lin_ap_lin CR p q c d. Lemma linear_ap_linear : (c[+X*]p [#] d[+X*]q) = (c [#] d or p [#] q). Proof cpoly_lin_ap_lin CR p q c d. End helpful_section. Lemma Ccpoly_induc : forall P : RX -> CProp, P [0] -> (forall p c, P p -> P (c[+X*]p)) -> forall p, P p. Proof (Ccpoly_ind_cs CR). Lemma Ccpoly_double_sym_ind : forall P : RX -> RX -> CProp, Csymmetric P -> (forall p, P p [0]) -> (forall p q c d, P p q -> P (c[+X*]p) (d[+X*]q)) -> forall p q, P p q. Proof (Ccpoly_double_sym_ind0_cs CR). Lemma Cpoly_double_comp_ind : forall P : RX -> RX -> CProp, (forall p1 p2 q1 q2, p1 [=] p2 -> q1 [=] q2 -> P p1 q1 -> P p2 q2) -> P [0] [0] -> (forall p q c d, P p q -> P (c[+X*]p) (d[+X*]q)) -> forall p q, P p q. Proof (Ccpoly_double_comp_ind CR). Lemma Cpoly_triple_comp_ind : forall P : RX -> RX -> RX -> CProp, (forall p1 p2 q1 q2 r1 r2, p1 [=] p2 -> q1 [=] q2 -> r1 [=] r2 -> P p1 q1 r1 -> P p2 q2 r2) -> P [0] [0] [0] -> (forall p q r c d e, P p q r -> P (c[+X*]p) (d[+X*]q) (e[+X*]r)) -> forall p q r, P p q r. Proof (Ccpoly_triple_comp_ind CR). Lemma cpoly_induc : forall P : RX -> Prop, P [0] -> (forall p c, P p -> P (c[+X*]p)) -> forall p, P p. Proof (cpoly_ind_cs CR). Lemma cpoly_double_sym_ind : forall P : RX -> RX -> Prop, Tsymmetric P -> (forall p, P p [0]) -> (forall p q c d, P p q -> P (c[+X*]p) (d[+X*]q)) -> forall p q, P p q. Proof (cpoly_double_sym_ind0_cs CR). Lemma poly_double_comp_ind : forall P : RX -> RX -> Prop, (forall p1 p2 q1 q2, p1 [=] p2 -> q1 [=] q2 -> P p1 q1 -> P p2 q2) -> P [0] [0] -> (forall p q c d, P p q -> P (c[+X*]p) (d[+X*]q)) -> forall p q, P p q. Proof (cpoly_double_comp_ind CR). Lemma poly_triple_comp_ind : forall P : RX -> RX -> RX -> Prop, (forall p1 p2 q1 q2 r1 r2, p1 [=] p2 -> q1 [=] q2 -> r1 [=] r2 -> P p1 q1 r1 -> P p2 q2 r2) -> P [0] [0] [0] -> (forall p q r c d e, P p q r -> P (c[+X*]p) (d[+X*]q) (e[+X*]r)) -> forall p q r, P p q r. Proof (cpoly_triple_comp_ind CR). Transparent cpoly_cring. Transparent cpoly_cgroup. Transparent cpoly_csetoid. Fixpoint cpoly_apply (p : RX) (x : CR) {struct p} : CR := match p with | cpoly_zero _ => [0] | cpoly_linear _ c p1 => c[+]x[*]cpoly_apply p1 x end. Lemma cpoly_apply_strext : bin_fun_strext _ _ _ cpoly_apply. Proof. unfold bin_fun_strext in |- *. do 2 intro. pattern x1, x2 in |- *. apply Ccpoly_double_sym_ind. unfold Csymmetric in |- *. intros. generalize (ap_symmetric _ _ _ X0); intro. elim (X _ _ X1); intro. left. apply ap_symmetric_unfolded. assumption. right. apply ap_symmetric_unfolded. assumption. do 3 intro. pattern p in |- *. apply Ccpoly_induc. simpl in |- *. intro H. elim (ap_irreflexive _ _ H). intros. simpl in X0. simpl in X. cut (c[+]y1[*]cpoly_apply p0 y1 [#] [0][+]y1[*][0]). intro. elim (cs_bin_op_strext _ _ _ _ _ _ X1); intro H2. left. cut (c [#] [0] or p0 [#] [0]). intro. apply _linear_ap_zero. auto. left. assumption. elim (cs_bin_op_strext _ _ _ _ _ _ H2); intro H3. elim (ap_irreflexive _ _ H3). elim (X H3); intro H4. left. cut (c [#] [0] or p0 [#] [0]). intro; apply _linear_ap_zero. auto. right. exact H4. auto. astepr ([0][+]([0]:CR)). astepr ([0]:CR). auto. simpl in |- *. intros. elim (cs_bin_op_strext _ _ _ _ _ _ X0); intro H1. auto. elim (cs_bin_op_strext _ _ _ _ _ _ H1); intro H2. auto. elim (X _ _ H2); auto. Qed. Lemma cpoly_apply_wd : bin_fun_wd _ _ _ cpoly_apply. Proof. apply bin_fun_strext_imp_wd. exact cpoly_apply_strext. Qed. Definition cpoly_apply_fun := Build_CSetoid_bin_fun _ _ _ _ cpoly_apply_strext. End CPoly_CRing_ctd. (** %\begin{convention}% [cpoly_apply_fun] is denoted infix by [!] The first argument is left implicit, so the application of polynomial [f] (seen as a function) to argument [x] can be written as [f!x]. In the names of lemmas, we write [apply]. %\end{convention}% *) Arguments cpoly_apply_fun {CR}. Infix "!" := cpoly_apply_fun (at level 1, no associativity). (** ** Basic properties of polynomials %\begin{convention}% Let [R] be a ring and write [RX] for the ring of polynomials over [R]. %\end{convention}% *) Section Poly_properties. Variable R : CRing. Add Ring cpolycring_thR : (cpoly_ring_th R). Notation RX := (cpoly_cring R). Lemma cpoly_const_one : [1] [=] cpoly_constant_fun _ ([1]:R). Proof. simpl in |- *; split; algebra. Qed. Lemma cpoly_const_plus : forall a b : R, cpoly_constant_fun _ (a[+]b) [=] cpoly_constant_fun _ a[+]cpoly_constant_fun _ b. Proof. simpl in |- *; split; algebra. Qed. Lemma cpoly_const_mult : forall a b : R, cpoly_constant_fun _ (a[*]b) [=] cpoly_constant_fun _ a[*] cpoly_constant_fun _ b. Proof. simpl in |- *; split; algebra. Qed. Definition polyconst : RingHom R RX := Build_RingHom _ _ _ cpoly_const_plus cpoly_const_mult cpoly_const_one. Notation "'_C_'" := polyconst. Lemma c_one : [1] [=] _C_ ([1]:R). Proof. simpl in |- *; split; algebra. Qed. Lemma c_plus : forall a b : R, _C_ (a[+]b) [=] _C_ a[+] _C_ b. Proof. simpl in |- *; split; algebra. Qed. Lemma c_mult : forall a b : R, _C_ (a[*]b) [=] _C_ a[*] _C_ b. Proof. simpl in |- *; split; algebra. Qed. Lemma c_zero : [0] [=] _C_ ([0]:R). Proof. simpl in |- *; split; algebra. Qed. (** *** Constant and identity *) Lemma cpoly_X_ : _X_ [=] ([0]:RX) [+X*][1]. Proof. algebra. Qed. Lemma cpoly_C_ : forall c : R, _C_ c [=] c[+X*][0]. Proof. algebra. Qed. Hint Resolve cpoly_X_ cpoly_C_: algebra. Lemma cpoly_const_eq : forall c d : R, c [=] d -> _C_ c [=] _C_ d. Proof. algebra. Qed. Lemma cpoly_lin : forall (p : RX) (c : R), c[+X*]p [=] _C_ c[+]_X_[*]p. Proof. intros. astepr (c[+X*][0][+] ((cpoly_mult_cr_cs _ p [0]:RX) [+] (cpoly_linear _ ([0]:R) (cpoly_mult_cs _ (cpoly_one R) (p:cpoly_csetoid R)) :cpoly_csetoid R))). cut (cpoly_mult_cr_cs R p [0] [=] ([0]:RX)). intro. astepr (c[+X*][0][+] (([0]:RX) [+] (cpoly_linear _ ([0]:R) (cpoly_mult_cs _ (cpoly_one R) (p:cpoly_csetoid R)) :cpoly_csetoid R))). 2: apply (cpoly_mult_cr_zero R p). cut ((cpoly_mult_cs _ (cpoly_one R) (p:cpoly_csetoid R):cpoly_csetoid R) [=] p). intro. apply eq_transitive_unfolded with (c[+X*][0][+](([0]:RX) [+]cpoly_linear _ ([0]:R) (p:cpoly_csetoid R))). 2: apply bin_op_wd_unfolded. 2: algebra. 2: apply bin_op_wd_unfolded. 2: algebra. 2: apply (cpoly_linear_wd R). 2: algebra. 2: apply eq_symmetric_unfolded. 2: apply cpoly_one_mult. astepr (c[+X*][0][+]cpoly_linear _ ([0]:R) (p:cpoly_csetoid R)). astepr (c[+][0][+X*]([0][+]p)). astepr (c[+X*]p). algebra. apply cpoly_one_mult. destruct p. simpl. algebra. simpl. split. auto with *. apply eq_reflexive with (S:=cpoly_cring R). Qed. Hint Resolve cpoly_lin: algebra. (* SUPERFLUOUS *) Lemma poly_linear : forall c f, (cpoly_linear _ c f:RX) [=] _X_[*]f[+]_C_ c. Proof. intros. astepr (_C_ c[+]_X_[*]f). exact (cpoly_lin f c). Qed. Lemma poly_c_apzero : forall a : R, _C_ a [#] [0] -> a [#] [0]. Proof. intros. cut (_C_ a [#] _C_ [0]). intro H0. generalize (csf_strext _ _ _ _ _ H0); auto. Hint Resolve c_zero: algebra. astepr ([0]:RX). auto. Qed. Lemma c_mult_lin : forall (p : RX) c d, _C_ c[*] (d[+X*]p) [=] c[*]d[+X*]_C_ c[*]p. Proof. intros. pattern p in |- *. apply cpoly_induc. simpl in |- *. repeat split; algebra. intros. simpl in |- *. repeat split; algebra. change ((cpoly_mult_cr R p0 c:RX) [=] (cpoly_mult_cr R p0 c:RX)[+][0]) in |- *. algebra. Qed. (* SUPERFLUOUS ? *) Lemma lin_mult : forall (p q : RX) c, (c[+X*]p) [*]q [=] _C_ c[*]q[+]_X_[*] (p[*]q). Proof. intros. astepl ((_C_ c[+]_X_[*]p)[*]q). astepl (_C_ c[*]q[+]_X_[*]p[*]q). algebra. Qed. Hint Resolve lin_mult: algebra. (** *** Application of polynomials *) Lemma poly_eq_zero : forall p : RX, p [=] cpoly_zero R -> forall x, p ! x [=] [0]. Proof. intros. astepl (cpoly_zero R) ! x. change ([0] ! x [=] [0]) in |- *. algebra. Qed. Lemma apply_wd : forall (p p' : RX) x x', p [=] p' -> x [=] x' -> p ! x [=] p' ! x'. Proof. algebra. Qed. Lemma cpolyap_pres_eq : forall (f : RX) x y, x [=] y -> f ! x [=] f ! y. Proof. algebra. Qed. Lemma cpolyap_strext : forall (f : RX) x y, f ! x [#] f ! y -> x [#] y. Proof. intros f x y H. elim (csbf_strext _ _ _ _ _ _ _ _ H); intro H0. elim (ap_irreflexive_unfolded _ _ H0). assumption. Qed. Definition cpoly_csetoid_op (f : RX) : CSetoid_un_op R := Build_CSetoid_fun _ _ (fun x => f ! x) (cpolyap_strext f). Definition FPoly p := total_eq_part _ (cpoly_csetoid_op p). Lemma c_apply : forall c x : R, (_C_ c) ! x [=] c. Proof. intros. simpl in |- *. astepl (c[+][0]). algebra. Qed. Lemma x_apply : forall x : R, _X_ ! x [=] x. Proof. intros. simpl in |- *. astepl (x[*]([1][+]x[*][0])). astepl (x[*]([1][+][0])). astepl (x[*][1]). algebra. Qed. Lemma plus_apply : forall (p q : RX) x, (p[+]q) ! x [=] p ! x[+]q ! x. Proof. intros. pattern p, q in |- *; apply poly_double_comp_ind. intros. astepl (p1[+]q1) ! x. astepr (p1 ! x[+]q1 ! x). algebra. simpl in |- *. algebra. intros. astepl (c[+]d[+]x[*](p0[+]q0) ! x). astepr (c[+]x[*]p0 ! x[+](d[+]x[*]q0 ! x)). astepl (c[+]d[+]x[*](p0 ! x[+]q0 ! x)). astepl (c[+]d[+](x[*]p0 ! x[+]x[*]q0 ! x)). astepl (c[+](d[+](x[*]p0 ! x[+]x[*]q0 ! x))). astepr (c[+](x[*]p0 ! x[+](d[+]x[*]q0 ! x))). astepl (c[+](d[+]x[*]p0 ! x[+]x[*]q0 ! x)). astepr (c[+](x[*]p0 ! x[+]d[+]x[*]q0 ! x)). algebra. Qed. Lemma inv_apply : forall (p : RX) x, ( [--]p) ! x [=] [--]p ! x. Proof. intros. pattern p in |- *. apply cpoly_induc. simpl in |- *. algebra. intros. astepl ( [--]c[+]x[*]( [--]p0) ! x). astepr ( [--](c[+]x[*]p0 ! x)). astepr ( [--]c[+][--](x[*]p0 ! x)). astepr ( [--]c[+]x[*][--]p0 ! x). algebra. Qed. Hint Resolve plus_apply inv_apply: algebra. Lemma minus_apply : forall (p q : RX) x, (p[-]q) ! x [=] p ! x[-]q ! x. Proof. intros. astepl (p[+][--]q) ! x. astepr (p ! x[+][--]q ! x). astepl (p ! x[+]( [--]q) ! x). algebra. Qed. Lemma c_mult_apply : forall (q : RX) c x, (_C_ c[*]q) ! x [=] c[*]q ! x. Proof. intros. astepl ((cpoly_mult_cr R q c:RX)[+]([0][+X*][0])) ! x. astepl ((cpoly_mult_cr R q c) ! x[+]([0][+X*][0]) ! x). astepl ((cpoly_mult_cr R q c) ! x[+]([0][+]x[*][0])). astepl ((cpoly_mult_cr R q c) ! x[+]([0][+][0])). astepl ((cpoly_mult_cr R q c) ! x[+][0]). astepl (cpoly_mult_cr R q c) ! x. pattern q in |- *. apply cpoly_induc. simpl in |- *. algebra. intros. astepl (c[*]c0[+X*]cpoly_mult_cr R p c) ! x. astepl (c[*]c0[+]x[*](cpoly_mult_cr R p c) ! x). astepl (c[*]c0[+]x[*](c[*]p ! x)). astepr (c[*](c0[+]x[*]p ! x)). astepr (c[*]c0[+]c[*](x[*]p ! x)). apply bin_op_wd_unfolded. algebra. astepl (x[*]c[*]p ! x). astepr (c[*]x[*]p ! x). algebra. stepr ((cpoly_mult _ (_C_ c) q)!x). apply eq_reflexive. apply apply_wd. apply eq_symmetric. apply (cpoly_mult_fast_equiv _ (_C_ c) q). apply eq_reflexive. Qed. Hint Resolve c_mult_apply: algebra. Lemma mult_apply : forall (p q : RX) x, (p[*]q) ! x [=] p ! x[*]q ! x. Proof. intros. pattern p in |- *. apply cpoly_induc. astepl ([0] ! x). simpl in |- *. algebra. intros. astepl (_C_ c[*]q[+]_X_[*](p0[*]q)) ! x. astepl ((_C_ c[*]q) ! x[+](_X_[*](p0[*]q)) ! x). astepl ((_C_ c[*]q) ! x[+]([0][+]_X_[*](p0[*]q)) ! x). astepl ((_C_ c[*]q) ! x[+](_C_ [0][+]_X_[*](p0[*]q)) ! x). astepl ((_C_ c[*]q) ! x[+]([0][+X*]p0[*]q) ! x). astepl ((_C_ c[*]q) ! x[+]([0][+]x[*](p0[*]q) ! x)). astepl (c[*]q ! x[+]x[*](p0[*]q) ! x). astepl (c[*]q ! x[+]x[*](p0 ! x[*]q ! x)). astepr ((c[+]x[*]p0 ! x)[*]q ! x). astepr (c[*]q ! x[+]x[*]p0 ! x[*]q ! x). algebra. Qed. Hint Resolve mult_apply: algebra. Lemma one_apply : forall x : R, [1] ! x [=] [1]. Proof. intro. astepl (_C_ [1]) ! x. apply c_apply. Qed. Hint Resolve one_apply: algebra. Lemma nexp_apply : forall (p : RX) n x, (p[^]n) ! x [=] p ! x[^]n. Proof. intros. induction n as [| n Hrecn]. astepl ([1]:RX) ! x. astepl ([1]:R). algebra. astepl (p[*]p[^]n) ! x. astepl (p ! x[*](p[^]n) ! x). astepl (p ! x[*]p ! x[^]n). algebra. Qed. (* SUPERFLUOUS *) Lemma poly_inv_apply : forall (p : RX) x, (cpoly_inv _ p) ! x [=] [--]p ! x. Proof inv_apply. Lemma Sum0_cpoly_ap : forall (f : nat -> RX) a k, (Sum0 k f) ! a [=] Sum0 k (fun i => (f i) ! a). Proof. intros. induction k as [| k Hreck]. simpl in |- *. algebra. astepl (Sum0 k f[+]f k) ! a. astepl ((Sum0 k f) ! a[+](f k) ! a). astepl (Sum0 k (fun i : nat => (f i) ! a)[+](f k) ! a). simpl in |- *. algebra. Qed. Lemma Sum_cpoly_ap : forall (f : nat -> RX) a k l, (Sum k l f) ! a [=] Sum k l (fun i => (f i) ! a). Proof. unfold Sum in |- *. unfold Sum1 in |- *. intros. unfold cg_minus in |- *. astepl ((Sum0 (S l) f) ! a[+]( [--](Sum0 k f)) ! a). astepl ((Sum0 (S l) f) ! a[+][--](Sum0 k f) ! a). apply bin_op_wd_unfolded. apply Sum0_cpoly_ap. apply un_op_wd_unfolded. apply Sum0_cpoly_ap. Qed. Lemma cm_Sum_apply (l: list (cpoly_cring R)) (x: R): (cm_Sum l) ! x [=] cm_Sum (map (fun e => e ! x) l). Proof. induction l. reflexivity. change ((a [+] cm_Sum l) ! x[=]cm_Sum (map (fun e : cpoly_cring R => e ! x) (a :: l))). rewrite plus_apply, IHl. reflexivity. Qed. Hint Rewrite cm_Sum_apply: apply. Lemma cr_Product_apply (l: list (cpoly_cring R)) (x: R): (cr_Product l) ! x [=] cr_Product (map (fun e => e ! x) l). Proof. induction l. simpl. rewrite cring_mult_zero. apply cm_rht_unit_unfolded. change ((a [*] cr_Product l) ! x[=]cr_Product (map (fun e : cpoly_cring R => e ! x) (a :: l))). rewrite mult_apply, IHl. reflexivity. Qed. Hint Rewrite cr_Product_apply: apply. End Poly_properties. (* Implicit Arguments _C_ [R].*) Notation "'_C_'" := (@polyconst _). (** ** Induction properties of polynomials for [Prop] *) Section Poly_Prop_Induction. Variable CR : CRing. Add Ring cpolycring_thCR : (cpoly_ring_th CR). Notation Cpoly := (cpoly CR). Notation Cpoly_zero := (cpoly_zero CR). Notation Cpoly_linear := (cpoly_linear CR). Notation Cpoly_cring := (cpoly_cring CR). Lemma cpoly_double_ind : forall P : Cpoly_cring -> Cpoly_cring -> Prop, (forall p, P p [0]) -> (forall p, P [0] p) -> (forall p q c d, P p q -> P (c[+X*]p) (d[+X*]q)) -> forall p q, P p q. Proof (cpoly_double_ind0_cs CR). End Poly_Prop_Induction. #[global] Hint Resolve poly_linear cpoly_lin: algebra. #[global] Hint Resolve apply_wd cpoly_const_eq: algebra_c. #[global] Hint Resolve c_apply x_apply inv_apply plus_apply minus_apply mult_apply nexp_apply: algebra. #[global] Hint Resolve one_apply c_zero c_one c_mult: algebra. #[global] Hint Resolve poly_inv_apply: algebra. #[global] Hint Resolve c_mult_lin: algebra. #[global] Hint Rewrite one_apply c_apply x_apply mult_apply plus_apply minus_apply : apply. #[global] Hint Rewrite inv_apply nexp_apply c_mult_apply poly_inv_apply : apply. Ltac poly_apply:= autorewrite with apply; simpl. (** The tactic [poly_apply] applies polynomials to arguments *) Section Derivative. Variable R:CRing. Add Ring cpolycring_thR1 : (cpoly_ring_th R). Notation RX:= (cpoly_cring R). Fixpoint cpoly_diff (p : RX) : RX := match p with | cpoly_zero _ => [0] | cpoly_linear _ c p1 => p1[+]([0][+X*](cpoly_diff p1)) end. Lemma cpoly_diff_strext : un_op_strext _ cpoly_diff. Proof. intros x. induction x. induction y. auto with *. intros Hxy. right. abstract ( destruct (cpoly_ap_zero_plus _ _ _ (ap_symmetric _ _ _ Hxy)) as [c|[c|c]]; [apply (ap_symmetric _ _ _ c) |elim (ap_irreflexive _ _ c) |apply IHy;apply c]). intros [|a y] Hxy. simpl in Hxy. right. abstract ( destruct (cpoly_ap_zero_plus _ _ _ Hxy) as [c|[c|c]]; [apply (ap_symmetric _ _ _ c) |elim (ap_irreflexive _ _ c) |change ([0][#]x); apply ap_symmetric; apply IHx; apply ap_symmetric; apply c]). right. destruct (cpoly_plus_op_strext _ _ _ _ _ Hxy) as [c|[c|c]]. assumption. elim (ap_irreflexive _ _ c). apply IHx; apply c. Defined. Lemma cpoly_diff_wd : un_op_wd _ cpoly_diff. Proof. apply fun_strext_imp_wd. apply cpoly_diff_strext. Qed. Definition cpolyder := Build_CSetoid_un_op _ _ cpoly_diff_strext. Notation "'_D_'" := cpolyder. Lemma diff_zero : _D_ [0][=][0]. Proof. reflexivity. Qed. Lemma diff_one : _D_ [1][=][0]. Proof. simpl; split; auto with *; reflexivity. Qed. Lemma diff_const : forall c, _D_ (_C_ c)[=][0]. Proof. simpl; split; auto with *. Qed. Lemma diff_x : _D_ _X_[=][1]. Proof. simpl; split; auto with *. Qed. Lemma diff_linear : forall a (p:RX), _D_ (a[+X*]p)[=]p[+]_X_[*]_D_ p. Proof. intros a p. change (p[+]([0][+X*]_D_ p)[=]p[+]_X_[*]_D_ p). rewrite -> cpoly_lin. rewrite <- c_zero. ring. Qed. Lemma diff_plus : forall (p q:RX), _D_ (p[+]q)[=]_D_ p[+]_D_ q. Proof. induction p. reflexivity. intros [|a q]. rewrite -> cm_rht_unit_unfolded. change (cpoly_zero R) with ([0]:cpoly_cring R); algebra. change ((p[+]q)[+]cpoly_linear _ [0] (_D_ (p[+]q))[=] (p[+]cpoly_linear _ [0] (_D_ p))[+](q[+]cpoly_linear _ [0] (_D_ q))). do 3 rewrite -> poly_linear. change (st_car RX) in p, q. change (p[+]q[+](_X_[*]_D_ (p[+]q)[+]_C_ [0])[=] p[+](_X_[*]_D_ p[+]_C_ [0])[+](q[+](_X_[*]_D_ q[+]_C_ [0]))). rewrite -> (IHp q). rewrite <- c_zero. ring. Qed. Lemma diff_c_mult : forall c (p:RX), _D_ (_C_ c[*]p)[=]_C_ c[*]_D_ p. Proof. intros c p. induction p. auto with *. change (_D_ (cpoly_linear R s p)) with (p[+]([0][+X*](_D_ p))). change (cpoly_linear R s p) with (s[+X*]p). rewrite -> c_mult_lin. change (_D_ (c[*]s[+X*]_C_ c[*]p)) with (_C_ c[*]p [+] ([0][+X*](_D_ (_C_ c[*]p)))). rewrite -> IHp. do 2 rewrite -> cpoly_lin. rewrite <- c_zero. (* An attempt to avoid the following "change" Bind Scope ring_scope with CRing. Notation "a '====' b":=(a [=] b)(at level 80, right associativity): ring_scope. set (LHS:=_C_ c[*]p[+]([0][+]_X_[*](_C_ c[*]_D_ p))). set (RHS:=(_C_ c[*](p[+]([0][+]_X_[*]_D_ p)))). change (LHS ==== RHS). Or even: Ltac preRing := match goal with | |-(@st_eq ?s ?l ?r) => change (l ==== r) end. preRing.*) (* (cpoly_csemi_grp R) should be folded to RX *) change (@st_eq RX (@csg_op RX (@cr_mult RX (polyconst R c) p) (@csg_op RX (cm_unit RX) (@cr_mult RX (cpoly_var R) (@cr_mult RX (polyconst R c) (cpolyder p))))) (@cr_mult RX (polyconst R c) (@csg_op RX p (@csg_op RX (cm_unit RX) (@cr_mult RX (cpoly_var R) (cpolyder p)))))). ring. Qed. Lemma diff_mult : forall (p q:RX), _D_ (p[*]q)[=]_D_ p[*]q [+] p[*]_D_ q. Proof. induction p. intros q. change (_D_([0][*]q)[=][0][*]q[+][0][*]_D_ q). stepl (_D_([0]:RX)). 2: now destruct q. rewrite -> diff_zero. ring. intros q. change (st_car RX) in p. change (_D_((s[+X*]p)[*]q)[=]_D_(s[+X*]p)[*]q[+](s[+X*]p)[*]_D_ q). do 2 rewrite -> lin_mult. rewrite -> diff_linear. rewrite -> diff_plus. setoid_replace (_D_ ((_C_ s:RX)[*]q)) with (_C_ s[*]_D_ q) by apply diff_c_mult. setoid_replace (((_X_:RX)[*](p[*]q)):RX) with ((((_X_:RX)[*](p[*]q)))[+][0]) by (symmetry;apply cm_rht_unit_unfolded). setoid_replace ([0]:RX) with (_C_ [0]:RX) by apply c_zero. rewrite <- poly_linear. change (_D_ (cpoly_linear R [0] (p[*]q))) with (p[*]q [+] ([0][+X*]_D_ (p[*]q))). rewrite -> cpoly_lin. rewrite <- c_zero. rewrite -> IHp. ring. Qed. End Derivative. Notation "'_D_'" := (@cpolyder _). #[global] Hint Rewrite diff_zero diff_one diff_const diff_x diff_plus diff_c_mult diff_mult diff_linear : poly_diff. Section Map. Variable R S : CRing. Add Ring cpolycring_thRR : (cpoly_ring_th R). Add Ring cpolycring_thSS : (cpoly_ring_th S). Variable f : RingHom R S. Notation RX := (cpoly_cring R). Notation SX := (cpoly_cring S). Fixpoint cpoly_map_fun (p:RX) : SX := match p with | cpoly_zero _ => cpoly_zero _ | cpoly_linear _ c p1 => cpoly_linear _ (f c) (cpoly_map_fun p1) end. Lemma cpoly_map_strext : fun_strext cpoly_map_fun. Proof. intros x. induction x; intros y H. induction y. elim H. destruct H as [H|H]. left. eapply rh_apzero; apply H. right. apply IHy. apply H. destruct y as [|c y]. destruct H as [H|H]. left. eapply rh_apzero; apply H. right. change ([0][#]x). apply ap_symmetric. apply IHx. apply ap_symmetric. apply H. destruct H as [H|H]. left. eapply rh_strext; apply H. right. apply IHx. apply H. Defined. Definition cpoly_map_csf : CSetoid_fun RX SX := Build_CSetoid_fun _ _ _ cpoly_map_strext. Lemma cpoly_map_pres_plus : fun_pres_plus _ _ cpoly_map_csf. Proof. unfold fun_pres_plus. apply (cpoly_double_ind0 R). intros p. change (cpoly_map_csf(p[+][0])[=]cpoly_map_csf p[+][0]). stepr (cpoly_map_csf p). 2: ring. apply csf_wd. cut (forall p: cpoly_cring R, csg_op p [0] [=] p). easy. intros. ring. reflexivity. intros p q c d H. split. apply rh_pres_plus. apply H. Qed. Lemma cpoly_map_pres_mult : fun_pres_mult _ _ cpoly_map_csf. Proof. unfold fun_pres_mult. assert (X:forall x y, cpoly_map_csf (cpoly_mult_cr _ x y)[=]cpoly_mult_cr _ (cpoly_map_csf x) (f y)). induction x; intros y. apply eq_reflexive. split. apply rh_pres_mult. apply IHx. apply (cpoly_double_ind0 R). intros p. apply eq_reflexive. intros p. change (st_car RX) in p. change (cpoly_zero R) with ([0]:RX). stepl (cpoly_map_csf ([0]:RX)). change (cpoly_map_csf [0]) with ([0]:SX). ring. apply csf_wd; ring. intros p q c d H. split. autorewrite with ringHomPush. reflexivity. change (st_car RX) in p,q. change (cpoly_map_csf ((cpoly_mult_cr _ q c)[+](p[*](cpoly_linear _ d q))) [=](cpoly_mult_cr _ (cpoly_map_csf q) (f c))[+](cpoly_map_csf p)[*](cpoly_map_csf (cpoly_linear _ d q))). stepl ((cpoly_map_csf (cpoly_mult_cr R q c))[+](cpoly_map_csf (p[*]cpoly_linear R d q))); [| apply eq_symmetric; apply cpoly_map_pres_plus]. apply csbf_wd. apply X. stepl (cpoly_map_csf ((cpoly_linear R d q:RX)[*]p)); [| apply csf_wd;ring]. stepr (cpoly_map_csf (cpoly_linear R d q)[*]cpoly_map_csf p). 2:apply (mult_commut_unfolded SX). change ((cpoly_linear R d q:RX)[*]p) with (cpoly_mult_fast_cs _ (cpoly_linear R d q) p). rewrite -> cpoly_mult_fast_equiv. rewrite cpoly_lin_mult. change (cpoly_map_csf (cpoly_linear R d q:RX)[*]cpoly_map_csf p) with (cpoly_mult_fast_cs _ (cpoly_linear S (f d) (cpoly_map_csf q)) (cpoly_map_csf p)). rewrite -> cpoly_mult_fast_equiv. rewrite cpoly_lin_mult. stepl (cpoly_map_csf (cpoly_mult_cr_cs R p d)[+]cpoly_map_csf (cpoly_linear R [0] (cpoly_mult_cs R q p))); [| apply eq_symmetric; apply cpoly_map_pres_plus]. change (cpoly_map_fun (cpoly_mult_cr_cs R p d)[+] cpoly_map_fun ([0][+X*] (cpoly_mult_cs R q p))[=] (cpoly_mult_cr_cs S (cpoly_map_fun p) (f d))[+] ([0][+X*](cpoly_mult_cs S (cpoly_map_fun q) (cpoly_map_fun p)))). apply csbf_wd. apply X. split. auto with *. change ((cpoly_map_csf (cpoly_mult_cs R q p))[=](cpoly_mult_cs S (cpoly_map_csf q) (cpoly_map_csf p))). repeat setoid_rewrite <- cpoly_mult_fast_equiv. change (cpoly_map_csf (q[*]p)[=]cpoly_map_csf q[*]cpoly_map_csf p). stepr (cpoly_map_csf p[*]cpoly_map_csf q). 2: ring. rewrite <- H. apply csf_wd;ring. Qed. Lemma cpoly_map_pres_unit : fun_pres_unit _ _ cpoly_map_csf. Proof. split. apply rh_pres_unit. constructor. Qed. Definition cpoly_map := Build_RingHom _ _ _ cpoly_map_pres_plus cpoly_map_pres_mult cpoly_map_pres_unit. Lemma cpoly_map_X : cpoly_map _X_[=]_X_. Proof. repeat split. apply rh_pres_zero. apply rh_pres_unit. Qed. Lemma cpoly_map_C : forall c, cpoly_map (_C_ c)[=]_C_ (f c). Proof. reflexivity. Qed. Lemma cpoly_map_diff : forall p, cpoly_map (_D_ p) [=] _D_ (cpoly_map p). Proof. induction p. reflexivity. change (cpoly_map (_D_ (s[+X*]p))[=]_D_ (f s[+X*](cpoly_map p))). do 2 rewrite -> diff_linear. autorewrite with ringHomPush. rewrite -> IHp. rewrite -> cpoly_map_X. reflexivity. Qed. Lemma cpoly_map_apply : forall p x, f (p ! x)[=] (cpoly_map p) ! (f x). Proof. induction p. intros x. apply rh_pres_zero. intros x. simpl in *. rewrite -> rh_pres_plus. rewrite -> rh_pres_mult. rewrite -> IHp. reflexivity. Qed. End Map. Arguments cpoly_map [R S]. Lemma cpoly_map_compose : forall R S T (g:RingHom S T) (f:RingHom R S) p, (cpoly_map (RHcompose _ _ _ g f) p)[=]cpoly_map g (cpoly_map f p). Proof. induction p. constructor. split. reflexivity. apply IHp. Qed. (* TODO: prove that the polynomials form a module over the ring*) corn-8.20.0/algebra/CRing_Homomorphisms.v000066400000000000000000000125031473720167500202710ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* CRing_Homomorphisms.v, v1.0, 28april2004, Bart Kirkels *) (** printing [+] %\ensuremath+% #+# *) (** printing [*] %\ensuremath\times% #×# *) (** printing ['] %\ensuremath.% #.# *) (** printing [-] %\ensuremath{-}% #−# *) (** printing [--] %\ensuremath-% #−# *) (** printing [=] %\ensuremath=% #≡# *) (** printing [#] %\ensuremath\#% *) (** printing [0] %\ensuremath{\mathbf0}% #0# *) (** printing [1] %\ensuremath{\mathbf1}% #1# *) (** printing phi %\ensuremath{\phi}% *) Require Export CoRN.algebra.CRings. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". (** * Ring Homomorphisms ** Definition of Ring Homomorphisms Let [R] and [S] be rings, and [phi : R -> S]. *) Section RingHom_Definition. Variables R S : CRing. Section RingHom_Preliminary. Variable phi : CSetoid_fun R S. Definition fun_pres_plus := forall x y:R, phi (x[+]y) [=] (phi x) [+] (phi y). Definition fun_pres_mult := forall x y:R, phi (x[*]y) [=] (phi x) [*] (phi y). Definition fun_pres_unit := (phi ([1]:R)) [=] ([1]:S). End RingHom_Preliminary. Record RingHom : Type := {rhmap : CSetoid_fun R S; rh1 : fun_pres_plus rhmap; rh2 : fun_pres_mult rhmap; rh3 : fun_pres_unit rhmap}. End RingHom_Definition. Module Export coercions. Coercion rhmap : RingHom >-> CSetoid_fun. End coercions. (** ** Lemmas on Ring Homomorphisms Let [R] and [S] be rings and [f] a ring homomorphism from [R] to [S]. *** Axioms on Ring Homomorphisms *) Section RingHom_Lemmas. Variables R S : CRing. Section RingHom_Axioms. Variable f : RingHom R S. Lemma rh_strext : forall x y:R, (f x) [#] (f y) -> x [#] y. Proof. elim f; intuition. assert (fun_strext rhmap0); elim rhmap0; intuition. Qed. Lemma rh_pres_plus : forall x y:R, f (x[+]y) [=] (f x) [+] (f y). Proof. elim f; auto. Qed. Lemma rh_pres_mult : forall x y:R, f (x[*]y) [=] (f x) [*] (f y). Proof. elim f; auto. Qed. Lemma rh_pres_unit : (f ([1]:R)) [=] ([1]:S). Proof. elim f; auto. Qed. End RingHom_Axioms. Hint Resolve rh_strext rh_pres_plus rh_pres_mult rh_pres_unit : algebra. (** *** Facts on Ring Homomorphisms *) Section RingHom_Basics. Variable f : RingHom R S. Lemma rh_pres_zero : (f ([0]:R)) [=] ([0]:S). Proof. astepr ((f [0])[-](f [0])). astepr ((f ([0][+][0]))[-](f [0])). Step_final ((f [0][+]f [0])[-]f [0]). Qed. Lemma rh_pres_inv : forall x:R, (f [--]x) [=] [--] (f x). Proof. intro x; apply (cg_cancel_lft S (f x)). astepr ([0]:S). astepl (f (x[+][--]x)). Step_final (f ([0]:R)); try apply rh_pres_zero. Qed. Lemma rh_pres_minus : forall x y:R, f (x[-]y) [=] (f x) [-] (f y). Proof. unfold cg_minus. intros x y. rewrite -> rh_pres_plus. rewrite -> rh_pres_inv. reflexivity. Qed. Lemma rh_apzero : forall x:R, (f x) [#] [0] -> x [#] [0]. Proof. intros x X; apply (cg_ap_cancel_rht R x ([0]:R) x). astepr x. apply (rh_strext f (x[+]x) x). astepl ((f x)[+](f x)). astepr (([0]:S) [+] (f x)). apply (op_rht_resp_ap S (f x) ([0]:S) (f x)). assumption. Qed. Lemma rh_pres_nring : forall n, (f (nring n:R)) [=] (nring n:S). Proof. induction n. apply rh_pres_zero. simpl. rewrite -> rh_pres_plus;auto with *. Qed. End RingHom_Basics. End RingHom_Lemmas. #[global] Hint Resolve rh_strext rh_pres_plus rh_pres_mult rh_pres_unit : algebra. #[global] Hint Resolve rh_pres_zero rh_pres_minus rh_pres_inv rh_apzero : algebra. #[global] Hint Rewrite rh_pres_zero rh_pres_plus rh_pres_minus rh_pres_inv rh_pres_mult rh_pres_unit : ringHomPush. Definition RHid R : RingHom R R. Proof. exists (id_un_op R). intros x y; apply eq_reflexive. intros x y; apply eq_reflexive. apply eq_reflexive. Defined. Section Compose. Variable R S T : CRing. Variable phi : RingHom S T. Variable psi : RingHom R S. Lemma RHcompose1 : fun_pres_plus _ _ (compose_CSetoid_fun _ _ _ psi phi). Proof. intros x y. simpl. repeat rewrite -> rh_pres_plus;reflexivity. Qed. Lemma RHcompose2 : fun_pres_mult _ _ (compose_CSetoid_fun _ _ _ psi phi). Proof. intros x y. simpl. repeat rewrite -> rh_pres_mult; reflexivity. Qed. Lemma RHcompose3 : fun_pres_unit _ _ (compose_CSetoid_fun _ _ _ psi phi). Proof. unfold fun_pres_unit. simpl. repeat rewrite -> rh_pres_unit; reflexivity. Qed. Definition RHcompose : RingHom R T := Build_RingHom _ _ _ RHcompose1 RHcompose2 RHcompose3. End Compose. corn-8.20.0/algebra/CRing_as_Ring.v000066400000000000000000000003531473720167500170070ustar00rootroot00000000000000 Require Export CoRN.algebra.CRings. From Coq Require Export Ring. Definition CRing_Ring(R:CRing):(ring_theory (@cm_unit R) (@cr_one R) (@csg_op R) (@cr_mult R) (fun x y => x [-] y) (@cg_inv R) (@cs_eq R)). Proof. split;algebra. Qed. corn-8.20.0/algebra/CRings.v000066400000000000000000001044471473720167500155410ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Cezary Kaliszyk * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [*] %\ensuremath\times% #×# *) (** printing [^] %\ensuremath{\hat{\ }}% #^# *) (** printing {*} %\ensuremath\times% #×# *) (** printing {**} %\ensuremath\ast% #∗# *) (** printing {^} %\ensuremath{\hat{\ }}% #^# *) (** printing [1] %\ensuremath{\mathbf1}% #1# *) (** printing Two %\ensuremath{\mathbf2}% #2# *) (** printing Three %\ensuremath{\mathbf3}% #3# *) (** printing Four %\ensuremath{\mathbf4}% #4# *) (** printing Six %\ensuremath{\mathbf6}% #6# *) (** printing Eight %\ensuremath{\mathbf8}% #8# *) (** printing Nine %\ensuremath{\mathbf9}% #9# *) (** printing Twelve %\ensuremath{\mathbf{12}}% #12# *) (** printing Sixteen %\ensuremath{\mathbf{16}}% #16# *) (** printing Eighteen %\ensuremath{\mathbf{18}}% #18# *) (** printing TwentyFour %\ensuremath{\mathbf{24}}% #24# *) (** printing FortyEight %\ensuremath{\mathbf{48}}% #48# *) Require Import CoRN.tactics.CornTac. Require Export CoRN.algebra.CSums. Require Import CoRN.algebra.CAbMonoids Coq.Sorting.Permutation CoRN.util.SetoidPermutation Coq.Setoids.Setoid Coq.Classes.Morphisms. From Coq Require Import Lia. Transparent sym_eq. Transparent f_equal. (* Begin_SpecReals *) (* Constructive RINGS *) (** * Rings We actually define commutative rings with identity. ** Definition of the notion of Ring *) Definition distributive S (mult plus : CSetoid_bin_op S) := forall x y z, mult x (plus y z) [=] plus (mult x y) (mult x z). Arguments distributive [S]. Record is_CRing (G : CAbGroup) (One : G) (mult : CSetoid_bin_op G) : CProp := {ax_mult_assoc : associative mult; ax_mult_mon : is_CMonoid (Build_CSemiGroup G mult ax_mult_assoc) One; ax_mult_com : commutes mult; ax_dist : distributive mult csg_op; ax_non_triv : One [#] [0]}. Record CRing : Type := {cr_crr : CAbGroup; cr_one : cr_crr; cr_mult : CSetoid_bin_op cr_crr; cr_proof : is_CRing cr_crr cr_one cr_mult}. Definition cr_plus := @csg_op. Definition cr_inv := @cg_inv. Definition cr_minus := cg_minus. Notation "[1]" := (cr_one _). Module Export coercions. Export CAbGroups.coercions. Coercion cr_crr : CRing >-> CAbGroup. End coercions. (* End_SpecReals *) (* Begin_SpecReals *) (** %\begin{nameconvention}% In the names of lemmas, we will denote [One] with [one], and [[*]] with [mult]. %\end{nameconvention}% *) Arguments cr_mult {c}. Infix "[*]" := cr_mult (at level 40, left associativity). Section CRing_axioms. (** ** Ring axioms %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. Lemma CRing_is_CRing : is_CRing R [1] cr_mult. Proof. elim R; auto. Qed. Lemma mult_assoc : associative (cr_mult (c:=R)). Proof. elim CRing_is_CRing; auto. Qed. Lemma mult_commutes : commutes (cr_mult (c:=R)). Proof. elim CRing_is_CRing; auto. Qed. Lemma mult_mon : is_CMonoid (Build_CSemiGroup R cr_mult mult_assoc) [1]. Proof. elim (cr_proof R). intros H1 H2 H3 H4 H5. apply is_CMonoid_proof_irr with H1. assumption. Qed. (* End_SpecReals *) Lemma dist : distributive (S:=R) cr_mult (cr_plus R). Proof. elim (cr_proof R); auto. Qed. Lemma ring_non_triv : ([1]:R) [#] [0]. Proof. elim (cr_proof R); auto. Qed. Lemma mult_wd : forall x1 x2 y1 y2 : R, x1 [=] x2 -> y1 [=] y2 -> x1[*]y1 [=] x2[*]y2. Proof. intros; algebra. Qed. Lemma mult_wdl : forall x1 x2 y : R, x1 [=] x2 -> x1[*]y [=] x2[*]y. Proof. intros; algebra. Qed. Lemma mult_wdr : forall x y1 y2 : R, y1 [=] y2 -> x[*]y1 [=] x[*]y2. Proof. intros; algebra. Qed. (* Begin_SpecReals *) End CRing_axioms. Section Ring_constructions. (** ** Ring constructions %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. (** The multiplicative monoid of a ring is defined as follows. *) Definition Build_multCMonoid : CMonoid := Build_CMonoid _ _ (mult_mon R). (** Furthermore, this is an abelian monoid: *) Definition Build_multCAbMonoid: CAbMonoid := Build_CAbMonoid Build_multCMonoid (mult_commutes R). End Ring_constructions. (* End_SpecReals *) Section Ring_unfolded. (** ** Ring unfolded %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. (* begin hide *) Let mmR := Build_multCMonoid R. (* end hide *) Lemma mult_assoc_unfolded : forall x y z : R, x[*] (y[*]z) [=] x[*]y[*]z. Proof mult_assoc R. Lemma mult_commut_unfolded : forall x y : R, x[*]y [=] y[*]x. Proof mult_commutes R. Hint Resolve mult_commut_unfolded: algebra. Lemma mult_one : forall x : R, x[*][1] [=] x. Proof cm_rht_unit mmR. Lemma one_mult : forall x : R, [1][*]x [=] x. Proof cm_lft_unit mmR. Lemma ring_dist_unfolded : forall x y z : R, x[*] (y[+]z) [=] x[*]y[+]x[*]z. Proof dist R. Hint Resolve ring_dist_unfolded: algebra. Lemma ring_distl_unfolded : forall x y z : R, (y[+]z) [*]x [=] y[*]x[+]z[*]x. Proof. intros x y z. astepl (x[*] (y[+]z)). astepl (x[*]y[+]x[*]z). astepl (y[*]x[+]x[*]z). Step_final (y[*]x[+]z[*]x). Qed. End Ring_unfolded. #[global] Hint Resolve mult_assoc_unfolded: algebra. #[global] Hint Resolve ring_non_triv mult_one one_mult mult_commut_unfolded: algebra. #[global] Hint Resolve ring_dist_unfolded ring_distl_unfolded: algebra. Section Ring_basics. (** ** Ring basics %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. Lemma one_ap_zero : ([1]:R) [#] [0]. Proof ring_non_triv R. Definition is_zero_rht S (op : CSetoid_bin_op S) Zero : Prop := forall x, op x Zero [=] Zero. Definition is_zero_lft S (op : CSetoid_bin_op S) Zero : Prop := forall x, op Zero x [=] Zero. Arguments is_zero_rht [S]. Arguments is_zero_lft [S]. Lemma cring_mult_zero : forall x : R, x[*][0] [=] [0]. Proof. intro x. apply cg_cancel_lft with (x[*][0]). astepr (x[*][0]). Step_final (x[*] ([0][+][0])). Qed. Hint Resolve cring_mult_zero: algebra. Lemma x_mult_zero : forall x y : R, y [=] [0] -> x[*]y [=] [0]. Proof. intros x y H; Step_final (x[*][0]). Qed. Lemma cring_mult_zero_op : forall x : R, [0][*]x [=] [0]. Proof. intro x; Step_final (x[*][0]). Qed. Hint Resolve cring_mult_zero_op: algebra. Lemma cring_inv_mult_lft : forall x y : R, x[*] [--]y [=] [--] (x[*]y). Proof. intros x y. apply cg_inv_unique. astepl (x[*] (y[+] [--]y)). Step_final (x[*][0]). Qed. Hint Resolve cring_inv_mult_lft: algebra. Lemma cring_inv_mult_rht : forall x y : R, [--]x[*]y [=] [--] (x[*]y). Proof. intros x y. astepl (y[*] [--]x). Step_final ( [--] (y[*]x)). Qed. Hint Resolve cring_inv_mult_rht: algebra. Lemma cring_mult_ap_zero :(forall x y : R, x[*]y [#] [0] -> x [#] [0]):CProp. Proof. intros x y H. elim (cs_bin_op_strext _ cr_mult x [0] y y). auto. intro contra; elim (ap_irreflexive _ _ contra). astepr ([0]:R). auto. Qed. Lemma cring_mult_ap_zero_op : (forall x y : R, x[*]y [#] [0] -> y [#] [0]) :CProp. Proof. intros x y H. apply cring_mult_ap_zero with x. astepl (x[*]y). auto. Qed. Lemma inv_mult_invol : forall x y : R, [--]x[*] [--]y [=] x[*]y. Proof. intros x y. astepl ( [--] (x[*] [--]y)). Step_final ( [--][--] (x[*]y)). Qed. Lemma ring_dist_minus : forall x y z : R, x[*] (y[-]z) [=] x[*]y[-]x[*]z. Proof. intros x y z. unfold cg_minus in |- *. Step_final (x[*]y[+]x[*] [--]z). Qed. Hint Resolve ring_dist_minus: algebra. Lemma ring_distl_minus : forall x y z : R, (y[-]z) [*]x [=] y[*]x[-]z[*]x. Proof. intros x y z. unfold cg_minus in |- *. Step_final (y[*]x[+] [--]z[*]x). Qed. Hint Resolve ring_distl_minus: algebra. Lemma mult_minus1 : forall x:R, [--][1] [*] x [=] [--]x. Proof. intro x. apply (cg_cancel_lft R x). astepr ([0]:R). astepl (([1][*]x)[+]([--][1][*]x)). astepl (([1][+][--][1])[*]x). Step_final ([0][*]x). Qed. Lemma ring_distr1 : forall a b1 b2:R, a [*] (b1[-]b2) [=] a[*]b1 [-] a[*]b2. Proof. intros a b1 b2. astepl (a[*](b1[+][--]b2)). astepl (a[*]b1 [+] a[*][--]b2). Step_final (a[*]b1 [+] [--](a[*]b2)). Qed. Lemma ring_distr2 : forall a1 a2 b:R, (a1[-]a2) [*] b [=] a1[*]b [-] a2[*]b. Proof. intros a1 a2 b. astepl ((a1[+][--]a2)[*]b). astepl (a1[*]b [+] [--]a2[*]b). Step_final (a1[*]b [+] [--](a2[*]b)). Qed. End Ring_basics. #[global] Hint Resolve cring_mult_zero cring_mult_zero_op: algebra. #[global] Hint Resolve inv_mult_invol: algebra. #[global] Hint Resolve cring_inv_mult_lft cring_inv_mult_rht: algebra. #[global] Hint Resolve ring_dist_minus: algebra. #[global] Hint Resolve ring_distl_minus: algebra. #[global] Hint Resolve mult_minus1 ring_distr1 ring_distr2: algebra. (* Begin_SpecReals *) (** ** Ring Definitions Some auxiliary functions and operations over a ring; especially geared towards CReals. *) Section exponentiation. (** *** Exponentiation %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. (* End_SpecReals *) Fixpoint nexp (m : nat) : R -> R := match m with | O => fun _ : R => [1] | S n => fun x : R => nexp n x[*]x end. Lemma nexp_well_def : forall n, fun_wd (nexp n). intro n; induction n as [| n Hrecn]; red in |- *; intros; simpl in |- *; algebra. Qed. Lemma nexp_strong_ext : forall n, fun_strext (nexp n). intro n; red in |- *; induction n as [| n Hrecn]; simpl in |- *; intros x y H. Proof. elim (ap_irreflexive _ _ H). elim (cs_bin_op_strext _ cr_mult _ _ _ _ H); auto. Qed. Definition nexp_op n := Build_CSetoid_un_op R (nexp n) (nexp_strong_ext n). (* Begin_SpecReals *) End exponentiation. (* End_SpecReals *) Notation "x [^] n" := (nexp_op _ n x) (at level 20). Arguments nexp_op [R]. (* Begin_SpecReals *) Section nat_injection. (** *** The injection of natural numbers into a ring %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. (** The injection of Coq natural numbers into a ring is called [nring]. Note that this need not really be an injection; when it is, the ring is said to have characteristic [0]. *) Fixpoint nring (m : nat) : R := match m with | O => [0] | S n => nring n[+][1] end. Definition Char0 := forall n : nat, 0 < n -> nring n [#] [0]. (* End_SpecReals *) Lemma nring_comm_plus : forall n m, nring (n + m) [=] nring n[+]nring m. Proof. intros n m; induction n as [| n Hrecn]; simpl in |- *. algebra. astepr (nring n[+] ([1][+]nring m)). astepr (nring n[+] (nring m[+][1])). Step_final (nring n[+]nring m[+][1]). Qed. Lemma nring_comm_mult : forall n m, nring (n * m) [=] nring n[*]nring m. Proof. intros n m; induction n as [| n Hrecn]; simpl in |- *. algebra. apply eq_transitive_unfolded with (nring m[+]nring (n * m)). apply (nring_comm_plus m (n * m)). astepr (nring n[*]nring m[+][1][*]nring m). astepr (nring n[*]nring m[+]nring m). Step_final (nring m[+]nring n[*]nring m). Qed. End nat_injection. #[global] Hint Resolve nring_comm_plus nring_comm_mult: algebra. Arguments nring [R]. Notation Two := (nring 2). Notation Three := (nring 3). Notation Four := (nring 4). Notation Six := (nring 6). Notation Eight := (nring 8). Notation Twelve := (nring 12). Notation Sixteen := (nring 16). Notation Nine := (nring 9). Notation Eighteen := (nring 18). Notation TwentyFour := (nring 24). Notation FortyEight := (nring 48). Lemma one_plus_one : forall R : CRing, [1][+][1] [=] (Two:R). Proof. simpl in |- *; algebra. Qed. Lemma x_plus_x : forall (R : CRing) (x : R), x[+]x [=] Two[*]x. Proof. intros R x. astepl ([1][*]x[+][1][*]x). astepl (([1][+][1]) [*]x). simpl in |- *; algebra. Qed. #[global] Hint Resolve one_plus_one x_plus_x: algebra. (** In a ring of characteristic zero, [nring] is really an injection. *) Lemma nring_different : forall R, Char0 R -> forall i j, i <> j -> nring i [#] (nring j:R). Proof. intros R H i j H0. elim (Cnat_total_order i j); intros. replace j with (i + (j - i)). astepr (nring i[+]nring (j - i):R). astepl (nring i[+][0]:R). apply op_lft_resp_ap. apply ap_symmetric_unfolded. apply H. lia. auto with arith. replace i with (j + (i - j)). astepl (nring j[+]nring (i - j):R). astepr (nring j[+] ([0]:R)). apply op_lft_resp_ap. apply H. lia. auto with arith. auto. Qed. Section int_injection. (** *** The injection of integers into a ring %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. (** The injection of Coq integers into a ring is called [zring]. Again, this need not really be an injection. The first definition is now obsolete, having been replaced by a more efficient one. It is kept to avoid having to redo all the proofs. *) Definition zring_old k : R := caseZ_diff k (fun m n => nring m[-]nring n). Lemma zring_old_zero : zring_old 0 [=] [0]. Proof. simpl in |- *; algebra. Qed. Hint Resolve zring_old_zero: algebra. Lemma zring_old_diff : forall m n : nat, zring_old (m - n) [=] nring m[-]nring n. Proof. unfold zring_old in |- *. intros m n. apply proper_caseZ_diff_CS with (f := fun m0 n0 : nat => nring (R:=R) m0[-]nring n0). clear m n. intros m n p q H. apply cg_cancel_lft with (nring n:R). unfold cg_minus in |- *. astepl (nring (R:=R) n[+] ( [--] (nring n) [+]nring m)). astepl (nring (R:=R) n[+] [--] (nring n) [+]nring m). astepl ([0][+]nring (R:=R) m). astepl (nring (R:=R) m). apply cg_cancel_rht with (nring q:R). astepr (nring (R:=R) n[+] (nring p[+] [--] (nring q) [+]nring q)). astepr (nring (R:=R) n[+] (nring p[+] ( [--] (nring q) [+]nring q))). astepr (nring (R:=R) n[+] (nring p[+][0])). astepr (nring (R:=R) n[+]nring p). astepr (nring (R:=R) (n + p)). astepl (nring (R:=R) (m + q)). rewrite H. algebra. Qed. Hint Resolve zring_old_diff. Lemma zring_old_plus_nat : forall n : nat, zring_old n [=] nring n. Proof. intro n. replace (n:Z) with (n - 0%nat)%Z. astepl (nring (R:=R) n[-]nring 0). simpl in |- *; algebra. simpl in |- *; auto with zarith. Qed. Hint Resolve zring_old_plus_nat: algebra. Lemma zring_old_inv_nat : forall n : nat, zring_old (- n) [=] [--] (nring n). Proof. intro n. replace (- n)%Z with (0%nat - n)%Z. astepl (nring 0[-]nring (R:=R) n). simpl in |- *; algebra. simpl in |- *; auto. Qed. Hint Resolve zring_old_inv_nat: algebra. Lemma zring_old_plus : forall i j, zring_old (i + j) [=] zring_old i[+]zring_old j. Proof. intros i j. pattern i in |- *. apply diff_Z_ind. intros m n. pattern j in |- *. apply diff_Z_ind. intros m0 n0. Hint Resolve zring_old_diff: algebra. replace (m - n + (m0 - n0))%Z with ((m + m0)%nat - (n + n0)%nat)%Z. astepl (nring (m + m0) [-]nring (n + n0):R). astepl (nring m[+]nring m0[-] (nring n[+]nring n0):R). astepr (nring m[-]nring n[+] (nring m0[-]nring n0):R). unfold cg_minus in |- *. astepl (nring m[+] (nring m0[+] [--] (nring n[+]nring n0)):R). astepr (nring m[+] ( [--] (nring n) [+] (nring m0[+] [--] (nring n0))):R). apply bin_op_wd_unfolded. algebra. astepl (nring m0[+] ( [--] (nring n) [+] [--] (nring n0)):R). astepl (nring m0[+] [--] (nring n) [+] [--] (nring n0):R). Step_final ( [--] (nring n) [+]nring m0[+] [--] (nring n0):R). repeat rewrite Znat.inj_plus. auto with zarith. Qed. Hint Resolve zring_old_plus: algebra. Lemma zring_old_inv : forall i, zring_old (- i) [=] [--] (zring_old i). Proof. intro i. pattern i in |- *. apply diff_Z_ind. intros m n. replace (- (m - n))%Z with (n - m)%Z. astepl (nring (R:=R) n[-]nring m). astepr ( [--] (nring (R:=R) m[-]nring n)). unfold cg_minus in |- *. astepr ( [--] (nring m) [+] [--][--] (nring (R:=R) n)). Step_final ( [--] (nring (R:=R) m) [+]nring n). auto with zarith. Qed. Hint Resolve zring_old_inv: algebra. Lemma zring_old_minus : forall i j, zring_old (i - j) [=] zring_old i[-]zring_old j. Proof. intros i j. unfold cg_minus in |- *. replace (i - j)%Z with (i + - j)%Z. Step_final (zring_old i[+]zring_old (- j)). auto. Qed. Hint Resolve zring_old_minus: algebra. Lemma zring_old_mult : forall i j, zring_old (i * j) [=] zring_old i[*]zring_old j. Proof. intros i j. pattern i in |- *. apply diff_Z_ind. intros m n. pattern j in |- *. apply diff_Z_ind. intros m0 n0. astepr ((nring (R:=R) m[-]nring n) [*] (nring m0[-]nring n0)). replace ((m - n) * (m0 - n0))%Z with ((m * m0 + n * n0)%nat - (n * m0 + m * n0)%nat)%Z. 2: repeat rewrite Znat.inj_plus. 2: repeat rewrite Znat.inj_mult. 2: repeat rewrite BinInt.Zmult_minus_distr_r. 2: repeat rewrite CornBasics.Zmult_minus_distr_r. 2: auto with zarith. astepl (nring (R:=R) (m * m0 + n * n0) [-]nring (n * m0 + m * n0)). astepl (nring (R:=R) (m * m0) [+]nring (n * n0) [-] (nring (n * m0) [+]nring (m * n0))). astepl (nring (R:=R) m[*]nring m0[+]nring n[*]nring n0[-] (nring n[*]nring m0[+]nring m[*]nring n0)). astepr (nring (R:=R) m[*] (nring m0[-]nring n0) [-]nring n[*] (nring m0[-]nring n0)). astepr (nring (R:=R) m[*]nring m0[-]nring m[*]nring n0[-] (nring n[*]nring m0[-]nring n[*]nring n0)). unfold cg_minus in |- *. astepr (nring (R:=R) m[*]nring m0[+] ( [--] (nring m[*]nring n0) [+] [--] (nring n[*]nring m0[+] [--] (nring n[*]nring n0)))). astepl (nring (R:=R) m[*]nring m0[+] (nring n[*]nring n0[+] [--] (nring n[*]nring m0[+]nring m[*]nring n0))). apply bin_op_wd_unfolded. algebra. astepl (nring (R:=R) n[*]nring n0[+] ( [--] (nring n[*]nring m0) [+] [--] (nring m[*]nring n0))). astepr ( [--] (nring (R:=R) m[*]nring n0) [+] ( [--] (nring n[*]nring m0) [+] [--][--] (nring n[*]nring n0))). astepr ( [--] (nring (R:=R) m[*]nring n0) [+] ( [--] (nring n[*]nring m0) [+]nring n[*]nring n0)). astepr ( [--] (nring (R:=R) m[*]nring n0) [+] (nring n[*]nring n0[+] [--] (nring n[*]nring m0))). astepr ( [--] (nring (R:=R) m[*]nring n0) [+]nring n[*]nring n0[+] [--] (nring n[*]nring m0)). astepr (nring (R:=R) n[*]nring n0[+] [--] (nring m[*]nring n0) [+] [--] (nring n[*]nring m0)). Step_final (nring (R:=R) n[*]nring n0[+] ( [--] (nring m[*]nring n0) [+] [--] (nring n[*]nring m0))). Qed. Hint Resolve zring_old_mult: algebra. Lemma zring_old_one : zring_old 1 [=] [1]. Proof. simpl in |- *. Step_final ([1][-][0]:R). Qed. Hint Resolve zring_old_one: algebra. Lemma zring_old_inv_one : forall x, zring_old (-1) [*]x [=] [--]x. Proof. intro x. simpl in |- *. astepl ( [--] ([0][+][1]) [*]x). astepl ( [--][1][*]x). Step_final ( [--] ([1][*]x)). Qed. (*---------------- new def of zring. --------------------*) (** The [zring] function can be defined directly. This is done here. *) Fixpoint pring_aux (p : positive) (pow2 : R) {struct p} : R := match p with | xH => pow2 | xO p => pring_aux p (Two[*]pow2) | xI p => pow2[+]pring_aux p (Two[*]pow2) end. Definition pring (p : positive) : R := pring_aux p [1]. Definition zring (z : Z) : R := match z with | Z0 => [0] | Zpos p => pring p | Zneg p => [--] (pring p) end. Lemma pring_aux_lemma : forall p r r', r [=] r' -> pring_aux p r [=] pring_aux p r'. Proof. simple induction p; simpl in |- *; algebra. Qed. Lemma double_nring : forall n, Two[*]nring (R:=R) n [=] nring (R:=R) (n + n). Proof. intros. Step_final (nring (R:=R) n[+]nring n). Qed. Hint Resolve pring_aux_lemma double_nring: algebra. Lemma pring_aux_nring : forall p n, pring_aux p (nring n) [=] nring (Pmult_nat p n). Proof. simple induction p; simpl in |- *; intros. astepl (nring n[+]pring_aux p0 (nring (n + n))). Step_final (nring (R:=R) n[+]nring (R:=R) (Pmult_nat p0 (n + n))). Step_final (pring_aux p0 (nring (n + n))). algebra. Qed. Hint Resolve pring_aux_nring: algebra. Lemma pring_convert : forall p, pring p [=] nring (nat_of_P p). Proof. intros; unfold pring, nat_of_P in |- *; simpl in |- *. astepr (pring_aux p (nring 1)). simpl in |- *; algebra. Qed. Hint Resolve pring_convert: algebra. Lemma zring_zring_old : forall z : Z, zring z [=] zring_old z. Proof. simple induction z; simpl in |- *; intros. algebra. astepr (nring (R:=R) (nat_of_P p)). algebra. astepr ( [--] (nring (R:=R) (nat_of_P p))). algebra. Qed. Hint Resolve zring_zring_old: algebra. Lemma zring_zero : zring 0 [=] [0]. Proof. simpl in |- *; algebra. Qed. Lemma zring_diff : forall m n : nat, zring (m - n) [=] nring m[-]nring n. Proof. intros; Step_final (zring_old (m - n)). Qed. Lemma zring_plus_nat : forall n : nat, zring n [=] nring n. Proof. intro n; Step_final (zring_old n). Qed. Lemma zring_inv_nat : forall n : nat, zring (- n) [=] [--] (nring n). Proof. intro n; Step_final (zring_old (- n)). Qed. Lemma zring_plus : forall i j, zring (i + j) [=] zring i[+]zring j. Proof. intros. astepl (zring_old (i + j)). Step_final (zring_old i[+]zring_old j). Qed. Lemma zring_inv : forall i, zring (- i) [=] [--] (zring i). Proof. intro i. astepl (zring_old (- i)). Step_final ( [--] (zring_old i)). Qed. Lemma zring_minus : forall i j, zring (i - j) [=] zring i[-]zring j. Proof. intros i j. astepl (zring_old (i - j)). Step_final (zring_old i[-]zring_old j). Qed. Lemma zring_mult : forall i j, zring (i * j) [=] zring i[*]zring j. Proof. intros i j. astepl (zring_old (i * j)). Step_final (zring_old i[*]zring_old j). Qed. Lemma zring_one : zring 1 [=] [1]. Proof. simpl in |- *. unfold pring in |- *. algebra. Qed. Lemma zring_inv_one : forall x, zring (-1) [*]x [=] [--]x. Proof. intro x. simpl in |- *. unfold pring in |- *. simpl in |- *. Step_final ( [--] ([1][*]x)). Qed. End int_injection. Arguments zring [R]. #[global] Hint Resolve pring_convert zring_zero zring_diff zring_plus_nat zring_inv_nat zring_plus zring_inv zring_minus zring_mult zring_one zring_inv_one: algebra. Section Ring_sums. (** ** Ring sums %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. (** *** Infinite Ring sums *) Section infinite_ring_sums. Fixpoint Sum_upto (f : nat -> R) (n : nat) {struct n} : R := match n with | O => [0] | S x => f x[+]Sum_upto f x end. Lemma sum_upto_O : forall f : nat -> R, Sum_upto f 0 [=] [0]. Proof. algebra. Qed. Definition Sum_from_upto f m n : R := Sum_upto f n[-]Sum_upto f m. (** Here's an alternative def of [Sum_from_upto], with a lemma that it's equivalent to the original. *) Definition seq_from (f : nat -> R) (n i : nat) : R := f (n + i). Definition Sum_from_upto_alt f m n : R := Sum_upto (seq_from f m) (n - m). End infinite_ring_sums. Section ring_sums_over_lists. (** *** Ring Sums over Lists *) Fixpoint RList_Mem (l : list R) (n : nat) {struct n} : R := match l, n with | nil, _ => [0] | cons a _, O => a | cons _ k, S y => RList_Mem k y end. Fixpoint List_Sum_upto (l : list R) (n : nat) {struct n} : R := match n with | O => [0] | S x => RList_Mem l x[+]List_Sum_upto l x end. Lemma list_sum_upto_O : forall l : list R, List_Sum_upto l 0 [=] [0]. Proof. algebra. Qed. Definition List_Sum_from_upto l m n := List_Sum_upto l n[-]List_Sum_upto l m. End ring_sums_over_lists. End Ring_sums. (** ** Distribution properties %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Section Dist_properties. Variable R : CRing. Lemma dist_1b : forall x y z : R, (x[+]y) [*]z [=] x[*]z[+]y[*]z. Proof. intros x y z. astepl (z[*] (x[+]y)). Step_final (z[*]x[+]z[*]y). Qed. Hint Resolve dist_1b: algebra. Lemma dist_2a : forall x y z : R, z[*] (x[-]y) [=] z[*]x[-]z[*]y. Proof. intros x y z. astepl (z[*] (x[+] [--]y)). astepl (z[*]x[+]z[*] [--]y). Step_final (z[*]x[+] [--] (z[*]y)). Qed. Hint Resolve dist_2a: algebra. Lemma dist_2b : forall x y z : R, (x[-]y) [*]z [=] x[*]z[-]y[*]z. Proof. intros x y z. astepl (z[*] (x[-]y)). Step_final (z[*]x[-]z[*]y). Qed. Hint Resolve dist_2b: algebra. Lemma mult_distr_sum0_lft : forall (f : nat -> R) x n, Sum0 n (fun i => x[*]f i) [=] x[*]Sum0 n f. Proof. intros f x n. induction n as [| n Hrecn]. simpl in |- *; algebra. simpl in |- *. Step_final (x[*]Sum0 n f[+]x[*]f n). Qed. Hint Resolve mult_distr_sum0_lft. Lemma mult_distr_sum_lft : forall (f : nat -> R) x m n, Sum m n (fun i => x[*]f i) [=] x[*]Sum m n f. Proof. intros f x m n. unfold Sum in |- *. unfold Sum1 in |- *. Step_final (x[*]Sum0 (S n) f[-]x[*]Sum0 m f). Qed. Hint Resolve mult_distr_sum_lft: algebra. Lemma mult_distr_sum_rht : forall (f : nat -> R) x m n, Sum m n (fun i => f i[*]x) [=] Sum m n f[*]x. Proof. intros f x m n. astepl (Sum m n (fun i : nat => x[*]f i)). Step_final (x[*]Sum m n f). Qed. Lemma sumx_const : forall n (x : R), Sumx (fun i (_ : i < n) => x) [=] nring n[*]x. Proof. intros n x; induction n as [| n Hrecn]. simpl in |- *; algebra. simpl in |- *. astepr (nring n[*]x[+][1][*]x). Step_final (nring n[*]x[+]x). Qed. End Dist_properties. #[global] Hint Resolve dist_1b dist_2a dist_2b mult_distr_sum_lft mult_distr_sum_rht sumx_const: algebra. (** ** Properties of exponentiation (with the exponent in [nat]) %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Section NExp_properties. Variable R : CRing. Lemma nexp_wd : forall (x y : R) n, x [=] y -> x[^]n [=] y[^]n. Proof. algebra. Qed. Lemma nexp_strext : forall (x y : R) n, x[^]n [#] y[^]n -> x [#] y. Proof. intros x y n H. exact (un_op_strext_unfolded _ _ _ _ H). Qed. Lemma nexp_Sn : forall (x : R) n, x[*]x[^]n [=] x[^]S n. Proof. intros x n. Step_final (x[^]n[*]x). Qed. Hint Resolve nexp_wd nexp_Sn: algebra. Lemma nexp_plus : forall (x : R) m n, x[^]m[*]x[^]n [=] x[^] (m + n). Proof. intros x m n. induction m as [| m Hrecm]. rewrite plus_O_n. Step_final ([1][*]x[^]n). rewrite plus_Sn_m. astepl (x[^]m[*]x[*]x[^]n). astepl (x[*]x[^]m[*]x[^]n). astepl (x[*] (x[^]m[*]x[^]n)). Step_final (x[*]x[^] (m + n)). Qed. Hint Resolve nexp_plus: algebra. Lemma one_nexp : forall n : nat, ([1]:R) [^]n [=] [1]. Proof. intro n. induction n as [| n Hrecn]. algebra. astepl (([1]:R) [*][1][^]n). Step_final (([1]:R) [*][1]). Qed. Hint Resolve one_nexp: algebra. Lemma mult_nexp : forall (x y : R) n, (x[*]y) [^]n [=] x[^]n[*]y[^]n. Proof. intros x y n. induction n as [| n Hrecn]. astepl ([1]:R). Step_final (([1]:R) [*][1]). astepl (x[*]y[*] (x[*]y) [^]n). astepl (x[*]y[*] (x[^]n[*]y[^]n)). astepl (x[*] (y[*] (x[^]n[*]y[^]n))). astepl (x[*] (y[*]x[^]n[*]y[^]n)). astepl (x[*] (x[^]n[*]y[*]y[^]n)). astepl (x[*] (x[^]n[*] (y[*]y[^]n))). Step_final (x[*]x[^]n[*] (y[*]y[^]n)). Qed. Hint Resolve mult_nexp: algebra. Lemma nexp_mult : forall (x : R) m n, (x[^]m) [^]n [=] x[^] (m * n). Proof. intros x m n. induction m as [| m Hrecm]. simpl in |- *. Step_final (([1]:R) [^]n). astepl ((x[*]x[^]m) [^]n). astepl (x[^]n[*] (x[^]m) [^]n). astepl (x[^]n[*]x[^] (m * n)). astepl (x[^] (n + m * n)). replace (n + m * n) with (S m * n); algebra. Qed. Hint Resolve nexp_mult: algebra. Lemma zero_nexp : forall n, 0 < n -> ([0]:R) [^]n [=] [0]. Proof. intros n H. induction n as [| n Hrecn]. inversion H. Step_final (([0]:R) [*][0][^]n). Qed. Hint Resolve zero_nexp: algebra. Lemma inv_nexp_even : forall (x : R) n, Nat.Even n -> [--]x[^]n [=] x[^]n. Proof. intros x n [k H]. replace (2 * k) with (k + k) in H by lia; rewrite H. astepl ( [--]x[^](k)[*] [--]x[^](k)). astepl (( [--]x[*] [--]x) [^](k)). astepl ((x[*]x) [^](k)). Step_final (x[^](k)[*]x[^](k)). Qed. Hint Resolve inv_nexp_even: algebra. Lemma inv_nexp_two : forall x : R, [--]x[^]2 [=] x[^]2. Proof. intro x. now apply inv_nexp_even; exists 1. Qed. Hint Resolve inv_nexp_two: algebra. Lemma inv_nexp_odd : forall (x : R) n, Nat.Odd n -> [--]x[^]n [=] [--] (x[^]n). Proof. intros x [| n] H; [apply Nat.odd_spec in H; discriminate H |]. apply Nat.Odd_succ in H. astepl ( [--]x[*] [--]x[^]n). astepl ( [--]x[*]x[^]n). Step_final ( [--] (x[*]x[^]n)). Qed. Hint Resolve inv_nexp_odd: algebra. Lemma nexp_one : forall x : R, x[^]1 [=] x. Proof. intro x. Step_final ([1][*]x). Qed. Hint Resolve nexp_one: algebra. Lemma nexp_two : forall x : R, x[^]2 [=] x[*]x. Proof. intro x. replace 2 with (1 + 1). Step_final (x[^]1[*]x[^]1). auto with arith. Qed. Hint Resolve nexp_two: algebra. Lemma inv_one_even_nexp : forall n : nat, Nat.Even n -> [--][1][^]n [=] ([1]:R). Proof. intros n H. Step_final (([1]:R) [^]n). Qed. Hint Resolve inv_one_even_nexp: algebra. Lemma inv_one_odd_nexp : forall n : nat, Nat.Odd n -> [--][1][^]n [=] [--] ([1]:R). Proof. intros n H. Step_final ( [--] (([1]:R) [^]n)). Qed. Hint Resolve inv_one_odd_nexp: algebra. Lemma square_plus : forall x y : R, (x[+]y) [^]2 [=] x[^]2[+]y[^]2[+]Two[*]x[*]y. Proof. intros x y. astepl ((x[+]y) [*] (x[+]y)). astepl (x[*] (x[+]y) [+]y[*] (x[+]y)). astepl (x[*]x[+]x[*]y[+] (y[*]x[+]y[*]y)). astepl (x[^]2[+]x[*]y[+] (x[*]y[+]y[^]2)). astepl (x[^]2[+]x[*]y[+]x[*]y[+]y[^]2). astepl (x[^]2[+] (x[*]y[+]x[*]y) [+]y[^]2). astepl (x[^]2[+]Two[*] (x[*]y) [+]y[^]2). astepl (x[^]2[+]Two[*]x[*]y[+]y[^]2). astepl (x[^]2[+] (Two[*]x[*]y[+]y[^]2)). Step_final (x[^]2[+] (y[^]2[+]Two[*]x[*]y)). Qed. Lemma square_minus : forall x y : R, (x[-]y) [^]2 [=] x[^]2[+]y[^]2[-]Two[*]x[*]y. Proof. intros x y. unfold cg_minus in |- *. eapply eq_transitive_unfolded. apply square_plus. algebra. Qed. Lemma nexp_funny : forall x y : R, (x[+]y) [*] (x[-]y) [=] x[^]2[-]y[^]2. Proof. intros x y. astepl (x[*] (x[-]y) [+]y[*] (x[-]y)). astepl (x[*]x[-]x[*]y[+] (y[*]x[-]y[*]y)). astepl (x[*]x[+] [--] (x[*]y) [+] (y[*]x[+] [--] (y[*]y))). astepl (x[*]x[+] [--] (x[*]y) [+]y[*]x[+] [--] (y[*]y)). astepl (x[*]x[+] ( [--] (x[*]y) [+]y[*]x) [+] [--] (y[*]y)). astepl (x[*]x[+] ( [--] (x[*]y) [+]x[*]y) [+] [--] (y[*]y)). astepl (x[*]x[+][0][+] [--] (y[*]y)). astepl (x[*]x[+] [--] (y[*]y)). Step_final (x[*]x[-]y[*]y). Qed. Hint Resolve nexp_funny: algebra. Lemma nexp_funny' : forall x y : R, (x[-]y) [*] (x[+]y) [=] x[^]2[-]y[^]2. Proof. intros x y. Step_final ((x[+]y) [*] (x[-]y)). Qed. Hint Resolve nexp_funny': algebra. End NExp_properties. Add Parametric Morphism c n : (nexp c n) with signature (@cs_eq (cr_crr c)) ==> (@cs_eq c) as nexp_morph_wd. Proof. intros. apply: nexp_wd. assumption. Qed. #[global] Hint Resolve nexp_wd nexp_Sn nexp_plus one_nexp mult_nexp nexp_mult zero_nexp inv_nexp_even inv_nexp_two inv_nexp_odd nexp_one nexp_two nexp_funny inv_one_even_nexp inv_one_odd_nexp nexp_funny' one_nexp square_plus square_minus: algebra. Section CRing_Ops. (** ** Functional Operations Now for partial functions. %\begin{convention}% Let [R] be a ring and let [F,G:(PartFunct R)] with predicates respectively [P] and [Q]. %\end{convention}% *) Variable R : CRing. Variables F G : PartFunct R. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Section Part_Function_Mult. Lemma part_function_mult_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y), F x (Prj1 Hx) [*]G x (Prj2 Hx) [#] F y (Prj1 Hy) [*]G y (Prj2 Hy) -> x [#] y. Proof. intros x y Hx Hy H. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); intro H1; exact (pfstrx _ _ _ _ _ _ H1). Qed. Definition Fmult := Build_PartFunct R _ (conj_wd (dom_wd _ F) (dom_wd _ G)) (fun x Hx => F x (Prj1 Hx) [*]G x (Prj2 Hx)) part_function_mult_strext. End Part_Function_Mult. Section Part_Function_Nth_Power. Variable n : nat. Lemma part_function_nth_strext : forall x y Hx Hy, F x Hx[^]n [#] F y Hy[^]n -> x [#] y. Proof. intros x y Hx Hy H. apply pfstrx with F Hx Hy. apply nexp_strext with n; assumption. Qed. Definition Fnth := Build_PartFunct R _ (dom_wd R F) (fun x Hx => F x Hx[^]n) part_function_nth_strext. End Part_Function_Nth_Power. (** %\begin{convention}% Let [R':R->CProp]. %\end{convention}% *) Variable R':R -> CProp. Lemma included_FMult : included R' P -> included R' Q -> included R' (Dom Fmult). Proof. intros; simpl in |- *; apply included_conj; assumption. Qed. Lemma included_FMult' : included R' (Dom Fmult) -> included R' P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. Lemma included_FMult'' : included R' (Dom Fmult) -> included R' Q. Proof. intro H; simpl in H; eapply included_conj_rht; apply H. Qed. Variable n:nat. Lemma included_FNth : included R' P -> forall n, included R' (Dom (Fnth n)). Proof. auto. Qed. Lemma included_FNth' : forall n, included R' (Dom (Fnth n)) -> included R' (Dom F). Proof. auto. Qed. End CRing_Ops. Definition Fscalmult (R:CRing) alpha F := Fmult R [-C-]alpha F. Arguments Fmult [R]. Infix "{*}" := Fmult (at level 40, left associativity). Arguments Fscalmult [R]. Infix "{**}" := Fscalmult (at level 40, left associativity). Arguments Fnth [R]. Infix "{^}" := Fnth (at level 30, right associativity). Section ScalarMultiplication. Variable R : CRing. Variable F : PartFunct R. (* begin hide *) Let P := Dom F. (* end hide *) Variable R':R -> CProp. Lemma included_FScalMult : included R' P -> forall c, included R' (Dom (c{**}F)). Proof. intros; simpl in |- *; apply included_conj. red in |- *; intros; auto. assumption. Qed. Lemma included_FScalMult' : forall c, included R' (Dom (c{**}F)) -> included R' P. Proof. intros c H; simpl in H; eapply included_conj_rht; apply H. Qed. End ScalarMultiplication. Section cr_Product. Context {R: CRing}. Definition cr_Product: list R -> R := @cm_Sum (Build_multCAbMonoid R). Lemma cr_Product_ones (l: list R): (forall x, In x l -> x [=] [1]) -> cr_Product l [=] [1]. Proof. apply (@cm_Sum_units (Build_multCMonoid R)). Qed. Lemma cr_Product_0 (z: R) (zE: z [=] [0]): forall l, In z l -> cr_Product l [=] [0]. Proof with auto. induction l. simpl. intuition. intros [?|?]; simpl. subst. rewrite zE. apply cring_mult_zero_op. rewrite IHl... apply cring_mult_zero. Qed. Global Instance cr_Product_Proper: Proper (SetoidPermutation (@st_eq R) ==> @st_eq R) cr_Product. Proof. apply ( @cm_Sum_AbMonoid_Proper (Build_multCAbMonoid R)). Qed. (* For convenience, we also make a weaker instance for Permutation: *) Global Instance: Proper (@Permutation R ==> @st_eq R) cr_Product. Proof. repeat intro. apply cr_Product_Proper. apply SetoidPermutation_from_Permutation. apply _. assumption. Qed. End cr_Product. #[global] Hint Resolve included_FMult included_FScalMult included_FNth : included. #[global] Hint Immediate included_FMult' included_FMult'' included_FScalMult' included_FNth' : included. corn-8.20.0/algebra/CSemiGroups.v000066400000000000000000000206761473720167500165550ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [+] %\ensuremath+% #+# *) (** printing {+} %\ensuremath+% #+# *) Require Export CoRN.algebra.CSetoidInc. (* Begin_SpecReals *) (** * Semigroups ** Definition of the notion of semigroup *) Definition is_CSemiGroup A (op : CSetoid_bin_op A) := associative op. Record CSemiGroup : Type := {csg_crr :> CSetoid; csg_op : CSetoid_bin_op csg_crr; csg_proof : is_CSemiGroup csg_crr csg_op}. (** %\begin{nameconvention}% In the %{\em %names%}% of lemmas, we will denote [[+]] with [plus]. %\end{nameconvention}% *) Arguments csg_op {c}. Infix "[+]" := csg_op (at level 50, left associativity). (* End_SpecReals *) (** ** Semigroup axioms The axiomatic properties of a semi group. %\begin{convention}% Let [G] be a semi-group. %\end{convention}% *) Section CSemiGroup_axioms. Variable G : CSemiGroup. Lemma CSemiGroup_is_CSemiGroup : is_CSemiGroup G csg_op. Proof. elim G; auto. Qed. Lemma plus_assoc : associative (csg_op (c:=G)). Proof. exact CSemiGroup_is_CSemiGroup. Qed. End CSemiGroup_axioms. (* Begin_SpecReals *) (** ** Semigroup basics %\begin{convention}% Let [G] be a semi-group. %\end{convention}% *) Section CSemiGroup_basics. Variable G : CSemiGroup. (* End_SpecReals *) Lemma plus_assoc_unfolded : forall (G : CSemiGroup) (x y z : G), x[+] (y[+]z) [=] x[+]y[+]z. Proof. exact plus_assoc. Qed. End CSemiGroup_basics. Section p71R1. (** ** Morphism %\begin{convention}% Let [S1 S2:CSemiGroup]. %\end{convention}% *) Variable S1:CSemiGroup. Variable S2:CSemiGroup. Definition morphism_of_CSemiGroups (f:(CSetoid_fun S1 S2)):CProp:= forall (a b:S1), (f (a[+]b))[=] (f a)[+](f b). End p71R1. (** ** About the unit *) Definition is_rht_unit S (op : CSetoid_bin_op S) Zero : Prop := forall x, op x Zero [=] x. (* End_SpecReals *) Definition is_lft_unit S (op : CSetoid_bin_op S) Zero : Prop := forall x, op Zero x [=] x. Arguments is_lft_unit [S]. (* Begin_SpecReals *) Arguments is_rht_unit [S]. (** An alternative definition: *) Definition is_unit (S:CSemiGroup): S -> Prop := fun e => forall (a:S), e[+]a [=] a /\ a[+]e [=]a. Lemma cs_unique_unit : forall (S:CSemiGroup) (e f:S), (is_unit S e) /\ (is_unit S f) -> e[=]f. Proof. intros S e f. unfold is_unit. intros H. elim H. clear H. intros H0 H1. elim (H0 f). clear H0. intros H2 H3. elim (H1 e). clear H1. intros H4 H5. astepr (e[+]f). astepl (e[+]f). apply eq_reflexive. Qed. (* End_SpecReals *) #[global] Hint Resolve plus_assoc_unfolded: algebra. (** ** Functional operations We can also define a similar addition operator, which will be denoted by [{+}], on partial functions. %\begin{convention}% Whenever possible, we will denote the functional construction corresponding to an algebraic operation by the same symbol enclosed in curly braces. %\end{convention}% At this stage, we will always consider automorphisms; we %{\em %could%}% treat this in a more general setting, but we feel that it wouldn't really be a useful effort. %\begin{convention}% Let [G:CSemiGroup] and [F,F':(PartFunct G)] and denote by [P] and [Q], respectively, the predicates characterizing their domains. %\end{convention}% *) Section Part_Function_Plus. Variable G : CSemiGroup. Variables F F' : PartFunct G. (* begin hide *) Let P := Dom F. Let Q := Dom F'. (* end hide *) Lemma part_function_plus_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y), F x (Prj1 Hx) [+]F' x (Prj2 Hx) [#] F y (Prj1 Hy) [+]F' y (Prj2 Hy) -> x [#] y. Proof. intros x y Hx Hy H. case (cs_bin_op_strext _ _ _ _ _ _ H); intros H1; exact (pfstrx _ _ _ _ _ _ H1). Qed. Definition Fplus := Build_PartFunct G _ (conj_wd (dom_wd _ F) (dom_wd _ F')) (fun x Hx => F x (Prj1 Hx) [+]F' x (Prj2 Hx)) part_function_plus_strext. (** %\begin{convention}% Let [R:G->CProp]. %\end{convention}% *) Variable R : G -> CProp. Lemma included_FPlus : included R P -> included R Q -> included R (Dom Fplus). Proof. intros; simpl in |- *; apply included_conj; assumption. Qed. Lemma included_FPlus' : included R (Dom Fplus) -> included R P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. Lemma included_FPlus'' : included R (Dom Fplus) -> included R Q. Proof. intro H; simpl in H; eapply included_conj_rht; apply H. Qed. End Part_Function_Plus. Arguments Fplus [G]. Infix "{+}" := Fplus (at level 50, left associativity). #[global] Hint Resolve included_FPlus : included. #[global] Hint Immediate included_FPlus' included_FPlus'' : included. (** ** Subsemigroups %\begin{convention}% Let [csg] a semi-group and [P] a non-empty predicate on the semi-group which is preserved by [[+]]. %\end{convention}% *) Section SubCSemiGroups. Variable csg : CSemiGroup. Variable P : csg -> CProp. Variable op_pres_P : bin_op_pres_pred _ P csg_op. Let subcrr : CSetoid := Build_SubCSetoid _ P. Definition Build_SubCSemiGroup : CSemiGroup := Build_CSemiGroup subcrr (Build_SubCSetoid_bin_op _ _ _ op_pres_P) (restr_f_assoc _ _ _ op_pres_P (plus_assoc csg)). End SubCSemiGroups. Section D9S. (** ** Direct Product %\begin{convention}% Let [M1 M2:CSemiGroup] %\end{convention}% *) Variable M1 M2: CSemiGroup. Definition dprod (x:ProdCSetoid M1 M2)(y:ProdCSetoid M1 M2): (ProdCSetoid M1 M2):= let (x1, x2):= x in let (y1, y2):= y in (pairT (x1[+]y1) (x2 [+] y2)). Lemma dprod_strext:(bin_fun_strext (ProdCSetoid M1 M2)(ProdCSetoid M1 M2) (ProdCSetoid M1 M2)dprod). Proof. unfold bin_fun_strext. intros x1 x2 y1 y2. unfold dprod. case x1. intros a1 a2. case x2. intros b1 b2. case y1. intros c1 c2. case y2. intros d1 d2. simpl. intro H. elim H. clear H. intro H. cut (a1[#]b1 or c1[#]d1). intuition. set (H0:= (@csg_op M1)). unfold CSetoid_bin_op in H0. set (H1:= (@csbf_strext M1 M1 M1 H0)). unfold bin_fun_strext in H1. apply H1. exact H. clear H. intro H. cut (a2[#]b2 or c2[#]d2). intuition. set (H0:= (@csg_op M2)). unfold CSetoid_bin_op in H0. set (H1:= (@csbf_strext M2 M2 M2 H0)). unfold bin_fun_strext in H1. apply H1. exact H. Qed. Definition dprod_as_csb_fun: CSetoid_bin_fun (ProdCSetoid M1 M2) (ProdCSetoid M1 M2)(ProdCSetoid M1 M2):= (Build_CSetoid_bin_fun (ProdCSetoid M1 M2)(ProdCSetoid M1 M2) (ProdCSetoid M1 M2) dprod dprod_strext). Lemma direct_product_is_CSemiGroup: (is_CSemiGroup (ProdCSetoid M1 M2) dprod_as_csb_fun). Proof. unfold is_CSemiGroup. unfold associative. intros x y z. case x. intros x1 x2. case y. intros y1 y2. case z. intros z1 z2. simpl. split. apply CSemiGroup_is_CSemiGroup. apply CSemiGroup_is_CSemiGroup. Qed. Definition direct_product_as_CSemiGroup:= (Build_CSemiGroup (ProdCSetoid M1 M2) dprod_as_csb_fun direct_product_is_CSemiGroup). End D9S. (** ** The SemiGroup of Setoid functions *) Lemma FS_is_CSemiGroup: forall (X:CSetoid),(is_CSemiGroup (FS_as_CSetoid X X) (comp_as_bin_op X )). Proof. unfold is_CSemiGroup. exact assoc_comp. Qed. Definition FS_as_CSemiGroup (A : CSetoid) := Build_CSemiGroup (FS_as_CSetoid A A) (comp_as_bin_op A) (assoc_comp A). Section p66E2b4. (** ** The Free SemiGroup %\begin{convention}% Let [A:CSetoid]. %\end{convention}% *) Variable A:CSetoid. Lemma Astar_is_CSemiGroup: (is_CSemiGroup (free_csetoid_as_csetoid A) (app_as_csb_fun A)). Proof. unfold is_CSemiGroup. unfold associative. intros x. unfold app_as_csb_fun. simpl. induction x. simpl. intros x y. apply eq_fm_reflexive. simpl. intuition. Qed. Definition Astar_as_CSemiGroup:= (Build_CSemiGroup (free_csetoid_as_csetoid A) (app_as_csb_fun A) Astar_is_CSemiGroup). End p66E2b4. corn-8.20.0/algebra/CSetoidFun.v000066400000000000000000000651641473720167500163610ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CSetoids. (** ** The Setoid of Setoid functions The setoid functions form again a setoid. *) Definition ap_fun (A B : CSetoid) (f g : CSetoid_fun A B) := {a : A | f a[#]g a}. Definition eq_fun (A B : CSetoid) (f g : CSetoid_fun A B) := forall a : A, f a[=]g a. Lemma irrefl_apfun : forall A B : CSetoid, irreflexive (ap_fun A B). Proof. intros A B. unfold irreflexive in |- *. intros f. unfold ap_fun in |- *. red in |- *. intro H. elim H. intros a H0. set (H1 := ap_irreflexive B (f a)) in *. intuition. Qed. Lemma cotrans_apfun : forall A B : CSetoid, cotransitive (ap_fun A B). Proof. intros A B. unfold cotransitive in |- *. unfold ap_fun in |- *. intros f g H h. elim H. clear H. intros a H. set (H1 := ap_cotransitive B (f a) (g a) H (h a)) in *. elim H1. clear H1. intros H1. left. exists a. exact H1. clear H1. intro H1. right. exists a. exact H1. Qed. Lemma ta_apfun : forall A B : CSetoid, tight_apart (eq_fun A B) (ap_fun A B). Proof. unfold tight_apart in |- *. unfold ap_fun in |- *. unfold eq_fun in |- *. intros A B f g. split. intros H a. red in H. apply not_ap_imp_eq. red in |- *. intros H0. apply H. exists a. exact H0. intros H. red in |- *. intro H1. elim H1. intros a X. set (H2 := eq_imp_not_ap B (f a) (g a) (H a) X) in *. exact H2. Qed. Lemma sym_apfun : forall A B : CSetoid, Csymmetric (ap_fun A B). Proof. unfold Csymmetric in |- *. unfold ap_fun in |- *. intros A B f g H. elim H. clear H. intros a H. exists a. apply ap_symmetric. exact H. Qed. Definition FS_is_CSetoid (A B : CSetoid) := Build_is_CSetoid (CSetoid_fun A B) (eq_fun A B) (ap_fun A B) (irrefl_apfun A B) (sym_apfun A B) (cotrans_apfun A B) (ta_apfun A B). Definition FS_as_CSetoid (A B : CSetoid) := Build_CSetoid (CSetoid_fun A B) (eq_fun A B) (ap_fun A B) (FS_is_CSetoid A B). (** ** Nullary and n-ary operations *) Definition is_nullary_operation (S:CSetoid) (s:S):Prop := True. Fixpoint n_ary_operation (n:nat)(V:CSetoid){struct n}:CSetoid:= match n with |0 => V |(S m)=> (FS_as_CSetoid V (n_ary_operation m V)) end. Section unary_function_composition. (** ** Composition of Setoid functions Let [S1], [S2] and [S3] be setoids, [f] a setoid function from [S1] to [S2], and [g] from [S2] to [S3] in the following definition of composition. *) Variables S1 S2 S3 : CSetoid. Variable f : CSetoid_fun S1 S2. Variable g : CSetoid_fun S2 S3. Definition compose_CSetoid_fun : CSetoid_fun S1 S3. Proof. apply (Build_CSetoid_fun _ _ (fun x : S1 => g (f x))). (* str_ext *) unfold fun_strext in |- *; intros x y H. apply (csf_strext _ _ f). apply (csf_strext _ _ g). assumption. Defined. End unary_function_composition. (** *** Composition as operation *) Definition comp (A B C : CSetoid) : FS_as_CSetoid A B -> FS_as_CSetoid B C -> FS_as_CSetoid A C. Proof. intros f g. set (H := compose_CSetoid_fun A B C f g) in *. exact H. Defined. Definition comp_as_bin_op (A:CSetoid) : CSetoid_bin_op (FS_as_CSetoid A A). Proof. unfold CSetoid_bin_op in |- *. eapply Build_CSetoid_bin_fun with (comp A A A). unfold bin_fun_strext in |- *. unfold comp in |- *. intros f1 f2 g1 g2. simpl in |- *. unfold ap_fun in |- *. unfold compose_CSetoid_fun in |- *. simpl in |- *. elim f1. unfold fun_strext in |- *. clear f1. intros f1 Hf1. elim f2. unfold fun_strext in |- *. clear f2. intros f2 Hf2. elim g1. unfold fun_strext in |- *. clear g1. intros g1 Hg1. elim g2. unfold fun_strext in |- *. clear g2. intros g2 Hg2. simpl in |- *. intro H. elim H. clear H. intros a H. set (H0 := ap_cotransitive A (g1 (f1 a)) (g2 (f2 a)) H (g2 (f1 a))) in *. elim H0. clear H0. intro H0. right. exists (f1 a). exact H0. clear H0. intro H0. left. exists a. apply Hg2. exact H0. Defined. Lemma assoc_comp : forall A : CSetoid, associative (comp_as_bin_op A). Proof. unfold associative in |- *. unfold comp_as_bin_op in |- *. intros A f g h. simpl in |- *. unfold eq_fun in |- *. simpl in |- *. intuition. Qed. Section unary_and_binary_function_composition. Definition compose_CSetoid_bin_un_fun (A B C : CSetoid) (f : CSetoid_bin_fun B B C) (g : CSetoid_fun A B) : CSetoid_bin_fun A A C. Proof. apply (Build_CSetoid_bin_fun A A C (fun a0 a1 : A => f (g a0) (g a1))). intros x1 x2 y1 y2 H0. assert (H10:= csbf_strext B B C f). red in H10. assert (H40 := csf_strext A B g). red in H40. elim (H10 (g x1) (g x2) (g y1) (g y2) H0); [left | right]; auto. Defined. Definition compose_CSetoid_bin_fun A B C (f g : CSetoid_fun A B) (h : CSetoid_bin_fun B B C) : CSetoid_fun A C. Proof. apply (Build_CSetoid_fun A C (fun a : A => h (f a) (g a))). intros x y H. elim (csbf_strext _ _ _ _ _ _ _ _ H); apply csf_strext. Defined. Definition compose_CSetoid_un_bin_fun A B C (f : CSetoid_bin_fun B B C) (g : CSetoid_fun C A) : CSetoid_bin_fun B B A. Proof. apply Build_CSetoid_bin_fun with (fun x y : B => g (f x y)). intros x1 x2 y1 y2. case f. simpl in |- *. unfold bin_fun_strext in |- *. case g. simpl in |- *. unfold fun_strext in |- *. intros gu gstrext fu fstrext H. apply fstrext. apply gstrext. exact H. Defined. End unary_and_binary_function_composition. (** *** Projections *) Section function_projection. Lemma proj_bin_fun : forall A B C (f : CSetoid_bin_fun A B C) a, fun_strext (f a). Proof. intros A B C f a. red in |- *. elim f. intro fo. simpl. intros csbf_strext0 x y H. elim (csbf_strext0 _ _ _ _ H); intro H0. elim (ap_irreflexive _ _ H0). exact H0. Qed. Definition projected_bin_fun A B C (f : CSetoid_bin_fun A B C) (a : A) := Build_CSetoid_fun B C (f a) (proj_bin_fun A B C f a). End function_projection. Section BinProj. Variable S : CSetoid. Definition binproj1 (x y:S) := x. Lemma binproj1_strext : bin_fun_strext _ _ _ binproj1. Proof. red in |- *; auto. Qed. Definition cs_binproj1 : CSetoid_bin_op S. Proof. red in |- *; apply Build_CSetoid_bin_op with binproj1. apply binproj1_strext. Defined. End BinProj. (** ** Combining operations %\begin{convention}% Let [S1], [S2] and [S3] be setoids. %\end{convention}% *) Section CombiningOperations. Variables S1 S2 S3 : CSetoid. (** In the following definition, we assume [f] is a setoid function from [S1] to [S2], and [op] is an unary operation on [S2]. Then [opOnFun] is the composition [op] after [f]. *) Section CombiningUnaryOperations. Variable f : CSetoid_fun S1 S2. Variable op : CSetoid_un_op S2. Definition opOnFun : CSetoid_fun S1 S2. Proof. apply (Build_CSetoid_fun S1 S2 (fun x : S1 => op (f x))). (* str_ext *) unfold fun_strext in |- *; intros x y H. apply (csf_strext _ _ f x y). apply (csf_strext _ _ op _ _ H). Defined. End CombiningUnaryOperations. End CombiningOperations. Section p66E2b4. (** ** The Free Setoid %\begin{convention}% Let [A:CSetoid]. %\end{convention}% *) Variable A:CSetoid. Definition Astar := (list A). Definition empty_word := (@nil A). Definition appA:= (@app A). Fixpoint eq_fm (m:Astar)(k:Astar){struct m}:Prop:= match m with |nil => match k with |nil => True |cons a l => False end |cons b n => match k with |nil => False |cons a l => b[=]a /\ (eq_fm n l) end end. Fixpoint ap_fm (m:Astar)(k:Astar){struct m}: CProp := match m with |nil => match k with |nil => False |cons a l => True end |cons b n => match k with |nil => True |cons a l => b[#]a or (ap_fm n l) end end. Lemma ap_fm_irreflexive: (irreflexive ap_fm). Proof. unfold irreflexive. intro x. induction x. simpl. red. intuition. simpl. red. intro H. apply IHx. elim H. clear H. generalize (ap_irreflexive A a). unfold Not. intuition. intuition. Qed. Lemma ap_fm_symmetric: Csymmetric ap_fm. Proof. unfold Csymmetric. intros x. induction x. intro y. case y. simpl. intuition. simpl. intuition. simpl. intro y. case y. simpl. intuition. simpl. intros c l H0. elim H0. generalize (ap_symmetric A a c). intuition. clear H0. intro H0. right. apply IHx. exact H0. Qed. Lemma ap_fm_cotransitive : (cotransitive ap_fm). Proof. unfold cotransitive. intro x. induction x. simpl. intro y. case y. intuition. intros c l H z. case z. simpl. intuition. intuition. simpl. intro y. case y. intros H z. case z. intuition. simpl. intuition. intros c l H z. case z. intuition. simpl. intros c0 l0. elim H. clear H. intro H. generalize (ap_cotransitive A a c H c0). intuition. clear H. intro H. generalize (IHx l H l0). intuition. Qed. Lemma ap_fm_tight : (tight_apart eq_fm ap_fm). Proof. unfold tight_apart. intros x. induction x. simpl. intro y. case y. red. unfold Not. intuition. intuition. intro y. simpl. case y. intuition. intros c l. generalize (IHx l). red. intro H0. elim H0. intros H1 H2. split. intro H3. split. red in H3. generalize (ap_tight A a c). intuition. apply H1. intro H4. apply H3. right. exact H4. intro H3. elim H3. clear H3. intros H3 H4. intro H5. elim H5. generalize (ap_tight A a c). intuition. apply H2. exact H4. Qed. Definition free_csetoid_is_CSetoid:(is_CSetoid Astar eq_fm ap_fm):= (Build_is_CSetoid Astar eq_fm ap_fm ap_fm_irreflexive ap_fm_symmetric ap_fm_cotransitive ap_fm_tight). Definition free_csetoid_as_csetoid:CSetoid:= (Build_CSetoid Astar eq_fm ap_fm free_csetoid_is_CSetoid). Lemma app_strext: (bin_fun_strext free_csetoid_as_csetoid free_csetoid_as_csetoid free_csetoid_as_csetoid appA). Proof. unfold bin_fun_strext. intros x1. induction x1. simpl. intro x2. case x2. simpl. intuition. intuition. intros x2 y1 y2. simpl. case x2. case y2. simpl. intuition. simpl. intuition. case y2. simpl. simpl in IHx1. intros c l H. elim H. intuition. clear H. generalize (IHx1 l y1 (@nil A)). intuition. simpl. intros c l c0 l0. intro H. elim H. intuition. generalize (IHx1 l0 y1 (cons c l)). intuition. Qed. Definition app_as_csb_fun: (CSetoid_bin_fun free_csetoid_as_csetoid free_csetoid_as_csetoid free_csetoid_as_csetoid):= (Build_CSetoid_bin_fun free_csetoid_as_csetoid free_csetoid_as_csetoid free_csetoid_as_csetoid appA app_strext). Lemma eq_fm_reflexive: forall (x:Astar), (eq_fm x x). Proof. intro x. induction x. simpl. intuition. simpl. intuition. Qed. End p66E2b4. (** ** Partial Functions In this section we define a concept of partial function for an arbitrary setoid. Essentially, a partial function is what would be expected---a predicate on the setoid in question and a total function from the set of points satisfying that predicate to the setoid. There is one important limitations to this approach: first, the record we obtain has type [Type], meaning that we can't use, for instance, elimination of existential quantifiers. Furthermore, for reasons we will explain ahead, partial functions will not be defined via the [CSetoid_fun] record, but the whole structure will be incorporated in a new record. Finally, notice that to be completely general the domains of the functions have to be characterized by a [CProp]-valued predicate; otherwise, the use you can make of a function will be %\emph{%##a priori##%}% restricted at the moment it is defined. Before we state our definitions we need to do some work on domains. *) Section SubSets_of_G. (** *** Subsets of Setoids Subsets of a setoid will be identified with predicates from the carrier set of the setoid into [CProp]. At this stage, we do not make any assumptions about these predicates. We will begin by defining elementary operations on predicates, along with their basic properties. In particular, we will work with well defined predicates, so we will prove that these operations preserve welldefinedness. %\begin{convention}% Let [S:CSetoid] and [P,Q:S->CProp]. %\end{convention}% *) Variable S : CSetoid. Section Conjunction. Variables P Q : S -> CProp. Definition conjP (x : S) : CProp := P x and Q x. Lemma prj1 : forall x : S, conjP x -> P x. Proof. intros x H; inversion_clear H; assumption. Qed. Lemma prj2 : forall x : S, conjP x -> Q x. Proof. intros x H; inversion_clear H; assumption. Qed. Lemma conj_wd : pred_wd _ P -> pred_wd _ Q -> pred_wd _ conjP. Proof. intros H H0. red in |- *; intros x y H1 H2. inversion_clear H1; split. apply H with x; assumption. apply H0 with x; assumption. Qed. End Conjunction. Section Disjunction. Variables P Q : S -> CProp. (** Although at this stage we never use it, for completeness's sake we also treat disjunction (corresponding to union of subsets). *) Definition disj (x : S) : CProp := P x or Q x. Lemma inj1 : forall x : S, P x -> disj x. Proof. intros; left; assumption. Qed. Lemma inj2 : forall x : S, Q x -> disj x. Proof. intros; right; assumption. Qed. Lemma disj_wd : pred_wd _ P -> pred_wd _ Q -> pred_wd _ disj. Proof. intros H H0. red in |- *; intros x y H1 H2. inversion_clear H1. left; apply H with x; assumption. right; apply H0 with x; assumption. Qed. End Disjunction. Section Extension. (** The next definition is a bit tricky, and is useful for choosing among the elements that satisfy a predicate [P] those that also satisfy [R] in the case where [R] is only defined for elements satisfying [P]---consider [R] to be a condition on the image of an object via a function with domain [P]. We chose to call this operation [extension]. *) Variable P : S -> CProp. Variable R : forall x : S, P x -> CProp. Definition extend (x : S) : CProp := P x and (forall H : P x, R x H). Lemma ext1 : forall x : S, extend x -> P x. Proof. intros x H; inversion_clear H; assumption. Qed. Lemma ext2_a : forall x : S, extend x -> {H : P x | R x H}. Proof. intros x H; inversion_clear H. exists X; auto. Qed. Lemma ext2 : forall (x : S) (Hx : extend x), R x (ProjT1 (ext2_a x Hx)). Proof. intros; apply projT2. Qed. Lemma extension_wd : pred_wd _ P -> (forall (x y : S) Hx Hy, x [=] y -> R x Hx -> R y Hy) -> pred_wd _ extend. Proof. intros H H0. red in |- *; intros x y H1 H2. elim H1; intros H3 H4; split. apply H with x; assumption. intro H5; apply H0 with x H3; [ apply H2 | apply H4 ]. Qed. End Extension. End SubSets_of_G. Notation Conj := (conjP _). Arguments disj [S]. Arguments extend [S]. Arguments ext1 [S P R x]. Arguments ext2 [S P R x]. (** *** Operations We are now ready to define the concept of partial function between arbitrary setoids. *) Record BinPartFunct (S1 S2 : CSetoid) : Type := {bpfdom : S1 -> CProp; bdom_wd : pred_wd S1 bpfdom; bpfpfun :> forall x : S1, bpfdom x -> S2; bpfstrx : forall x y Hx Hy, bpfpfun x Hx [#] bpfpfun y Hy -> x [#] y}. Notation BDom := (bpfdom _ _). Arguments bpfpfun [S1 S2]. (** The next lemma states that every partial function is well defined. *) Lemma bpfwdef : forall S1 S2 (F : BinPartFunct S1 S2) x y Hx Hy, x [=] y -> F x Hx [=] F y Hy. Proof. intros. apply not_ap_imp_eq; intro H0. generalize (bpfstrx _ _ _ _ _ _ _ H0). exact (eq_imp_not_ap _ _ _ H). Qed. (** Similar for automorphisms. *) Record PartFunct (S : CSetoid) : Type := {pfdom : S -> CProp; dom_wd : pred_wd S pfdom; pfpfun :> forall x : S, pfdom x -> S; pfstrx : forall x y Hx Hy, pfpfun x Hx [#] pfpfun y Hy -> x [#] y}. Notation Dom := (pfdom _). Notation Part := (pfpfun _). Arguments pfpfun [S]. (** The next lemma states that every partial function is well defined. *) Lemma pfwdef : forall S (F : PartFunct S) x y Hx Hy, x [=] y -> F x Hx [=] F y Hy. Proof. intros. apply not_ap_imp_eq; intro H0. generalize (pfstrx _ _ _ _ _ _ H0). exact (eq_imp_not_ap _ _ _ H). Qed. (** A few characteristics of this definition should be explained: - The domain of the partial function is characterized by a predicate that is required to be well defined but not strongly extensional. The motivation for this choice comes from two facts: first, one very important subset of real numbers is the compact interval [[a,b]]---characterized by the predicate [ fun x : IR => a [<=] x /\ x [<=] b], which is not strongly extensional; on the other hand, if we can apply a function to an element [s] of a setoid [S] it seems reasonable (and at some point we do have to do it) to apply that same function to any element [s'] which is equal to [s] from the point of view of the setoid equality. - The last two conditions state that [pfpfun] is really a subsetoid function. The reason why we do not write it that way is the following: when applying a partial function [f] to an element [s] of [S] we also need a proof object [H]; with this definition the object we get is [f(s,H)], where the proof is kept separate from the object. Using subsetoid notation, we would get $f(\langle s,H\rangle)$#f(⟨s,H⟩)#; from this we need to apply two projections to get either the original object or the proof, and we need to apply an extra constructor to get $f(\langle s,H\rangle)$#f(⟨s,H⟩)# from [s] and [H]. This amounts to spending more resources when actually working with these objects. - This record has type [Type], which is very unfortunate, because it means in particular that we cannot use the well behaved set existential quantification over partial functions; however, later on we will manage to avoid this problem in a way that also justifies that we don't really need to use that kind of quantification. Another approach to this definition that completely avoid this complication would be to make [PartFunct] a dependent type, receiving the predicate as an argument. This does work in that it allows us to give [PartFunct] type [Set] and do some useful stuff with it; however, we are not able to define something as simple as an operator that gets a function and returns its domain (because of the restrictions in the type elimination rules). This sounds very unnatural, and soon gets us into strange problems that yield very unlikely definitions, which is why we chose to altogether do away with this approach. %\begin{convention}% All partial functions will henceforth be denoted by capital letters. %\end{convention}% We now present some methods for defining partial functions. *) #[global] Hint Resolve I: core. Section CSetoid_Ops. Variable S : CSetoid. (** To begin with, we want to be able to ``see'' each total function as a partial function. *) Definition total_eq_part : CSetoid_un_op S -> PartFunct S. Proof. intros f. apply Build_PartFunct with (fun x : S => True) (fun (x : S) (H : True) => f x). red in |- *; intros; auto. intros x y Hx Hy H. exact (csf_strext _ _ f _ _ H). Defined. Section Part_Function_Const. (** In any setoid we can also define constant functions (one for each element of the setoid) and an identity function: %\begin{convention}% Let [c:S]. %\end{convention}% *) Variable c : S. Definition Fconst := total_eq_part (Const_CSetoid_fun _ _ c). End Part_Function_Const. Section Part_Function_Id. Definition Fid := total_eq_part (id_un_op S). End Part_Function_Id. (** (These happen to be always total functions, but that is more or less obvious, as we have no information on the setoid; however, we will be able to define partial functions just applying other operators to these ones.) If we have two setoid functions [F] and [G] we can always compose them. The domain of our new function will be the set of points [s] in the domain of [F] for which [F(s)] is in the domain of [G]#. #%\footnote{%Notice that the use of extension here is essential.%}.% The inversion in the order of the variables is done to maintain uniformity with the usual mathematical notation. %\begin{convention}% Let [G,F:(PartFunct S)] and denote by [Q] and [P], respectively, the predicates characterizing their domains. %\end{convention}% *) Section Part_Function_Composition. Variables G F : PartFunct S. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Let R x := {Hx : P x | Q (F x Hx)}. Lemma part_function_comp_strext : forall x y (Hx : R x) (Hy : R y), G (F x (ProjT1 Hx)) (ProjT2 Hx) [#] G (F y (ProjT1 Hy)) (ProjT2 Hy) -> x [#] y. Proof. intros x y Hx Hy H. exact (pfstrx _ _ _ _ _ _ (pfstrx _ _ _ _ _ _ H)). Qed. Lemma part_function_comp_dom_wd : pred_wd S R. Proof. red in |- *; intros x y H H0. unfold R in |- *; inversion_clear H. exists (dom_wd _ F x y x0 H0). apply (dom_wd _ G) with (F x x0). assumption. apply pfwdef; assumption. Qed. Definition Fcomp := Build_PartFunct _ R part_function_comp_dom_wd (fun x (Hx : R x) => G (F x (ProjT1 Hx)) (ProjT2 Hx)) part_function_comp_strext. End Part_Function_Composition. End CSetoid_Ops. (** %\begin{convention}% Let [F:(BinPartFunct S1 S2)] and [G:(PartFunct S2 S3)], and denote by [Q] and [P], respectively, the predicates characterizing their domains. %\end{convention}% *) Section BinPart_Function_Composition. Variables S1 S2 S3 : CSetoid. Variable G : BinPartFunct S2 S3. Variable F : BinPartFunct S1 S2. (* begin hide *) Let P := BDom F. Let Q := BDom G. (* end hide *) Let R x := {Hx : P x | Q (F x Hx)}. Lemma bin_part_function_comp_strext : forall x y (Hx : R x) (Hy : R y), G (F x (ProjT1 Hx)) (ProjT2 Hx) [#] G (F y (ProjT1 Hy)) (ProjT2 Hy) -> x [#] y. Proof. intros x y Hx Hy H. exact (bpfstrx _ _ _ _ _ _ _ (bpfstrx _ _ _ _ _ _ _ H)). Qed. Lemma bin_part_function_comp_dom_wd : pred_wd S1 R. Proof. red in |- *; intros x y H H0. unfold R in |- *; inversion_clear H. exists (bdom_wd _ _ F x y x0 H0). apply (bdom_wd _ _ G) with (F x x0). assumption. apply bpfwdef; assumption. Qed. Definition BinFcomp := Build_BinPartFunct _ _ R bin_part_function_comp_dom_wd (fun x (Hx : R x) => G (F x (ProjT1 Hx)) (ProjT2 Hx)) bin_part_function_comp_strext. End BinPart_Function_Composition. (* Different tokens for compatibility with coqdoc *) Arguments Fconst [S]. Notation "[-C-] x" := (Fconst x) (at level 4, right associativity). Notation FId := (Fid _). Arguments Fcomp [S]. Infix "[o]" := Fcomp (at level 65, no associativity). #[global] Hint Resolve pfwdef bpfwdef: algebra. Section bijections. (** ** Bijections *) Definition injective A B (f : CSetoid_fun A B) := (forall a0 a1 : A, a0 [#] a1 -> f a0 [#] f a1):CProp. Definition injective_weak A B (f : CSetoid_fun A B) := forall a0 a1 : A, f a0 [=] f a1 -> a0 [=] a1. Definition surjective A B (f : CSetoid_fun A B) := (forall b : B, {a : A | f a [=] b}):CProp. Arguments injective [A B]. Arguments injective_weak [A B]. Arguments surjective [A B]. Lemma injective_imp_injective_weak : forall A B (f : CSetoid_fun A B), injective f -> injective_weak f. Proof. intros A B f. unfold injective in |- *. intro H. unfold injective_weak in |- *. intros a0 a1 H0. apply not_ap_imp_eq. red in |- *. intro H1. set (H2 := H a0 a1 H1) in *. set (H3 := ap_imp_neq B (f a0) (f a1) H2) in *. set (H4 := eq_imp_not_neq B (f a0) (f a1) H0) in *. apply H4. exact H3. Qed. Definition bijective A B (f:CSetoid_fun A B) := injective f and surjective f. Arguments bijective [A B]. Lemma id_is_bij : forall A, bijective (id_un_op A). Proof. intro A. split. red; simpl; auto. intro b; exists b; apply eq_reflexive. Qed. Lemma comp_resp_bij : forall A B C f g, bijective f -> bijective g -> bijective (compose_CSetoid_fun A B C f g). Proof. intros A B C f g. intros H0 H1. elim H0; clear H0; intros H00 H01. elim H1; clear H1; intros H10 H11. split. intros a0 a1; simpl; intro. apply H10; apply H00; auto. intro c; simpl. elim (H11 c); intros b H20. elim (H01 b); intros a H30. exists a. Step_final (g b). Qed. Lemma inv : forall A B (f:CSetoid_fun A B), bijective f -> forall b : B, {a : A | f a [=] b}. Proof. unfold bijective in |- *. unfold surjective in |- *. intuition. Qed. Arguments inv [A B]. Definition invfun A B (f : CSetoid_fun A B) (H : bijective f) : B -> A. Proof. intros H0. elim (inv f H H0); intros a H2. apply a. Defined. Arguments invfun [A B]. Lemma inv1 : forall A B (f : CSetoid_fun A B) (H : bijective f) (b : B), f (invfun f H b) [=] b. Proof. intros A B f H b. unfold invfun in |- *; case inv. simpl; auto. Qed. Lemma inv2 : forall A B (f : CSetoid_fun A B) (H : bijective f) (a : A), invfun f H (f a) [=] a. Proof. intros. unfold invfun in |- *; case inv; simpl. destruct H as [H0 H1]. intros x. now apply injective_imp_injective_weak. Qed. Lemma inv_strext : forall A B (f : CSetoid_fun A B) (H : bijective f), fun_strext (invfun f H). Proof. intros A B f H x y H1. case H. intros H00 H01. destruct (H01 x) as [a0 H2]. destruct (H01 y) as [a1 H3]. astepl (f a0). astepr (f a1). apply H00. astepl (invfun f H x). astepr (invfun f H y); [exact H1|]. astepl (invfun f H (f a1)); [apply inv2|]. apply injective_imp_injective_weak with (f := f); auto. astepl (f a1). astepl y. apply eq_symmetric; apply inv1. apply eq_symmetric; apply inv1. apply injective_imp_injective_weak with (f := f); auto. rewrite -> inv1. algebra. Qed. Definition Inv A B f (H : bijective f) := Build_CSetoid_fun B A (invfun f H) (inv_strext A B f H). Arguments Inv [A B]. Definition Inv_bij : forall A B (f : CSetoid_fun A B) (H : bijective f), bijective (Inv f H). Proof. intros A B f H. split. unfold injective in |- *. unfold bijective in H. unfold surjective in H. case H; intros H0 H1. intros b0 b1 H2. destruct (H1 b0) as [a0 H3]. destruct (H1 b1) as [a1 H4]. astepl (Inv f (pair H0 H1) (f a0)). astepr (Inv f (pair H0 H1) (f a1)). cut (fun_strext f). intros H5. apply H5. astepl (f a0). astepr (f a1). astepl b0. now astepr b1. apply eq_symmetric. unfold Inv in |- *. apply inv1. apply eq_symmetric. simpl in |- *; apply inv1. elim f; intuition. intro a. exists (f a). unfold Inv in |- *. apply inv2. Qed. End bijections. Arguments bijective [A B]. Arguments injective [A B]. Arguments injective_weak [A B]. Arguments surjective [A B]. Arguments inv [A B]. Arguments invfun [A B]. Arguments Inv [A B]. Arguments conj_wd [S P Q]. Notation Prj1 := (prj1 _ _ _ _). Notation Prj2 := (prj2 _ _ _ _). corn-8.20.0/algebra/CSetoidInc.v000066400000000000000000000064311473720167500163320ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing included %\ensuremath{\subseteq}% #⊆# *) Require Export CoRN.algebra.CSetoidFun. Section inclusion. (** ** Inclusion Let [S] be a setoid, and [P], [Q], [R] be predicates on [S]. *) Variable S : CSetoid. Definition included (P Q : S -> CProp) : CProp := forall x : S, P x -> Q x. Section Basics. Variables P Q R : S -> CProp. Lemma included_refl : included P P. Proof. red in |- *; intros. auto. Qed. Lemma included_trans : included P Q -> included Q R -> included P R. Proof. intros. red in |- *; intros. apply X0; apply X; auto. Qed. Lemma included_conj : forall P Q R, included P Q -> included P R -> included P (Conj Q R). Proof. intros. red in |- *; red in X, X0. intros; red in |- *. split. apply X; assumption. apply X0; assumption. Qed. Lemma included_conj' : included (Conj P Q) P. Proof. exact (prj1 _ P Q). Qed. Lemma included_conj'' : included (Conj P Q) Q. Proof. exact (prj2 _ P Q). Qed. Lemma included_conj_lft : included R (Conj P Q) -> included R P. Proof. red in |- *. unfold conjP. intros H1 x H2. elim (H1 x); auto. Qed. Lemma included_conj_rht : included R (Conj P Q) -> included R Q. Proof. red in |- *. unfold conjP. intros H1 x H2. elim (H1 x); auto. Qed. Lemma included_extend : forall (H : forall x, P x -> CProp), included R (extend P H) -> included R P. Proof. intros H0 H1. red in |- *. unfold extend in H1. intros. elim (H1 x); auto. Qed. End Basics. (** %\begin{convention}% Let [I,R:S->CProp] and [F G:(PartFunct S)], and denote by [P] and [Q], respectively, the domains of [F] and [G]. %\end{convention}% *) Variables F G : (PartFunct S). (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Variable R : S -> CProp. Lemma included_FComp : included R P -> (forall x Hx, (R x) -> Q (F x Hx)) -> included R (Dom (G[o]F)). Proof. intros HP HQ. simpl in |- *. red in |- *; intros x Hx. exists (HP x Hx). apply HQ. assumption. Qed. Lemma included_FComp' : included R (Dom (G[o]F)) -> included R P. Proof. intro H; simpl in H; red in |- *; intros x Hx. elim (H x Hx); auto. Qed. End inclusion. Arguments included [S]. #[global] Hint Resolve included_refl included_FComp : included. #[global] Hint Immediate included_trans included_FComp' : included. corn-8.20.0/algebra/CSetoids.v000066400000000000000000000755501473720167500160730ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Cezary Kaliszyk * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing != %\ensuremath{\mathrel\#}% *) (** printing == %\ensuremath{\equiv}% #≡# *) (** printing [=] %\ensuremath{\equiv}% #≡# *) (** printing [~=] %\ensuremath{\mathrel{\not\equiv}}% #≠# *) (** printing [#] %\ensuremath{\mathrel\#}% *) (** printing ex_unq %\ensuremath{\exists^1}% #∃1# *) (** printing [o] %\ensuremath\circ% #⋅# *) (** printing [-C-] %\ensuremath\diamond% *) (** * Setoids Definition of a constructive setoid with apartness, i.e.%\% a set with an equivalence relation and an apartness relation compatible with it. *) Require Import CoRN.tactics.CornTac. Require Export CoRN.logic.CLogic. Require Export CoRN.tactics.Step. Require Export CoRN.algebra.RSetoid. Delimit Scope corn_scope with corn. Open Scope corn_scope. Definition Relation := Trelation. Arguments Treflexive [A]. Arguments Creflexive [A]. Arguments Tsymmetric [A]. Arguments Csymmetric [A]. Arguments Ttransitive [A]. Arguments Ctransitive [A]. (* begin hide *) Set Implicit Arguments. Unset Strict Implicit. (* end hide *) (** ** Relations necessary for Setoids %\begin{convention}% Let [A:Type]. %\end{convention}% Notice that their type depends on the main logical connective. *) Section Properties_of_relations. Variable A : Type. Definition irreflexive (R : Crelation A) : Prop := forall x : A, Not (R x x). Definition cotransitive (R : Crelation A) : CProp := forall x y : A, R x y -> forall z : A, R x z or R z y. Definition tight_apart (eq : Relation A) (ap : Crelation A) : Prop := forall x y : A, Not (ap x y) <-> eq x y. Definition antisymmetric (R : Crelation A) : Prop := forall x y : A, R x y -> Not (R y x). End Properties_of_relations. (* begin hide *) Set Strict Implicit. Unset Implicit Arguments. (* end hide *) (** ** Definition of Setoid Apartness, being the main relation, needs to be [CProp]-valued. Equality, as it is characterized by a negative statement, lives in [Prop]. *) Record is_CSetoid (A : Type) (eq : Relation A) (ap : Crelation A) : CProp := {ax_ap_irreflexive : irreflexive ap; ax_ap_symmetric : Csymmetric ap; ax_ap_cotransitive : cotransitive ap; ax_ap_tight : tight_apart eq ap}. Record CSetoid : Type := makeCSetoid {cs_crr :> RSetoid; cs_ap : Crelation cs_crr; cs_proof : is_CSetoid cs_crr (@st_eq cs_crr) cs_ap}. Notation cs_eq := st_eq (only parsing). Arguments cs_ap [c]. Infix "[=]" := cs_eq (at level 70, no associativity). Infix "[#]" := cs_ap (at level 70, no associativity). (* End_SpecReals *) Definition cs_neq (S : CSetoid) : Relation S := fun x y : S => ~ x [=] y. Arguments cs_neq [S]. Infix "[~=]" := cs_neq (at level 70, no associativity). (** %\begin{nameconvention}% In the names of lemmas, we refer to [ [=] ] by [eq], [ [~=] ] by [neq], and [ [#] ] by [ap]. %\end{nameconvention}% ** Setoid axioms We want concrete lemmas that state the axiomatic properties of a setoid. %\begin{convention}% Let [S] be a setoid. %\end{convention}% *) (* Begin_SpecReals *) Section CSetoid_axioms. Variable S : CSetoid. Lemma CSetoid_is_CSetoid : is_CSetoid S (cs_eq (r:=S)) (cs_ap (c:=S)). Proof cs_proof S. Lemma ap_irreflexive : irreflexive (cs_ap (c:=S)). Proof. elim CSetoid_is_CSetoid; auto. Qed. Lemma ap_symmetric : Csymmetric (cs_ap (c:=S)). Proof. elim CSetoid_is_CSetoid; auto. Qed. Lemma ap_cotransitive : cotransitive (cs_ap (c:=S)). Proof. elim CSetoid_is_CSetoid; auto. Qed. Lemma ap_tight : tight_apart (cs_eq (r:=S)) (cs_ap (c:=S)). Proof. elim CSetoid_is_CSetoid; auto. Qed. End CSetoid_axioms. (** ** Setoid basics%\label{section:setoid-basics}% %\begin{convention}% Let [S] be a setoid. %\end{convention}% *) Lemma is_CSetoid_Setoid : forall S eq ap, is_CSetoid S eq ap -> Setoid_Theory S eq. Proof. intros S eq ap p. destruct p. split. firstorder. intros a b. red in ax_ap_tight0 . repeat rewrite <- ax_ap_tight0. firstorder. intros a b c. red in ax_ap_tight0 . repeat rewrite <- ax_ap_tight0. intros H H0 H1. destruct (ax_ap_cotransitive0 _ _ H1 b); auto. Qed. Definition Build_CSetoid (X:Type) (eq:Relation X) (ap:Crelation X) (p:is_CSetoid X eq ap) : CSetoid. Proof. exists (Build_RSetoid (is_CSetoid_Setoid _ _ _ p)) ap. assumption. Defined. Section CSetoid_basics. Variable S : CSetoid. (* End_SpecReals *) (** In `there exists a unique [a:S] such that %\ldots%#...#', we now mean unique with respect to the setoid equality. We use [ex_unq] to denote unique existence. *) Definition ex_unq (P : S -> CProp) := {x : S | forall y : S, P y -> x [=] y | P x}. Lemma eq_reflexive : Treflexive (cs_eq (r:=S)). Proof. intro x. reflexivity. Qed. Lemma eq_symmetric : Tsymmetric (cs_eq (r:=S)). Proof. intro x; intros y H. symmetry; assumption. Qed. Lemma eq_transitive : Ttransitive (cs_eq (r:=S)). Proof. intro x; intros y z H H0. transitivity y; assumption. Qed. (** %\begin{shortcoming}% The lemma [eq_reflexive] above is convertible to [eq_reflexive_unfolded] below. We need the second version too, because the first cannot be applied when an instance of reflexivity is needed. (``I have complained bitterly about this.'' RP) %\end{shortcoming}% tes %\begin{nameconvention}% If lemma [a] is just an unfolding of lemma [b], the name of [a] is the name [b] with the suffix ``[_unfolded]''. %\end{nameconvention}% *) Lemma eq_reflexive_unfolded : forall x : S, x [=] x. Proof eq_reflexive. Lemma eq_symmetric_unfolded : forall x y : S, x [=] y -> y [=] x. Proof eq_symmetric. Lemma eq_transitive_unfolded : forall x y z : S, x [=] y -> y [=] z -> x [=] z. Proof eq_transitive. Lemma eq_wdl : forall x y z : S, x [=] y -> x [=] z -> z [=] y. Proof. intros. now apply (eq_transitive _ x);[apply: eq_symmetric|]. Qed. Lemma ap_irreflexive_unfolded : forall x : S, Not (x [#] x). Proof ap_irreflexive S. Lemma ap_cotransitive_unfolded : forall a b : S, a [#] b -> forall c : S, a [#] c or c [#] b. Proof. intros a b H c. exact (ap_cotransitive _ _ _ H c). Qed. Lemma ap_symmetric_unfolded : forall x y : S, x [#] y -> y [#] x. Proof ap_symmetric S. (** We would like to write [[ Lemma eq_equiv_not_ap : forall (x y:S), (x [=] y) iff Not (x [#] y). ]] In Coq, however, this lemma cannot be easily applied. Therefore we have to split the lemma into the following two lemmas [eq_imp_not_ap] and [not_ap_imp_eq]. For this we should fix the Prop CProp problem. *) Lemma eq_imp_not_ap : forall x y : S, x [=] y -> Not (x [#] y). Proof. intros x y. elim (ap_tight S x y). intros H1 H2. assumption. Qed. Lemma not_ap_imp_eq : forall x y : S, Not (x [#] y) -> x [=] y. Proof. intros x y. elim (ap_tight S x y). intros H1 H2. assumption. Qed. Lemma neq_imp_notnot_ap : forall x y : S, x [~=] y -> ~ Not (x [#] y). Proof. intros x y H H0. now apply: H; apply: not_ap_imp_eq. Qed. Lemma notnot_ap_imp_neq : forall x y : S, ~ Not (x [#] y) -> x [~=] y. Proof. intros x y H H0. now apply H; apply eq_imp_not_ap. Qed. Lemma ap_imp_neq : forall x y : S, x [#] y -> x [~=] y. Proof. intros x y H H1. now apply (eq_imp_not_ap _ _ H1). Qed. Lemma not_neq_imp_eq : forall x y : S, ~ x [~=] y -> x [=] y. Proof. intros x y H. apply: not_ap_imp_eq. intros H0. apply: H. now apply: ap_imp_neq. Qed. Lemma eq_imp_not_neq : forall x y : S, x [=] y -> ~ x [~=] y. Proof. intros x y H H0. easy. Qed. End CSetoid_basics. Section product_csetoid. (** ** The product of setoids *) Definition prod_ap (A B : CSetoid) (c d : prodT A B) : CProp. Proof. destruct c as [a b], d as [a0 b0]. exact (cs_ap (c:=A) a a0 or cs_ap (c:=B) b b0). Defined. Definition prod_eq (A B : CSetoid) (c d : prodT A B) : Prop. Proof. destruct c as [a b], d as [a0 b0]. exact (a [=] a0 /\ b [=] b0). Defined. Lemma prodcsetoid_is_CSetoid : forall A B : CSetoid, is_CSetoid (prodT A B) (prod_eq A B) (prod_ap A B). Proof. (* Can be shortened *) intros A B. apply (Build_is_CSetoid _ (prod_eq A B) (prod_ap A B)). intros x. case x. intros c c0 H. elim H. intros H1. now apply: (ap_irreflexive A _ H1). apply (ap_irreflexive B _ ). intros x y. case x. case y. intros c c0 c1 c2 H. elim H. intros. left. now apply ap_symmetric. intros. right. now apply ap_symmetric. intros x y. case x. case y. intros c c0 c1 c2 H z. case z. intros c3 c4. generalize H. intros. elim H. intros. cut (c1 [#] c3 or c3 [#] c). intros [H1|H2]. left. now left. intros. right. now left. now apply: ap_cotransitive. intros. cut (c2 [#] c4 or c4 [#] c0). intros [H1|H2]. left; now right. now right;right. now apply: ap_cotransitive. intros x y. case x. case y. intros c c0 c1 c2. split. intros. split. apply not_ap_imp_eq. intros H1. now cut (c1 [#] c or c2 [#] c0);[|left]. apply not_ap_imp_eq. intros H1. now cut (c1 [#] c or c2 [#] c0);[|right]. intros. elim H. intros H0 H1 H2. now elim H2;apply eq_imp_not_ap. Qed. Definition ProdCSetoid (A B : CSetoid) : CSetoid := Build_CSetoid (prodT A B) (prod_eq A B) (prod_ap A B) (prodcsetoid_is_CSetoid A B). End product_csetoid. Arguments ex_unq [S]. #[global] Hint Resolve eq_reflexive_unfolded ap_irreflexive_unfolded: algebra_r. #[global] Hint Resolve eq_symmetric_unfolded ap_symmetric_unfolded: algebra_s. #[global] Hint Resolve eq_transitive_unfolded ap_cotransitive_unfolded: algebra_c. Declare Left Step eq_wdl. Declare Right Step eq_transitive_unfolded. (** ** Relations and predicates Here we define the notions of well-definedness and strong extensionality on predicates and relations. %\begin{convention}% Let [S] be a setoid. %\end{convention}% %\begin{nameconvention}% - ``well-defined'' is abbreviated to [well_def] (or [wd]). - ``strongly extensional'' is abbreviated to [strong_ext] (or [strext]). %\end{nameconvention}% *) Section CSetoid_relations_and_predicates. Variable S : CSetoid. (** *** Predicates At this stage, we consider [CProp]- and [Prop]-valued predicates on setoids. %\begin{convention}% Let [P] be a predicate on (the carrier of) [S]. %\end{convention}% *) Section CSetoidPredicates. Variable P : S -> CProp. Definition pred_strong_ext : CProp := forall x y : S, P x -> P y or x [#] y. Definition pred_wd : CProp := forall x y : S, P x -> x [=] y -> P y. End CSetoidPredicates. Record wd_pred : Type := {wdp_pred :> S -> CProp; wdp_well_def : pred_wd wdp_pred}. Record CSetoid_predicate : Type := {csp_pred :> S -> CProp; csp_strext : pred_strong_ext csp_pred}. Lemma csp_wd : forall P : CSetoid_predicate, pred_wd P. Proof. intro P. intro x; intros y H H0. elim (csp_strext P x y H). auto. set (eq_imp_not_ap _ _ _ H0); contradiction. Qed. (** Similar, with [Prop] instead of [CProp]. *) Section CSetoidPPredicates. Variable P : S -> Prop. Definition pred_strong_ext' : CProp := forall x y : S, P x -> P y or x [#] y. Definition pred_wd' : Prop := forall x y : S, P x -> x [=] y -> P y. End CSetoidPPredicates. (** *** Definition of a setoid predicate *) Record CSetoid_predicate' : Type := {csp'_pred :> S -> Prop; csp'_strext : pred_strong_ext' csp'_pred}. Lemma csp'_wd : forall P : CSetoid_predicate', pred_wd' P. Proof. intro P. intro x; intros y H H0. elim (csp'_strext P x y H). auto. set (eq_imp_not_ap _ _ _ H0); contradiction. Qed. (** *** Relations %\begin{convention}% Let [R] be a relation on (the carrier of) [S]. %\end{convention}% *) Section CsetoidRelations. Variable R : S -> S -> Prop. Definition rel_wdr : Prop := forall x y z : S, R x y -> y [=] z -> R x z. Definition rel_wdl : Prop := forall x y z : S, R x y -> x [=] z -> R z y. Definition rel_strext : CProp := forall x1 x2 y1 y2 : S, R x1 y1 -> (x1 [#] x2 or y1 [#] y2) or R x2 y2. Definition rel_strext_lft : CProp := forall x1 x2 y : S, R x1 y -> x1 [#] x2 or R x2 y. Definition rel_strext_rht : CProp := forall x y1 y2 : S, R x y1 -> y1 [#] y2 or R x y2. Lemma rel_strext_imp_lftarg : rel_strext -> rel_strext_lft. Proof. intros H x1 x2 y H0. generalize (H x1 x2 y y). intros H1. elim (H1 H0);[|auto]. intros [H2|H3];[auto|]. elim (ap_irreflexive S _ H3). Qed. Lemma rel_strext_imp_rhtarg : rel_strext -> rel_strext_rht. Proof. intros H x y1 y2 H0. generalize (H x x y1 y2 H0). intros [[H1|H2]|H3]; auto. elim (ap_irreflexive _ _ H1). Qed. Lemma rel_strextarg_imp_strext : rel_strext_rht -> rel_strext_lft -> rel_strext. Proof. intros H H0 x1 x2 y1 y2 H1. elim (H x1 y1 y2 H1); intro H2;[|elim (H0 x1 x2 y2 H2)];auto. Qed. End CsetoidRelations. (** *** Definition of a setoid relation The type of relations over a setoid. *) Record CSetoid_relation : Type := {csr_rel :> S -> S -> Prop; csr_wdr : rel_wdr csr_rel; csr_wdl : rel_wdl csr_rel; csr_strext : rel_strext csr_rel}. (** *** [CProp] Relations %\begin{convention}% Let [R] be a relation on (the carrier of) [S]. %\end{convention}% *) Section CCsetoidRelations. Variable R : S -> S -> CProp. Definition Crel_wdr : CProp := forall x y z : S, R x y -> y [=] z -> R x z. Definition Crel_wdl : CProp := forall x y z : S, R x y -> x [=] z -> R z y. Definition Crel_strext : CProp := forall x1 x2 y1 y2 : S, R x1 y1 -> R x2 y2 or x1 [#] x2 or y1 [#] y2. Definition Crel_strext_lft : CProp := forall x1 x2 y : S, R x1 y -> R x2 y or x1 [#] x2. Definition Crel_strext_rht : CProp := forall x y1 y2 : S, R x y1 -> R x y2 or y1 [#] y2. Lemma Crel_strext_imp_lftarg : Crel_strext -> Crel_strext_lft. Proof. intros H x1 x2 y H0. generalize (H x1 x2 y y). intros [H1|H2];auto. case H2. auto. intro H3. elim (ap_irreflexive _ _ H3). Qed. Lemma Crel_strext_imp_rhtarg : Crel_strext -> Crel_strext_rht. Proof. intros H x y1 y2 H0. generalize (H x x y1 y2 H0). intros [H1|H2];auto. case H2; auto. intro H3. elim (ap_irreflexive _ _ H3). Qed. Lemma Crel_strextarg_imp_strext : Crel_strext_rht -> Crel_strext_lft -> Crel_strext. Proof. intros H H0 x1 x2 y1 y2 H1. elim (H x1 y1 y2 H1); auto. intro H2. elim (H0 x1 x2 y2 H2); auto. Qed. End CCsetoidRelations. (** *** Definition of a [CProp] setoid relation The type of relations over a setoid. *) Record CCSetoid_relation : Type := {Ccsr_rel :> S -> S -> CProp; Ccsr_strext : Crel_strext Ccsr_rel}. Lemma Ccsr_wdr : forall R : CCSetoid_relation, Crel_wdr R. Proof. intro R. intros x y z H H0. elim (Ccsr_strext R x x y z H);auto. intros [H1|H2]. elim (ap_irreflexive _ _ H1). set (eq_imp_not_ap _ _ _ H0). contradiction. Qed. Lemma Ccsr_wdl : forall R : CCSetoid_relation, Crel_wdl R. Proof. intros R x y z H H0. elim (Ccsr_strext R x z y y H);auto. intros [H1|H2]; [set (eq_imp_not_ap _ _ _ H0); contradiction| elim (ap_irreflexive _ _ H2)]. Qed. Lemma ap_wdr : Crel_wdr (cs_ap (c:=S)). Proof. intros x y z H H0. generalize (eq_imp_not_ap _ _ _ H0); intro H1. elim (ap_cotransitive _ _ _ H z); intro H2. assumption. elim H1. now apply: ap_symmetric. Qed. Lemma ap_wdl : Crel_wdl (cs_ap (c:=S)). Proof. intros x y z H H0. generalize (ap_wdr y x z); intro H1. apply ap_symmetric. now apply H1;[apply ap_symmetric|]. Qed. Lemma ap_wdr_unfolded : forall x y z : S, x [#] y -> y [=] z -> x [#] z. Proof ap_wdr. Lemma ap_wdl_unfolded : forall x y z : S, x [#] y -> x [=] z -> z [#] y. Proof ap_wdl. Lemma ap_strext : Crel_strext (cs_ap (c:=S)). Proof. intros x1 x2 y1 y2 H. case (ap_cotransitive _ _ _ H x2); intro H0;auto. case (ap_cotransitive _ _ _ H0 y2); intro H1;auto. right; right. now apply ap_symmetric. Qed. Definition predS_well_def (P : S -> CProp) : CProp := forall x y : S, P x -> x [=] y -> P y. End CSetoid_relations_and_predicates. Declare Left Step ap_wdl_unfolded. Declare Right Step ap_wdr_unfolded. (** ** Functions between setoids Such functions must preserve the setoid equality and be strongly extensional w.r.t.%\% the apartness, i.e.%\% if [f(x,y) [#] f(x1,y1)], then [x [#] x1 + y [#] y1]. For every arity this has to be defined separately. %\begin{convention}% Let [S1], [S2] and [S3] be setoids. %\end{convention}% First we consider unary functions. *) Section CSetoid_functions. Variables S1 S2 S3 : CSetoid. Section unary_functions. (** In the following two definitions, [f] is a function from (the carrier of) [S1] to (the carrier of) [S2]. *) Variable f : S1 -> S2. Definition fun_wd : Prop := forall x y : S1, x [=] y -> f x [=] f y. Definition fun_strext : CProp := forall x y : S1, f x [#] f y -> x [#] y. Lemma fun_strext_imp_wd : fun_strext -> fun_wd. Proof. intros H x y H0. apply not_ap_imp_eq. intro H1. generalize (H _ _ H1); intro H2. now generalize (eq_imp_not_ap _ _ _ H0). Qed. End unary_functions. Record CSetoid_fun : Type := {csf_fun :> S1 -> S2; csf_strext : fun_strext csf_fun}. Lemma csf_wd : forall f : CSetoid_fun, fun_wd f. Proof. intro f. apply fun_strext_imp_wd. apply csf_strext. Qed. Lemma csf_wd_unfolded: forall (f : CSetoid_fun) (x y : S1), x[=]y -> f x[=]f y. Proof csf_wd. Definition Const_CSetoid_fun : S2 -> CSetoid_fun. Proof. intro c; apply (Build_CSetoid_fun (fun x : S1 => c)); intros x y H. elim (ap_irreflexive _ _ H). Defined. Section binary_functions. (** Now we consider binary functions. In the following two definitions, [f] is a function from [S1] and [S2] to [S3]. *) Variable f : S1 -> S2 -> S3. Definition bin_fun_wd : Prop := forall x1 x2 y1 y2, x1 [=] x2 -> y1 [=] y2 -> f x1 y1 [=] f x2 y2. Definition bin_fun_strext : CProp := forall x1 x2 y1 y2, f x1 y1 [#] f x2 y2 -> x1 [#] x2 or y1 [#] y2. Lemma bin_fun_strext_imp_wd : bin_fun_strext -> bin_fun_wd. Proof. intros H x1 x2 y1 y2 H0 H1. apply not_ap_imp_eq. intro H2. generalize (H _ _ _ _ H2); intro H3. elim H3; intro H4. now set (eq_imp_not_ap _ _ _ H0). now set (eq_imp_not_ap _ _ _ H1). Qed. End binary_functions. Record CSetoid_bin_fun : Type := {csbf_fun :> S1 -> S2 -> S3; csbf_strext : bin_fun_strext csbf_fun}. Lemma csbf_wd : forall f : CSetoid_bin_fun, bin_fun_wd f. Proof. intro f. apply: bin_fun_strext_imp_wd. apply csbf_strext. Qed. Lemma csbf_wd_unfolded : forall (f : CSetoid_bin_fun) (x x' : S1) (y y' : S2), x [=] x' -> y [=] y' -> f x y [=] f x' y'. Proof csbf_wd. Lemma csf_strext_unfolded : forall (f : CSetoid_fun) (x y : S1), f x [#] f y -> x [#] y. Proof csf_strext. End CSetoid_functions. Lemma bin_fun_is_wd_fun_lft : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S2), fun_wd _ _ (fun x : S1 => f x c). Proof. intros S1 S2 S3 f c x y H. now apply csbf_wd; [|apply eq_reflexive]. Qed. Lemma bin_fun_is_wd_fun_rht : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S1), fun_wd _ _ (fun x : S2 => f c x). Proof. intros S1 S2 S3 f c x y H. now apply csbf_wd; [apply eq_reflexive|]. Qed. Lemma bin_fun_is_strext_fun_lft : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S2), fun_strext _ _ (fun x : S1 => f x c). Proof. intros S1 S2 S3 f c x y H. cut (x [#] y or c [#] c). intros [H1|H2];auto. now set (ap_irreflexive _ c H2). eapply csbf_strext. apply H. Defined. Lemma bin_fun_is_strext_fun_rht : forall S1 S2 S3 (f : CSetoid_bin_fun S1 S2 S3) (c : S1), fun_strext _ _ (fun x : S2 => f c x). Proof. intros S1 S2 S3 op c x y H. cut (c [#] c or x [#] y). intro Hv. elim Hv. intro Hf. generalize (ap_irreflexive _ c Hf). tauto. auto. eapply csbf_strext. apply H. Defined. Definition bin_fun2fun_rht (S1 S2 S3:CSetoid) (f : CSetoid_bin_fun S1 S2 S3) (c : S1) : CSetoid_fun S2 S3 := Build_CSetoid_fun _ _ (fun x : S2 => f c x) (bin_fun_is_strext_fun_rht _ _ _ f c). Definition bin_fun2fun_lft (S1 S2 S3:CSetoid) (f : CSetoid_bin_fun S1 S2 S3) (c : S2) : CSetoid_fun S1 S3 := Build_CSetoid_fun _ _ (fun x : S1 => f x c) (bin_fun_is_strext_fun_lft _ _ _ f c). #[global] Hint Resolve csf_wd_unfolded csbf_wd_unfolded csf_strext_unfolded: algebra_c. Arguments fun_wd [S1 S2]. Arguments fun_strext [S1 S2]. (** ** The unary and binary (inner) operations on a csetoid An operation is a function with domain(s) and co-domain equal. %\begin{nameconvention}% The word ``unary operation'' is abbreviated to [un_op]; ``binary operation'' is abbreviated to [bin_op]. %\end{nameconvention}% %\begin{convention}% Let [S] be a setoid. %\end{convention}% *) Section csetoid_inner_ops. Variable S : CSetoid. (** Properties of binary operations *) Definition commutes (f : S -> S -> S) : Prop := forall x y : S, f x y [=] f y x. Definition associative (f : S -> S -> S) : Prop := forall x y z : S, f x (f y z) [=] f (f x y) z. (** Well-defined unary operations on a setoid. *) Definition un_op_wd := fun_wd (S1:=S) (S2:=S). Definition un_op_strext := fun_strext (S1:=S) (S2:=S). Definition CSetoid_un_op := CSetoid_fun S S. Definition Build_CSetoid_un_op := Build_CSetoid_fun S S. Lemma id_strext : un_op_strext (fun x : S => x). Proof. now repeat intro. Qed. Lemma id_pres_eq : un_op_wd (fun x : S => x). Proof. now repeat intro. Qed. Definition id_un_op := Build_CSetoid_un_op (fun x : S => x) id_strext. (* begin hide *) Identity Coercion un_op_fun : CSetoid_un_op >-> CSetoid_fun. (* end hide *) Definition cs_un_op_strext := csf_strext S S. (** Well-defined binary operations on a setoid. *) Definition bin_op_wd := bin_fun_wd S S S. Definition bin_op_strext := bin_fun_strext S S S. Definition CSetoid_bin_op : Type := CSetoid_bin_fun S S S. Definition Build_CSetoid_bin_op := Build_CSetoid_bin_fun S S S. Definition cs_bin_op_wd := csbf_wd S S S. Definition cs_bin_op_strext := csbf_strext S S S. (* begin hide *) Identity Coercion bin_op_bin_fun : CSetoid_bin_op >-> CSetoid_bin_fun. (* end hide *) Lemma bin_op_is_wd_un_op_lft : forall (op : CSetoid_bin_op) (c : S), un_op_wd (fun x : S => op x c). Proof. apply bin_fun_is_wd_fun_lft. Qed. Lemma bin_op_is_wd_un_op_rht : forall (op : CSetoid_bin_op) (c : S), un_op_wd (fun x : S => op c x). Proof. apply bin_fun_is_wd_fun_rht. Qed. Lemma bin_op_is_strext_un_op_lft : forall (op : CSetoid_bin_op) (c : S), un_op_strext (fun x : S => op x c). Proof. apply bin_fun_is_strext_fun_lft. Defined. Lemma bin_op_is_strext_un_op_rht : forall (op : CSetoid_bin_op) (c : S), un_op_strext (fun x : S => op c x). Proof. apply bin_fun_is_strext_fun_rht. Defined. Definition bin_op2un_op_rht (op : CSetoid_bin_op) (c : S) : CSetoid_un_op := bin_fun2fun_rht _ _ _ op c. Definition bin_op2un_op_lft (op : CSetoid_bin_op) (c : S) : CSetoid_un_op := bin_fun2fun_lft _ _ _ op c. Lemma un_op_wd_unfolded : forall (op : CSetoid_un_op) (x y : S), x [=] y -> op x [=] op y. Proof csf_wd S S. Lemma un_op_strext_unfolded : forall (op : CSetoid_un_op) (x y : S), op x [#] op y -> x [#] y. Proof cs_un_op_strext. Lemma bin_op_wd_unfolded : forall (op : CSetoid_bin_op) (x1 x2 y1 y2 : S), x1 [=] x2 -> y1 [=] y2 -> op x1 y1 [=] op x2 y2. Proof cs_bin_op_wd. Lemma bin_op_strext_unfolded : forall (op : CSetoid_bin_op) (x1 x2 y1 y2 : S), op x1 y1 [#] op x2 y2 -> x1 [#] x2 or y1 [#] y2. Proof cs_bin_op_strext. End csetoid_inner_ops. Arguments commutes [S]. Arguments associative [S]. (* Needs to be unfolded to be used as a Hint *) #[global] Hint Resolve ap_wdr_unfolded ap_wdl_unfolded bin_op_wd_unfolded un_op_wd_unfolded : algebra_c. (** ** The binary outer operations on a csetoid %\begin{convention}% Let [S1] and [S2] be setoids. %\end{convention}% *) Section csetoid_outer_ops. Variables S1 S2 : CSetoid. (** Well-defined outer operations on a setoid. *) Definition outer_op_well_def := bin_fun_wd S1 S2 S2. Definition outer_op_strext := bin_fun_strext S1 S2 S2. Definition CSetoid_outer_op : Type := CSetoid_bin_fun S1 S2 S2. Definition Build_CSetoid_outer_op := Build_CSetoid_bin_fun S1 S2 S2. Definition csoo_wd := csbf_wd S1 S2 S2. Definition csoo_strext := csbf_strext S1 S2 S2. Lemma csoo_wd_unfolded : forall (op : CSetoid_outer_op) x1 x2 y1 y2, x1 [=] x2 -> y1 [=] y2 -> op x1 y1 [=] op x2 y2. Proof csoo_wd. (* begin hide *) Identity Coercion outer_op_bin_fun : CSetoid_outer_op >-> CSetoid_bin_fun. (* end hide *) End csetoid_outer_ops. #[global] Hint Resolve csoo_wd_unfolded: algebra_c. (** ** Subsetoids %\begin{convention}% Let [S] be a setoid, and [P] a predicate on the carrier of [S]. %\end{convention}% *) Section SubCSetoids. Variable S : CSetoid. Variable P : S -> CProp. Record subcsetoid_crr : Type := {scs_elem :> S; scs_prf : P scs_elem}. (** Though [scs_elem] is declared as a coercion, it does not satisfy the uniform inheritance condition and will not be inserted. However it will also not be printed, which is handy. *) Definition restrict_relation (R : Relation S) : Relation subcsetoid_crr := fun a b : subcsetoid_crr => match a, b with | Build_subcsetoid_crr x _, Build_subcsetoid_crr y _ => R x y end. Definition Crestrict_relation (R : Crelation S) : Crelation subcsetoid_crr := fun a b : subcsetoid_crr => match a, b with | Build_subcsetoid_crr x _, Build_subcsetoid_crr y _ => R x y end. Definition subcsetoid_eq : Relation subcsetoid_crr := restrict_relation (cs_eq (r:=S)). Definition subcsetoid_ap : Crelation subcsetoid_crr := Crestrict_relation (cs_ap (c:=S)). Remark subcsetoid_equiv : Tequiv _ subcsetoid_eq. Proof. split. (* reflexive *) intros a; case a. intros x s. apply (eq_reflexive S). (* transitive *) split. intros a b c; case a. intros x s; case b. intros y t; case c. intros z u. apply eq_transitive. (* symmetric *) intros a b; case a. intros x s; case b. intros y t. apply eq_symmetric. Qed. Lemma subcsetoid_is_CSetoid : is_CSetoid _ subcsetoid_eq subcsetoid_ap. Proof. apply (Build_is_CSetoid _ subcsetoid_eq subcsetoid_ap). (* irreflexive *) intro x. case x. intros. apply ap_irreflexive. (* symmetric *) intros x y. case x. case y. intros. exact (ap_symmetric S _ _ X). (* cotransitive *) intros x y. case x. case y. intros; case z. intros. exact (ap_cotransitive S _ _ X scs_elem2). (* tight *) intros x y. case x. case y. intros. exact (ap_tight S scs_elem1 scs_elem0). Qed. Definition Build_SubCSetoid : CSetoid := Build_CSetoid subcsetoid_crr subcsetoid_eq subcsetoid_ap subcsetoid_is_CSetoid. (** *** Subsetoid unary operations %\begin{convention}% Let [f] be a unary setoid operation on [S]. %\end{convention}% *) Section SubCSetoid_unary_operations. Variable f : CSetoid_un_op S. Definition un_op_pres_pred : CProp := forall x : S, P x -> P (f x). (** %\begin{convention}% Assume [pr:un_op_pres_pred]. %\end{convention}% *) Variable pr : un_op_pres_pred. Definition restr_un_op (a : subcsetoid_crr) : subcsetoid_crr := match a with | Build_subcsetoid_crr x p => Build_subcsetoid_crr (f x) (pr x p) end. Lemma restr_un_op_wd : un_op_wd Build_SubCSetoid restr_un_op. Proof. intros x y. case y. case x. intros. now apply: (csf_wd _ _ f). Qed. Lemma restr_un_op_strext : un_op_strext Build_SubCSetoid restr_un_op. Proof. intros x y. case y. case x. intros. exact (cs_un_op_strext _ f _ _ X). Qed. Definition Build_SubCSetoid_un_op : CSetoid_un_op Build_SubCSetoid := Build_CSetoid_un_op Build_SubCSetoid restr_un_op restr_un_op_strext. End SubCSetoid_unary_operations. (** *** Subsetoid binary operations %\begin{convention}% Let [f] be a binary setoid operation on [S]. %\end{convention}% *) Section SubCSetoid_binary_operations. Variable f : CSetoid_bin_op S. Definition bin_op_pres_pred : CProp := forall x y : S, P x -> P y -> P (f x y). (** %\begin{convention}% Assume [bin_op_pres_pred]. %\end{convention}% *) Variable pr : bin_op_pres_pred. Definition restr_bin_op (a b : subcsetoid_crr) : subcsetoid_crr := match a, b with | Build_subcsetoid_crr x p, Build_subcsetoid_crr y q => Build_subcsetoid_crr (f x y) (pr x y p q) end. Lemma restr_bin_op_well_def : bin_op_wd Build_SubCSetoid restr_bin_op. Proof. intros x1 x2 y1 y2. case y2. case y1. case x2. case x1. intros. exact (cs_bin_op_wd _ f _ _ _ _ H H0). Qed. Lemma restr_bin_op_strext : bin_op_strext Build_SubCSetoid restr_bin_op. Proof. intros x1 x2 y1 y2. case y2. case y1. case x2. case x1. intros. exact (cs_bin_op_strext _ f _ _ _ _ X). Qed. Definition Build_SubCSetoid_bin_op : CSetoid_bin_op Build_SubCSetoid := Build_CSetoid_bin_op Build_SubCSetoid restr_bin_op restr_bin_op_strext. Lemma restr_f_assoc : associative f -> associative Build_SubCSetoid_bin_op. Proof. intros assf x y z. case z. case y. case x. intros. apply: assf. Qed. End SubCSetoid_binary_operations. End SubCSetoids. (* begin hide *) Ltac Step_final x := apply eq_transitive with x; algebra. (* end hide *) Tactic Notation "Step_final" constr(c) := Step_final c. (** ** Miscellaneous *) Lemma proper_caseZ_diff_CS : forall (S : CSetoid) (f : nat -> nat -> S), (forall m n p q : nat, m + q = n + p -> f m n [=] f p q) -> forall m n : nat, caseZ_diff (m - n) f [=] f m n. Proof. intro CS. intros. pattern m, n in |- *. apply nat_double_ind. intro. replace (0%nat - n0)%Z with (- n0)%Z;auto. rewrite caseZ_diff_Neg; reflexivity. intros. replace (S n0 - 0%nat)%Z with (S n0:Z);auto. rewrite caseZ_diff_Pos; reflexivity. intros. generalize (H (S n0) (S m0) n0 m0); intro. cut (S n0 + m0 = S m0 + n0). intro. generalize (H1 H2); intro. apply eq_transitive with (f n0 m0). apply eq_transitive with (caseZ_diff (n0 - m0) f);auto. replace (S n0 - S m0)%Z with (n0 - m0)%Z. apply eq_reflexive. repeat rewrite Znat.inj_S; clear H1; auto with zarith. now apply eq_symmetric. clear H1; auto with zarith. Qed. (** Finally, we characterize functions defined on the natural numbers also as setoid functions, similarly to what we already did for predicates. *) Definition nat_less_n_fun (S : CSetoid) (n : nat) (f : forall i : nat, i < n -> S) := forall i j : nat, i = j -> forall (H : i < n) (H' : j < n), f i H [=] f j H'. Definition nat_less_n_fun' (S : CSetoid) (n : nat) (f : forall i : nat, i <= n -> S) := forall i j : nat, i = j -> forall (H : i <= n) (H' : j <= n), f i H [=] f j H'. Arguments nat_less_n_fun [S n]. Arguments nat_less_n_fun' [S n]. Add Parametric Relation c : (cs_crr c) (@cs_eq c) reflexivity proved by (eq_reflexive c) symmetry proved by (eq_symmetric c) transitivity proved by (eq_transitive c) as CSetoid_eq_Setoid. Add Parametric Morphism (c1 c2 c3 : CSetoid) f: (csbf_fun c1 c2 c3 f) with signature (@cs_eq c1) ==> (@cs_eq c2) ==> (@cs_eq c3) as csbf_fun_wd. Proof. intros x1 x2 Hx y1 y2 Hy. now apply csbf_wd. Qed. Add Parametric Morphism (c1 c2 : CSetoid) f: (@csf_fun c1 c2 f) with signature (@cs_eq c1) ==> (@cs_eq c2) as csf_fun_wd. Proof. intros x1 x2 Hx. now apply csf_wd. Qed. corn-8.20.0/algebra/CSums.v000066400000000000000000000574511473720167500154100ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Sum0 %\ensuremath{\sum_0}% #∑0# *) (** printing Sum1 %\ensuremath{\sum_1}% #∑1# *) (** printing Sum2 %\ensuremath{\sum_2}% #∑2# *) (** printing Sum %\ensuremath{\sum}% #∑# *) (** printing Sumx %\ensuremath{\sum'}% #∑'&*) Require Export CoRN.algebra.CAbGroups. From Coq Require Export Peano_dec. From Coq Require Import Lia. (** * Sums %\begin{convention}% Let [G] be an abelian group. %\end{convention}% *) Section Sums. Variable G : CAbGroup. (* Sum1 and Sum use subtraction *) Fixpoint Sumlist (l : list G) : G := match l with | nil => [0]:G | cons x k => x[+]Sumlist k end. Fixpoint Sumx n : (forall i : nat, i < n -> G) -> G := match n return ((forall i : nat, i < n -> G) -> G) with | O => fun _ => [0]:G | S m => fun f => Sumx m (fun i l => f i (Nat.lt_lt_succ_r _ _ l)) [+]f m (Nat.lt_succ_diag_r m) end. (** It is sometimes useful to view a function defined on $\{0,\ldots,i-1\}$ #{0, ... i-1}# as a function on the natural numbers which evaluates to [Zero] when the input is greater than or equal to [i]. *) Definition part_tot_nat_fun n (f : forall i, i < n -> G) : nat -> G. Proof. intros i. elim (le_lt_dec n i). intro a; apply ([0]:G). intro b; apply (f i b). Defined. Lemma part_tot_nat_fun_ch1 : forall n (f : forall i, i < n -> G), nat_less_n_fun f -> forall i Hi, part_tot_nat_fun n f i [=] f i Hi. Proof. intros n f Hf i Hi. unfold part_tot_nat_fun in |- *. elim le_lt_dec; intro. exfalso; apply (Nat.le_ngt n i); auto. simpl in |- *; apply Hf; auto. Qed. Lemma part_tot_nat_fun_ch2 : forall n (f : forall i, i < n -> G) i, n <= i -> part_tot_nat_fun n f i [=] [0]. Proof. intros n f i Hi. unfold part_tot_nat_fun in |- *. elim le_lt_dec; intro. simpl in |- *; algebra. exfalso; apply (Nat.le_ngt n i); auto. Qed. (** [Sum0] defines the sum for [i=0..(n-1)] *) Fixpoint Sum0 (n:nat) (f : nat -> G) {struct n} : G := match n with | O => [0]:G | S m => Sum0 m f[+]f m end. (** [Sum1] defines the sum for [i=m..(n-1)] *) Definition Sum1 m n f := Sum0 n f[-]Sum0 m f. Definition Sum m n : (nat -> G) -> G := Sum1 m (S n). (* Sum i=m..n *) (** [Sum2] is similar to [Sum1], but does not require the summand to be defined outside where it is being added. *) Definition Sum2 m n (h : forall i : nat, m <= i -> i <= n -> G) : G. Proof. apply (Sum m n). intro i. elim (le_lt_dec m i); intro H. elim (le_lt_dec i n); intro H0. apply (h i H H0). apply ([0]:G). apply ([0]:G). Defined. Lemma Sum_one : forall n f, Sum n n f [=] f n. Proof. intros n f. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. Step_final (f n[+]Sum0 n f[-]Sum0 n f). Qed. Hint Resolve Sum_one: algebra. Lemma Sum_empty : forall n f, 0 < n -> Sum n (pred n) f [=] [0]. Proof. intros n f H. unfold Sum in |- *. rewrite <- (Nat.lt_succ_pred _ _ H). unfold Sum1 in |- *; algebra. Qed. Hint Resolve Sum_empty: algebra. Lemma Sum_Sum : forall l m n f, Sum l m f[+]Sum (S m) n f [=] Sum l n f. Proof. intros l m n f. unfold Sum in |- *. unfold Sum1 in |- *. astepl (Sum0 (S n) f[-]Sum0 (S m) f[+] (Sum0 (S m) f[-]Sum0 l f)). astepl (Sum0 (S n) f[-]Sum0 (S m) f[+]Sum0 (S m) f[-]Sum0 l f). astepl (Sum0 (S n) f[-] (Sum0 (S m) f[-]Sum0 (S m) f) [-]Sum0 l f). astepl (Sum0 (S n) f[-][0][-]Sum0 l f). astepl (Sum0 (S n) f[+] [--][0][-]Sum0 l f). Step_final (Sum0 (S n) f[+][0][-]Sum0 l f). Qed. Hint Resolve Sum_Sum: algebra. Lemma Sum_first : forall m n f, Sum m n f [=] f m[+]Sum (S m) n f. Proof. intros m n f. unfold Sum in |- *. unfold Sum1 in |- *. astepr (f m[+]Sum0 (S n) f[-]Sum0 (S m) f). astepr (Sum0 (S n) f[+]f m[-]Sum0 (S m) f). astepr (Sum0 (S n) f[+] (f m[-]Sum0 (S m) f)). unfold cg_minus in |- *. apply bin_op_wd_unfolded. algebra. simpl in |- *. astepr (f m[+] [--] (f m[+]Sum0 m f)). astepr (f m[+] ([--] (f m) [+] [--] (Sum0 m f))). astepr (f m[+] [--] (f m) [+] [--] (Sum0 m f)). astepr ([0][+] [--] (Sum0 m f)). algebra. Qed. Lemma Sum_last : forall m n f, Sum m (S n) f [=] Sum m n f[+]f (S n). Proof. intros m n f. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. unfold cg_minus in |- *. astepl (Sum0 n f[+]f n[+] (f (S n) [+] [--] (Sum0 m f))). astepr (Sum0 n f[+]f n[+] ([--] (Sum0 m f) [+]f (S n))). algebra. Qed. Hint Resolve Sum_last: algebra. Lemma Sum_last' : forall m n f, 0 < n -> Sum m n f [=] Sum m (pred n) f[+]f n. Proof. intros m n f H. induction n as [| n Hrecn]. elim (Nat.lt_irrefl 0 H). apply Sum_last. Qed. (** We add some extensionality results which will be quite useful when working with integration. *) Lemma Sum0_strext : forall f g n, Sum0 n f [#] Sum0 n g -> {i:nat | i < n | f i [#] g i}. Proof. intros f g n H. induction n as [| n Hrecn]. simpl in H. elim (ap_irreflexive_unfolded _ _ H). simpl in H. cut ({i : nat | i < n | f i [#] g i} or f n [#] g n). intro H0. elim H0; intro H1. elim H1; intros i H2 H3; exists i; auto with arith. exists n; auto with arith. cut (Sum0 n f [#] Sum0 n g or f n [#] g n). intro H0; elim H0; intro H1. left; apply Hrecn; assumption. auto. apply bin_op_strext_unfolded with (csg_op (c:=G)). assumption. Qed. Lemma Sum_strext : forall f g m n, m <= S n -> Sum m n f [#] Sum m n g -> {i : nat | m <= i /\ i <= n | f i [#] g i}. Proof. intros f g m n H H0. induction n as [| n Hrecn]. elim (le_lt_eq_dec _ _ H); intro H2. cut (m = 0). intro H1. rewrite H1; exists 0; auto. rewrite H1 in H0. astepl (Sum 0 0 f); astepr (Sum 0 0 g); assumption. inversion H2; [ auto | inversion H3 ]. exfalso. cut (0 = pred 1); [ intro H3 | auto ]. rewrite H3 in H0. rewrite H2 in H0. apply (ap_irreflexive_unfolded G [0]). eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply H0. apply Sum_empty; auto. apply Sum_empty; auto. elim (le_lt_eq_dec _ _ H); intro Hmn. cut (Sum m n f [#] Sum m n g or f (S n) [#] g (S n)). intro H1; elim H1; intro H2. cut {i : nat | m <= i /\ i <= n | f i [#] g i}. intro H3; elim H3; intros i H4 H5; elim H4; intros H6 H7; clear H1 H4. exists i; try split; auto with arith. apply Hrecn; auto with arith. exists (S n); try split; auto with arith. apply bin_op_strext_unfolded with (csg_op (c:=G)). astepl (Sum m (S n) f); astepr (Sum m (S n) g); assumption. clear Hrecn. exfalso. cut (S n = pred (S (S n))); [ intro H1 | auto ]. rewrite H1 in H0. rewrite Hmn in H0. apply (ap_irreflexive_unfolded G [0]). eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply H0. apply Sum_empty; auto with arith. apply Sum_empty; auto with arith. Qed. Lemma Sumx_strext : forall n f g, nat_less_n_fun f -> nat_less_n_fun g -> Sumx _ f [#] Sumx _ g -> {N : nat | {HN : N < n | f N HN [#] g N HN}}. Proof. intro n; induction n as [| n Hrecn]. intros f g H H0 H1. elim (ap_irreflexive_unfolded _ _ H1). intros f g H H0 H1. simpl in H1. elim (bin_op_strext_unfolded _ _ _ _ _ _ H1); clear H1; intro H1. cut (nat_less_n_fun (fun (i : nat) (l : i < n) => f i (Nat.lt_lt_succ_r _ _ l))); [ intro H2 | red in |- *; intros; apply H; assumption ]. cut (nat_less_n_fun (fun (i : nat) (l : i < n) => g i (Nat.lt_lt_succ_r _ _ l))); [ intro H3 | red in |- *; intros; apply H0; assumption ]. elim (Hrecn _ _ H2 H3 H1); intros N HN. elim HN; clear HN; intros HN H'. exists N. exists (Nat.lt_lt_succ_r _ _ HN). eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply H'. algebra. algebra. exists n. exists (Nat.lt_succ_diag_r n). eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply H1. algebra. algebra. Qed. Lemma Sum0_strext' : forall f g n, Sum0 n f [#] Sum0 n g -> {i : nat | f i [#] g i}. Proof. intros f g n H. elim (Sum0_strext _ _ _ H); intros i Hi Hi'; exists i; auto. Qed. Lemma Sum_strext' : forall f g m n, Sum m n f [#] Sum m n g -> {i : nat | f i [#] g i}. Proof. intros f g m n H. unfold Sum, Sum1 in H. elim (cg_minus_strext _ _ _ _ _ H); intro H1; elim (Sum0_strext _ _ _ H1); intros i Hi Hi'; exists i; assumption. Qed. Lemma Sum0_wd : forall m f f', (forall i, f i [=] f' i) -> Sum0 m f [=] Sum0 m f'. Proof. intros m f f' H. elim m; simpl in |- *; algebra. Qed. Lemma Sum_wd : forall m n f f', (forall i, f i [=] f' i) -> Sum m n f [=] Sum m n f'. Proof. intros m n f f' H. unfold Sum in |- *. unfold Sum1 in |- *. unfold cg_minus in |- *. apply bin_op_wd_unfolded. apply Sum0_wd; exact H. apply un_op_wd_unfolded. apply Sum0_wd; exact H. Qed. Lemma Sumx_wd : forall n f g, (forall i H, f i H [=] g i H) -> Sumx n f [=] Sumx n g. Proof. intro n; elim n; intros; simpl in |- *; algebra. Qed. Lemma Sum_wd' : forall m n, m <= S n -> forall f f', (forall i, m <= i -> i <= n -> f i [=] f' i) -> Sum m n f [=] Sum m n f'. Proof. intros m n. induction n as [| n Hrecn]; intros H f f' H0. inversion H. unfold Sum in |- *. unfold Sum1 in |- *. Step_final ([0]:G). inversion H2. astepl (f 0). astepr (f' 0). auto. elim (le_lt_eq_dec m (S (S n)) H); intro H1. astepl (Sum m n f[+]f (S n)). astepr (Sum m n f'[+]f' (S n)). apply bin_op_wd_unfolded; auto with arith. rewrite H1. unfold Sum in |- *. unfold Sum1 in |- *. Step_final ([0]:G). Qed. Lemma Sum2_wd : forall m n, m <= S n -> forall f g, (forall i Hm Hn, f i Hm Hn [=] g i Hm Hn) -> Sum2 m n f [=] Sum2 m n g. Proof. intros m n H f g H0. unfold Sum2 in |- *. apply Sum_wd'. assumption. intros i H1 H2. elim le_lt_dec; intro H3; [ simpl in |- * | exfalso; apply (Nat.le_ngt i n); auto ]. elim le_lt_dec; intro H4; [ simpl in |- * | exfalso; apply (Nat.le_ngt m i); auto ]. algebra. Qed. Lemma Sum0_plus_Sum0 : forall f g m, Sum0 m (fun i => f i[+]g i) [=] Sum0 m f[+]Sum0 m g. Proof. intros f g m. elim m. simpl in |- *; algebra. intros n H. simpl in |- *. astepl (Sum0 n f[+]Sum0 n g[+] (f n[+]g n)). astepl (Sum0 n f[+] (Sum0 n g[+] (f n[+]g n))). astepl (Sum0 n f[+] (Sum0 n g[+]f n[+]g n)). astepl (Sum0 n f[+] (f n[+]Sum0 n g[+]g n)). astepl (Sum0 n f[+] (f n[+]Sum0 n g) [+]g n). Step_final (Sum0 n f[+]f n[+]Sum0 n g[+]g n). Qed. Hint Resolve Sum0_plus_Sum0: algebra. Lemma Sum_plus_Sum : forall f g m n, Sum m n (fun i => f i[+]g i) [=] Sum m n f[+]Sum m n g. Proof. intros f g m n. unfold Sum in |- *. unfold Sum1 in |- *. astepl (Sum0 (S n) f[+]Sum0 (S n) g[-] (Sum0 m f[+]Sum0 m g)). astepl (Sum0 (S n) f[+]Sum0 (S n) g[-]Sum0 m f[-]Sum0 m g). unfold cg_minus in |- *. astepr (Sum0 (S n) f[+] [--] (Sum0 m f) [+]Sum0 (S n) g[+] [--] (Sum0 m g)). apply bin_op_wd_unfolded. astepl (Sum0 (S n) f[+] (Sum0 (S n) g[+] [--] (Sum0 m f))). astepl (Sum0 (S n) f[+] ([--] (Sum0 m f) [+]Sum0 (S n) g)). algebra. algebra. Qed. Lemma Sumx_plus_Sumx : forall n f g, Sumx n f[+]Sumx n g [=] Sumx n (fun i Hi => f i Hi[+]g i Hi). Proof. intro n; induction n as [| n Hrecn]. intros; simpl in |- *; algebra. intros f g; simpl in |- *. apply eq_transitive_unfolded with (Sumx _ (fun (i : nat) (l : i < n) => f i (Nat.lt_lt_succ_r i n l)) [+] Sumx _ (fun (i : nat) (l : i < n) => g i (Nat.lt_lt_succ_r i n l)) [+] (f n (Nat.lt_succ_diag_r n) [+]g n (Nat.lt_succ_diag_r n))). set (Sf := Sumx _ (fun (i : nat) (l : i < n) => f i (Nat.lt_lt_succ_r i n l))) in *. set (Sg := Sumx _ (fun (i : nat) (l : i < n) => g i (Nat.lt_lt_succ_r i n l))) in *. set (fn := f n (Nat.lt_succ_diag_r n)) in *; set (gn := g n (Nat.lt_succ_diag_r n)) in *. astepl (Sf[+]fn[+]Sg[+]gn). astepl (Sf[+] (fn[+]Sg) [+]gn). astepl (Sf[+] (Sg[+]fn) [+]gn). Step_final (Sf[+]Sg[+]fn[+]gn). apply bin_op_wd_unfolded; algebra. (* useless since V8.1: apply Hrecn with (f := fun (i : nat) (l : i < n) => f i (lt_S i n l)) (g := fun (i : nat) (l : i < n) => g i (lt_S i n l)). *) Qed. Lemma Sum2_plus_Sum2 : forall m n, m <= S n -> forall f g, Sum2 m n f[+]Sum2 m n g [=] Sum2 _ _ (fun i Hm Hn => f i Hm Hn[+]g i Hm Hn). Proof. intros m n H f g. unfold Sum2 in |- *; simpl in |- *. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply Sum_plus_Sum. apply Sum_wd; intro i. elim le_lt_dec; intro H0; simpl in |- *; elim le_lt_dec; intro H1; simpl in |- *; algebra. Qed. Lemma inv_Sum0 : forall f n, Sum0 n (fun i => [--] (f i)) [=] [--] (Sum0 n f). Proof. intros f n. induction n as [| n Hrecn]. simpl in |- *; algebra. simpl in |- *. Step_final ([--] (Sum0 n f) [+] [--] (f n)). Qed. Hint Resolve inv_Sum0: algebra. Lemma inv_Sum : forall f m n, Sum m n (fun i => [--] (f i)) [=] [--] (Sum m n f). Proof. intros f a b. unfold Sum in |- *. unfold Sum1 in |- *. astepl ([--] (Sum0 (S b) f) [-][--] (Sum0 a f)). astepl ([--] (Sum0 (S b) f) [+] [--][--] (Sum0 a f)). Step_final ([--] (Sum0 (S b) f[+] [--] (Sum0 a f))). Qed. Hint Resolve inv_Sum: algebra. Lemma inv_Sumx : forall n f, [--] (Sumx n f) [=] Sumx _ (fun i Hi => [--] (f i Hi)). Proof. intro n; induction n as [| n Hrecn]. simpl in |- *; algebra. intro f; simpl in |- *. astepl ([--] (Sumx _ (fun i (l : i < n) => f i (Nat.lt_lt_succ_r i n l))) [+] [--] (f n (Nat.lt_succ_diag_r n))). apply bin_op_wd_unfolded. apply Hrecn with (f := fun i (l : i < n) => f i (Nat.lt_lt_succ_r i n l)). algebra. Qed. Lemma inv_Sum2 : forall m n : nat, m <= S n -> forall f, [--] (Sum2 m n f) [=] Sum2 _ _ (fun i Hm Hn => [--] (f i Hm Hn)). Proof. intros m n H f. unfold Sum2 in |- *; simpl in |- *. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply inv_Sum. apply Sum_wd; intro i. elim le_lt_dec; intro; simpl in |- *; elim le_lt_dec; intro; simpl in |- *; algebra. Qed. Lemma Sum_minus_Sum : forall f g m n, Sum m n (fun i => f i[-]g i) [=] Sum m n f[-]Sum m n g. Proof. (* WHAT A MISERY TO PROVE THIS *) intros f g a b. astepl (Sum a b (fun i : nat => f i[+] [--] (g i))). cut (Sum a b (fun i : nat => f i[+] (fun j : nat => [--] (g j)) i) [=] Sum a b f[+]Sum a b (fun j : nat => [--] (g j))). intro H. astepl (Sum a b f[+]Sum a b (fun j : nat => [--] (g j))). Step_final (Sum a b f[+] [--] (Sum a b g)). change (Sum a b (fun i : nat => f i[+] (fun j : nat => [--] (g j)) i) [=] Sum a b f[+]Sum a b (fun j : nat => [--] (g j))) in |- *. apply Sum_plus_Sum. Qed. Hint Resolve Sum_minus_Sum: algebra. Lemma Sumx_minus_Sumx : forall n f g, Sumx n f[-]Sumx n g [=] Sumx _ (fun i Hi => f i Hi[-]g i Hi). Proof. intros n f g; unfold cg_minus in |- *. eapply eq_transitive_unfolded. 2: apply Sumx_plus_Sumx with (f := f) (g := fun i (Hi : i < n) => [--] (g i Hi)). apply bin_op_wd_unfolded; algebra. apply inv_Sumx. Qed. Lemma Sum2_minus_Sum2 : forall m n, m <= S n -> forall f g, Sum2 m n f[-]Sum2 m n g [=] Sum2 _ _ (fun i Hm Hn => f i Hm Hn[-]g i Hm Hn). Proof. intros m n H f g; unfold cg_minus in |- *. eapply eq_transitive_unfolded. 2: apply Sum2_plus_Sum2 with (f := f) (g := fun i (Hm : m <= i) (Hn : i <= n) => [--] (g i Hm Hn)); assumption. apply bin_op_wd_unfolded. algebra. apply inv_Sum2; assumption. Qed. Lemma Sum_apzero : forall f m n, m <= n -> Sum m n f [#] [0] -> {i : nat | m <= i /\ i <= n | f i [#] [0]}. Proof. intros a k l H H0. induction l as [| l Hrecl]. exists 0. split; auto. cut (k = 0). intro H'. rewrite H' in H0. astepl (Sum 0 0 a). auto. inversion H. auto. elim (le_lt_eq_dec k (S l) H); intro HH. cut (Sum k l a [#] [0] or a (S l) [#] [0]). intro H1. elim H1; clear H1; intro H1. elim Hrecl; auto with arith. intro i. intros H2 H6. exists i; auto. elim H2; intros H3 H4; auto. exists (S l); try split; auto with arith. apply cg_add_ap_zero. apply ap_wdl_unfolded with (Sum k (S l) a). auto. apply Sum_last. rewrite HH in H0. exists (S l); auto. astepl (Sum (S l) (S l) a). auto. Qed. Lemma Sum_zero : forall f m n, m <= S n -> (forall i, m <= i -> i <= n -> f i [=] [0]) -> Sum m n f [=] [0]. Proof. intros a k l H H0. induction l as [| l Hrecl]. elim (le_lt_eq_dec _ _ H); clear H; intro H. replace k with 0. astepl (a 0). apply H0. auto. auto with arith. auto. inversion H. auto. inversion H2. rewrite H. unfold Sum in |- *. unfold Sum1 in |- *. algebra. elim (le_lt_eq_dec k (S (S l)) H); intro HH. astepl (Sum k l a[+]a (S l)). astepr ([0][+] ([0]:G)). apply bin_op_wd_unfolded. apply Hrecl; auto with arith. apply H0; auto with arith. rewrite HH. unfold Sum in |- *. unfold Sum1 in |- *. algebra. Qed. Lemma Sum_term : forall f m i n, m <= i -> i <= n -> (forall j, m <= j -> j <> i -> j <= n -> f j [=] [0]) -> Sum m n f [=] f i. Proof. intros a k i0 l H H0 H1. astepl (Sum k i0 a[+]Sum (S i0) l a). astepr (a i0[+][0]). apply bin_op_wd_unfolded. elim (O_or_S i0); intro H2. elim H2; intros m Hm. rewrite <- Hm. astepl (Sum k m a[+]a (S m)). astepr ([0][+]a (S m)). apply bin_op_wd_unfolded. apply Sum_zero. rewrite Hm; auto. intros i H3 H4. apply H1. auto. lia. lia. algebra. rewrite <- H2 in H. rewrite <- H2. inversion H. algebra. apply Sum_zero. auto with arith. intros. apply H1. lia. lia. auto. Qed. Lemma Sum0_shift : forall f g n, (forall i, f i [=] g (S i)) -> g 0[+]Sum0 n f [=] Sum0 (S n) g. Proof. intros a b l H. induction l as [| l Hrecl]. simpl in |- *; algebra. simpl in |- *. astepl (b 0[+]Sum0 l a[+]a l). Step_final (Sum0 (S l) b[+]a l). Qed. Hint Resolve Sum0_shift: algebra. Lemma Sum_shift : forall f g m n, (forall i, f i [=] g (S i)) -> Sum m n f [=] Sum (S m) (S n) g. Proof. unfold Sum in |- *. unfold Sum1 in |- *. intros a b k l H. astepl (Sum0 (S l) a[+]b 0[-]b 0[-]Sum0 k a). astepl (Sum0 (S l) a[+]b 0[-] (b 0[+]Sum0 k a)). Step_final (b 0[+]Sum0 (S l) a[-] (b 0[+]Sum0 k a)). Qed. Lemma Sum_big_shift : forall f g k m n, (forall j, m <= j -> f j [=] g (j + k)) -> m <= S n -> Sum m n f [=] Sum (m + k) (n + k) g. Proof. do 3 intro; generalize f g; clear f g. induction k as [| k Hreck]. intros f g n m. repeat rewrite <- plus_n_O. intros H H0. apply: Sum_wd'. auto. intros. set (Hi:= H i). rewrite <- (plus_n_O i) in Hi. apply: Hi. auto. intros; repeat rewrite <- plus_n_Sm. apply eq_transitive_unfolded with (Sum (m + k) (n + k) (fun n : nat => g (S n))). 2: apply Sum_shift; algebra. apply Hreck. intros; rewrite plus_n_Sm; apply H; auto with arith. auto. Qed. Lemma Sumx_Sum0 : forall n f g, (forall i Hi, f i Hi [=] g i) -> Sumx n f [=] Sum0 n g. Proof. intro; induction n as [| n Hrecn]; simpl in |- *; algebra. Qed. End Sums. Arguments Sum [G]. Arguments Sum0 [G]. Arguments Sumx [G n]. Arguments Sum2 [G m n]. (** The next results are useful for calculating some special sums, often referred to as ``Mengolli Sums''. %\begin{convention}% Let [G] be an abelian group. %\end{convention}% *) Section More_Sums. Variable G : CAbGroup. Lemma Mengolli_Sum : forall n (f : forall i, i <= n -> G) (g : forall i, i < n -> G), nat_less_n_fun' f -> (forall i H, g i H [=] f (S i) H[-]f i (Nat.lt_le_incl _ _ H)) -> Sumx g [=] f n (le_n n) [-]f 0 (Nat.le_0_l n). Proof. intro n; induction n as [| n Hrecn]; intros f g Hf H; simpl in |- *. astepl (f 0 (le_n 0) [-]f 0 (le_n 0)). apply cg_minus_wd; algebra. apply eq_transitive_unfolded with (f _ (le_n (S n)) [-]f _ (le_S _ _ (le_n n)) [+] (f _ (le_S _ _ (le_n n)) [-]f 0 (Nat.le_0_l (S n)))). eapply eq_transitive_unfolded. apply cag_commutes_unfolded. apply bin_op_wd_unfolded. eapply eq_transitive_unfolded. apply H. apply cg_minus_wd; apply Hf; algebra. set (f' := fun i (H : i <= n) => f i (le_S _ _ H)) in *. set (g' := fun i (H : i < n) => g i (Nat.lt_lt_succ_r _ _ H)) in *. apply eq_transitive_unfolded with (f' n (le_n n) [-]f' 0 (Nat.le_0_l n)). apply Hrecn. red in |- *; intros; unfold f' in |- *; apply Hf; algebra. intros i Hi. unfold f' in |- *; unfold g' in |- *. eapply eq_transitive_unfolded. apply H. apply cg_minus_wd; apply Hf; algebra. unfold f' in |- *; apply cg_minus_wd; apply Hf; algebra. astepr (f (S n) (le_n (S n)) [+][0][-]f 0 (Nat.le_0_l (S n))). astepr (f (S n) (le_n (S n)) [+] ([--] (f n (le_S _ _ (le_n n))) [+]f n (le_S _ _ (le_n n))) [-] f 0 (Nat.le_0_l (S n))). Step_final (f (S n) (le_n (S n)) [+] [--] (f n (le_S _ _ (le_n n))) [+] f n (le_S _ _ (le_n n)) [-]f 0 (Nat.le_0_l (S n))). Qed. Lemma Mengolli_Sum_gen : forall f g : nat -> G, (forall n, g n [=] f (S n) [-]f n) -> forall m n, m <= S n -> Sum m n g [=] f (S n) [-]f m. Proof. intros f g H m n; induction n as [| n Hrecn]; intro Hmn. elim (le_lt_eq_dec _ _ Hmn); intro H0. cut (m = 0); [ intro H1 | inversion H0; auto with arith; inversion H2 ]. rewrite H1. eapply eq_transitive_unfolded; [ apply Sum_one | apply H ]. cut (0 = pred 1); [ intro H1 | auto ]. rewrite H0; astepr ([0]:G); rewrite H1; apply Sum_empty. auto with arith. simpl in Hmn; elim (le_lt_eq_dec _ _ Hmn); intro H0. apply eq_transitive_unfolded with (f (S (S n)) [-]f (S n) [+] (f (S n) [-]f m)). eapply eq_transitive_unfolded. apply Sum_last. eapply eq_transitive_unfolded. apply cag_commutes_unfolded. apply bin_op_wd_unfolded; [ apply H | apply Hrecn ]. auto with arith. astepr (f (S (S n)) [+][0][-]f m). astepr (f (S (S n)) [+] ([--] (f (S n)) [+]f (S n)) [-]f m). Step_final (f (S (S n)) [+] [--] (f (S n)) [+]f (S n) [-]f m). rewrite H0. astepr ([0]:G). cut (S n = pred (S (S n))); [ intro H2 | auto ]. rewrite H2; apply Sum_empty. auto with arith. Qed. Lemma str_Mengolli_Sum_gen : forall (f g : nat -> G) m n, m <= S n -> (forall i, m <= i -> i <= n -> g i [=] f (S i) [-]f i) -> Sum m n g [=] f (S n) [-]f m. Proof. intros f g m n H H0. apply eq_transitive_unfolded with (Sum m n (fun i : nat => f (S i) [-]f i)). apply Sum_wd'; assumption. apply Mengolli_Sum_gen; [ intro; algebra | assumption ]. Qed. Lemma Sumx_to_Sum : forall n, 0 < n -> forall f, nat_less_n_fun f -> Sumx f [=] Sum 0 (pred n) (part_tot_nat_fun G n f). Proof. intro n; induction n as [| n Hrecn]; intros H f Hf. exfalso; inversion H. cut (0 <= n); [ intro H0 | auto with arith ]. elim (le_lt_eq_dec _ _ H0); clear H H0; intro H. simpl in |- *. pattern n at 6 in |- *; rewrite <- (Nat.lt_succ_pred _ _ H). eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Sum_last. apply bin_op_wd_unfolded. eapply eq_transitive_unfolded. apply Hrecn; auto. red in |- *; intros; apply Hf; auto. apply Sum_wd'. auto with arith. intros i H1 H2. cut (i < n); [ intro | lia ]. eapply eq_transitive_unfolded. apply part_tot_nat_fun_ch1 with (Hi := H0). red in |- *; intros; apply Hf; auto. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply part_tot_nat_fun_ch1 with (Hi := Nat.lt_lt_succ_r _ _ H0). red in |- *; intros; apply Hf; auto. algebra. rewrite -> (Nat.lt_succ_pred _ _ H). apply eq_symmetric_unfolded; apply part_tot_nat_fun_ch1; auto. generalize f Hf; clear Hf f; rewrite <- H. simpl in |- *; intros f Hf. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Sum_one. astepl (f 0 (Nat.lt_succ_diag_r 0)). apply eq_symmetric_unfolded; apply part_tot_nat_fun_ch1; auto. Qed. End More_Sums. #[global] Hint Resolve Sum_one Sum_Sum Sum_first Sum_last Sum_last' Sum_wd Sum_plus_Sum: algebra. #[global] Hint Resolve Sum_minus_Sum inv_Sum inv_Sum0: algebra. corn-8.20.0/algebra/Cauchy_COF.v000066400000000000000000001054031473720167500162500ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.COrdCauchy. Require Export CoRN.tactics.RingReflection. (** * The Field of Cauchy Sequences In this chapter we will prove that whenever we start from an ordered field [F], we can define a new ordered field of Cauchy sequences over [F]. %\begin{convention}% Let [F] be an ordered field. %\end{convention}% *) Section Structure. Variable F : COrdField. (** ** Setoid Structure [R_Set] is the setoid of Cauchy sequences over [F]; given two sequences [x,y] over [F], we say that [x] is smaller than [y] if from some point onwards [(y n) [-] (x n)] is greater than some fixed, positive [e]. Apartness of two sequences means that one of them is smaller than the other, equality is the negation of the apartness. *) Definition R_Set := CauchySeq F. Section CSetoid_Structure. Definition R_lt (x y : R_Set) := {N : nat | {e : F | [0] [<] e | forall n, N <= n -> e [<=] CS_seq _ y n[-]CS_seq _ x n}}. Definition R_ap (x y : R_Set) := R_lt x y or R_lt y x. Definition R_eq (x y : R_Set) := Not (R_ap x y). Lemma R_lt_cotrans : cotransitive R_lt. Proof. red in |- *. intros x y. elim x; intros x_ px. elim y; intros y_ py. intros Hxy z. elim z; intros z_ pz. elim Hxy; intros N H. elim H; clear Hxy H; intros e He HN. simpl in HN. set (e3 := e [/]ThreeNZ) in *. cut ([0] [<] e3); [ intro He3 | unfold e3 in |- *; apply pos_div_three; auto ]. set (e6 := e [/]SixNZ) in *. cut ([0] [<] e6); [ intro He6 | unfold e6 in |- *; apply pos_div_six; auto ]. set (e12 := e [/]TwelveNZ) in *. cut ([0] [<] e12); [ intro He12 | unfold e12 in |- *; apply pos_div_twelve; auto ]. set (e24 := e [/]TwentyFourNZ) in *. cut ([0] [<] e24); [ intro He24 | unfold e24 in |- *; apply pos_div_twentyfour; auto ]. elim (px e24 He24); intros Nx HNx. elim (py e24 He24); intros Ny HNy. elim (pz e24 He24); intros Nz HNz. set (NN := Nat.max N (Nat.max Nx (Nat.max Ny Nz))) in *. set (x0 := x_ NN) in *. set (y0 := y_ NN) in *. set (z0 := z_ NN) in *. elim (less_cotransitive_unfolded _ (x0[+]e3) (y0[-]e3)) with z0. intro Hyz. left. exists NN; exists e6; auto. intros n Hn; simpl in |- *. apply leEq_wdl with (e3[-] (e24[+]e24[+]e24[+]e24)). 2: unfold e3, e6, e12, e24 in |- *; rational. apply leEq_transitive with (e3[-] (z0[-]z_ Nz[+] (z_ Nz[-]z_ n) [+] (x_ n[-]x_ Nx) [+] (x_ Nx[-]x0))). apply minus_resp_leEq_rht. repeat apply plus_resp_leEq_both. unfold z0 in |- *; elim (HNz NN); auto; unfold NN in |- *; eauto with arith. apply shift_minus_leEq; apply shift_leEq_plus'. unfold cg_minus in |- *; apply shift_plus_leEq'. elim (HNz n); auto; apply Nat.le_trans with NN; auto; unfold NN in |- *; eauto with arith. elim (HNx n); auto; apply Nat.le_trans with NN; auto; unfold NN in |- *; eauto with arith. apply shift_minus_leEq; apply shift_leEq_plus'. unfold cg_minus in |- *; apply shift_plus_leEq'. unfold x0 in |- *; elim (HNx NN); auto; unfold NN in |- *; eauto with arith. apply shift_minus_leEq. rstepr (z0[-]x0). apply shift_leEq_minus; astepl (x0[+]e3); apply less_leEq; auto. intro Hzx. right. exists NN; exists e6; auto. intros n Hn; simpl in |- *. apply leEq_wdl with (e3[-] (e24[+]e24[+]e24[+]e24)). 2: unfold e3, e6, e12, e24 in |- *; rational. apply leEq_transitive with (e3[-] (z_ Nz[-]z0[+] (z_ n[-]z_ Nz) [+] (y_ Ny[-]y_ n) [+] (y0[-]y_ Ny))). apply minus_resp_leEq_rht. repeat apply plus_resp_leEq_both. apply shift_minus_leEq; apply shift_leEq_plus'. unfold cg_minus in |- *; apply shift_plus_leEq'. unfold z0 in |- *; elim (HNz NN); auto; unfold NN in |- *; eauto with arith. elim (HNz n); auto; apply Nat.le_trans with NN; auto; unfold NN in |- *; eauto with arith. apply shift_minus_leEq; apply shift_leEq_plus'. unfold cg_minus in |- *; apply shift_plus_leEq'. elim (HNy n); auto; apply Nat.le_trans with NN; auto; unfold NN in |- *; eauto with arith. unfold y0 in |- *; elim (HNy NN); auto; unfold NN in |- *; eauto with arith. apply shift_minus_leEq. rstepr (y0[-]z0). apply shift_leEq_minus; apply shift_plus_leEq'; apply less_leEq; auto. apply shift_less_minus. astepl (x0[+] (e3[+]e3)); apply shift_plus_less'. apply less_leEq_trans with e. apply shift_plus_less. apply less_wdl with ((e[-]e3) [/]TwoNZ). 2: unfold e3 in |- *; rational. apply pos_div_two'. apply shift_less_minus; astepl e3; unfold e3 in |- *; apply pos_div_three'; auto. unfold x0, y0, NN in |- *; apply HN; eauto with arith. Qed. Lemma R_ap_cotrans : cotransitive R_ap. Proof. red in |- *; intros x y Hxy z. elim Hxy; intro H; elim (R_lt_cotrans _ _ H z); unfold R_ap in |- *; auto. Qed. Lemma R_ap_symmetric : Csymmetric R_ap. Proof. red in |- *; intros x y Hxy. elim Hxy; unfold R_ap in |- *; auto. Qed. Lemma R_lt_irreflexive : irreflexive R_lt. Proof. red in |- *; intros x Hx. elim Hx; intros N HN. elim HN; clear Hx HN; intros e He HN. apply (ap_irreflexive_unfolded _ (x N)). apply less_imp_ap. apply less_leEq_trans with (x N[+]e). astepl (x N[+][0]); apply plus_resp_less_lft; auto. apply shift_plus_leEq'; auto with arith. Qed. Lemma R_ap_irreflexive : irreflexive R_ap. Proof. red in |- *; intros x Hx. elim (R_lt_irreflexive x). elim Hx; auto. Qed. Lemma R_ap_eq_tight : tight_apart R_eq R_ap. Proof. split; auto. Qed. Definition R_CSetoid : CSetoid. Proof. apply Build_CSetoid with R_Set R_eq R_ap. split. exact R_ap_irreflexive. exact R_ap_symmetric. exact R_ap_cotrans. exact R_ap_eq_tight. Defined. End CSetoid_Structure. Section Group_Structure. (** ** Group Structure The group structure is just the expected one; the lemmas which are specifically proved are just the necessary ones to get the group axioms. *) Definition R_plus (x y : R_CSetoid) : R_CSetoid := Build_CauchySeq _ _ (CS_seq_plus F _ _ (CS_proof _ x) (CS_proof _ y)). Definition R_zero := Build_CauchySeq _ _ (CS_seq_const F [0]). Lemma R_plus_lft_ext : forall x y z, R_plus x z [#] R_plus y z -> x [#] y. Proof. intros x y z Hxy. elim Hxy; clear Hxy; intro H; [ left | right ]; elim H; intros N HN; elim HN; clear H HN; intros e He HN; exists N; exists e; auto; intros n Hn; simpl in HN. rstepr (CS_seq _ y n[+]CS_seq _ z n[-] (CS_seq _ x n[+]CS_seq _ z n)); auto. rstepr (CS_seq _ x n[+]CS_seq _ z n[-] (CS_seq _ y n[+]CS_seq _ z n)); auto. Qed. Lemma R_plus_assoc : associative R_plus. Proof. intros x y z Hap. elim Hap; clear Hap; intro H; elim H; intros N HN; elim HN; clear H HN; intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with (CS_seq _ x N[+]CS_seq _ y N[+]CS_seq _ z N[-] (CS_seq _ x N[+] (CS_seq _ y N[+]CS_seq _ z N))); auto. rstepl ([0]:F); auto. apply leEq_less_trans with (CS_seq _ x N[+] (CS_seq _ y N[+]CS_seq _ z N) [-] (CS_seq _ x N[+]CS_seq _ y N[+]CS_seq _ z N)); auto. rstepl ([0]:F); auto. Qed. Lemma R_zero_lft_unit : forall x, R_plus R_zero x [=] x. Proof. intro x; intro x_ap. apply (R_lt_irreflexive x). elim x_ap; clear x_ap; intro x_lt; elim x_lt; intros N H; elim H; clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn. astepr (CS_seq _ x n[-] ([0][+]CS_seq _ x n)); auto. astepr ([0][+]CS_seq _ x n[-]CS_seq _ x n); auto. Qed. Lemma R_plus_comm : forall x y, R_plus x y [=] R_plus y x. Proof. intros x y Hxy. elim Hxy; clear Hxy; intro H; elim H; intros N HN; elim HN; clear H HN; intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with (CS_seq _ y N[+]CS_seq _ x N[-] (CS_seq _ x N[+]CS_seq _ y N)); auto. rstepl ([0]:F); auto. apply leEq_less_trans with (CS_seq _ x N[+]CS_seq _ y N[-] (CS_seq _ y N[+]CS_seq _ x N)); auto. rstepl ([0]:F); auto. Qed. Definition R_inv (x : R_CSetoid) : R_CSetoid := Build_CauchySeq _ _ (CS_seq_inv F _ (CS_proof _ x)). Lemma R_inv_is_inv : forall x, R_plus x (R_inv x) [=] R_zero. Proof. intro x; intro x_ap. apply (R_lt_irreflexive R_zero). elim x_ap; clear x_ap; intro x_lt; elim x_lt; intros N H; elim H; clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn. simpl in |- *; astepr ([0][-] (CS_seq _ x n[+][--] (CS_seq _ x n))); auto. simpl in |- *; astepr (CS_seq _ x n[+][--] (CS_seq _ x n) [-][0]); auto. Qed. Lemma R_inv_ext : un_op_strext _ R_inv. Proof. intros x y Hxy. elim Hxy; clear Hxy; intro x_lt; [ right | left ]; elim x_lt; intros N H; elim H; clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn. rstepr ([--] (CS_seq _ y n) [-][--] (CS_seq _ x n)); auto. rstepr ([--] (CS_seq _ x n) [-][--] (CS_seq _ y n)); auto. Qed. Definition Rinv : CSetoid_un_op R_CSetoid. Proof. red in |- *. apply Build_CSetoid_un_op with R_inv. exact R_inv_ext. Defined. Definition R_CAbGroup : CAbGroup. Proof. apply Build_CAbGroup' with R_CSetoid R_zero R_plus Rinv. exact R_plus_lft_ext. exact R_zero_lft_unit. exact R_plus_comm. exact R_plus_assoc. exact R_inv_is_inv. Defined. End Group_Structure. Section Ring_Structure. (** ** Ring Structure Same comments as previously. *) Definition R_mult (x y : R_CAbGroup) : R_CAbGroup := Build_CauchySeq _ _ (CS_seq_mult F _ _ (CS_proof _ x) (CS_proof _ y)). Definition R_one : R_CAbGroup := Build_CauchySeq _ _ (CS_seq_const F [1]). Lemma R_one_ap_zero : R_one [#] [0]. Proof. right; exists 0; exists ([1]:F). apply pos_one. intros; simpl in |- *; astepr ([1]:F); apply leEq_reflexive. Qed. Lemma R_mult_dist_plus : forall x y z, R_mult x (y[+]z) [=] R_mult x y[+]R_mult x z. Proof. intros x y z H. elim H; intro Hlt; elim Hlt; intros N HN; elim HN; clear H Hlt HN; intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e). eapply leEq_less_trans. apply (HN N (le_n _)). rstepl ([0]:F); auto. eapply leEq_less_trans. apply (HN N (le_n _)). rstepl ([0]:F); auto. Qed. Lemma R_mult_dist_minus : forall x y z, R_mult x (y[-]z) [=] R_mult x y[-]R_mult x z. Proof. intros x y z H. elim H; intro Hlt; elim Hlt; intros N HN; elim HN; clear H Hlt HN; intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e). eapply leEq_less_trans. apply (HN N (le_n _)). rstepl ([0]:F); auto. eapply leEq_less_trans. apply (HN N (le_n _)). rstepl ([0]:F); auto. Qed. Lemma R_one_rht_unit : forall x, R_mult x R_one [=] x. Proof. intro x; intro x_ap. apply (R_lt_irreflexive x). elim x_ap; clear x_ap; intro x_lt; elim x_lt; intros N H; elim H; clear x_lt H; intros e He HN; exists N; exists e; auto; simpl in HN; intros n Hn. astepr (CS_seq _ x n[-]CS_seq _ x n[*][1]); auto. astepr (CS_seq _ x n[*][1][-]CS_seq _ x n); auto. Qed. Lemma R_mult_comm : forall x y, R_mult x y [=] R_mult y x. Proof. intros x y Hxy. elim Hxy; clear Hxy; intro H; elim H; intros N HN; elim HN; clear H HN; intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with (CS_seq _ y N[*]CS_seq _ x N[-]CS_seq _ x N[*]CS_seq _ y N); auto. rstepl ([0]:F); auto. apply leEq_less_trans with (CS_seq _ x N[*]CS_seq _ y N[-]CS_seq _ y N[*]CS_seq _ x N); auto. rstepl ([0]:F); auto. Qed. Lemma R_mult_ap_zero' : forall x y, R_mult x y [#] [0] -> x [#] [0]. Proof. intros x y Hxy. elim (CS_seq_bounded _ (CS_seq _ y) (CS_proof _ y)); intros K HK Hy; elim Hy; clear Hy; intros Ny HNY. set (z := Build_CauchySeq _ _ (CS_seq_mult _ _ _ (CS_seq_const _ (Two[*]K)) (CS_proof _ x)) :R_CAbGroup) in *. elim (ap_cotransitive_unfolded _ _ _ Hxy z); intro Hap; elim Hap; intro Hlt; elim Hlt; intros N HN; elim HN; clear Hap Hlt HN; intros e He HN. right. cut (forall n : nat, Ny <= n -> [0] [<] Two[*]K[-]CS_seq _ y n); [ intro Hy' | intros n Hn ]. set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)) in *. exists (Nat.max N Ny); exists KK. unfold KK in |- *; apply div_resp_pos; auto. apply mult_resp_pos; auto; apply pos_three. intros; simpl in |- *; unfold KK in |- *. cut (N <= n); [ intro Hn | apply Nat.le_trans with (Nat.max N Ny); auto with arith ]. cut (Ny <= n); [ intro Hn' | apply Nat.le_trans with (Nat.max N Ny); auto with arith ]. apply leEq_transitive with (e[/] _[//]pos_ap_zero _ _ (Hy' n Hn')). apply mult_cancel_leEq with ([1][/] _[//]pos_ap_zero _ _ He). apply recip_resp_pos; auto. rstepl ([1][/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)). rstepr ([1][/] _[//]pos_ap_zero _ _ (Hy' n Hn')). apply recip_resp_leEq; auto. unfold cg_minus in |- *; apply shift_plus_leEq'; rstepr ([--][--]K). apply inv_resp_leEq; elim (HNY n); auto. apply shift_div_leEq; auto. eapply leEq_wdr. apply (HN n); auto. simpl in |- *; rational. apply shift_zero_less_minus; apply leEq_less_trans with K. elim (HNY n); auto. astepl ([0][+]K); astepr (K[+]K); apply plus_resp_less_rht; auto. left. cut (forall n : nat, Ny <= n -> [0] [<] Two[*]K[-]CS_seq _ y n); [ intro Hy' | intros n Hn ]. set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)) in *. exists (Nat.max N Ny); exists KK. unfold KK in |- *; apply div_resp_pos; auto. apply mult_resp_pos; auto; apply pos_three. intros; simpl in |- *; unfold KK in |- *. cut (N <= n); [ intro Hn | apply Nat.le_trans with (Nat.max N Ny); auto with arith ]. cut (Ny <= n); [ intro Hn' | apply Nat.le_trans with (Nat.max N Ny); auto with arith ]. apply leEq_transitive with (e[/] _[//]pos_ap_zero _ _ (Hy' n Hn')). apply mult_cancel_leEq with ([1][/] _[//]pos_ap_zero _ _ He). apply recip_resp_pos; auto. rstepl ([1][/] _[//]mult_resp_ap_zero _ _ _ (three_ap_zero _) (pos_ap_zero _ _ HK)). rstepr ([1][/] _[//]pos_ap_zero _ _ (Hy' n Hn')). apply recip_resp_leEq; auto. unfold cg_minus in |- *; apply shift_plus_leEq'; rstepr ([--][--]K). apply inv_resp_leEq; elim (HNY n); auto. apply shift_div_leEq; auto. eapply leEq_wdr. apply (HN n); auto. simpl in |- *; rational. apply shift_zero_less_minus; apply leEq_less_trans with K. elim (HNY n); auto. astepl ([0][+]K); astepr (K[+]K); apply plus_resp_less_rht; auto. left. set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (two_ap_zero _) (pos_ap_zero _ _ HK)) in *. exists N; exists KK. unfold KK in |- *; apply div_resp_pos; auto. apply mult_resp_pos; auto; apply pos_two. intros; simpl in |- *; unfold KK in |- *. apply shift_div_leEq. apply mult_resp_pos; auto; apply pos_two. eapply leEq_wdr. apply (HN n H). simpl in |- *; rational. right. set (KK := e[/] _[//]mult_resp_ap_zero _ _ _ (two_ap_zero _) (pos_ap_zero _ _ HK)) in *. exists N; exists KK. unfold KK in |- *; apply div_resp_pos; auto. apply mult_resp_pos; auto; apply pos_two. intros; simpl in |- *; unfold KK in |- *. apply shift_div_leEq. apply mult_resp_pos; auto; apply pos_two. eapply leEq_wdr. apply (HN n H). simpl in |- *; rational. Qed. Lemma R_mult_lft_ext : forall x y z, R_mult x z [#] R_mult y z -> x [#] y. Proof. intros x y z Hxy. apply zero_minus_apart. apply R_mult_ap_zero' with z. apply ap_wdl_unfolded with (R_mult x z[-]R_mult y z). apply minus_ap_zero; auto. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply R_mult_comm. eapply eq_transitive_unfolded. apply R_mult_dist_minus. apply cg_minus_wd; apply R_mult_comm. Qed. Lemma R_mult_rht_ext : forall x y z, R_mult x y [#] R_mult x z -> y [#] z. Proof. intros x y z Hxy. apply R_mult_lft_ext with x. eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply Hxy. apply R_mult_comm. apply R_mult_comm. Qed. Lemma R_mult_strext : bin_op_strext _ R_mult. Proof. red in |- *; red in |- *. intros x y a b Hap. elim (ap_cotransitive_unfolded _ _ _ Hap (R_mult x b)); intro H. right; apply R_mult_rht_ext with x; auto. left; apply R_mult_lft_ext with b; auto. Qed. Definition Rmult : CSetoid_bin_op R_CAbGroup. Proof. red in |- *. apply Build_CSetoid_bin_fun with R_mult. apply R_mult_strext. Defined. Lemma R_mult_assoc : associative Rmult. Proof. intros x y z Hap. elim Hap; clear Hap; intro H; elim H; intros N HN; elim HN; clear H HN; intros e He HN; simpl in HN; apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with (CS_seq _ x N[*]CS_seq _ y N[*]CS_seq _ z N[-] CS_seq _ x N[*] (CS_seq _ y N[*]CS_seq _ z N)); auto. rstepl ([0]:F); auto. apply leEq_less_trans with (CS_seq _ x N[*] (CS_seq _ y N[*]CS_seq _ z N) [-] CS_seq _ x N[*]CS_seq _ y N[*]CS_seq _ z N); auto. rstepl ([0]:F); auto. Qed. Lemma R_one_lft_unit : forall x, R_mult R_one x [=] x. Proof. intro. eapply eq_transitive_unfolded. apply R_mult_comm. apply R_one_rht_unit. Qed. Definition R_CRing : CRing. Proof. apply Build_CRing with R_CAbGroup R_one Rmult. apply Build_is_CRing with R_mult_assoc. apply Build_is_CMonoid. exact R_one_rht_unit. exact R_one_lft_unit. exact R_mult_comm. exact R_mult_dist_plus. exact R_one_ap_zero. Defined. End Ring_Structure. Add Ring R_CRing: (CRing_Ring R_CRing). Section Field_Structure. (** ** Field Structure For the field structure, it is technically easier to first prove that our ring is actually an integral domain. The rest then follows quite straightforwardly. *) Lemma R_integral_domain : forall x y : R_CRing, x [#] [0] -> y [#] [0] -> x[*]y [#] [0]. Proof. intros x y Hx Hy. elim Hx; intro Hlt; elim Hlt; intros Nx HN; elim HN; clear Hx Hlt HN; intros ex Hex HNx; simpl in HNx; elim Hy; intro Hlt; elim Hlt; intros Ny HN; elim HN; clear Hy Hlt HN; intros ey Hey HNy; simpl in HNy. right. exists (Nat.max Nx Ny); exists (ex[*]ey). apply mult_resp_pos; auto. intros; simpl in |- *; rstepr ([--] (CS_seq _ x n) [*][--] (CS_seq _ y n)). apply mult_resp_leEq_both; try (apply less_leEq; assumption). astepr ([0][-]CS_seq _ x n); eauto with arith. astepr ([0][-]CS_seq _ y n); eauto with arith. left. exists (Nat.max Nx Ny); exists (ex[*]ey). apply mult_resp_pos; auto. intros; simpl in |- *; rstepr ([--] (CS_seq _ x n) [*]CS_seq _ y n). apply mult_resp_leEq_both; try (apply less_leEq; assumption). astepr ([0][-]CS_seq _ x n); eauto with arith. astepr (CS_seq _ y n[-][0]); eauto with arith. left. exists (Nat.max Nx Ny); exists (ex[*]ey). apply mult_resp_pos; auto. intros; simpl in |- *; rstepr (CS_seq _ x n[*][--] (CS_seq _ y n)). apply mult_resp_leEq_both; try (apply less_leEq; assumption). astepr (CS_seq _ x n[-][0]); eauto with arith. astepr ([0][-]CS_seq _ y n); eauto with arith. right. exists (Nat.max Nx Ny); exists (ex[*]ey). apply mult_resp_pos; auto. intros; simpl in |- *; astepr (CS_seq _ x n[*]CS_seq _ y n). apply mult_resp_leEq_both; try (apply less_leEq; assumption). astepr (CS_seq _ x n[-][0]); eauto with arith. astepr (CS_seq _ y n[-][0]); eauto with arith. Qed. Definition R_recip : forall x : R_CRing, x [#] [0] -> R_CRing. intros x Hx; elim Hx; intro Hlt; elim Hlt; intros N HN; elim HN; clear Hx Hlt HN; intros e He HN. Proof. cut (forall n : nat, N <= n -> e [<=] [--] (CS_seq _ x n)); intros. apply (Build_CauchySeq _ _ (CS_seq_inv _ _ (CS_seq_recip _ _ (CS_seq_inv _ _ (CS_proof _ x)) e He N H))). astepr ([0][-]CS_seq _ x n); simpl in HN; auto. cut (forall n : nat, N <= n -> e [<=] CS_seq _ x n); intros. apply (Build_CauchySeq _ _ (CS_seq_recip _ _ (CS_proof _ x) e He N H)). astepr (CS_seq _ x n[-][0]); simpl in HN; auto. Defined. Lemma R_recip_inverse : forall x x_, x[*]R_recip x x_ [=] [1]. Proof. intros x Hx; elim Hx; intro Hlt; elim Hlt; intros N HN; elim HN; clear Hx Hlt HN; simpl in |- *; intros e He HN Hap; elim Hap; intro Hlt; elim Hlt; intros K HK; elim HK; clear Hap Hlt HK; intros d Hd HM; simpl in HM. apply (less_irreflexive_unfolded _ d). apply leEq_less_trans with ([0]:F); auto. simpl in HM. eapply leEq_wdr. apply (HM (Nat.max K N)); auto with arith. unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro. exfalso; apply Nat.le_ngt with N (Nat.max K N); auto with arith. simpl in |- *; rational. apply (less_irreflexive_unfolded _ d). apply leEq_less_trans with ([0]:F); auto. simpl in HM. eapply leEq_wdr. apply (HM (Nat.max K N)); auto with arith. unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro. exfalso; apply Nat.le_ngt with N (Nat.max K N); auto with arith. simpl in |- *; rational. apply (less_irreflexive_unfolded _ d). apply leEq_less_trans with ([0]:F); auto. simpl in HM. eapply leEq_wdr. apply (HM (Nat.max K N)); auto with arith. unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro. exfalso; apply Nat.le_ngt with N (Nat.max K N); auto with arith. simpl in |- *; rational. apply (less_irreflexive_unfolded _ d). apply leEq_less_trans with ([0]:F); auto. simpl in HM. eapply leEq_wdr. apply (HM (Nat.max K N)); auto with arith. unfold CS_seq_recip_seq in |- *; elim lt_le_dec; intro. exfalso; apply Nat.le_ngt with N (Nat.max K N); auto with arith. simpl in |- *; rational. Qed. Lemma R_recip_strext : forall x y x_ y_, R_recip x x_ [#] R_recip y y_ -> x [#] y. Proof. intros. apply zero_minus_apart. apply ap_wdl with (x[*]y[*] (R_recip y y_[-]R_recip x x_)). apply R_integral_domain. apply R_integral_domain; auto. apply minus_ap_zero; apply ap_symmetric_unfolded; auto. stepl (y[*]R_recip y y_[*]x[-]x[*]R_recip x x_[*]y). 2: unfold cg_minus; ring. stepr ([1][*]x[-][1][*]y). 2: unfold cg_minus; ring. apply cg_minus_wd; apply mult_wdl; apply R_recip_inverse. Qed. Lemma R_recip_inverse' : forall x x_, R_recip x x_[*]x [=] [1]. Proof. intros. astepl (x[*]R_recip x x_). apply R_recip_inverse. Qed. Definition R_CField : CField. Proof. apply Build_CField with R_CRing R_recip. split. apply R_recip_inverse. apply R_recip_inverse'. exact R_recip_strext. Defined. End Field_Structure. Section Order. (** ** Order Structure Finally, we extend the field structure with the ordering we defined at the beginning. *) Lemma R_lt_strext : Crel_strext R_CSetoid R_lt. Proof. intros x a y b Hxy. elim (R_lt_cotrans x y Hxy a); intro H. right; left; left; auto. elim (R_lt_cotrans a y H b); intro H'. left; auto. right; right; right; auto. Qed. Definition Rlt : CCSetoid_relation R_CField. Proof. apply Build_CCSetoid_relation with R_lt. exact R_lt_strext. Defined. Lemma Rlt_transitive : Ctransitive Rlt. Proof. intros x y z H H'. simpl in H, H'. elim H; intros N1 HN1; elim HN1; clear H HN1; intros e1 He1 HN1. elim H'; intros N2 HN2; elim HN2; clear H' HN2; intros e2 He2 HN2. exists (Nat.max N1 N2); exists (e1[+]e2). apply plus_resp_pos; auto. intros; rstepr (CS_seq _ y n[-]CS_seq _ x n[+] (CS_seq _ z n[-]CS_seq _ y n)). apply plus_resp_leEq_both; eauto with arith. Qed. Lemma Rlt_strict : strictorder Rlt. Proof. apply Build_strictorder. exact Rlt_transitive. intros x y H H'. apply R_lt_irreflexive with x. apply Rlt_transitive with y; auto. Qed. Lemma R_plus_resp_lt : forall x y, Rlt x y -> forall z, Rlt (x[+]z) (y[+]z). Proof. intros x y Hxy z. elim Hxy; intros N HN; elim HN; clear Hxy HN; intros e He HN; exists N; exists e; auto; intros n Hn. simpl in |- *; rstepr (CS_seq _ y n[-]CS_seq _ x n); auto. Qed. Lemma R_mult_resp_lt : forall x y, Rlt [0] x -> Rlt [0] y -> Rlt [0] (x[*]y). Proof. intros x y Hx Hy. elim Hx; intros Nx HN; elim HN; clear Hx HN; intros ex Hex HNx; simpl in HNx; elim Hy; intros Ny HN; elim HN; clear Hy HN; intros ey Hey HNy; simpl in HNy. exists (Nat.max Nx Ny); exists (ex[*]ey). apply mult_resp_pos; auto. intros; simpl in |- *; astepr (CS_seq _ x n[*]CS_seq _ y n). apply mult_resp_leEq_both; try (apply less_leEq; assumption). astepr (CS_seq _ x n[-][0]); eauto with arith. astepr (CS_seq _ y n[-][0]); eauto with arith. Qed. Definition R_COrdField : COrdField. Proof. apply Build_COrdField with R_CField Rlt (default_leEq _ Rlt) (default_greater _ Rlt) (default_grEq _ (default_leEq _ Rlt)). apply Build_is_COrdField; try solve [unfold Iff; tauto]. exact Rlt_strict. exact R_plus_resp_lt. exact R_mult_resp_lt. split; auto. Defined. End Order. (** ** Other Results Auxiliary characterizations of the main relations on [R_Set]. *) Section Auxiliary. Lemma Rlt_alt_1 : forall x y : R_Set, {e : F | [0] [<] e | {N : nat | forall m, N <= m -> e [<=] CS_seq F y m[-]CS_seq F x m}} -> Rlt x y. Proof. intros x y H. case H. intro e1. intros H1 H2. case H2. intro N1. intros H3. unfold Rlt in |- *. exists N1. exists (e1 [/]TwoNZ). apply pos_div_two. assumption. intros. apply leEq_transitive with e1. apply mult_cancel_leEq with (Two:F). apply pos_two. rstepl (e1[+] ([0]:F)). rstepr (e1[+]e1). apply plus_resp_leEq_lft. apply less_leEq; assumption. apply H3. assumption. Qed. Lemma Rlt_alt_2 : forall x y : R_Set, Rlt x y -> {e : F | [0] [<] e | {N : nat | forall m, N <= m -> e [<=] CS_seq F y m[-]CS_seq F x m}}. Proof. intros x y H. unfold Rlt in H. case H. intros N H2. case H2. intros e H1 H0. exists e. assumption. exists N. auto. Qed. Lemma R_ap_alt_1 : forall x y : R_CSetoid, x [#] y -> {e : F | [0] [<] e | {N : nat | forall m, N <= m -> AbsBig e (CS_seq F x m[-]CS_seq F y m)}}. Proof. intros x y H. case H; intros H0. case H0; intros N1 HN1. case HN1; intros e1 H2 H31. exists e1. assumption. exists N1. split. assumption. right. apply inv_cancel_leEq. rstepl e1. rstepr (CS_seq F y m[-]CS_seq F x m). apply H31. assumption. case H0; intros N1 HN1. case HN1; intros e1 H2 H31. exists e1. assumption. exists N1. split; try left; auto. Qed. Lemma Eq_alt_1 : forall (x y : R_Set) (e : F), [0] [<] e -> Not {N : nat | forall m, N <= m -> AbsBig (e [/]FourNZ) (CS_seq F x m[-]CS_seq F y m)} -> {N : nat | forall m, N <= m -> AbsSmall e (CS_seq F x m[-]CS_seq F y m)}. Proof. intros x y e H. set (e2 := e [/]TwoNZ) in *. set (e4 := e [/]FourNZ) in *. set (e8 := e [/]EightNZ) in *. set (e16 := e [/]SixteenNZ) in *. assert (He2 : [0] [<] e2). unfold e2 in |- *; apply pos_div_two; assumption. assert (He4 : [0] [<] e4). unfold e4 in |- *; apply pos_div_four; assumption. assert (He8 : [0] [<] e8). unfold e8 in |- *; apply pos_div_eight; assumption. assert (He16 : [0] [<] e16). unfold e16 in |- *; apply pos_div_sixteen; assumption. case x; intros x_ px. case y; intros y_ py. unfold CS_seq in |- *; intro. case (px e16 He16); intros N1 px2. case (py e16 He16); intros N2 py2. set (NN := Nat.max N1 N2) in *. assert (N1_NN : N1 <= NN). unfold NN in |- *; auto with arith. assert (N2_NN : N2 <= NN). unfold NN in |- *; auto with arith. exists NN. cut (forall m : nat, Not (NN <= m and AbsBig e2 (x_ m[-]y_ m))). intros. unfold AbsSmall in |- *. assert (H3 : Not (AbsBig e2 (x_ m[-]y_ m))). intro; elim (H1 m); split; assumption. assert (H4 : ~ e2 [<=] x_ m[-]y_ m). intro; apply H3; split; try left; assumption. assert (H5 : ~ x_ m[-]y_ m [<=] [--]e2). intro; apply H3; split; try right; assumption. split; rewrite -> leEq_def; intro. apply H5. apply leEq_transitive with ([--]e). apply less_leEq; assumption. apply less_leEq; apply inv_resp_less. unfold e2 in |- *; apply pos_div_two'; assumption. apply H4. apply leEq_transitive with e. apply less_leEq; unfold e2 in |- *; apply pos_div_two'; auto. apply less_leEq; assumption. intro. intro H1. elim H1; intros X Y. elim H0. exists NN. intros. apply AbsBig_wdl with (e2[-]e8[-]e8). 2: unfold e2, e4, e8 in |- *; rational. apply AbsBig_wdr with (x_ m[-]y_ m[-] (x_ m[-]x_ m0) [-] (y_ m0[-]y_ m)). 2: rational. assert (e8 [<] e2). unfold e2, e8 in |- *. rstepl ((e [/]TwoNZ) [/]FourNZ). rstepr (e [/]TwoNZ). apply pos_div_four'. assumption. assert ([0] [<] e2[-]e8). apply plus_cancel_less with e8. rstepl e8. rstepr e2. assumption. assert (e8 [<] e2[-]e8). apply plus_cancel_less with e8. rstepr e2. unfold e2, e8 in |- *; rstepl (e [/]FourNZ). rstepl ((e [/]TwoNZ) [/]TwoNZ). apply pos_div_two'. assumption. apply AbsBigSmall_minus; auto. apply AbsBigSmall_minus; auto. unfold e8 in |- *. rstepl (e [/]SixteenNZ[+]e [/]SixteenNZ). rstepr (x_ m[-]x_ N1[+] (x_ N1[-]x_ m0)). apply AbsSmall_plus. apply px2. apply Nat.le_trans with NN; assumption. apply AbsSmall_minus. apply px2. apply Nat.le_trans with NN; assumption. unfold e8 in |- *. rstepl (e [/]SixteenNZ[+]e [/]SixteenNZ). rstepr (y_ m0[-]y_ N2[+] (y_ N2[-]y_ m)). apply AbsSmall_plus. apply py2. apply Nat.le_trans with NN; assumption. apply AbsSmall_minus. apply py2. apply Nat.le_trans with NN; assumption. Qed. Lemma R_ap_alt_2 : forall x y : R_CSetoid, {e : F | [0] [<] e | {N : nat | forall m, N <= m -> AbsBig e (CS_seq F x m[-]CS_seq F y m)}} -> x [#] y. Proof. intros x y H. case H. intros e H0. set (e2 := e [/]TwoNZ) in *. set (e4 := e [/]FourNZ) in *. set (e8 := e [/]EightNZ) in *. set (e16 := e [/]SixteenNZ) in *. assert (He2 : [0] [<] e2). unfold e2 in |- *; apply pos_div_two; assumption. assert (He4 : [0] [<] e4). unfold e4 in |- *; apply pos_div_four; assumption. assert (He8 : [0] [<] e8). unfold e8 in |- *; apply pos_div_eight; assumption. assert (He16 : [0] [<] e16). unfold e16 in |- *; apply pos_div_sixteen; assumption. case x; intros x_ px. case y; intros y_ py. case (px e16 He16); intros N1 H31. case (py e16 He16); intros N2 H41. simpl in |- *; intro H2; case H2; intros N H21. set (NN := Nat.max N (Nat.max N1 N2)) in *. assert (N_NN : N <= NN). unfold NN in |- *; auto with arith. assert (N1_NN : N1 <= NN). unfold NN in |- *; apply Nat.le_trans with (Nat.max N1 N2); auto with arith. assert (N2_NN : N2 <= NN). unfold NN in |- *; apply Nat.le_trans with (Nat.max N1 N2); auto with arith. set (x0 := x_ NN) in *. set (y0 := y_ NN) in *. simpl in |- *. unfold R_ap in |- *. unfold R_lt in |- *. simpl in |- *. assert (H5 : AbsBig e2 (x0[-]y0)). assert (e2 [<=] e). unfold e2 in |- *; apply less_leEq; apply pos_div_two'; auto. split; auto. elim (H21 NN). intros H' Haux; elim Haux; intros; [ left | right ]. apply leEq_transitive with e; auto. apply leEq_transitive with ([--]e); auto; apply inv_resp_leEq; auto. unfold NN in |- *; auto with arith. case H5; intros Hx s; case s; intro H6. right. exists NN. exists e4. assumption. intro m; intros. astepl ([--]e8[+]e2[+][--]e8). 2: unfold e2, e8, e4 in |- *; rational. rstepr (x_ m[-]x0[+] (x0[-]y0) [+] (y0[-]y_ m)). apply plus_resp_leEq_both. apply plus_resp_leEq_both. astepl ([--]e16[+][--]e16). 2: unfold e16, e8 in |- *; rational. rstepr (x_ m[-]x_ N1[+] (x_ N1[-]x0)). apply plus_resp_leEq_both. assert (H7 : AbsSmall e16 (x_ m[-]x_ N1)). apply H31; apply Nat.le_trans with NN; auto. elim H7; intros. rstepl ([--]e16). assumption. assert (H7 : AbsSmall e16 (x_ N1[-]x0)). apply AbsSmall_minus. unfold x0 in |- *; auto. elim H7; intros. rstepl ([--]e16). assumption. (* e *) assumption. (* e *) astepl ([--]e16[+][--]e16). 2: unfold e16, e8 in |- *; rational. rstepr (y0[-]y_ N2[+] (y_ N2[-]y_ m)). apply plus_resp_leEq_both. assert (H7 : AbsSmall e16 (y0[-]y_ N2)). unfold y0 in |- *; auto. elim H7; intros. rstepl ([--]e16). assumption. assert (H7 : AbsSmall e16 (y_ N2[-]y_ m)). apply AbsSmall_minus. apply H41. apply Nat.le_trans with NN; auto. elim H7; intros. rstepl ([--]e16). assumption. left. exists NN. exists e4. assumption. intro m; intros. astepl ([--]e8[+]e2[+][--]e8). 2: unfold e8, e2, e4 in |- *; rational. rstepr (y_ m[-]y0[+] (y0[-]x0) [+] (x0[-]x_ m)). apply plus_resp_leEq_both. apply plus_resp_leEq_both. astepl ([--]e16[+][--]e16). 2: unfold e16, e8 in |- *; rational. rstepr (y_ m[-]y_ N2[+] (y_ N2[-]y0)). apply plus_resp_leEq_both. assert (H8 : AbsSmall e16 (y_ m[-]y_ N2)). apply H41. apply Nat.le_trans with NN; auto. elim H8; intros. rstepl ([--]e16). assumption. assert (H8 : AbsSmall e16 (y_ N2[-]y0)). apply AbsSmall_minus. unfold y0 in |- *; auto. elim H8; intros. rstepl ([--]e16). assumption. (* e *) apply inv_cancel_leEq. rstepl (x0[-]y0). assumption. (* e *) astepl ([--]e16[+][--]e16). 2: unfold e16, e8 in |- *; rational. rstepr (x0[-]x_ N1[+] (x_ N1[-]x_ m)). apply plus_resp_leEq_both. assert (H8 : AbsSmall e16 (x0[-]x_ N1)). unfold x0 in |- *; auto. elim H8; intros. rstepl ([--]e16). assumption. assert (H8 : AbsSmall e16 (x_ N1[-]x_ m)). apply AbsSmall_minus. apply H31. apply Nat.le_trans with NN; auto. elim H8; intros. rstepl ([--]e16). assumption. Qed. Lemma Eq_alt_2_1 : forall x y : R_Set, Not (R_ap x y) -> forall e : F, [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (CS_seq F x m[-]CS_seq F y m)}. Proof. intros. apply Eq_alt_1. assumption. intro. apply H. apply R_ap_alt_2. exists (e [/]FourNZ). apply pos_div_four; auto. assumption. Qed. Lemma Eq_alt_2_2 : forall x y : R_Set, (forall e : F, [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (CS_seq F x m[-]CS_seq F y m)}) -> Not (R_ap x y). Proof. intros x y. case x; intros x_ px. case y; intros y_ py. simpl in |- *. intros H. intro H0. assert (H1 : {e : F | [0] [<] e | {N : nat | forall m : nat, N <= m -> AbsBig (Two[*]e) (x_ m[-]y_ m)}}). elim (R_ap_alt_1 _ _ H0). intros e H1 H2. exists (e [/]TwoNZ). apply pos_div_two; assumption. elim H2; intros N HN. exists N. intros. apply AbsBig_wdl with e; [ auto | rational ]. case H1. intros e H2 H3. case H3; intros N1 A. case (H e H2); intros N2 B. set (NN := Nat.max N1 N2) in *. assert (N1_NN : N1 <= NN). unfold NN in |- *; auto with arith. assert (N2_NN : N2 <= NN). unfold NN in |- *; auto with arith. assert (H4 := A NN N1_NN). assert (H5 := B NN N2_NN). unfold AbsSmall in H5. rewrite -> leEq_def in H5. elim H5; intros. elim H4; intros. elim b; intros. rewrite -> leEq_def in H7; apply H7. apply less_leEq_trans with (Two[*]e). astepl ([0][+]e). rstepr (e[+]e). apply plus_resp_less_rht; auto. assumption. apply H6. apply leEq_less_trans with ([--] (Two[*]e)). auto. apply inv_resp_less. astepl ([0][+]e); rstepr (e[+]e). apply plus_resp_less_rht; auto. Qed. End Auxiliary. End Structure. corn-8.20.0/algebra/CornScope.v000066400000000000000000000020641473720167500162370ustar00rootroot00000000000000Require Export CoRN.algebra.CSetoids. Delimit Scope corn_scope with corn. (* Open Scope corn_scope.*) Arguments cs_ap _ _%corn_scope _%corn_scope. Arguments cs_eq _ _%corn_scope _%corn_scope. (* Infix "#" := cs_ap (at level 70, no associativity) : corn_scope. *) Infix "==" := cs_eq (at level 70, no associativity) : corn_scope. Require Import CoRN.algebra.CSemiGroups. Arguments csg_op _ _%corn_scope _%corn_scope : extra scopes. Infix "+" := csg_op (at level 50, left associativity) : corn_scope. Require Import CoRN.algebra.CMonoids. Notation "0" := (cm_unit _) : corn_scope. Notation "(+)" := csg_op (only parsing) : corn_scope. Require Import CoRN.algebra.CGroups. Notation "- x" := (cg_inv x) (at level 35, right associativity) : corn_scope. Infix "-" := cg_minus (at level 50, left associativity) : corn_scope. Require Import CoRN.algebra.CRings. Arguments cr_mult _ _%corn_scope _%corn_scope : extra scopes. Infix "*" := cr_mult (at level 40, left associativity) : corn_scope. Notation "x ^ n" := (nexp_op _ n x) : corn_scope. Notation "1" := [1] : corn_scope. corn-8.20.0/algebra/Expon.v000066400000000000000000000521041473720167500154350ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [^^] %\ensuremath{\hat{\ }}% #^# *) From Coq Require Export Arith. Require Export CoRN.algebra.COrdCauchy. From Coq Require Import Lia. Load "Transparent_algebra". (** * Exponentiation ** More properties about [nexp] %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Section More_Nexp. Variable R : COrdField. Lemma nexp_resp_ap_zero : forall (x : R) n, x [#] [0] -> x[^]n [#] [0]. Proof. intros. elim n. simpl in |- *. algebra. intros. simpl in |- *. apply mult_resp_ap_zero. assumption. assumption. Qed. Hint Resolve nexp_resp_ap_zero: algebra. Lemma nexp_distr_div : forall (x y : R) n y_ yn_, (x[/] y[//]y_) [^]n [=] (x[^]n[/] y[^]n[//]yn_). Proof. simple induction n. intros. simpl in |- *. algebra. intros. simpl in |- *. generalize (H y_ (nexp_resp_ap_zero y n0 y_)); intro. astepl ((x[^]n0[/] y[^]n0[//]nexp_resp_ap_zero y n0 y_) [*] (x[/] y[//]y_)). simpl in |- *. rational. Qed. Lemma nexp_distr_div' : forall (x y : R) n y_, (x[/] y[//]y_) [^]n [=] (x[^]n[/] y[^]n[//]nexp_resp_ap_zero y n y_). Proof. intros. apply nexp_distr_div. Qed. Lemma small_nexp_resp_lt : forall (x : R) m n, [0] [<] x -> x [<] [1] -> m < n -> x[^]n [<] x[^]m. Proof. intros. cut (forall k : nat, 0 < k -> x[^]k [<] [1]). intro H2. replace n with (m + (n - m)). astepl (x[^]m[*]x[^] (n - m)). astepr (x[^]m[*][1]). apply mult_resp_less_lft. apply H2. lia. apply nexp_resp_pos. assumption. auto with arith. simple induction k. intro H2. exfalso. inversion H2. intros. elim n0. astepl x. assumption. intros. astepl (x[*]x[^]S n1). astepr ([1][*] ([1]:R)). apply mult_resp_less_both. apply less_leEq. assumption. assumption. apply less_leEq. apply nexp_resp_pos. assumption. assumption. Qed. Lemma great_nexp_resp_lt : forall (x : R) m n, [1] [<] x -> m < n -> x[^]m [<] x[^]n. Proof. intros. induction n as [| n Hrecn]; intros. exfalso. inversion H. cut (m <= n). intro. cut (x[^]n [<] x[^]S n). intro. elim (le_lt_eq_dec _ _ H0); intro y. apply less_transitive_unfolded with (x[^]n); auto. rewrite y. auto. astepl (x[^]n[*][1]). astepr (x[^]n[*]x). apply mult_resp_less_lft. auto. apply nexp_resp_pos. apply leEq_less_trans with ([1]:R). apply less_leEq. apply pos_one. auto. auto with arith. Qed. Lemma small_nexp_resp_le : forall (x : R) m n, [0] [<=] x -> x [<=] [1] -> m <= n -> x[^]n [<=] x[^]m. Proof. intros. cut (forall k : nat, x[^]k [<=] [1]). intro. replace n with (m + (n - m)). astepl (x[^]m[*]x[^] (n - m)). astepr (x[^]m[*][1]). apply mult_resp_leEq_lft. apply H2. apply nexp_resp_nonneg. auto. auto with arith. simple induction k. apply leEq_reflexive. clear H1 n; intros. astepl (x[^]n[*]x); astepr (([1]:R)[*][1]). apply mult_resp_leEq_both; auto. apply nexp_resp_nonneg; auto. Qed. Lemma great_nexp_resp_le : forall (x : R) m n, [1] [<=] x -> m <= n -> x[^]m [<=] x[^]n. Proof. intros. induction n as [| n Hrecn]; intros. replace m with 0. apply leEq_reflexive. auto with arith. elim (le_lt_eq_dec _ _ H0); intro. astepl (x[^]m[*][1]). astepr (x[^]n[*]x). apply mult_resp_leEq_both; auto with arith. apply nexp_resp_nonneg; auto. apply leEq_transitive with ([1]:R); auto. apply less_leEq. apply pos_one. apply less_leEq. apply pos_one. rewrite b. apply leEq_reflexive. Qed. Lemma nexp_resp_leEq : forall (x y : R) k, [0] [<=] x -> x [<=] y -> x[^]k [<=] y[^]k. Proof. intros. rewrite -> leEq_def in *. intro. apply H0. apply power_cancel_less with k; firstorder using leEq_def. Qed. Lemma nexp_resp_leEq_one : forall c : R, [0] [<=] c -> c [<=] [1] -> forall n, c[^]n [<=] [1]. Proof. simple induction n. red in |- *; apply eq_imp_leEq. algebra. clear n; intros. astepl (c[^]n[*]c). astepr (([1]:R)[*][1]). apply mult_resp_leEq_both; auto. apply nexp_resp_nonneg; assumption. Qed. Lemma nexp_resp_leEq_neg_even : forall n, Nat.Even n -> forall x y : R, y [<=] [0] -> x [<=] y -> y[^]n [<=] x[^]n. Proof. do 2 intro; pattern n in |- *; apply even_ind; [| | assumption]. intros; simpl in |- *; apply leEq_reflexive. clear H n; intros. astepr (x[^]n[*]x[*]x); astepl (y[^]n[*]y[*]y). astepr (x[^]n[*] (x[*]x)); astepl (y[^]n[*] (y[*]y)). apply mult_resp_leEq_both. eapply leEq_wdr. 2: apply inv_nexp_even; auto. apply nexp_resp_nonneg; astepl ([--] ([0]:R)); apply inv_resp_leEq; auto. astepr (y[^]2); apply sqr_nonneg. auto. astepl (y[^]2); astepr (x[^]2). assert (E : Nat.Even 2) by (now exists 1). eapply leEq_wdr. 2: apply inv_nexp_even; assumption. eapply leEq_wdl. 2: apply inv_nexp_even; assumption. apply nexp_resp_leEq. astepl ([--] ([0]:R)); apply inv_resp_leEq; assumption. apply inv_resp_leEq; assumption. Qed. Lemma nexp_resp_leEq_neg_odd : forall n, Nat.Odd n -> forall x y : R, y [<=] [0] -> x [<=] y -> x[^]n [<=] y[^]n. Proof. intro; case n; [intros [x H]; rewrite Nat.add_1_r in H; discriminate H |]. clear n; intros n H%Nat.Odd_succ x y Hy Hxy. astepl (x[^]n[*]x); astepr (y[^]n[*]y). rstepl ([--] (x[^]n[*][--]x)); rstepr ([--] (y[^]n[*][--]y)). apply inv_resp_leEq; apply mult_resp_leEq_both. eapply leEq_wdr. 2: { apply inv_nexp_even; inversion H; assumption. } apply nexp_resp_nonneg; astepl ([--] ([0]:R)); apply inv_resp_leEq; auto. astepl ([--] ([0]:R)); apply inv_resp_leEq; auto. apply nexp_resp_leEq_neg_even; auto; inversion H. apply inv_resp_leEq; auto. Qed. Lemma nexp_distr_recip : forall (x : R) n x_ xn_, ([1][/] x[//]x_) [^]n [=] ([1][/] x[^]n[//]xn_). Proof. intros. induction n as [| n Hrecn]; intros. simpl in |- *. algebra. astepl (([1][/] x[//]x_)[^]n[*] ([1][/] x[//]x_)). cut (x[^]n [#] [0]). intro H. astepl (([1][/] x[^]n[//]H)[*] ([1][/] x[//]x_)). cut (x[^]n[*]x [#] [0]). intro H2. rstepl ([1][/] x[^]n[*]x[//]H2). apply div_wd; algebra. apply mult_resp_ap_zero; auto. apply nexp_resp_ap_zero. auto. Qed. Hint Resolve nexp_distr_recip: algebra. Lemma nexp_even_nonneg : forall n, Nat.Even n -> forall x : R, [0] [<=] x[^]n. Proof. do 2 intro. pattern n in |- *; apply even_ind; intros. simpl in |- *; apply less_leEq; apply pos_one. apply leEq_wdr with (x[^]n0[*]x[^]2). 2: simpl in |- *; rational. apply mult_resp_nonneg. auto. apply sqr_nonneg. auto. Qed. Lemma nexp_resp_le' : forall c : R, [0] [<=] c -> c [<=] [1] -> forall m n, m <= n -> c[^]n [<=] c[^]m. Proof. intros. astepl ([0][+]c[^]n); apply shift_plus_leEq. set (N := n - m) in *. apply leEq_wdr with (c[^]m[-]c[^]m[*]c[^]N). rstepr (c[^]m[*] ([1][-]c[^]N)). astepl (([0]:R)[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive. apply nexp_resp_nonneg; auto. apply shift_leEq_minus. astepl (c[^]N). apply nexp_resp_leEq_one; assumption. apply cg_minus_wd. algebra. eapply eq_transitive_unfolded. apply nexp_plus. replace n with (m + (n - m)). algebra. auto with arith. Qed. Lemma nexp_resp_le : forall c : R, [1] [<=] c -> forall m n, m <= n -> c[^]m [<=] c[^]n. Proof. intros. cut ([0] [<] c); intros. 2: apply less_leEq_trans with ([1]:R); [ apply pos_one | assumption ]. cut (c [#] [0]); intros. 2: apply Greater_imp_ap; assumption. cut (forall n : nat, c[^]n [#] [0]); intros H3. 2: apply nexp_resp_ap_zero; assumption. cut (forall n : nat, ([1][/] _[//]H3 n) [#] [0]); intros H4. 2: apply div_resp_ap_zero_rev; apply one_ap_zero. rstepl ([1][/] _[//]H4 m). rstepr ([1][/] _[//]H4 n). apply recip_resp_leEq. apply recip_resp_pos; apply nexp_resp_pos; assumption. eapply leEq_wdl. 2: apply nexp_distr_recip with (x_ := X0). eapply leEq_wdr. 2: apply nexp_distr_recip with (x_ := X0). apply nexp_resp_le'. apply less_leEq. apply recip_resp_pos; assumption. apply shift_div_leEq. assumption. astepr c; assumption. assumption. Qed. Lemma bin_less_un : forall n H H1, ([1][/] (Two:R) [^]S n[//]H) [<] ([1][/] nring (S n) [//]H1). Proof. intros n H H1. apply recip_resp_less. simpl in |- *. apply plus_resp_nonneg_pos. apply nring_nonneg. apply pos_one. induction n as [| n Hrecn]. simpl in |- *. astepl ([1]:R). astepr (([1]:R)[+][1]). astepr (Two:R). apply one_less_two. rational. astepr ((Two:R)[*]Two[^]S n). apply leEq_less_trans with ((Two:R)[*]nring (S n)). apply suc_leEq_dub. apply mult_resp_less_lft. apply Hrecn. red; unfold f_rcpcl'. apply nexp_resp_ap_zero. apply Greater_imp_ap. apply pos_two. red; unfold f_rcpcl'. apply nring_ap_zero. auto. apply pos_two. Qed. End More_Nexp. #[global] Hint Resolve nexp_distr_div nexp_distr_recip: algebra. Arguments nexp_resp_ap_zero [R x]. (** ** Definition of [zexp]: integer exponentiation %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Section Zexp_def. Variable R : CField. (** It would be nicer to define [zexp] using [caseZdiff], but we already have most properties now. *) Definition zexp (x : R) x_ (n : Z) : R := match n with | Z0 => [1]:R | Zpos p => x[^]nat_of_P p | Zneg p => ([1][/] x[//]x_) [^]nat_of_P p end. End Zexp_def. Arguments zexp [R]. Notation "( x [//] Hx ) [^^] n" := (zexp x Hx n) (at level 0). (** ** Properties of [zexp] %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Section Zexp_properties. Variable R : COrdField. Lemma zexp_zero : forall (x : R) x_, (x[//]x_) [^^] (0) [=] [1]. Proof. intros. unfold zexp in |- *. algebra. Qed. Hint Resolve zexp_zero: algebra. Lemma zexp_nexp : forall (x : R) x_ (n : nat), (x[//]x_) [^^] (n) [=] x[^]n. Proof. intros. unfold zexp in |- *. simpl in |- *. elim n. simpl in |- *. algebra. intros. simpl in |- *. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. simpl in |- *. algebra. Qed. Hint Resolve zexp_nexp: algebra. Lemma zexp_inv_nexp : forall (x : R) x_ (n : nat), (x[//]x_) [^^] (- n) [=] ([1][/] x[//]x_) [^]n. Proof. intros. unfold zexp in |- *. simpl in |- *. elim n. simpl in |- *. algebra. intros. simpl in |- *. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. simpl in |- *. algebra. Qed. Hint Resolve zexp_inv_nexp: algebra. Lemma zexp_inv_nexp' : forall (x : R) (n : nat) x_ xn_, (x[//]x_) [^^] (- n) [=] ([1][/] x[^]n[//]xn_). Proof. intros x n Hx H1. astepl (([1][/] x[//]Hx) [^]n). astepr ([1][^]n[/] x[^]n[//]H1). apply nexp_distr_div. Qed. Hint Resolve zexp_inv_nexp': algebra. Lemma zexp_strext : forall (x y : R) m x_ y_, (x[//]x_) [^^] (m) [#] (y[//]y_) [^^] (m) -> x [#] y. Proof. intros x y m Hx Hy. pattern m in |- *. apply Cnats_Z_ind. intros. apply (nexp_strong_ext R n). change (x[^]n [#] y[^]n) in |- *. astepl (x[//]Hx)[^^] (n). astepr (y[//]Hy)[^^] (n). auto. intros. apply (nexp_strong_ext R n). change (x[^]n [#] y[^]n) in |- *. cut (([1][/] x[^]n[//]nexp_resp_ap_zero n Hx) [#] ([1][/] y[^]n[//]nexp_resp_ap_zero n Hy)). intro H0. generalize (div_strext _ _ _ _ _ _ _ H0); intro. elim X0; intros H2. elim (ap_irreflexive_unfolded _ _ H2). assumption. astepl (x[//]Hx)[^^] (- n). astepr (y[//]Hy)[^^] (- n). auto. Qed. Lemma zexp_wd : forall (x y : R) m x_ y_, x [=] y -> (x[//]x_) [^^] (m) [=] (y[//]y_) [^^] (m). Proof. intros x y m Hx Hy; intros. apply not_ap_imp_eq. intro H0. generalize (zexp_strext _ _ _ _ _ H0); intro. apply (eq_imp_not_ap _ _ _ H). assumption. Qed. Hint Resolve zexp_wd: algebra_c. Lemma zexp_plus1 : forall (x : R) x_ m, (x[//]x_) [^^] (m + 1) [=] (x[//]x_) [^^] (m) [*]x. Proof. intros x Hx m. pattern m in |- *. apply nats_Z_ind. intro. replace (Z_of_nat n + 1)%Z with (S n:Z). astepl (x[^]S n). astepr (x[^]n[*]x). algebra. rewrite Znat.inj_S. reflexivity. intros. induction n as [| n Hrecn]. simpl in |- *. algebra. replace (- Z_of_nat (S n) + 1)%Z with (- n)%Z. astepl (([1][/] x[//]Hx) [^]n). astepr (([1][/] x[//]Hx) [^]S n[*]x). simpl in |- *. rational. rewrite Znat.inj_S. replace (Z.succ (Z_of_nat n)) with (1 + Z_of_nat n)%Z. rewrite Zopp_plus_distr. rewrite Zplus_comm. unfold Z.opp at 2 in |- *. rewrite Zplus_assoc. reflexivity. unfold Z.succ in |- *. apply Zplus_comm. Qed. Hint Resolve zexp_plus1: algebra. Lemma zexp_resp_ap_zero : forall (x : R) m x_, (x[//]x_) [^^] (m) [#] [0]. Proof. intros. pattern m in |- *. apply Cnats_Z_ind. intros. astepl (x[^]n). apply nexp_resp_ap_zero. assumption. intro. astepl (([1][/] x[//]x_) [^]n). apply nexp_resp_ap_zero. apply div_resp_ap_zero_rev. algebra. Qed. Hint Resolve zexp_resp_ap_zero: algebra. Lemma zexp_inv : forall (x : R) x_ m xm_, (x[//]x_) [^^] (- m) [=] ([1][/] (x[//]x_) [^^] (m) [//]xm_). Proof. intros x Hx m. pattern m in |- *. apply nats_Z_ind. intros. (* Here I would like to use Rewrite zexp_inv_nexp', i.e. Rewriting with our own equality. *) apply eq_transitive_unfolded with ([1][/] x[^]n[//]nexp_resp_ap_zero n Hx). apply zexp_inv_nexp'. apply div_wd. algebra. algebra. intros. rewrite Z.opp_involutive. astepl (x[^]n). astepl ((x[^]n) [/]OneNZ). apply eq_div. astepl (x[^]n[*] ([1][/] x[//]Hx) [^]n). astepl ((x[*] ([1][/] x[//]Hx)) [^]n). astepr ([1]:R). astepr (([1]:R) [^]n). apply nexp_wd. algebra. Qed. Hint Resolve zexp_inv: algebra. Lemma zexp_inv1 : forall (x : R) x_ m, (x[//]x_) [^^] (m - 1) [=] ((x[//]x_) [^^] (m) [/] x[//]x_). Proof. intros x Hx; intros. replace (m - 1)%Z with (- (- m + 1))%Z. (* Here I would like to use Rewriting with our own equality. *) astepl ([1][/] (x[//]Hx) [^^] (- m + 1) [//]zexp_resp_ap_zero x (- m + 1) Hx). apply eq_div. astepr ((x[//]Hx) [^^] (m) [*] ((x[//]Hx) [^^] (- m) [*]x)). astepr ((x[//]Hx) [^^] (m) [*] (([1][/] (x[//]Hx) [^^] (m) [//]zexp_resp_ap_zero x m Hx) [*]x)). rational. rewrite Zopp_plus_distr. rewrite Z.opp_involutive. reflexivity. Qed. Hint Resolve zexp_inv1: algebra. Lemma zexp_plus : forall (x : R) x_ m n, (x[//]x_) [^^] (m + n) [=] (x[//]x_) [^^] (m) [*] (x[//]x_) [^^] (n). Proof. intros x Hx; intros. pattern n in |- *. apply pred_succ_Z_ind. simpl in |- *. replace (m + 0)%Z with m. algebra. auto with zarith. intros. replace (m + (n0 + 1))%Z with (m + n0 + 1)%Z. astepl ((x[//]Hx) [^^] (m + n0) [*]x). astepr ((x[//]Hx) [^^] (m) [*] ((x[//]Hx) [^^] (n0) [*]x)). astepr ((x[//]Hx) [^^] (m) [*] (x[//]Hx) [^^] (n0) [*]x). algebra. auto with zarith. intros. replace (m + (n0 - 1))%Z with (m + n0 - 1)%Z. astepl ((x[//]Hx) [^^] (m + n0) [/] x[//]Hx). astepr ((x[//]Hx) [^^] (m) [*] ((x[//]Hx) [^^] (n0) [/] x[//]Hx)). astepr ((x[//]Hx) [^^] (m) [*] (x[//]Hx) [^^] (n0) [/] x[//]Hx). algebra. unfold Zminus in |- *. auto with zarith. Qed. Hint Resolve zexp_plus: algebra. Lemma zexp_minus : forall (x : R) x_ m n xn_, (x[//]x_) [^^] (m - n) [=] ((x[//]x_) [^^] (m) [/] (x[//]x_) [^^] (n) [//]xn_). Proof. intros x Hx m n Hexp. replace (m - n)%Z with (m + - n)%Z. astepl ((x[//]Hx) [^^] (m) [*] (x[//]Hx) [^^] (- n)). astepl ((x[//]Hx) [^^] (m) [*] ([1][/] (x[//]Hx) [^^] (n) [//]Hexp)). astepl ((x[//]Hx) [^^] (m) [*][1][/] (x[//]Hx) [^^] (n) [//]Hexp). algebra. reflexivity. Qed. Hint Resolve zexp_minus: algebra. Lemma one_zexp : forall z, ([1][//]ring_non_triv _) [^^] (z) [=] ([1]:R). Proof. intro. pattern z in |- *. apply nats_Z_ind. intro. (* Rewrite would be nice *) astepl (([1]:R) [^]n). apply one_nexp. intros. astepl ([1][/] ([1][//]ring_non_triv _) [^^] (n) [//] zexp_resp_ap_zero [1] n (ring_non_triv _)). astepr (([1]:R) [/]OneNZ). apply eq_div. astepr (([1]:R) [*][1][^]n). astepr (([1]:R) [*][1]). algebra. Qed. Hint Resolve one_zexp: algebra. Lemma mult_zexp : forall (x y : R) z x_ y_ xy_, (x[*]y[//]xy_) [^^] (z) [=] (x[//]x_) [^^] (z) [*] (y[//]y_) [^^] (z). Proof. intros x y z Hx Hy Hp. pattern z in |- *. apply nats_Z_ind. intros. astepl ((x[*]y) [^]n). astepr (x[^]n[*]y[^]n). apply mult_nexp. intros. astepl ([1][/] (x[*]y[//]Hp) [^^] (n) [//]zexp_resp_ap_zero (x[*]y) n Hp). astepr (([1][/] (x[//]Hx) [^^] (n) [//]zexp_resp_ap_zero x n Hx) [*] ([1][/] (y[//]Hy) [^^] (n) [//]zexp_resp_ap_zero y n Hy)). astepl ([1][/] (x[*]y) [^]n[//]nexp_resp_ap_zero n Hp). astepr (([1][/] x[^]n[//]nexp_resp_ap_zero n Hx) [*] ([1][/] y[^]n[//]nexp_resp_ap_zero n Hy)). rstepr ([1][/] x[^]n[*]y[^]n[//] mult_resp_ap_zero _ _ _ (nexp_resp_ap_zero n Hx) (nexp_resp_ap_zero n Hy)). apply eq_div. algebra. Qed. Hint Resolve mult_zexp: algebra. Lemma zexp_mult : forall (x : R) m n x_ xm_, (x[//]x_) [^^] (m * n) [=] ((x[//]x_) [^^] (m) [//]xm_) [^^] (n). Proof. intros x m n Hx He. pattern n in |- *. apply pred_succ_Z_ind. rewrite <- Zmult_0_r_reverse. algebra. intros. rewrite Zmult_plus_distr_r. astepr (((x[//]Hx) [^^] (m) [//]He) [^^] (n0) [*] (x[//]Hx) [^^] (m)). rewrite Zmult_1_r. astepl ((x[//]Hx) [^^] (m * n0) [*] (x[//]Hx) [^^] (m)). algebra. intros. rewrite CornBasics.Zmult_minus_distr_r. astepr (((x[//]Hx) [^^] (m) [//]He) [^^] (n0) [/] (x[//]Hx) [^^] (m) [//]He). rewrite Zmult_1_r. astepl ((x[//]Hx) [^^] (m * n0) [/] (x[//]Hx) [^^] (m) [//]He). algebra. Qed. Hint Resolve zexp_mult: algebra. Lemma zexp_two : forall (x : R) x_, (x[//]x_) [^^] (2) [=] x[*]x. Proof. intros. simpl in |- *. algebra. Qed. Hint Resolve zexp_two: algebra. Lemma inv_zexp_even : forall (x : R) m, Zeven m -> forall x_ x__, ([--]x[//]x__) [^^] (m) [=] (x[//]x_) [^^] (m). Proof. intros x m H Hx Hneg. pattern m in |- *. rewrite -> Zeven.Zeven_div2. astepl (([--]x[//]Hneg) [^^] (2) [//]zexp_resp_ap_zero [--]x 2 Hneg) [^^] (Z.div2 m). astepl ([--]x[*][--]x[//]mult_resp_ap_zero _ _ _ Hneg Hneg) [^^] (Z.div2 m). astepl (x[*]x[//]mult_resp_ap_zero _ _ _ Hx Hx) [^^] (Z.div2 m). astepl ((x[//]Hx) [^^] (2) [//]zexp_resp_ap_zero x 2 Hx) [^^] (Z.div2 m). algebra. assumption. Qed. Hint Resolve inv_zexp_even: algebra. Lemma inv_zexp_two : forall (x : R) x_ x__, ([--]x[//]x__) [^^] (2) [=] (x[//]x_) [^^] (2). Proof. intros. apply inv_zexp_even. simpl in |- *. auto. Qed. Hint Resolve inv_zexp_two: algebra. Lemma inv_zexp_odd : forall (x : R) m, Zodd m -> forall x_ x__, ([--]x[//]x__) [^^] (m) [=] [--] (x[//]x_) [^^] (m). Proof. intros x m H Hx Hneg. replace m with (m - 1 + 1)%Z. astepl (([--]x[//]Hneg) [^^] (m - 1) [*][--]x). astepr ([--] ((x[//]Hx) [^^] (m - 1) [*]x)). rstepr ((x[//]Hx) [^^] (m - 1) [*][--]x). apply mult_wd. apply inv_zexp_even. apply Zodd_Zeven_min1. assumption. simpl in |- *. auto. algebra. change ((m + -1 + 1)%Z = m) in |- *. rewrite <- Zplus_assoc. simpl in |- *. rewrite <- Zplus_0_r_reverse. reflexivity. Qed. Lemma zexp_one : forall (x : R) x_, (x[//]x_) [^^] (1) [=] x. Proof. intros. simpl in |- *. algebra. Qed. Hint Resolve zexp_one: algebra. Lemma zexp_funny : forall (x y : R) x_ y_, (x[+]y) [*] (x[-]y) [=] (x[//]x_) [^^] (2) [-] (y[//]y_) [^^] (2). Proof. intros. astepr (x[*]x[-]y[*]y). rational. Qed. Hint Resolve zexp_funny: algebra. Lemma zexp_funny' : forall (x y : R) x_ y_, (x[-]y) [*] (x[+]y) [=] (x[//]x_) [^^] (2) [-] (y[//]y_) [^^] (2). Proof. intros. astepl ((x[+]y) [*] (x[-]y)). apply zexp_funny. Qed. Hint Resolve zexp_funny': algebra. Lemma zexp_pos : forall (x : R) x_ z, [0] [<] x -> [0] [<] (x[//]x_) [^^] (z). Proof. intros. pattern z in |- *. apply Cnats_Z_ind. intros. astepr (x[^]n). apply nexp_resp_pos. assumption. intros. astepr ([1][/] x[^]n[//]nexp_resp_ap_zero n x_). apply div_resp_pos. apply nexp_resp_pos. assumption. apply pos_one. Qed. End Zexp_properties. #[global] Hint Resolve nexp_resp_ap_zero zexp_zero zexp_nexp zexp_inv_nexp zexp_inv_nexp' zexp_plus1 zexp_resp_ap_zero zexp_inv zexp_inv1 zexp_plus zexp_minus one_zexp mult_zexp zexp_mult zexp_two inv_zexp_even inv_zexp_two zexp_one zexp_funny zexp_funny': algebra. #[global] Hint Resolve zexp_wd: algebra_c. Section Root_Unique. Variable R : COrdField. Lemma root_unique : forall x y : R, [0] [<=] x -> [0] [<=] y -> forall n, 0 < n -> x[^]n [=] y[^]n -> x [=] y. Proof. intros. apply leEq_imp_eq. apply power_cancel_leEq with n; auto. astepr (x[^]n). apply leEq_reflexive. apply power_cancel_leEq with n; auto. astepl (x[^]n). apply leEq_reflexive. Qed. Lemma root_one : forall x : R, [0] [<=] x -> forall n, 0 < n -> x[^]n [=] [1] -> x [=] [1]. Proof. intros. apply root_unique with n; auto. apply less_leEq. apply pos_one. Step_final ([1]:R). Qed. End Root_Unique. corn-8.20.0/algebra/OperationClasses.v000066400000000000000000000144501473720167500176240ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms. Notation " x === y " := (Equivalence.equiv x y) (at level 70, no associativity). Set Implicit Arguments. Unset Strict Implicit. Section Definitions. Definition unop (R : Type) := R -> R. Definition binop (R : Type) := R -> R -> R. Context {R : Type}. Class unop_intern (P : R -> Type) (op : unop R) := unop_int : forall x : R, P x -> P (op x). Class binop_intern (P : R -> Type) (op : binop R) := binop_int : forall x y : R, P x -> P y -> P (op x y). Context `{r_st : Equivalence R}. Class associative (op : binop R) := assoc : forall x y z, op x (op y z) === op (op x y) z. Class commutative (op : binop R) := commut : forall x y, op x y === op y x. Class left_commutative (op : binop R) := left_commut : forall x y z, op x (op y z) === op y (op x z). Class right_commutative (op : binop R) := right_commut : forall x y z, op (op x y) z === op (op x z) y. Class left_unit (op : binop R) (idm : R) := left_id : forall x, op idm x === x. Class right_unit (op : binop R) (idm : R) := right_id : forall x, op x idm === x. Class left_absorbing (op : binop R) (idm : R) := left_zero : forall x, op idm x === idm. Class right_absorbing (op : binop R) (idm : R) := right_zero : forall x, op x idm === idm. Class left_distributive (op mul : binop R) := left_dist : forall x y z, mul (op x y) z === op (mul x z) (mul y z). Class right_distributive (op mul : binop R) := right_dist : forall x y z, mul x (op y z) === op (mul x y) (mul x z). Class left_inverse (op : binop R) (idm : R) (inv : unop R) := left_inv : forall x, op x (inv x) === idm. Class right_inverse (op : binop R) (idm : R) (inv : unop R) := right_inv : forall x, op (inv x) x === idm. End Definitions. Section Commutative. (* Class monoid `{r_st : Equivalence R req}:= {mul :> binop R ;mulC : commutative mul}.*) Context `{r_st : Equivalence}. Context {mul : binop A} {mulC : commutative mul}. Global Instance mulC_id_l {idm : A} {H : left_unit mul idm} : right_unit mul idm. Proof. reduce; rewrite commut; apply left_id. Qed. Global Instance mulC_id_r {idm : A} {H : right_unit mul idm} : left_unit mul idm. Proof. reduce; rewrite commut; apply right_id. Qed. Global Instance mulC_zero_l {zero : A} {H : left_absorbing mul zero} : right_absorbing mul zero. Proof. reduce; rewrite commut; apply left_zero. Qed. Global Instance mulC_zero_r {zero : A} {H : right_absorbing mul zero} : left_absorbing mul zero. Proof. reduce; rewrite commut; apply right_zero. Qed. Global Instance mulC_inv_l {idm : A} {inv : unop A} {H : left_inverse mul idm inv} : right_inverse mul idm inv. Proof. reduce; rewrite commut; apply left_inv. Qed. Global Instance mulC_inv_r {idm : A} {inv : unop A} {H : right_inverse mul idm inv} : left_inverse mul idm inv. Proof. reduce; rewrite commut; apply right_inv. Qed. Section distributivity. Context {op : binop A}. Context {op_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) op}. Global Instance mulC_distr_l {H : left_distributive op mul} : right_distributive op mul. Proof. intros x y z; rewrite -> (commut x (op _ _)), -> (commut x y), -> (commut x z); apply left_dist. Qed. Global Instance mulC_distr_r {H : right_distributive op mul} : left_distributive op mul. Proof. intros x y z; rewrite -> (commut (op _ _) z), -> (commut x z), -> (commut y z); apply right_dist. Qed. End distributivity. Section Associativity. Context {mul_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) mul}. Context {mulA : associative mul}. Global Instance mulAC_comm_l : left_commutative mul. Proof. intros x y z; rewrite -> assoc, assoc, (commut x y); reflexivity. Qed. Global Instance mulAC_comm_r : right_commutative mul. Proof. intros x y z; rewrite <- assoc, <- assoc, (commut y z); reflexivity. Qed. End Associativity. End Commutative. Section AssociativeCommutative. Context `{r_st : Equivalence}. Context {add mul : binop A} {opp : unop A} {zero : A}. Context {add_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) add}. Context {mul_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) mul}. Context {opA : associative add}. Context {opC : commutative add}. Section Left. Context {l_inv : left_inverse add zero opp}. Context {op_id : left_unit add zero}. Context {l_d : left_distributive add mul}. (* Sinon ca marche pas... *) Existing Instance mulC_id_l. Global Instance opA_zero_l : left_absorbing mul zero. Proof. intro; rewrite <- (left_id (mul _ _)); rewrite <- (left_id zero) at 3. set (e := left_inv (mul zero x)); rewrite <- e at 1 3; clear e. rewrite -> (commut (mul _ _)), <- assoc, <-assoc; apply add_morph; try reflexivity. rewrite <- left_dist, (left_id zero), (right_id (mul _ _)); reflexivity. Qed. End Left. Section Right. Context {r_inv : right_inverse add zero opp}. Context {op_id : right_unit add zero}. Context {r_d : right_distributive add mul}. (* Sinon ca marche pas... *) Existing Instance mulC_id_r. Global Instance opA_zero_r : right_absorbing mul zero. Proof. intro; rewrite <- (right_id (mul _ _)); rewrite <- (right_id zero) at 3. set (e := right_inv (mul x zero)); rewrite <- e at 2 4; clear e. rewrite -> (commut (opp _)), assoc, assoc; apply add_morph; try reflexivity. rewrite <- right_dist, (right_id zero), (left_id (mul _ _)); reflexivity. Qed. End Right. End AssociativeCommutative. corn-8.20.0/algebra/RSetoid.v000066400000000000000000000131661473720167500157220ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) (* Backwards compatibility for Typeclasses Transparent locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Require Export Coq.Setoids.Setoid. Require Export (hints) MathClasses.interfaces.orders. Require Import MathClasses.interfaces.abstract_algebra. Export (hints) MathClasses.interfaces.abstract_algebra. (** * Classic Setoids presented in a bundled way. * * THIS NOTION IS OBSOLETE AND SHOULD NOT BE USED ANYMORE * Use [abstract_algebra.Setoid] instead *) Structure RSetoid: Type := { st_car :> Type; st_eq : Equiv st_car ; st_isSetoid : Setoid st_car }. #[global] Typeclasses Transparent Equiv. #[global] Hint Extern 10 (Equiv _) => apply @st_eq : typeclass_instances. #[global] Hint Extern 10 (Setoid _) => apply @st_isSetoid : typeclass_instances. Arguments st_eq [r]. Definition mcSetoid_as_RSetoid X {e : Equiv X} {setoid : Setoid X} : RSetoid := Build_RSetoid setoid. Arguments mcSetoid_as_RSetoid X {e setoid}. (* Canonical Structure mcSetoid_as_RSetoid. *) (* If we make this a canonical structure StepQsec will break: investigate *) (** Propositions form a setoid under iff *) Definition iffSetoid : RSetoid. Proof. eexists Prop iff. firstorder. Defined. (** ** Morhpisms between Setoids *) Record Morphism (X Y : RSetoid) := {evalMorphism :> X -> Y ;Morphism_prf : forall x1 x2, (st_eq x1 x2) -> (st_eq (evalMorphism x1) (evalMorphism x2)) }. Definition extEq (X:Type) (Y : RSetoid) (f g:X -> Y) := forall x, st_eq (f x) (g x). Definition extSetoid (X Y : RSetoid) : RSetoid. Proof. eexists (Morphism X Y) (extEq Y). split. intros x y; reflexivity. intros x y H a; symmetry; auto. intros x y z Hxy Hyz a; transitivity (y a); auto. Defined. Notation "x --> y" := (extSetoid x y) (at level 55, right associativity) : setoid_scope. Local Open Scope setoid_scope. (** ** Basic Combinators for Setoids *) Definition id (X : RSetoid) : X-->X. Proof. eexists (fun x => x). abstract (auto). Defined. (* begin hide *) Arguments id {X}. (* end hide *) Definition compose0 X Y Z (x : Y ->Z) (y:X -> Y) z := x (y z). Definition compose1 (X Y Z : RSetoid) : (Y-->Z) -> (X --> Y) -> X --> Z. Proof. intros f0 f1. exists (compose0 f0 f1). abstract ( destruct f0 as [f0 Hf0]; destruct f1 as [f1 Hf1]; intros x1 x2 Hx; apply Hf0; apply Hf1; assumption). Defined. Definition compose2 (X Y Z : RSetoid) : (Y-->Z) -> (X --> Y) --> X --> Z. Proof. intros f0. eexists (compose1 f0). abstract ( destruct f0 as [f0 Hf0]; intros x1 x2 H y; apply Hf0; apply H). Defined. Definition compose (X Y Z : RSetoid) : (Y-->Z) --> (X --> Y) --> X --> Z. Proof. exists (@compose2 X Y Z). abstract ( intros x1 x2 H y z; apply H). Defined. (* begin hide *) Arguments compose {X Y Z}. (* end hide *) Definition const0 (X Y : RSetoid) : X->Y-->X. Proof. intros x. eexists (fun y => x). abstract reflexivity. Defined. Definition const (X Y : RSetoid) : X-->Y-->X. Proof. exists (@const0 X Y). abstract ( intros x1 x2 Hx y; assumption). Defined. (* begin hide *) Arguments const {X Y}. (* end hide *) Definition flip0 (X Y Z : RSetoid) : (X-->Y-->Z)->Y->X-->Z. Proof. intros f y. exists (fun x => f x y). abstract ( destruct f as [f Hf]; intros x1 x2 H; apply Hf; auto). Defined. Definition flip1 (X Y Z : RSetoid) : (X-->Y-->Z)->Y-->X-->Z. Proof. intros f. exists (flip0 f). abstract ( destruct f as [f Hf]; intros x1 x2 H y; simpl; destruct (f y) as [g Hg]; apply Hg; auto). Defined. Definition flip (X Y Z : RSetoid) : (X-->Y-->Z)-->Y-->X-->Z. Proof. exists (@flip1 X Y Z). abstract ( intros x1 x2 H y z; apply H). Defined. (* begin hide *) Arguments flip {X Y Z}. (* end hide *) Definition join0 (X Y : RSetoid) : (X-->X-->Y)->X-->Y. Proof. intros f. exists (fun y => f y y). abstract ( destruct f as [f Hf]; intros x1 x2 H; simpl; transitivity (f x1 x2); [destruct (f x1) as [g Hg]; apply Hg; auto |apply Hf; auto]). Defined. Definition join (X Y : RSetoid) : (X-->X-->Y)-->X-->Y. Proof. exists (@join0 X Y). abstract ( intros x1 x2 H y; apply H). Defined. (* begin hide *) Arguments join {X Y}. (* end hide *) Definition ap (X Y Z : RSetoid) : (X --> Y --> Z) --> (X --> Y) --> (X --> Z) := compose (compose (compose (@join _ _)) (@flip _ _ _)) (compose (@compose _ _ _)). (* begin hide *) Arguments ap {X Y Z}. (* end hide *) Definition bind (X Y Z : RSetoid) : (X--> Y) --> (Y --> X--> Z) --> (X--> Z):= (compose (compose (@join _ _)) (flip (@compose X Y (X-->Z)))). Definition bind_compose (X Y Z W : RSetoid) : (W--> X--> Y) --> (Y --> X--> Z) --> (W--> X--> Z):= (flip (compose (@compose W _ _) ((flip (@bind X Y Z))))). (* begin hide *) Arguments bind {X Y Z}. Arguments bind_compose {X Y Z W}. (* end hide *) corn-8.20.0/broken/000077500000000000000000000000001473720167500140365ustar00rootroot00000000000000corn-8.20.0/broken/CCayleyHamilton.v000066400000000000000000000240201473720167500172500ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. Require Import finfun paths perm. Require Import CPoly_Degree Setoid Morphisms Ring CRingClass CPoly_Euclid. Require Import bigopsClass matrixClass. Set Implicit Arguments. Unset Strict Implicit. Opaque csg_op. Opaque cm_unit. Opaque cr_mult. Opaque polyconst. Opaque cr_one. Opaque cpoly_apply_fun. Opaque cg_inv. Section Cayley_Hamilton. Variable CR : CRing. Add Ring cr_r : (RingClass.r_rt (Ring:=CRing_is_Ring CR)). Add Ring cpoly_r : (RingClass.r_rt (Ring:=CRing_is_Ring (cpoly_cring CR))). Section degree_le. Global Instance degree_le_morph : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@degree_le CR). Proof. by move=> p q -> x y eqxy; split;[|symmetry in eqxy]; apply degree_le_wd. Qed. Lemma bigsum_degree_le : forall n (I : finType) (F : I -> cpoly_cring CR), (forall i : I, degree_le n (F i)) -> degree_le n (\big[csg_op/Zero]_i (F i)). Proof. move=> n I F H. have Hz : degree_le n (Zero : cpoly_cring CR) by move=> m Hlt; reflexivity. have Hplus : forall p q : cpoly_cring CR, degree_le n p -> degree_le n q -> degree_le n (p[+]q). by move=> p q; apply degree_le_plus. by apply (big_prop Hz Hplus _ (P:=predT)). Qed. Lemma bigprod_degree_le : forall (I : finType) (P : pred I) (F : I -> cpoly_cring CR) (deg : I -> nat), (forall i : I, P i -> degree_le (deg i) (F i)) -> degree_le (\big[addn/0]_(i|P i) (deg i)) (\big[cr_mult/One]_(i|P i) (F i)). Proof. move=> I P F deg Hdeg. generalize (index_enum I). elim=>[|i r Hrec]. case; [case/lt_irrefl|reflexivity]. simpl; have{Hdeg}:=Hdeg i. case: (P i)=> Hi; last by apply Hrec. by apply degree_le_mult; [apply Hi|apply Hrec]. Qed. Global Instance nth_coeff_morph : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@nth_coeff CR). Proof. by move=> p q -> x y eqxy; apply nth_coeff_wd. Qed. Lemma nth_coeff_bigsum : forall n (I : finType) (F : I -> cpoly_cring CR), nth_coeff n (\big[csg_op/Zero]_i (F i)) [=] \big[csg_op/Zero]_i (nth_coeff n (F i)). Proof. move=> n I F. have Hz : nth_coeff n Zero [=] (Zero : CR) by reflexivity. have Hplus : forall p q : cpoly_cring CR, nth_coeff n (p[+]q) [=] nth_coeff n p [+] nth_coeff n q. by move=> p q; apply nth_coeff_plus. by apply (big_morph Hplus Hz _ predT). Qed. Global Instance monic_morphism : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@monic CR). Proof. by move=> p q -> x y eqxy; split; [|symmetry in eqxy]; apply monic_wd. Qed. Lemma monic_bigsum : forall n (I : finType) (F : I -> cpoly_cring CR) (i : I), monic n.+1 (F i) -> (forall j : I, j != i -> degree_le n (F j)) -> monic n.+1 (\big[csg_op/Zero]_i F i). Proof. move=> n I F i Hmon Hdeg. split; last first. apply bigsum_degree_le=> j. case_eq (i==j). by move/eqP=> <-; apply Hmon. rewrite eq_sym. move/negbT=> Heq. apply (degree_le_mon _ _ n); first by apply le_S; apply le_n. by apply (Hdeg j). rewrite nth_coeff_bigsum. setoid_rewrite (bigD1 (P:=predT) (j:=i) (fun i0 => nth_coeff n.+1 (F i0))); last by done. transitivity ((One : CR)[+]Zero); last by ring. apply csbf_wd; first by apply Hmon. apply big1=> j'. case/andP=> Pj' neqj'. by apply Hdeg. Qed. Lemma monic_bigprod : forall (I : finType) (F : I -> cpoly_cring CR) (deg : I -> nat), (forall i : I, monic (deg i) (F i)) -> monic (\big[addn/0]_i deg i) (\big[cr_mult/One]_i F i). Proof. move=> I F deg Hdeg. elim:(index_enum I)=>[|i r Hrec]. by apply monic_c_one. simpl. by apply monic_mult. Qed. Global Instance cpoly_apply_morph : Morphisms.Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (cpoly_apply CR). Proof. by move=> a b eqab x y eqxy; apply cpoly_apply_wd. Qed. Lemma apply_bigsum : forall (I : finType) (F : I -> cpoly_cring CR) (x : CR), (\big[csg_op/Zero]_i F i) ! x [=] \big[csg_op/Zero]_i (F i) ! x. Proof. move=> I F x. elim:(index_enum I)=>[|j r Hrec] /=. by apply poly_eq_zero; reflexivity. rewrite (plus_apply _ (F j)). by rewrite Hrec; reflexivity. Qed. Lemma apply_big_prod : forall (I : finType) (F : I -> cpoly_cring CR) (x : CR), (\big[cr_mult/One]_i F i) ! x [=] \big[cr_mult/One]_i (F i) ! x. Proof. move=> I F x. elim:(index_enum I)=>[|j r Hrec] /=. by apply one_apply. rewrite (mult_apply _ (F j)). by rewrite Hrec; reflexivity. Qed. End degree_le. Open Scope matrix_scope. Section char_poly. Variable n : nat. Local Notation "R [ 'X' ]" := (cpoly_cring R) (at level 0, format "R [ 'X' ]"). Local Notation "'M' ( R )" := (matrix R n n) (at level 0, format "'M' ( R )"). Variable A : M(CR). Definition matrixC : M(CR[X]) := \matrix_(i,j < n) _C_ (A i j). Definition char_poly : CR[X] := \det (_X_%:M -m matrixC). Lemma char_poly_monic : monic n char_poly. Proof. rewrite /char_poly /determinant /matrixC. move: n A. clear n A. case=>[|n]=>A. have -> : index_enum (perm_for_finType (ordinal_finType 0)) = [::perm_one (ordinal_finType 0)]; last first. rewrite /= odd_perm1 /=. apply (monic_wd _ One); last by apply monic_c_one. rewrite /index_enum -enumT. have <- : [::] = enum (ordinal_finType 0); last first. by change ((One : CR[X])[=]One[*]One[+]Zero); ring. rewrite <- enum0. by apply eq_enum; case. rewrite /index_enum -enumT. have := (enum1 (perm_one (ordinal_finType 0)))=> /= <-. apply (@eq_enum _ 'S_0)=> s /=. symmetry. apply/eqP. apply/permP=> x. by case:x. apply (monic_bigsum (i:=perm_one (ordinal_finType n.+1)) (F:=fun s => _)). rewrite odd_perm1 /=. change (n.+1) with (0 + n.+1). apply monic_mult; first by apply monic_c_one. have : n.+1 = \big[addn/0]_(i n /= ->. move => Heq. rewrite -> Heq at 1. apply monic_bigprod=> i. rewrite /scalar_mx /addmx /oppmx perm1 eq_refl. split; first by rewrite -> nth_coeff_plus; reflexivity. apply degree_le_plus; first by apply degree_le_x_. change (degree_le 1 [--](_C_(A i i))). apply degree_le_inv. apply (degree_le_mon _ _ 0); first by apply le_S; apply le_n. by apply degree_le_c_. move=> s neq. change n with (0 + n). apply degree_le_mult. change (One : CR[X]) with (_C_ (One : CR)). case: (odd_perm s)=> /=; last by apply degree_le_c_. change (degree_le 0 ([--](_C_ One)[*](_C_ (One : CR)))). change 0 with (0 + 0). by apply degree_le_mult; [apply degree_le_inv|]; apply degree_le_c_. have: existsb i : ordinal_finType n.+1, s i != i. apply/forallP=> Heq. case: (negP neq)=> {neq}. apply/eqP. apply/permP=> x. rewrite perm1. apply/eqP. by apply Heq. case/existsP=> j Hj. setoid_rewrite (bigD1 (j:=j)); last by done. change n with (0 + n). apply degree_le_mult=> [|/=]. rewrite /scalar_mx /addmx /oppmx eq_sym (negbTE Hj). setoid_rewrite cm_lft_unit. apply degree_le_inv. by apply degree_le_c_. change (0 + n) with n. have Heq : n = \big[addn/0]_(i|i!=j) 1. setoid_rewrite big_const_seq; clear. have -> : count (predC (pred1 j)) (index_enum (ordinal_finType n.+1)) = n; last first. move=> {j}; revert n. by elim; [|move=> n /= <-]. have := (count_predC (pred1 j) (index_enum (ordinal_finType n.+1))). rewrite enumP /index_enum -enumT size_enum_ord /= add1n. by move/eqP; rewrite eqSS; move/eqP. rewrite {1}Heq=> {Heq}. apply bigprod_degree_le=> i Hneq. rewrite /scalar_mx /addmx /oppmx. apply degree_le_plus. case: (i == s i); first by apply degree_le_x_. apply (degree_le_mon _ _ 0); first by apply le_S; apply le_n. by move=> n' _; apply nth_coeff_zero. change (degree_le 1 ([--](_C_(A i (s i))))). apply degree_le_inv. apply (degree_le_mon _ _ 0); first by apply le_S; apply le_n. by apply degree_le_c_. Qed. Lemma char_poly_apply : forall a : CR, char_poly ! a === \det (a%:M -m A). Proof. rewrite /char_poly /determinant=> a. rewrite apply_bigsum. apply eq_bigr=> s _. rewrite -> mult_apply. apply csbf_wd. case: (odd_perm s)=> /=; last by apply one_apply. rewrite /Equivalence.equiv. rewrite (mult_apply CR). apply csbf_wd; last by apply one_apply. rewrite -> inv_apply. rewrite -> one_apply. by reflexivity. rewrite apply_big_prod. apply eq_bigr=> i _. rewrite /scalar_mx /addmx /oppmx /matrixC. rewrite -> plus_apply. rewrite -> inv_apply. rewrite -> c_apply. apply csbf_wd; last by reflexivity. case: (i == s i); first by apply x_apply. by apply poly_eq_zero; reflexivity. Qed. Lemma Cayley_Hamilton : forall (a : CR) (X : matrix CR n 1), A *m X === a%:M *m X -> (char_poly ! a)%:M *m X === '0m. Proof. move=> a X Heq. rewrite char_poly_apply. rewrite <- mulmx_adjl. rewrite <- (mulmx0 (\adj (a%:M -m A))). rewrite <- mulmxA. apply mulmx_morph; first by reflexivity. rewrite -> mulmx_addl. Existing Instance addmx_morph. rewrite <- Heq=> i j {Heq}. rewrite /addmx /oppmx /mulmx /null_mx. have Heq : forall k, xpredT k -> [--](A i k)[*]X k j [=] [--](A i k[*]X k j) by move=> k _; ring. setoid_rewrite (eq_bigr _ Heq)=> {Heq}. setoid_rewrite <- (big_morph (op1:=csg_op) (idx1:=Zero) (phi:=fun x => [--]x))=> /=[|x y| |]; [by ring|by ring|by ring|]. move=> x x' eqx y y' eqy. by rewrite eqx eqy; reflexivity. Qed. End char_poly. End Cayley_Hamilton. corn-8.20.0/broken/CPoly_Lagrange.v000066400000000000000000000123011473720167500170500ustar00rootroot00000000000000Require Import Unicode.Utf8 Setoid Arith List Program Permutation CSetoids CRings CPoly_Degree CPoly_ApZero CRArith Qmetric Qring CReals stdlib_omissions.Pair stdlib_omissions.Q list_separates SetoidPermutation. Require ne_list. Import ne_list.notations. Local Open Scope CR_scope. Local Notation Σ := cm_Sum. Local Notation Π := cr_Product. Section contents. Notation QPoint := (Q * CR)%type. Notation CRPoint := (CR * CR)%type. Variables (qpoints: list QPoint) (distinct: QNoDup (map fst qpoints)). Let crpoints := map (first inject_Q_CR) qpoints. (** Definition of the Lagrange polynomial: *) Definition L: cpoly CRasCRing := Σ (map (fun p => let '((x, y), rest) := p in _C_ y [*] Π (map (fun xy' => (' (- fst xy')%Q [+X*] [1]) [*] _C_ (' (/ (x - fst xy')))) rest)) (separates qpoints)). (** Its degree follows easily from its structure: *) Lemma degree: degree_le (length (tl qpoints)) L. Proof with auto. unfold L. apply degree_le_Sum. intros ? H. destruct (proj1 (in_map_iff _ _ _) H) as [[[] v] [[] B]]. clear H. apply degree_le_mult_constant_l. clear crpoints. destruct qpoints. simpl in B. exfalso... simpl length. replace (@length (prod Q (RegularFunction Q_as_MetricSpace)) l) with (length (map (fun xi => (' (- fst xi)%Q[+X*][1])[*]_C_ (' (/ (q - fst xi)))) v) * 1)%nat. apply degree_le_Product. intros. destruct (proj1 (in_map_iff _ _ _) H) as [?[[]?]]. apply degree_le_mult_constant_r. apply degree_le_cpoly_linear_inv. apply (degree_le_c_ CRasCRing [1]). rewrite map_length. ring_simplify. apply eq_add_S. rewrite <- (separates_elem_lengths (p0 :: l) v)... replace v with (snd ((q, s), v))... apply in_map... Qed. (** Applying the polynomial gives what you'd expect: *) Definition functional (x: Q): CR := Σ (map (fun p => let '((xj, y), rest) := p in y [*] ' Π (map (fun xi => (x - fst xi) * / (xj - fst xi))%Q rest)) (separates qpoints)). Lemma apply x: (L ! ' x) [=] functional x. Proof. unfold L, functional. rewrite cm_Sum_apply. autorewrite with apply. rewrite map_map. apply (@cm_Sum_eq _). intros [[u v] w]. autorewrite with apply. apply mult_wd. reflexivity. rewrite inject_Q_product. rewrite cr_Product_apply. do 2 rewrite map_map. apply (@cm_Sum_eq (Build_multCMonoid CRasCRing)). intros [p q]. rewrite <- CRmult_Qmult. autorewrite with apply. change (((' (- p)%Q + ' x * (1 + ' x * 0)) * ' (/ (u - p))) == (' (x + - p)%Q * ' (/ (u - p))))%CR. rewrite <- CRplus_Qplus. generalize (/ (u - p)). intros. ring. Qed. (** Finally, the polynomial actually interpolates the given points: *) Lemma interpolates: interpolates crpoints L. Proof with auto. intros xy. unfold crpoints. rewrite in_map_iff. intros [[xi y] [V W]]. subst. simpl @fst. simpl @snd. rewrite apply. unfold functional. destruct (move_to_front _ _ W) as [x H1]. set (fun p => let '(xj, y1, rest) := p in y1[*] ' Π (map (fun xi0 : Q and CR => ((xi - fst xi0) * / (xj - fst xi0))%Q) rest)). assert ((pair_rel eq (@Permutation _) ==> @st_eq _) s s) as H2. intros [u w] [[p q]] [A B]. simpl in A, B. subst u. cbv beta iota. apply mult_wd. reflexivity. apply inject_Q_CR_wd. rewrite B. reflexivity. pose proof (separates_Proper _ _ H1) as H3. assert (@Equivalence ((Q * CR) * list (Q * CR)) (pair_rel (@eq _) (@Permutation _))) as T. apply Pair.Equivalence_instance_0. apply _. apply _. (* I'm really clueless why this rewrite has ever worked? *) etransitivity. apply cm_Sum_Proper. apply cag_commutes. symmetry. apply (@map_perm_proper _ CR (pair_rel eq (@Permutation _)) (@st_eq _) T _ _ _ H2 _ _ H3). clear H2 H3. subst s. simpl @cm_Sum. rewrite cm_Sum_units. setoid_replace (' Π (map (fun xi0 : Q and CR => ((xi - fst xi0) * / (xi - fst xi0))%Q) x)) with 1%CR. change (y * 1 + 0 == y). ring. apply inject_Q_CR_wd. rewrite cr_Product_ones. reflexivity. intros. destruct (proj1 (in_map_iff _ _ _) H) as [x1 [[] H4]]. simpl. apply Qmult_inv_r. unfold QNoDup in distinct. revert distinct. apply Permutation_sym in H1. (* only needed to work around evar anomaly *) rewrite H1. intros H3 H5. simpl in H3. inversion_clear H3. apply H0. apply in_map_iff. exists (fst x1). split... apply Qred_complete. symmetry... apply -> Qminus_eq... apply in_map... intros. destruct (proj1 (in_map_iff _ _ _) H) as [[[v w] u] [[] H4]]. clear H. destruct (proj1 (in_map_iff _ _ _) H4) as [[[n m] k] [A B]]. inversion_clear A. simpl @cr_Product. setoid_replace (xi - xi)%Q with 0%Q by (simpl; ring). repeat rewrite Qmult_0_l. change ((w: CR) * 0 == 0). ring. Qed. (* Todo: Clean up more. *) End contents. Lemma interpolates_economically (qpoints: ne_list (Q * CR)): QNoDup (map fst qpoints) → interpolates_economically (ne_list.map (first inject_Q_CR) qpoints) (L qpoints). Proof with auto. split. rewrite ne_list.list_map. apply interpolates... rewrite ne_list.list_map. rewrite tl_map. rewrite map_length. apply degree... Qed. Module notations. Notation lagrange_poly := L. End notations. corn-8.20.0/broken/CompletePointFree.v000066400000000000000000000043421473720167500176140ustar00rootroot00000000000000(* This is a test of how to combine type classes with the old records. Specifically, how to use the pointfree machinery with the [Complete] monad *) Require Import CRtrans. Require Import Qmetric. Section ODE. Open Scope uc_scope. Require Import ProductMetric CompleteProduct. Require Import Unicode.Utf8. Require Import metric2.Classified. Require Import stdlib_rationals. (* Check (_:MetricSpaceClass (Q*Q)). Check (_:MetricSpaceClass (CR*Q)). *) Section bind_uc. (* We use the packed MetricSpace because we do not (yet) want to redefine Complete. However, here is a first attempt: Definition CompleteC Y `{MetricSpaceClass Y}:=(Complete (bundle_MetricSpace Y)). Context `{MetricSpaceClass X} `{MetricSpaceClass Y} {f: X → CompleteC Y} `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. *) Context {X Y : MetricSpace} (f: X → Complete Y) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. (* Definition bindf : Complete X -> Complete Y := Cbind_slow (wrap_uc_fun' f). Definition test: UCFunction (Complete X) (Complete Y):= ucFunction (fun x => bindf x). *) (* The classified version *) Definition Cbind_slowC: UCFunction (Complete X) (Complete Y):= ucFunction (Cbind_slow (wrap_uc_fun' f)). Variable g:X --> Complete Y. Definition test': UCFunction (Complete X) (Complete Y):= ucFunction (fun x => (Cbind_slow g) x). (* Note that: unwrap_uc_fun automatically unwraps g *) End bind_uc. Notation " f >> g ":= (Cbind_slowC f ∘ g) (at level 50). Notation " x >>= f ":= (Cbind_slowC f x) (at level 50). Section test. (* Should Q*Q be bundled ? *) Context (v: (Q*Q) → CR) `{!UniformlyContinuous_mu v} `{!UniformlyContinuous v}. Context (f:Q→CR) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. (* Can be replace by the default (,) ? Notation "( f , g )":= (together f g). We would like to define fun x => v (x, f x), more precisely: *) Check (Cbind_slowC v). Definition vxfx : UCFunction Q CR := ucFunction (fun x => (Couple (Cunit x, f x) >>= v)). Better: Definition vxfx : UCFunction Q CR := ucFunction (fun x => (Couple (x, f x) >>= v)). Where Cunit is derived from the Coercion inject_Q. Coercion inject_Q: QArith_base.Q>-> CR. But this cannot be a Coercion(?) *) End test.corn-8.20.0/broken/DivDiff_RepeatedIntegral.v000066400000000000000000000235021473720167500210410ustar00rootroot00000000000000(* Require Import Unicode.Utf8 Setoid Arith List Program Permutation metric2.Classified CSetoids CPoly_ApZero CRings CPoly_Degree CRArith Qmetric Qring CReals stdlib_omissions.Pair stdlib_omissions.Q list_separates SetoidPermutation util.Container NewAbstractIntegration algebra.CPoly_Newton Ranges. Require ne_list. Import ne_list.notations. Opaque CR. Section contents. Notation QPoint := (Q * CR)%type. Notation CRPoint := (CR * CR)%type. Local Notation Σ := cm_Sum. Require Import Qabs. (* Some utility operations and lemmas for ne_list/vector (todo: move these): *) Definition Vec_to_ne_list {A}: ∀ {n}, Vector.t A (S n) → ne_list A := @Vector.rectS A (fun _ _ => ne_list A) ne_list.one (fun a _ _ x => ne_list.cons a x). Lemma ne_list_head_map {A B} (f: A → B) (l: ne_list A): ne_list.head (ne_list.map f l) = f (ne_list.head l). Proof. induction l. reflexivity. simpl. congruence. Qed. Lemma ne_list_tail_map {A B} (f: A → B) (l: ne_list A): ne_list.tail (ne_list.map f l) = map f (ne_list.tail l). Proof. destruct l. reflexivity. simpl. induction l. reflexivity. simpl. congruence. Qed. Lemma ding_vec n A (v: Vector.t A (S n)): v = Vector.cons _ (Vector.hd v) _ (Vector.tl v). Proof. dependent destruction v. simpl. reflexivity. Qed. Lemma through_ne A n (v: Vector.t A (S n)): ne_list.to_list (Vec_to_ne_list _ v) = v. Proof with auto. induction n. dependent destruction v. dependent destruction v. simpl. reflexivity. dependent destruction v. simpl. rewrite IHn. reflexivity. Qed. Lemma Vec_cons_to_ne_list {A} n (a: A) (v: Vector.t A (S n)): Vec_to_ne_list _ (Vector.cons _ a _ v) = ne_list.cons a (Vec_to_ne_list _ v). Admitted. Lemma Vec_cons_to_ne_list' {A} n (v: Vector.t A n): ∀ a, Vec_to_ne_list _ (Vector.cons _ a _ v) = ne_list.from_list a v. Proof with auto. induction n. dependent destruction v. reflexivity. dependent destruction v. intros. change (Vec_to_ne_list (S n) (Vector.cons A a (S n) (Vector.cons A h n v)) = a ::: ne_list.from_list h v). rewrite <- IHn. reflexivity. Qed. Lemma ne_head_from_list {X} (x: X) (xs: list X): ne_list.head (ne_list.from_list x xs) = x. Proof. destruct xs; reflexivity. Qed. Lemma ne_to_from_list {X} (xs: list X): ∀ x, ne_list.to_list (ne_list.from_list x xs) = x :: xs. Proof. induction xs. reflexivity. simpl. rewrite IHxs. reflexivity. Qed. Lemma ne_tail_from_list {X} (x: X) (xs: list X): ne_list.tail (ne_list.from_list x xs) = xs. Proof. induction xs. reflexivity. simpl. rewrite ne_to_from_list. reflexivity. Qed. Lemma ne_list_map_from_list {X Y} (f: X → Y) (xs: list X): ∀ h, ne_list.map f (ne_list.from_list h xs) = ne_list.from_list (f h) (map f xs). Proof. induction xs; simpl; congruence. Qed. (* Section inner_space. (* Need vector space, norm, inner product, metric from norm, Lipschitz continuity from boundedness *) Definition norm `(x: Vector.t Q n):=Σ (map Qabs x). Definition inner (n:nat)(x y : Vector.t Q n):=Σ(map (λ p, Qmult (fst p) (snd p)) (zip x y)). End inner_space.*) Section divdiff_as_repeated_integral. Context (nth_deriv_bound: Range CR) (nth_deriv: Q → sig ((∈ nth_deriv_bound))) (* Todo: only require boundedness on the interval that contains the points. *) `{!UniformlyContinuous_mu nth_deriv} `{!UniformlyContinuous nth_deriv}. (* Todo: This should be replaced with some "n times differentiable" requirement on a subject function. *) Context (n: nat) (points: Vector.t Q (S n)). Opaque Qmult Qplus Qminus. (* Without these, instance resolution gets a little too enthusiastic and breaks these operations open when looking for PointFree instances below. It's actually kinda neat that it can put these in PointFree form though. *) Definition totalweight {n} (ws: Vector.t Q n): Q := cm_Sum ws. Notation SomeWeights n := (sig (λ ts: Vector.t Q n, totalweight ts <= 1)%Q). (** apply_weights: *) (** Note that this an innerproduct *) (** ||≤|points| |w| |-|=|| ≤||points|| ||w-v|| , the function is Lipshitz with constant norm ||points||*) Definition apply_weights (w: Vector.t Q (S n)): Q := cm_Sum (map (λ p, Qmult (fst p) (snd p)) (zip points (Vector.to_list w))). Instance apply_weights_mu: UniformlyContinuous_mu apply_weights. constructor. exact (fun x => x). Defined. Instance apply_weights_uc: UniformlyContinuous apply_weights. constructor; try apply _. intros ??? H. (*Check apply_weights. *) Admitted. Obligation Tactic := idtac. (** "inner", the function of n weights: *) Program Definition inner: SomeWeights n → sig ((∈ nth_deriv_bound)) := λ ts, nth_deriv (apply_weights (Vector.cons _ (1 - totalweight ts) _ ts))%Q. Instance inner_mu: UniformlyContinuous_mu inner. unfold inner. apply compose_mu. apply _. apply (@compose_mu (SomeWeights n) (Vector.t Q (S n)) Q (apply_weights)). apply _. Admitted. Instance inner_uc: UniformlyContinuous inner. Admitted. (** Next up is "reduce" *) Definition G (n: nat): Type := UCFunction (SomeWeights n) (sig ((∈ nth_deriv_bound))). Local Open Scope CR_scope. Section reduce. Variables (m: nat) (X: G (S m)). Program Definition integrand (ts: SomeWeights m) (t: sig ((∈ (0, (1 - totalweight ts))))%Q): sig ((∈ nth_deriv_bound)) := X (@uncurry_Vector_cons Q m (` t, ` ts)). Next Obligation. intros. change (`t + Σ (` ts) <= 1)%Q. admit. Qed. Instance integrand_mu: ∀ ts, UniformlyContinuous_mu (integrand ts). unfold integrand. intros. apply compose_mu. apply _. constructor. intro. apply Qpos2QposInf. exact H. Defined. Instance integrand_uc: ∀ ts, UniformlyContinuous (integrand ts). Proof. unfold integrand. intros. apply compose_uc. apply _. constructor; try apply _. simpl. intros. constructor. assumption. simpl. admit. (* doable *) Qed. Program Definition reduce_raw: SomeWeights m → sig ((∈ nth_deriv_bound)) := λ ts, @integrate_ucFunc_wrapped_for_continuity nth_deriv_bound (existT _ (0, 1 - totalweight (` ts))%Q (ucFunction (integrand ts))). Next Obligation. intros. unfold integrate_ucFunc_wrapped_for_continuity. simpl. Admitted. (* need to show that the result is bounded *) Instance reduce_mu: UniformlyContinuous_mu reduce_raw. Proof with auto. unfold reduce_raw. apply exist_mu. set (integrate_ucFunc_wrapped_for_continuity nth_deriv_bound). apply (@compose_mu (SomeWeights m) {r : Range Q & UCFunction (sig ((∈r))) (sig ((∈nth_deriv_bound)))} CR s). apply _. admit. Defined. Instance reduce_uc: UniformlyContinuous reduce_raw. Proof with auto. unfold reduce_raw. apply exist_uc. set (integrate_ucFunc_wrapped_for_continuity nth_deriv_bound). apply (@compose_uc (SomeWeights m) _ _ {r : Range Q & UCFunction (sig ((∈r))) (sig ((∈nth_deriv_bound)))} _ _ CR _ _ s). apply _. admit. Qed. Definition reduce: G m := ucFunction reduce_raw. End reduce. (** Finally, the divided difference arises from iterated reduction of the inner function: *) Definition alt_divdiff: CR. refine (proj1_sig (iterate reduce (ucFunction inner) _)). exists (Vector.nil Q). abstract (unfold totalweight; simpl; auto). Defined. (* Todo: Why won't Program work here? *) End divdiff_as_repeated_integral. Section divdiffs_equal. Context (f: Q → CR) (nth_deriv_bound: Range CR) (nth_deriv: Q → sig (∈nth_deriv_bound)). Lemma divdiffs_equal: ∀ n (xs: Vector.t Q (S n)), (divdiff (ne_list.map (λ x, (x, f x)) (Vec_to_ne_list _ xs)) == alt_divdiff nth_deriv_bound nth_deriv _ xs)%CR. Proof with auto. induction n. intros. assert (xs = Vector.cons _ (Vector.hd xs) _ (Vector.nil _)) as E. do 2 dependent destruction xs. reflexivity. rewrite E. change (f (Vector.hd xs) [=] proj1_sig (nth_deriv (Vector.hd xs * (1 - 0) + 0))). admit. (* in this case the nth derivative is f itself *) intros. simpl in *. unfold Basics.compose. dependent destruction xs. dependent destruction xs. rewrite Vec_cons_to_ne_list. unfold divdiff. rewrite ne_list_head_map. rewrite ne_list_tail_map. simpl @ne_list.head. change (divdiff_l (h, f h) (map (λ x : Q, (x, f x)) (Vec_to_ne_list n (Vector.cons Q h0 n xs)))[=] alt_divdiff nth_deriv_bound nth_deriv (S n) (Vector.cons Q h (S n) (Vector.cons Q h0 n xs))). rewrite through_ne. change (divdiff_l (h, f h) ((h0, f h0) :: map (λ x : Q, (x, f x)) xs)[=] alt_divdiff nth_deriv_bound nth_deriv (S n) (Vector.cons Q h (S n) (Vector.cons Q h0 n xs))). simpl. replace (divdiff_l (h, f h) (map (λ x : Q, (x, f x)) xs)) with (divdiff (ne_list.from_list (h, f h) (map (λ x : Q, (x, f x)) xs))). Focus 2. unfold divdiff. rewrite ne_head_from_list. rewrite ne_tail_from_list. reflexivity. replace (divdiff_l (h0, f h0) (map (λ x : Q, (x, f x)) xs)) with (divdiff (ne_list.from_list (h0, f h0) (map (λ x : Q, (x, f x)) xs))). Focus 2. unfold divdiff. rewrite ne_head_from_list. rewrite ne_tail_from_list. reflexivity. rewrite <- (ne_list_map_from_list (λ x: Q, (x, f x)) xs h). rewrite <- (ne_list_map_from_list (λ x: Q, (x, f x)) xs h0). rewrite <- Vec_cons_to_ne_list'. rewrite <- Vec_cons_to_ne_list'. rewrite IHn. rewrite IHn. clear IHn. unfold alt_divdiff. (* now it's "just" an equation between repeated integrals *) admit. Qed. End divdiffs_equal. End contents. *) corn-8.20.0/broken/IntegrationExamples.v000066400000000000000000000061051473720167500202110ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import Integration. Require Import AbstractIntegration. Require SimpleIntegration. Require SimpsonIntegration. Require Import CRtrans. Require QnonNeg. Import QnonNeg.notations. (* The answer function returns an approximation of r within 10^-n. Take the resulting integer and divide by 10^n to get the actual rational approximation. answer is useful for because it displays a familar list of digits rather than an unfamiliar fraction that approximate would return *) Definition answer (n:positive) (r:CR) : Z := let m := (iter_pos n _ (Pmult 10) 1%positive) in let (a,b) := (approximate r (1#m)%Qpos)*m in Zdiv a b. (* This file illustrates how to use the computational integration *) (* Please review RealFast.v for examples on how to compute with CR *) (* Integrate01 requires that we integrate uniformly continuous functions. Therefore we cannot integerate (sin : CR -> CR), we must instead integrate the UniformlyContinuousFunction (sin_uc : Q --> CR). *) Time Eval vm_compute in answer 3 (Integrate sin_uc 3 (1#2)). Time Eval vm_compute in answer 3 (SimpleIntegration.integrate sin_uc 3 (1#2)%Qnn). Time Eval vm_compute in answer 10 (SimpsonIntegration.integrate sin_uc 1 3 (1#2)%Qnn). (* Integrate01 the x^2 function Time Eval vm_compute in answer 3 (Integrate01 (uc_compose (CRpower_positive_bounded 2 (1#1)) Cunit)). Time Eval vm_compute in answer 4 (Integrate01 (uc_compose (CRpower_positive_bounded 2 (1#1)) Cunit)). *) (* find the supremum of cos on [0,1] *) Time Eval vm_compute in answer 3 (ContinuousSup01 cos_uc). (* find the supremum of id on [0,1] *) Time Eval vm_compute in answer 3 (ContinuousSup01 Cunit). (* An example of an elliptic integral that cannot be solved symbolically \int_0^1 (1-\fract{1}{4}\sin^2\phi)^{-\fract{1}{2}} d\phi *) Definition sinsquare:= (uc_compose (CRpower_positive_bounded 2 (1#1)) sin_uc). Definition quartersinsquare:=(uc_compose (scale (1#4)) sinsquare). Definition body:=(uc_compose (translate 1) quartersinsquare). Definition rootbody:=(uc_compose CRsqrt body). Time Eval vm_compute in answer 1 (Integrate01 rootbody). corn-8.20.0/broken/NewAbstractIntegration.v000066400000000000000000000234701473720167500206540ustar00rootroot00000000000000Require Import Unicode.Utf8 Program CRArith CRabs Qminmax Qauto Qround Qmetric stdlib_omissions.P stdlib_omissions.Z stdlib_omissions.Q stdlib_omissions.N metric2.Classified util.Container Ranges decision. Require QnonNeg QnnInf CRball. Import QnonNeg.notations QnnInf.notations CRball.notations. Implicit Arguments proj1_sig [[A] [P]]. Local Open Scope Q_scope. Local Open Scope uc_scope. Local Open Scope CR_scope. Hint Immediate ball_refl Qle_refl. (** Some missing theory about positive: *) Lemma Pmax_le_l (x y: positive): (x <= Pmax x y)%positive. Admitted. Lemma Pmax_le_r (x y: positive): (x <= Pmax y x)%positive. Admitted. Hint Immediate Pmax_le_l Pmax_le_r. (** A few summing/enumming utilities: *) Program Fixpoint enum' (n: nat): list (sig (ge n)) := match n with | O => nil | S n' => n' :: map (λ x: sig (ge n'), x) (enum' n') end. Lemma enum_enum' (n: nat): enum n = map (@proj1_sig _ _) (enum' n). Proof. induction n; simpl. reflexivity. rewrite IHn, map_map. reflexivity. Qed. Lemma length_enum' n: length (enum' n) = n. Proof with auto with arith. induction n... simpl. rewrite map_length... Qed. Definition cmΣ {M: CMonoid} (n: nat) (f: nat -> M): M := cm_Sum (map f (enum n)). Definition cmΣ' {M: CMonoid} (n: nat) (f: sig (ge n) → M): M := cm_Sum (map f (enum' n)). Opaque CR. Lemma cm_Sum_constant (c: CR) (l: list CR): (forall x, List.In x l → x == c) → cm_Sum l == ' length l * c. Proof with auto. intros. induction l. simpl. admit. simpl. rewrite IHl... admit. Qed. Lemma cmΣ'_constant (c: CR) (n: nat): cmΣ' n (λ _, c) == ' n * c. Proof with auto. unfold cmΣ'. rewrite (cm_Sum_constant c). rewrite map_length, length_enum'. reflexivity. intros. apply in_map_iff in H. destruct H. symmetry. destruct H. subst. reflexivity. Qed. (** A straightforward definition of a Riemann approximation with n samples: *) Program Definition Riemann (r: Range Q) (f: sig (In r) → CR) (n: positive): CR := let w := (snd r - fst r)%Q in let iw: Q := w / n in ' iw * cmΣ' (nat_of_P n) (λ i, f (fst r + (` i: nat) * iw)%Q). Next Obligation. Proof with auto with *. apply alt_in_QRange. exists (i / n). split. split. apply Qmult_le_0_compat. admit. apply Qinv_le_0_compat... apply Qdiv_le_1. split... admit. unfold Qdiv. generalize (Qinv n). intro. ring. Qed. (** ... and some properties thereof: *) Lemma Riemann_plus (r: Range Q) (f g: sig (In r) → CR) n: Riemann r (λ x, f x + g x) n == Riemann r f n + Riemann r g n. Proof with auto. unfold Riemann. unfold cmΣ'. Admitted. Lemma Riemann_scale (r: Range Q) (f: sig (In r) → CR) (c: CR) n: Riemann r (CRmult c ∘ f)%prg n == c * Riemann r f n. Proof with auto. unfold Riemann. unfold cmΣ'. unfold Basics.compose. Admitted. (** Finally, we say what it means for a value to be the integral of a function on some range: *) Class Integral (r: Range Q) (f: sig (∈ r) → CR): Type := integral: sig (λ x: CR, ∀ e: Qpos, ∃ n: positive, ∀ m: positive, (n <= m)%positive → ball e (Riemann r f m) x). (* this used to be just [∃ n, ball e (Riemann r f n) x], but i couldn't prove unicity that way *) Implicit Arguments Integral [[r]]. Implicit Arguments integral [[r] [Integral]]. Notation "∫" := integral. Lemma integral_unique (r: Range Q) (f: sig (In r) → CR) {i0: Integral f} {i1: Integral f}: ` i0 == ` i1. Proof with auto. destruct i0, i1. simpl @proj1_sig. apply ball_eq. intros. set (h := (e1 * (1#2))%Qpos). setoid_replace e1 with (h+h)%Qpos. 2: subst h; unfold QposEq; simpl; ring. specialize (e h). specialize (e0 h). destruct e, e0. apply ball_triangle with (Riemann r f (Pmax x1 x2))... apply ball_sym... Qed. (** We know what the integral must be for constant functions: *) Obligation Tactic := idtac. Section constant_integral. Context (r: Range Q) (y: CR). Notation f := (λ _: sig (In r), y). Program Definition integrate_constant: Integral f := ' (snd r - fst r)%Q * y. Next Obligation. Proof with auto. intros. exists 1%positive. intros. apply ball_eq_iff. unfold Riemann. clear H. rewrite cmΣ'_constant. admit. (* arithmetic *) Qed. Program Lemma constant_integral `{!Integral (λ _: sig (In r), y)}: ∫ f == integrate_constant. Proof. intros. apply integral_unique. Qed. End constant_integral. (** ...and for sums: *) Section additive. Context (r: Range Q) (f g: sig (In r) → CR) `{!Integral f} `{!Integral g}. Let summed := (λ x, f x + g x). Program Definition sum_integrals: Integral summed := ∫ f + ∫ g. Next Obligation. intro. unfold integral. destruct Integral0, Integral1. simpl @proj1_sig. set (h := (e * (1#2))%Qpos). specialize (e0 h). specialize (e1 h). destruct e0, e1. exists (Pmax x1 x2). intros. setoid_replace e with (h+h)%Qpos. 2: subst h; unfold QposEq; simpl; ring. unfold summed. rewrite Riemann_plus. admit. (* not hard *) Qed. Program Lemma summed_integral `{!Integral summed}: ∫ summed == sum_integrals. Proof. intro. apply integral_unique. Qed. End additive. (** ...and for scaled functions: *) Section scalar_mult. Context (r: Range Q) (f: sig (∈ r) → CR) `{!Integral f} (c: Qpos). Let scaled := (CRmult (' c) ∘ f)%prg. Program Definition scale_integral: Integral scaled := ' c * ∫ f. Next Obligation. intro. unfold integral. destruct Integral0. simpl @proj1_sig. specialize (e0 (e / c)%Qpos). destruct e0. exists x0. intros. specialize (H m H0). unfold scaled. rewrite Riemann_scale. admit. (* not hard *) Qed. Program Lemma scaled_integral `{!Integral scaled}: ∫ scaled == scale_integral. Proof. intro. apply integral_unique. Qed. End scalar_mult. (* Todo: generalize to more than just Qpos *) (** ...and if we know the integral for a function at two adjacent ranges, we know the integral on the merged range: *) Section adjacent. Context (a b c: Q) (fab: sig (In (a, b)) → CR) (fbc: sig (In (b, c)) → CR) (fac: sig (In (a, c)) → CR) (fab_good: ∀ x x', (` x == ` x')%Q → fab x == fac x') (fbc_good: ∀ x x', (` x == ` x')%Q → fac x == fac x') `{!Integral fab} `{!Integral fbc}. Program Definition integrate_merged: Integral fac := ∫ fab + ∫ fbc. Next Obligation. intro. unfold integral. destruct Integral0, Integral1. simpl @proj1_sig. set (h := (e * (1#2))%Qpos). specialize (e0 h). specialize (e1 h). destruct e0, e1. exists (x1 * x2)%positive. intros. Admitted. (* hassle, but doable, i think *) Context `{!Integral fac}. Program Lemma adjacent: ∫ fac == ∫ fab + ∫ fbc. Proof. transitivity (` integrate_merged). apply integral_unique. reflexivity. Qed. End adjacent. (** More generally, we can implement integration of uniformly continuous functions: *) Section implementable. Context (r: Range Q) (f: sig (∈ r) → CR) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. Definition integrate_ucFunc: Integral f. Admitted. End implementable. (* Note: This should be much easier than it was in the old setting, because now all we'll need to do (hopefully) in the implementation is show that it does indeed produce Riemann approximations, and we no longer have to show Bishop's properties. *) (** It should be fairly easy to prove that the implementation above is continuous in the function parameter: *) Section continuity_in_f. (* with fixed range *) Context (r: Range Q) . Program Let raw (u: UCFunction (sig (∈ r)) CR): CR := integrate_ucFunc r u. (* needed to remove the type dependency by dropping the Integral wrapping around the result CR *) Instance: UniformlyContinuous_mu raw. constructor. intro. admit. Defined. Instance: UniformlyContinuous raw. Proof with auto. constructor. apply _. apply _. intros. unfold raw. unfold uc_mu in H. simpl in H. Admitted. End continuity_in_f. (** Continuity in both range and function simultaneously is trickier. *) Section extend. Context (T: Type) (P: T → Prop) `{∀ t, Decision (P t)} (f: sig P → CR). Definition extend (t: T): CR := match decide (P t) with | left H => f (exist _ _ H) | right _ => 0 end. Context `{te: canonical_names.Equiv T}. Global Instance: Proper canonical_names.equiv extend. Admitted. End extend. Section continuity_in_both. Context (bound: Range CR). Definition IntegrationInput := sigT (λ r: Range Q, UCFunction (sig (∈ r)) (sig (∈ bound))). (* Hm, I think this probably needs an a-priori bound on r as well.. *) Instance dec_in: ∀ (a: Range Q), (∀ t : Q, Decision ((∈ a) t)). Admitted. Program Definition metric: IntegrationInput → Range Q * @sig (Q → CR) (Proper canonical_names.equiv) := λ ab, (projT1 ab, (@extend Q (∈ projT1 ab) _ (@proj1_sig _ _ ∘ ucFun_itself (projT2 ab))%prg)). (* should never actually run at runtime *) (* Global Instance IntegrationInput_equiv: canonical_names.Equiv IntegrationInput := delegated_equiv _ metric. Global Instance IntegrationInput_ball: MetricSpaceBall IntegrationInput := delegated_ball _ metric. Global Instance IntegrationInput_mspc: MetricSpaceClass IntegrationInput. Proof. apply (delegated_mspc _ metric). Qed. Program Definition integrate_ucFunc_wrapped_for_continuity: IntegrationInput → CR := λ p, integrate_ucFunc (fst (projT1 p), snd (projT1 p)) (λ x, projT2 p (` x)). Next Obligation. intros. destruct x. simpl. assumption. Qed. Global Instance integrate_ucFunc_wrapped_for_continuity_mu: UniformlyContinuous_mu integrate_ucFunc_wrapped_for_continuity. Admitted. Global Instance integrate_ucFunc_wrapped_for_continuity_uc: UniformlyContinuous integrate_ucFunc_wrapped_for_continuity. Proof. constructor. apply _. apply _. admit. Qed. *) End continuity_in_both. corn-8.20.0/broken/SimpsonIntegration.v000066400000000000000000000334441473720167500200710ustar00rootroot00000000000000Require Import List NPeano QArith Qabs Qpossec Qsums Qround Qmetric ZArith CRArith CRsum (*AbstractIntegration*) util.Qgcd Program uneven_CRplus stdlib_omissions.P stdlib_omissions.Z stdlib_omissions.Q. Open Scope uc_scope. Set Automatic Introduction. Hint Resolve Qpos_nonzero. Hint Immediate Q.Qle_nat. Hint Resolve Qmult_le_0_compat. Hint Resolve QnonNeg.Qplus_nonneg. Parameter (z:Z). (* Zsqrt_plain_is_pos *) (* Lemma Zsqrt_r_nonneg (z: Z) (E: 0 <= z): (0 <= Zsqrt z)%Z. Proof with auto. destruct Zsqrt; try easy. admit. subst. simpl. omega. Qed. *) Require Import Coq.ZArith.Zsqrt_compat. Open Scope Z_scope. Definition Z_4th_root_floor (x: Z): (0 <= x)%Z -> {s: Z & {r: Z | x = Zpower s 4 + r /\ Zpower s 4 <= x < Zpower (s + 1) 4}}%Z. Proof. intro E. destruct x. exists 0%Z. exists 0%Z. split. reflexivity. change (0 <= 0 < 1). omega. exists (projT1 (Zsqrt (projT1 (Zsqrt p (Zle_0_pos p))) (Zsqrt_plain_is_pos p E))). set (Zsqrt (projT1 (Zsqrt p (Zle_0_pos p))) (Zsqrt_plain_is_pos p E)). admit. exfalso. apply E. reflexivity. Defined. Definition Z_4th_root_floor_plain (z: Z): Z := match z with | Zpos p => projT1 (Z_4th_root_floor p (Zle_0_pos p)) | _ => 0%Z end. Lemma Zle_uniq {x y: Z} (p q: Zle x y): p = q. Admitted. Goal forall z, Z_4th_root_floor_plain z = Zsqrt_plain (Zsqrt_plain z). Proof. intros. unfold Zsqrt_plain. destruct z; try reflexivity. unfold Z_4th_root_floor_plain, Z_4th_root_floor. unfold projT1 at 1. generalize (Zsqrt_plain_is_pos). (* p (Zle_0_pos p)). *) unfold Zsqrt_plain. (*generalize (Zsqrt).*) (*p (Zle_0_pos p)).*) admit. (* destruct s. simpl @projT1 at 1. destruct x. simpl. reflexivity. *) admit. admit. (* rewrite (Zle_uniq z (Zle_0_pos p)). intro. reflexivity. simpl. intro. exfalso. apply z. reflexivity.*) Qed. Definition Q_4th_root_floor_plain (q: Q): Z := Z_4th_root_floor_plain (Qceiling q). Section definition. Context (f: Q_as_MetricSpace --> CR) (b: Q). (* bound for the absolute value of f's fourth derivative *) Section approx. Context (n : positive)(fr: Q) (w: Qpos) (e: Qpos). Definition N: positive := P_of_succ_nat (Zabs_nat (Q_4th_root_floor_plain ((w^5) / 2880 * b / e))). (* This Zabs is silly because we know the squaring thing only returns nonnegatives, but whatever. *) (* Also, a ceil variant would obviate need to take the successor, but I haven't defined ceil variants of the 4th root for Z/Q yet. *) Definition iw : Qpos := (w / N)%Qpos. Definition iw1 : Qpos := (w / n)%Qpos. Definition halfiw : Qpos := (w / ((2#1) * N))%Qpos. Definition halfiw1 : Qpos := (w / ((2#1) * n))%Qpos. Open Scope Q_scope. Definition simpson (fr: Q): CR := (' (iw / 6) * (f fr + f (fr + halfiw)%Q * '4 + f (fr + iw)%Q))%CR. Definition simpson1 (fr: Q): CR := (' (iw1) * (f fr + f (fr + halfiw1)%Q * '4 + f (fr + iw1)%Q))%CR. Definition approx: CR := CRsum_list (map (fun i: nat => simpson (fr + i * iw)) (N.enum (nat_of_P N))). Definition approx1 : CR := CRsum_list (map (fun i: nat => simpson1 (fr + i * iw1)) (N.enum (nat_of_P n))). End approx. Lemma regular fr w: is_RegularFunction_noInf CR (approx fr w). Admitted. Definition simpson_integral fr w: CR := Cjoin (mkRegularFunction ('(0%Q))%CR (regular fr w)). (* Global Instance integrate: Integral f := @integral_extended_to_nn_width f pre_result. *) End definition. Require Import ARtrans. Require Import Qdlog. Require Import BigQ ARbigQ ARQ ARbigD. Definition eps (n : positive) := (1 # (10^n))%Qpos. Definition answer (n:positive) (r:CR) : Z := let m := (10^n)%positive in let (a,b) := ((approximate r (1#m)%Qpos) * m)%Q in Zdiv a b. (*Time Eval vm_compute in approximate (simpson_integral sin_uc 1 0 1) (1#100000)%Qpos.*) Definition sum_pos `{Zero A, Plus A} (f : positive -> A) (n : positive) := Pos.peano_rect (λ _, A) 0 (λ p x, f p + x) n. Definition sum_pos_iter `{Zero A, Plus A} (f : positive -> A) (n : positive) : A := match n with | xH => 0 | _ => let z := Pos.iter (Pos.pred n) (λ y : positive * A, let (p, x) := y in ((Pos.succ p), (f p + x))) (1%positive, 0) in snd z end. Section ARsum. Context `{AppRationals AQ}. Definition ARsum_list_raw (l : list AR) (e : QposInf) : AQ := fold_left (@plus AQ _) match l with | nil => nil | cons h t => let e' := QposInf_mult (1#(Pos.of_nat (length t)))%Qpos e in (map (fun x => approximate x e') l) end 0. Definition ARsum_raw (f : positive -> AR) (n : positive) (eps : QposInf) : AQ := let e := (eps * (1 # Pos.pred n)%Qpos)%QposInf in sum_pos_iter (λ p, approximate (f p) e) n. Lemma ARsum_list_prf : forall l, @is_RegularFunction AQ_as_MetricSpace (ARsum_list_raw l). Admitted. Lemma ARsum_prf : forall f n, @is_RegularFunction AQ_as_MetricSpace (ARsum_raw f n). Admitted. Definition ARsum_list (l : list AR) : AR := Build_RegularFunction (ARsum_list_prf l). Definition ARsum (f : positive -> AR) (n : positive) : AR := Build_RegularFunction (ARsum_prf f n). End ARsum. Section ARInt. Context `{AppRationals AQ} (f : AR -> AR) (B : Q) (* bound for the absolute value of f's fourth derivative *) (a b : AR) (w : AQ). Let width : AR := b - a. Section ARIntN. Variable n : positive. Section ARIntEps. Variable eps : Qpos. Let hl' : AR := width * AQinv ('(Zpos n~0)). (* hl' = width / (2 * n) *) Let eps' : Qpos := eps * (1 # (6 * n)%positive)%Qpos. Let h (p : positive) := approximate (f (a + ARscale ('(Zpos p)) hl')) eps'. Definition ARsimpson_sum_raw : AQ := 4 * (sum_pos_iter (λ p, h (Pos.pred_double p)) (Pos.succ n)) + 2 * (sum_pos_iter (λ p, h p~0) n) + (approximate (f a) eps' + approximate (f b) eps'). End ARIntEps. Lemma ARsimson_sum_regular : is_RegularFunction_noInf AQ_as_MetricSpace ARsimpson_sum_raw. Admitted. Definition ARsimpson_sum : AR := mkRegularFunction 0 ARsimson_sum_regular. End ARIntN. Section ARIntEps1. Variable eps : Qpos. Definition num_intervals : nat := S (Z.to_nat (Q_4th_root_floor_plain ('w^5 / 2880 * B / eps))). (* To be optimized *) Definition num_intervals1 : positive := P_of_succ_nat (Zabs_nat (Q_4th_root_floor_plain (('w^5) / 2880 * B / eps))). Definition num_intervals2 : positive := let w : Q := 'approximate width (1#1000)%Qpos + (1#1000) in Pos.succ (Z.to_pos (Q_4th_root_floor_plain (w^5 / 2880 * B / eps))). (* half-length *) Let hl : AR := width * AQinv ('(Zpos (num_intervals2~0)%positive)). Let f' (n : nat) := f(a + '(n : Z) * 'w * AQinv ('(2 * (num_intervals : Z))%Z)). Let g (p : positive) := f(a + ARscale ('(Zpos p)) hl). (*Let h (p : positive) (e : Qpos) := approximate (f (a + ARscale ('(Zpos p)) hl)) e.*) Definition ARsimpson_raw : AR := (ARscale 4 (ARsum_list (map (fun i : nat => f' (2 * i + 1)) (N.enum (num_intervals - 0)))) + ARscale 2 (ARsum_list (map (fun i : nat => f' (2 * i + 2)) (N.enum (num_intervals - 1)))) + (f' 0 + f' (2 * num_intervals))) * 'w * AQinv ('(6 * (num_intervals : Z))%Z). Definition ARsimpson1_raw : AR := ((ARscale 4 (ARsum (λ p, g (Pos.pred_double p)) (Pos.succ num_intervals2))) + (ARscale 2 (ARsum (λ p, g p~0) num_intervals2)) + (f a + f b)) * width * AQinv ('(6 * (num_intervals2 : Z))%Z). (*Definition ARsimpson_sum_raw : AQ := let e := eps * (1 # (6 * num_intervals2)%positive)%Qpos in 4 * (sum_pos_iter (λ p, h (Pos.pred_double p) e) (Pos.succ num_intervals2)) + 2 * (sum_pos_iter (λ p, h p~0 e) num_intervals2) + (approximate (f a) e + approximate (f b) e).*) Definition ARsimpson2_raw : AR := ARsimpson_sum num_intervals2 * (width * AQinv ('Zpos (6 * num_intervals2)%positive)). End ARIntEps1. Lemma ARsimson_regular : is_RegularFunction_noInf AR ARsimpson_raw. Admitted. Lemma ARsimson1_regular : is_RegularFunction_noInf AR ARsimpson1_raw. Admitted. Lemma ARsimson2_regular : is_RegularFunction_noInf AR ARsimpson2_raw. Admitted. Definition ARsimpson : AR := Cjoin (mkRegularFunction 0 ARsimson_regular). Definition ARsimpson1 : AR := Cjoin (mkRegularFunction 0 ARsimson1_regular). Definition ARsimpson2 : AR := Cjoin (mkRegularFunction 0 ARsimson2_regular). End ARInt. (*Time Compute approximate (ARexp (AQ := bigD) 4) (eps 2000) Time Check approximate ((ARexp (AQ := bigD) 4) * '((10 ^ 1000)%positive : Z)) (1#1)%Qpos.*) (*Compute N 3 1 (eps 20). Compute num_intervals (AQ := bigD) 3 1 (eps 13).*) (*Extraction "mult.ml" ARmult.*) (*Time Compute approximate (simpson_integral (exp_bound_uc 2) 3 0 1) (eps 11).*) (* (* The following shows that in evaluating x * y up to eps, (approximate x (eps / (2 * c))) where c is an approximation of y up to 1, is computed once and not twice. We make y very large so that the approximation of x takes a long time. Multiplcation takes less than twice the time of the approximation of x. *) Definition int := (ARsimpson (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 3 0 1). Definition e := '((10 ^ 12)%positive : Z) : ARbigD. Time Compute approximate (int * e) (1#1)%Qpos. Time Compute approximate int (eps 13). *) (* (ARexp x) calls ARexp_bounded on (Qceiling ('approximate x (1#1)%Qpos + (1#1))) and x. If x = 1, then the approximation is 2. *) Definition repeat {A : Type} (M : unit -> A) (n : positive) := Pos.iter n (fun _ => (fun _ => tt) (M tt)) tt. (*Definition M := fun _ : unit => approximate (ARexp_bounded (AQ := bigD) 2 1) (eps 12).*) (*Compute num_intervals2 (AQ := bigD) 3 0 1 (eps 15).*) (*Time Compute approximate (ARsimpson (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 3 0 1) (eps 14). Time Compute approximate (ARsimpson1 (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 3 0 1) (eps 14).*) (*Time Compute approximate (ARsimpson2 (AQ := Q) (ARexp_bounded 2) 3 0 1) (eps 9). Time Compute approximate (ARsimpson_sum (AQ := bigD) (ARexp_bounded (AQ := bigD) 2) 0 1 1012) (eps 14).*) Section Picard. Context `{AppRationals AQ} (F : AR -> AR) (a b : AR). Definition picard (f : AR -> AR) (x : AR) := b + ARsimpson2 (AQ := AQ) (λ t, F (f t)) 1 a x. Definition picard_iter (n : nat) : AR -> AR := nat_iter n picard (λ _, b). End Picard. Definition d := approximate (picard_iter (AQ := bigD) (λ y, y) 0 1 6 1) (eps 1). Extraction "simpson.ml" d. Time Compute approximate (picard_iter (AQ := bigD) (λ y, y) 0 1 6 1) (eps 1). (*Time Compute approximate (ARsimpson (AQ := bigD) ARexp 3 0 1) (eps 10). Time Compute approximate (ARsimpson (AQ := bigD) ARarctan 1 0 1) (eps 1). Time Compute approximate (ARsimpson (AQ := bigD) ARsqrt 3 0 1) (eps 12). Timeout 30 Compute approximate (ARsimpson (AQ := bigD) ARexp 3 0 1) (eps 1). Compute num_intervals (AQ := bigD) 3 1 (eps 0).*) Section ARInt'. Context `{AppRationals AQ} (f : AQ -> AR) (B : Q). (* bound for the absolute value of f's fourth derivative *) Section ARapprox. Context (n : positive) (a : AQ) (w : AQ) (eps : Qpos). Definition N' : nat := Z.to_nat (1 + Zdiv (Qdlog2 ('w^5 / 2880 * B / eps))%Q 4). Definition iw' : AQ := w ≪ -(N' : Z). Definition iw1' : AQ := w ≪ -(n : Z). Definition simpson' (a' : AQ) : AR := ('iw' * (f a' + f (a' + (iw' ≪ -1)) * '4 + f (a' + iw'))). Definition simpson1' (a' : AQ) : AR := ('iw1' * (f a' + f (a' + (iw1' ≪ -1)) * '4 + f (a' + iw1'))). Definition approx' : AR := ARsum_list (map (fun i : nat => simpson' (a + '(i : Z) * iw')) (N.enum (2^N'))). Definition approx1' : AR := ARsum_list (map (fun i : nat => simpson1' (a + '(i : Z) * iw1')) (N.enum (nat_of_P (2^n)%positive))). End ARapprox. Lemma regular' a w : is_RegularFunction_noInf AR (approx' a w). Admitted. Definition simpson_integral' a w : AR := Cjoin (mkRegularFunction 0 (regular' a w)). End ARInt'. Time Compute approximate (simpson_integral' (AQ := bigD) AQexp 3 0 1) (eps 10). Time Compute approximate (simpson_integral' (AQ := bigD) ARexp 3 0 1) (eps 10). (*Eval compute in N' (AQ := bigD) 1 1 (eps 8). Eval compute in N 1 1 (eps 8).*) (*Time Check approximate (ARexp_bounded_uc (AQ := bigD) 2 1) (eps 20). Time Check approximate (ARexp (AQ := bigD) 1) (eps 20). Time Eval vm_compute in approximate (ARexp_bounded_uc (AQ := bigD) 2 1) (eps 20). Time Eval vm_compute in approximate (ARexp (AQ := bigD) 1) (eps 20).*) (*Time Check approximate (Cjoin_fun (Cmap_fun AQPrelengthSpace (ARexp_bounded_uc (AQ := bigD) 2) 1)) (eps 20). Time Eval vm_compute in approximate (Cjoin_fun (Cmap_fun AQPrelengthSpace (ARexp_bounded_uc (AQ := bigD) 2) 1)) (eps 20).*) Time Eval vm_compute in approximate (ARexp (AQ := bigD) 1) (eps 20). Time Eval vm_compute in approximate (exp 1) (eps 20). Time Eval vm_compute in approximate (exp_bound_uc 3 1) (eps 130). Time Eval vm_compute in approximate (ARsin_uc (AQ := bigD) 1) (eps 20). Time Eval vm_compute in approximate (sin_uc 1) (eps 20). Time Eval vm_compute in approximate (sin_slow 1) (eps 50). Time Eval vm_compute in approximate (ARsin (AQ := bigD) 1) (eps 50). Require Import PowerSeries. Time Eval vm_compute in approximate (ARsin (AQ := bigD) (ARsin (AQ := bigD) (ARsin (AQ := bigD) 1))) (eps 25). Time Eval vm_compute in approximate (approx1 sin_uc 32 0 1) (eps 50). Time Eval vm_compute in approximate (approx1' (AQ := bigD) ARsin_uc 5 0 1) (eps 50). Time Eval vm_compute in (fun _ => tt) (map (fun _ => approximate (ARsin_uc (AQ := bigD) 1) (eps 10)) (N.enum 10)). Time Eval vm_compute in (fun _ => tt) (map (fun _ => approximate (sin_uc 1) (eps 10)) (N.enum 10)). Time Eval vm_compute in approximate (approx' (AQ := bigD) ARsin_uc 1 0 1 (eps 8)) (eps 8). Time Eval vm_compute in approximate (simpson_integral sin_uc 1 0 1) (1#100000000)%Qpos. Time Eval vm_compute in answer 8 (simpson_integral sin_uc 1 0 1). (*Eval vm_compute in approximate (simpson' (AQ := bigD) ARsin_uc 1 1 (1#1)%Qpos 0) (1#1)%Qpos.*) (*Eval vm_compute in (*cast _ Q*) (approximate (approx' (AQ := bigD) ARsin_uc 1 0 1 (1#10)%Qpos) (1#10)%Qpos).*) Time Eval vm_compute in cast _ Q (approximate (simpson_integral' (AQ := bigD) ARsin_uc 1 0 1) (1#100000000)%Qpos). Time Eval vm_compute in N.enum ((2 : nat)^(N' (AQ := bigD) 1 1 (1#10000000000)%Qpos)). corn-8.20.0/broken/abstract_gsum.v000066400000000000000000000070661473720167500170740ustar00rootroot00000000000000 (* Import in the following order to minimize trouble: stdlib, old corn things, mathclasses, new corn things *) Require Import Limit. Require Import abstract_algebra orders additional_operations streams series. (* Lemma forall_impl {A} (P Q: ∞ A → Prop) (H1:∀ t, P t → Q t) : ∀ t, ForAll P t → ForAll Q t. Proof. cofix G. split. apply (H1 t). destruct H as [Ha _]. exact Ha. destruct H as [_ Hb]. apply (G (tl t) Hb). Qed. *) (** This section is about computing a generalized version of a geometric series. A geometric series has the form $s_{i+1} = r * s_i$ for some ratio $0 < r < 1$ (should we allow negative values for $a$ the series will be alternating, however, we don't allow this). We impose a further positivity restriction on the elements of the series, $0 ≤ s_i$. *) Section geom_sum. (** We work abstractly of an ordered ring R *) Context `{FullPseudoSemiRingOrder R}. (** R is not automatically a SemiRing as this causes loops in instance search. So we add it locally as this is needed for rewrites, e.g. (1) *) Instance: SemiRing R := pseudo_srorder_semiring. (** A geometric series is a series with a constant ratio between succesive terms. Here we parametrize by this ratio *) Variable r : R. Hypothesis Hr : 0 < r < 1. (** A slightly stricter (positive) version of [GeometricSeries], which specifies a slightly more general (less-than instead of equality) version of a geometric series. *) Definition ARGeometricSeries : ∞ R → Prop := ForAll (λ xs, 0 ≤ hd (tl xs) ≤ r * hd xs). Section properties. Context `(gs: ARGeometricSeries s). (** If [s] is a geometric series, then so is it's tail *) Lemma gs_tl : ARGeometricSeries (tl s). Proof. apply ForAll_tl; now assumption. Qed. (** Every element in a geometric series is positive *) Lemma gs_positive : 0 ≤ hd s. Proof. destruct gs as [GS FA]. apply (maps.order_reflecting_pos (.*.) r); try tauto. rewrite rings.mult_0_r. transitivity (hd (tl s)); tauto. Qed. (** A geometric series is always decreasing *) Lemma gs_decreasing : hd (tl s) ≤ hd s. Proof. destruct gs. apply (maps.order_reflecting_pos (.*.) r); try tauto. transitivity (hd (tl s)); try tauto. rewrite <- (rings.mult_1_l (hd (tl s))) at 2. apply semirings.mult_le_compat; try solve [apply orders.lt_le; tauto]. tauto. reflexivity. Qed. Notation "'x₀'" := (hd s). (* if only... Notation "'xₙ₊1'" := (Str_nth (n + 1) s). Notation "'xₙ'" := (Str_nth n s). *) Require Import nat_pow. Lemma helper n `{xs:∞A} : Str_nth (1 + n) xs ≡ hd (tl (Str_nth_tl n xs)). Admitted. (* [peano_naturals.nat_induction] is a induction scheme that uses type classed naturals. *) Lemma gs_nth_rn n : Str_nth n s ≤ r^n * x₀. Proof. induction n using peano_naturals.nat_induction. rewrite nat_pow_0, rings.mult_1_l; compute; reflexivity. rewrite nat_pow_S. apply (ForAll_Str_nth_tl n) in gs. destruct gs as [[GS1 GS2] FA]. replace (hd (Str_nth_tl n s)) with (Str_nth n s) in GS2 by auto. replace (hd (tl (Str_nth_tl n s))) with (Str_nth (1+n) s) in GS2. transitivity (r * Str_nth n s); [assumption|]. rewrite <- associativity. apply (maps.order_preserving_nonneg (.*.) r). apply orders.lt_le. destruct Hr as [Ha Hb]. auto. assumption. apply helper. Admitted. End properties. (** A geometric series is decreasing and non negative. *) Lemma gs_dnn `(gs: ARGeometricSeries s) : DecreasingNonNegative s. Proof. revert s gs. cofix FIX; intros s gs. constructor. now split; auto using gs_positive, gs_tl, gs_decreasing. now apply FIX, gs_tl. Qed. End geom_sum.corn-8.20.0/broken/algebra/000077500000000000000000000000001473720167500154335ustar00rootroot00000000000000corn-8.20.0/broken/algebra/bigopsClass.v000066400000000000000000001177061473720167500201070ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype. Require Import finfun paths. Require Import Setoid Morphisms. Require Import OperationClasses. Set Implicit Arguments. Unset Strict Implicit. Reserved Notation "\big [ op / idx ]_ i F" (at level 36, F at level 36, op, idx at level 10, i at level 0, right associativity, format "'[' \big [ op / idx ]_ i '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( <- r | P ) F" (at level 36, F at level 36, op, idx at level 10, r at level 50, format "'[' \big [ op / idx ]_ ( <- r | P ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i <- r | P ) F" (at level 36, F at level 36, op, idx at level 10, i, r at level 50, format "'[' \big [ op / idx ]_ ( i <- r | P ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i <- r ) F" (at level 36, F at level 36, op, idx at level 10, i, r at level 50, format "'[' \big [ op / idx ]_ ( i <- r ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" (at level 36, F at level 36, op, idx at level 10, m, i, n at level 50, format "'[' \big [ op / idx ]_ ( m <= i < n | P ) F ']'"). Reserved Notation "\big [ op / idx ]_ ( m <= i < n ) F" (at level 36, F at level 36, op, idx at level 10, i, m, n at level 50, format "'[' \big [ op / idx ]_ ( m <= i < n ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i | P ) F" (at level 36, F at level 36, op, idx at level 10, i at level 50, format "'[' \big [ op / idx ]_ ( i | P ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i : t | P ) F" (at level 36, F at level 36, op, idx at level 10, i at level 50, format "'[' \big [ op / idx ]_ ( i : t | P ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i : t ) F" (at level 36, F at level 36, op, idx at level 10, i at level 50, format "'[' \big [ op / idx ]_ ( i : t ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i < n | P ) F" (at level 36, F at level 36, op, idx at level 10, i, n at level 50, format "'[' \big [ op / idx ]_ ( i < n | P ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i < n ) F" (at level 36, F at level 36, op, idx at level 10, i, n at level 50, format "'[' \big [ op / idx ]_ ( i < n ) F ']'"). Reserved Notation "\big [ op / idx ]_ ( i \in A | P ) F" (at level 36, F at level 36, op, idx at level 10, i, A at level 50, format "'[' \big [ op / idx ]_ ( i \in A | P ) '/ ' F ']'"). Reserved Notation "\big [ op / idx ]_ ( i \in A ) F" (at level 36, F at level 36, op, idx at level 10, i, A at level 50, format "'[' \big [ op / idx ]_ ( i \in A ) '/ ' F ']'"). Open Scope equiv_scope. Open Scope signature_scope. Delimit Scope big_scope with BIG. Open Scope big_scope. Require Import bigops. Definition index_iota m n := iota m (n - m). Definition index_enum (T : finType) := Finite.enum T. Lemma mem_index_iota : forall m n i, i \in index_iota m n = (m <= i < n). Proof. move=> m n i; rewrite mem_iota; case le_m_i: (m <= i) => //=. by rewrite -leq_sub_add leq_subS // -subn_gt0 subn_sub addnC subnK // subn_gt0. Qed. Lemma filter_index_enum : forall T P, filter P (index_enum T) = enum P. Proof. by []. Qed. Notation "\big [ op / idx ]_ ( <- r | P ) F" := (reducebig idx op r P F) : big_scope. Notation "\big [ op / idx ]_ ( i <- r | P ) F" := (reducebig idx op r (fun i => P%B) (fun i => F)) : big_scope. Notation "\big [ op / idx ]_ ( i <- r ) F" := (reducebig idx op r (fun _ => true) (fun i => F)) : big_scope. Notation "\big [ op / idx ]_ ( m <= i < n | P ) F" := (reducebig idx op (index_iota m n) (fun i : nat => P%B) (fun i : nat => F)) : big_scope. Notation "\big [ op / idx ]_ ( m <= i < n ) F" := (reducebig idx op (index_iota m n) (fun _ => true) (fun i : nat => F)) : big_scope. Notation "\big [ op / idx ]_ ( i | P ) F" := (reducebig idx op (index_enum _) (fun i => P%B) (fun i => F)) : big_scope. Notation "\big [ op / idx ]_ i F" := (reducebig idx op (index_enum _) (fun _ => true) (fun i => F)) : big_scope. Notation "\big [ op / idx ]_ ( i : t | P ) F" := (reducebig idx op (index_enum _) (fun i : t => P%B) (fun i : t => F)) (only parsing) : big_scope. Notation "\big [ op / idx ]_ ( i : t ) F" := (reducebig idx op (index_enum _) (fun _ => true) (fun i : t => F)) (only parsing) : big_scope. Notation "\big [ op / idx ]_ ( i < n | P ) F" := (\big[op/idx]_(i : ordinal n | P%B) F) : big_scope. Notation "\big [ op / idx ]_ ( i < n ) F" := (\big[op/idx]_(i : ordinal n) F) : big_scope. Notation "\big [ op / idx ]_ ( i \in A | P ) F" := (\big[op/idx]_(i | (i \in A) && P) F) : big_scope. Notation "\big [ op / idx ]_ ( i \in A ) F" := (\big[op/idx]_(i | i \in A) F) : big_scope. Add Parametric Morphism I `{Equivalence} : (@reducebig A I) with signature (R==>(R==>R==>R)==>@eq (seq I)==>(@eq I==>@eq bool)==>(pointwise_relation I R)==>R) as reducebig_morph. move=> x y eqxy op1 op2 eqop12 r P1 P2 eqP12 F1 F2 eqF12. elim: r=> //= h q HR; rewrite (eqP12 h h (refl_equal h)). by case: (P2 h)=> //=; apply: eqop12=> //=; apply: eqF12. Qed. Section Extensionality. Context `{Equivalence} {idx : A} {op : binop A}. Context `{Proper (binop A) (R==>R==>R) op}. Section SeqExtension. Variable I : Type. Lemma big_filter : forall r (P : pred I) F, \big[op/idx]_(i <- filter P r) F i === \big[op/idx]_(i <- r | P i) F i. Proof. by move=> r P F; elim: r; try reflexivity; move=> i r //=; case (P i); move=> Heq; rewrite <- Heq; reflexivity. Qed. Lemma eq_bigl : forall r (P1 P2 : pred I) F, P1 =1 P2 -> \big[op/idx]_(i <- r | P1 i) F i === \big[op/idx]_(i <- r | P2 i) F i. Proof. move=> r P1 P2 F eqP12; rewrite <- big_filter, (eq_filter eqP12), big_filter; reflexivity. Qed. Lemma eq_bigr : forall r (P : pred I) F1 F2, (forall i, P i -> F1 i === F2 i) -> \big[op/idx]_(i <- r | P i) F1 i === \big[op/idx]_(i <- r | P i) F2 i. Proof. move=> r P F1 F2 eqF12. elim: r => //=;try reflexivity; move=> x r H1. case Px: (P x); last by assumption. apply H0; [apply eqF12; assumption|rewrite -> H1; reflexivity]. Qed. Lemma eq_big : forall r (P1 P2 : pred I) F1 F2, P1 =1 P2 -> (forall i, P1 i -> F1 i === F2 i) -> \big[op/idx]_(i <- r | P1 i) F1 i === \big[op/idx]_(i <- r | P2 i) F2 i. Proof. move=> r P1 P2 F1 F2; move/eq_bigl=> Heq; rewrite <- Heq=>{Heq}. move/eq_bigr=> Heq; rewrite -> Heq=>{Heq}; reflexivity. Qed. Lemma congr_big : forall r1 r2 (P1 P2 : pred I) F1 F2, r1 = r2 -> P1 =1 P2 -> (forall i, P1 i -> F1 i === F2 i) -> \big[op/idx]_(i <- r1 | P1 i) F1 i === \big[op/idx]_(i <- r2 | P2 i) F2 i. Proof. move=> r1 r2 P1 P2 F1 F2 <-{r2}; exact: eq_big. Qed. Lemma big_filter_cond : forall r (P1 P2 : pred I) F, \big[op/idx]_(i <- filter P1 r | P2 i) F i === \big[op/idx]_(i <- r | P1 i && P2 i) F i. Proof. move=> r P1 P2 F; rewrite <- big_filter, <- (big_filter r). apply congr_big=> [|i|]; try reflexivity. by rewrite -filter_predI; apply: eq_filter => i; exact: andbC. Qed. Lemma big_nil : forall (P : pred I) F, \big[op/idx]_(i <- [::] | P i) F i === idx. Proof. by reflexivity. Qed. Lemma big_cons : forall i r (P : pred I) F, let x := \big[op/idx]_(j <- r | P j) F j in \big[op/idx]_(j <- i :: r | P j) F j === if P i then op (F i) x else x. Proof. by reflexivity. Qed. Lemma big_map : forall (J : eqType) (h : J -> I) r (P : pred I) F, \big[op/idx]_(i <- map h r | P i) F i === \big[op/idx]_(j <- r | P (h j)) F (h j). Proof. move=> J h r P F; elim: r;try reflexivity; move=> j r //=. by case: (P (h j)); move=> Heq; rewrite -> Heq; reflexivity. Qed. Lemma big_nth : forall x0 r (P : pred I) F, \big[op/idx]_(i <- r | P i) F i === \big[op/idx]_(0 <= i < size r | P (nth x0 r i)) (F (nth x0 r i)). Proof. move=> x0 r P F; rewrite -{1}(mkseq_nth x0 r) /mkseq. by rewrite -> (big_map (nth x0 r)); rewrite /index_iota subn0; reflexivity. Qed. Lemma big_hasC : forall r (P : pred I) F, ~~ has P r -> \big[op/idx]_(i <- r | P i) F i === idx. Proof. move=> r P F; rewrite <- big_filter; rewrite has_count count_filter. case: filter => // _; exact: big_nil. Qed. Lemma big_pred0_eq : forall (r : seq I) F, \big[op/idx]_(i <- r | false) F i === idx. Proof. by move=> r F; rewrite -> (big_hasC)=> //; try apply H; try reflexivity; rewrite has_pred0. Qed. Lemma big_pred0 : forall r (P : pred I) F, P =1 xpred0 -> \big[op/idx]_(i <- r | P i) F i === idx. Proof. move=> r P F; move/eq_bigl=> Heq; rewrite -> Heq; exact: big_pred0_eq. Qed. Lemma big_cat_nested : forall r1 r2 (P : pred I) F, let x := \big[op/idx]_(i <- r2 | P i) F i in \big[op/idx]_(i <- r1 ++ r2 | P i) F i === \big[op/x]_(i <- r1 | P i) F i. Proof. by move=> r1 r2 P F; rewrite /reducebig foldr_cat; reflexivity. Qed. Lemma big_catl : forall r1 r2 (P : pred I) F, ~~ has P r2 -> \big[op/idx]_(i <- r1 ++ r2 | P i) F i === \big[op/idx]_(i <- r1 | P i) F i. Proof. by move=> r1 r2 P F; rewrite -> big_cat_nested; move/big_hasC=> Heq; rewrite -> Heq; reflexivity. Qed. Lemma big_catr : forall r1 r2 (P : pred I) F, ~~ has P r1 -> \big[op/idx]_(i <- r1 ++ r2 | P i) F i === \big[op/idx]_(i <- r2 | P i) F i. Proof. move=> r1 r2 P F; rewrite <- big_filter, <- (big_filter r2), filter_cat. by rewrite has_count count_filter; case: filter; try reflexivity. Qed. Lemma big_const_seq : forall r (P : pred I) x, \big[op/idx]_(i <- r | P i) x === iter (count P r) (op x) idx. Proof. move=> r P x; elim: r; try reflexivity; move=> i r //=. by case: (P i); move=> Heq; rewrite -> Heq; reflexivity. Qed. End SeqExtension. Lemma big_cond_seq : forall (I : eqType) r (P : pred I) F, \big[op/idx]_(i <- r | P i) F i === \big[op/idx]_(i <- r | P i && (i \in r)) F i. Proof. move=> I r P F; rewrite <- !(big_filter r). apply congr_big=> [|i|]; try reflexivity. by apply: eq_in_filter => i ->; rewrite andbT. Qed. Lemma congr_big_nat : forall m1 n1 m2 n2 P1 P2 F1 F2, m1 = m2 -> n1 = n2 -> (forall i, m1 <= i < n2 -> P1 i = P2 i) -> (forall i, P1 i && (m1 <= i < n2) -> F1 i === F2 i) -> \big[op/idx]_(m1 <= i < n1 | P1 i) F1 i === \big[op/idx]_(m2 <= i < n2 | P2 i) F2 i. Proof. move=> m n _ _ P1 P2 F1 F2 <- <- eqP12 eqF12. rewrite -> (big_cond_seq _ P1), -> (big_cond_seq _ P2). apply: eq_big => i; rewrite ?inE /= !mem_index_iota; last exact: eqF12. case inmn_i: (m <= i < n); rewrite ?(andbT, andbF) //; exact: eqP12. Qed. Lemma big_geq : forall m n (P : pred nat) F, m >= n -> \big[op/idx]_(m <= i < n | P i) F i === idx. Proof. by move=> m n P F ge_m_n; rewrite /index_iota (eqnP ge_m_n); rewrite -> big_nil; reflexivity. Qed. Lemma big_ltn_cond : forall m n (P : pred nat) F, m < n -> let x := \big[op/idx]_(m.+1 <= i < n | P i) F i in \big[op/idx]_(m <= i < n | P i) F i === if P m then op (F m) x else x. Proof. move=> m [//|n] P F le_m_n; rewrite /index_iota leq_subS //=. by case: (P m); reflexivity. Qed. Lemma big_ltn : forall m n F, m < n -> \big[op/idx]_(m <= i < n) F i === op (F m) (\big[op/idx]_(m.+1 <= i < n) F i). Proof. move=> *; exact: big_ltn_cond. Qed. Lemma big_addn : forall m n a (P : pred nat) F, \big[op/idx]_(m + a <= i < n | P i) F i === \big[op/idx]_(m <= i < n - a | P (i + a)) F (i + a). Proof. move=> m n a P F. rewrite /index_iota subn_sub addnC iota_addl; rewrite -> (big_map (addn a)). by apply: eq_big => ? *; rewrite addnC;try reflexivity. Qed. Lemma big_add1 : forall m n (P : pred nat) F, \big[op/idx]_(m.+1 <= i < n | P i) F i === \big[op/idx]_(m <= i < n.-1 | P (i.+1)) F (i.+1). Proof. move=> m n P F; rewrite -addn1; rewrite -> big_addn, subn1. by apply: eq_big => ? *; rewrite addn1;try reflexivity. Qed. Lemma big_nat_recl : forall n F, \big[op/idx]_(0 <= i < n.+1) F i === op (F 0) (\big[op/idx]_(0 <= i < n) F i.+1). Proof. by move=> n F; rewrite -> big_ltn=> //; rewrite -> big_add1;try reflexivity. Qed. Lemma big_mkord : forall n (P : pred nat) F, \big[op/idx]_(0 <= i < n | P i) F i === \big[op/idx]_(i < n | P i) F i. Proof. move=> n P F; rewrite /index_iota subn0; rewrite <- (big_map (@nat_of_ord n)). apply (reducebig_morph _); try reflexivity; try apply H0. by rewrite /index_enum unlock val_ord_enum. Qed. Lemma big_nat_widen : forall m n1 n2 (P : pred nat) F, n1 <= n2 -> \big[op/idx]_(m <= i < n1 | P i) F i === \big[op/idx]_(m <= i < n2 | P i && (i < n1)) F i. Proof. move=> m n1 n2 P F len12; symmetry. rewrite <- big_filter; rewrite filter_predI; rewrite -> big_filter. apply (reducebig_morph _); try reflexivity; try apply H0. rewrite /index_iota; set d1 := n1 - m; set d2 := n2 - m. rewrite -(@subnK d1 d2) /=; last by rewrite leq_sub2r ?leq_addr. have: ~~ has (fun i => i < n1) (iota (m + d1) (d2 - d1)). apply/hasPn=> i; rewrite mem_iota -leqNgt; case/andP=> le_mn1_i _. by apply: leq_trans le_mn1_i; rewrite -leq_sub_add. rewrite -(addnC d1 (d2 - d1)) iota_add filter_cat has_filter /=; case: filter => // _. rewrite cats0; apply/all_filterP; apply/allP=> i. rewrite mem_iota; case/andP=> le_m_i lt_i_md1. apply: (leq_trans lt_i_md1); rewrite subnKC // ltnW //. rewrite -subn_gt0 -(ltn_add2l m) addn0; exact: leq_trans lt_i_md1. Qed. Lemma big_ord_widen_cond : forall n1 n2 (P : pred nat) (F : nat -> A), n1 <= n2 -> \big[op/idx]_(i < n1 | P i) F i === \big[op/idx]_(i < n2 | P i && (i < n1)) F i. Proof. move=> n1 n2 P F len12. rewrite <- big_mkord, (big_nat_widen _ _ _ len12), big_mkord; reflexivity. Qed. Lemma big_ord_widen : forall n1 n2 (F : nat -> A), n1 <= n2 -> \big[op/idx]_(i < n1) F i === \big[op/idx]_(i < n2 | i < n1) F i. Proof. by move=> *; apply: (big_ord_widen_cond (predT)). Qed. Lemma big_ord_widen_leq : forall n1 n2 (P : pred 'I_(n1.+1)) F, n1 < n2 -> \big[op/idx]_(i < n1.+1 | P i) F i === \big[op/idx]_(i < n2 | P (inord i) && (i <= n1)) F (inord i). Proof. move=> n1 n2 P F len12; pose g G i := G (inord i : 'I_(n1.+1)). pose e := big_ord_widen_cond (g _ P) (g _ F) len12; unfold g in e; rewrite <- e. by apply: eq_big => i *; rewrite inord_val;try reflexivity. Qed. Lemma big_ord_narrow_cond : forall n1 n2 (P : pred 'I_n2) F, forall le_n1_n2 : n1 <= n2, let w := widen_ord le_n1_n2 in \big[op/idx]_(i < n2 | P i && (i < n1)) F i === \big[op/idx]_(i < n1 | P (w i)) F (w i). Proof. move=> [|n1] n2 P F ltn12 /=. rewrite -> !big_pred0. reflexivity. intro; inversion x; inversion H1. intro; rewrite andbF//. rewrite -> (big_ord_widen_leq (fun i => P (widen_ord (m:=n2) ltn12 i)) (fun i => F (widen_ord (m:=n2) ltn12 i)) ltn12); apply: eq_big => i. rewrite ltnS; case: leqP => [le_i_n1|_]; last by rewrite !andbF. by congr (P _ && _); apply: val_inj; rewrite /= inordK. case/andP=> _ le_i_n1. assert (i = widen_ord (m:=n2) ltn12 (inord i)). by apply: val_inj; rewrite /= inordK. rewrite <- H1; reflexivity. Qed. Lemma big_ord_narrow_cond_leq : forall n1 n2 (P : pred 'I_(n2.+1)) F, forall le_n1_n2 : n1 <= n2, let w := @widen_ord n1.+1 n2.+1 le_n1_n2 in \big[op/idx]_(i < n2.+1 | P i && (i <= n1)) F i === \big[op/idx]_(i < n1.+1 | P (w i)) F (w i). Proof. move=> n1 n2; exact: big_ord_narrow_cond n1.+1 n2.+1. Qed. Lemma big_ord_narrow : forall n1 n2 F, forall le_n1_n2 : n1 <= n2, let w := widen_ord le_n1_n2 in \big[op/idx]_(i < n2 | i < n1) F i === \big[op/idx]_(i < n1) F (w i). Proof. move=> *; exact: (big_ord_narrow_cond (predT)). Qed. Lemma big_ord_narrow_leq : forall n1 n2 F, forall le_n1_n2 : n1 <= n2, let w := @widen_ord n1.+1 n2.+1 le_n1_n2 in \big[op/idx]_(i < n2.+1 | i <= n1) F i === \big[op/idx]_(i < n1.+1) F (w i). Proof. move=> *; exact: (big_ord_narrow_cond_leq (predT)). Qed. Lemma big_ord0 : forall P F, \big[op/idx]_(i < 0 | P i) F i === idx. Proof. by move=> P F; rewrite -> big_pred0 => [|[]]; try reflexivity. Qed. Lemma big_ord_recl : forall n F, \big[op/idx]_(i < n.+1) F i === op (F ord0) (\big[op/idx]_(i < n) F (@lift n.+1 ord0 i)). Proof. move=> n F; pose G i := F (inord i). have eqFG: forall i, R (F i) (G i) by move=> i; rewrite /G inord_val;reflexivity. transitivity (\big[op/idx]_(i < n.+1) G i); first by apply eq_bigr=> *; apply eqFG. rewrite <- (big_mkord (S n) (fun _ => true) G), eqFG. rewrite -> big_ltn=> //; rewrite -> big_add1=> /=; rewrite -> big_mkord. apply H0; try reflexivity. by apply: eq_bigr => i _; rewrite -> eqFG; reflexivity. Qed. Lemma big_const : forall (I : finType) (P : pred I) x, \big[op/idx]_(i \in P) x === iter #|P| (op x) idx. Proof. by move=> I P x; rewrite -> big_const_seq, count_filter, cardE; reflexivity. Qed. Lemma big_const_nat : forall m n x, \big[op/idx]_(m <= i < n) x === iter (n - m) (op x) idx. Proof. by move=> *; rewrite -> big_const_seq; rewrite count_predT size_iota; reflexivity. Qed. Lemma big_const_ord : forall n x, \big[op/idx]_(i < n) x === iter n (op x) idx. Proof. move=> n x; have e := big_const. rewrite /in_mem /mem //= in e. by rewrite -> e, card_ord; reflexivity. Qed. End Extensionality. Section MonoidProperties. Section Plain. Context `{Equivalence } {op : binop A} {idm : A}. Context {op_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) op}. Context {op_assoc : associative op}. Context {op_left_id : left_unit op idm}. Context {op_right_id : right_unit op idm}. Local Notation "*%M" := op (at level 0). Local Notation "x * y" := (op x y). Local Notation "1" := idm. Lemma eq_big_idx_seq : forall idx' I r (P : pred I) F, right_unit *%M idx' -> has P r -> \big[*%M/idx']_(i <- r | P i) F i === \big[*%M/1]_(i <- r | P i) F i. Proof. move=> idx' I r P F op_idx'. rewrite <- !(big_filter r), has_count, count_filter. case/lastP: (filter P r) => {r p}// r i _. rewrite <- cats1, !big_cat_nested; rewrite -> big_cons; rewrite -> big_nil => /=. by rewrite -> op_right_id, op_idx'; reflexivity. Qed. Lemma eq_big_idx : forall idx' (I : finType) i0 (P : pred I) F, P i0 -> right_unit *%M idx' -> \big[*%M/idx']_(i | P i) F i === \big[*%M/1]_(i | P i) F i. Proof. move=> idx' I i0 P F op_idx' Pi0; apply: eq_big_idx_seq => //. by apply/hasP; exists i0; first rewrite /index_enum -enumT mem_enum. Qed. Lemma big1_eq : forall I r (P : pred I), \big[*%M/1]_(i <- r | P i) 1 === 1. Proof. move=> *; rewrite -> big_const_seq. elim: (count _ _); try reflexivity; move=> n //= Heq; rewrite -> Heq; apply op_right_id. Qed. Lemma big1 : forall (I : finType) (P : pred I) F, (forall i, P i -> F i === 1) -> \big[*%M/1]_(i | P i) F i === 1. Proof. by move=> I P F eq_F_1; rewrite -> (eq_bigr _ eq_F_1); rewrite -> big1_eq; reflexivity. Qed. Lemma big1_seq : forall (I : eqType) r (P : pred I) F, (forall i, P i && (i \in r) -> F i === 1) -> \big[*%M/1]_(i <- r | P i) F i === 1. Proof. move=> I r P F eqF1; rewrite -> big_cond_seq; rewrite -> (eq_bigr _ eqF1). by rewrite -> big1_eq;reflexivity. Qed. Lemma big_seq1 : forall I (i : I) F, \big[*%M/1]_(j <- [:: i]) F j === F i. Proof. by move=> /= *; rewrite -> op_right_id; reflexivity. Qed. Lemma big_mkcond : forall I r (P : pred I) F, \big[*%M/1]_(i <- r | P i) F i === \big[*%M/1]_(i <- r) (if P i then F i else 1). Proof. move=> I r P F. elim: r => //=; try reflexivity; move=> i r HR. case P. by rewrite -> HR;reflexivity. by rewrite -> op_left_id; exact HR. Qed. Lemma big_cat : forall I r1 r2 (P : pred I) F, \big[*%M/1]_(i <- r1 ++ r2 | P i) F i === \big[*%M/1]_(i <- r1 | P i) F i * \big[*%M/1]_(i <- r2 | P i) F i. Proof. move=> I r1 r2 P F; rewrite -> !(big_mkcond _ P). elim: r1 => [|i r1 IHr1]. by rewrite -> big_nil; rewrite -> op_left_id; reflexivity. by move=> /=; rewrite -> IHr1; apply assoc. Qed. Lemma big_pred1_eq : forall (I : finType) (i : I) F, \big[*%M/1]_(j | j == i) F j === F i. Proof. by move=> I i F; rewrite <- big_filter; rewrite -> filter_index_enum; rewrite enum1; rewrite -> big_seq1;reflexivity. Qed. Lemma big_pred1 : forall (I : finType) i (P : pred I) F, P =1 pred1 i -> \big[*%M/1]_(j | P j) F j === F i. Proof. by move=> I i P F eqP; rewrite -> (eq_bigl _ _ eqP); exact: big_pred1_eq. Qed. Lemma big_cat_nat : forall n m p (P : pred nat) F, m <= n -> n <= p -> \big[*%M/1]_(m <= i < p | P i) F i === (\big[*%M/1]_(m <= i < n | P i) F i) * (\big[*%M/1]_(n <= i < p | P i) F i). Proof. move=> n m p F P le_mn le_np; rewrite <- big_cat. rewrite -{2}(subnKC le_mn) -iota_add -subn_sub subnKC; [reflexivity|apply leq_sub2]=> //. Qed. Lemma big_nat1 : forall n F, \big[*%M/1]_(n <= i < n.+1) F i === F n. Proof. move=> n F; rewrite -> big_ltn; last by auto. rewrite -> big_geq=> //; rewrite -> op_right_id; reflexivity. Qed. Lemma big_nat_recr : forall n F, \big[*%M/1]_(0 <= i < n.+1) F i === (\big[*%M/1]_(0 <= i < n) F i) * F n. Proof. move=> n F; rewrite -> (@big_cat_nat n), ?leqnSn, big_nat1=> //; reflexivity. Qed. (* Lemma big_ord_recr : forall n F, \big[*%M/1]_(i < n.+1) F i === (\big[*%M/1]_(i < n) F (widen_ord (leqnSn n) i)) * F ord_max. Proof. move=> n F; transitivity (\big[*%M/1]_(0 <= i < n.+1) F (inord i)). by rewrite -> big_mkord; apply eq_bigr=> i; rewrite inord_val;reflexivity. rewrite -> big_nat_recr, big_mkord; apply op_morph; last first. by (have: (inord n = @ord_max (S_pos_nat n)) by apply: val_inj; rewrite /= inordK); move <-; reflexivity. by apply eq_bigr => [] i _; (have: (inord i = widen_ord (m:=n.+1) (leqnSn n) i) by apply: ord_inj; rewrite inordK //= leqW); move <-; reflexivity. Qed. *) Lemma big_sumType : forall (I1 I2 : finType) (P : pred (I1 + I2)) F, \big[*%M/1]_(i | P i) F i === (\big[*%M/1]_(i | P (inl _ i)) F (inl _ i)) * (\big[*%M/1]_(i | P (inr _ i)) F (inr _ i)). Proof. move=> I1 I2 P F. rewrite /index_enum [@Finite.enum _]unlock /= /sum_enum; rewrite -> big_cat. rewrite -> (big_map _ (Finite.enum I1)). rewrite -> (big_map _ (Finite.enum I2)). by reflexivity. Qed. Lemma big_split_ord : forall m n (P : pred 'I_(m + n)) F, \big[*%M/1]_(i | P i) F i === (\big[*%M/1]_(i | P (lshift n i)) F (lshift n i)) * (\big[*%M/1]_(i | P (rshift m i)) F (rshift m i)). Proof. move=> m n P F. rewrite <- (big_map (lshift n) _ P F), <- (big_map (@rshift m _) _ P F), <- big_cat. apply congr_big;move=> *;try reflexivity. by apply: (inj_map (@val_inj _ _ _)); rewrite /index_enum -!enumT val_enum_ord map_cat -map_comp val_enum_ord -map_comp (map_comp (addn m)) val_enum_ord -iota_addl addn0 iota_add. Qed. End Plain. Lemma cardD1x : forall (I : finType) (A : pred I) j, A j -> #|SimplPred A| = 1 + #|[pred i | A i && (i != j)]|. Proof. move=> I A j Aj; rewrite (cardD1 j) [j \in A]Aj; congr (_ + _). by apply: eq_card => i; rewrite inE /= andbC. Qed. Section Abelian. Context `{Equivalence} {op : binop A} {idm : A}. Context {op_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) op}. Context {op_assoc : associative op}. Context {op_left_id : left_unit op idm}. Context {op_right_id : right_unit op idm}. Context {op_comm : commutative op}. Local Notation "'*%M'" := op (at level 0). Local Notation "x * y" := (op x y). Local Notation "1" := idm. (* sinon ca marche pas... *) Existing Instance mulAC_comm_l. Lemma eq_big_perm : forall (I : eqType) r1 r2 (P : pred I) F, perm_eq r1 r2 -> \big[*%M/1]_(i <- r1 | P i) F i === \big[*%M/1]_(i <- r2 | P i) F i. Proof. move=> I r1 r2 P F; move/perm_eqP; rewrite -> !(big_mkcond _ P). elim: r1 r2 => [|i r1 IHr1] r2 eq_r12. by case: r2 eq_r12 => //;try reflexivity; move=> i r2; move/(_ (pred1 i)); rewrite /= eqxx. have r2i: i \in r2 by rewrite -has_pred1 has_count -eq_r12 /= eqxx. case/splitPr: r2 / r2i => [r3 r4] in eq_r12 *. rewrite -> big_cat, -> !big_cons. rewrite -> left_commut; apply op_morph; [reflexivity|]; rewrite <- big_cat; apply: IHr1 => a. move/(_ a): eq_r12; rewrite !count_cat /= addnCA; exact: addnI. Qed. Lemma big_uniq : forall (I : finType) (r : seq I) F, uniq r -> \big[*%M/1]_(i <- r) F i === \big[*%M/1]_(i | i \in r) F i. Proof. move=> I r F uniq_r; rewrite <- (big_filter (index_enum I)); apply: eq_big_perm. by rewrite filter_index_enum uniq_perm_eq ?enum_uniq // => i; rewrite mem_enum. Qed. Lemma big_split : forall I r (P : pred I) F1 F2, \big[*%M/1]_(i <- r | P i) (F1 i * F2 i) === \big[*%M/1]_(i <- r | P i) F1 i * \big[*%M/1]_(i <- r | P i) F2 i. Proof. move=> I r P F1 F2. elim: r => //=; first by symmetry; apply op_left_id. move=> i r; case: (P i)=> Heq; rewrite -> Heq; try reflexivity. rewrite -> !op_assoc; apply op_morph; try reflexivity; rewrite -> right_commut at 1; reflexivity. Qed. Lemma bigID : forall I r (a P : pred I) F, \big[*%M/1]_(i <- r | P i) F i === \big[*%M/1]_(i <- r | P i && a i) F i * \big[*%M/1]_(i <- r | P i && ~~ a i) F i. Proof. move=> I r a P F. rewrite -> big_mkcond. rewrite -> (big_mkcond _ (fun i => P i && a i)). rewrite -> (big_mkcond _ (fun i => P i && ~~ a i)). rewrite <- big_split; apply eq_bigr => i _. by case: (P i) => //=; case: (a i) => //=; symmetry; try apply op_left_id; apply op_right_id. Qed. Lemma bigU : forall (I : finType) (P Q : pred I) F, [disjoint P & Q] -> \big[*%M/1]_(i \in [predU P & Q]) F i === (\big[*%M/1]_(i \in P) F i) * (\big[*%M/1]_(i \in Q) F i). Proof. move=> I P Q F dAB; rewrite -> (bigID _ (mem P)); apply op_morph. by apply eq_bigl; rewrite /mem // /in_mem; move=> i //=; rewrite orbK. by apply eq_bigl; move=> i //=; have:= pred0P dAB i; rewrite andbC /= !inE; case: (i \in P). Qed. Lemma bigD1 : forall (I : finType) j (P : pred I) F, P j -> \big[*%M/1]_(i | P i) F i === F j * \big[*%M/1]_(i | P i && (i != j)) F i. Proof. move=> I j P F Pj; rewrite -> (bigID _ (pred1 j)). apply op_morph; try reflexivity. apply (big_pred1 (P:=fun i => P i && pred1 j i)). by move=> i; rewrite /= andbC; case: eqP => // ->. Qed. Lemma partition_big : forall (I J : finType) (P : pred I) p (Q : pred J) F, (forall i, P i -> Q (p i)) -> \big[*%M/1]_(i | P i) F i === \big[*%M/1]_(j | Q j) \big[*%M/1]_(i | P i && (p i == j)) F i. Proof. move=> I J P p Q F Qp; transitivity (\big[*%M/1]_(i | P i && Q (p i)) F i). by apply eq_bigl=> i; case Pi: (P i)=> [|//=]; rewrite Qp. elim: {Q Qp}_.+1 {-2}Q (ltnSn #|Q|) => // n IHn Q. case: (pickP Q) => [j Qj | Q0 _]; last first. by rewrite -> !big_pred0=> //; try reflexivity; move=> i//=; rewrite Q0 andbF. rewrite ltnS (cardD1x Qj); rewrite -> (bigD1 (j:=j))=> //; move/IHn=> {n IHn} Heq; rewrite <- Heq. rewrite -> (bigID _ (fun i => p i == j)); apply op_morph. by apply eq_bigl=> i//=; case: eqP => [-> | _]; rewrite ?Qj //= andbC //= andbC //=. by apply eq_bigl=> i//=; rewrite andbA. Qed. Lemma reindex_onto : forall (I J : finType) (h : J -> I) h' (P : pred I) F, (forall i, P i -> h (h' i) = i) -> \big[*%M/1]_(i | P i) F i === \big[*%M/1]_(j | P (h j) && (h' (h j) == j)) F (h j). Proof. move=> I J h h' P F h'K. elim: {P}_.+1 {-3}P h'K (ltnSn #|P|) => //= n IHn P h'K. case: (pickP P) => [i Pi | P0 _]; last first. rewrite -> big_pred0=> //; rewrite -> big_pred0=> //; [reflexivity|]. by move=> j //=; rewrite P0. rewrite ltnS (cardD1x Pi); move/IHn {n IHn} => IH. rewrite -> (bigD1 (j:=i) _ Pi), (bigD1 (j:=h' i)); rewrite h'K ?Pi ?eq_refl //=; apply op_morph; try reflexivity. rewrite -> IH. apply eq_bigl=> j//=; rewrite andbC -andbA (andbCA (P _)). by case: eqP => //= hK; congr (_ && ~~ _); apply/eqP/eqP=> [<-|->] //; rewrite h'K. by move=> j//=; case/andP; auto. Qed. Lemma reindex : forall (I J : finType) (h : J -> I) (P : pred I) F, {on [pred i | P i], bijective h} -> \big[*%M/1]_(i | P i) F i === \big[*%M/1]_(j | P (h j)) F (h j). Proof. move=> I J h P F [h' hK h'K]; rewrite -> (reindex_onto _ h'K); apply eq_bigl=> j//=. by rewrite !inE; case Pi: (P _); rewrite //= hK ?eqxx. Qed. Lemma pair_big_dep : forall (I J : finType) (P : pred I) (Q : I -> pred J) F, \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q i j) F i j === \big[*%M/1]_(p | P p.1 && Q p.1 p.2) F p.1 p.2. Proof. move=> I J P Q F. rewrite -> (partition_big (P:=fun p => P p.1 && Q p.1 p.2) (p:=fun p => p.1) (Q:=P))=> [|j]; last by case/andP. apply eq_bigr=>i Pi. rewrite -> (reindex_onto (h:=pair i) (h':=fun p => p.2)). by apply eq_bigl=> j; rewrite !eqxx [P i]Pi !andbT. by case=> i' j /=; case/andP=> _ /=; move/eqP->. Qed. Lemma pair_big : forall (I J : finType) (P : pred I) (Q : pred J) F, \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q j) F i j === \big[*%M/1]_(p | P p.1 && Q p.2) F p.1 p.2. Proof. move=> *; exact: pair_big_dep. Qed. (* Lemma pair_bigA : forall (I J : finType) (F : I -> J -> R), \big[*%M/1]_i \big[*%M/1]_j F i j === \big[*%M/1]_p F p.1 p.2. Proof. move=> *; exact: pair_big_dep. Qed. *) Lemma exchange_big_dep : forall (I J : finType) (P : pred I) (Q : I -> pred J) (xQ : pred J) F, (forall i j, P i -> Q i j -> xQ j) -> \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q i j) F i j === \big[*%M/1]_(j | xQ j) \big[*%M/1]_(i | P i && Q i j) F i j. Proof. move=> I J P Q xQ F PQxQ; pose p u := (u.2, u.1). rewrite -> !pair_big_dep, (reindex_onto (h:=p J I) (h':=p I J)) => [|[//]]. apply eq_big=> [] [j i] //=;try reflexivity; symmetry. by rewrite eq_refl andbC; case: (@andP (P i)) => //= [[]]; exact: PQxQ. Qed. Lemma exchange_big : forall (I J : finType) (P : pred I) (Q : pred J) F, \big[*%M/1]_(i | P i) \big[*%M/1]_(j | Q j) F i j === \big[*%M/1]_(j | Q j) \big[*%M/1]_(i | P i) F i j. Proof. move=> I J P Q F; rewrite -> (exchange_big_dep (Q:=fun i j => Q j) (xQ:=Q))=> //. by apply eq_bigr=> i /= Qi; apply eq_bigl=> j; rewrite [Q i]Qi andbT. Qed. Lemma exchange_big_dep_nat : forall m1 n1 m2 n2 (P : pred nat) (Q : rel nat) (xQ : pred nat) F, (forall i j, m1 <= i < n1 -> m2 <= j < n2 -> P i -> Q i j -> xQ j) -> \big[*%M/1]_(m1 <= i < n1 | P i) \big[*%M/1]_(m2 <= j < n2 | Q i j) F i j === \big[*%M/1]_(m2 <= j < n2 | xQ j) \big[*%M/1]_(m1 <= i < n1 | P i && Q i j) F i j. Proof. move=> m1 n1 m2 n2 P Q xQ F PQxQ. transitivity (\big[*%M/1]_(i < n1 - m1| P (i + m1)) \big[*%M/1]_(j < n2 - m2 | Q (i + m1) (j + m2)) F (i + m1) (j + m2)). - rewrite -{1}[m1]add0n; rewrite -> big_addn; rewrite -> big_mkord; apply eq_bigr=> i _. by rewrite -{1}[m2]add0n; rewrite -> big_addn; rewrite -> big_mkord; reflexivity. rewrite -> (exchange_big_dep (I:=ordinal_finType (n1 - m1)) (J:=ordinal_finType (n2 - m2)) (P:=fun i => P (i + m1)) (Q:=fun i j => Q (i + m1) (j + m2)) (xQ:=fun j: 'I__ => xQ (j + m2)))=> [|i j]; last first. by apply: PQxQ; rewrite leq_addl addnC -subn_gt0 -subn_sub subn_gt0 ltn_ord. symmetry; rewrite -{1}[m2]add0n; rewrite -> big_addn; rewrite -> big_mkord; apply eq_bigr=> j _. by rewrite -{1}[m1]add0n; rewrite -> big_addn; rewrite -> big_mkord; reflexivity. Qed. Lemma exchange_big_nat : forall m1 n1 m2 n2 (P Q : pred nat) F, \big[*%M/1]_(m1 <= i < n1 | P i) \big[*%M/1]_(m2 <= j < n2 | Q j) F i j === \big[*%M/1]_(m2 <= j < n2 | Q j) \big[*%M/1]_(m1 <= i < n1 | P i) F i j. Proof. move=> m1 n1 m2 n2 P Q F. rewrite -> (exchange_big_dep_nat (P:=P) (Q:=fun i j => Q j) (xQ:=Q))=> //. by apply eq_bigr=> i /= Qi; apply eq_bigl=> j; rewrite [Q i]Qi andbT. Qed. End Abelian. End MonoidProperties. Section BigProp. Context `{Equivalence} {Pb : A -> Prop}. Context {idx : A} {op1 : binop A}. Context {Pb_morph : Proper (Equivalence.equiv==>Equivalence.equiv) Pb}. Context {op1_morph : Proper (R==>R==>R) op1}. Hypothesis (Pb_idx : Pb idx) (Pb_op1 : forall x y, Pb x -> Pb y -> Pb (op1 x y)). Lemma big_prop : forall I r (P : pred I) F, (forall i, P i -> Pb (F i)) -> Pb (\big[op1/idx]_(i <- r | P i) F i). Proof. by move=> I r P F PbF; elim: r => //= i *; case Pi: (P i); auto. Qed. Variable (op2 : binop A). Context {op2_morph : Proper (R==>R==>R) op2}. Hypothesis (Pb_eq_op : forall x y, Pb x -> Pb y -> op1 x y === op2 x y). Lemma big_prop_seq : forall (I : eqType) (r : seq I) (P : pred I) F, (forall i, P i && (i \in r) -> Pb (F i)) -> Pb (\big[op1/idx]_(i <- r | P i) F i). Proof. by move=> I r P F; rewrite -> big_cond_seq; exact: big_prop. Qed. Lemma eq_big_op : forall I r (P : pred I) F, (forall i, P i -> Pb (F i)) -> \big[op1/idx]_(i <- r | P i) F i === \big[op2/idx]_(i <- r | P i) F i. Proof. have:= big_prop=> Pb_big I r P F Pb_F. elim: r; try reflexivity; move=> i r //=; case Pi: (P i); move=> Heq; rewrite <- Heq; auto; reflexivity. Qed. Lemma eq_big_op_seq : forall (I : eqType) r (P : pred I) F, (forall i, P i && (i \in r) -> Pb (F i)) -> \big[op1/idx]_(i <- r | P i) F i === \big[op2/idx]_(i <- r | P i) F i. Proof. move=> I r P F Pb_F; rewrite -> big_cond_seq. by symmetry; rewrite -> big_cond_seq; symmetry; apply eq_big_op. Qed. End BigProp. Section BigRel. Context (A1:Type). Context (R1:relation A1). Context `{@Equivalence A1 R1}. Variables (idx1 : A1) (op1 : binop A1). Context (A2:Type). Context (R2:relation A2). Context `{@Equivalence A2 R2}. Variables (idx2 : A2) (op2 : binop A2). Variable Pr : A1 -> A2 -> Prop. Context {Pr_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) Pr}. Context {op1_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) op1}. Context {op2_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) op2}. Hypothesis Pr_idx : Pr idx1 idx2. Hypothesis Pr_rel : forall x1 x2 y1 y2, Pr x1 x2 -> Pr y1 y2 -> Pr (op1 x1 y1) (op2 x2 y2). Lemma big_rel : forall I r (P : pred I) F1 F2, (forall i, (P i) -> Pr (F1 i) (F2 i)) -> Pr (\big[op1/idx1]_(i <- r | P i) F1 i) (\big[op2/idx2]_(i <- r | P i) F2 i). Proof. move=> I r P F1 F2 PrF. elim: r => //= i *; case Pi: (P i); auto. Qed. Lemma big_rel_seq : forall (I : eqType) (r : seq I) (P : pred I) F1 F2, (forall i, P i && (i \in r) -> Pr (F1 i) (F2 i)) -> Pr (\big[op1/idx1]_(i <- r | P i) F1 i) (\big[op2/idx2]_(i <- r | P i) F2 i). Proof. move=> I r P F1 F2 *; rewrite -> big_cond_seq. by rewrite -> (big_cond_seq (idx:=idx2)); apply big_rel. Qed. End BigRel. (* Section Morphism. Context `{Equivalence}. Variables (idx1 : A) (op1 : binop A). Context {R2 : Type}. Variables (idx2 : R2) (op2 : binop R2). Variable phi : A -> R2. Hypothesis phiM : forall x y, R (phi (op1 x y)) (op2 (phi x) (phi y)). Hypothesis phi_id : req2 (phi idx1) idx2. Context {op2_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) op2}. Lemma big_morph : forall I r (P : pred I) F, phi (\big[op1/idx1]_(i <- r | P i) F i) === \big[op2/idx2]_(i <- r | P i) phi (F i). Proof. move=> I r P F; elim: r => [ //= | i r //= ]. case: (P i) => Heq; rewrite <- Heq; [apply phiM|reflexivity]. Qed. End Morphism. *) (* Section Distributivity. Context `{Equivalence} {add mul : binop A} {zero : A}. Local Notation "*%M" := mul (at level 0). Local Notation "x * y" := (mul x y). Local Notation "0" := zero. Local Notation "+%M" := add (at level 0). Local Notation "x + y" := (add x y). Context {op_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) add}. Context {mul_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) mul}. Context {op_assoc : associative +%M}. Context {op_comm : commutative +%M}. Context {op_left_unit : left_unit +%M 0}. Context {op_left_zero : left_absorbing *%M 0}. Context {op_right_zero : right_absorbing *%M 0}. Context {op_left_distr : left_distributive +%M *%M}. Context {op_right_distr : right_distributive +%M *%M}. Lemma big_distrl : forall I r a (P : pred I) F, \big[+%M/0]_(i <- r | P i) F i * a === \big[+%M/0]_(i <- r | P i) (F i * a). Proof. move=> I r a P F; apply (big_morph (phi:=fun x => x * a)) => [ x y | | //= ]. by apply left_dist. by apply op_left_zero. Qed. Lemma big_distrr : forall I r a (P : pred I) F, a * \big[+%M/0]_(i <- r | P i) F i === \big[+%M/0]_(i <- r | P i) (a * F i). Proof. move=> I r a P F. apply (big_morph (phi:=fun x => a *x)) => [ x y || //= ]. by apply op_right_distr. by apply op_right_zero. Qed. Context {one : R}. Local Notation "1" := one. (* sinon ça marche pas...*) Existing Instance mulC_id_l. Lemma big_distr_big_dep : forall (I J : finType) j0 (P : pred I) (Q : I -> pred J) F, \big[*%M/1]_(i | P i) \big[+%M/0]_(j | Q i j) F i j === \big[+%M/0]_(f | pfamily j0 P Q f) \big[*%M/1]_(i | P i) F i (f i). Proof. move=> I J j0 P Q F; rewrite <- big_filter; rewrite filter_index_enum; set r := enum P. pose fIJ := {ffun I -> J}; pose Pf := pfamily j0 _ Q; symmetry. transitivity (\big[+%M/0]_(f | Pf (mem r) f) \big[*%M/1]_(i <- r) F i (f i)). apply: eq_big=> f; auto; last by rewrite <- big_filter; rewrite filter_index_enum; reflexivity. by apply: eq_forallb => i; rewrite /= mem_enum. have: uniq r by exact: enum_uniq. elim: {P}r => [_|i r IHr]. rewrite -> (big_pred1 (i:=[ffun => j0])); first by rewrite -> big_nil; reflexivity. move=> f //=; apply /familyP /eqP=> /= [Df |->{f} i]; last by rewrite ffunE. by apply/ffunP=> i; rewrite ffunE; exact/eqP. case/andP=> nri; rewrite -> big_cons; move/IHr {IHr} => IHr; rewrite <- IHr; rewrite -> big_distrl. rewrite -> (partition_big (P:=Pf (mem (i :: r))) (p:=fun f : fIJ => f i) (Q:=Q i)); last first. by move=> f; move/familyP; move/(_ i); rewrite /= inE /= eqxx. pose seti j (f : fIJ) := [ffun k => if k == i then j else f k]. apply eq_bigr => j Qij; rewrite -> (reindex_onto (h:=seti j) (h':=seti j0) (P:=fun i0 => andb (Pf (mem (Cons I i r)) i0) (eq_op (i0 i) j))); last first. move=> f /=; case/andP; move/familyP=> eq_f; move/eqP=> fi. by apply/ffunP => k; rewrite !ffunE; case: eqP => // ->. rewrite -> big_distrr; apply eq_big => [f | f eq_f]; last first. rewrite -> big_cons; rewrite ffunE eq_refl; apply mul_morph; [reflexivity|]; rewrite -> !(big_cond_seq r predT). by apply eq_bigr => k; rewrite ffunE; case: eqP; try reflexivity; move => ->; case/idPn. rewrite !ffunE !eq_refl andbT; apply/andP/familyP=> [[Pjf fij0] k | Pff]. have:= familyP _ _ Pjf k; rewrite /= ffunE in_cons; case: eqP => // -> _. by rewrite (negbTE nri) -(eqP fij0) !ffunE ?inE /= !eqxx. split. apply/familyP=> k; move/(_ k): Pff; rewrite /= ffunE in_cons. by case: eqP => // ->. apply/eqP; apply/ffunP=> k; have:= Pff k; rewrite !ffunE /=. by case: eqP => // ->; rewrite (negbTE nri) /=; move/eqP. Qed. Lemma big_distr_big : forall (I J : finType) j0 (P : pred I) (Q : pred J) F, \big[*%M/1]_(i | P i) \big[+%M/0]_(j | Q j) F i j === \big[+%M/0]_(f | pffun_on j0 P Q f) \big[*%M/1]_(i | P i) F i (f i). Proof. move=> I J j0 P Q F; rewrite -> (big_distr_big_dep j0); apply eq_bigl => f. by apply/familyP/familyP=> Pf i; move/(_ i): Pf; case: (P i). Qed. Lemma bigA_distr_big_dep : forall (I J : finType) (Q : I -> pred J) F, \big[*%M/1]_i \big[+%M/0]_(j | Q i j) F i j === \big[+%M/0]_(f | family Q f) \big[*%M/1]_i F i (f i). Proof. move=> I J Q F; case: (pickP J) => [j0 _ | J0]. exact: (big_distr_big_dep j0). rewrite /index_enum -enumT; case: (enum I) (mem_enum I) => [I0 | i r _]. have f0: I -> J by move=> i; have:= I0 i. rewrite -> (big_pred1 (i:=finfun f0)); first by rewrite -> big_nil; reflexivity. rewrite /mem // => x. by apply/familyP/eqP=> _; first apply/ffunP; move=> i; have:= I0 i. have Q0: Q _ =1 pred0 by move=> ? j; have:= J0 j. rewrite -> big_cons=> /=; rewrite -> big_pred0=> //; rewrite -> op_left_zero; rewrite -> big_pred0; first by reflexivity. by move=> f; apply/familyP; move/(_ i); rewrite Q0. Qed. Lemma bigA_distr_big : forall (I J : finType) (Q : pred J) (F : I -> J -> R), \big[*%M/1]_i \big[+%M/0]_(j | Q j) F i j === \big[+%M/0]_(f | ffun_on Q f) \big[*%M/1]_i F i (f i). Proof. move=> *; exact: bigA_distr_big_dep. Qed. Lemma bigA_distr_bigA : forall (I J : finType) F, \big[*%M/1]_(i : I) \big[+%M/0]_(j : J) F i j === \big[+%M/0]_(f : {ffun I -> J}) \big[*%M/1]_i F i (f i). Proof. move=> *; rewrite -> bigA_distr_big; apply eq_bigl => ?; exact/familyP. Qed. End Distributivity. *)corn-8.20.0/broken/diff.v000066400000000000000000000151711473720167500151420ustar00rootroot00000000000000(* Require Import CPoly_Newton. Require Import CRArith. Require Import Unicode.Utf8 Setoid Arith List Program Permutation metric2.Classified CSetoids CPoly_ApZero CRings CPoly_Degree CRArith Qmetric Qring CReals stdlib_omissions.Pair stdlib_omissions.Q list_separates SetoidPermutation. Require ne_list. Import ne_list.notations. (* Require Import ProductMetric CompleteProduct.*) (** Outline of the definition of the derivative using div diff. Should lead to FTC. Should also be the basis for Newton iteration. Becomes very sketchy at the end. *) Notation "'one' a":=(ne_list.one a) (at level 60). Implicit Arguments ne_zip [A B]. Section divdiff. Definition divdiff2 (f: Q-> CR) :=fun x:Q*Q => let (p , q) := x in let l:= (p ::: (one q)) in (divdiff (ne_zip l (ne_list.map f l) )). End divdiff. (* Section extra. Context {X Y : MetricSpace} (f: X → Complete Y) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. Definition Cbind_slowC: UCFunction (Complete X) (Complete Y):= ucFunction (Cbind_slow (wrap_uc_fun' f)). End extra. Notation " x >>= f ":= (Cbind_slowC f x) (at level 50). *) Section derivative. (* Notation Q:=Q_as_MetricSpace.*) (** Definition of the derivative. The usual rules should follow from the ones for dd*) Context (f:Q->CR) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. Context `{!UniformlyContinuous_mu (divdiff2 f)} `{!UniformlyContinuous (divdiff2 f)}. Definition der : UCFunction Q CR := ucFunction (compose (divdiff2 f) diagonal). End derivative. Section towardsLBC. (** We work towards the Law of Bounded change *) (* This is seq 1 (S n) *) Fixpoint posnats (n: nat): ne_list nat:= match n with | O => one (S O) | S n' => (S (S n')) ::: (posnats n') end. Eval compute in (posnats 2). Notation QPoint := (Q * CR)%type. Notation CRPoint := (CR * CR)%type. Local Notation Σ := cm_Sum. (* Unfortunately, this is not allowed: Fixpoint interleave {A:Type} (l1 l2 : list A) {struct l1}: list A := match l1 with | nil => l2 | a :: l1 => a :: (interleave l2 l1) end. *) Fixpoint interleave {A:Type} (l1 l2 : ne_list A) {struct l1}: ne_list A := match l1 with | one a => a ::: l2 | a ::: l1 => a ::: match l2 with | one b => b :::l1 | b ::: l2 => b ::: (interleave l1 l2) end end. (* Fixpoint ne_removelast {A:Set} (l:ne_list A) : ne_list A := match l with | one a => one a | a ::: l => a ::: ne_removelast l end. *) Eval compute in (interleave ( 1 ::: (one 2#1)) (ne_list.map Qopp (ne_list.app (one 3#1) (one 0)))). Definition diff_list (x y: Q) (m:nat) (f:Q->CR):= let h:=(x-y)/(S m) in let l:= (ne_list.map (λ x: Q * Q, fst x + snd x) (ne_zip (ne_list.map (λ n:nat, h * n) (posnats m)) (ne_list.replicate_Sn x m))) in Σ (ne_list.map (divdiff2 f) (ne_zip (x ::: l) (ne_list.app l (one 0)))). (* (map (λ x0 : Q and Q, let (p, q) := x0 in (f p - f q )* ' (/p -q))%CR)*) Check (diff_list 1 1 2 inject_Q_CR). Section telescope. (* This really holds for a group, but we do not want to use the group tactic plugin. *) (* Should be type classified *) Context {R:CRing}. Add Ring R: (CRing_Ring R)(preprocess [unfold cg_minus;simpl]). Lemma telescope_sum : forall l:ne_list R, forall x y:R, Σ (interleave (x ::: l) (ne_list.map cg_inv (ne_list.app l (one y)))) [=] x [-] y. Proof with ring. induction l. unfold ne_list.last;simpl. intros... intros; simpl. change (x [+] ([--] t [+] Σ (interleave (t ::: l) (ne_list.map cg_inv (ne_list.app l (one y))))) [=] x[-]y). rewrite IHl... Qed. End telescope. Require Import Morphisms. (* We would like to use a Map2 for vectors. However, this only works for lists of a fixed length. Define a general theory of applicative functors from a (strong) monad using type classes. https://secure.wikimedia.org/wikibooks/en/wiki/Haskell/Applicative_Functors Map2 should be for vectors We need the rules: f ^@> l <@> C a = fun x => (f x a) ^@> l f ^@> C a <@> l = (f a) ^@> l Or even f ^@> C a = C f a *) Definition dd_pointfree(f:Q->Q):=(compose (uncurry Qdiv) (compose (map_pair (compose (uncurry Qminus) (map_pair f f)) (uncurry Qminus)) (@diagonal (Q*Q)))). (* This example seems to be too difficult for pointfree: Require Export PointFree. Definition test0: PointFree (@fst (unit*unit) unit) _ := _. Check test0. Definition test1: PointFree (λ x y: Q, (Qdiv x y)) _ := _. Check test1. Opaque Qdiv. Definition test2: PointFree (uncurry (λ x y: Q, (Qdiv x y))) _ := _. Check test2. Definition test1: PointFree (λ x y: Q, (x-y)) _ := (uncurry Qminus (map_pair fst snd)). *) (* Sanity check: The derivative of 2x is 2*) Eval compute in (dd_pointfree (fun x =>(2#1)*x) (1#1,0#1)). Context (f:Q->CR). Lemma dd_sum:forall x y:Q, forall m:nat, (('(S m))* (divdiff2 f (x, y)))%CR [=] diff_list x y m f. intros. pose h:=(x-y)/(S m). transitivity ( ((f x) - (f y))*('(/h))%CR)%CR. change divdiff2 with dd_pointfree. unfold divdiff2. change ((' S m * ((f x - f y) * ' (/ (x - y))))%CR[=] ((f x - f y) * ' (/ h))%CR). unfold h. unfold Qdiv. set ((f x) - (f y))%CR. rewrite Qinv_mult_distr Qinv_involutive -CRmult_Qmult. set (/(x - y)). ring. unfold diff_list. fold h. unfold divdiff2. set l:= (ne_list.map (λ x: Q * Q, fst x + snd x) (ne_zip (ne_list.map (λ n:nat, h * n) (posnats m)) (ne_list.replicate_Sn x m))). set fl:= (ne_list.map f l). transitivity (Σ (interleave (f x ::: fl) (ne_list.map cg_inv (ne_list.app fl (one f y))))*'(/h))%CR. rewrite (telescope_sum fl); reflexivity. (* setoid_rewrite divdiff_e. *)(* we need map to be a morphism *) transitivity (Σ (ne_list.map (λ x0 : Q and Q, let (p, q) := x0 in ((f p [-] f q)%CR *'(/ (p -q))))%CR (ne_zip (x ::: l) (ne_list.app l (one 0))))). 2:admit. (* transitivity Σ (ne_list.map (fun x => (fst x *snd x)) etc. (λ x0 : Q and Q, let (p, q) := x0 in ((f p[-]f q) * ' (/ (p - q)))%CR) (ne_zip (x ::: l) (ne_list.app l (one 0)))) set (ne_list.map (λ x0 : Q and Q, fst x0 + snd x0) (ne_zip (ne_list.map (λ n : nat, h * n) (posnats m)) (ne_list.replicate_Sn x m))). *) admit. Qed. Context (f:Q->CR) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. Context `{!UniformlyContinuous_mu (divdiff2 f)} `{!UniformlyContinuous (divdiff2 f)}. (* Use compare to avoid dependency on proofs of being in the interval *) Lemma der_pos_dd_pos: (forall x:Q, (('0 <= (der f) x)%CR)) -> forall x y, ('0<= (divdiff2 f (x, y)))%CR. intros. rewrite CRle_not_lt. intro. contradict H. (* definition of der is not correct *) unfold der . simpl. unfold diagonal. simpl. unfold compose. simpl. setoid_rewrite divdiff_e. simpl. SearchAbout [CRlt]. admit. Qed. End bla. *)corn-8.20.0/broken/lagrange.v000066400000000000000000003571041473720167500160170ustar00rootroot00000000000000Require Import ssreflect CSetoids CSetoidFun CFields CPolynomials Program Omega Equivalence Morphisms Wf Morphisms CRings CRing_Homomorphisms Rational Setoid CPoly_NthCoeff CPoly_Degree CReals Intervals CauchySeq IntervalFunct MoreIntervals MoreFunctions Composition. Require Import seq. Open Scope program_scope. (** * The sq(uash) and unsq(uash) tricks are just * hacks because we are dealing with a flaw in * the Program Fixpoint construct. Bas and other * people are working on this. It is assumed that * this construct will not be required in the * final version of this proof. *) Inductive sq (A : Type) : Prop := insq : A -> (sq A). Axiom unsq : forall A : Type, (sq A) -> A. (** * A 'fresh' sequence is a sequence where no two * elements are the same. Therefore, we know that * for elements a, b in such a sequence it holds * that a - b =/= 0. The following section deals * with fresh sequences. *) Section FreshSeq. Variable A : CSetoid. (** * Freshness of a sequence relative to one * element. *) Lemma fresh (s : seq A) : A -> Type. intro s. induction s as [a|b s fresh_s]. exact (fun _ => True). exact (fun a => (b [#] a) and (fresh_s a)). Defined. (** * 'Squashed' version of the freshness property. * For more information, read the Type vs. Prop * discussion above. *) Definition sqfresh (s : seq A) (a : A) := (sq (fresh s a)). (** * A fresh sequence is a sequence where every * two elements lie apart. It is similar to the * normal sequence type. *) Inductive fresh_seq : seq A -> Prop := | fresh_nil : fresh_seq nil | fresh_cons : forall x s, sqfresh s x -> fresh_seq s -> fresh_seq (x :: s). (** * If we an element a is fresh (relative to a * sequence s), then a is also fresh relative * to any subsequence of s. *) Lemma take_fresh : forall (n : nat) (s : seq A) (a : A), fresh s a -> fresh (take n s) a. Proof. intro n; induction n. intros s a H; rewrite take0; simpl; auto. intros s a H; destruct s; simpl; auto. simpl; split. by inversion H. apply IHn; by inversion H. Defined. (** * Any subsequence we take from the beginning of a fresh * sequence is still fresh. *) Lemma take_fresh_seq : forall (n : nat) (s : seq A), fresh_seq s -> fresh_seq (take n s). Proof. intro n; induction n. intros s H; simpl; rewrite take0; exact fresh_nil. intros s H; destruct s; simpl; auto. simpl; apply fresh_cons. unfold sqfresh; apply insq; apply take_fresh. apply unsq; by inversion H. apply IHn; by inversion H. Defined. (** * If an element is fresh with respect to a certain * sequence, it results in a fresh sequence if we add * this element to the rear of this sequence. *) Lemma rcons_fresh : forall (s : seq A) (a t : A), fresh (t :: s) a -> fresh (rcons s t) a. Proof. intros s a t H; induction s. simpl; by inversion H. simpl; inversion H; inversion X0; split. auto. apply IHs; simpl; by split. Defined. (** * The inverse of the previous theorem. If an element * added to the rear of a sequence results in a fresh * sequence, we might instead add this element in the * front and still come up with a fresh sequence. *) Lemma fresh_rcons : forall (s : seq A) (a t : A), fresh (rcons s t) a -> fresh (t :: s) a. Proof. intros s a t H; induction s. simpl; by inversion H. simpl; simpl in H; split. apply IHs; by inversion H. split. by inversion H. apply IHs; by inversion H. Defined. (** * Freshness remains if we reverse a sequence. *) Lemma rev_fresh : forall (s : seq A) (a : A), fresh s a -> fresh (rev s) a. Proof. intros s a H; induction s. auto. rewrite rev_cons; apply rcons_fresh; simpl; split. by inversion H. apply IHs; by inversion H. Defined. (** * If we have a fresh sequence with one element on front, * the sequence remains fresh if we add this element to * the rear. *) Lemma rcons_fresh_seq : forall (s : seq A) (a : A), fresh_seq (a :: s) -> fresh_seq (rcons s a). Proof. intros s a H; induction s. auto. simpl; apply fresh_cons. unfold sqfresh; inversion H; apply insq. apply rcons_fresh; simpl; unfold sqfresh in H2. assert (fresh (t :: s) a). by apply unsq. inversion X. split. algebra. assert (sq (fresh s t)). inversion H3; auto. by apply unsq in H4. apply IHs; inversion H; apply fresh_cons. inversion H2; inversion X; unfold sqfresh; by apply insq. by inversion H3. Defined. (** * If a sequence with a specific element on its rear is * fresh, the sequence is still fresh if we would have * added this element in the front. *) Lemma fresh_seq_rcons : forall (s : seq A) (a : A), fresh_seq (rcons s a) -> fresh_seq (a :: s). Proof. intros; induction s. auto. simpl in H; inversion H; apply fresh_cons. unfold sqfresh; apply insq. assert (fresh (a :: s) t); apply fresh_rcons. unfold sqfresh in H2; by apply unsq in H2. simpl; simpl in X; inversion X; apply unsq; inversion H. assert (fresh_seq (a :: s)). by apply IHs. apply insq; apply rcons_fresh; simpl; split. algebra. apply unsq; inversion H8. unfold sqfresh in H11; apply unsq in H11; by apply insq. apply fresh_cons; unfold sqfresh in H2; apply unsq in H2. apply fresh_rcons in H2; inversion H2; unfold sqfresh. by apply insq. assert (fresh_seq (a :: s)). by apply IHs. by inversion H4. Defined. (** * If a sequence is fresh, it remains fresh if we completely * reverse it. *) Lemma rev_fresh_seq : forall (s : seq A), fresh_seq s -> fresh_seq (rev s). Proof. intros; induction s. auto. rewrite rev_cons; apply rcons_fresh_seq; apply fresh_cons. inversion H; unfold sqfresh; apply insq; apply rev_fresh. unfold sqfresh in H2; by apply unsq. apply IHs; by inversion H. Defined. Hint Constructors fresh_seq. End FreshSeq. (** * The definitions and lemmas for Newton * polynomials hold for polynomials over an * arbitrary field K. We will later confine * this K to the real numbers R. *) Section NewtonPolynomials. Variable K : CField. Variable f : K -> K. (** * The definition of the divided differences * follows here. This is the function f [..] * as described in the paper written by Bas. * To avoid any confusion, the notation f () * is used for the polynomial subject to * interpolation. *) Program Fixpoint dd (s : seq K) (P : fresh_seq K s) {measure (size s)} : K := match s with | nil => Zero | (a :: nil) => (f a) | (a :: b :: s') => ((dd (a :: s') _) [-] (dd (b :: s') _) [/] (a [-] b) [//] _) end. Next Obligation. apply fresh_cons; inversion P; inversion H1. inversion X; unfold sqfresh; by apply insq. inversion P; by inversion H2. Qed. Next Obligation. by inversion P. Qed. Next Obligation. apply minus_ap_zero; apply unsq; inversion P; inversion H1. inversion X; apply insq; algebra. Qed. (** * Now that we have solved all obligations for * the definition of divided differences, we * continue with our definitions of the functions * N, alpha and eta. *) Variable s : seq K. Variable k : nat. Hypothesis fresh_s : fresh_seq K s. (** * This definition still uses the bigopsClass, but it will be * replaced by a fold until the problems in bigopsClass are * resolved. This definition of eta corresponds to the * definition of n_j(x) in the paper written by Bas. * * TODO: Replace bigopsClass definitions by folds *) Require Export bigopsClass. Definition eta (j : nat) : cpoly_cring K := \big[(cpoly_mult_cs K)/(cpoly_one K)]_(x_i <- take j s) (cpoly_linear _ ([--] x_i) (cpoly_one _)). (** * This definition corresponds to the definition of a_j in * the paper. It is basically a direct call to the definition * of divided differences using the vector x_j, ..., x_0. *) Definition alpha (j : nat) : K := dd (rev (take (j + 1) s)) ((rev_fresh_seq K (take (j + 1) s)) (take_fresh_seq K (j + 1) s fresh_s)). (** * This is the definition of N from the paper. The mkseq * construct creates an increasing sequence. * * TODO: Replace bigopsClass definitions by folds. *) Definition N : cpoly_cring K := \big[cpoly_plus_cs K/(cpoly_zero K)]_(j <- (mkseq (fun x => x) (k + 1)) | (fun x => true) j) (_C_ (alpha j) [*] (eta j)). End NewtonPolynomials. Section BigopsTheory. Variable K : CField. Variable f : K -> K. (** * This is proof independence of divided differences with * respect to freshness. *) Lemma dd_indep : forall (l1 l2 : seq K) (P1 : fresh_seq K l1) (P2 : fresh_seq K l2), l1 = l2 -> dd K f l1 P1 [=] dd K f l2 P2. Proof. intros. unfold dd. replace (existT (fun s : seq K => fresh_seq K s) l2 P2) with (existT (fun s : seq K => fresh_seq K s) l1 P1). reflexivity. by apply subsetT_eq_compat. Qed. (** * Equality of CPolynomials over a field K is reflexive, * symmetric and transitive according to the following * three type class instances. *) Instance cpoly_eq_refl : Reflexive (cpoly_eq K). unfold Reflexive; by reflexivity. Qed. Instance cpoly_eq_symm : Symmetric (cpoly_eq K). unfold Symmetric; by symmetry. Qed. Instance cpoly_eq_trans : Transitive (cpoly_eq K). unfold Transitive; intros x y z; by transitivity y. Qed. Instance eqv_cpoly : Equivalence (cpoly_eq K). Instance eqv_K : Equivalence (@st_eq K). (** * TODO: This definition is not required because we have * an equivalent construct in the type class system. *) Add Parametric Relation : (cpoly_cring K) (cpoly_eq K) reflexivity proved by cpoly_eq_refl symmetry proved by cpoly_eq_symm transitivity proved by cpoly_eq_trans as cpeq. (** * This is meant to prove that addition of polynomials * is a morphism with respect to equality. However, I * cannot complete the proof because it somehow seems * that this exact morphism is required to finish the * proof. * * TODO: Fix this proof. *) Instance morph_cpoly : Proper ((cpoly_eq K) ==> (cpoly_eq K) ==> (cpoly_eq K)) (cpoly_plus_cs K). Admitted. (** * Multiplication of polynomials is also a morphism with * respect to equality. However, the same problem as in * the previous proof arises here. * * TODO: Complete this proof. *) Instance morph_cpoly_mult : Proper ((cpoly_eq K) ==> (cpoly_eq K) ==> (cpoly_eq K)) (cpoly_mult_cs K). Admitted. (** * Multiplication in an arbitrary field K is a morphism with * respect to the standard equality defined in K. * * TODO: Are definitions like these really required? Aren't * they already defined in the CoRN libraries? *) Instance morph_K_mult : Proper ((@st_eq K) ==> (@st_eq K) ==> (@st_eq K)) cr_mult. unfold Proper; unfold respectful. intros x y H x0 y0 H0; rewrite H H0; reflexivity. Qed. (** * Addition in a field K is a morphism with respect to the * standard equality defined on K. *) Instance morph_K_plus : Proper ((@st_eq K) ==> (@st_eq K) ==> (@st_eq K)) csg_op. unfold Proper; unfold respectful. intros x y H x0 y0 H0; rewrite H H0; reflexivity. Qed. (** * Addition of polynomials is associative. * * TODO: As OperationClasses is no longer compiling, this * has to be replaced with another construct. *) Instance assoc_cpoly : @OperationClasses.associative (cpoly_cring K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K). unfold OperationClasses.associative. intros x y z; red. set cpoly_plus_associative. unfold associative in a; simpl in a; apply a. Qed. (** * Multiplication of polynomials is associatve. * * TODO: Fix usage of OperationClasses. *) Instance assoc_cpoly_mult : @OperationClasses.associative (cpoly_cring K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K). unfold OperationClasses.associative. intros x y z; red. set cpoly_mult_assoc. unfold associative in a; simpl in a; apply a. Qed. (** * Multiplication is associative in any field K * * TODO: This should be replaced by a standard lemma from * the CoRN libraries. *) Instance assoc_K_mult : @OperationClasses.associative K (@st_eq K) eqv_K cr_mult. unfold OperationClasses.associative. intros x y z; red; algebra. Qed. (** * Addition is associative in any field K * * TODO: This is very probably already somewhere in the * libraries. *) Instance assoc_K_plus : @OperationClasses.associative K (@st_eq K) eqv_K csg_op. unfold OperationClasses.associative. intros x y z; red; algebra. Qed. (** * The zero-polynomial is a left-unit element with respect * to addition. * * TODO: Fix OperationClasses usage. *) Instance left_unit_cpoly : @OperationClasses.left_unit (cpoly_cring K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K). intro x; red. simpl; reflexivity. Qed. (** * The one-polynomial is a left-unit element with respect * to multiplication. * * TODO: Fix OperationClasses usage. *) Instance left_unit_cpoly_mult : @OperationClasses.left_unit (cpoly_cring K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K). intro x; red. rewrite cpoly_mult_commutative. rewrite cpoly_mult_one. reflexivity. Qed. (** * TODO: Deprecated, do not use OperationClasses. *) Instance left_unit_K_mult : @OperationClasses.left_unit K (@st_eq K) eqv_K cr_mult (One:K). intro x; red; algebra. Qed. (** * TODO: Deprecated, do not use Operationclasses. *) Instance left_unit_K_plus : @OperationClasses.left_unit K (@st_eq K) eqv_K csg_op (Zero:K). intro x; red; algebra. Qed. (** * The zero-polynomial is a right-unit element with respect * to to addition of polynomials. * * TODO: Get rid of OperationClasses code. *) Instance right_unit_cpoly : @OperationClasses.right_unit (cpoly_cring K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K). intro x; red. rewrite cpoly_plus_commutative; simpl; reflexivity. Qed. (** * The one-polynomial is a right-unit element with respect * to multiplication of polynomials. * * TODO: Get rid of OperationClasses code. *) Instance right_unit_cpoly_mult : @OperationClasses.right_unit (cpoly_cring K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K). intro x; red. rewrite cpoly_mult_one; reflexivity. Qed. (** * TODO: Deprecated, do not use OperationClasses code. *) Instance right_unit_K_mult : @OperationClasses.right_unit K (@st_eq K) eqv_K cr_mult (One:K). intro x; red; algebra. Qed. (** * TODO: Deprecated, do not use OperationClasses code. *) Instance right_unit_K_plus : @OperationClasses.right_unit K (@st_eq K) eqv_K csg_op (Zero:K). intro x; red; algebra. Qed. (** * Application of polynomials (over K) is a morphism with * respect to the standard equality defined on K. * * TODO: Fix this proof. To be honest, I have no clue why * this cannot be done. Will take a look at it later. *) Add Parametric Morphism : (@cpoly_apply K) with signature (@cpoly_eq K) ==> (@st_eq K) ==> (@st_eq K) as cpoly_apply_mor. Admitted. (** * Multiplication of polynomials is a morphism with respect * to the equality defined on polynomials. * * TODO: Replace with type class instance. *) Add Parametric Morphism : (@cpoly_mult_cs K) with signature (@cpoly_eq K) ==> (@cpoly_eq K) ==> (@cpoly_eq K) as cpoly_mult_mor. intros x y H x0 y0 H0. rewrite H; rewrite H0; reflexivity. Qed. (** * TODO: Replace with type class instance. *) Add Parametric Morphism : (@polyconst K) with signature (@st_eq K) ==> (@cpoly_eq K) as cpoly_const_mor. intros x y H; rewrite H; reflexivity. Qed. (** * Multiplication of a polynomial (over any field K) and an * element from K is invariant under both equality over poly(K) * and K. * * TODO: Fix this proof. Seems to mutually depend on a previous * morphism for polynomial-multiplication. *) Add Parametric Morphism : (@cpoly_mult_cr_cs K) with signature (@cpoly_eq K) ==> (@st_eq K) ==> (cpoly_eq K) as cpoly_mult_cr_mor. intros x y H x0 y0 H0. Admitted. (** * TODO: Replace with corresponding type class instance. *) Add Parametric Morphism : (@cg_minus K) with signature (@st_eq K) ==> (@st_eq K) ==> (@st_eq K) as cg_minus_mor. intros x y H x0 y0 H0; rewrite H; rewrite H0; reflexivity. Qed. (** * Getting the nth coefficient of a polynomial is a morphism * with respect to equality over nat. * * TODO: Fix this proof. Should not be very difficult. Will * take a look at it later. *) Add Parametric Morphism : (@nth_coeff K) with signature (@eq nat) ==> (@cpoly_eq K) ==> (@st_eq K) as nth_coeff_mor. intros y x y0 H. Admitted. (** * TODO: Replace with corresponding type class instance *) Add Parametric Morphism : (@csg_op K) with signature (@st_eq K) ==> (@st_eq K) ==> (@st_eq K) as csg_op_mor. intros x y H x0 y0 H0; rewrite H H0; reflexivity. Qed. (** * TODO: Replace with corresponding type class instance *) Add Parametric Morphism : (@cg_inv K) with signature (@st_eq K) ==> (@st_eq K) as cg_inv_mor. intros x y H; rewrite H; reflexivity. Qed. (** * The equality on K can be continued to an equality on * polynomials. However, it was not immediately clear how * to prove this. * * TODO: Replace with corresponding definition from the * CoRN libraries. *) Add Parametric Morphism : (@cpoly_linear K) with signature (@st_eq K) ==> (@cpoly_eq K) ==> (@cpoly_eq K) as cpoly_lin_mor. intros x y H x0 y0 H0. Admitted. (** * I have not been able to get rings to work for polynomials. * * TODO: Fix this because it makes many proofs easier to * understand. * * Add Ring cpolyk_th : (CRing_Ring (cpoly_cring K)). * Add Ring cring_K : (CRing_Ring K). * *) (** * If a bigops-expression results in a polynomial, and if * this expression is therefore applied to a particular * value, the application results in the same value as if * the application was done inside the bigops-expression. * * TODO: This should be more general. * TODO: Replace the bigops expression with a corresponding * fold. *) Lemma apply_bigops : forall (r : seq K) F x, (\big[cpoly_mult_cs K/cpoly_one K]_(i <- r) F i) ! x [=] \big[cr_mult/(One:K)]_(i <- r) ((F i) ! x). Proof. intros r F x; destruct r; simpl. rewrite cring_mult_zero; algebra. induction r. simpl; rewrite mult_one; rewrite cpoly_mult_one. reflexivity. repeat rewrite big_cons; simpl in IHr; rewrite mult_assoc. rewrite (mult_commutes K (cpoly_apply K (F s) x) (cpoly_apply K (F t) x)). rewrite <- mult_assoc; rewrite <- IHr. set (@mult_apply); simpl in s0; rewrite <- s0. rewrite cpoly_mult_fast_equiv. set (@cpoly_mult_assoc); unfold CSetoids.associative in a. simpl in a; repeat rewrite a. rewrite (cpoly_mult_commutative K (F s) (F t)). reflexivity. Qed. (** * If we take a subsequence from (the start of) * another sequence, it does not matter if this * sequence was already the result of a 'take' operation. *) Lemma take_nest_redun : forall (n m : nat) (s : seq K), m <= n -> m <= size s -> take m (take n s) = take m s. Proof. intro n; induction n. intros m s H H0; rewrite take0; inversion H. repeat rewrite take0; reflexivity. intros m s H H0. destruct s. simpl; reflexivity. assert (take (S n) (s :: s0) = s :: take n s0) by auto. rewrite H1; destruct m. simpl; reflexivity. simpl; rewrite IHn. reflexivity. omega. inversion H0. auto. omega. Qed. (** * This lemma effectively says that: * * x_0, x_1, ..., x_(k+1) = x_0, x_1, ..., x_i, x_(i+1), * ..., x_(k+1) * * TODO: Perhaps all these takes, nths and drops can be * set up a bit more clearer. *) Lemma take_nth_drop : forall (i k : nat) (s : seq K), i <= k -> k < size s -> take (S k) s = take i s ++ (nth Zero s i) :: (take (k - i) (drop (i + 1) s)). Proof. intro i; induction i. intros k s H H0; destruct s. inversion H0; simpl. replace (k - 0) with k by omega; simpl. rewrite drop0; reflexivity. intros k s H H0; destruct s. inversion H0; simpl. replace (k - S i) with ((k - 1) - i) by omega. simpl; rewrite <- IHi. replace (S (k - 1)) with k by omega; reflexivity. omega. inversion H0. assert (1 <= k) by omega; omega. assert (1 <= k) by omega; omega. Qed. (** * This lemma asserts that the repeated multiplication * of an expression (-x_i) + x_i is equal to zero. *) Lemma lem11a : forall i s k, size s > 1 -> k < size s -> i <= k -> \big[cr_mult/(One:K)]_(x_i <- take (S k) s) (cpoly_linear K [--]x_i (cpoly_one K)) ! (nth Zero s i) [=] Zero. Proof. intros. rewrite (@eq_big_idx_seq K (@st_eq K) eqv_K (cr_mult) (One:K) morph_K_mult right_unit_K_mult (One:K) K (take (S k) s) _ (fun x : K => (cpoly_linear K [--]x (cpoly_one K)) ! (nth Zero s i)) right_unit_K_mult). assert (take (S k) s = (take i s) ++ ((nth Zero s i) :: (take (k - i) (drop (i + 1) s)))). apply take_nth_drop. omega. exact H0. rewrite H2. rewrite (@big_cat K (@st_eq K) eqv_K cr_mult (One:K) morph_K_mult assoc_K_mult left_unit_K_mult K (take i s) (nth Zero s i :: take (k - i) (drop (i + 1) s)) (fun x : K => true)). rewrite big_cons. assert ((cpoly_linear K [--](nth Zero s i) (cpoly_one K)) ! (nth Zero s i) [=] Zero). simpl. rewrite cring_mult_zero. rewrite cm_rht_unit_unfolded. rewrite mult_one. rewrite cg_lft_inv_unfolded. reflexivity. rewrite H3. rewrite mult_assoc. rewrite cring_mult_zero. rewrite mult_commutes. rewrite cring_mult_zero. reflexivity. destruct s. inversion H. simpl; auto. Qed. (** * If we have a fresh sequence s, it is clear that the kth * element is fresh with respect to a subsequence of s. *) Lemma nth_fresh : forall (s : seq K) (k c : nat), k < size s -> fresh_seq K s -> fresh K (take (k - c) s) (nth Zero s k). Proof. intros. induction c. assert (k - 0 = k) by omega. rewrite H1. assert (fresh_seq K (take (k + 1) s)). apply take_fresh_seq. exact H0. cut (take (k + 1) s = take k s ++ [:: nth Zero s k]). intro. rewrite H3 in H2. assert (fresh_seq K ((nth Zero s k) :: take k s)). apply fresh_seq_rcons. rewrite <- cat_rcons in H2. rewrite cats0 in H2. exact H2. apply unsq. inversion H4. unfold sqfresh in H7. exact H7. rewrite <- cat_rcons. rewrite cats0. rewrite <- take_nth. replace (S k) with (k + 1) by omega. reflexivity. apply (ssrbool.introT (P := S k <= size s)). apply ssrnat.leP. omega. cut (take (k - S c) s = take (k - S c) (take (k - c) s)). intro. rewrite H1. apply take_fresh. exact IHc. rewrite take_nest_redun. reflexivity. omega. omega. Qed. (** * If a sequence of elements is fresh, than any two * elements from this sequence lie apart. This is not * immediately clear from the definition (although it * seems so) because of difficulty with the definition * of nth. * * TODO: This proof can be made a bit shorter. *) Lemma ap_fresh_nth : forall (s : seq K) (k c : nat), 0 < k -> c < k -> k < size s -> fresh_seq K s -> (nth Zero s k) [-] (nth Zero s (k - S c)) [#] Zero. Proof. intros. apply minus_ap_zero. assert (fresh K (take (k - c) s) (nth Zero s k)). apply nth_fresh. exact H1. exact H2. assert (take (k - c) s = take (k - S c) s ++ [:: nth Zero s (k - S c)]). rewrite <- cat_rcons. rewrite <- take_nth. replace (S (k - S c)) with (k - c) by omega. rewrite cats0. reflexivity. apply (ssrbool.introT (P := S (k - S c) <= size s)). apply ssrnat.leP. omega. rewrite H3 in X. rewrite <- cat_rcons in X. rewrite cats0 in X. apply fresh_rcons in X. inversion X. algebra. Qed. (** * This lemma is essentially a one-step reduction in the * definition of divided differences. However, it is not * as straightforwardly provable as it might seem. * * TODO: Fix this proof. *) Lemma dd_reduce : forall (s : seq K) (a b : K) (P1 : fresh_seq K (a :: b :: s)) (P2 : fresh_seq K (a :: s)) (P3 : fresh_seq K (b :: s)) (P4 : a [-] b [#] Zero), (dd K f (a :: b :: s) P1) = (((dd K f (a :: s) P2) [-] (dd K f (b :: s) P3)) [/] (a [-] b) [//] P4). Proof. intros. Admitted. (** * This rather complicated lemma states that if we have a * one-step reduction for divided differences, we also have * an n-step reduction according to a specific pattern. * * TODO: This lemma is very unreadable. Perhaps this can be * made more clear using appropriate syntax elements. *) Lemma dd_reduce_nth : forall (s : seq K) (k c : nat) (P : fresh_seq K (nth Zero s k :: rev (take (k - c) s))) (Q : fresh_seq K (nth Zero s k :: rev (take (k - S c) s))) (R : fresh_seq K (rev (take (k - c) s))) (X : (nth Zero s k) [-] (nth Zero s (k - S c)) [#] Zero), 0 < k -> c < k -> k < size s -> fresh_seq K s -> (dd K f (nth Zero s k :: rev (take (k - c) s)) P) [=] ((dd K f (nth Zero s k :: rev (take (k - S c) s)) Q)[-] (dd K f (rev (take (k - c) s)) R)[/] (nth Zero s k[-]nth Zero s (k - S c))[//]X). Proof. intros. assert (fresh_seq K (nth Zero s k :: nth Zero s (k - S c) :: rev (take (k - S c) s))). apply fresh_cons. unfold sqfresh. apply insq. simpl. split. apply zero_minus_apart. algebra. apply rev_fresh. apply nth_fresh. exact H1. exact H2. apply fresh_cons. unfold sqfresh. apply insq. assert (forall k, k < size s -> fresh K (rev (take k s)) (nth Zero s k)). intros. apply rev_fresh. assert (take k0 s = take (k0 - 0) s). replace (k0 - 0) with k0 by omega; reflexivity. rewrite H4. apply nth_fresh. exact H3. exact H2. apply X0. omega. apply rev_fresh_seq. apply take_fresh_seq. exact H2. assert (rev (take (k - c) s) = nth Zero s (k - S c) :: rev (take (k - S c) s)). assert (k - c = (S (k - S c))) by omega. rewrite H4. set (@take_nth). rewrite (@take_nth K Zero (k - S c) s). rewrite rev_rcons; reflexivity. apply (ssrbool.introT (P := S (k - S c) <= size s)). apply ssrnat.leP. omega. assert ((dd K f (nth Zero s k :: rev (take (k - c) s)) P) [=] (dd K f [:: nth Zero s k, nth Zero s (k - S c) & rev (take (k - S c) s)] H3)). apply dd_indep. rewrite H4; reflexivity. rewrite H5. assert (fresh_seq K ((nth Zero s (k - S c)) :: rev (take (k - S c) s))). inversion H3. exact H9. assert ((dd K f (rev (take (k - c) s)) R) [=] (dd K f (nth Zero s (k - S c) :: rev (take (k - S c) s)) H6)). apply dd_indep. rewrite H4; reflexivity. unfold cf_div. rewrite H7. set (dd_reduce (rev (take (k - S c) s)) (nth Zero s k) (nth Zero s (k - S c)) H3 Q H6 X). unfold cf_div in e. rewrite e. reflexivity. Qed. (** * The Newton polynomial coincides with the Lagrange * polynomial. This lemma essentially proves this. * * TODO: Replace bigopsClass operators with corresponding * folds. *) Lemma lem11b : forall (k c : nat) (s : seq K) (Q : fresh_seq K s) (R : fresh_seq K ((nth Zero s k) :: (rev (take (k - c) s)))), 0 < k -> c <= k -> k < size s -> (N K f s k Q) ! (nth Zero s k) [=] (\big[(cpoly_plus_cs K)/(cpoly_zero K)]_(j <- (mkseq (fun x => x) (k - c)) | (fun x => true) j) (_C_ (alpha K f s Q j) [*] (eta K s j))) ! (nth Zero s k) [+] (dd K f ((nth Zero s k) :: (rev (take (k - c) s))) R) [*] (eta K s (k - c)) ! (nth Zero s k). Proof. intros. induction c. assert (k - 0 = k) by omega. assert (mkseq ssrfun.id (k - 0) = mkseq ssrfun.id k). rewrite H2; reflexivity. rewrite H3. clear H2 H3. assert (fresh_seq K (rev (take k s))). apply rev_fresh_seq. apply take_fresh_seq. exact Q. assert (dd K f (nth Zero s k :: rev (take (k - 0) s)) R [=] alpha K f s Q k). unfold alpha. apply dd_indep. rewrite <- cat1s. assert (rev [:: nth Zero s k] = [:: nth Zero s k]). auto. rewrite <- H3. rewrite <- rev_cat. assert (take (k - 0) s ++ [:: nth Zero s k] = take (k + 1) s). rewrite cats1. assert (k - 0 = k) by omega. rewrite H4. rewrite <- take_nth. assert (S k = k + 1) by omega. rewrite H5. reflexivity. apply (ssrbool.introT (P := S k <= size s)). apply ssrnat.leP. auto. rewrite H4. reflexivity. rewrite H3. rewrite <- c_mult_apply. rewrite <- plus_apply. assert (k - 0 = k) by omega. rewrite H4. rewrite <- (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) right_unit_cpoly nat k (fun x => cr_mult (_C_ (alpha K f s Q x)) (eta K s x))). rewrite <- (@big_cat (cpoly K) (cpoly_eq K) (eqv_cpoly) (cpoly_plus_cs K) (cpoly_zero K) morph_cpoly assoc_cpoly left_unit_cpoly nat (mkseq ssrfun.id k) ([:: k]) (fun x => true) (fun x => cr_mult (_C_ (alpha K f s Q x)) (eta K s x)) ). simpl. assert (mkseq ssrfun.id k ++ [:: k] = mkseq ssrfun.id (k + 1)). unfold mkseq. assert ([:: k] = map ssrfun.id [:: k]). auto. rewrite H5. rewrite <- map_cat. assert ([:: k] = iota k 1). auto. rewrite H6. rewrite <- iota_add. auto. rewrite H5. reflexivity. assert (fresh_seq K (nth Zero s k :: rev (take (k - c) s))). apply fresh_cons. unfold sqfresh. apply insq. apply rev_fresh. apply nth_fresh. exact H1. exact Q. apply rev_fresh_seq. apply take_fresh_seq. exact Q. rewrite (IHc H2). assert (mkseq ssrfun.id (k - c) = mkseq ssrfun.id (k - S c) ++ [:: (k - S c)]). unfold mkseq. assert ([:: k - S c] = map ssrfun.id (iota (k - S c) 1)) by auto. rewrite H3. rewrite <- map_cat. assert (iota (k - S c) 1 = iota (0 + (k - S c)) 1) by auto. rewrite H4. rewrite <- iota_add. assert (ssrnat.addn (k - S c) 1 = k - c). rewrite ssrnat.addn1. omega. rewrite H5; reflexivity. rewrite H3. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) morph_cpoly assoc_cpoly left_unit_cpoly nat (mkseq ssrfun.id (k - S c)) [:: k - S c] ). rewrite plus_apply. set (CSemiGroups.plus_assoc K). unfold associative in a. rewrite <- a. rewrite (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) right_unit_cpoly nat (k - S c)). assert (fresh_seq K (rev (take (k - c) s))). apply rev_fresh_seq. apply take_fresh_seq. exact Q. assert ((nth Zero s k) [-] (nth Zero s (k - S c)) [#] Zero). apply ap_fresh_nth. omega. omega. exact H1. exact Q. assert ((dd K f (nth Zero s k :: rev (take (k - c) s)) H2) [=] (((dd K f (nth Zero s k :: rev (take (k - S c) s)) R) [-] (dd K f (rev (take (k - c) s)) H4)) [/] ((nth Zero s k) [-] (nth Zero s (k - S c))) [//] X)). apply dd_reduce_nth. exact H. omega. exact H1. exact Q. rewrite H5. unfold eta at 3. assert (\big[cpoly_mult_cs K/cpoly_one K]_(x_i <- take (k - c) s) (cpoly_linear K (cg_inv x_i) (cpoly_one K)) [=] \big[cpoly_mult_cs K/cpoly_one K]_(x_i <- (take (k - S c) s) ++ [:: nth Zero s (k - S c)]) (cpoly_linear K (cg_inv x_i) (cpoly_one K))). assert (take (k - c) s = take (k - S c) s ++ [:: nth Zero s (k - S c)]). rewrite <- cat_rcons. rewrite <- take_nth. assert (k - c = S (k - S c)) by omega. rewrite H6. rewrite cats0; reflexivity. apply (ssrbool.introT (P := S (k - S c) <= size s)). apply ssrnat.leP. omega. rewrite H6. reflexivity. rewrite H6. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K) morph_cpoly_mult assoc_cpoly_mult left_unit_cpoly_mult K (take (k - S c) s) [:: nth Zero s (k - S c)]). rewrite (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K) right_unit_cpoly_mult K (nth Zero s (k - S c))). rewrite (mult_apply K _ (cpoly_linear K (cg_inv (nth Zero s (k - S c))) (cpoly_one K))). assert (cpoly_apply_fun (cpoly_linear K (cg_inv (nth Zero s (k - S c))) (cpoly_one K)) (nth Zero s k) [=] nth Zero s k [-] nth Zero s (k - S c)). simpl. rewrite cring_mult_zero. rewrite cm_rht_unit_unfolded. rewrite mult_one. rewrite cg_minus_unfolded. algebra. rewrite H7. rewrite (mult_commutes K _ (nth Zero s k [-] nth Zero s (k - S c))). rewrite mult_assoc. rewrite div_1. rewrite (mult_commutes K (_ [-] _) _). rewrite ring_dist_minus. unfold alpha at 2. assert (dd K f (rev (take (k - S c + 1) s)) (rev_fresh_seq K (take (k - S c + 1) s) (take_fresh_seq K (k - S c + 1) s Q)) [=] dd K f (rev (take (k - c) s)) H4). apply dd_indep. assert (k - S c + 1 = k - c) by omega. rewrite H8. reflexivity. rewrite H8. rewrite cg_minus_unfolded. rewrite (cag_commutes K _ (cg_inv _)). rewrite (a _ (cg_inv _)). unfold eta at 2. rewrite c_mult_apply. rewrite (mult_commutes K _ (dd _ _ _ H4)). rewrite cg_rht_inv_unfolded. rewrite cm_lft_unit_unfolded. rewrite (mult_commutes K (dd _ _ _ _) _). unfold eta at 3. reflexivity. omega. Qed. (** * This lemma corresponds with lemma 13 in the paper as * sent to me on january 11th. It is called 'lem11' here * because it was based on a previous version of the paper. * It relies on lemmas 11a and 11b (see before). *) Lemma lem11 : forall (k i : nat) (s : seq K) (P : i <= k) (Q : fresh_seq K s), k < size s -> f (nth Zero s i) [=] (N K f s k Q) ! (nth Zero s i). Proof. intros. induction k. inversion P. destruct s. inversion H. simpl. unfold alpha. assert (fresh_seq K [:: s]). apply fresh_cons. unfold sqfresh. apply insq. simpl; auto. apply fresh_nil. assert (dd K f (rev (take (0 + 1) (s :: s0))) (rev_fresh_seq K (take (0 + 1) (s :: s0)) (take_fresh_seq K (0 + 1) (s :: s0) Q)) [=] dd K f [:: s] H1). apply dd_indep. simpl. rewrite take0. reflexivity. rewrite H2. assert (f s [=] dd K f [:: s] H1). algebra. rewrite <- H3. rewrite cring_mult_zero. rewrite cm_rht_unit_unfolded. rewrite cm_rht_unit_unfolded. algebra. inversion P. assert (fresh_seq K (nth Zero s (S k) :: rev (take (S k - S k) s))). assert (S k - S k = 0) by omega. rewrite H1. rewrite take0. apply fresh_cons. unfold sqfresh. apply insq. simpl; auto. apply rev_fresh_seq. apply fresh_nil. rewrite (lem11b (S k) (S k) _ _ H1). assert (mkseq ssrfun.id (S k - S k) = Nil nat). assert (S k - S k = 0) by omega. rewrite H2. auto. rewrite H2. rewrite big_nil. assert (fresh_seq K [:: nth Zero s (S k)]). apply fresh_cons. unfold sqfresh. apply insq. simpl; auto. apply fresh_nil. setoid_replace (dd K f (nth Zero s (S k) :: (rev (take (S k - S k) s))) H1) with (dd K f [:: nth Zero s (S k)] H3). assert (cpoly_apply_fun (cpoly_zero K) (nth Zero s (S k)) [=] Zero). algebra. rewrite H4. rewrite cm_lft_unit_unfolded. unfold eta. assert (take (S k - S k) s = Nil K). assert (S k - S k = 0) by omega. rewrite H5. rewrite take0; reflexivity. rewrite H5. rewrite apply_bigops. rewrite big_nil. rewrite mult_one. algebra. apply dd_indep. assert (S k - S k = 0) by omega. rewrite H4. rewrite take0. auto. omega. auto. omega. unfold N. rewrite (@eq_big_idx_seq (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) morph_cpoly right_unit_cpoly (cpoly_zero K) nat (mkseq ssrfun.id (S k + 1)) (fun x : nat => true) (fun x : nat => cr_mult (_C_ (alpha K f s Q x)) (eta K s x)) right_unit_cpoly). assert (mkseq ssrfun.id (S (k + 1)) = (mkseq ssrfun.id (S k)) ++ [:: S k]). unfold mkseq. replace (S (S k)) with (S k + 1). rewrite (iota_add 0 (S k) 1). rewrite map_cat; auto. omega. rewrite H2. clear H2. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) morph_cpoly assoc_cpoly left_unit_cpoly nat (mkseq ssrfun.id (S k)) ([:: S k]) (fun x : nat => true) (fun x : nat => _C_ (alpha K f s Q x) [*] (eta K s x))). unfold N in IHk. rewrite (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) right_unit_cpoly nat (S k) (fun x : nat => _C_ (alpha K f s Q x) [*] (eta K s x))). rewrite (@plus_apply K ((\big[cpoly_plus_cs K/cpoly_zero K]_(i0 <- mkseq ssrfun.id (S k)) (_C_ (alpha K f s Q i0) [*] (eta K s i0)))) (_C_ (alpha K f s Q (S k)) [*] (eta K s (S k))) (nth Zero s i)). assert ((_C_ (alpha K f s Q (S k)) [*] (eta K s (S k))) ! (nth Zero s i) [=] Zero). rewrite c_mult_apply. unfold eta. rewrite (@apply_bigops (take (S k) s)). rewrite lem11a. rewrite cring_mult_zero. reflexivity. omega. omega. exact H1. rewrite H2. rewrite IHk. assert (S k = k + 1) by omega. rewrite H3. rewrite cm_rht_unit_unfolded. reflexivity. exact H1. omega. auto. Qed. (** * Getting the nth coefficient of a polynomial can be done * outside a bigop, as well as inside, resulting in the * same value (with the bigop applied in the latter case, * of course). * * TODO: Generalise to arbitrary bigop. * TODO: Replace bigopsClass construct with corresponding * folds. *) Lemma nth_coeff_bigops : forall (k : nat) (r : seq nat) F, nth_coeff k (\big[cpoly_plus_cs K/cpoly_zero K]_(i <- r) F i) [=] \big[csg_op/(Zero:K)]_(i <- r) (nth_coeff k (F i)). Proof. intros. induction r. rewrite big_nil. simpl; reflexivity. rewrite big_cons. rewrite nth_coeff_plus. rewrite IHr. rewrite big_cons. reflexivity. Qed. (** * A small lemma to ascertain compatibility between two * types of multiplication between polynomials and constant * values. *) Lemma cpoly_mult_cr_c_ : forall p c, (cpoly_mult_cr K p c [=] p [*] _C_ c). Proof. intros. simpl. induction p. simpl; auto. simpl. split. rewrite cm_rht_unit_unfolded. rewrite mult_commutes. reflexivity. rewrite IHp. reflexivity. Qed. (** * This corrolary corresponds to corrolary 14 in the PDF as * e-mailed to me on january 11th. It states that the divided * difference f[a_1, ..., a_n] is the coefficient of x^n in * the (Newton) polynomial that interpolates f at a_1, ..., a_n. * * TODO: Fix usage of bigopsClass constructs. * TODO: Shorten proof. *) Lemma cor12 : forall (k : nat) (s : seq K) (Q : fresh_seq K s), k < size s -> nth_coeff k (N K f s k Q) [=] alpha K f s Q k. Proof. intros. unfold N. cut (mkseq ssrfun.id (k + 1) = mkseq ssrfun.id k ++ [:: k]). intro. rewrite H0. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) morph_cpoly assoc_cpoly left_unit_cpoly). rewrite (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) right_unit_cpoly). rewrite nth_coeff_plus. rewrite nth_coeff_c_mult_p. assert (nth_coeff k (eta K s k) [=] One). unfold eta. clear H0. induction k. rewrite take0. simpl; reflexivity. cut (take (S k) s = take k s ++ [:: nth Zero s k]). intro. rewrite H0. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K) morph_cpoly_mult assoc_cpoly_mult left_unit_cpoly_mult). rewrite (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K) right_unit_cpoly_mult). rewrite cpoly_mult_lin. rewrite nth_coeff_plus. rewrite coeff_Sm_lin. rewrite cpoly_mult_one. rewrite IHk. unfold cpoly_mult_cr_cs. rewrite cpoly_mult_cr_c_. rewrite nth_coeff_p_mult_c_. assert (degree_le k (\big[cpoly_mult_cs K/cpoly_one K]_(i <- take k s) cpoly_linear K (cg_inv i) (cpoly_one K))). clear IHk H0. induction k. rewrite take0. unfold degree_le. intros. rewrite big_nil. destruct m. inversion H0. simpl; reflexivity. cut (take (S k) s = take k s ++ [:: nth Zero s k]). intro. rewrite H0. unfold degree_le. intros. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K) morph_cpoly_mult assoc_cpoly_mult left_unit_cpoly_mult). set degree_mult_aux. simpl in s0. destruct m. inversion H1. replace (S m) with (m + 1) by omega. rewrite <- cpoly_mult_fast_equiv. rewrite s0. simpl. rewrite mult_one. rewrite cm_rht_unit_unfolded. rewrite mult_one. unfold degree_le in IHk. rewrite IHk. reflexivity. omega. omega. unfold degree_le in IHk. unfold degree_le. intros. rewrite IHk. reflexivity. omega. omega. unfold degree_le. intros. destruct m0. inversion H2. destruct m0. inversion H2. inversion H4. simpl. reflexivity. rewrite cats1. rewrite <- take_nth. reflexivity. apply (ssrbool.introT (P := S k <= size s)). apply ssrnat.leP. omega. unfold degree_le in H1. rewrite H1. rewrite mult_commutes. rewrite cring_mult_zero. algebra. omega. omega. rewrite cats1. rewrite <- take_nth. reflexivity. apply (ssrbool.introT (P := S k <= size s)). apply ssrnat.leP. omega. rewrite H1. rewrite mult_one. assert (degree_le (k - 1) (\big[cpoly_plus_cs K/cpoly_zero K]_(i <- mkseq ssrfun.id k) cr_mult (_C_ (alpha K f s Q i)) (eta K s i))). unfold degree_le. clear H0 H1. induction k. simpl. intros. reflexivity. intros. cut (mkseq ssrfun.id (S k) = mkseq ssrfun.id k ++ [:: k]). intro. rewrite H1. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) morph_cpoly assoc_cpoly left_unit_cpoly). rewrite (@big_seq1 (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_plus_cs K) (cpoly_zero K) right_unit_cpoly). rewrite nth_coeff_plus. unfold degree_le in IHk. rewrite IHk. rewrite cm_lft_unit_unfolded. rewrite nth_coeff_c_mult_p. clear IHk. assert (degree_le k (eta K s k)). unfold degree_le. induction k. unfold degree_le, eta. intros. rewrite take0. destruct m0. assert (1 < 0) by omega. inversion H2. simpl; reflexivity. unfold degree_le, eta. intros. cut (take (S k) s = take k s ++ [:: nth Zero s k]). intro. rewrite H3. rewrite (@big_cat (cpoly K) (cpoly_eq K) eqv_cpoly (cpoly_mult_cs K) (cpoly_one K) morph_cpoly_mult assoc_cpoly_mult left_unit_cpoly_mult). set degree_mult_aux. simpl in s0. rewrite <- cpoly_mult_fast_equiv. destruct m0. inversion H2. replace (S m0) with (m0 + 1) by omega. rewrite s0. unfold degree_le in IHk. rewrite IHk. rewrite mult_commutes. rewrite cring_mult_zero. reflexivity. omega. omega. unfold mkseq. assert ([:: k] = map ssrfun.id (iota k 1)). simpl; reflexivity. rewrite H4. rewrite <- map_cat. rewrite <- iota_add. rewrite ssrnat.addn1. reflexivity. omega. unfold degree_le. intros. rewrite IHk. reflexivity. omega. omega. unfold mkseq. assert ([:: k] = map ssrfun.id (iota k 1)). simpl; reflexivity. rewrite H5. rewrite <- map_cat. rewrite <- iota_add. rewrite ssrnat.addn1. reflexivity. omega. unfold degree_le. intros. simpl. destruct m1. inversion H4. destruct m1. inversion H4. inversion H6. reflexivity. rewrite cats1. rewrite <- take_nth. reflexivity. apply (ssrbool.introT (P := S k <= size s)). apply ssrnat.leP. omega. unfold degree_le in H2. rewrite H2. rewrite cring_mult_zero. reflexivity. omega. omega. omega. unfold mkseq. assert ([:: k] = map ssrfun.id (iota k 1)). simpl; reflexivity. rewrite H1. rewrite <- map_cat. rewrite <- iota_add. rewrite ssrnat.addn1. reflexivity. destruct k. simpl. rewrite cm_lft_unit_unfolded. reflexivity. unfold degree_le in H2. rewrite H2. rewrite cm_lft_unit_unfolded. reflexivity. omega. unfold mkseq. assert ([:: k] = map ssrfun.id (iota k 1)). simpl; reflexivity. rewrite H0. rewrite <- map_cat. rewrite <- iota_add. rewrite ssrnat.addn1. replace (S k) with (k + 1) by omega. reflexivity. Qed. End BigopsTheory. (** * Since we don't have decidable equality for elements * in a Field K, we have to define our own permutation * for sequences. *) Section Permutations. Variable A : CSetoid. (** * Alternative definition for permutations. This one * matches the definition of dd a bit better. *) Inductive permutation : seq A -> seq A -> Prop := | permutation_nil : permutation nil nil | permutation_singleton : forall (a : A), permutation [:: a] [:: a] | permutation_skip : forall (a b : A) (s1 s2 : seq A), permutation s1 s2 -> permutation (a :: s1) (a :: s2) -> permutation (b :: s1) (b :: s2) -> permutation (a :: b :: s1) (a :: b :: s2) | permutation_swap : forall (a b : A) (s : seq A), permutation (a :: b :: s) (b :: a :: s) | permutation_trans : forall s1 s2 s3 : seq A, permutation s1 s2 -> permutation s2 s3 -> permutation s1 s3. Hint Constructors permutation. (** * A type of induction on sequences that suits the * definition of divided differences a bit better. * * TODO: Fix this proof, which should not be too hard. * A solution might be to distinguish between sequences * of even and odd length. *) Lemma dd_type_ind : forall P, P [::] -> (forall (a : A), P [:: a]) -> (forall (a b : A) (s : seq A), P s -> P (a :: s) -> P (b :: s) -> P (a :: b :: s)) -> (forall (s : seq A), P s). Proof. intros. Admitted. (** * Permutations are reflexive. *) Lemma permutation_refl : forall s : seq A, permutation s s. Proof. intros. induction s using dd_type_ind. apply permutation_nil. apply permutation_singleton. apply permutation_skip. exact IHs. exact IHs0. exact IHs1. Qed. Hint Resolve permutation_refl. (** * Permutations are symmetric. *) Lemma permutation_sym : forall l m : seq A, permutation l m -> permutation m l. Proof. intros l1 l2 H'; elim H'. apply permutation_nil. intro a. apply permutation_singleton. intros. apply permutation_skip. exact H0. exact H2. exact H4. intros. apply permutation_swap. intros l1' l2' l3' H1 H2 H3 H4. apply permutation_trans with (1 := H4) (2 := H2). Qed. (** * The length of a sequence does not change under * permutation. *) Lemma permutation_size : forall l m : seq A, permutation l m -> size l = size m. Proof. intros l m H'; elim H'; simpl in |- *; auto. intros l1 l2 l3 H'0 H'1 H'2 H'3. rewrite <- H'3; auto. Qed. (** * The permutation nil originates from nil. *) Lemma permutation_nil_inv : forall l : seq A, permutation l nil -> l = nil. Proof. intros l H; generalize (permutation_size _ _ H); case l; simpl in |- *; auto. intros; discriminate. Qed. (** * Permutation on sequences of length 1 is an identity * operation. *) Lemma permutation_one_inv_aux : forall l1 l2 : seq A, permutation l1 l2 -> forall a : A, l1 = a :: nil -> l2 = a :: nil. Proof. intros l1 l2 H; elim H; clear H l1 l2; auto. intros. inversion H5. intros. inversion H. Qed. (** * TODO: Do we really require this lemma? *) Lemma permutation_one_inv : forall (a : A) (l : seq A), permutation (a :: nil) l -> l = a :: nil. intros a l H; apply permutation_one_inv_aux with (l1 := a :: nil); auto. Qed. End Permutations. Section PermProperties. Variable K : CField. Variable f : K -> K. (** * The property of freshness is preserved under permutation. *) Lemma perm_fresh : forall (s1 s2 : seq K), fresh_seq K s1 -> permutation K s1 s2 -> fresh_seq K s2. Proof. intros. induction H0. apply fresh_nil. apply fresh_cons. unfold sqfresh; simpl. apply insq; auto. apply fresh_nil. apply fresh_cons. assert (fresh_seq K (a :: s2)). apply IHpermutation2. apply fresh_cons. inversion H. inversion H2. inversion X. unfold sqfresh. apply insq. exact X1. inversion H. inversion H3. exact H7. inversion H. inversion H3. inversion X. unfold sqfresh. apply insq. simpl. split. exact X0. apply unsq. inversion H0. unfold sqfresh in H7. exact H7. apply IHpermutation3. inversion H. exact H3. apply fresh_cons. inversion H. inversion H2. inversion X. unfold sqfresh. apply insq. simpl. split. apply ap_symmetric. exact X0. apply unsq. inversion H3. unfold sqfresh in H6. exact H6. apply fresh_cons. inversion H. inversion H2. inversion X. unfold sqfresh. apply insq. exact X1. inversion H. inversion H3. exact H7. apply IHpermutation2. apply IHpermutation1. exact H. Qed. (** * Lemma 14 - The result of dd is invariant under * permutation of its sequence of arguments. * * In the paper as sent to me on january 11th, this is * referred to as lemma 16. * * TODO: Shorten proof. *) Lemma lem14 : forall (s1 s2 : seq K) (P1 : fresh_seq K s1) (P2 : fresh_seq K s2), (permutation K s1 s2) -> dd K f s1 P1 [=] dd K f s2 P2. Proof. intros s1 s2 P1 P2 perm. induction perm. algebra. algebra. assert (fresh_seq K (a :: s1)). apply fresh_cons. inversion P1. inversion H1. inversion X. unfold sqfresh. apply insq. exact X1. inversion P1. inversion H2. exact H6. assert (fresh_seq K (b :: s1)). inversion P1. exact H3. inversion P1. inversion H3. inversion X. assert (a [-] b [#] Zero). apply minus_ap_zero. apply ap_symmetric. exact X0. rewrite (dd_reduce K f s1 a b P1 H H0 X2). assert (fresh_seq K (a :: s2)). apply fresh_cons. inversion P2. inversion H7. inversion X3. apply insq. exact X5. inversion P2. inversion H8. exact H12. assert (fresh_seq K (b :: s2)). inversion P2. exact H9. rewrite (dd_reduce K f s2 a b P2 H5 H6 X2). apply div_wd. rewrite (IHperm2 H H5). rewrite (IHperm3 H0 H6). reflexivity. reflexivity. assert (fresh_seq K (a :: s)). inversion P2. exact H2. assert (fresh_seq K (b :: s)). inversion P1. exact H3. inversion P1. inversion H3. inversion X. assert (a [-] b [#] Zero). apply minus_ap_zero. apply ap_symmetric. exact X0. rewrite (dd_reduce K f s a b P1 H H0 X2). assert (b [-] a [#] Zero). apply minus_ap_zero. exact X0. rewrite (dd_reduce K f s b a P2 H0 H X3). apply eq_div. rewrite ring_dist_minus. rewrite ring_dist_minus. rewrite dist_2b. rewrite dist_2b. rewrite dist_2b. rewrite dist_2b. set (cr_mult (dd K f (a :: s) H) b). set (cr_mult (dd K f (b :: s) H0) b). set (cr_mult (dd K f (a :: s) H) a). set (cr_mult (dd K f (b :: s) H0) a). rewrite assoc_1. rewrite assoc_1. rewrite <- minus_plus. rewrite <- minus_plus. rewrite (cag_commutes_unfolded K s3 s2). rewrite (cag_commutes_unfolded K _ s1). rewrite assoc_2. rewrite (cag_commutes_unfolded K _ s4). rewrite assoc_2. rewrite cg_minus_unfolded. rewrite cg_minus_unfolded. rewrite (cag_commutes_unfolded K s1 s4). reflexivity. assert (fresh_seq K s2). apply (perm_fresh s1). exact P1. exact perm1. rewrite (IHperm1 P1 H). rewrite (IHperm2 H P2). reflexivity. Qed. End PermProperties. (** * This is the end of the section about permutations. As I * indicated before in our conversations, from this point on * I have much concern about the proper heading of this * research. For instance, many lemmas below are only * required to get NAH-material to work (while it is still * a bit uncertain if we require this at all). Another * important mistake (in my opinion) is the usage of two * different definitions of continuity, differentiability * etc. * * I therefore propose the following: * * - Keep the file from line 0 up until here intact * (but fix the proofs, of course). * - Start over again to work on multi-variable integration * as a separate branch (but only what is really required * for this project). * - Bridge the gap between these two, and complete the * proof. *) Section Derivations. (** * Lemma 15 - If a < b then C[a,b] is an algebra over * the ring R. *) Require Import Structures. Variable a b : IR. Hypothesis Hab : a [<] b. (** * These are the partial functions on IR such that for * each n, they are n-times differentiable. *) Record C_inf_ab := { f_crr : PartFunct IR ; f_pdf : forall n, Diffble_I_n Hab n f_crr}. (** * These are type class instances and not further explained. *) Instance IR_plus : RingPlus IR := csg_op. Instance IR_mult : RingMult IR := cr_mult. Instance IR_inv : GroupInv IR := cg_inv. Instance IR_zero : RingZero IR := Zero. Instance IR_one : RingOne IR := One. Instance IR_equiv : Equiv IR := (@st_eq IR). Instance IR_equivalence : Equivalence (@st_eq IR). (** * Addition is associative for IR *) Instance IR_associative : @Associative IR (@st_eq IR) IR_plus. unfold Associative. intros. unfold IR_plus. unfold equiv. algebra. Qed. (** * Addition is a morphism with respect to the standard * equality on IR. *) Instance IR_proper : Proper ((@st_eq IR) ==> (@st_eq IR) ==> (@st_eq IR)) IR_plus. unfold Proper. unfold respectful. intros. rewrite H. rewrite H0. reflexivity. Qed. (** * These two facts allow us to state IR as a semigroup for * addition. *) Instance IR_semigroup : @SemiGroup IR (@st_eq IR) IR_plus. (** * IR is a monoid for addition over IR. *) Instance IR_monoid : @Monoid IR (@st_eq IR) IR_plus Zero. assert (forall x : IR, Zero [+] x == x). intros. rewrite cm_lft_unit_unfolded. reflexivity. assert (forall x : IR, x [+] Zero == x). intros. rewrite cm_rht_unit_unfolded. reflexivity. apply (Build_Monoid IR (@st_eq IR) IR_plus Zero IR_semigroup H H0). Qed. (** * Type instance stating that inversion for IR is a * morphism with respect to the standard equality on IR. *) Instance IR_proper_inv : Proper ((@st_eq IR) ==> (@st_eq IR)) IR_inv. unfold Proper. unfold respectful. intros. rewrite H. reflexivity. Qed. (** * This makes IR a group with addition, inversion and zero. *) Instance IR_group : @Group IR (@st_eq IR) IR_plus Zero IR_inv. assert (forall x : IR, IR_plus (IR_inv x) x == Zero). intros. unfold IR_plus, IR_inv. assert (csg_op (cg_inv x) x [=] Zero). algebra. rewrite H. reflexivity. assert (forall x : IR, IR_plus x (IR_inv x) == Zero). intros. unfold IR_plus, IR_inv. assert (csg_op x (cg_inv x) [=] Zero). algebra. rewrite H0. reflexivity. apply (Build_Group IR (@st_eq IR) IR_plus Zero IR_inv IR_monoid IR_proper_inv H H0). Qed. (** * IR is also an Abelian group because of the commutativity * of addition. *) Instance IR_abgroup : @AbGroup IR (@st_eq IR) IR_plus Zero IR_inv. assert (Commutative IR_plus). unfold Commutative. intros. assert (IR_plus x y [=] IR_plus y x). unfold IR_plus. algebra. rewrite H. reflexivity. apply (Build_AbGroup IR (@st_eq IR) IR_plus Zero IR_inv IR_group H). Qed. (** * Multiplication on IR is clearly associative. *) Instance IR_associative_mult : @Associative IR (@st_eq IR) IR_mult. unfold Associative. intros. unfold IR_mult. unfold equiv. algebra. Qed. (** * Multiplication on IR is a morphism with respect to the * standard equality on IR. *) Instance IR_proper_mult : Proper ((@st_eq IR) ==> (@st_eq IR) ==> (@st_eq IR)) IR_mult. unfold Proper. unfold respectful. intros. rewrite H. rewrite H0. reflexivity. Qed. (** * This makes IR a semigroup with respect to multiplication. *) Instance IR_semigroup_mult : @SemiGroup IR (@st_eq IR) IR_mult. (** * We may now conclude that IR is a monoid with one as the * neutral element in multiplication. *) Instance IR_monoid_mult : @Monoid IR (@st_eq IR) IR_mult One. assert (forall x : IR, One [*] x == x). intros. rewrite mult_commutes. rewrite mult_one. reflexivity. assert (forall x : IR, x [*] One == x). intros. rewrite mult_one. reflexivity. apply (Build_Monoid IR (@st_eq IR) IR_mult One IR_semigroup_mult H H0). Qed. (** * The reals form a ring with addition and multiplication. * * TODO: All these lemmas (this one and the ones before) are * probably defined in the CoRN libraries as well and are * therefore not required to be stated here (but I am not * sure if they are already present as type class instances). *) Instance IR_ring : @Ring IR (@st_eq IR) IR_plus IR_mult IR_inv Zero One. assert (Commutative IR_mult). unfold Commutative. intros. assert (IR_mult x y [=] IR_mult y x). unfold IR_mult. algebra. rewrite H. reflexivity. assert (Distribute IR_mult IR_plus). assert (forall a b c, IR_mult a (IR_plus b c) == IR_plus (IR_mult a b) (IR_mult a c)). intros. unfold IR_mult, IR_plus. assert (cr_mult a0 (csg_op b0 c) [=] csg_op (cr_mult a0 b0) (cr_mult a0 c)). algebra. rewrite H0. reflexivity. assert (forall a b c, IR_mult (IR_plus a b) c == IR_plus (IR_mult a c) (IR_mult b c)). intros. unfold IR_mult, IR_plus. assert (cr_mult (csg_op a0 b0) c [=] csg_op (cr_mult a0 c) (cr_mult b0 c)). algebra. rewrite H1. reflexivity. apply (Build_Distribute IR (@st_eq IR) IR_mult IR_plus H0 H1). apply (Build_Ring IR (@st_eq IR) IR_plus IR_mult IR_inv Zero One IR_abgroup IR_monoid_mult H H0). Qed. (** * If f' and g' are the nth derivatives of respectively * f and g, then f'+g' is the nth derivative of f+g. * * TODO: Is it possible to make these proofs a bit shorter? *) Lemma Derivative_I_n_add : forall (n : nat) (f g f' g' : PartFunct IR) (Pfderiv : Derivative_I_n Hab n f f') (Pgderiv : Derivative_I_n Hab n g g'), Derivative_I_n Hab n (f{+}g) (f'{+}g'). Proof. intro n. induction n. intros. apply Feq_plus. exact Pfderiv. exact Pgderiv. intros. simpl. elim Pfderiv. intros. elim Pgderiv. intros. exists (IPlus x x0). apply Derivative_I_wdr with (PartInt x{+}PartInt x0). apply part_int_plus. apply Feq_reflexive. apply derivative_imp_inc' with f. exact p. apply Feq_reflexive. apply derivative_imp_inc' with g. exact p0. apply Derivative_I_plus. exact p. exact p0. apply Derivative_I_n_wdl with (PartInt x{+}PartInt x0). apply part_int_plus. apply Feq_reflexive. apply derivative_imp_inc' with f. exact p. apply Feq_reflexive. apply derivative_imp_inc' with g. exact p0. apply IHn. exact q. exact q0. Qed. (** * Now that we have an exact representation of the nth * derivative under addition, we can more easily prove * n-times differentiability for the addition of functions. *) Lemma Diffble_I_n_plus : forall (n : nat) (f g : PartFunct IR) (Pfdf : Diffble_I_n Hab n f) (Pgdf : Diffble_I_n Hab n g), Diffble_I_n Hab n (Fplus f g). Proof. intros. assert ({f0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab n f (PartInt f0')}). apply Diffble_I_n_imp_deriv_n. exact Pfdf. assert ({g' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab n g (PartInt g')}). apply Diffble_I_n_imp_deriv_n. exact Pgdf. inversion_clear X. inversion_clear X0. apply deriv_n_imp_Diffble_I_n with (PartInt x{+}PartInt x0). apply Derivative_I_n_add. exact X1. exact X. Qed. (** * If f' and g' are the nth derivatives of respectively * f and g, then f'-g' is the nth derivative of f-g. *) Lemma Derivative_I_n_minus : forall (n : nat) (f g f' g' : PartFunct IR) (Pfderiv : Derivative_I_n Hab n f f') (Pgderiv : Derivative_I_n Hab n g g'), Derivative_I_n Hab n (f{-}g) (f'{-}g'). Proof. intro n. induction n. intros. apply Feq_minus. exact Pfderiv. exact Pgderiv. intros. simpl. elim Pfderiv. intros. elim Pgderiv. intros. exists (IMinus x x0). apply Derivative_I_wdr with (PartInt x{-}PartInt x0). apply part_int_minus. apply Feq_reflexive. apply derivative_imp_inc' with f. exact p. apply Feq_reflexive. apply derivative_imp_inc' with g. exact p0. apply Derivative_I_minus. exact p. exact p0. apply Derivative_I_n_wdl with (PartInt x{-}PartInt x0). apply part_int_minus. apply Feq_reflexive. apply derivative_imp_inc' with f. exact p. apply Feq_reflexive. apply derivative_imp_inc' with g. exact p0. apply IHn. exact q. exact q0. Qed. (** * The n-times differentiability of two functions f and g * continues to the n-times differentiability of f-g. * * TODO: Prove this lemma using only backward reasoning. *) Lemma Diffble_I_n_minus : forall (n : nat) (f g : PartFunct IR) (Pfdf : Diffble_I_n Hab n f) (Pgdf : Diffble_I_n Hab n g), Diffble_I_n Hab n (f{-}g). Proof. intros. assert ({f0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab n f (PartInt f0')}). apply Diffble_I_n_imp_deriv_n. exact Pfdf. assert ({g' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab n g (PartInt g')}). apply Diffble_I_n_imp_deriv_n. exact Pgdf. inversion_clear X. inversion_clear X0. apply deriv_n_imp_Diffble_I_n with (PartInt x{-}PartInt x0). apply Derivative_I_n_minus. exact X1. exact X. Qed. (** * Use addition of functions to create a semigroup-operation * for infinitely-differentiable functions. *) Program Instance C_inf_ab_plus : SemiGroupOp C_inf_ab := (fun f g => Build_C_inf_ab (@Fplus IR (f_crr f) (f_crr g)) _ ). Next Obligation. apply Diffble_I_n_plus. destruct f. assert (f_crr (Build_C_inf_ab f_crr0 f_pdf0) = f_crr0). auto. rewrite H. apply f_pdf0. destruct g. assert (f_crr (Build_C_inf_ab f_crr0 f_pdf0) = f_crr0). auto. rewrite H. apply f_pdf0. Qed. (** * The standard equality between functions can be continued * to an equality on C_inf_ab (the functions that are * infinitely-times differentiable). *) Program Instance C_inf_ab_eq : Equiv C_inf_ab := (fun f g => sq (Feq (Compact (less_leEq _ _ _ Hab)) (f_crr f) (f_crr g))). (** * The addition in C_inf_ab is associative. This is * represented here using a type class instance. *) Instance C_inf_ab_associative : @Associative C_inf_ab (C_inf_ab_eq) C_inf_ab_plus. unfold Associative. intros. unfold C_inf_ab_plus. red. unfold C_inf_ab_eq. apply insq. simpl. FEQ. apply included_FPlus. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct z. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. apply included_FPlus. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct z. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. Qed. (** * The addition we defined on C_inf_ab is a morphism * with respect to our equality. *) Instance C_inf_ab_proper : Proper (C_inf_ab_eq ==> C_inf_ab_eq ==> C_inf_ab_eq) C_inf_ab_plus. unfold Proper. unfold respectful. intros. red in H. apply unsq in H. red in H0. apply unsq in H0. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_plus. simpl. apply Feq_plus. exact H. exact H0. Qed. (** * Short proof that the equality we defined is also an * equivalence. *) Instance C_inf_ab_equivalence : Equivalence C_inf_ab_eq. assert (Reflexive C_inf_ab_eq). unfold Reflexive. intros. unfold C_inf_ab_eq. apply insq. apply Feq_reflexive. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (Symmetric C_inf_ab_eq). unfold Symmetric. intros. unfold C_inf_ab_eq in H0. apply unsq in H0. unfold C_inf_ab_eq. apply insq. apply Feq_symmetric. exact H0. assert (Transitive C_inf_ab_eq). unfold Transitive. intros. unfold C_inf_ab_eq in H1, H2. apply unsq in H1; apply unsq in H2. unfold C_inf_ab_eq; apply insq. apply Feq_transitive with (f_crr y). exact H1. exact H2. apply (Build_Equivalence C_inf_ab (C_inf_ab_eq) H H0 H1). Qed. (** * This makes the infinitely differentiable functions on * [a,b] a semigroup with respect to functional addition. *) Instance C_inf_ab_semigroup : @SemiGroup C_inf_ab C_inf_ab_eq C_inf_ab_plus. (** * An n-times differentiable function can be multiplied with * an arbitrary constant. *) Lemma Diffble_I_n_const : forall (n : nat) (c : IR), Diffble_I_n Hab n (Fconst c). Proof. intro n. induction n. intro c. simpl. unfold included. auto. intro c. simpl. assert (Diffble_I Hab [-C-] c). apply Diffble_I_const. exists X. destruct X. simpl. assert (Derivative_I Hab [-C-]c [-C-]Zero). apply Derivative_I_const. apply Diffble_I_n_wd with ([-C-]Zero). apply Derivative_I_unique with ([-C-]c). exact X. exact d. apply IHn. Qed. (** * The constant zero function is a neutral element in * the definition of C_inf_ab as a monoid under addition. *) Instance C_inf_ab_mon_unit : @MonoidUnit C_inf_ab := (Build_C_inf_ab (Fconst Zero) _). intros. apply Diffble_I_n_const. Defined. (** * The infinitely-differentiable functions on [a,b] are * a monoid under addition. *) Instance C_inf_ab_monoid : @Monoid C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mon_unit. assert (forall x, C_inf_ab_plus C_inf_ab_mon_unit x == x). intros. unfold C_inf_ab_mon_unit. red. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_plus. simpl. FEQ. apply included_FPlus. simpl. unfold included. auto. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (forall x, C_inf_ab_plus x C_inf_ab_mon_unit == x). intros. unfold C_inf_ab_mon_unit. red. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_plus. simpl. FEQ. apply included_FPlus. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. simpl. unfold included. auto. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_Monoid C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_semigroup H H0). Qed. (** * If a function is n-times differentiable, its functional * inverse also has this property. To prove this, we first * need an exact representation of the nth derivative. *) Lemma Derivative_I_n_inv : forall (n : nat) (f f' : PartFunct IR), Derivative_I_n Hab n f f' -> Derivative_I_n Hab n (Finv f) (Finv f'). Proof. intro. induction n. intros. simpl. simpl in X. apply Feq_inv. exact X. intros. simpl. destruct X. exists (IInv x). apply Derivative_I_wdr with (Finv (PartInt x)). apply part_int_inv. apply Feq_reflexive. apply derivative_imp_inc' with f. exact d. apply Derivative_I_inv. exact d. apply Derivative_I_n_wdl with (Finv (PartInt x)). apply part_int_inv. apply Feq_reflexive. apply derivative_imp_inc' with f. exact d. apply IHn. exact d0. Qed. (** * This is a small lemma to get from the nth derivative to * the n-times differentiability of the functional inverse. *) Lemma Diffble_I_n_inv : forall (n : nat) (f : PartFunct IR), Diffble_I_n Hab n f -> Diffble_I_n Hab n (Finv f). Proof. intros. assert ({f0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab n f (PartInt f0')}). apply Diffble_I_n_imp_deriv_n. exact X. elim X0. intros. apply deriv_n_imp_Diffble_I_n with (Finv (PartInt x)). apply Derivative_I_n_inv. exact p. Qed. (** * Type class instance to define the inverse on C_inf_ab * as a group inversion operation. *) Program Instance C_inf_ab_inv : GroupInv C_inf_ab := (fun f => Build_C_inf_ab (Finv (f_crr f)) _). Next Obligation. apply Diffble_I_n_inv. destruct f. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply f_pdf0. Defined. (** * This inversion operation on C_inf_ab is a morphism with * respect to the equality as previously defined on C_inf_ab. *) Instance C_inf_ab_proper_inv : Proper (C_inf_ab_eq ==> C_inf_ab_eq) C_inf_ab_inv. intros. unfold Proper. unfold respectful. intros. red. apply insq. unfold C_inf_ab_inv. simpl. apply Feq_inv. apply unsq. inversion H. apply insq. exact X. Qed. (** * The infinitely-differentiable functions on [a,b] form * a group with respect to addition, inversion and the * constant zero function. *) Instance C_inf_ab_group : @Group C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_inv. assert (forall x, C_inf_ab_plus (C_inf_ab_inv x) x == C_inf_ab_mon_unit). intros. red. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_plus. unfold C_inf_ab_inv. simpl. FEQ. apply included_FPlus. apply included_FInv. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (forall x, C_inf_ab_plus x (C_inf_ab_inv x) == C_inf_ab_mon_unit). intros. red. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_plus. unfold C_inf_ab_inv. simpl. FEQ. apply included_FPlus. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FInv. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_Group C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_inv C_inf_ab_monoid C_inf_ab_proper_inv H H0). Qed. (** * The addition operator we defined is commutative, * resulting in an Abelian group for C_inf_ab. *) Instance C_inf_ab_abgroup : @AbGroup C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_inv. assert (Commutative C_inf_ab_plus). unfold Commutative. intros. unfold C_inf_ab_plus. red. unfold C_inf_ab_eq. apply insq. simpl. FEQ. apply included_FPlus. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_AbGroup C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_inv C_inf_ab_group H). Qed. (** * If f' is the nth derivative if f, it is immediate that * c*f' is the nth derivative of c*f. *) Lemma Derivative_I_n_cmul : forall (n : nat) (f f' : PartFunct IR) (c : IR), Derivative_I_n Hab n f f' -> Derivative_I_n Hab n (c{**}f) (c{**}f'). Proof. intro n. induction n. intros. simpl. simpl in X. unfold Fscalmult. apply Feq_mult. apply Feq_reflexive. unfold included. simpl. auto. exact X. intros. simpl. destruct X. exists (IMult (IConst c) x). apply Derivative_I_wdr with ((Fconst c) {*} PartInt x). apply part_int_mult. apply part_int_const. apply Feq_reflexive. apply derivative_imp_inc' with f. exact d. apply Derivative_I_scal. exact d. apply Derivative_I_n_wdl with ((Fconst c) {*} PartInt x). apply part_int_mult. apply part_int_const. apply Feq_reflexive. apply derivative_imp_inc' with f. exact d. apply IHn. exact d0. Qed. (** * Because of the previous lemma, it is only a small step to * the n-times differentiability of constant-multiplication. *) Lemma Diffble_I_n_cmul : forall (n : nat) (f : PartFunct IR) (c : IR), Diffble_I_n Hab n f -> Diffble_I_n Hab n (c{**}f). Proof. intros. assert ({f0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab n f (PartInt f0')}). apply Diffble_I_n_imp_deriv_n. exact X. inversion_clear X0. apply deriv_n_imp_Diffble_I_n with (c{**}PartInt x). apply Derivative_I_n_cmul. exact X1. Qed. (** * Define the algebra-action (terminology from NAH) as an * operation on C_inf_ab using type class instances. *) Program Instance C_inf_ab_ralg_act : RalgebraAction IR C_inf_ab := (fun c f => Build_C_inf_ab (c {**} (f_crr f)) _). Next Obligation. apply Diffble_I_n_cmul. destruct f. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply f_pdf0. Defined. (** * Addition and multiplication on IR, as well as addition * on C_inf_ab can be used to prove that the infinitely- * differentiable functions on [a,b] are an R-module. *) Instance C_inf_ab_rmodule : @Rmodule IR (@st_eq IR) C_inf_ab C_inf_ab_eq C_inf_ab_ralg_act IR_plus IR_mult IR_inv IR_zero IR_one C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_inv. assert (forall (a b : C_inf_ab) (x : IR), C_inf_ab_ralg_act x (C_inf_ab_plus a b) == C_inf_ab_plus (C_inf_ab_ralg_act x a) (C_inf_ab_ralg_act x b)). intros. unfold C_inf_ab_ralg_act. unfold C_inf_ab_plus. simpl. red. unfold C_inf_ab_eq. apply insq. simpl. FEQ. apply included_FMult. unfold included; simpl. auto. apply included_FPlus. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. unfold included; simpl; auto. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (forall (a : C_inf_ab) (x y : IR), C_inf_ab_ralg_act (x [+] y) a == C_inf_ab_plus (C_inf_ab_ralg_act x a) (C_inf_ab_ralg_act y a)). intros. unfold C_inf_ab_ralg_act, C_inf_ab_plus. simpl. red. unfold C_inf_ab_eq. apply insq. simpl. FEQ. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (forall (a : C_inf_ab) (x y : IR), C_inf_ab_ralg_act (x [*] y) a == C_inf_ab_ralg_act x (C_inf_ab_ralg_act y a)). intros. unfold C_inf_ab_ralg_act; simpl. red; unfold C_inf_ab_eq; simpl. apply insq; FEQ. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. unfold included; simpl; auto. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_Rmodule IR (@st_eq IR) C_inf_ab C_inf_ab_eq C_inf_ab_ralg_act IR_plus IR_mult IR_inv IR_zero IR_one C_inf_ab_plus C_inf_ab_mon_unit C_inf_ab_inv IR_ring C_inf_ab_abgroup H H0 H1). Qed. (** * The property of n-times differentiability is preserved * under multiplication. *) Lemma Diffble_I_n_mult : forall (n : nat) (f g : PartFunct IR) (Pfdf : Diffble_I_n Hab n f) (Pgdf : Diffble_I_n Hab n g), Diffble_I_n Hab n (Fmult f g). Proof. intro n. induction n. intros. simpl. apply included_conj. simpl in Pfdf. exact Pfdf. simpl in Pgdf. exact Pgdf. intros. simpl. elim Pfdf. intros. inversion x. elim Pgdf. intros. inversion x1. assert (included (Compact (less_leEq _ _ _ Hab)) (Dom f)). apply derivative_imp_inc with (PartInt x0). exact X. assert (included (Compact (less_leEq _ _ _ Hab)) (Dom g)). apply derivative_imp_inc with (PartInt x2). exact X0. assert (Diffble_I Hab (f{*}g)). apply Diffble_I_mult. exact x. exact x1. exists X3. destruct X3. simpl. assert (Derivative_I Hab (f{*}g) ((f{*}PartInt x2){+}(PartInt x0{*}g))). apply Derivative_I_mult. exact X. exact X0. apply Diffble_I_n_wd with (f{*}PartInt x2{+}PartInt x0{*}g). apply Derivative_I_unique with (f{*}g). exact X3. exact d. apply Diffble_I_n_plus. apply IHn. apply le_imp_Diffble_I with (S n). omega. exact Pfdf. destruct x1. simpl in p0. apply Diffble_I_n_wd with (PartInt x1). apply Derivative_I_unique with g. exact d0. exact X0. exact p0. apply IHn. destruct x. simpl in p. apply Diffble_I_n_wd with (PartInt x). apply Derivative_I_unique with f. exact d0. exact X. exact p. apply le_imp_Diffble_I with (S n). omega. exact Pgdf. Qed. (** * Using the previous lemma, we can come up with a * straightforward (but lengthy) proof about the * n-times differentiability of functional division. *) Lemma Diffble_I_n_div : forall (n : nat) (f g : PartFunct IR) (Pfdf : Diffble_I_n Hab n f) (Pgdf : Diffble_I_n Hab n g) (Pbnd : bnd_away_zero (Compact (less_leEq _ _ _ Hab)) g), Diffble_I_n Hab n (Fdiv f g). Proof. intro n. induction n. intros f0 g Hf0 Hg Hbnd. simpl. unfold included. intros. red. split. simpl in Hf0. unfold included in Hf0. apply Hf0. exact H. red. split. simpl in Hg. unfold included in Hg. apply Hg. exact H. intros. elim Hbnd. intros. elim b0. intros. apply AbsIR_cancel_ap_zero. apply pos_ap_zero. apply less_leEq_trans with x0. exact p. apply q. exact H. intros. simpl. simpl in Pfdf. inversion Pfdf. inversion x. simpl in Pgdf. inversion Pgdf. inversion x1. assert (Derivative_I Hab (f{/}g) (((PartInt x0){*}g{-}f{*}(PartInt x2)){/} (g{*}g))). apply Derivative_I_div. exact X0. exact X2. exact Pbnd. assert (Diffble_I Hab (f{/}g)). apply deriv_imp_Diffble_I with ((PartInt x0{*}g{-}f{*}PartInt x2){/}g{*}g). exact X3. exists X4. destruct X4. simpl. apply Diffble_I_n_wd with ((PartInt x0{*}g{-}f{*}PartInt x2){/}g{*}g). apply Derivative_I_unique with (f{/}g). exact X3. exact d. apply IHn. apply Diffble_I_n_minus. apply Diffble_I_n_mult. replace n with (pred (S n)) by omega. apply Diffble_I_imp_le with f. omega. simpl. exists x. exact X. exact X0. apply le_imp_Diffble_I with (S n). omega. simpl. exact Pgdf. apply Diffble_I_n_mult. apply le_imp_Diffble_I with (S n). omega. simpl. exact Pfdf. replace n with (pred (S n)) by omega. apply Diffble_I_imp_le with g. omega. simpl. exact Pgdf. exact X2. apply Diffble_I_n_mult. apply le_imp_Diffble_I with (S n). omega. simpl. exact Pgdf. apply le_imp_Diffble_I with (S n). omega. simpl. exact Pgdf. unfold bnd_away_zero. split. apply included_FMult. apply Diffble_I_n_imp_inc with (S n). simpl. exact Pgdf. apply Diffble_I_n_imp_inc with (S n). simpl. exact Pgdf. unfold bnd_away_zero in Pbnd. inversion Pbnd. inversion X5. exists (x4[*]x4). apply mult_resp_pos. exact X6. exact X6. intros. rewrite AbsIR_resp_mult. apply mult_resp_leEq_both. algebra. algebra. apply H. exact H0. apply H. exact H0. Qed. (** * We are now able to create a type class instance of * multiplication on C_inf_ab as a semi-group operation. *) Program Instance C_inf_ab_mult : SemiGroupOp C_inf_ab := (fun f g => Build_C_inf_ab (@Fmult IR (f_crr f) (f_crr g)) _ ). Next Obligation. apply Diffble_I_n_mult. destruct f. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply f_pdf0. destruct g. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply f_pdf0. Qed. (** * Multiplication on C_inf_ab is associative. *) Instance C_inf_ab_associative_mult : @Associative C_inf_ab (C_inf_ab_eq) C_inf_ab_mult. unfold Associative. intros. unfold C_inf_ab_mult; simpl. red; unfold C_inf_ab_eq. apply insq; simpl. FEQ. apply included_FMult. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct z. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. apply included_FMult. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct z. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. Qed. (** * Multiplication on C_inf_ab is a morphism with respect * to the equality we previously defined. *) Instance C_inf_ab_proper_mult : Proper (C_inf_ab_eq ==> C_inf_ab_eq ==> C_inf_ab_eq) C_inf_ab_mult. unfold Proper. unfold respectful. intros. unfold C_inf_ab_eq, C_inf_ab_mult. apply insq; simpl. apply Feq_mult. apply unsq; inversion H. apply insq. exact X. apply unsq; inversion H0. apply insq. exact X. Qed. (** * The type class instance of C_inf_ab as a semigroup * under multiplication. *) Instance C_inf_ab_semigroup_mult : @SemiGroup C_inf_ab C_inf_ab_eq C_inf_ab_mult. (** * The constant function one is a neutral element in the * multiplication of C_inf_ab. *) Instance C_inf_ab_mon_unit_mult : @MonoidUnit C_inf_ab := (Build_C_inf_ab (Fconst One) _). intros. apply Diffble_I_n_const. Defined. (** * C_inf_ab is a monoid under multiplication with * the constant function one as unit element. *) Instance C_inf_ab_monoid_mult : @Monoid C_inf_ab C_inf_ab_eq C_inf_ab_mult C_inf_ab_mon_unit_mult. assert (forall x, C_inf_ab_mult C_inf_ab_mon_unit_mult x == x). intros. unfold C_inf_ab_mon_unit_mult. red. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_mult. simpl. FEQ. apply included_FMult. simpl. unfold included. auto. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (forall x, C_inf_ab_mult x C_inf_ab_mon_unit_mult == x). intros. unfold C_inf_ab_mon_unit_mult. red. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_mult. simpl. FEQ. apply included_FMult. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. simpl. unfold included. auto. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_Monoid C_inf_ab C_inf_ab_eq C_inf_ab_mult C_inf_ab_mon_unit_mult C_inf_ab_semigroup_mult H H0). Qed. (** * C_inf_ab is a ring with respect to its addition and * multiplication operators. *) Instance C_inf_ab_ring : @Ring C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mult C_inf_ab_inv C_inf_ab_mon_unit C_inf_ab_mon_unit_mult. assert (Commutative C_inf_ab_mult). unfold Commutative. intros; red. unfold C_inf_ab_mult, C_inf_ab_eq. apply insq; simpl. FEQ. apply included_FMult. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. destruct y. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct x. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (Distribute C_inf_ab_mult C_inf_ab_plus). assert (forall a b c, C_inf_ab_mult a (C_inf_ab_plus b c) == C_inf_ab_plus (C_inf_ab_mult a b) (C_inf_ab_mult a c)). intros. unfold C_inf_ab_mult, C_inf_ab_plus; red; simpl. unfold C_inf_ab_eq; simpl; apply insq; FEQ. apply included_FMult. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct c. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. apply included_FMult. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct c. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. assert (forall a b c, C_inf_ab_mult (C_inf_ab_plus a b) c == C_inf_ab_plus (C_inf_ab_mult a c) (C_inf_ab_mult b c)). intros. unfold C_inf_ab_mult, C_inf_ab_plus; simpl; red. unfold C_inf_ab_eq; simpl; apply insq; FEQ. apply included_FMult. apply included_FPlus. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct c. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FPlus. apply included_FMult. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct c. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct c. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_Distribute C_inf_ab C_inf_ab_eq C_inf_ab_mult C_inf_ab_plus H0 H1). apply (Build_Ring C_inf_ab C_inf_ab_eq C_inf_ab_plus C_inf_ab_mult C_inf_ab_inv C_inf_ab_mon_unit C_inf_ab_mon_unit_mult C_inf_ab_abgroup C_inf_ab_monoid_mult H H0). Qed. (** * Together with the operations in IR, we may use the * addition and multiplication in C_inf_ab to define * and R-algebra for the infinitely-differentiable functions. *) Instance C_inf_ab_ralgebra : @Ralgebra IR (@st_eq IR) C_inf_ab C_inf_ab_eq C_inf_ab_ralg_act IR_plus IR_mult IR_inv IR_zero IR_one C_inf_ab_plus C_inf_ab_mult C_inf_ab_mon_unit C_inf_ab_mon_unit_mult C_inf_ab_inv. assert (forall (a b : C_inf_ab) (x : IR), C_inf_ab_ralg_act x (C_inf_ab_mult a b) == C_inf_ab_mult (C_inf_ab_ralg_act x a) b). intros. unfold C_inf_ab_ralg_act, C_inf_ab_mult; red. unfold C_inf_ab_eq; simpl. apply insq; FEQ. apply included_FMult. unfold included; simpl; auto. apply included_FMult. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply included_FMult. apply included_FMult. unfold included; simpl; auto. destruct a0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. destruct b0. replace (f_crr (Build_C_inf_ab f_crr0 f_pdf0)) with f_crr0 by auto. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply (Build_Ralgebra IR (@st_eq IR) C_inf_ab C_inf_ab_eq C_inf_ab_ralg_act IR_plus IR_mult IR_inv IR_zero IR_one C_inf_ab_plus C_inf_ab_mult C_inf_ab_mon_unit C_inf_ab_mon_unit_mult C_inf_ab_inv C_inf_ab_rmodule C_inf_ab_ring H). Qed. (** * This is the definition of the abstract property of * derivation on an R-algebra. *) Definition is_derivation `(Ralgebra Scalar Elem) (D : Elem -> Elem) : Prop. repeat intro. exact ( (forall (a b : Elem), e' (elem_plus (D a) (D b)) (D (elem_plus a b))) and (forall (a : Elem) (c : Scalar), e' (H c (D a)) (D (H c a))) and (forall (a b : Elem), e' (D (elem_mult a b)) (elem_plus (elem_mult a (D b)) (elem_mult (D a) b)))). Defined. (** * Define the derivative of a function in C_inf_ab as a * directly-callable operation. That is, the result of * the expression is the required derivative. *) Definition deriv_I_C_inf (f : C_inf_ab) : C_inf_ab. intro. destruct f. assert (Diffble_I_n Hab 1 f_crr0). apply f_pdf0. set (n_deriv_I a b Hab 1 f_crr0 X). assert (forall n, Diffble_I_n Hab n p). intro n. replace n with (pred (S n)) by omega. apply Diffble_I_imp_le with f_crr0. omega. apply f_pdf0. assert (Diffble_I_n Hab 0 f_crr0). simpl. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply Derivative_I_wdl with (n_deriv_I a b Hab 0 f_crr0 X0). simpl. apply Feq_symmetric. apply FRestr_wd. apply n_Sn_deriv. exact (Build_C_inf_ab p X0). Defined. (** * This corresponds to proposition 25 in the PDF as sent to * me on january 11th. We prove that the derivation operator * deriv_I_C_inf on C_inf_ab is a derivation with respect * to the R_algebra we defined on C_inf_ab. * * TODO: This proof can be made shorter *) Lemma lem18 : is_derivation C_inf_ab_ralgebra deriv_I_C_inf. Proof. unfold is_derivation. split. intros. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_plus. destruct a0. destruct b0. assert (forall x y, f_crr (Build_C_inf_ab x y) = x). intros. auto. rewrite H. assert (f_crr (deriv_I_C_inf (Build_C_inf_ab f_crr0 f_pdf0)) = n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)). auto. rewrite H0. assert (f_crr (deriv_I_C_inf (Build_C_inf_ab f_crr1 f_pdf1)) = n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1)). auto. rewrite H1. assert (f_crr (deriv_I_C_inf (Build_C_inf_ab (f_crr (Build_C_inf_ab f_crr0 f_pdf0){+} f_crr (Build_C_inf_ab f_crr1 f_pdf1)) (C_inf_ab_plus_obligation_1 (Build_C_inf_ab f_crr0 f_pdf0) (Build_C_inf_ab f_crr1 f_pdf1)))) = n_deriv_I a b Hab 1 (f_crr0{+}f_crr1) (C_inf_ab_plus_obligation_1 (Build_C_inf_ab f_crr0 f_pdf0) (Build_C_inf_ab f_crr1 f_pdf1) 1)). auto. rewrite H2. clear H H0 H1 H2. apply Feq_transitive with (n_deriv_I a b Hab 1 (f_crr0{+}f_crr1) (Diffble_I_n_plus 1 f_crr0 f_crr1 (f_pdf0 1) (f_pdf1 1))). assert ({f_crr0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab 1 f_crr0 (PartInt f_crr0')}). apply Diffble_I_n_imp_deriv_n. apply f_pdf0. inversion_clear X. assert (Derivative_I_n Hab 1 f_crr0 (n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1))). apply n_deriv_lemma. assert (Feq (Compact (less_leEq IR a b Hab)) (PartInt x) (n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1))). apply (Derivative_I_n_unique a b Hab 1 f_crr0). exact X0. exact X. assert ({f_crr1' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab 1 f_crr1 (PartInt f_crr1')}). apply Diffble_I_n_imp_deriv_n. apply f_pdf1. inversion_clear X2. assert (Derivative_I_n Hab 1 f_crr1 (n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1))). apply n_deriv_lemma. assert (Feq (Compact (less_leEq IR a b Hab)) (PartInt x0) (n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1))). apply (Derivative_I_n_unique a b Hab 1 f_crr1). exact X3. exact X2. assert (Feq (Compact (less_leEq IR a b Hab)) (PartInt x{+}PartInt x0) ((n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)){+} (n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1)))). apply Feq_plus. exact X1. exact X4. apply Feq_transitive with (PartInt x{+}PartInt x0). apply Feq_plus. apply Feq_symmetric; exact X1. apply Feq_symmetric; exact X4. assert (Derivative_I_n Hab 1 (f_crr0{+}f_crr1) (PartInt x{+}PartInt x0)). apply Derivative_I_n_add. exact X0. exact X3. assert (Derivative_I_n Hab 1 (f_crr0{+}f_crr1) ((n_deriv_I a b Hab 1 (f_crr0{+}f_crr1) (Diffble_I_n_plus 1 f_crr0 f_crr1 (f_pdf0 1) (f_pdf1 1))))). apply n_deriv_lemma. apply (Derivative_I_n_unique a b Hab 1 (f_crr0{+}f_crr1)). exact X6. exact X7. apply n_deriv_I_wd. apply Feq_plus. apply Feq_reflexive. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. apply Feq_reflexive. apply Diffble_I_n_imp_inc with 42. apply f_pdf1. split. intros. unfold C_inf_ab_eq. apply insq. unfold C_inf_ab_ralg_act. assert (forall x y, f_crr (Build_C_inf_ab x y) = x) by auto. rewrite H. destruct a0. assert (f_crr (deriv_I_C_inf (Build_C_inf_ab f_crr0 f_pdf0)) = n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)). auto. rewrite H0. assert ( f_crr (deriv_I_C_inf (Build_C_inf_ab (c{**}f_crr (Build_C_inf_ab f_crr0 f_pdf0)) (C_inf_ab_ralg_act_obligation_1 c (Build_C_inf_ab f_crr0 f_pdf0)))) = n_deriv_I a b Hab 1 (c{**}f_crr0) (C_inf_ab_ralg_act_obligation_1 c (Build_C_inf_ab f_crr0 f_pdf0) 1)). auto. rewrite H1. clear H H0 H1. apply Feq_transitive with (n_deriv_I a b Hab 1 (c{**}f_crr0) (Diffble_I_n_cmul 1 f_crr0 c (f_pdf0 1))). assert ({f_crr0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab 1 f_crr0 (PartInt f_crr0')}). apply Diffble_I_n_imp_deriv_n. apply f_pdf0. inversion_clear X. assert (Derivative_I_n Hab 1 f_crr0 (n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1))). apply n_deriv_lemma. assert (Feq (Compact (less_leEq IR a b Hab)) (PartInt x) (n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1))). apply (Derivative_I_n_unique a b Hab 1 f_crr0). exact X0. exact X. assert (Derivative_I_n Hab 1 (c{**}f_crr0) (c{**}PartInt x)). apply Derivative_I_n_cmul. exact X0. assert (Derivative_I_n Hab 1 (c{**}f_crr0) ((n_deriv_I a b Hab 1 (c{**}f_crr0) (Diffble_I_n_cmul 1 f_crr0 c (f_pdf0 1))))). apply n_deriv_lemma. apply Feq_transitive with (c{**}PartInt x). unfold Fscalmult. apply Feq_mult. apply Feq_reflexive. unfold included; simpl; auto. apply Feq_symmetric. exact X1. assert (Derivative_I_n Hab 1 (c{**}f_crr0) (c{**}(n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)))). apply Derivative_I_n_cmul. apply n_deriv_lemma. assert (Derivative_I_n Hab 1 (c{**}f_crr0) (c{**}PartInt x)). apply Derivative_I_n_cmul. exact X0. apply Feq_transitive with (c{**}n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)). unfold Fscalmult. apply Feq_mult. apply Feq_reflexive. unfold included; simpl; auto. exact X1. apply Feq_transitive with (c{**}PartInt x). apply (Derivative_I_n_unique a b Hab 1 (c{**}f_crr0)). exact X4. exact X2. apply Feq_transitive with (c{**}n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)). unfold Fscalmult. apply Feq_mult. apply Feq_reflexive. unfold included; simpl; auto. exact X1. apply (Derivative_I_n_unique a b Hab 1 (c{**}f_crr0)). exact X4. exact X3. apply n_deriv_I_wd. unfold Fscalmult. apply Feq_mult. apply Feq_reflexive. unfold included; simpl; auto. apply Feq_reflexive. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. intros. unfold C_inf_ab_eq. apply insq. destruct a0. destruct b0. unfold C_inf_ab_mult, C_inf_ab_plus. set (f_crr (Build_C_inf_ab f_crr0 f_pdf0)). set (f_crr (Build_C_inf_ab f_crr1 f_pdf1)). set (deriv_I_C_inf (Build_C_inf_ab f_crr0 f_pdf0)). set (deriv_I_C_inf (Build_C_inf_ab f_crr1 f_pdf1)). set (Build_C_inf_ab f_crr0 f_pdf0). set (Build_C_inf_ab f_crr1 f_pdf1). replace (f_crr (deriv_I_C_inf (Build_C_inf_ab (p{*}p0) (C_inf_ab_mult_obligation_1 c1 c2)))) with (n_deriv_I a b Hab 1 (p{*}p0) (C_inf_ab_mult_obligation_1 c1 c2 1)) by auto. replace (f_crr (Build_C_inf_ab (f_crr (Build_C_inf_ab (p{*}f_crr c0) (C_inf_ab_mult_obligation_1 c1 c0)){+} f_crr (Build_C_inf_ab (f_crr c{*}p0) (C_inf_ab_mult_obligation_1 c c2))) (C_inf_ab_plus_obligation_1 (Build_C_inf_ab (p{*}f_crr c0) (C_inf_ab_mult_obligation_1 c1 c0)) (Build_C_inf_ab (f_crr c{*}p0) (C_inf_ab_mult_obligation_1 c c2))))) with (f_crr (Build_C_inf_ab (p{*}f_crr c0) (C_inf_ab_mult_obligation_1 c1 c0)){+} f_crr (Build_C_inf_ab (f_crr c{*}p0) (C_inf_ab_mult_obligation_1 c c2))) by auto. replace (f_crr ((Build_C_inf_ab (f_crr c{*}p0) (C_inf_ab_mult_obligation_1 c c2)))) with (f_crr c{*}p0) by auto. replace (f_crr (Build_C_inf_ab (p{*}f_crr c0) (C_inf_ab_mult_obligation_1 c1 c0))) with (p{*}f_crr c0) by auto. assert (Derivative_I_n Hab 1 (p{*}p0) (n_deriv_I a b Hab 1 (p{*}p0) (C_inf_ab_mult_obligation_1 c1 c2 1))). apply n_deriv_lemma. assert ({f_crr0' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab 1 f_crr0 (PartInt f_crr0')}). apply Diffble_I_n_imp_deriv_n. apply f_pdf0. inversion_clear X0. assert ({f_crr1' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I_n Hab 1 f_crr1 (PartInt f_crr1')}). apply Diffble_I_n_imp_deriv_n. apply f_pdf1. inversion_clear X0. assert (Derivative_I_n Hab 1 (p{*}p0) (f_crr0{*}PartInt x0{+}PartInt x{*}f_crr1)). simpl. assert (included (Compact (less_leEq _ _ _ Hab)) (Dom (f_crr0{*}PartInt x0{+}PartInt x{*}f_crr1))). apply included_FPlus. apply included_FMult. apply (Derivative_I_n_imp_inc a b Hab 1 f_crr0 (PartInt x)). exact X1. apply (Derivative_I_n_imp_inc' a b Hab 1 f_crr1 (PartInt x0)). exact X2. apply included_FMult. apply (Derivative_I_n_imp_inc' a b Hab 1 f_crr0 (PartInt x)). exact X1. apply (Derivative_I_n_imp_inc a b Hab 1 f_crr1 (PartInt x0)). exact X2. exists (@IntPartIR (f_crr0{*}PartInt x0{+}PartInt x{*}f_crr1) a b (less_leEq _ _ _ Hab) X0). apply Derivative_I_wdr with (f_crr0{*}PartInt x0{+}PartInt x{*}f_crr1). apply int_part_int. replace p with f_crr0 by auto. replace p0 with f_crr1 by auto. apply Derivative_I_mult. simpl in X1. inversion_clear X1. apply Derivative_I_wdr with (PartInt x1). exact X4. exact X3. simpl in X2. inversion_clear X2. apply Derivative_I_wdr with (PartInt x1). exact X4. exact X3. apply Feq_symmetric. apply int_part_int. apply Feq_transitive with (p{*}f_crr c0{+}f_crr c{*}p0). apply (Derivative_I_n_unique a b Hab 1 (p{*}p0)). exact X. replace p with f_crr0 by auto. replace p0 with f_crr1 by auto. replace (f_crr c0) with (n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1)) by auto. replace (f_crr c) with (n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)) by auto. replace p with f_crr0 in X0 by auto. replace p0 with f_crr1 in X0 by auto. apply Derivative_I_n_wdr with (f_crr0{*}PartInt x0{+}PartInt x{*}f_crr1). apply Feq_plus. apply Feq_mult. apply Feq_reflexive. apply (Derivative_I_n_imp_inc a b Hab 1 f_crr0 (PartInt x)). exact X1. assert (Derivative_I_n Hab 1 f_crr1 (n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1))). apply n_deriv_lemma. apply (Derivative_I_n_unique a b Hab 1 f_crr1). exact X2. apply n_deriv_lemma. apply Feq_mult. apply (Derivative_I_n_unique a b Hab 1 f_crr0). exact X1. apply n_deriv_lemma. apply Feq_reflexive. apply (Derivative_I_n_imp_inc a b Hab 1 f_crr1 (PartInt x0)). exact X2. exact X0. apply Feq_reflexive. apply included_FPlus. apply included_FMult. replace p with f_crr0 by auto. apply (Derivative_I_n_imp_inc a b Hab 1 f_crr0 (PartInt x)). exact X1. replace (f_crr c0) with (n_deriv_I a b Hab 1 f_crr1 (f_pdf1 1)) by auto. apply n_deriv_inc. apply included_FMult. replace (f_crr c) with (n_deriv_I a b Hab 1 f_crr0 (f_pdf0 1)) by auto. apply n_deriv_inc. replace p0 with f_crr1 by auto. apply (Derivative_I_n_imp_inc a b Hab 1 f_crr1 (PartInt x0)). exact X2. Qed. End Derivations. (** * This section contains lemmas and definitions about the * function L. Note that the order in which things appear * in the proof differs from the order in the paper because * the proof is still based on a previous version of the * paper. *) Section Lfunct. Variables a b c d : IR. Hypothesis Hab : a [<] b. Hypothesis Hcd : c [<] d. Hypothesis Hac : a [<=] c. Hypothesis Hdb : d [<=] b. (** * TODO: This lemma is unneccesary. *) Lemma ab_diff : b [-] a [#] Zero. Proof. apply minus_ap_zero. apply Greater_imp_ap. exact Hab. Qed. (** * We don't define L_inner as a direct lambda-expression * but instead as a composition of functions because this * enhances the usage of this definition in the proof. *) Definition L_inner := Fplus (Fconst c) (Fmult (Fminus (Fconst d) (Fconst c)) (Fdiv (Fminus (Fid IR) (Fconst a)) (Fminus (Fconst b) (Fconst a)))). Definition L_func (f : C_inf_ab c d Hcd) := Fcomp (f_crr c d Hcd f) L_inner. (** * Prove that the function L is n-times differentiable for * each n. This effectively proves that the function L * belongs to the class C_inf_ab. *) Lemma L_diffble : forall (n : nat) (f : C_inf_ab c d Hcd), Diffble_I_n Hab n (L_func f). Proof. intro n. induction n. intro f0. unfold L_func. simpl. unfold included. intros. assert (Conj (fun _ : IR => True) (Conj (Conj (fun _ : IR => True) (fun _ : IR => True)) (Conj (Conj (fun _ : IR => True) (fun _ : IR => True)) (extend (Conj (fun _ : IR => True) (fun _ : IR => True)) (fun (x0 : IR) (_ : Conj (fun _ : IR => True) (fun _ : IR => True) x0) => b[-]a[#]Zero)))) x). unfold extend. red. split. auto. red. split. red. auto. red. split. red. auto. split. red. auto. intro. apply ab_diff. exists X. destruct f0. replace (f_crr c d Hcd (Build_C_inf_ab c d Hcd f_crr0 f_pdf0)) with f_crr0 by auto. destruct f_crr0. simpl. assert (included (Compact (less_leEq _ _ _ Hcd)) pfdom). assert (Diffble_I_n Hcd 0 (Build_PartFunct IR pfdom dom_wd pfpfun pfstrx)). apply f_pdf0. simpl in X0. exact X0. unfold included in X0. apply X0. red. split. red in H. rewrite <- cm_rht_unit_unfolded at 1. apply plus_resp_leEq_lft. rewrite <- (cring_mult_zero_op IR Zero). apply mult_resp_leEq_both. apply leEq_reflexive. apply leEq_reflexive. apply shift_leEq_lft. algebra. apply shift_leEq_div. apply shift_zero_less_minus. exact Hab. rewrite cring_mult_zero_op. apply shift_leEq_lft. inversion H. exact H0. apply shift_plus_leEq'. rewrite <- (mult_one IR (d[-]c)) at 2. apply mult_resp_leEq_both. apply shift_leEq_lft. algebra. apply shift_leEq_div. apply shift_zero_less_minus. exact Hab. rewrite cring_mult_zero_op. red in H. inversion H. apply shift_leEq_lft. exact H0. apply leEq_reflexive. apply shift_div_leEq. apply shift_zero_less_minus. exact Hab. rewrite mult_commutes. rewrite mult_one. apply minus_resp_leEq_both. red in H. inversion H. exact H1. apply leEq_reflexive. intro f0. simpl. assert (Derivative_I Hab L_inner ( ([-C-] Zero) {+} ( ([-C-] d {-} [-C-] c) {*} ( Fdiv ((([-C-] One) {*} ([-C-] b {-} [-C-] a)) {-} ((Fid IR {-} [-C-] a) {*} ([-C-] Zero))) (([-C-] b {-} [-C-] a) {*} ([-C-] b {-} [-C-] a)) ) {+} ([-C-] Zero) {*} ( Fdiv (Fid IR {-} [-C-] a) ([-C-] b {-} [-C-] a) ) ) )). unfold L_inner. apply Derivative_I_plus. apply Derivative_I_const. apply Derivative_I_mult. apply Derivative_I_wdr with ([-C-]Zero{-}[-C-]Zero). FEQ. apply Derivative_I_minus. apply Derivative_I_const. apply Derivative_I_const. apply Derivative_I_div. apply Derivative_I_wdr with ([-C-]One{-}[-C-]Zero). FEQ. apply Derivative_I_minus. apply Derivative_I_id. apply Derivative_I_const. apply Derivative_I_wdr with ([-C-]Zero{-}[-C-]Zero). FEQ. apply Derivative_I_minus. apply Derivative_I_const. apply Derivative_I_const. red. split. apply included_FMinus. unfold included; simpl; auto. unfold included; simpl; auto. exists (AbsIR (b[-]a)). apply AbsIR_pos. apply ab_diff. intros. simpl. apply leEq_reflexive. assert (Diffble_I Hcd (f_crr c d Hcd f0)). destruct f0; simpl. apply Diffble_I_n_imp_diffble with 42. omega. apply f_pdf0. destruct X0. assert (forall n, Diffble_I_n Hcd n (PartInt x)). intro n0. replace n0 with (pred (S n0)) by omega. apply Diffble_I_imp_le with (f_crr c d Hcd f0). omega. destruct f0. replace (f_crr c d Hcd (Build_C_inf_ab c d Hcd f_crr0 f_pdf0)) with f_crr0 by auto. apply f_pdf0. exact d0. assert (Derivative_I Hab (L_func f0) ((L_func (Build_C_inf_ab c d Hcd (PartInt x) X0)) {*} (([-C-]Zero{+} (([-C-]d{-}[-C-]c){*} (([-C-]One{*}([-C-]b{-}[-C-]a){-}(FId{-}[-C-]a){*}[-C-]Zero){/} ([-C-]b{-}[-C-]a){*}([-C-]b{-}[-C-]a)){+} [-C-]Zero{*}((FId{-}[-C-]a){/}([-C-]b{-}[-C-]a)))))) ). unfold L_func. apply (Derivative_I_comp _ _ _ _ _ _ _ c d Hcd). exact X. simpl. exact d0. unfold maps_into_compacts. split. destruct f0. simpl. apply Diffble_I_n_imp_inc with 42. apply f_pdf0. intros. red. split. unfold L_inner. simpl. rewrite <- cm_rht_unit_unfolded at 1. apply plus_resp_leEq_lft. rewrite <- (cring_mult_zero_op IR Zero). apply mult_resp_leEq_both. apply leEq_reflexive. apply leEq_reflexive. apply shift_leEq_lft. algebra. apply shift_leEq_div. apply shift_zero_less_minus. exact Hab. rewrite cring_mult_zero_op. apply shift_leEq_lft. inversion H. exact H0. unfold L_inner. simpl. apply shift_plus_leEq'. rewrite <- (mult_one IR (d[-]c)) at 2. apply mult_resp_leEq_both. apply shift_leEq_lft. algebra. apply shift_leEq_div. apply shift_zero_less_minus. exact Hab. rewrite cring_mult_zero_op. inversion H. apply shift_leEq_lft. exact H0. apply leEq_reflexive. apply shift_div_leEq. apply shift_zero_less_minus. exact Hab. rewrite mult_commutes. rewrite mult_one. apply minus_resp_leEq_both. inversion H. exact H1. apply leEq_reflexive. assert (Diffble_I Hab (L_func f0)). apply (deriv_imp_Diffble_I _ _ _ _ _ X1). exists X2. destruct X2. simpl. apply Diffble_I_n_wd with (L_func (Build_C_inf_ab c d Hcd (PartInt x) X0){*} ([-C-]Zero{+}(([-C-]d{-}[-C-]c){*} (([-C-]One{*}([-C-]b{-}[-C-]a){-}(FId{-}[-C-]a){*}[-C-]Zero){/} ([-C-]b{-}[-C-]a){*}([-C-]b{-}[-C-]a)){+} [-C-]Zero{*}((FId{-}[-C-]a){/}([-C-]b{-}[-C-]a))))). apply Derivative_I_unique with (L_func f0). exact X1. exact d1. apply Diffble_I_n_mult. apply IHn. apply Diffble_I_n_plus. apply Diffble_I_n_const. apply Diffble_I_n_plus. apply Diffble_I_n_mult. apply Diffble_I_n_minus. apply Diffble_I_n_const. apply Diffble_I_n_const. apply Diffble_I_n_div. apply Diffble_I_n_minus. apply Diffble_I_n_mult. apply Diffble_I_n_const. apply Diffble_I_n_minus. apply Diffble_I_n_const. apply Diffble_I_n_const. apply Diffble_I_n_wd with ([-C-] Zero). FEQ. apply Diffble_I_n_const. apply Diffble_I_n_mult. apply Diffble_I_n_minus. apply Diffble_I_n_const. apply Diffble_I_n_const. apply Diffble_I_n_minus. apply Diffble_I_n_const. apply Diffble_I_n_const. unfold bnd_away_zero. split. apply included_FMult. apply included_FMinus. unfold included; simpl; auto. unfold included; simpl; auto. apply included_FMinus. unfold included; simpl; auto. unfold included; simpl; auto. exists ((b[-]a)[*](b[-]a)). apply mult_resp_pos. apply shift_zero_less_minus. exact Hab. apply shift_zero_less_minus. exact Hab. intros. rewrite AbsIR_resp_mult. apply mult_resp_leEq_both. apply shift_zero_leEq_minus. algebra. apply shift_zero_leEq_minus. algebra. apply eq_imp_leEq. symmetry. apply AbsIR_eq_x. apply shift_zero_leEq_minus. algebra. apply eq_imp_leEq. symmetry. apply AbsIR_eq_x. algebra. apply Diffble_I_n_wd with ([-C-] Zero). apply eq_imp_Feq. unfold included; simpl; auto. apply included_FMult. unfold included; simpl; auto. apply included_FDiv. apply included_FMinus. unfold included; simpl; auto. unfold included; simpl; auto. apply included_FMinus. unfold included; simpl; auto. unfold included; simpl; auto. intros. simpl. apply pos_ap_zero. apply shift_zero_less_minus. exact Hab. intros. simpl. rewrite mult_commutes. rewrite cring_mult_zero. reflexivity. apply Diffble_I_n_const. Qed. Lemma L_diffble_all_n : forall (f : C_inf_ab c d Hcd) (n : nat), Diffble_I_n Hab n (L_func f). Proof. intros. apply L_diffble. Qed. (** * Define L as a member of the class C_inf_ab. *) Definition L (f : C_inf_ab c d Hcd) : (C_inf_ab a b Hab) := Build_C_inf_ab a b Hab (L_func f) (L_diffble_all_n f). End Lfunct. (** * The following section is vague at best. Various versions * of lemmas (e.g. continuity) are used. One of the main * improvements should be to make things more consistent. *) Section Integration. Require Import ProductMetric. Require Import CRIR. Require Import Integration. Require Import Qmetric. Require Import QposMinMax. Variable a b : CR. Hypothesis Hab : a [<] b. (** * Define equality on a sub-metricspace (a sub-metricspace * is a collection of elements from a metric space restricted * to certain property). *) Definition eqSubMS (X : MetricSpace) (P : X -> Prop) (a : {X | P X}) (b : {X | P X}) := (projT1 a) [=] (projT1 b). (** * Because a metric space is a setoid, it follows * automatically that a sub-metricspace is also a setoid. *) Definition setoidSubMS (X : MetricSpace) (P : X -> Prop) : Setoid. intros X P. assert (Reflexive (eqSubMS X P)). unfold Reflexive, eqSubMS. intro x. reflexivity. assert (Symmetric (eqSubMS X P)). unfold Symmetric, eqSubMS. intros x y H42. symmetry. exact H42. assert (Transitive (eqSubMS X P)). unfold Transitive, eqSubMS. intros x y z H37 H42. transitivity (projT1 y). exact H37. exact H42. apply (@Build_Setoid {X | P X} (eqSubMS X P) (Build_Equivalence {X | P X} (eqSubMS X P) H H0 H1)). Defined. (** * The usual definition of a ball can be used in a * sub-metricspace as well. *) Program Definition ballSubMS (X : MetricSpace) (P : X -> Prop) (x : Qpos) (a : {X | P X}) (b : {X | P X}) := (@ball X x a b). (** * The actual definition of sub-metricspace. * * TODO: Perhaps P should be directly dicidable (although * we axiomatized anything in Prop to be decidable using * sq and unsq). *) Definition SubMS (X : MetricSpace) (P : X -> Prop) : MetricSpace. intros X P. apply (@Build_MetricSpace (setoidSubMS X P) (ballSubMS X P)). intros e1 e2 H x1 x2 H0 y1 y2 H1. split. intro H2. unfold ballSubMS. unfold ballSubMS in H2. assert ((`x1) [=] (`x2)). destruct x1. destruct x2. auto. assert ((`y1) [=] (`y2)). destruct y1. destruct y2. auto. apply (ball_wd X H (`x1) (`x2) H3 (`y1) (`y2) H4). exact H2. intro H2. unfold ballSubMS. unfold ballSubMS in H2. assert ((`x1) [=] (`x2)). destruct x1. destruct x2. auto. assert ((`y1) [=] (`y2)). destruct y1. destruct y2. auto. apply (ball_wd X H (`x1) (`x2) H3 (`y1) (`y2) H4). exact H2. assert (forall e : Qpos, Reflexive (ballSubMS X P e)). intro e; unfold Reflexive. intro x; unfold ballSubMS. apply (msp_refl (msp X) e (`x)). assert (forall e : Qpos, Symmetric (ballSubMS X P e)). intro e; unfold Symmetric. intros x y H0; unfold ballSubMS; unfold ballSubMS in H0. apply (msp_sym (msp X) e (`x) (`y)). exact H0. assert (forall (e1 e2 : Qpos) (a b c : (setoidSubMS X P)), (ballSubMS X P e1 a b) -> (ballSubMS X P e2 b c) -> (ballSubMS X P ((e1 + e2)%Qpos) a c)). intros e1 e2 a0 b0 c H1 H2. unfold ballSubMS; unfold ballSubMS in H1; unfold ballSubMS in H2. apply (msp_triangle (msp X) _ _ _ (`b0)). exact H1. exact H2. assert (forall (e : Qpos) (a b : (setoidSubMS X P)), (forall d : Qpos, ballSubMS X P ((e + d)%Qpos) a b) -> ballSubMS X P e a b). intros e a0 b0 H2. unfold ballSubMS. apply (msp_closed (msp X)). exact H2. assert (forall a b : (setoidSubMS X P), (forall e : Qpos, ballSubMS X P e a b) -> a [=] b). intros a0 b0 H3. destruct a0. destruct b0. simpl. unfold eqSubMS. simpl. apply (msp_eq (msp X)). unfold ballSubMS in H3. simpl in H3. exact H3. apply (Build_is_MetricSpace (setoidSubMS X P) (ballSubMS X P) H H0 H1 H2 H3). Defined. (** * The abstract concept of nultiplication of a * MetricSpace (as in IR x IR etc). This results in * a product space (which is again a metric space). *) Fixpoint XpowM (X : MetricSpace) (m : nat) {struct m} : MetricSpace := match m with | 0 => X (* Should not be used *) | 1 => X | S n => ProductMS X (XpowM X n) end. (** * If an element is known to be inside a sub-metricspace, it * can also be typed as an element from the original metric * space. *) Definition unres (m : nat) (P : CR -> Prop) (X : XpowM (SubMS CR P) m) : XpowM CR m. intros m P x. induction m. simpl; simpl in x. inversion x. exact x0. destruct m. simpl. simpl in x. inversion x. exact x0. simpl. split. simpl in x. inversion x. inversion X. exact x0. apply IHm. simpl in x. inversion x. exact X0. Defined. (** * The definition of continuity according to the book of * Bishop. Please note that this definition does not use * the continuity-definitions from CoRN/ftc. * * TODO: Find a way to make continuity and differentiability * as consistent as possible throughout the proof. *) Definition Bcont (m : nat) (X : MetricSpace) (f : (XpowM CR m) -> X) := forall (a b : CR) (Hab : a [<] b) (g : (XpowM (SubMS CR (fun x => sq (a [<] x and x [<] b))) m) -> X), (forall x : (XpowM (SubMS CR (fun x => sq (a [<] x and x [<] b))) m), (f (unres m (fun x => sq (a [<] x and x [<] b)) x) [=] g x)) -> {m | is_UniformlyContinuousFunction g m}. (** * Application of a pair of functions to an element from a * metric space resulting in an element of a product space. *) Definition pairFG (m : nat) (X : MetricSpace) (Y : MetricSpace) (f : (XpowM CR m) -> X) (g : (XpowM CR m) -> Y) : (XpowM CR m) -> ProductMS X Y. intros m X Y f g x. unfold ProductMS. simpl; split. apply f. exact x. apply g. exact x. Defined. (** * This lemma corresponds to lemma 20 in the PDF as sent to * me on january 11th. It states that Bishop-continuity of * individual functions can be continued to pairs of functions. *) Lemma lem20 : forall (m : nat) (X : MetricSpace) (Y : MetricSpace) (f : (XpowM CR m) -> X) (g : (XpowM CR m) -> Y) (Hf : Bcont m X f) (Hg : Bcont m Y g), Bcont m (ProductMS X Y) (pairFG m X Y f g). Proof. intros m X Y f g Hf Hg. unfold Bcont. intros a0 b0 Ha0b0 g0 Hg0. unfold Bcont in Hf. assert ({f' : XpowM (SubMS CR (fun x : CR => sq (cof_less a0 x and cof_less x b0))) m -> X | (forall x : XpowM (SubMS CR (fun x : CR => sq (cof_less a0 x and cof_less x b0))) m, f (unres m (fun x0 : CR => sq (cof_less a0 x0 and cof_less x0 b0)) x) [=] f' x)}). exists (fun x => fst (g0 x)). intro x. unfold pairFG in Hg0. destruct (Hg0 x). rewrite <- H. simpl; reflexivity. inversion X0. elim (Hf a0 b0 Ha0b0 x H). intros mu1 H0. unfold Bcont in Hg. assert ({g' : XpowM (SubMS CR (fun x : CR => sq (cof_less a0 x and cof_less x b0))) m -> Y | (forall x : XpowM (SubMS CR (fun x : CR => sq (cof_less a0 x and cof_less x b0))) m, g (unres m (fun x0 : CR => sq (cof_less a0 x0 and cof_less x0 b0)) x) [=] g' x)}). exists (fun x => snd (g0 x)). intro x0. unfold pairFG in Hg0. destruct (Hg0 x0). rewrite <- H2. simpl; reflexivity. inversion X1. elim (Hg a0 b0 Ha0b0 x0 H1). intros mu2 H2. exists (fun x : Qpos => QposInf_min (mu1 x) (mu2 x)). unfold is_UniformlyContinuousFunction. intros e a1 b1 H3. unfold is_UniformlyContinuousFunction in H0, H2. assert (ball_ex (mu1 e) a1 b1). apply ball_ex_weak_le with (QposInf_min (mu1 e) (mu2 e)). apply QposInf_min_lb_l. exact H3. assert (ball_ex (mu2 e) a1 b1). apply ball_ex_weak_le with (QposInf_min (mu1 e) (mu2 e)). apply QposInf_min_lb_r. exact H3. assert (ball e (x a1) (x b1)). apply H0. exact H4. assert (ball e (x0 a1) (x0 b1)). apply H2. exact H5. simpl; unfold prod_ball; split. destruct (Hg0 a1). rewrite <- H8. destruct (Hg0 b1). rewrite <- H10. simpl. rewrite H. rewrite H. exact H6. simpl. destruct (Hg0 a1). rewrite <- H9. destruct (Hg0 b1). rewrite <- H11. simpl. rewrite H1. rewrite H1. exact H7. Qed. (** * TODO: This should be formulated either directly in the * proof or in a more general way. *) Definition betw01 (x : CR) : Prop := Zero [<=] x and x [<=] One. Require Import QMinMax. Require Import iso_CReals. (** * A quick definition to have the computational reals (CR) * represented as CR^1. *) Definition CRasCRpow1 (c : CR) : XpowM CR 1. intro c. simpl. simpl in c. exact c. Defined. (** * A somewhat general definition of a subspace of * the rationals. *) Definition QsubMS (a b : Q) := SubMS Q_as_MetricSpace (fun x : Q_as_MetricSpace => (a <= x)%Q and (x <= b)%Q). (** * Any element in a subset of Q is - of course - an element * in Q. *) Definition QsubMSasQ (a b : Q) (m : QsubMS a b) : Q. intros a0 b0 m. inversion m. exact x. Defined. (** * A 'flatten' function because apparently total functions * can be handled better by CoRN compared tot partial * funtions. * * flat_raw takes a function f from ([a,b] Q) to * R and returns a function f':Q -> R according to the * following diagram: * * ---(b)-------------- * / * / * -- * / * --------(a)--/ * * That is: the result of f'(x) in xb is equal to * f(a) and f(b) respectively. *) Definition flat_raw (a b : Q) (Hab : (a < b)%Q) (f : (QsubMS a b) -> CR) (Hf : Bcont 1 CR f) := (fun x : Q_as_MetricSpace => match (Qlt_le_dec_fast a x) with | left _ => match (Qlt_le_dec_fast x b) with | left _ => f (CRasCRpow1 (IRasCR (inj_Q IR x))) | right _ => f (CRasCRpow1 (IRasCR (inj_Q IR b))) end | right _ => f (CRasCRpow1 (IRasCR (inj_Q IR a))) end ). (** * A proof that the 'flatten' operation indeed preserves * uniform continuity. *) Lemma flat_prf : forall (a b : Qpos) (Hab : (a < b)%Q) (f : (XpowM CR 1) -> CR) (Hf : Bcont 1 CR f), {m | is_UniformlyContinuousFunction (flat_raw a b Hab f Hf) m}. Proof. intros a0 b0 Ha0b0 f Hf. unfold Bcont in Hf. set (IRasCR (inj_Q IR a0)). set (IRasCR (inj_Q IR b0)). assert ({g : XpowM (SubMS CR (fun x : CR => sq (cof_less s x and cof_less x s0))) 1 -> CR | (forall x : XpowM (SubMS CR (fun x : CR => sq (cof_less s x and cof_less x s0))) 1, f (unres 1 (fun x0 : CR => sq (cof_less s x0 and cof_less x0 s0)) x) [=] g x)}). exists (fun x : XpowM (SubMS CR (fun x : CR => sq (cof_less s x and cof_less x s0))) 1 => f (unres 1 (fun x0 : CR => sq (cof_less s x0 and cof_less x0 s0)) x)). intro x; reflexivity. inversion X. assert (cof_less s s0). unfold s. unfold s0. Admitted. (** * A 'flattened' function typed as a uniformly continuous * space. *) Definition flat (a b : Qpos) (Hab : (a < b)%Q) (f : (XpowM CR 1) -> CR) (Hf : Bcont 1 CR f) : UniformlyContinuousSpace Q_as_MetricSpace CR. intros a0 b0 Ha0b0 f Hf. set (flat_prf a0 b0 Ha0b0 f Hf). inversion s. exact (Build_UniformlyContinuousFunction H). Defined. (** * The is a repeated attempt at the definition of the * function L (see above). The function L0 is again a * translation function. It transforms a function * f : ([a,b] Q) -> R to a function * f' : ([c,d] Q) -> R. * * TODO: Finish or reconsider this proof. *) Definition L0_def (a b c d : Q) (Hab : (a < b)%Q) (Hcd : (c < d)%Q) (f : (QsubMS a b) -> CR) : (QsubMS c d) -> CR. intros a0 b0 c d Ha0b0 Hcd f x. inversion x. set (Qplus c (Qmult (Qminus d c) (Qdiv (Qminus (QsubMSasQ c d x) a0) (Qminus b0 a0)))). cut ((a0 <= q)%Q and (q <= b0)%Q). intro Hq. apply f. simpl. exists q. exact Hq. Admitted. (** * A new definition of L0 in terms of Q as a metric space. * * TODO: This proof (and the whole L0 construct, for that * matter) should be set up in a different way. *) Definition L0_ext_def (a b c d : Q) (Hab : (a < b)%Q) (Hcd : (c < d)%Q) (f : (QsubMS a b) -> CR) : Q_as_MetricSpace -> CR. intros a0 b0 c d Ha0b0 Hcd f x. case (Qlt_le_dec_fast c x). intro H. case (Qlt_le_dec_fast x d). intro H0. apply (L0_def a0 b0 c d Ha0b0 Hcd f). simpl. exists x. split. auto with *. auto with *. intro H0. apply (L0_def a0 b0 c d Ha0b0 Hcd f). simpl. exists d. split. auto with *. auto with *. intro H. apply (L0_def a0 b0 c d Ha0b0 Hcd f). simpl. exists c. split. auto with *. auto with *. Defined. (** * TODO: Lemma should be replaced/removed. *) Lemma L0_ext_uc : forall (a b c d : Q) (f : (QsubMS a b) -> CR) (Hab : (a < b)%Q) (Hcd : (c < d)%Q), {m : Qpos -> QposInf | is_UniformlyContinuousFunction (L0_ext_def a b c d Hab Hcd f) m}. Admitted. (** * TODO: Definition should be replaced/removed. *) Definition L0 (a b c d : Q) (f : (QsubMS a b) -> CR) (Hab : (a < b)%Q) (Hcd : (c < d)%Q) : UniformlyContinuousSpace Q_as_MetricSpace CR. intros a0 b0 c d f Ha0b0 Hcd. set (L0_ext_uc a0 b0 c d f Ha0b0 Hcd). inversion s. exact (Build_UniformlyContinuousFunction H). Defined. (** * Integration as a total function from Q to R. However, this * part of the proof probably has to be set up in a different * way (as I indicated before during our discussions). *) Definition F (a b : Qpos) (Hab : (a < b)%Q) (f : (XpowM CR 1) -> CR) (Hf : Bcont 1 CR f) := (fun x : Q_as_MetricSpace => match (Qlt_le_dec_fast x (1%Q)) with | left _ => IRasCR Zero | right _ => (Integrate01 (flat a b Hab f Hf)) end ). corn-8.20.0/broken/matrixClass.v000066400000000000000000001566511473720167500165350ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq choice fintype. Require Import finfun bigops ssralg groups perm zmodp morphisms. Require Import Ring RingClass. Require Import bigopsClass. Require Import Setoid Morphisms. Notation " x === y " := (Equivalence.equiv x y) (at level 70, no associativity). Open Scope signature_scope. Set Implicit Arguments. Unset Strict Implicit. Import Prenex Implicits. Reserved Notation "''M_' n" (at level 8, n at level 2, format "''M_' n"). Reserved Notation "''M_' ( n )" (at level 8, only parsing). Reserved Notation "''M_' ( m , n )" (at level 8, format "''M_' ( m , n )"). Reserved Notation "\matrix_ ( i , j ) E" (at level 36, E at level 36, i, j at level 50, format "\matrix_ ( i , j ) E"). Reserved Notation "\matrix_ ( i < m , j < n ) E" (at level 36, E at level 36, i, m, j, n at level 50, format "\matrix_ ( i < m , j < n ) E"). Reserved Notation "\matrix_ ( i , j < n ) E" (at level 36, E at level 36, i, j, n at level 50, format "\matrix_ ( i , j < n ) E"). Reserved Notation "x %:M" (at level 8, format "x %:M"). Reserved Notation "-m A" (at level 35, right associativity). Reserved Notation "A +m B" (at level 50, left associativity). Reserved Notation "A -m B" (at level 50, left associativity). Reserved Notation "x *m: A" (at level 40, left associativity). Reserved Notation "A *m B" (at level 40, left associativity). Reserved Notation "A ^T" (at level 8). Reserved Notation "\tr A" (at level 10, A at level 8, format "\tr A"). Reserved Notation "\det A" (at level 10, A at level 8, format "\det A"). Reserved Notation "\adj A" (at level 10, A at level 8, format "\adj A"). Delimit Scope matrix_scope with M. Local Open Scope matrix_scope. Definition setoid_cancel {A : Type} {B : Type} `{Equivalence A aeq} (f : A -> B) g := forall x, g (f x) === x. Section MatrixDef. Variable R : Type. Variables m n : nat. Definition matrix : Type := 'I_m -> 'I_n -> R. End MatrixDef. Notation "''M_' n" := (matrix _ n n) : type_scope. Notation "''M_' ( n )" := 'M_n (only parsing) : type_scope. Notation "''M_' ( m , n )" := (matrix _ m n) : type_scope. Notation "\matrix_ ( i < m , j < n ) E" := (fun (i : 'I_m) (j : 'I_n) => E) (only parsing). Notation "\matrix_ ( i , j < n ) E" := (\matrix_(i < n, j < n) E) (only parsing). Notation "\matrix_ ( i , j ) E" := (\matrix_(i < _, j < _) E). Section Slicing. Context `{r_st : Equivalence R req}. Definition mx_row m n i0 (A : 'M_(m, n)) := \matrix_(i < 1, j < n) (A i0 j : R). Global Instance mx_row_morph m n i0 : Proper (Equivalence.equiv==>Equivalence.equiv) (@mx_row m n i0). Proof. by move=> m n i0 A B eqAB i; apply eqAB. Qed. Definition mx_col m n j0 (A : 'M_(m, n)) := \matrix_(i < m, j < 1) (A i j0 : R). Global Instance mx_col_morph m n i0 : Proper (Equivalence.equiv==>Equivalence.equiv) (@mx_col m n i0). Proof. by move=> m n i0 A B eqAB i j; apply eqAB. Qed. Definition mx_row' m n i0 (A : 'M_(m, n)) := \matrix_(i, j) (A (lift i0 i) j : R). Global Instance mx_row'_morph m n i0 : Proper (Equivalence.equiv==>Equivalence.equiv) (@mx_row' m n i0). Proof. by move=> m n i0 A B eqAB i; apply eqAB. Qed. Definition mx_col' m n j0 (A : 'M_(m, n)) := \matrix_(i, j) (A i (lift j0 j) : R). Global Instance mx_col'_morph m n i0 : Proper (Equivalence.equiv==>Equivalence.equiv) (@mx_col' m n i0). Proof. by move=> m n i0 A B eqAB i j; apply eqAB. Qed. Definition rswap m n i1 i2 (A : 'M_(m, n)) := \matrix_(i, j) (A (tperm i1 i2 i) j : R). Global Instance rswap_morph m n i1 i2 : Proper (Equivalence.equiv==>Equivalence.equiv) (@rswap m n i1 i2). Proof. by move=> m n i1 i2 A B eqAB i; apply eqAB. Qed. Definition cswap m n i1 i2 (A : 'M_(m, n)) := \matrix_(i, j) (A i (tperm i1 i2 j) : R). Global Instance cswap_morph m n i1 i2 : Proper (Equivalence.equiv==>Equivalence.equiv) (@cswap m n i1 i2). Proof. by move=> m n i1 i2 A B eqAB i j; apply eqAB. Qed. Definition trmx m n (A : 'M_(m, n)) := \matrix_(i, j) (A j i : R). Global Instance trmx_morph m n : Proper (Equivalence.equiv==>Equivalence.equiv) (@trmx m n). Proof. by move=> m n A B eqAB i j; apply eqAB. Qed. Lemma trmxK : forall m n, setoid_cancel (@trmx m n) (@trmx n m). Proof. by move=> m n A i j; rewrite/trmx; reflexivity. Qed. Lemma trmx_inj : forall m n (A B : 'M_(m, n)), trmx A === trmx B -> A === B. Proof. by rewrite/trmx=> m n A B eqtr i j; apply eqtr. Qed. Notation "A ^T" := (trmx A). Lemma trmx_row : forall m n i0 (A : 'M_(m, n)), (mx_row i0 A)^T === mx_col i0 A^T. Proof. by rewrite/trmx/mx_row/mx_col=> m n i0 A i j; reflexivity. Qed. Lemma trmx_row' : forall m n i0 (A : 'M_(m, n)), (mx_row' i0 A)^T === mx_col' i0 A^T. Proof. by rewrite/trmx/mx_row/mx_col=> m n i0 A i j; reflexivity. Qed. Lemma trmx_col : forall m n j0 (A : 'M_(m, n)), (mx_col j0 A)^T === mx_row j0 A^T. Proof. by rewrite/trmx/mx_row/mx_col=> m n i0 A i j; reflexivity. Qed. Lemma trmx_col' : forall m n j0 (A : 'M_(m, n)), (mx_col' j0 A)^T === mx_row' j0 A^T. Proof. by rewrite/trmx/mx_row/mx_col=> m n i0 A i j; reflexivity. Qed. Lemma trmx_cswap : forall m n (A : 'M_(m, n)) i1 i2, (cswap i1 i2 A)^T === rswap i1 i2 A^T. Proof. by rewrite/trmx/rswap/cswap=> m n A i1 i2 i j; case tpermP; reflexivity. Qed. Lemma trmx_rswap : forall m n (A : 'M_(m, n)) i1 i2, (rswap i1 i2 A)^T === cswap i1 i2 A^T. Proof. by rewrite/trmx/rswap/cswap=> m n A i1 i2 i j; case tpermP; reflexivity. Qed. Lemma mx_row_id : forall n (A : 'M_(1, n)), mx_row ord0 A === A. Proof. by move=> n A i j; (have -> : ord0 = i by rewrite (ord1 i); apply ord_inj => //); reflexivity. Qed. Lemma mx_row_eq : forall m1 m2 n i1 i2 (A1 : 'M_(m1, n)) (A2 : 'M_(m2, n)), mx_row i1 A1 === mx_row i2 A2 -> A1 i1 === A2 i2. Proof. rewrite/mx_row => m1 m2 n i1 i2 A1 A2 eqA1A2 j. by apply eqA1A2; apply (@Ordinal 1 0). Qed. Lemma mx_row'_eq : forall m n i0 (A B : 'M_(m, n)), mx_row' i0 A === mx_row' i0 B -> {in predC1 i0, forall i, A i === B i}. Proof. move=> m n i0 A B eqAB i; rewrite /mx_row' inE /= eq_sym. by case/unlift_some=> i' -> _; apply: eqAB. Qed. Section CutPaste. Variables m n1 n2 : nat. (* The shape of the (dependent) width parameter of the type of A *) (* determines where the cut is made! *) Definition lcutmx (A : 'M_(m, n1 + n2)):= \matrix_(i < m, j < n1) (A i (lshift n2 j) : R). Global Instance lcutmx_morph : Proper (Equivalence.equiv==>Equivalence.equiv) lcutmx. Proof. by move=> A B eqAB i j; apply eqAB. Qed. Definition rcutmx (A : 'M_(m, n1 + n2)) := \matrix_(i < m, j < n2) (A i (rshift n1 j) : R). Global Instance rcutmx_morph : Proper (Equivalence.equiv==>Equivalence.equiv) rcutmx. Proof. by move=> A B eqAB i j; apply eqAB. Qed. Definition pastemx (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)) := \matrix_(i < m, j < n1 + n2) (match split j with inl j1 => A1 i j1 | inr j2 => A2 i j2 end : R). Global Instance pastemx_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) pastemx. Proof. rewrite/pastemx=> A1 B1 eqAB1 A2 B2 eqAB2 i j; case: (splitP j)=> j' _; first by apply eqAB1. by apply eqAB2. Qed. Lemma pastemxEl : forall A1 A2 i j, pastemx A1 A2 i (lshift n2 j) === A1 i j. Proof. by rewrite/pastemx=> A1 A2 i j; rewrite (unsplitK (inl _ _)); reflexivity. Qed. Lemma pastemxEr : forall A1 A2 i j, pastemx A1 A2 i (rshift n1 j) === A2 i j. Proof. by rewrite/pastemx=> A1 A2 i j; rewrite (unsplitK (inr _ _)); reflexivity. Qed. Lemma pastemxKl : forall A1 A2, lcutmx (pastemx A1 A2) === A1. Proof. by move=> A1 A2 i j; rewrite /lcutmx; rewrite -> pastemxEl; reflexivity. Qed. Lemma pastemxKr : forall A1 A2, rcutmx (pastemx A1 A2) === A2. Proof. by move=> A1 A2 i j; rewrite /rcutmx; rewrite -> pastemxEr; reflexivity. Qed. Lemma cutmxK : forall A, pastemx (lcutmx A) (rcutmx A) === A. Proof. move=> A i j. rewrite/pastemx/lcutmx/rcutmx. case: splitP; case=> /= k kprf eqk. by have <- : j = lshift n2 (Ordinal kprf); [apply ord_inj; apply eqk | reflexivity]. by have <- : j = rshift n1 (Ordinal kprf); [apply ord_inj; apply eqk | reflexivity]. Qed. End CutPaste. Lemma mx_row_paste : forall m n1 n2 i0 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)), mx_row i0 (pastemx A1 A2) === pastemx (mx_row i0 A1) (mx_row i0 A2). Proof. by reflexivity. Qed. Lemma mx_row'_paste : forall m n1 n2 i0 (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)), mx_row' i0 (pastemx A1 A2) === pastemx (mx_row' i0 A1) (mx_row' i0 A2). Proof. by reflexivity. Qed. Lemma mx_col_lshift : forall m n1 n2 j1 (A1 : 'M_(m, n1)) A2, mx_col (lshift n2 j1) (pastemx A1 A2) === mx_col j1 A1. Proof. by rewrite/mx_col=> m n1 n2 j1 A1 A2 i j; rewrite -> pastemxEl; reflexivity. Qed. Lemma mx_col_rshift : forall m n1 n2 j2 A1 (A2 : 'M_(m, n2)), mx_col (rshift n1 j2) (pastemx A1 A2) === mx_col j2 A2. Proof. by rewrite/mx_col=> m n1 n2 j1 A1 A2 i j; rewrite -> pastemxEr; reflexivity. Qed. Lemma mx_col'_lshift : forall m n1 n2 j1 (A1 : 'M_(m, n1.+1)) A2, mx_col' (lshift n2 j1) (pastemx A1 A2) === pastemx (mx_col' j1 A1) A2. Proof. move=> m n1 n2 j1 A1 A2 i /= j. case: (splitP j) => j' def_j'. have -> : j = lshift n2 j' by apply ord_inj; apply def_j'. rewrite -> pastemxEl; rewrite /mx_col'. have -> : lift (lshift n2 j1) (lshift n2 j') = lshift n2 (lift j1 j'); last by rewrite -> pastemxEl; reflexivity. by apply ord_inj. have -> : j = rshift n1 j' by apply ord_inj; apply def_j'. rewrite -> pastemxEr; rewrite /mx_col'. have -> : lift (lshift n2 j1) (rshift n1 j') = (rshift n1.+1 j'); last by rewrite -> pastemxEr; reflexivity. apply ord_inj => /=. rewrite/bump //= addSnnS addnS -def_j' -(addn1 j) addnC. have -> : j1 <= j=>//. rewrite def_j' {def_j'}. by apply leq_trans with n1; [apply j1 | apply leq_addr]. Qed. Lemma mx_col'_rcast : forall n1 n2, 'I_n2 -> (n1 + n2.-1)%N === (n1 + n2).-1. Proof. by move=> n1 n2 [j]; move/ltn_predK <-; rewrite addnS. Qed. (*Lemma paste_mx_col' : forall m n1 n2 j2 A1 (A2 : 'M_(m, n2)), pastemx A1 (mx_col' j2 A2) === eq_rect _ (matrix R m) (mx_col' (rshift n1 j2) (pastemx A1 A2)) _ (esym (mx_col'_rcast n1 j2)). Proof. move=> m n1 n2 j2 A1 A2; apply/matrixP=> i /= j; rewrite mxE. case: splitP => j' def_j'; case: (n1 + n2.-1)%N / (esym _) => /= in j def_j' *. rewrite mxE -(pastemxEl _ A2); congr (pastemx _ _ _); apply: ord_inj. by rewrite /= def_j' /bump leqNgt ltn_addr. rewrite 2!mxE -(pastemxEr A1); congr (pastemx _ _ _ _); apply: ord_inj => /=. by rewrite def_j' /bump leq_add2l addnCA. Qed. Lemma mx_col'_rshift : forall m n1 n2 j2 A1 (A2 : 'M_(m, n2)), mx_col' (rshift n1 j2) (pastemx A1 A2) = eq_rect _ (matrix R m) (pastemx A1 (mx_col' j2 A2)) _ (mx_col'_rcast n1 j2). Proof. move=> m n1 n2 j2 A1 A2; rewrite paste_mx_col'. by case: _.-1 / (mx_col'_rcast n1 j2) {A1 A2}(mx_col' _ _). Qed.*) Section Block. Variables m1 m2 n1 n2 : nat. Definition block_mx Aul Aur All Alr : 'M_(m1 + m2, n1 + n2) := (pastemx (pastemx Aul Aur)^T (pastemx All Alr)^T)^T. Global Instance block_mx_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) block_mx. Proof. rewrite/block_mx=> Aul1 Aul2 eqAul Aur1 Aur2 eqAur All1 All2 eqAll Alr1 Alr2 eqAlr i j. by apply pastemx_morph; apply trmx_morph; apply pastemx_morph. Qed. Section CutBlock. Variable A : matrix R (m1 + m2) (n1 + n2). Definition ulsubmx := lcutmx (lcutmx A^T)^T. Definition ursubmx := rcutmx (lcutmx A^T)^T. Definition llsubmx := lcutmx (rcutmx A^T)^T. Definition lrsubmx := rcutmx (rcutmx A^T)^T. Lemma submxK : block_mx ulsubmx ursubmx llsubmx lrsubmx === A. Proof. rewrite/block_mx/ulsubmx/ursubmx/llsubmx/lrsubmx. rewrite -> !cutmxK => i j. rewrite/rcutmx/lcutmx/pastemx/trmx. case: splitP => i' eqii'. by have -> : lshift m2 i' = i; [apply ord_inj|reflexivity]. by have -> : rshift m1 i' = i; [apply ord_inj|reflexivity]. Qed. End CutBlock. Section PasteBlock. Variables (Aul : matrix R m1 n1) (Aur : matrix R m1 n2). Variables (All : matrix R m2 n1) (Alr : matrix R m2 n2). Let A := block_mx Aul Aur All Alr. Lemma block_mxEul : forall i j, A (lshift m2 i) (lshift n2 j) === Aul i j. Proof. by move=> i j; rewrite /A /block_mx /trmx; rewrite -> !pastemxEl; reflexivity. Qed. Lemma block_mxKul : ulsubmx A === Aul. Proof. by move=> i j; rewrite /A /block_mx /ulsubmx /lcutmx /trmx; rewrite -> !pastemxEl; reflexivity. Qed. Lemma block_mxEur : forall i j, A (lshift m2 i) (rshift n1 j) === Aur i j. Proof. by move=> i j; rewrite /A /block_mx /trmx; rewrite -> pastemxEl, pastemxEr; reflexivity. Qed. Lemma block_mxKur : ursubmx A === Aur. Proof. by move=> i j; rewrite /A /block_mx /ursubmx /lcutmx /rcutmx /trmx; rewrite -> pastemxEl, pastemxEr; reflexivity. Qed. Lemma block_mxEll : forall i j, A (rshift m1 i) (lshift n2 j) === All i j. Proof. by move=> i j; rewrite /A /block_mx /trmx; rewrite -> pastemxEr, pastemxEl; reflexivity. Qed. Lemma block_mxKll : llsubmx A === All. Proof. by move=> i j; rewrite /A /block_mx /llsubmx /lcutmx /rcutmx /trmx; rewrite -> pastemxEr, pastemxEl; reflexivity. Qed. Lemma block_mxElr : forall i j, A (rshift m1 i) (rshift n1 j) === Alr i j. Proof. by move=> i j; rewrite /A /block_mx /trmx; rewrite -> !pastemxEr; reflexivity. Qed. Lemma block_mxKlr : lrsubmx A === Alr. Proof. by move=> i j; rewrite /A /block_mx /lrsubmx /lcutmx /rcutmx /trmx; rewrite -> !pastemxEr; reflexivity. Qed. End PasteBlock. End Block. Section TrBlock. Variables m1 m2 n1 n2 : nat. Section TrCut. Variable A : matrix R (m1 + m2) (n1 + n2). Lemma trmx_ulsub : (ulsubmx A)^T === ulsubmx A^T. Proof. by move => i j /=; reflexivity. Qed. Lemma trmx_ursub : (ursubmx A)^T === llsubmx A^T. Proof. by move => i j /=; reflexivity. Qed. Lemma trmx_llsub : (llsubmx A)^T === ursubmx A^T. Proof. by move => i j /=; reflexivity. Qed. Lemma trmx_lrsub : (lrsubmx A)^T === lrsubmx A^T. Proof. by move => i j /=; reflexivity. Qed. End TrCut. Lemma trmx_block : forall (Aul : 'M_(m1, n1)) Aur All (Alr : 'M_(m2, n2)), (block_mx Aul Aur All Alr)^T === block_mx Aul^T All^T Aur^T Alr^T. Proof. move=> Aul Aur All Alr. pose (block_mx Aul Aur All Alr). rewrite -/m. rewrite <- (block_mxKul Aul Aur All Alr). rewrite <- (block_mxKll Aul Aur All Alr) at 2. rewrite <- (block_mxKur Aul Aur All Alr) at 3. rewrite <- (block_mxKlr Aul Aur All Alr) at 4. by rewrite -> trmx_ulsub, trmx_llsub, trmx_ursub, trmx_lrsub, submxK; reflexivity. Qed. End TrBlock. End Slicing. Notation "A ^T" := (trmx A). Prenex Implicits lcutmx rcutmx ulsubmx ursubmx llsubmx lrsubmx. (* Definition of operations for matrices over a ring *) Section MatrixOpsDef. Context `{r_ring : Ring}. Add Ring r_r : r_rt (setoid r_st r_ree, preprocess [unfold Equivalence.equiv]). Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "\sum_ ( <- r | P ) F" := (\big[radd/0]_(<- r | P) F). Notation "\sum_ ( i <- r | P ) F" := (\big[radd/0]_(i <- r | P) F). Notation "\sum_ ( i <- r ) F" := (\big[radd/0]_(i <- r) F). Notation "\sum_ ( m <= i < n | P ) F" := (\big[radd/0]_(m <= i < n | P) F). Notation "\sum_ ( m <= i < n ) F" := (\big[radd/0]_(m <= i < n) F). Notation "\sum_ ( i | P ) F" := (\big[radd/0]_(i | P) F). Notation "\sum_ i F" := (\big[radd/0]_i F). Notation "\sum_ ( i : t | P ) F" := (\big[radd/0]_(i : t | P) F) (only parsing). Notation "\sum_ ( i : t ) F" := (\big[radd/0]_(i : t) F) (only parsing). Notation "\sum_ ( i < n | P ) F" := (\big[radd/0]_(i < n | P) F). Notation "\sum_ ( i < n ) F" := (\big[radd/0]_(i < n) F). Notation "\sum_ ( i \in A | P ) F" := (\big[radd/0]_(i \in A | P) F). Notation "\sum_ ( i \in A ) F" := (\big[radd/0]_(i \in A) F). Notation "\prod_ ( <- r | P ) F" := (\big[rmul/1]_(<- r | P) F). Notation "\prod_ ( i <- r | P ) F" := (\big[rmul/1]_(i <- r | P) F). Notation "\prod_ ( i <- r ) F" := (\big[rmul/1]_(i <- r) F). Notation "\prod_ ( m <= i < n | P ) F" := (\big[rmul/1]_(m <= i < n | P) F). Notation "\prod_ ( m <= i < n ) F" := (\big[rmul/1]_(m <= i < n) F). Notation "\prod_ ( i | P ) F" := (\big[rmul/1]_(i | P) F). Notation "\prod_ i F" := (\big[rmul/1]_i F). Notation "\prod_ ( i : t | P ) F" := (\big[rmul/1]_(i : t | P) F) (only parsing). Notation "\prod_ ( i : t ) F" := (\big[rmul/1]_(i : t) F) (only parsing). Notation "\prod_ ( i < n | P ) F" := (\big[rmul/1]_(i < n | P) F). Notation "\prod_ ( i < n ) F" := (\big[rmul/1]_(i < n) F). Notation "\prod_ ( i \in A | P ) F" := (\big[rmul/1]_(i \in A | P) F). Notation "\prod_ ( i \in A ) F" := (\big[rmul/1]_(i \in A) F). Existing Instance radd_morph. Existing Instance rmul_morph. Existing Instance rsub_morph. Existing Instance ropp_morph. Existing Instance radd_assoc. Existing Instance radd_comm. Existing Instance radd_left_unit. Existing Instance rmul_assoc. Existing Instance rmul_comm. Existing Instance rmul_left_unit. Existing Instance rmul_left_zero. Existing Instance radd_rmul_left_distr. Section ZmodOps. (* The Zmodule structure *) Variables m n : nat. Implicit Types A B C : matrix R m n. Definition null_mx := \matrix_(i < m, j < n) (0 : R). Definition oppmx A := \matrix_(i < m, j < n) (- A i j). Definition addmx A B := \matrix_(i < m, j < n) (A i j + B i j). Definition scalemx x A := \matrix_(i < m, j < n) (x * A i j). Global Instance addmx_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) addmx. Proof. by move=> A A' eqAA' B B' eqBB' i j; rewrite/addmx; setoid_rewrite eqAA'; setoid_rewrite eqBB'; reflexivity. Qed. Global Instance oppmx_morph : Proper (Equivalence.equiv==>Equivalence.equiv) oppmx. Proof. by move=> A A' eqAA' i j ; rewrite/oppmx; setoid_rewrite eqAA'; reflexivity. Qed. Global Instance scalemx_morph : Proper (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) scalemx. Proof. by move=> A A' eqAA' B B' eqBB' i j ; rewrite/scalemx; setoid_rewrite eqAA'; setoid_rewrite eqBB'; reflexivity. Qed. Lemma summxE : forall I r (P : pred I) (E : I -> 'M_(m, n)) i j, (\big[addmx/null_mx]_(k <- r | P k) E k) i j === \sum_(k <- r | P k) E k i j. Proof. move=> I r P E i j. apply: (big_morph (phi:=fun A => A i j)) => [A B||]. by rewrite/addmx; ring. by rewrite/null_mx; ring. apply radd_morph. Qed. (* Vector space structure... pending the definition *) Notation "'0m" := null_mx. Notation "-m A" := (oppmx A). Notation "A +m B" := (addmx A B). Notation "A -m B" := (addmx A (oppmx B)). Notation "x *m: A" := (scalemx x A). Lemma scale0mx : forall A, 0 *m: A === '0m. Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> A i j; ring. Qed. Lemma scalemx0 : forall x, x *m: '0m === '0m. Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x i j; ring. Qed. Lemma scale1mx : forall A, 1 *m: A === A. Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> A i j; ring. Qed. Lemma scaleNmx : forall x A, (- x) *m: A === -m (x *m: A). Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x A i j; ring. Qed. Lemma scalemxN : forall x A, x *m: (-m A) === -m (x *m: A). Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x A i j; ring. Qed. Lemma scalemx_addl : forall x y A, (x + y) *m: A === (x *m: A) +m (y *m: A). Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x y A i j; ring. Qed. Lemma scalemx_addr : forall x A B, x *m: (A +m B) === (x *m: A) +m (x *m: B). Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x A B i j; ring. Qed. Lemma scalemx_subl : forall x y A, (x - y) *m: A === (x *m: A) -m (y *m: A). Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x y A i j; ring. Qed. Lemma scalemx_subr : forall x A B, x *m: (A -m B) === (x *m: A) -m (x *m: B). Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x A B i j; ring. Qed. Lemma scalemxA : forall x y A, x *m: (y *m: A) === (x * y) *m: A. Proof. by rewrite/null_mx/addmx/oppmx/scalemx=> x y A i j; ring. Qed. (* Basis... *) Definition delta_mx i0 j0 := \matrix_(i < m, j < n) (if ((i == i0) && (j == j0)) then 1 else 0). Lemma matrix_sum_delta : forall A, A === \big[addmx/null_mx]_(i < m) \big[addmx/null_mx]_(j < n) (A i j *m: delta_mx i j). Proof. move=> A i j. setoid_rewrite summxE. setoid_rewrite summxE. setoid_rewrite (bigD1 (j:=i))=>//=. setoid_rewrite (big1 (P:=fun i0 => i0 != i))=>[|i0 Hi0]. setoid_rewrite (bigD1 (j:=j))=>//=. setoid_rewrite (big1 (P:=fun i0 => i0 != j))=>[|i0 Hi0]. by rewrite/delta_mx/scalemx !eq_refl/=; ring. rewrite/delta_mx/scalemx !eq_refl/= eq_sym; move:Hi0. by case/negbRL=>->/=; ring. apply (big1 (P:=fun _ => true) (F:=fun k => (A i0 k *m: delta_mx i0 k) i j))=>i1 _. rewrite/delta_mx/scalemx eq_sym/=; move:Hi0. by case/negbRL=>->/=; ring. Qed. End ZmodOps. Notation "'0m" := (@null_mx _ _). Notation "-m A" := (oppmx A). Notation "A +m B" := (addmx A B). Notation "A -m B" := (addmx A (oppmx B)). Notation "x *m: A" := (scalemx x A). Lemma trmx0 : forall (m n : nat), (@null_mx m n)^T === @null_mx n m. Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma trmx_add : forall m n (A B : 'M_(m, n)), (A +m B)^T === A^T +m B^T. Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma trmx_scale : forall m n a (A : 'M_(m, n)), (a *m: A)^T === a *m: A^T. Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma mx_row0 : forall m n i0, mx_row i0 (@null_mx m n) === (@null_mx 1 n). Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma mx_col0 : forall m n j0, mx_col j0 (@null_mx m n) === (@null_mx m 1). Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma mx_row'0 : forall m n i0, mx_row' i0 (@null_mx m n) === (@null_mx m.-1 n). Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma mx_col'0 : forall m n i0, mx_col' i0 (@null_mx m n) === (@null_mx m n.-1). Proof. by move=> m n; rewrite/trmx/null_mx/addmx/oppmx/scalemx; reflexivity. Qed. Lemma pastemx0 : forall m n1 n2, pastemx (@null_mx m n1) (@null_mx m n2) === (@null_mx m (n1 + n2)). Proof. by move=> m n1 n2 i j; rewrite/pastemx/trmx/null_mx/addmx/oppmx/scalemx; case: split; reflexivity. Qed. Lemma addmx_paste : forall m n1 n2 (A1 B1 : 'M_(m, n1)) (A2 B2 : 'M_(m, n2)), pastemx A1 A2 +m pastemx B1 B2 === pastemx (A1 +m B1) (A2 +m B2). Proof. by move=> m n1 n2 iA1 B1 A2 B2 i j; rewrite/pastemx/trmx/null_mx/addmx/oppmx/scalemx; case: split; reflexivity. Qed. Lemma scalemx_paste : forall m n1 n2 a (A1 : 'M_(m, n1)) (A2 : 'M_(m, n2)), a *m: pastemx A1 A2 === pastemx (a *m: A1) (a *m: A2). Proof. by move=> m n1 n2 a A1 A2 i j; rewrite/pastemx/trmx/null_mx/addmx/oppmx/scalemx; case: split; reflexivity. Qed. Lemma block_mx0 : forall m1 m2 n1 n2, block_mx (@null_mx m1 n1) (@null_mx m1 n2) (@null_mx m2 n1) (@null_mx m2 n2) === @null_mx (m1 + m2) (n1 + n2). Proof. by move=> m1 m2 n1 n2 i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx; case: split; case: split; reflexivity. Qed. Lemma addmx_block : forall m1 m2 n1 n2 (Aul Bul : 'M_(m1, n1)) (Aur Bur : 'M_(m1, n2)) (All Bll : 'M_(m2, n1)) (Alr Blr : 'M_(m2, n2)), block_mx Aul Aur All Alr +m block_mx Bul Bur Bll Blr === block_mx (Aul +m Bul) (Aur +m Bur) (All +m Bll) (Alr +m Blr). Proof. by move=> m1 m2 n1 n2 Aul Bul Aur Bur All Bll Alr Blr i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx; case: split; case: split; reflexivity. Qed. Lemma scalemx_block : forall m1 m2 n1 n2 a (Aul : 'M_(m1, n1)) (Aur : 'M_(m1, n2)) (All : 'M_(m2, n1)) (Alr : 'M_(m2, n2)), a *m: block_mx Aul Aur All Alr === block_mx (a *m: Aul) (a *m: Aur) (a *m: All) (a *m: Alr). Proof. by move=> m1 m2 n1 n2 a Aul Aur All Alr i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx; case: split; case: split; reflexivity. Qed. (* The graded ring structure *) Definition scalar_mx n x := \matrix_(i , j < n) (if i == j then x else 0). Global Instance scalar_mx_morph n : Morphism (Equivalence.equiv==>Equivalence.equiv) (@scalar_mx n). Proof. by rewrite/scalar_mx=>n x y eqxy i j; case:(i==j); [apply eqxy | reflexivity]. Qed. Definition mulmx m n p (A : 'M_(m, n)) (B : 'M_(n, p)) := \matrix_(i < m, k < p) \big [radd/0]_(j < n) (A i j * B j k). Global Instance mulmx_morph m n p : Morphism (Equivalence.equiv==>Equivalence.equiv==>Equivalence.equiv) (@mulmx m n p). Proof. move=> m n p A A' eqAA' B B' eqBB' i k. rewrite/mulmx; apply eq_bigr=> j _. by setoid_rewrite eqAA'; setoid_rewrite eqBB'; reflexivity. Qed. Notation "x %:M" := (@scalar_mx _ x). Notation "A *m B" := (mulmx A B). Lemma scalar_mx0 : forall n, 0 %:M === @null_mx n n. Proof. by move=> n i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx/scalar_mx/mulmx; case: eqP=> _; ring. Qed. Lemma scalar_mx_opp : forall (n : nat) a, (- a)%:M === -m (@scalar_mx n a). Proof. by move=> n a i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx/scalar_mx/mulmx; case: eqP=> _; ring. Qed. Lemma scalar_mx_add : forall n a b, @scalar_mx n (a + b) === a%:M +m b%:M. Proof. by move=> n a b i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx/scalar_mx/mulmx; case: eqP=> _; ring. Qed. Lemma mulmx_scalar : forall m n a (A : 'M_(m, n)), (a%:M) *m A === a *m: A. Proof. move=> m n a A i j; rewrite/block_mx/pastemx/trmx/null_mx/addmx/oppmx/scalemx/scalar_mx/mulmx. setoid_rewrite (bigD1 (j:=i))=>//. setoid_rewrite big1=>[|i'/=]; first by case: eqP=>ii'//; ring. by rewrite/is_true eq_sym; move/negbRL=>->/=; ring. Qed. Lemma scalar_mx_mul : forall n a b, @scalar_mx n (a * b) === a%:M *m b%:M. Proof. by move=> n a b; rewrite -> mulmx_scalar; rewrite /scalar_mx /scalemx=> i j; by case (i==j); ring. Qed. Lemma trmx_scalar : forall n a, (a%:M)^T === @scalar_mx n a. Proof. by move=> n a i j; rewrite/trmx/null_mx/addmx/oppmx/scalemx/scalar_mx/mulmx eq_sym; reflexivity. Qed. Lemma mul1mx : forall m n (A : 'M_(m, n)), 1%:M *m A === A. Proof. by move=> m n A; rewrite -> mulmx_scalar, scale1mx; reflexivity. Qed. Lemma mulmx_addl : forall m n p (A1 A2 : 'M_(m, n)) (B : 'M_(n, p)), (A1 +m A2) *m B === A1 *m B +m A2 *m B. Proof. move=> m n p A1 A2 B i k; rewrite /addmx /mulmx. setoid_rewrite <- big_split. by apply eq_bigr=> j _; ring. Qed. Lemma scalemx_add : forall n a1 a2, @scalar_mx n (a1 + a2) === a1%:M +m a2%:M. Proof. by move=> n a1 a2 i j; rewrite/scalar_mx/addmx; case: (i==j); ring. Qed. Lemma scalemxAl : forall m n p a (A : 'M_(m, n)) (B : 'M_(n, p)), a *m: (A *m B) === (a *m: A) *m B. Proof. move=> m n p a A B i k. rewrite/scalemx/mulmx. setoid_rewrite (big_distrr). apply eq_bigr => j _; ring. Qed. Lemma mul0mx : forall m n p (A : 'M_(n, p)), '0m *m A === @null_mx m p. Proof. by move=> m n p A i k; rewrite/mulmx/null_mx; apply (big1 (P:=fun _ => true) (F:=fun j => 0 * A j k))=> j _; ring. Qed. Lemma mulmx0 : forall m n p (A : 'M_(m, n)), A *m '0m === @null_mx m p. Proof. by move=> m n p A i k; rewrite/mulmx/null_mx; apply (big1 (P:=fun _ => true) (F:=fun j => A i j * 0))=> j _; ring. Qed. Lemma mulmx1 : forall m n (A : 'M_(m, n)), A *m 1%:M === A. Proof. move=> m n A i k; rewrite/mulmx/scalar_mx. setoid_rewrite (bigD1 (j:=k))=>//. setoid_rewrite big1=> [| j/=]; first by rewrite eq_refl; ring. by rewrite/is_true; move/negbRL=>->/=; ring. Qed. Lemma mulmx_addr : forall m n p (A : 'M_(m, n)) (B1 B2 : 'M_(n, p)), A *m (B1 +m B2) === A *m B1 +m A *m B2. Proof. by move=> m n p A B1 B2 i k; rewrite/mulmx/addmx; setoid_rewrite <- big_split; apply eq_bigr=> j _; ring. Qed. Lemma mulmxA : forall m n p q (A : 'M_(m, n)) (B : 'M_(n, p)) (C : 'M_(p, q)), A *m (B *m C) === A *m B *m C. Proof. move=> m n p q A B C i l; rewrite/mulmx. setoid_rewrite big_distrr; setoid_rewrite big_distrl. setoid_rewrite (exchange_big predT predT (fun j k => A i j * (B j k * C k l))). by apply eq_bigr=> j _; apply eq_bigr=> k _; ring. Qed. Definition perm_mx n (s : 'S_n) := \matrix_(i, j) (if s i == j then 1 else 0). Definition tperm_mx n i1 i2 := @perm_mx n (tperm i1 i2). Lemma trmx_perm : forall n (s : 'S_n), (perm_mx s)^T === perm_mx s^-1. Proof. by move=> n s i j; rewrite /trmx /perm_mx (canF_eq (permK _)) eq_sym; reflexivity. Qed. Lemma trmx_tperm : forall n i1 i2, (@tperm_mx n i1 i2)^T === tperm_mx i1 i2. Proof. by move=> n i1 i2; rewrite /tperm_mx; rewrite -> trmx_perm, tpermV; reflexivity. Qed. Lemma mulmx_perm : forall n (s t : 'S_n), perm_mx s *m perm_mx t === perm_mx (s * t). Proof. move=> n s t i j; rewrite/mulmx/perm_mx. setoid_rewrite (bigD1 (j:=s i))=>//=. setoid_rewrite (big1 (P:=fun k => k != s i))=>[|k]; first by rewrite eq_refl permM; ring. by rewrite eq_sym; move/negbTE => ->; ring. Qed. Lemma mul_tperm_mx : forall m n (A : 'M_(m, n)) i1 i2, (tperm_mx i1 i2) *m A === rswap i1 i2 A. Proof. move=> m n' A i1 i2 i j. rewrite /mulmx /tperm_mx /perm_mx /rswap. setoid_rewrite (bigD1 (j:=tperm i1 i2 i))=>//=. setoid_rewrite (big1 (P:=fun k => k != tperm i1 i2 i))=>[|k]; first by rewrite eq_refl; ring. by rewrite eq_sym; move/negbTE => ->; ring. Qed. Lemma perm_mx1 : forall n, perm_mx 1 === @scalar_mx n 1. Proof. by move=> n i j; rewrite /perm_mx /scalar_mx perm1; reflexivity. Qed. (* The trace, in 1/4 line. *) Definition mx_trace n (A : 'M_n) := \sum_(i < n) A i i. Notation "'\tr' A" := (mx_trace A). Lemma mx_trace0 : forall n, \tr ('0m : 'M_n) === 0. Proof. by move=> n; apply (big1 (I:=ordinal_finType n))=> i _; reflexivity. Qed. Lemma mx_trace_scale : forall n a (A : 'M_n), \tr (a *m: A) === a * \tr A. Proof. by move=> n a A; rewrite/mx_trace; setoid_rewrite (big_distrr (I:=ordinal_finType n)); apply eq_bigr => i _; reflexivity. Qed. Notation "a *+ n" := (iter n (radd a) rO). Lemma mx_trace_scalar : forall n a, \tr (a%:M : 'M_n) === a *+ n. Proof. by move=> n a; rewrite <- big_const_ord; apply eq_bigr=> i _; rewrite/scalar_mx eq_refl; reflexivity. Qed. Lemma mx_trace_add : forall n A B, \tr (A +m B : 'M_n) === \tr A + \tr B. Proof. by move=> n A B; rewrite/mx_trace/addmx; apply big_split. Qed. Lemma mx_trace_tr : forall n (A : 'M_n), \tr A^T === \tr A. Proof. by move=> n A; apply eq_bigr=> i _; reflexivity. Qed. Lemma mx_trace_block : forall n1 n2 Aul Aur All Alr, \tr (block_mx Aul Aur All Alr : 'M_(n1 + n2)) === \tr Aul + \tr Alr. Proof. move=> n1 n2 Aul Aur All Alr; rewrite /mx_trace; setoid_rewrite big_split_ord => /=. apply radd_morph; apply eq_bigr=> i _; [rewrite -> block_mxEul | rewrite -> block_mxElr]; reflexivity. Qed. Lemma mulmx_paste : forall m n p1 p2 (A : 'M_(m, n)) (B1 : 'M_(n, p1)) (B2 : 'M_(n, p2)), A *m (pastemx B1 B2) === pastemx (A *m B1) (A *m B2). Proof. by move=> m n p1 p2 A B1 B2 i k; rewrite/pastemx/mulmx; case defk: (split k) => [k1 | k2]; apply eq_bigr=> j _; reflexivity. Qed. Lemma dotmx_paste : forall m n1 n2 p A1 A2 B1 B2, (pastemx A1 A2 : 'M_(m, n1 + n2)) *m (pastemx B1 B2 : 'M_(p, n1 + n2))^T === A1 *m B1^T +m A2 *m B2^T. Proof. move=> m n1 n2 p A1 A2 B1 B2 i k; rewrite/mulmx/addmx/trmx; setoid_rewrite big_split_ord. by apply radd_morph; apply eq_bigr=> j _; [rewrite -> pastemxEl, pastemxEl | rewrite -> pastemxEr, pastemxEr]; reflexivity. Qed. End MatrixOpsDef. Notation "'0m" := (@null_mx _ _ _ _ _ _ _ _ _ _ _ _). Notation "-m A" := (oppmx A). Notation "A +m B" := (addmx A B). Notation "A -m B" := (addmx A (oppmx B)). Notation "x *m: A" := (scalemx x A). Notation "x %:M" := (scalar_mx x). Notation "A *m B" := (mulmx A B). Notation "'\tr' A" := (mx_trace A). Section TrMul. Context `{r_ring : Ring}. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "\sum_ ( <- r | P ) F" := (\big[radd/0]_(<- r | P) F). Notation "\sum_ ( i <- r | P ) F" := (\big[radd/0]_(i <- r | P) F). Notation "\sum_ ( i <- r ) F" := (\big[radd/0]_(i <- r) F). Notation "\sum_ ( m <= i < n | P ) F" := (\big[radd/0]_(m <= i < n | P) F). Notation "\sum_ ( m <= i < n ) F" := (\big[radd/0]_(m <= i < n) F). Notation "\sum_ ( i | P ) F" := (\big[radd/0]_(i | P) F). Notation "\sum_ i F" := (\big[radd/0]_i F). Notation "\sum_ ( i : t | P ) F" := (\big[radd/0]_(i : t | P) F) (only parsing). Notation "\sum_ ( i : t ) F" := (\big[radd/0]_(i : t) F) (only parsing). Notation "\sum_ ( i < n | P ) F" := (\big[radd/0]_(i < n | P) F). Notation "\sum_ ( i < n ) F" := (\big[radd/0]_(i < n) F). Notation "\sum_ ( i \in A | P ) F" := (\big[radd/0]_(i \in A | P) F). Notation "\sum_ ( i \in A ) F" := (\big[radd/0]_(i \in A) F). Notation "\prod_ ( <- r | P ) F" := (\big[rmul/1]_(<- r | P) F). Notation "\prod_ ( i <- r | P ) F" := (\big[rmul/1]_(i <- r | P) F). Notation "\prod_ ( i <- r ) F" := (\big[rmul/1]_(i <- r) F). Notation "\prod_ ( m <= i < n | P ) F" := (\big[rmul/1]_(m <= i < n | P) F). Notation "\prod_ ( m <= i < n ) F" := (\big[rmul/1]_(m <= i < n) F). Notation "\prod_ ( i | P ) F" := (\big[rmul/1]_(i | P) F). Notation "\prod_ i F" := (\big[rmul/1]_i F). Notation "\prod_ ( i : t | P ) F" := (\big[rmul/1]_(i : t | P) F) (only parsing). Notation "\prod_ ( i : t ) F" := (\big[rmul/1]_(i : t) F) (only parsing). Notation "\prod_ ( i < n | P ) F" := (\big[rmul/1]_(i < n | P) F). Notation "\prod_ ( i < n ) F" := (\big[rmul/1]_(i < n) F). Notation "\prod_ ( i \in A | P ) F" := (\big[rmul/1]_(i \in A | P) F). Notation "\prod_ ( i \in A ) F" := (\big[rmul/1]_(i \in A) F). Existing Instance radd_morph. Existing Instance rmul_morph. Existing Instance rsub_morph. Existing Instance ropp_morph. Existing Instance radd_assoc. Existing Instance radd_comm. Existing Instance radd_left_unit. Existing Instance rmul_assoc. Existing Instance rmul_comm. Existing Instance rmul_left_unit. Existing Instance rmul_left_zero. Existing Instance radd_rmul_left_distr. Add Ring r_r2 : r_rt (setoid r_st r_ree, preprocess [unfold Equivalence.equiv]). Existing Instance addmx_morph. Existing Instance oppmx_morph. Existing Instance mulmx_morph. Existing Instance trmx_morph. Existing Instance pastemx_morph. Existing Instance block_mx_morph. Lemma trmx_mul_rev : forall m n p (A : matrix R m n) (B : matrix R n p), (A *m B)^T === B^T *m A^T. Proof. by move=> m n p A B k i; rewrite/trmx; apply eq_bigr=> j _; ring. Qed. Lemma mulmx_block : forall m1 m2 n1 n2 p1 p2 (Aul : matrix R m1 n1) Aur All Alr Bul Bur Bll Blr, (block_mx Aul Aur All Alr : 'M_(m1 + m2, n1 + n2)) *m (block_mx Bul Bur Bll Blr : 'M_(n1 + n2, p1 + p2)) === block_mx (Aul *m Bul +m Aur *m Bll) (Aul *m Bur +m Aur *m Blr) (All *m Bul +m Alr *m Bll) (All *m Bur +m Alr *m Blr). Proof. move=> m1 m2 n1 n2 p1 p2 Aul Aur All Alr Bul Bur Bll Blr/=; rewrite <- (trmxK (_ *m _)). rewrite -> trmx_mul_rev, (trmx_block Aul); rewrite /block_mx; rewrite -> (trmxK (pastemx _ _)), dotmx_paste, <- !addmx_paste. by rewrite -> !trmx_add, (trmxK _), (trmxK _), <- addmx_paste, !mulmx_paste, <- !trmx_mul_rev, !mulmx_paste; reflexivity. Qed. Lemma mul_mx_tperm : forall m n (A : matrix R m n) i1 i2, A *m (tperm_mx i1 i2) === cswap i1 i2 A. Proof. move=> m n A i1 i2; apply: trmx_inj. by rewrite -> trmx_mul_rev, trmx_tperm, mul_tperm_mx, trmx_cswap; reflexivity. Qed. End TrMul. Section ComMatrix. Context `{r_ring : Ring}. Notation "0" := rO. Notation "1" := rI. Notation "x + y" := (radd x y). Notation "x * y " := (rmul x y). Notation "x - y " := (rsub x y). Notation "- x" := (ropp x). Notation "\sum_ ( <- r | P ) F" := (\big[radd/0]_(<- r | P) F). Notation "\sum_ ( i <- r | P ) F" := (\big[radd/0]_(i <- r | P) F). Notation "\sum_ ( i <- r ) F" := (\big[radd/0]_(i <- r) F). Notation "\sum_ ( m <= i < n | P ) F" := (\big[radd/0]_(m <= i < n | P) F). Notation "\sum_ ( m <= i < n ) F" := (\big[radd/0]_(m <= i < n) F). Notation "\sum_ ( i | P ) F" := (\big[radd/0]_(i | P) F). Notation "\sum_ i F" := (\big[radd/0]_i F). Notation "\sum_ ( i : t | P ) F" := (\big[radd/0]_(i : t | P) F) (only parsing). Notation "\sum_ ( i : t ) F" := (\big[radd/0]_(i : t) F) (only parsing). Notation "\sum_ ( i < n | P ) F" := (\big[radd/0]_(i < n | P) F). Notation "\sum_ ( i < n ) F" := (\big[radd/0]_(i < n) F). Notation "\sum_ ( i \in A | P ) F" := (\big[radd/0]_(i \in A | P) F). Notation "\sum_ ( i \in A ) F" := (\big[radd/0]_(i \in A) F). Notation "\prod_ ( <- r | P ) F" := (\big[rmul/1]_(<- r | P) F). Notation "\prod_ ( i <- r | P ) F" := (\big[rmul/1]_(i <- r | P) F). Notation "\prod_ ( i <- r ) F" := (\big[rmul/1]_(i <- r) F). Notation "\prod_ ( m <= i < n | P ) F" := (\big[rmul/1]_(m <= i < n | P) F). Notation "\prod_ ( m <= i < n ) F" := (\big[rmul/1]_(m <= i < n) F). Notation "\prod_ ( i | P ) F" := (\big[rmul/1]_(i | P) F). Notation "\prod_ i F" := (\big[rmul/1]_i F). Notation "\prod_ ( i : t | P ) F" := (\big[rmul/1]_(i : t | P) F) (only parsing). Notation "\prod_ ( i : t ) F" := (\big[rmul/1]_(i : t) F) (only parsing). Notation "\prod_ ( i < n | P ) F" := (\big[rmul/1]_(i < n | P) F). Notation "\prod_ ( i < n ) F" := (\big[rmul/1]_(i < n) F). Notation "\prod_ ( i \in A | P ) F" := (\big[rmul/1]_(i \in A | P) F). Notation "\prod_ ( i \in A ) F" := (\big[rmul/1]_(i \in A) F). Existing Instance radd_morph. Existing Instance rmul_morph. Existing Instance rsub_morph. Existing Instance ropp_morph. Existing Instance radd_assoc. Existing Instance radd_comm. Existing Instance radd_left_unit. Existing Instance rmul_assoc. Existing Instance rmul_comm. Existing Instance rmul_left_unit. Existing Instance rmul_left_zero. Existing Instance radd_rmul_left_distr. Add Ring r_r3 : r_rt (setoid r_st r_ree, preprocess [unfold Equivalence.equiv]). Existing Instance addmx_morph. Existing Instance oppmx_morph. Existing Instance mulmx_morph. Existing Instance trmx_morph. Existing Instance pastemx_morph. Existing Instance block_mx_morph. Lemma trmx_mul : forall m n p (A : matrix R m n) (B : 'M_(n, p)), (A *m B)^T === B^T *m A^T. Proof. move=> m n p A B; rewrite -> trmx_mul_rev; rewrite /mulmx=> k i. by apply (eq_bigr (I:=ordinal_finType n)) => j _; reflexivity. Qed. Lemma scalemxAr : forall m n p a (A : matrix R m n) (B : 'M_(n, p)), a *m: (A *m B) === A *m (a *m: B). Proof. move=> m n p a A B; apply trmx_inj. by rewrite -> trmx_scale, !trmx_mul, trmx_scale, scalemxAl; reflexivity. Qed. Lemma scalar_mx_comm : forall (n : pos_nat) a (A : matrix R n n), A *m (a%:M) === (a%:M) *m A. Proof. move=> n a A; apply: trmx_inj; rewrite -> trmx_mul, trmx_scalar. by rewrite -> !mulmx_scalar, trmx_scale; reflexivity. Qed. Lemma mx_trace_mulC : forall m n (A : matrix R m n) B, \tr (A *m B) === \tr (B *m A). Proof. move=> m n A B; transitivity (\sum_(i < m) \sum_(j < n) A i j * B j i). by apply eq_bigr; reflexivity. setoid_rewrite (exchange_big (I:=ordinal_finType m)); apply eq_bigr => i _. by apply eq_bigr => j _; ring. Qed. Local Notation "x ^+ n" := (iter n (rmul x) 1). (* The determinant, in one line. *) Definition determinant n (A : matrix R n n) := \big[radd/0]_(s : 'S_n) ((-(1:R)) ^+ s * \prod_(i < n) A i (s i)). Global Instance determinant_morph n : Morphism (Equivalence.equiv==>Equivalence.equiv) (@determinant n). Proof. move=> n A B eqAB; rewrite /determinant; apply eq_bigr => s _. apply rmul_morph; first by reflexivity. by apply eq_bigr => i _; apply eqAB. Qed. Notation "'\det' A" := (determinant A). Definition cofactor n A (i j : 'I_n) : R := (-(1:R)) ^+ (i + j) * \det (mx_row' i (mx_col' j A)). Definition adjugate n A := \matrix_(i, j < n) (cofactor A j i : R). Lemma determinant_multilinear : forall n (A B C : 'M_n) i0 b c, mx_row i0 A === b *m: mx_row i0 B +m c *m: mx_row i0 C -> mx_row' i0 B === mx_row' i0 A -> mx_row' i0 C === mx_row' i0 A -> \det A === b * \det B + c * \det C. Proof. move=> n A B C i0 b c; rewrite <- (mx_row_id (_ +m _)); move/mx_row_eq=> ABC. move/mx_row'_eq=> BA; move/mx_row'_eq=> CA; rewrite/determinant. setoid_rewrite (big_distrr _ b); setoid_rewrite (big_distrr _ c). rewrite <- big_split; apply eq_bigr => s _ /=. have Heq : forall x y z, req (b * (z * x) + c * (z * y)) (z * (b * x + c * y)) by move=> x y z; ring. rewrite -> Heq. apply rmul_morph; first by reflexivity. setoid_rewrite (bigD1 (j:=i0))=>//=. rewrite -> (ABC _). rewrite/mx_row/addmx/scalemx. transitivity ((b * B i0 (s i0)) * \prod_(i < n | i != i0) A i (s i) + c * (C i0 (s i0) * \prod_(i < n | i != i0) A i (s i))). set tmp := reducebig _ _ _ _ _; ring. apply radd_morph. ring_simplify; apply rmul_morph; first by reflexivity. by apply eq_bigr => i neq; symmetry; apply BA. ring_simplify; apply rmul_morph; first by reflexivity. by apply eq_bigr => i neq; symmetry; apply CA. Qed. Lemma alternate_determinant : forall n (A : 'M_n) i1 i2, i1 != i2 -> A i1 === A i2 -> \det A === 0. Proof. move=> n A i1 i2 Di12 A12; pose r := 'I_n. pose t := tperm i1 i2; pose tr s := (t * s)%g. have trK : involutive tr by move=> s; rewrite /tr mulgA tperm2 mul1g. rewrite /(\det _). setoid_rewrite (bigID (index_enum (perm_for_finType (ordinal_finType n))) (fun s => (s : bool))) => /=. set S1 := reducebig _ _ _ _ _; set T := S1 + _. have: req (S1 + (- S1)) 0 by ring. move => eq; rewrite <- eq; clear eq. apply radd_morph; first by reflexivity. rewrite {T}/S1. setoid_rewrite (big_morph (op2:=radd) (idx2:=0) (phi:=ropp)); [|by move=> x y; ring|by ring|by apply radd_morph]. setoid_rewrite (reindex (h:=tr)) at 1 => /=; last by exists tr => ? _. symmetry; apply eq_big => [s | s seven]. by rewrite /tr odd_permM odd_tperm Di12 negbK. rewrite odd_permM odd_tperm Di12 seven=> /=; ring_simplify. setoid_rewrite (reindex (h:=t)) at 1=>/=; last by exists (t : _ -> _) => i _; exact: tpermK. apply eq_bigr => i _; rewrite permM /t. by case: tpermP=> [H|H|H1 H2]; [rewrite -> H, (A12 _)|rewrite -> H, (A12 _)|]; reflexivity. Qed. Lemma det_trmx : forall n (A : 'M_n), \det A^T === \det A. Proof. move=> n A; pose r := 'I_n; pose ip p : 'S_n := p^-1%g. rewrite /(\det _). setoid_rewrite (reindex (h:=ip)) at 1 => /=; last first. by exists ip => s _; rewrite /ip invgK. apply eq_bigr => s _; rewrite !odd_permV /=. apply rmul_morph; first by reflexivity. setoid_rewrite (reindex (h:=s)) at 1. apply eq_bigr => i _; rewrite permK /trmx; reflexivity. by exists (s^-1%g : _ -> _) => i _; rewrite ?permK ?permKV. Qed. Lemma det_perm_mx : forall n (s : 'S_n), \det (perm_mx s) === (-(1:R)) ^+s. Proof. move=> n s; rewrite /(\det _); setoid_rewrite (bigD1 (j:=s))=>//=. setoid_rewrite (big1 (I:=perm_for_finType (ordinal_finType n))). rewrite/perm_mx; setoid_rewrite (big1 (I:=ordinal_finType n)); first by ring. by move=> i _; rewrite eq_refl; reflexivity. move=> t neq; rewrite/perm_mx. have Heq : req (\prod_(i < n) (if s i == t i then 1 else 0)) 0; last by rewrite -> Heq; ring. case: (pickP (fun i => s i != t i)) => [i ist | Est]. by setoid_rewrite (bigD1 (j:=i))=>//; rewrite (negbTE ist); ring. by case/eqP:neq; apply/permP=>i; apply/eqP; move:(Est i); rewrite eq_sym; apply negbFE. Qed. Lemma det1 : forall n, \det (1%:M : matrix R n n) === 1. Proof. move=> n; rewrite <- perm_mx1, det_perm_mx, odd_perm1. by rewrite/iter/=; reflexivity. Qed. Lemma det_scalemx : forall n x (A : 'M_n), \det (x *m: A) === x ^+ n * \det A. Proof. move=> n x A; rewrite/determinant. setoid_rewrite (big_distrr (I:=perm_for_finType (ordinal_finType n)))=>/=. apply eq_bigr => s _; ring_simplify. setoid_rewrite <- rmul_assoc; apply rmul_morph; first by reflexivity. rewrite/scalemx; setoid_rewrite <- (card_ord n) at 4. setoid_rewrite big_split; apply rmul_morph; last by reflexivity. by rewrite <- big_const; apply eq_bigr; reflexivity. Qed. Lemma det_mulmx : forall n (A B : 'M_n), \det (A *m B) === \det A * \det B. Proof. move=> n A B. pose AB (f : {ffun _}) := \matrix_(i, j) (A i (f i) * B (f i) j). transitivity (\sum_f \det (AB f)). rewrite{2}/determinant. setoid_rewrite (exchange_big (I:=finfun_of_finType (ordinal_finType n) (ordinal_finType n))). apply eq_bigr => /= s _. rewrite <- big_distrr => /=; apply rmul_morph; first by reflexivity. rewrite/mulmx. setoid_rewrite (bigA_distr_bigA (I:=ordinal_finType n)). by apply eq_bigr=>s' _; reflexivity. pose P_inj := fun f : {ffun 'I_n -> 'I_n} => injectiveb f. setoid_rewrite (bigID _ P_inj xpredT (fun f => \det (AB f)))=> /=. setoid_rewrite (big1 (I:=finfun_of_finType (ordinal_finType n) (ordinal_finType n))) at 2=>[|f]; last first. rewrite{}/P_inj; case/injectivePn=>i0;case=>j0 neq eq; rewrite{}/AB /determinant. setoid_rewrite big_split; setoid_rewrite rmul_comm at 2; setoid_rewrite rmul_assoc. rewrite <- big_distrl; rewrite -/(\det \matrix_(i,j) B (f i) j). by rewrite -> (alternate_determinant neq)=>[|i]; [ring|rewrite eq; reflexivity]. setoid_rewrite (reindex (J:=perm_for_finType (ordinal_finType n)) (h:=fun s => pval s)); last first. have s0 : 'S_n := 1%g; pose uf (f : {ffun 'I_n -> 'I_n}) := uniq (val f). exists (insubd s0) => /= f Uf; first apply: val_inj; exact: insubdK. setoid_rewrite (eq_bigl (I:=perm_for_finType (ordinal_finType n)) (P1:=fun j => P_inj (pval j)) (P2:=predT) _ (fun j => \det (AB (pval j)))); last by case. rewrite{2}/determinant=>{P_inj}; setoid_rewrite (big_distrl _ (\det _)). ring_simplify; apply eq_bigr=>s _; rewrite{}/AB (pvalE s) {2}/determinant. setoid_rewrite big_distrr. transitivity (\sum_(s' : 'S_n) (- (1)) ^+ s * (- rI) ^+ s' * (\prod_(i < n) A i (s i) * \prod_(i < n) B i (s' i))); last by apply eq_bigr=> j _; ring. have : forall s' : 'S_n, req ((- rI) ^+ s * (- rI) ^+ s') ((-rI) ^+ (s * s')%g). by move=>s'; rewrite odd_permM; case: (odd_perm s); case: (odd_perm s')=>/=; ring. move=>eq_puiss; setoid_rewrite eq_puiss; clear eq_puiss. setoid_rewrite (reindex (h:=fun t => (s^-1%g * t)%g)); last first. by exists [eta mulg s]=>s' _ /=; [apply (mulKVg s s') | apply (mulKg s s')]. apply eq_bigr=> s' _; rewrite (mulKVg s s'); apply rmul_morph; first by reflexivity. setoid_rewrite (reindex (h:=s)) at 3; last by exists (s^-1)%g=>i _; [rewrite permK|rewrite permKV]. setoid_rewrite big_split; apply rmul_morph; first by reflexivity. by apply eq_bigr=>i _; rewrite -permM (mulKVg s s'); reflexivity. Qed. Definition lift_perm_fun n i j (s : 'S_n) k := if @unlift n.+1 i k is Some k' then @lift n.+1 j (s k') else j. Lemma lift_permK : forall n i j s, cancel (@lift_perm_fun n i j s) (lift_perm_fun j i s^-1%g). Proof. move=> n i j s k; rewrite /lift_perm_fun. by case: (unliftP i k) => [j'|] ->; rewrite (liftK, unlift_none) ?permK. Qed. Definition lift_perm n i j s := perm (can_inj (@lift_permK n i j s)). Lemma lift_perm_id : forall n i j s, lift_perm i j s i = j :> 'I_n.+1. Proof. by move=> n i j s; rewrite permE /lift_perm_fun unlift_none. Qed. Lemma lift_perm_lift : forall n i j s k, lift_perm i j s (lift i k) = lift j (s k) :> 'I_n.+1. Proof. by move=> n i j s k; rewrite permE /lift_perm_fun liftK. Qed. Lemma lift_permM : forall n i j k s t, (@lift_perm n i j s * lift_perm j k t)%g = lift_perm i k (s * t)%g. Proof. move=> n i j k s t; apply/permP=> i1; case: (unliftP i i1) => [i2|] ->{i1}. by rewrite !(permM, lift_perm_lift). by rewrite permM !lift_perm_id. Qed. Lemma lift_perm1 : forall n i, @lift_perm n i i 1 = 1%g. Proof. by move=> n i; apply: (mulgI (lift_perm i i 1)); rewrite lift_permM !mulg1. Qed. Lemma lift_permV : forall n i j s, (@lift_perm n i j s)^-1%g = lift_perm j i s^-1. Proof. by move=> n i j s; apply/eqP; rewrite eq_invg_mul lift_permM mulgV lift_perm1. Qed. Lemma odd_lift_perm : forall n i j s, @lift_perm n i j s = odd i (+) odd j (+) s :> bool. Proof. move=> n i j s; rewrite -{1}(mul1g s) -(lift_permM _ j) odd_permM. congr (_ (+) _); last first. case: (prod_tpermP s) => ts ->{s} _. elim: ts => [|t ts IHts] /=; first by rewrite bigops.big_nil lift_perm1 !odd_perm1. rewrite bigops.big_cons odd_mul_tperm -(lift_permM _ j) odd_permM {}IHts //. congr (_ (+) _); rewrite (_ : _ j _ = tperm (lift j t.1) (lift j t.2)). by rewrite odd_tperm (inj_eq (@lift_inj _ _)). apply/permP=> k; case: (unliftP j k) => [k'|] ->. rewrite lift_perm_lift inj_tperm //; exact: lift_inj. by rewrite lift_perm_id tpermD // eq_sym neq_lift. suff{i j s} odd_lift0: forall k : 'I_n.+1, lift_perm ord0 k 1 = odd k :> bool. rewrite -!odd_lift0 -{2}invg1 -lift_permV odd_permV -odd_permM. by rewrite lift_permM mulg1. move=> k; elim: {k}(k : nat) {1 3}k (erefl (k : nat)) => [|m IHm] k def_k. rewrite (_ : k = ord0) ?lift_perm1 ?odd_perm1 //; exact: val_inj. have le_mn: m < n.+1 by [rewrite -def_k ltnW]; pose j := Ordinal le_mn. rewrite -(mulg1 1)%g -(lift_permM _ j) odd_permM {}IHm // addbC. rewrite (_ : _ k _ = tperm j k). by rewrite odd_tperm neq_ltn def_k leqnn. apply/permP=> i; case: (unliftP j i) => [i'|] ->; last first. by rewrite lift_perm_id tpermL. apply: ord_inj; rewrite lift_perm_lift !permE /= eq_sym -if_neg neq_lift. rewrite fun_if -val_eqE /= def_k /bump ltn_neqAle andbC. case: leqP => [_ | lt_i'm] /=; last by rewrite -if_neg neq_ltn leqW. by rewrite add1n eqSS eq_sym; case: eqP. Qed. Lemma expand_cofactor : forall n (A : 'M_n) i j, cofactor A i j === \sum_(s : 'S_n | s i == j) (-(1:R)) ^+ s * \prod_(k | i != k) A k (s k). Proof. move=> [_ [] //|n] A i0 j0; setoid_rewrite (reindex (h:=lift_perm i0 j0)); last first. pose ulsf i (s : 'S_n.+1) k := odflt k (unlift (s i) (s (lift i k))). have ulsfK: forall i (s : 'S__) k, lift (s i) (ulsf i s k) = s (lift i k). rewrite /ulsf => i s k; have:= neq_lift i k. by rewrite -(inj_eq (@perm_inj _ s)); case/unlift_some=> ? ? ->. have inj_ulsf: injective (ulsf i0 _). move=> s; apply: can_inj (ulsf (s i0) s^-1%g) _ => k'. by rewrite {1}/ulsf ulsfK !permK liftK. exists (fun s => perm (inj_ulsf s)) => [s _ | s]. by apply/permP=> k'; rewrite permE /ulsf lift_perm_lift lift_perm_id liftK. move/(s _ =P _) => si0; apply/permP=> k. case: (unliftP i0 k) => [k'|] ->; rewrite ?lift_perm_id //. by rewrite lift_perm_lift -si0 permE ulsfK. rewrite /cofactor /determinant. setoid_rewrite (big_distrr (I:=perm_for_finType (ordinal_finType (predn (S n)))))=> /=. apply eq_big => [s | s _]; first by rewrite lift_perm_id eqxx. have Heq : forall i, req ((-rI) ^+ i) ((-rI) ^+ (odd i)). elim=>[|i]//=; first by reflexivity. by case: (odd i)=>/= H; simpl; ring_simplify; rewrite -> H; ring. rewrite -> Heq, odd_lift_perm, <- odd_add, (Rmul_assoc r_rt). apply rmul_morph; first by case: (odd (i0 + j0)); case (odd_perm s)=>//=; ring. case: (pickP 'I_n) => [k0 _ | n0]; last first. setoid_rewrite (big1 (I:=ordinal_finType n))=>[|i _]; last by have:= n0 i. setoid_rewrite (big1 (I:=ordinal_finType (S n)))=>[|j]; first by reflexivity. by case/unlift_some=> i; have:= n0 i. setoid_rewrite (reindex (h:=lift i0)). apply eq_big => [k | k _] /=; first by rewrite neq_lift //. by rewrite lift_perm_lift; reflexivity. exists (fun k => odflt k0 (unlift i0 k)) => k; first by rewrite liftK. by case/unlift_some=> k' -> ->. Qed. Lemma expand_det_row : forall n (A : 'M_n) i0, \det A === \sum_j A i0 j * cofactor A i0 j. Proof. move=> n A i0; rewrite /(\det A). setoid_rewrite (partition_big (P:=predT) (p:=fun s : 'S_n => s i0) (Q:=predT))=>//. apply eq_bigr => j0 _; rewrite -> expand_cofactor. setoid_rewrite (big_distrr _ (A i0 j0)). apply eq_bigr => s; move/eqP=> Dsi0. setoid_rewrite (bigID _ (pred1 i0)) at 1=>/=. setoid_rewrite (big_pred1_eq (I:=ordinal_finType n)). rewrite Dsi0; ring_simplify. apply rmul_morph; first by reflexivity. by apply eq_bigl=>i; rewrite eq_sym. Qed. Lemma cofactor_tr : forall n (A : 'M_n) i j, cofactor A^T i j === cofactor A j i. Proof. move=> n A i j; rewrite /cofactor addnC. apply rmul_morph; first by reflexivity. rewrite <- det_trmx; apply determinant_morph. by apply trmx_inj=>i' j'; apply trmxK. Qed. Lemma expand_det_col : forall n (A : 'M_n) j0, \det A === \sum_i (A i j0 * cofactor A i j0). Proof. move=> n A j0; rewrite <- det_trmx, (expand_det_row _ j0). by apply eq_bigr => i _; rewrite -> cofactor_tr; reflexivity. Qed. Lemma mulmx_adjr : forall n (A : 'M_n), A *m adjugate A === (\det A)%:M. Proof. rewrite/scalar_mx=> n A i1 i2; case Di: (i1 == i2). rewrite -> (eqP Di), (expand_det_row _ i2)=> //=. by apply eq_bigr => j _; apply rmul_morph; reflexivity. pose B := \matrix_(i, j) (if i == i2 then A i1 j else A i j). have EBi12: pointwise_relation 'I_n req (B i1) (B i2). by rewrite /B Di eq_refl=>j; reflexivity. rewrite <- (alternate_determinant (negbT Di) EBi12) at 2. rewrite -> (expand_det_row _ i2); apply eq_bigr => j _. rewrite /B eq_refl; apply rmul_morph; first by reflexivity. rewrite/adjugate/cofactor; apply rmul_morph; first by reflexivity. apply eq_bigr => s _; apply rmul_morph; first by reflexivity. apply eq_bigr => i _; rewrite /mx_row' /mx_col'. by rewrite eq_sym -if_neg neq_lift; reflexivity. Qed. Lemma trmx_adj : forall n (A : 'M_n), (adjugate A)^T === adjugate A^T. Proof. by move=> n A i j; rewrite /adjugate; rewrite -> cofactor_tr; rewrite /trmx; reflexivity. Qed. Lemma mulmx_adjl : forall n (A : 'M_n), adjugate A *m A === (\det A)%:M. Proof. move=> n A; apply trmx_inj; rewrite -> trmx_mul, trmx_adj, mulmx_adjr. by rewrite -> det_trmx, trmx_scalar; reflexivity. Qed. Lemma detM : forall (n : pos_nat) (A B : 'M_n), \det (A *m B) === \det A * \det B. Proof. move=> n; exact: det_mulmx. Qed. Lemma det_scalar : forall n a, \det (a%:M : 'M_n) === a ^+ n. Proof. move=> n a. transitivity ((a ^+ n) * rI); last by ring. setoid_rewrite <- (det1 n) at 3; setoid_rewrite <- det_scalemx. apply determinant_morph; rewrite <- mulmx_scalar; rewrite <- scalar_mx_mul. by apply scalar_mx_morph; ring. Qed. Lemma det_scalar1 : forall a, \det (a%:M : 'M_1) === a. Proof. by move=>a; rewrite -> (det_scalar 1 a)=> /=; ring. Qed. Lemma det_ublock : forall n1 n2 (Aul : 'M_(n1, n1)) (Aur : 'M_(n1, n2)) (Alr : 'M_(n2, n2)), \det (block_mx Aul Aur (@null_mx _ _ _ _ _ _ _ _ _ _ _ _) Alr : 'M_(n1 + n2)) === \det Aul * \det Alr. Proof. move=> n1 n2 Aul Aur Alr; elim: n1 => [|n1 IHn1] in Aul Aur *. have Heq : req (\det Aul) 1. by rewrite <- det1; apply determinant_morph; case. rewrite -> Heq; ring_simplify; apply determinant_morph=> i j; rewrite/block_mx/pastemx/trmx. case:splitP; [ by case | move=>i'; move/val_inj ->]. by case:splitP; [ case | move=> j'; move/val_inj ->; reflexivity]. rewrite -> (expand_det_col (block_mx Aul _ _ _) (lshift n2 ord0)). setoid_rewrite big_split_ord=>/=. setoid_rewrite (Radd_comm (r_rt (Ring:=r_ring))). setoid_rewrite (big1 (I:= ordinal_finType n2))=>[|i _]; last first. by rewrite -> block_mxEll; rewrite /null_mx; ring. setoid_rewrite (Radd_0_l (r_rt (Ring:=r_ring))). setoid_rewrite (expand_det_col Aul ord0). setoid_rewrite big_distrl. apply eq_bigr=>i _; rewrite -> block_mxEul. setoid_rewrite <- Rmul_assoc; last by apply r_ring. apply rmul_morph; first by reflexivity. rewrite/cofactor; rewrite <- (Rmul_assoc r_rt). rewrite <- (IHn1 (mx_row' i (mx_col' ord0 Aul)) (mx_row' i Aur)). have -> : (addn (nat_of_ord i) (@nat_of_ord (S n1) ord0) = nat_of_ord i) by done. apply rmul_morph; first by reflexivity. apply determinant_morph; rewrite {2}/block_mx; rewrite <- (mx_row'_paste i), (trmx_row' i). rewrite <- (mx_col'_lshift i), (trmx_col' (lshift n2 i)); apply (mx_row'_morph (lshift n2 i)). rewrite <- (mx_col'_lshift ord0 Aul), (trmx_col' (lshift n2 ord0) (pastemx Aul Aur)). rewrite /block_mx; rewrite <- trmx_row', mx_row'_paste; apply trmx_morph. apply pastemx_morph; first by reflexivity. rewrite <- trmx_col'; apply trmx_morph; rewrite -> mx_col'_lshift. apply pastemx_morph; last by reflexivity. by move=> i' j'; rewrite/mx_col'/lift/null_mx; reflexivity. Qed. Lemma det_lblock : forall n1 n2 Aul All Alr, \det (block_mx Aul '0m All Alr : 'M_(n1 + n2)) === \det Aul * \det Alr. Proof. move=> n1 n2 Aul All Alr. by rewrite <- det_trmx, trmx_block, trmx0, det_ublock, !det_trmx; reflexivity. Qed. End ComMatrix. Notation "\det A" := (determinant A). Notation "\adj A" := (adjugate A). corn-8.20.0/classes/000077500000000000000000000000001473720167500142135ustar00rootroot00000000000000corn-8.20.0/classes/Qclasses.v000066400000000000000000000011551473720167500161620ustar00rootroot00000000000000Require Import CoRN.model.totalorder.QMinMax MathClasses.interfaces.orders MathClasses.interfaces.abstract_algebra MathClasses.orders.minmax. Require Export MathClasses.implementations.stdlib_rationals. Lemma Qmin_coincides x y : Qmin x y = x ⊓ y. Proof. destruct (total (≤) x y). rewrite lattices.meet_l by easy. now apply Qle_min_l. rewrite lattices.meet_r by easy. now apply Qle_min_r. Qed. Lemma Qmax_coincides x y : Qmax x y = x ⊔ y. Proof. destruct (total (≤) x y). rewrite lattices.join_r by easy. now apply Qle_max_r. rewrite lattices.join_l by easy. now apply Qle_max_l. Qed. corn-8.20.0/classes/Qposclasses.v000066400000000000000000000011131473720167500166760ustar00rootroot00000000000000(* todo: remove *) Require Export CoRN.model.structures.Qpossec. Require Import MathClasses.interfaces.abstract_algebra MathClasses.interfaces.additional_operations MathClasses.implementations.stdlib_rationals. #[global] Instance: Equiv Qpos := QposEq. #[global] Instance: One Qpos := Qpos_one. #[global] Instance: Plus Qpos := Qpos_plus. #[global] Instance: Mult Qpos := Qpos_mult. #[global] Instance: Pow Qpos Z := Qpos_power. #[global] Instance inject_Qpos_Q: Cast Qpos Q := QposAsQ. #[global] Instance: ∀ x : Qpos, PropHolds (0 < (x:Q)). Proof. intros x. now destruct x. Qed. corn-8.20.0/complex/000077500000000000000000000000001473720167500142255ustar00rootroot00000000000000corn-8.20.0/complex/AbsCC.v000066400000000000000000000364651473720167500153450ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.complex.CComplex. (** * Absolute value on [CC] ** Properties of [AbsCC] *) Section AbsCC_properties. Lemma AbsCC_nonneg : forall x : CC, [0] [<=] AbsCC x. Proof. unfold AbsCC in |- *. intros. apply sqrt_nonneg. Qed. Lemma AbsCC_ap_zero_imp_pos : forall z : CC, AbsCC z [#] [0] -> [0] [<] AbsCC z. Proof. intros z H. apply leEq_not_eq. apply AbsCC_nonneg. apply ap_symmetric_unfolded. assumption. Qed. Lemma AbsCC_wd : forall x y : CC, x [=] y -> AbsCC x [=] AbsCC y. Proof. intros x y. elim x. intros x1 x2. elim y. intros y1 y2. simpl in |- *. unfold cc_eq in |- *. unfold AbsCC in |- *. simpl in |- *. intros. change (sqrt (x1[^]2[+]x2[^]2) (cc_abs_aid _ x1 x2) [=] sqrt (y1[^]2[+]y2[^]2) (cc_abs_aid _ y1 y2)) in |- *. elim H. clear H. intros. apply sqrt_wd. algebra. Qed. Hint Resolve AbsCC_wd: algebra_c. Lemma cc_inv_abs : forall x : CC, AbsCC [--]x [=] AbsCC x. Proof. intros. unfold AbsCC in |- *. apply sqrt_wd. apply bin_op_wd_unfolded. Step_final ( [--] (Re x) [^]2). Step_final ( [--] (Im x) [^]2). Qed. Hint Resolve cc_inv_abs: algebra. Lemma cc_minus_abs : forall x y : CC, AbsCC (x[-]y) [=] AbsCC (y[-]x). Proof. intros. apply eq_transitive_unfolded with (AbsCC [--] (y[-]x)). apply AbsCC_wd. rational. apply cc_inv_abs. Qed. Lemma cc_mult_abs : forall x y : CC, AbsCC (x[*]y) [=] AbsCC x[*]AbsCC y. Proof. intros x y. elim x. intros x1 x2. elim y. intros y1 y2. intros. unfold AbsCC in |- *. apply sqrt_mult_wd. simpl in |- *. rational. Qed. Hint Resolve cc_mult_abs: algebra. Lemma AbsCC_minzero : forall x : CC, AbsCC (x[-][0]) [=] AbsCC x. Proof. intros. apply AbsCC_wd. algebra. Qed. Lemma AbsCC_IR : forall x : IR, [0] [<=] x -> AbsCC (cc_IR x) [=] x. Proof. intros. unfold AbsCC in |- *. change (sqrt (x[^]2[+][0][^]2) (cc_abs_aid _ x [0]) [=] x) in |- *. apply eq_transitive_unfolded with (sqrt (x[^]2) (sqr_nonneg _ x)). apply sqrt_wd. rational. apply sqrt_to_nonneg. auto. Qed. Hint Resolve AbsCC_IR: algebra. Lemma cc_div_abs : forall (x y : CC) y_ y__, AbsCC (x[/] y[//]y_) [=] (AbsCC x[/] AbsCC y[//]y__). Proof. intros x y nz anz. rstepl (AbsCC y[*]AbsCC (x[/] y[//]nz) [/] AbsCC y[//]anz). apply div_wd. 2: algebra. astepl (AbsCC (y[*] (x[/] y[//]nz))). apply AbsCC_wd. rational. Qed. Lemma cc_div_abs' : forall (x : CC) (y : IR) y_ y__, [0] [<=] y -> AbsCC (x[/] cc_IR y[//]y__) [=] (AbsCC x[/] y[//]y_). Proof. intros x y nz cnz H. rstepl (y[*]AbsCC (x[/] cc_IR y[//]cnz) [/] y[//]nz). apply div_wd. 2: algebra. astepl (AbsCC (cc_IR y) [*]AbsCC (x[/] cc_IR y[//]cnz)). astepl (AbsCC (cc_IR y[*] (x[/] cc_IR y[//]cnz))). apply AbsCC_wd. rational. Qed. Lemma AbsCC_zero : AbsCC [0] [=] [0]. Proof. astepl (AbsCC (cc_IR [0])). apply AbsCC_IR. apply leEq_reflexive. Qed. Hint Resolve AbsCC_zero: algebra. Lemma AbsCC_one : AbsCC [1] [=] [1]. Proof. astepl (AbsCC (cc_IR [1])). apply AbsCC_IR. apply less_leEq. apply pos_one. Qed. Lemma cc_pow_abs : forall (x : CC) (n : nat), AbsCC (x[^]n) [=] AbsCC x[^]n. Proof. intros. induction n as [| n Hrecn]; intros. simpl in |- *. apply AbsCC_one. simpl in |- *. Step_final (AbsCC (x[^]n) [*]AbsCC x). Qed. Lemma AbsCC_pos : forall x : CC, x [#] [0] -> [0] [<] AbsCC x. Proof. intro. elim x. intros x1 x2. unfold AbsCC in |- *. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. intros H. change ([0] [<] sqrt (x1[^]2[+]x2[^]2) (cc_abs_aid _ x1 x2)) in |- *. apply power_cancel_less with 2. apply sqrt_nonneg. astepl ZeroR. astepr (x1[^]2[+]x2[^]2). elim H; clear H; intros. apply plus_resp_pos_nonneg. apply pos_square. auto. apply sqr_nonneg. apply plus_resp_nonneg_pos. apply sqr_nonneg. apply pos_square. auto. Qed. Lemma AbsCC_ap_zero : forall x : CC, [0] [#] AbsCC x -> x [#] [0]. Proof. intro. elim x. intros x1 x2. simpl in |- *. unfold AbsCC in |- *. unfold cc_ap in |- *. change ([0] [#] sqrt (x1[^]2[+]x2[^]2) (cc_abs_aid _ x1 x2) -> x1 [#] [0] or x2 [#] [0]) in |- *. intros H. cut (x1[^]2 [#] [0] or x2[^]2 [#] [0]). intro H0. elim H0; clear H0; intros. left. apply cring_mult_ap_zero with x1. astepl (x1[^]2). auto. right. apply cring_mult_ap_zero with x2. astepl (x2[^]2). auto. apply cg_add_ap_zero. astepl (sqrt (x1[^]2[+]x2[^]2) (cc_abs_aid _ x1 x2) [^]2). apply nexp_resp_ap_zero. apply ap_symmetric_unfolded. auto. Qed. Lemma AbsCC_small_imp_eq : forall x : CC, (forall e, [0] [<] e -> AbsCC x [<] e) -> x [=] [0]. Proof. intros x H. apply not_ap_imp_eq. intro. elim (less_irreflexive_unfolded _ (AbsCC x)). apply H. apply AbsCC_pos. auto. Qed. (* begin hide *) Let l_1_1_2 : forall x y : IR, (x[+I*]y) [*] (x[+I*][--]y) [=] cc_IR (x[^]2[+]y[^]2). Proof. intros. apply calculate_norm with (x := x) (y := y). Qed. (* end hide *) Hint Resolve l_1_1_2: algebra. Lemma AbsCC_square_Re_Im : forall x y : IR, x[^]2[+]y[^]2 [=] AbsCC (x[+I*]y) [^]2. Proof. intros. unfold AbsCC in |- *. Step_final (Re (x[+I*]y) [^]2[+]Im (x[+I*]y) [^]2). Qed. Hint Resolve AbsCC_square_Re_Im: algebra. (* begin hide *) Let l_1_2_3_CC : forall x y : IR, cc_IR (x[^]2[+]y[^]2) [=] cc_IR (AbsCC (x[+I*]y) [^]2). Proof. intros. apply cc_IR_wd. apply AbsCC_square_Re_Im. Qed. (* end hide *) Hint Resolve l_1_2_3_CC: algebra. Lemma AbsCC_mult_conj : forall z : CC, z[*]CC_conj z [=] cc_IR (AbsCC z[^]2). Proof. intro z. unfold cc_IR in |- *. elim z. intros x y. apply eq_transitive_unfolded with (S := cc_csetoid) (y := cc_IR (x[^]2[+]y[^]2)). eapply l_1_1_2 with (x := x) (y := y). split; simpl in |- *. 2: algebra. eapply AbsCC_square_Re_Im with (x := x) (y := y). Qed. Hint Resolve CC_conj_mult: algebra. (* begin hide *) Lemma l_2_1_2 : forall z1 z2 : CC, cc_IR (AbsCC (z1[*]z2) [^]2) [=] z1[*]z2[*]CC_conj z1[*]CC_conj z2. Proof. intros z1 z2. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (z1[*]z2[*]CC_conj (z1[*]z2)). Step_final (z1[*]z2[*] (CC_conj z1[*]CC_conj z2)). apply AbsCC_mult_conj. Qed. Hint Resolve l_2_1_2: algebra. (* end hide *) Lemma AbsCC_mult_square : forall x y : CC, AbsCC (x[*]y) [^]2 [=] AbsCC x[^]2[*]AbsCC y[^]2. Proof. intros. rstepr ((AbsCC x[*]AbsCC y) [^]2). algebra. Qed. Lemma AbsCC_square_ap_zero : forall z : CC, z [#] [0] -> AbsCC z[^]2 [#] [0]. Proof. intros z H. stepl (Re z[^]2[+]Im z[^]2). apply (cc_inv_aid (Re z) (Im z) H). apply AbsCC_square_Re_Im with (x := Re z) (y := Im z). Qed. Lemma cc_recip_char : forall (z : CC) z_ z__, cc_recip z z_ [=] (CC_conj z[/] cc_IR (AbsCC z[^]2) [//]z__). Proof. intros z z_ HAbsCCz. unfold cc_recip in |- *. astepl (Re z[+I*][--] (Im z) [/] _[//] cc_IR_resp_ap _ _ (cc_inv_aid _ _ (cc_ap_zero _ z_))). 2: simpl in |- *; split; simpl in |- *; rational. apply div_wd with (F := CC) (x := Re z[+I*][--] (Im z)) (y := cc_IR (Re z[^]2[+]Im z[^]2)) (x' := CC_conj z) (y' := cc_IR (AbsCC z[^]2)). elim z. intros x y. simpl in |- *. split; simpl in |- *; algebra. apply cc_IR_wd. apply AbsCC_square_Re_Im with (x := Re z) (y := Im z). Qed. Lemma AbsCC_strext : fun_strext AbsCC. Proof. unfold fun_strext in |- *. intros z1 z2 H. cut (AbsCC z1[^]2 [#] AbsCC z2[^]2). elim z1. intros x1 y1. elim z2. intros x2 y2. intro H'. assert (H'' : x1[^]2[+]y1[^]2 [#] x2[^]2[+]y2[^]2). astepl (AbsCC (x1[+I*]y1) [^]2). astepr (AbsCC (x2[+I*]y2) [^]2). assumption. cut (x1[^]2 [#] x2[^]2 or y1[^]2 [#] y2[^]2). intros H'''. elim H'''; intro H0. cut (x1 [#] x2). intro H1. simpl in |- *. unfold cc_ap in |- *. unfold Re, Im in |- *. left. assumption. apply (nexp_strong_ext IR 2). assumption. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. right. apply (nexp_strong_ext IR 2). assumption. apply (bin_op_strext_unfolded _ _ _ _ _ _ H''). assert (H1 : AbsCC z1[-]AbsCC z2 [#] [0]). cut (AbsCC z1[-]AbsCC z2 [#] AbsCC z2[-]AbsCC z2). intro H0. astepr (AbsCC z2[-]AbsCC z2). assumption. apply minus_resp_ap_rht. assumption. assert (H2 : AbsCC z1[+]AbsCC z2 [#] [0]). apply Greater_imp_ap. assert (H0 : AbsCC z1 [#] [0] or [0] [#] AbsCC z2). apply ap_cotransitive_unfolded. assumption. elim H0. intro H'. assert (H'' : [0] [<] AbsCC z1). apply (AbsCC_ap_zero_imp_pos _ H'). apply leEq_less_trans with (y := AbsCC z2). apply AbsCC_nonneg. rstepl (AbsCC z2[+][0]). rstepr (AbsCC z2[+]AbsCC z1). apply plus_resp_less_lft. assumption. intro H'. assert (H'' : [0] [<] AbsCC z2). apply AbsCC_ap_zero_imp_pos. apply ap_symmetric_unfolded. assumption. apply leEq_less_trans with (y := AbsCC z1). apply AbsCC_nonneg. rstepl (AbsCC z1[+][0]). apply plus_resp_less_lft. assumption. cut (AbsCC z1[^]2[-]AbsCC z2[^]2 [#] [0]). intro H3. cut (AbsCC z1[^]2[-]AbsCC z2[^]2 [#] AbsCC z2[^]2[-]AbsCC z2[^]2). intro H4. rstepl (AbsCC z1[^]2[-]AbsCC z2[^]2[+]AbsCC z2[^]2). rstepr ([0][+]AbsCC z2[^]2). apply op_rht_resp_ap with (x := AbsCC z1[^]2[-]AbsCC z2[^]2) (y := ZeroR) (z := AbsCC z2[^]2). rstepr (AbsCC z2[^]2[-]AbsCC z2[^]2). assumption. rstepr ZeroR. assumption. astepl ((AbsCC z1[-]AbsCC z2) [*] (AbsCC z1[+]AbsCC z2)). apply mult_resp_ap_zero; assumption. Qed. Definition AbsSmallCC (e : IR) (x : CC) := AbsCC x [<=] e. Lemma Cexis_AFS_CC : forall x y eps, [0] [<] eps -> {y' : CC | AbsSmallCC eps (y'[-]y) | y' [#] x}. Proof. unfold AbsSmallCC in |- *. intros. set (e := cc_IR eps) in *. elim (ap_cotransitive_unfolded _ (y[-]e) (y[+]e)) with x; try intro H0. exists (y[-]e). apply leEq_wdl with (AbsCC [--]e). unfold e in |- *. astepl (AbsCC (cc_IR eps)). apply eq_imp_leEq. apply AbsCC_IR. apply less_leEq; auto. apply AbsCC_wd. rational. auto. exists (y[+]e). apply leEq_wdl with (AbsCC e). apply eq_imp_leEq. unfold e in |- *; apply AbsCC_IR. apply less_leEq; auto. apply AbsCC_wd. rational. apply ap_symmetric_unfolded. auto. apply zero_minus_apart. apply ap_wdl_unfolded with (cc_IR ( [--]Two[*]eps)). astepr (cc_IR [0]). apply cc_IR_resp_ap. apply mult_resp_ap_zero. apply inv_resp_ap_zero. apply two_ap_zero. apply pos_ap_zero; auto. unfold e in |- *. astepl (cc_IR [--]Two[*]cc_IR eps). rstepr ( [--]Two[*]cc_IR eps). apply mult_wdl. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; [ algebra | rational ]. Qed. (* The following lemmas are just auxiliary results *) (* begin hide *) Let l_4_1_2 : forall (z : CC) (H : z [#] [0]), z[*]cc_recip z H [=] (z[*]CC_conj z[/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H)). Proof. intros z H. apply eq_transitive_unfolded with (S := cc_csetoid) (y := z[*] (CC_conj z[/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H))). 2: algebra. astepr (z[*] (CC_conj z[/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H))). apply bin_op_wd_unfolded with (S := CC) (x1 := z) (x2 := z) (y1 := cc_recip z H) (y2 := CC_conj z[/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H)). algebra. apply cc_recip_char. generalize H. clear H. elim z. intros x y H. simpl in |- *. split; simpl in |- *; rational. Qed. Let l_4_2_3 : forall (z : CC) (H : z [#] [0]), (z[*]CC_conj z[/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H)) [=] (cc_IR (AbsCC z[^]2) [/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H)). Proof. intros z H. apply div_wd with (F := CC) (x := z[*]CC_conj z) (y := cc_IR (AbsCC z[^]2)) (x' := cc_IR (AbsCC z[^]2)) (y' := cc_IR (AbsCC z[^]2)). apply AbsCC_mult_conj. algebra. Qed. Let l_4_3_4 : forall (z : CC) (H : z [#] [0]), (cc_IR (AbsCC z[^]2) [/] _[//]cc_IR_resp_ap _ _ (AbsCC_square_ap_zero _ H)) [=] [1]. Proof. intros. rational. Qed. (* end hide *) End AbsCC_properties. #[global] Hint Resolve AbsCC_wd: algebra_c. #[global] Hint Resolve cc_inv_abs cc_mult_abs cc_div_abs cc_div_abs' cc_pow_abs AbsCC_zero AbsCC_one AbsCC_IR AbsCC_mult_conj AbsCC_mult_square cc_recip_char: algebra. (** ** The triangle inequality *) Lemma triangle : forall x y : CC, AbsCC (x[+]y) [<=] AbsCC x[+]AbsCC y. Proof. intros. elim x. intros x1 x2. elim y. intros y1 y2. unfold AbsCC in |- *. simpl in |- *. apply power_cancel_leEq with 2. auto. astepl ([0][+]ZeroR). apply plus_resp_leEq_both; apply sqrt_nonneg. astepl ([1][*](x1[+]y1)[*](x1[+]y1)[+][1][*](x2[+]y2)[*](x2[+]y2)). rstepr (sqrt ([1][*]x1[*]x1[+][1][*]x2[*]x2) (cc_abs_aid _ x1 x2)[^]2[+] sqrt ([1][*]y1[*]y1[+][1][*]y2[*]y2) (cc_abs_aid _ y1 y2)[^]2[+] Two[*]sqrt ([1][*]x1[*]x1[+][1][*]x2[*]x2) (cc_abs_aid _ x1 x2)[*] sqrt ([1][*]y1[*]y1[+][1][*]y2[*]y2) (cc_abs_aid _ y1 y2)). astepr ([1][*]x1[*]x1[+][1][*]x2[*]x2[+]([1][*]y1[*]y1[+][1][*]y2[*]y2)[+] Two[*]sqrt ([1][*]x1[*]x1[+][1][*]x2[*]x2) (cc_abs_aid _ x1 x2)[*] sqrt ([1][*]y1[*]y1[+][1][*]y2[*]y2) (cc_abs_aid _ y1 y2)). apply shift_leEq_rht. rstepr (Two[*] (sqrt ([1][*]x1[*]x1[+][1][*]x2[*]x2) (cc_abs_aid _ x1 x2)[*] sqrt ([1][*]y1[*]y1[+][1][*]y2[*]y2) (cc_abs_aid _ y1 y2)[-] (x1[*]y1[+]x2[*]y2))). apply mult_resp_nonneg. apply less_leEq. apply pos_two. apply shift_leEq_lft. apply power_cancel_leEq with 2. auto. apply mult_resp_nonneg; apply sqrt_nonneg. astepr (sqrt ([1][*]x1[*]x1[+][1][*]x2[*]x2) (cc_abs_aid _ x1 x2)[^]2[*] sqrt ([1][*]y1[*]y1[+][1][*]y2[*]y2) (cc_abs_aid _ y1 y2)[^]2). astepr (([1][*]x1[*]x1[+][1][*]x2[*]x2)[*]([1][*]y1[*]y1[+][1][*]y2[*]y2)). apply shift_leEq_rht. rstepr ((x1[*]y2[-]x2[*]y1)[^]2). apply sqr_nonneg. Qed. Lemma triangle_Sum : forall m n (z : nat -> CC), m <= S n -> AbsCC (Sum m n z) [<=] Sum m n (fun i => AbsCC (z i)). Proof. intros. induction n as [| n Hrecn]; intros. generalize (toCle _ _ H); clear H; intro H. inversion H as [|m0 H1 H2]. unfold Sum in |- *. unfold Sum1 in |- *. astepl (AbsCC [0]). astepr ZeroR. astepr (AbsCC [0]). apply leEq_reflexive. inversion H1. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. cut (AbsCC ([0][+]z 0[-][0])[<=][0][+]AbsCC (z 0)[-][0]). auto. apply eq_imp_leEq. rstepr (AbsCC (z 0)). apply AbsCC_wd. rational. elim (le_lt_eq_dec _ _ H); intro y. astepl (AbsCC (Sum m n z[+]z (S n))). apply leEq_wdr with (Sum m n (fun i : nat => AbsCC (z i))[+]AbsCC (z (S n))). apply leEq_transitive with (AbsCC (Sum m n z)[+]AbsCC (z (S n))). apply triangle. apply plus_resp_leEq. apply Hrecn. auto with arith. apply eq_symmetric_unfolded. apply Sum_last with (f := fun i : nat => AbsCC (z i)). rewrite y. unfold Sum in |- *. unfold Sum1 in |- *. astepl (AbsCC [0]). astepr ZeroR. astepr (AbsCC [0]). apply leEq_reflexive. Qed. corn-8.20.0/complex/CComplex.v000066400000000000000000000512551473720167500161360ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Re %\ensuremath{\Re}% #ℜ# *) (** printing Im %\ensuremath{\Im}% #ℑ# *) (** printing CC %\ensuremath{\mathbb C}% #C# *) (** printing II %\ensuremath{\imath}% #i# *) (** printing [+I*] %\ensuremath{+\imath}% *) (** printing AbsCC %\ensuremath{|\cdot|_{\mathbb C}}% *) (** printing CCX %\ensuremath{\mathbb C[X]}% #C[X]# *) Require Export CoRN.reals.NRootIR. (** * Complex Numbers ** Algebraic structure *) Section Complex_Numbers. Record CC_set : Type := {Re : IR; Im : IR}. Definition cc_ap (x y : CC_set) : CProp := Re x [#] Re y or Im x [#] Im y. Definition cc_eq (x y : CC_set) : Prop := Re x [=] Re y /\ Im x [=] Im y. Lemma cc_is_CSetoid : is_CSetoid _ cc_eq cc_ap. Proof. apply Build_is_CSetoid. unfold irreflexive in |- *. intros. elim x. intros x1 x2. unfold cc_ap in |- *. simpl in |- *. intro H. elim H; clear H; intros H. cut (Not (x1 [#] x1)). intros H0. elim (H0 H). apply ap_irreflexive_unfolded. cut (Not (x2 [#] x2)). intros H0. elim (H0 H). apply ap_irreflexive_unfolded. unfold Csymmetric in |- *. intros x y. elim x. intros x1 x2. elim y. intros y1 y2. unfold cc_ap in |- *. simpl in |- *. intros H. elim H; clear H; intros H. left. apply ap_symmetric_unfolded. auto. right. apply ap_symmetric_unfolded. auto. unfold cotransitive in |- *. intros x y. elim x. intros x1 x2. elim y. intros y1 y2. unfold cc_ap in |- *. simpl in |- *. intro H. intro. elim z. intros z1 z2. simpl in |- *. intros. elim H; clear H; intros H. cut (x1 [#] z1 or z1 [#] y1). intro H0. elim H0; clear H0; intros H0. left. left. auto. right. left. auto. apply ap_cotransitive_unfolded. auto. cut (x2 [#] z2 or z2 [#] y2). intro H0. elim H0; clear H0; intros H0. left. right. auto. right. right. auto. apply ap_cotransitive_unfolded. auto. unfold tight_apart in |- *. intros x y. elim x. intros x1 x2. elim y. intros y1 y2. unfold cc_ap in |- *. unfold cc_eq in |- *. simpl in |- *. split. intros. split. apply not_ap_imp_eq. intro. apply H. left. auto. apply not_ap_imp_eq. intro. apply H. right. auto. intros. elim H. clear H. intros H H0. intro H1. elim H1; clear H1; intros H1. cut (Not (x1 [#] y1)). intro. elim (H2 H1). apply eq_imp_not_ap. auto. cut (Not (x2 [#] y2)). intro. elim (H2 H1). apply eq_imp_not_ap. auto. Qed. Definition cc_csetoid := Build_CSetoid CC_set cc_eq cc_ap cc_is_CSetoid. Definition cc_plus x y := Build_CC_set (Re x[+]Re y) (Im x[+]Im y). Definition cc_mult x y := Build_CC_set (Re x[*]Re y[-]Im x[*]Im y) (Re x[*]Im y[+]Im x[*]Re y). Definition cc_zero := Build_CC_set ZeroR ZeroR. Definition cc_one := Build_CC_set OneR ZeroR. Definition cc_i := Build_CC_set ZeroR OneR. Definition cc_inv (x : CC_set) : CC_set := Build_CC_set [--] (Re x) [--] (Im x). (* not needed anymore Lemma cc_plus_op_proof : (bin_op_wd cc_csetoid cc_plus). Unfold bin_op_wd. Unfold bin_fun_wd. Intros x1 x2 y1 y2. Elim x1. Elim x2. Elim y1. Elim y2. Simpl. Unfold cc_eq. Simpl. Intros. Elim H. Clear H. Intros. Elim H0. Clear H0. Intros. Split; algebra. Qed. Lemma cc_mult_op_proof : (bin_op_wd cc_csetoid cc_mult). Unfold bin_op_wd. Unfold bin_fun_wd. Intros x1 x2 y1 y2. Elim x1. Elim x2. Elim y1. Elim y2. Simpl. Unfold cc_eq. Simpl. Intros. Elim H. Clear H. Intros. Elim H0. Clear H0. Intros. Split; algebra. Qed. Lemma cc_inv_op_proof : (un_op_wd cc_csetoid cc_inv). Unfold un_op_wd. Unfold fun_wd. Intros x y. Elim x. Elim y. Simpl. Unfold cc_eq. Simpl. Intros. Elim H. Clear H. Intros. Split; algebra. Qed. *) Lemma cc_inv_strext : un_op_strext cc_csetoid cc_inv. Proof. unfold un_op_strext in |- *. unfold fun_strext in |- *. intros x y. elim x. elim y. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. do 4 intro. intro H. elim H; clear H; intros. left. apply un_op_strext_unfolded with (cg_inv (c:=IR)). auto. right. apply un_op_strext_unfolded with (cg_inv (c:=IR)). auto. Qed. Lemma cc_plus_strext : bin_op_strext cc_csetoid cc_plus. Proof. unfold bin_op_strext in |- *. unfold bin_fun_strext in |- *. intros x1 x2 y1 y2. elim x1. elim x2. elim y1. elim y2. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. do 8 intro. intro H. elim H; clear H; intros H. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); intros. left. left. auto. right. left. auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); intros. left. right. auto. right. right. auto. Qed. Lemma cc_mult_strext : bin_op_strext cc_csetoid cc_mult. Proof. unfold bin_op_strext in |- *. unfold bin_fun_strext in |- *. intros x1 x2 y1 y2. elim x1. elim x2. elim y1. elim y2. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. do 8 intro. intro H. elim H; clear H; intros H. elim (bin_op_strext_unfolded _ (cg_minus_is_csetoid_bin_op _) _ _ _ _ H); intros H0. elim (bin_op_strext_unfolded _ _ _ _ _ _ H0); intros H1. left. left. auto. right. left. auto. cut (Im3[*]Im1 [#] Im2[*]Im0). intro H1. elim (bin_op_strext_unfolded _ _ _ _ _ _ H1); intros H2. left. right. auto. right. right. auto. auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); intros H0. elim (bin_op_strext_unfolded _ _ _ _ _ _ H0); intros H1. left. left. auto. right. right. auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ H0); intros. left. right. auto. right. left. auto. Qed. Definition cc_inv_op := Build_CSetoid_un_op _ _ cc_inv_strext. Definition cc_plus_op := Build_CSetoid_bin_op _ _ cc_plus_strext. Definition cc_mult_op := Build_CSetoid_bin_op _ _ cc_mult_strext. Lemma cc_csg_associative : associative cc_plus_op. Proof. unfold associative in |- *. intros. elim x. elim y. elim z. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Lemma cc_cr_mult_associative : associative cc_mult_op. Proof. unfold associative in |- *. intros. elim x. elim y. elim z. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Definition cc_csemi_grp := Build_CSemiGroup cc_csetoid _ cc_csg_associative. Lemma cc_cm_proof : is_CMonoid cc_csemi_grp cc_zero. Proof. apply Build_is_CMonoid. unfold is_rht_unit in |- *. intros. elim x. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. unfold is_lft_unit in |- *. intros. elim x. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Definition cc_cmonoid := Build_CMonoid _ _ cc_cm_proof. Lemma cc_cg_proof : is_CGroup cc_cmonoid cc_inv_op. Proof. unfold is_CGroup in |- *. intros. elim x. intros. split. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Lemma cc_cr_dist : distributive cc_mult_op cc_plus_op. Proof. unfold distributive in |- *. intros. elim x. elim y. elim z. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma cc_cr_non_triv : cc_ap cc_one cc_zero. Proof. unfold cc_ap in |- *. simpl in |- *. left. apply Greater_imp_ap. apply pos_one. Qed. Definition cc_cgroup := Build_CGroup cc_cmonoid cc_inv_op cc_cg_proof. Definition cc_cabgroup : CAbGroup. Proof. apply Build_CAbGroup with cc_cgroup. red in |- *; unfold commutes in |- *. intros. elim x; elim y; split; simpl in |- *; algebra. Defined. Lemma cc_cr_mult_mon : is_CMonoid (Build_CSemiGroup (csg_crr cc_cgroup) _ cc_cr_mult_associative) cc_one. Proof. apply Build_is_CMonoid. unfold is_rht_unit in |- *. intros. elim x. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. unfold is_lft_unit in |- *. intros. elim x. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma cc_mult_commutes : commutes cc_mult_op. Proof. unfold commutes in |- *. intros. elim x. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma cc_isCRing : is_CRing cc_cabgroup cc_one cc_mult_op. Proof. apply Build_is_CRing with cc_cr_mult_associative. exact cc_cr_mult_mon. exact cc_mult_commutes. exact cc_cr_dist. exact cc_cr_non_triv. Qed. Definition cc_cring : CRing := Build_CRing _ _ _ cc_isCRing. Lemma cc_ap_zero : forall z : cc_cring, z [#] [0] -> Re z [#] [0] or Im z [#] [0]. Proof. intro z. unfold cc_ap in |- *. intuition. Qed. Lemma cc_inv_aid : forall x y : IR, x [#] [0] or y [#] [0] -> x[^]2[+]y[^]2 [#] [0]. Proof. intros x y H. apply Greater_imp_ap. elim H; clear H; intros. apply plus_resp_pos_nonneg. apply pos_square. auto. apply sqr_nonneg. apply plus_resp_nonneg_pos. apply sqr_nonneg. apply pos_square. auto. Qed. (** If [x [~=] [0]] or [y [~=] [0]], then [x [/] x[^]2 [+] y[^]2 [~=] [0]] or [[--]y[/]x[^]2[+]y[^]2 [~=] [0]]. *) Lemma cc_inv_aid2 : forall (x y : IR) (H : x [#] [0] or y [#] [0]), (x[/] _[//]cc_inv_aid _ _ H) [#] [0] or ( [--]y[/] _[//]cc_inv_aid _ _ H) [#] [0]. Proof. intros x y H. elim H; intro H0. left. apply div_resp_ap_zero_rev. auto. right. apply div_resp_ap_zero_rev. apply inv_resp_ap_zero. auto. Qed. (* REMARK KEPT FOR SENTIMENTAL REASONS... This definition seems clever. Even though we *cannot* construct an element of (NonZeros cc_cring) (a Set) by deciding which part of the input (Re or Im) is NonZero (a Prop), we manage to construct the actual function. *) Definition cc_recip : forall z : cc_cring, z [#] [0] -> cc_cring. Proof. intros z z_. apply (Build_CC_set (Re z[/] _[//]cc_inv_aid _ _ z_) ( [--] (Im z) [/] _[//]cc_inv_aid _ _ z_)). Defined. Lemma cc_cfield_proof : is_CField cc_cring cc_recip. Proof. unfold is_CField in |- *. unfold is_inverse in |- *. intro. elim x. intros x1 x2 Hx. split; simpl in |- *; unfold cc_eq in |- *; simpl in |- *; split; rational. Qed. Lemma cc_Recip_proof : forall x y x_ y_, cc_recip x x_ [#] cc_recip y y_ -> x [#] y. Proof. intro. elim x. intros x1 x2 y. intro Hx. elim y. intros y1 y2 Hy. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. intros H. elim H; clear H; intros H. cut (x1 [#] y1 or x1[^]2[+]x2[^]2 [#] y1[^]2[+]y2[^]2). intro H0. elim H0; clear H0; intros H0. left. auto. cut (x1[^]2 [#] y1[^]2 or x2[^]2 [#] y2[^]2). intro H1. elim H1; clear H1; intros. left. apply un_op_strext_unfolded with (nexp_op (R:=IR) 2). auto. right. apply un_op_strext_unfolded with (nexp_op (R:=IR) 2). auto. apply bin_op_strext_unfolded with (csg_op (c:=IR)). auto. apply div_strext with (cc_inv_aid x1 x2 Hx) (cc_inv_aid y1 y2 Hy). auto. cut ( [--]x2 [#] [--]y2 or x1[^]2[+]x2[^]2 [#] y1[^]2[+]y2[^]2). intro H0. elim H0; clear H0; intros H0. right. apply un_op_strext_unfolded with (cg_inv (c:=IR)). auto. cut (x1[^]2 [#] y1[^]2 or x2[^]2 [#] y2[^]2). intro H1. elim H1; clear H1; intros H1. left. apply un_op_strext_unfolded with (nexp_op (R:=IR) 2). auto. right. apply un_op_strext_unfolded with (nexp_op (R:=IR) 2). auto. apply bin_op_strext_unfolded with (csg_op (c:=IR)). auto. apply div_strext with (cc_inv_aid x1 x2 Hx) (cc_inv_aid y1 y2 Hy). auto. Qed. Opaque cc_recip. Opaque cc_inv. Definition cc_cfield := Build_CField _ _ cc_cfield_proof cc_Recip_proof. Definition CC := cc_cfield. (** Maps from reals to complex and vice-versa are defined, as well as conjugate, absolute value and the imaginary unit [I] *) Definition cc_set_CC : IR -> IR -> CC := Build_CC_set. Definition cc_IR (x : IR) : CC := cc_set_CC x [0]. Definition CC_conj : CC -> CC := fun z : CC_set => match z with | Build_CC_set Re0 Im0 => Build_CC_set Re0 [--]Im0 end. (* old def Definition CC_conj' : CC->CC := [z:CC_set] (CC_set_rec [_:CC_set]CC_set [Re0,Im0:IR] (Build_CC_set Re0 [--]Im0) z). *) Definition AbsCC (z : CC) : IR := sqrt (Re z[^]2[+]Im z[^]2) (cc_abs_aid _ (Re z) (Im z)). Lemma TwoCC_ap_zero : (Two:CC) [#] [0]. Proof. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. left. astepl (Two:IR). apply Greater_imp_ap. apply pos_two. Qed. End Complex_Numbers. (* begin hide *) Notation CCX := (cpoly_cring CC). (* end hide *) Definition II : CC := cc_i. Infix "[+I*]" := cc_set_CC (at level 48, no associativity). (** ** Properties of [II] *) Section I_properties. Lemma I_square : II[*]II [=] [--][1]. Proof. simpl in |- *. unfold cc_mult in |- *. simpl in |- *. unfold cc_inv in |- *. simpl in |- *. split. simpl in |- *. rational. simpl in |- *. rational. Qed. Hint Resolve I_square: algebra. Lemma I_square' : II[^]2 [=] [--][1]. Proof. Step_final (II[*]II). Qed. Lemma I_recip_lft : [--]II[*]II [=] [1]. Proof. astepl ( [--] (II[*]II)). Step_final ( [--][--] ([1]:CC)). Qed. Lemma I_recip_rht : II[*][--]II [=] [1]. Proof. astepl ( [--] (II[*]II)). Step_final ( [--][--] ([1]:CC)). Qed. Lemma mult_I : forall x y : IR, (x[+I*]y) [*]II [=] [--]y[+I*]x. Proof. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma I_wd : forall x x' y y' : IR, x [=] x' -> y [=] y' -> x[+I*]y [=] x'[+I*]y'. Proof. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. algebra. Qed. (** ** Properties of [Re] and [Im] *) Lemma calculate_norm : forall x y : IR, (x[+I*]y) [*]CC_conj (x[+I*]y) [=] cc_IR (x[^]2[+]y[^]2). Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma calculate_Re : forall c : CC, cc_IR (Re c) [*]Two [=] c[+]CC_conj c. Proof. intros. elim c. intros x y. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma calculate_Im : forall c : CC, cc_IR (Im c) [*] (Two[*]II) [=] c[-]CC_conj c. Proof. intros. elim c. intros x y. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma Re_wd : forall c c' : CC, c [=] c' -> Re c [=] Re c'. Proof. intros c c'. elim c. intros x y. elim c'. intros x' y'. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. intros. elim H. auto. Qed. Lemma Im_wd : forall c c' : CC, c [=] c' -> Im c [=] Im c'. Proof. intros c c'. elim c. intros x y. elim c'. intros x' y'. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. intros. elim H. auto. Qed. Lemma Re_resp_plus : forall x y : CC, Re (x[+]y) [=] Re x[+]Re y. Proof. intros. elim x. intros x1 x2. elim y. intros y1 y2. simpl in |- *. unfold cc_eq in |- *. algebra. Qed. Lemma Re_resp_inv : forall x y : CC, Re (x[-]y) [=] Re x[-]Re y. Proof. intros. elim x. intros x1 x2. elim y. intros y1 y2. simpl in |- *. unfold cc_eq in |- *. algebra. Qed. Lemma Im_resp_plus : forall x y : CC, Im (x[+]y) [=] Im x[+]Im y. Proof. intros. elim x. intros x1 x2. elim y. intros y1 y2. simpl in |- *. unfold cc_eq in |- *. algebra. Qed. Lemma Im_resp_inv : forall x y : CC, Im (x[-]y) [=] Im x[-]Im y. Proof. intros. elim x. intros x1 x2. elim y. intros y1 y2. simpl in |- *. unfold cc_eq in |- *. algebra. Qed. Lemma cc_calculate_square : forall x y, (x[+I*]y) [^]2 [=] (x[^]2[-]y[^]2) [+I*]x[*]y[*]Two. Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. End I_properties. #[global] Hint Resolve I_square I_square' I_recip_lft I_recip_rht mult_I calculate_norm cc_calculate_square: algebra. #[global] Hint Resolve I_wd Re_wd Im_wd: algebra_c. (** ** Properties of conjugation *) Section Conj_properties. Lemma CC_conj_plus : forall c c' : CC, CC_conj (c[+]c') [=] CC_conj c[+]CC_conj c'. Proof. intros c c'. elim c. intros x y. elim c'. intros x' y'. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Lemma CC_conj_mult : forall c c' : CC, CC_conj (c[*]c') [=] CC_conj c[*]CC_conj c'. Proof. intros c c'. elim c. intros x y. elim c'. intros x' y'. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Hint Resolve CC_conj_mult: algebra. Lemma CC_conj_strext : forall c c' : CC, CC_conj c [#] CC_conj c' -> c [#] c'. Proof. intros c c'. elim c. intros x y. elim c'. intros x' y'. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. intros H. elim H; clear H; intros. left. auto. right. apply un_op_strext_unfolded with (cg_inv (c:=IR)). auto. Qed. Lemma CC_conj_conj : forall c : CC, CC_conj (CC_conj c) [=] c. Proof. intros. elim c. intros x y. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Lemma CC_conj_zero : CC_conj [0] [=] [0]. Proof. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Lemma CC_conj_one : CC_conj [1] [=] [1]. Proof. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Hint Resolve CC_conj_one: algebra. Lemma CC_conj_nexp : forall (c : CC) n, CC_conj (c[^]n) [=] CC_conj c[^]n. Proof. intros. induction n as [| n Hrecn]; intros. astepl (CC_conj [1]). Step_final ([1]:CC). astepl (CC_conj (c[^]n[*]c)). astepl (CC_conj (c[^]n) [*]CC_conj c). Step_final (CC_conj c[^]n[*]CC_conj c). Qed. End Conj_properties. #[global] Hint Resolve CC_conj_plus CC_conj_mult CC_conj_nexp CC_conj_conj CC_conj_zero: algebra. (** ** Properties of the real axis *) Section cc_IR_properties. Lemma Re_cc_IR : forall x : IR, Re (cc_IR x) [=] x. Proof. intro x. simpl in |- *. apply eq_reflexive. Qed. Lemma Im_cc_IR : forall x : IR, Im (cc_IR x) [=] [0]. Proof. intro x. simpl in |- *. apply eq_reflexive. Qed. Lemma cc_IR_wd : forall x y : IR, x [=] y -> cc_IR x [=] cc_IR y. Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Hint Resolve cc_IR_wd: algebra_c. Lemma cc_IR_resp_ap : forall x y : IR, x [#] y -> cc_IR x [#] cc_IR y. Proof. intros. simpl in |- *. unfold cc_ap in |- *. simpl in |- *. left. auto. Qed. Lemma cc_IR_mult : forall x y : IR, cc_IR x[*]cc_IR y [=] cc_IR (x[*]y). Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Hint Resolve cc_IR_mult: algebra. Lemma cc_IR_mult_lft : forall x y z, (x[+I*]y) [*]cc_IR z [=] x[*]z[+I*]y[*]z. Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma cc_IR_mult_rht : forall x y z, cc_IR z[*] (x[+I*]y) [=] z[*]x[+I*]z[*]y. Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; rational. Qed. Lemma cc_IR_plus : forall x y : IR, cc_IR x[+]cc_IR y [=] cc_IR (x[+]y). Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Hint Resolve cc_IR_plus: algebra. Lemma cc_IR_minus : forall x y : IR, cc_IR x[-]cc_IR y [=] cc_IR (x[-]y). Proof. intros. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Lemma cc_IR_zero : cc_IR [0] [=] [0]. Proof. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Hint Resolve cc_IR_zero: algebra. Lemma cc_IR_one : cc_IR [1] [=] [1]. Proof. simpl in |- *. unfold cc_eq in |- *. simpl in |- *. split; algebra. Qed. Hint Resolve cc_IR_one: algebra. Lemma cc_IR_nring : forall n : nat, cc_IR (nring n) [=] nring n. Proof. intros. induction n as [| n Hrecn]; intros. astepl (cc_IR [0]). Step_final ([0]:CC). astepl (cc_IR (nring n[+][1])). astepl (cc_IR (nring n) [+]cc_IR [1]). Step_final (nring n[+] ([1]:CC)). Qed. Lemma cc_IR_nexp : forall (x : IR) (n : nat), cc_IR x[^]n [=] cc_IR (x[^]n). Proof. intros. induction n as [| n Hrecn]; intros. astepl ([1]:CC). Step_final (cc_IR [1]). astepl (cc_IR x[^]n[*]cc_IR x). astepl (cc_IR (x[^]n) [*]cc_IR x). Step_final (cc_IR (x[^]n[*]x)). Qed. End cc_IR_properties. #[global] Hint Resolve Re_cc_IR Im_cc_IR: algebra. #[global] Hint Resolve cc_IR_wd: algebra_c. #[global] Hint Resolve cc_IR_mult cc_IR_nexp cc_IR_mult_lft cc_IR_mult_rht cc_IR_plus cc_IR_minus: algebra. #[global] Hint Resolve cc_IR_nring cc_IR_zero: algebra. (** ** [CC] has characteristic zero *) Load "Transparent_algebra". Lemma char0_CC : Char0 CC. Proof. unfold Char0 in |- *. intros. astepl (cc_IR (nring n)). simpl in |- *. unfold cc_ap in |- *. simpl in |- *. left. apply char0_IR. auto. Qed. Load "Opaque_algebra". Lemma poly_apzero_CC : forall f : CCX, f [#] [0] -> {c : CC | f ! c [#] [0]}. Proof. intros. apply poly_apzero. exact char0_CC. auto. Qed. Lemma poly_CC_extensional : forall p q : CCX, (forall x, p ! x [=] q ! x) -> p [=] q. Proof. intros. apply poly_extensional. exact char0_CC. auto. Qed. corn-8.20.0/complex/Complex_Exponential.v000066400000000000000000000175221473720167500204000ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing ExpCC %\ensuremath{\exp_{\mathbb C}}% *) Require Export CoRN.complex.AbsCC. Require Export CoRN.transc.Exponential. Require Export CoRN.transc.Pi. (** ** The Complex Exponential *) Definition ExpCC (z : CC) := cc_IR (Exp (Re z)) [*] (Cos (Im z) [+I*]Sin (Im z)). Lemma ExpCC_wd : forall z1 z2 : CC, z1 [=] z2 -> ExpCC z1 [=] ExpCC z2. Proof. intro z1. elim z1. intros x1 y1. intro z2. elim z2. intros x2 y2. unfold ExpCC in |- *. unfold Re, Im in |- *. intros (H1, H2). simpl in H1. simpl in H2. apply bin_op_wd_unfolded. apply cc_IR_wd. apply Exp_wd. assumption. astepl (Cos y2[+I*]Sin y1). astepl (Cos y2[+I*]Sin y2). apply eq_reflexive. Qed. (* begin hide *) Lemma ExpCC_equation_aid_1 : forall z1 z2 : CC, ExpCC (z1[+]z2) [=] cc_IR (Exp (Re z1[+]Re z2)) [*] (Cos (Im z1[+]Im z2) [+I*]Sin (Im z1[+]Im z2)). Proof. intro z1. elim z1. intros x1 y1. intro z2. elim z2. intros x2 y2. unfold Re, Im in |- *. unfold ExpCC in |- *. apply bin_op_wd_unfolded. apply cc_IR_wd. apply Exp_wd. algebra. split; algebra. Qed. Lemma ExpCC_equation_aid_2 : forall z1 z2 : CC, cc_IR (Exp (Re z1[+]Re z2)) [*] (Cos (Im z1[+]Im z2) [+I*]Sin (Im z1[+]Im z2)) [=] cc_IR (Exp (Re z1) [*]Exp (Re z2)) [*] ((Cos (Im z1) [*]Cos (Im z2) [-]Sin (Im z1) [*]Sin (Im z2)) [+I*] (Sin (Im z1) [*]Cos (Im z2) [+]Cos (Im z1) [*]Sin (Im z2))). Proof. intros z1 z2. apply bin_op_wd_unfolded. apply cc_IR_wd. algebra. split; algebra. Qed. Lemma ExpCC_equation_aid_3 : forall z1 z2 : CC, cc_IR (Exp (Re z1) [*]Exp (Re z2)) [*] ((Cos (Im z1) [*]Cos (Im z2) [-]Sin (Im z1) [*]Sin (Im z2)) [+I*] (Sin (Im z1) [*]Cos (Im z2) [+]Cos (Im z1) [*]Sin (Im z2))) [=] cc_IR (Exp (Re z1) [*]Exp (Re z2)) [*] ((Cos (Im z1) [+I*]Sin (Im z1)) [*] (Cos (Im z2) [+I*]Sin (Im z2))). Proof. intros z1 z2. apply bin_op_wd_unfolded. apply eq_reflexive. set (c1 := Cos (Im z1)) in *. set (c2 := Cos (Im z2)) in *. set (s1 := Sin (Im z1)) in *. set (s2 := Sin (Im z2)) in *. split; simpl in |- *; algebra. Qed. Lemma ExpCC_equation_aid_4 : forall z1 z2 : CC, cc_IR (Exp (Re z1) [*]Exp (Re z2)) [*] ((Cos (Im z1) [+I*]Sin (Im z1)) [*] (Cos (Im z2) [+I*]Sin (Im z2))) [=] ExpCC z1[*]ExpCC z2. Proof. intros z1 z2. unfold ExpCC in |- *. set (c := Cos (Im z1) [+I*]Sin (Im z1)) in *. set (d := Cos (Im z2) [+I*]Sin (Im z2)) in *. astepl (cc_IR (Exp (Re z1)) [*]cc_IR (Exp (Re z2)) [*] (c[*]d)). rational. Qed. (* end hide *) Lemma ExpCC_plus : forall z1 z2 : CC, ExpCC (z1[+]z2) [=] ExpCC z1[*]ExpCC z2. Proof. intros z1 z2. apply eq_transitive_unfolded with (S := cc_csetoid) (y := cc_IR (Exp (Re z1) [*]Exp (Re z2)) [*] ((Cos (Im z1) [*]Cos (Im z2) [-]Sin (Im z1) [*]Sin (Im z2)) [+I*] (Sin (Im z1) [*]Cos (Im z2) [+]Cos (Im z1) [*]Sin (Im z2)))). eapply eq_transitive_unfolded. apply ExpCC_equation_aid_1. apply ExpCC_equation_aid_2. eapply eq_transitive_unfolded. apply ExpCC_equation_aid_3. apply ExpCC_equation_aid_4. Qed. #[global] Hint Resolve ExpCC_plus: algebra. Lemma ExpCC_Zero : ExpCC [0] [=] [1]. Proof. unfold ExpCC in |- *. astepl (cc_IR (Exp [0]) [*] (Cos [0][+I*]Sin [0])). astepl (cc_IR [1][*] (Cos [0][+I*]Sin [0])). astepl (cc_IR [1][*] ([1][+I*][0])). simpl in |- *. split; simpl in |- *; rational. Qed. #[global] Hint Resolve ExpCC_Zero: algebra. Lemma ExpCC_inv_aid : forall z : CC, ExpCC z[*]ExpCC [--]z [=] [1]. Proof. intro z. apply eq_transitive_unfolded with (S := cc_csetoid) (y := ExpCC [0]). astepl (ExpCC (z[+][--]z)). apply ExpCC_wd. rational. algebra. Qed. #[global] Hint Resolve ExpCC_inv_aid: algebra. Lemma ExpCC_ap_zero : forall z : CC, ExpCC z [#] [0]. Proof. intro z. cut (ExpCC z[*]ExpCC [--]z [#] [0]). intro H. apply (mult_cancel_ap_zero_lft _ _ _ H). astepl ([1]:CC). apply cc_cr_non_triv. Qed. Lemma ExpCC_inv : forall z z_, ([1][/] (ExpCC z) [//]z_) [=] ExpCC [--]z. Proof. intros z H. astepl (ExpCC z[*]ExpCC [--]z[/] ExpCC z[//]H). rational. Qed. #[global] Hint Resolve ExpCC_inv: algebra. Lemma ExpCC_pow : forall z n, ExpCC z[^]n [=] ExpCC (nring n[*]z). Proof. intro z. simple induction n. unfold nexp in |- *. astepl ([1]:CC). astepr (ExpCC [0]). astepr ([1]:CC). apply eq_reflexive. apply ExpCC_wd. rational. intros n0 Hrec. astepl (ExpCC z[^]n0[*]ExpCC z). astepl (ExpCC (nring n0[*]z) [*]ExpCC z). astepl (ExpCC (nring n0[*]z[+]z)). apply ExpCC_wd. algebra. rstepl ((nring n0[+][1]) [*]z). algebra. Qed. #[global] Hint Resolve ExpCC_pow: algebra. Lemma AbsCC_ExpCC : forall z : CC, AbsCC (ExpCC z) [=] Exp (Re z). Proof. intro z. unfold ExpCC in |- *. astepl (AbsCC (cc_IR (Exp (Re z))) [*]AbsCC (Cos (Im z) [+I*]Sin (Im z))). astepr (Exp (Re z) [*][1]). apply bin_op_wd_unfolded. assert (H : AbsCC (cc_IR (Exp (Re z))) [=] Exp (Re z)). apply AbsCC_IR. apply less_leEq. apply Exp_pos. astepl (Exp (Re z)). apply eq_reflexive. cut (AbsCC (Cos (Im z) [+I*]Sin (Im z)) [^]2 [=] [1]). set (x := AbsCC (Cos (Im z) [+I*]Sin (Im z))) in *. intro H0. assert (H1 : x[+][1][~=][0]). apply ap_imp_neq. apply Greater_imp_ap. apply leEq_less_trans with (y := x). unfold x in |- *. apply AbsCC_nonneg. apply less_plusOne. assert (H2 : (x[+][1]) [*] (x[-][1]) [=] [0]). cut (x[^]2[-][1][^]2 [=] [0]). intro H'. astepl (x[^]2[-][1][^]2). assumption. astepl (x[^]2[-][1]). astepr (OneR[-]OneR). apply cg_minus_wd; [ assumption | apply eq_reflexive ]. assert (H3 : x[-][1] [=] [0]). apply (mult_eq_zero _ _ _ H1 H2). rstepl ([1][+] (x[-][1])). astepr (OneR[+]ZeroR). apply plus_resp_eq. assumption. astepl (Cos (Im z) [^]2[+]Sin (Im z) [^]2). astepl OneR. apply eq_reflexive. apply AbsCC_square_Re_Im. Qed. #[global] Hint Resolve AbsCC_ExpCC: algebra. Lemma ExpCC_Periodic : forall z, ExpCC (z[+]II[*]Two[*]cc_IR Pi) [=] ExpCC z. Proof. intro z. elim z. intros x y. astepl (ExpCC (x[+I*] (y[+]Two[*]Pi))). unfold ExpCC in |- *. apply bin_op_wd_unfolded. apply cc_IR_wd. apply Exp_wd. simpl in |- *. apply eq_reflexive_unfolded. astepl (Cos (y[+]Two[*]Pi) [+I*]Sin (y[+]Two[*]Pi)). astepl (Cos y[+I*]Sin y). apply eq_reflexive. apply ExpCC_wd. split; simpl in |- *; rational. Qed. #[global] Hint Resolve ExpCC_Periodic: algebra. Lemma ExpCC_Exp : forall x : IR, ExpCC (cc_IR x) [=] cc_IR (Exp x). Proof. intro x. unfold ExpCC in |- *. astepl (cc_IR (Exp x) [*] (Cos (Im (cc_IR x)) [+I*]Sin (Im (cc_IR x)))). astepr (cc_IR (Exp x) [*][1]). apply bin_op_wd_unfolded. algebra. astepl (Cos [0][+I*]Sin [0]). Step_final ([1][+I*][0]). Qed. #[global] Hint Resolve ExpCC_Exp: algebra. Theorem Euler : (ExpCC (II[*] (cc_IR Pi))) [+][1] [=] [0]. Proof. split. Opaque Sin Cos Exp. simpl. rstepl ((Exp [0]) [*] (Cos Pi) [+][1]). astepl (([1]:IR) [*][--][1][+][1]). rational. simpl. rstepl ((Exp [0]) [*] (Sin Pi)). Step_final (([1]:IR) [*][0]). Qed. corn-8.20.0/complex/NRootCC.v000066400000000000000000001320041473720167500156630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing sqrt_Half %\ensuremath{\sqrt{\frac12}}% *) (** printing sqrt_I %\ensuremath{\sqrt{\imath}}% *) (** printing nroot_I %\ensuremath{\sqrt[n]{\imath}}% *) (** printing nroot_minus_I %\ensuremath{\sqrt[n]{-\imath}}% *) Require Export CoRN.complex.CComplex. From Coq Require Export Wf_nat. From Coq Require Export ArithRing. Import CRing_Homomorphisms.coercions. (** * Roots of Complex Numbers Properties of non-zero complex numbers *) Section CC_ap_zero. Lemma cc_ap_zero : forall P : CC -> Prop, (forall a b, a [#] [0] -> P (a[+I*]b)) -> (forall a b, b [#] [0] -> P (a[+I*]b)) -> forall c, c [#] [0] -> P c. Proof. intros ????. elim c. intros a b H1. elim H1; intros H2; auto. Qed. Lemma C_cc_ap_zero : forall P : CC -> CProp, (forall a b, a [#] [0] -> P (a[+I*]b)) -> (forall a b, b [#] [0] -> P (a[+I*]b)) -> forall c, c [#] [0] -> P c. Proof. intro. intros H H0 c. elim c. intros a b. intro H1. elim H1; intros H2;auto. Qed. End CC_ap_zero. (** Weird lemma. *) Section Imag_to_Real. Lemma imag_to_real : forall a b a' b', a'[+I*]b' [=] (a[+I*]b) [*]II -> a [#] [0] -> b' [#] [0]. Proof. intros ????? H0. cut (b' [=] a); intros. (* astepl a. *) now apply ap_wdl with a. apply eq_transitive with (Im (a'[+I*]b')). apply eq_reflexive. (* astepl (Im a[+I*]b[*]II). *) apply eq_transitive with (Im ((a[+I*]b) [*]II)). now apply Im_wd. (* Step_final (Im ( [--]b) [+I*]a). *) apply eq_transitive with (Im ( [--]b[+I*]a)). apply Im_wd. apply mult_I. apply eq_reflexive. Qed. End Imag_to_Real. (** ** Roots of the imaginary unit *) Section NRootI. Definition sqrt_Half := sqrt Half (less_leEq _ _ _ (pos_half IR)). Definition sqrt_I := sqrt_Half[+I*]sqrt_Half. Lemma sqrt_I_nexp : sqrt_I[^]2 [=] II. Proof. (* astepl sqrt_I[*]sqrt_I. *) apply eq_transitive with (sqrt_I[*]sqrt_I). apply nexp_two. unfold sqrt_I in |- *. (* astepl (sqrt_Half[*]sqrt_Half[-]sqrt_Half[*]sqrt_Half) [+I*] (sqrt_Half[*]sqrt_Half[+]sqrt_Half[*]sqrt_Half). *) apply eq_transitive with ((sqrt_Half[*]sqrt_Half[-]sqrt_Half[*]sqrt_Half) [+I*] (sqrt_Half[*]sqrt_Half[+]sqrt_Half[*]sqrt_Half)). apply eq_reflexive_unfolded. cut (sqrt_Half[*]sqrt_Half [=] Half); intros. (* astepl [0][+I*] (Half[+]Half). *) apply eq_transitive with ([0][+I*] (Half[+]Half)). apply I_wd. apply cg_minus_correct. apply bin_op_wd_unfolded. exact H. exact H. (* Step_final [0][+I*][1]. *) apply eq_transitive with ([0][+I*][1]). apply I_wd. apply eq_reflexive. apply half_2. apply eq_reflexive. (* astepl sqrt_Half[^] (2). *) apply eq_transitive with (sqrt_Half[^]2). apply eq_symmetric. apply nexp_two. apply sqrt_sqr. Qed. Lemma nroot_I_nexp_aux : forall n, Nat.Odd n -> {m : nat | n * n = 4 * m + 1}. Proof. intros n H; destruct (even_or_odd_plus n) as [m [Hm | ->]]. - exfalso; apply (Nat.Even_Odd_False n); [| exact H]. exists m; rewrite Hm; ring. - exists (m * m + m); ring. Qed. Definition nroot_I (n : nat) (n_ : Nat.Odd n) : CC := II[^]n. Lemma nroot_I_nexp : forall n n_, nroot_I n n_[^]n [=] II. Proof. intros n on. unfold nroot_I in |- *. (* astepl II[^] (mult n n). *) apply eq_transitive with (II[^] (n * n)). apply nexp_mult. elim (nroot_I_nexp_aux n); try assumption. intros m H. rewrite H. (* astepl II[^] (mult (4) m) [*]II[^] (1). *) apply eq_transitive with (II[^] (4 * m) [*]II[^]1). apply eq_symmetric. apply nexp_plus. (* astepl (II[^] (4)) [^]m[*]II. *) apply eq_transitive with ((II[^]4) [^]m[*]II). apply bin_op_wd_unfolded. apply eq_symmetric. apply nexp_mult. apply nexp_one. cut (II[^]4 [=] [1]); intros. (* astepl [1][^]m[*]II. *) apply eq_transitive_unfolded with ([1][^]m[*]II). apply bin_op_wd_unfolded. apply un_op_wd_unfolded. exact H0. apply eq_reflexive_unfolded. (* Step_final [1][*]II. *) apply eq_transitive_unfolded with ([1][*]II). apply bin_op_wd_unfolded. apply one_nexp. apply eq_reflexive_unfolded. apply one_mult. replace 4 with (2 * 2). (* astepl (II[^] (2)) [^] (2). *) apply eq_transitive_unfolded with ((II[^]2) [^]2). apply eq_symmetric_unfolded. apply nexp_mult. (* astepl ( [--] ([1]::CC)) [^] (2). *) apply eq_transitive_unfolded with ( [--] ([1]:CC) [^]2). apply un_op_wd_unfolded. exact I_square'. (* Step_final ([1]::CC) [^] (2). *) apply eq_transitive_unfolded with (([1]:CC) [^]2). apply inv_nexp_two. apply one_nexp. auto with arith. Qed. Hint Resolve nroot_I_nexp: algebra. Definition nroot_minus_I (n : nat) (n_ : Nat.Odd n) : CC := [--] (nroot_I n n_). Lemma nroot_minus_I_nexp : forall n n_, nroot_minus_I n n_[^]n [=] [--]II. Proof. intros n on. unfold nroot_minus_I in |- *. (* Step_final [--] ((nroot_I n on) [^]n). *) apply eq_transitive_unfolded with ( [--] (nroot_I n on[^]n)). apply inv_nexp_odd. exact on. apply un_op_wd_unfolded. apply nroot_I_nexp. Qed. End NRootI. (** ** Roots of complex numbers *) Section NRootCC_1. (** We define the nth root of a complex number with a non zero imaginary part. *) Section NRootCC_1_ap_real. (** %\begin{convention}% Let [a,b : IR] and [b_ : (b [#] [0])]. Define [c2 := a[^]2[+]b[^]2], [c := sqrt c2], [a'2 := (c[+]a) [*]Half], [a' := sqrt a'2], [b'2 := (c[-]a) [*]Half] and [b' := sqrt b'2]. %\end{convention}% *) Variables a b : IR. Hypothesis b_ : b [#] [0]. (* begin hide *) Let c2 := a[^]2[+]b[^]2. (* end hide *) Lemma nrCC1_c2pos : [0] [<] c2. Proof. unfold c2 in |- *. apply plus_resp_nonneg_pos. apply sqr_nonneg. apply pos_square. assumption. Qed. (* begin hide *) Let c := sqrt c2 (less_leEq _ _ _ nrCC1_c2pos). Let a'2 := (c[+]a) [*]Half. (* end hide *) Lemma nrCC1_a'2pos : [0] [<] a'2. Proof. unfold a'2 in |- *. apply (mult_resp_pos IR). rstepr (c[-][--]a). apply shift_zero_less_minus. unfold c in |- *. apply sqrt_less'. unfold c2 in |- *. apply (Ccsr_wdl _ (cof_less (c:=IR)) (a[^]2[+][0]) (a[^]2[+]b[^]2)). apply plus_resp_less_lft. change ([0] [<] b[^]2) in |- *. apply pos_square. assumption. (* algebra. *) apply cm_rht_unit_unfolded. apply pos_half. Qed. (* begin hide *) Let a' := sqrt a'2 (less_leEq _ _ _ nrCC1_a'2pos). Let b'2 := (c[-]a) [*]Half. (* end hide *) Lemma nrCC1_b'2pos : [0] [<] b'2. Proof. unfold b'2 in |- *. apply (mult_resp_pos IR). change ([0] [<] c[-]a) in |- *. apply shift_zero_less_minus. unfold c in |- *. apply sqrt_less. unfold c2 in |- *. rstepl (a[^]2[+][0]). apply plus_resp_less_lft. change ([0] [<] b[^]2) in |- *. apply pos_square. assumption. apply pos_half. Qed. (* begin hide *) Let b' := sqrt b'2 (less_leEq _ _ _ nrCC1_b'2pos). (* end hide *) Lemma nrCC1_a3 : a'[^]2[-]b'[^]2 [=] a. Proof. unfold a', b' in |- *. (* astepl a'2[-]b'2. *) apply eq_transitive_unfolded with (a'2[-]b'2). apply cg_minus_wd. apply sqrt_sqr. apply sqrt_sqr. unfold a'2, b'2 in |- *. unfold Half in |- *. rational. Qed. Lemma nrCC1_a4 : (c[+]a) [*] (c[-]a) [=] b[^]2. Proof. (* astepl c[^] (2) [-]a[^] (2). *) apply eq_transitive_unfolded with (c[^]2[-]a[^]2). apply nexp_funny. unfold c in |- *. (* astepl c2[-]a[^] (2). *) apply eq_transitive_unfolded with (c2[-]a[^]2). apply cg_minus_wd. apply sqrt_sqr. apply eq_reflexive_unfolded. unfold c2 in |- *. (* astepl (a[^] (2) [+]b[^] (2)) [+][--] (a[^] (2)). *) apply eq_transitive_unfolded with (a[^]2[+]b[^]2[+][--] (a[^]2)). apply eq_reflexive_unfolded. (* astepl (b[^] (2) [+]a[^] (2)) [+][--] (a[^] (2)). *) apply eq_transitive_unfolded with (b[^]2[+]a[^]2[+][--] (a[^]2)). apply bin_op_wd_unfolded. apply cag_commutes_unfolded. apply eq_reflexive_unfolded. (* astepl b[^] (2) [+] (a[^] (2) [+][--] (a[^] (2))). *) apply eq_transitive_unfolded with (b[^]2[+] (a[^]2[+][--] (a[^]2))). apply eq_symmetric_unfolded. apply plus_assoc_unfolded. (* Step_final b[^] (2) [+][0]. *) apply eq_transitive_unfolded with (b[^]2[+][0]). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply cg_rht_inv_unfolded. apply cm_rht_unit_unfolded. Qed. Hint Resolve nrCC1_a4: algebra. Lemma nrCC1_a5 : a'2[*]b'2 [=] (b[*]Half) [^]2. Proof. unfold a'2, b'2 in |- *. (* astepl (c[+]a) [*] (Half[*] ((c[-]a) [*]Half)). *) apply eq_transitive_unfolded with ((c[+]a) [*] (Half[*] ((c[-]a) [*]Half))). apply eq_symmetric_unfolded. apply mult_assoc_unfolded. (* astepl (c[+]a) [*] (((c[-]a) [*]Half) [*]Half). *) apply eq_transitive_unfolded with ((c[+]a) [*] ((c[-]a) [*]Half[*]Half)). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply mult_commutes. (* astepl (c[+]a) [*] ((c[-]a) [*] (Half[*]Half)). *) apply eq_transitive_unfolded with ((c[+]a) [*] ((c[-]a) [*] (Half[*]Half))). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply mult_assoc_unfolded. (* astepl ((c[+]a) [*] (c[-]a)) [*] (Half[*]Half). *) apply eq_transitive_unfolded with ((c[+]a) [*] (c[-]a) [*] (Half[*]Half)). apply mult_assoc_unfolded. (* astepl b[^] (2) [*] (Half[*]Half). *) apply eq_transitive_unfolded with (b[^]2[*] (Half[*]Half)). apply bin_op_wd_unfolded. exact nrCC1_a4. apply eq_reflexive_unfolded. (* astepl (b[*]b) [*] (Half[*]Half). *) apply eq_transitive_unfolded with (b[*]b[*] (Half[*]Half)). apply bin_op_wd_unfolded. apply nexp_two. apply eq_reflexive_unfolded. (* astepl ((b[*]b) [*]Half) [*]Half. *) apply eq_transitive_unfolded with (b[*]b[*]Half[*]Half). apply mult_assoc_unfolded. (* astepl (b[*] (b[*]Half)) [*]Half. *) apply eq_transitive_unfolded with (b[*] (b[*]Half) [*]Half). apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply mult_assoc_unfolded. apply eq_reflexive_unfolded. (* astepl ((b[*]Half) [*]b) [*]Half. *) apply eq_transitive_unfolded with (b[*]Half[*]b[*]Half). apply bin_op_wd_unfolded. apply mult_commutes. apply eq_reflexive_unfolded. (* Step_final (b[*]Half) [*] (b[*]Half). *) apply eq_transitive_unfolded with (b[*]Half[*] (b[*]Half)). apply eq_symmetric_unfolded. apply mult_assoc_unfolded. apply eq_symmetric_unfolded. apply nexp_two. Qed. Lemma nrCC1_a6 : [0] [<] a'2[*]b'2. Proof. apply (mult_resp_pos IR). apply nrCC1_a'2pos. apply nrCC1_b'2pos. Qed. Lemma nrCC1_a6' : [0] [<] (b[*]Half) [^]2. Proof. apply pos_square. (* astepr [0][*]Half. *) apply ap_wdr_unfolded with (ZeroR[*]Half). 2: apply cring_mult_zero_op. apply mult_rht_resp_ap; try assumption. apply pos_ap_zero. apply pos_half. Qed. Hint Resolve nrCC1_a5: algebra. Lemma nrCC1_a7_upper : [0] [<] b -> a'[*]b' [=] b[*]Half. Proof. intros. unfold a', b' in |- *. (* astepl (sqrt a'2[*]b'2 (less_leEq ? ? ? nrCC1_a6)). *) apply eq_transitive_unfolded with (sqrt (a'2[*]b'2) (less_leEq _ _ _ nrCC1_a6)). apply eq_symmetric_unfolded. apply NRootIR.sqrt_mult. (* astepl (sqrt (b[*]Half) [^] (2) nrCC1_a6'). *) apply eq_transitive_unfolded with (sqrt ((b[*]Half) [^]2) (less_leEq _ _ _ nrCC1_a6')). apply sqrt_wd. exact nrCC1_a5. apply sqrt_to_nonneg. apply less_leEq. rstepl (ZeroR[*]Half). apply mult_resp_less. assumption. apply pos_half. Qed. Lemma nrCC1_a7_lower : b [<] [0] -> a'[*][--]b' [=] b[*]Half. Proof. intros. (* astepl [--] (a'[*]b'). *) apply eq_transitive_unfolded with ( [--] (a'[*]b')). apply cring_inv_mult_lft. cut (a'[*]b' [=] [--] (b[*]Half)); intros. rename H into H0. rename X into H. (* Step_final [--][--] (b[*]Half). *) apply eq_transitive_unfolded with ( [--][--] (b[*]Half)). apply un_op_wd_unfolded. exact H0. apply cg_inv_inv. unfold a', b' in |- *. (* astepl (sqrt a'2[*]b'2 (less_leEq ? ? ? nrCC1_a6)). *) apply eq_transitive_unfolded with (sqrt (a'2[*]b'2) (less_leEq _ _ _ nrCC1_a6)). apply eq_symmetric_unfolded. apply NRootIR.sqrt_mult. (* astepl (sqrt (b[*]Half) [^] (2) (less_leEq ? ? ? nrCC1_a6')). *) apply eq_transitive_unfolded with (sqrt ((b[*]Half) [^]2) (less_leEq _ _ _ nrCC1_a6')). apply sqrt_wd. exact nrCC1_a5. apply sqrt_to_nonpos. apply less_leEq. rstepr (ZeroR[*]Half). apply mult_resp_less. assumption. apply pos_half. Qed. Hint Resolve nrCC1_a3 nrCC1_a7_upper nrCC1_a7_lower: algebra. Lemma nrootCC_1_upper : [0] [<] b -> (a'[+I*]b') [^]2 [=] a[+I*]b. Proof. intros. (* astepl (a'[^] (2) [-]b'[^] (2)) [+I*] ((a'[*]b') [*]Two). *) apply eq_transitive_unfolded with ((a'[^]2[-]b'[^]2) [+I*]a'[*]b'[*]Two). apply cc_calculate_square. cut (a'[*]b'[*]Two [=] b); intros. (* Step_final a[+I*]b. *) apply eq_transitive_unfolded with (a[+I*]b). apply I_wd. exact nrCC1_a3. rename H into H0. exact H0. apply eq_reflexive_unfolded. (* astepl (b[*]Half) [*]Two. *) apply eq_transitive_unfolded with (b[*]Half[*]Two). apply bin_op_wd_unfolded. apply nrCC1_a7_upper. rename X into H. exact H. apply eq_reflexive_unfolded. (* algebra. *) apply half_1'. Qed. Lemma nrootCC_1_lower : b [<] [0] -> (a'[+I*][--]b') [^]2 [=] a[+I*]b. Proof. intros. cut (a'[^]2[-][--]b'[^]2 [=] a); intros. cut (a'[*][--]b'[*]Two [=] b); intros. (* Step_final (a'[^] (2) [-] ( [--]b') [^] (2)) [+I*] ((a'[*][--]b') [*]Two). *) apply eq_transitive_unfolded with ((a'[^]2[-][--]b'[^]2) [+I*]a'[*][--]b'[*]Two). apply cc_calculate_square. apply I_wd. rename H0 into H1. rename H into H0. rename X into H. exact H0. rename H0 into H1. rename H into H0. rename X into H. exact H1. (* astepl (b[*]Half) [*]Two. *) apply eq_transitive_unfolded with (b[*]Half[*]Two). apply bin_op_wd_unfolded. apply nrCC1_a7_lower. rename H into H0. rename X into H. exact H. apply eq_reflexive_unfolded. (* algebra. *) apply half_1'. (* Step_final a'[^] (2) [-]b'[^] (2). *) apply eq_transitive_unfolded with (a'[^]2[-]b'[^]2). apply cg_minus_wd. apply eq_reflexive_unfolded. apply inv_nexp_two. exact nrCC1_a3. Qed. Lemma nrootCC_1_ap_real : {z : CC | z[^]2 [=] a[+I*]b}. Proof. elim (ap_imp_less _ b [0]). intro H. exists (a'[+I*][--]b'). apply nrootCC_1_lower. assumption. intro H. exists (a'[+I*]b'). apply nrootCC_1_upper. assumption. assumption. Qed. End NRootCC_1_ap_real. (** We now define the nth root of a complex number with a non zero real part. *) Section NRootCC_1_ap_imag. (** %\begin{convention}% Let [a,b : IR] and [a_ : (a [#] [0])] and define [c' := (a[+I*]b) [*][--]II := a'[+I*]b']. %\end{convention}% *) Variables a b : IR. Hypothesis a_ : a [#] [0]. (* begin hide *) Let c' := (a[+I*]b) [*][--]II. Let a' := Re c'. Let b' := Im c'. (* end hide *) Lemma nrootCC_1_ap_imag : {z : CC | z[^]2 [=] a[+I*]b}. Proof. elim (nrootCC_1_ap_real a' b'). intros x H. exists (x[*]sqrt_I). (* astepl x[^] (2) [*]sqrt_I[^] (2). *) apply eq_transitive_unfolded with (x[^]2[*]sqrt_I[^]2). apply mult_nexp. Hint Resolve sqrt_I_nexp: algebra. (* astepl (a'[+I*]b') [*]II. *) apply eq_transitive_unfolded with ((a'[+I*]b') [*]II). apply bin_op_wd_unfolded. exact H. exact sqrt_I_nexp. (* astepl ((a[+I*]b) [*][--]II) [*]II. *) apply eq_transitive_unfolded with ((a[+I*]b) [*][--]II[*]II). apply eq_reflexive_unfolded. (* astepl (a[+I*]b) [*] ( [--]II[*]II). *) apply eq_transitive_unfolded with ((a[+I*]b) [*] ( [--]II[*]II)). apply eq_symmetric_unfolded. apply mult_assoc_unfolded. (* Step_final (a[+I*]b) [*][1]. *) apply eq_transitive_unfolded with ((a[+I*]b) [*][1]). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. exact I_recip_lft. apply mult_one. cut (b[+I*][--]a [=] c'); intros. (* astepl (Im c'). *) apply ap_wdl_unfolded with (Im c'). 2: apply eq_reflexive_unfolded. (* astepl (Im b[+I*][--]a). *) apply ap_wdl_unfolded with (Im (b[+I*][--]a)). 2: apply Im_wd. 2: exact H. (* astepl [--]a. *) apply ap_wdl_unfolded with ( [--]a). apply zero_minus_apart. apply minus_ap_zero. apply inv_resp_ap_zero. exact a_. apply eq_reflexive_unfolded. (* astepl ( [--][--]b) [+I*][--]a. *) apply eq_transitive_unfolded with ( [--][--]b[+I*][--]a). apply I_wd. apply eq_symmetric_unfolded. apply cg_inv_inv. apply eq_reflexive_unfolded. (* astepl [--] (( [--]b) [+I*]a). *) apply eq_transitive_unfolded with ( [--] ( [--]b[+I*]a)). apply eq_reflexive_unfolded. (* astepl [--] ((a[+I*]b) [*]II). *) apply eq_transitive_unfolded with ( [--] ((a[+I*]b) [*]II)). apply un_op_wd_unfolded. apply eq_symmetric_unfolded. apply mult_I. (* Step_final (a[+I*]b) [*][--]II. *) apply eq_transitive_unfolded with ((a[+I*]b) [*][--]II). apply eq_symmetric_unfolded. apply cring_inv_mult_lft. apply eq_reflexive_unfolded. Qed. End NRootCC_1_ap_imag. (** We now define the roots of arbitrary non zero complex numbers. *) Lemma nrootCC_1 : forall c : CC, c [#] [0] -> {z : CC | z[^]2 [=] c}. Proof. intros. pattern c in |- *. apply C_cc_ap_zero; try assumption; intros. apply nrootCC_1_ap_imag. assumption. apply nrootCC_1_ap_real. assumption. Qed. End NRootCC_1. Section NRootCC_2. (** %\begin{convention}% Let [n : nat] and [c,z : CC] and [c_:(c [#] [0])]. %\end{convention}% *) Variable n : nat. Variables c z : CC. Hypothesis c_ : c [#] [0]. Lemma nrootCC_2' : (z[*]CC_conj z) [^]n [=] c[*]CC_conj c -> z[^]n[*]CC_conj c[-]CC_conj z[^]n[*]c [=] [0] -> (z[^]n) [^]2 [=] c[^]2. Proof. intros. cut (z[^]n[*]CC_conj c [=] CC_conj z[^]n[*]c); intros. apply (mult_cancel_rht _ ((z[^]n) [^]2) (c[^]2) (CC_conj c)). apply CC_conj_strext. (* astepl c. *) apply ap_wdl_unfolded with c. 2: apply eq_symmetric_unfolded. 2: apply CC_conj_conj. (* astepr ([0]::CC). *) apply ap_wdr_unfolded with ([0]:CC). exact c_. apply eq_symmetric_unfolded. exact CC_conj_zero. (* astepl (z[^]n[*]z[^]n) [*] (CC_conj c). *) apply eq_transitive_unfolded with (z[^]n[*]z[^]n[*]CC_conj c). apply bin_op_wd_unfolded. apply nexp_two. apply eq_reflexive_unfolded. (* astepl z[^]n[*] (z[^]n[*] (CC_conj c)). *) apply eq_transitive_unfolded with (z[^]n[*] (z[^]n[*]CC_conj c)). apply eq_symmetric_unfolded. apply mult_assoc_unfolded. (* astepl z[^]n[*] ((CC_conj z) [^]n[*]c). *) apply eq_transitive_unfolded with (z[^]n[*] (CC_conj z[^]n[*]c)). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. exact H1. (* astepl (z[^]n[*] (CC_conj z) [^]n) [*]c. *) apply eq_transitive_unfolded with (z[^]n[*]CC_conj z[^]n[*]c). apply mult_assoc_unfolded. (* astepl ((z[*] (CC_conj z)) [^]n) [*]c. *) apply eq_transitive_unfolded with ((z[*]CC_conj z) [^]n[*]c). apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply mult_nexp. apply eq_reflexive_unfolded. (* astepl (c[*] (CC_conj c)) [*]c. *) apply eq_transitive_unfolded with (c[*]CC_conj c[*]c). apply bin_op_wd_unfolded. exact H. apply eq_reflexive_unfolded. (* astepl c[*] (c[*] (CC_conj c)). *) apply eq_transitive_unfolded with (c[*] (c[*]CC_conj c)). apply mult_commutes. (* Step_final (c[*]c) [*] (CC_conj c). *) apply eq_transitive_unfolded with (c[*]c[*]CC_conj c). apply mult_assoc_unfolded. apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply nexp_two. apply eq_reflexive_unfolded. cut (forall (G : CGroup) (x y : G), x[-]y [=] [0] -> x [=] y); intros. apply H1. assumption. (* astepl x[+][0]. *) apply eq_transitive_unfolded with (x[+][0]). apply eq_symmetric_unfolded. apply cm_rht_unit_unfolded. (* astepl x[+] ( [--]y[+]y). *) apply eq_transitive_unfolded with (x[+] ( [--]y[+]y)). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply cg_lft_inv_unfolded. (* astepl (x[+][--]y) [+]y. *) apply eq_transitive_unfolded with (x[+][--]y[+]y). apply plus_assoc_unfolded. (* Step_final [0][+]y. *) apply eq_transitive_unfolded with ([0][+]y). apply bin_op_wd_unfolded. exact H1. apply eq_reflexive_unfolded. apply cm_lft_unit_unfolded. Qed. Lemma nrootCC_2 : (z[*]CC_conj z) [^]n [=] c[*]CC_conj c -> z[^]n[*]CC_conj c[-]CC_conj z[^]n[*]c [=] [0] -> z[^]n [=] c or z[^]n [=] [--]c. Proof. intros. apply cond_square_eq; try assumption. exact TwoCC_ap_zero. apply nrootCC_2'; assumption. Qed. End NRootCC_2. Section NRootCC_3. Fixpoint Im_poly (p : cpoly CC) : cpoly IR := match p with | cpoly_zero _ => cpoly_zero IR | cpoly_linear _ c p1 => cpoly_linear IR (Im c) (Im_poly p1) end. Lemma nrCC3_a1 : forall p r, (Im_poly p) ! r [=] Im p ! (cc_IR r). Proof. intros. elim p; intros. unfold Im_poly in |- *. (* astepl ([0]::IR). *) apply eq_transitive_unfolded with ZeroR. apply eq_reflexive_unfolded. (* Step_final (Im ([0]::CC)). *) apply eq_transitive_unfolded with (Im ([0]:CC)); apply eq_reflexive_unfolded. (* astepl (cpoly_linear ? (Im s) (Im_poly c))!r. *) apply eq_transitive_unfolded with (cpoly_linear _ (Im s) (Im_poly c)) ! r. apply eq_reflexive_unfolded. (* astepl (Im s) [+]r[*] ((Im_poly c)!r). *) apply eq_transitive_unfolded with (Im s[+]r[*] (Im_poly c) ! r). apply eq_reflexive_unfolded. (* astepl (Im s) [+]r[*] (Im (c!(cc_IR r))). *) apply eq_transitive_unfolded with (Im s[+]r[*]Im c ! (cc_IR r)). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. exact H. cut (forall (r : IR) (c : CC), r[*]Im c [=] Im (cc_IR r[*]c)); intros. (* astepl (Im s) [+] (Im (cc_IR r) [*] (c!(cc_IR r))). *) apply eq_transitive_unfolded with (Im s[+]Im (cc_IR r[*]c ! (cc_IR r))). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply H0. (* Step_final (Im s[+] (cc_IR r) [*] (c!(cc_IR r))). *) apply eq_transitive_unfolded with (Im (s[+]cc_IR r[*]c ! (cc_IR r))). apply eq_reflexive_unfolded. apply eq_reflexive_unfolded. (* astepl r0[*] (Im c0) [+][0]. *) apply eq_transitive_unfolded with (r0[*]Im c0[+][0]). apply eq_symmetric_unfolded. apply cm_rht_unit_unfolded. (* astepl r0[*] (Im c0) [+][0][*] (Re c0). *) apply eq_transitive_unfolded with (r0[*]Im c0[+][0][*]Re c0). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply cring_mult_zero_op. (* astepl (Im (r0[+I*][0]) [*] ((Re c0) [+I*] (Im c0))). *) apply eq_transitive_unfolded with (Im ((r0[+I*][0]) [*] (Re c0[+I*]Im c0))). apply eq_reflexive_unfolded. (* Step_final (Im (cc_IR r0) [*] ((Re c0) [+I*] (Im c0))). *) apply eq_transitive_unfolded with (Im (cc_IR r0[*] (Re c0[+I*]Im c0))). apply eq_reflexive_unfolded. apply eq_reflexive_unfolded. Qed. Lemma nrCC3_a2 : forall p n, nth_coeff n (Im_poly p) [=] Im (nth_coeff n p). Proof. intro. elim p; intros. unfold Im_poly in |- *. (* astepl ([0]::IR). *) apply eq_transitive_unfolded with ZeroR. apply eq_reflexive_unfolded. (* Step_final (Im ([0]::CC)). *) apply eq_transitive_unfolded with (Im ([0]:CC)). apply eq_reflexive_unfolded. apply eq_reflexive_unfolded. elim n; intros. (* Step_final (Im s). *) apply eq_transitive_unfolded with (Im s). apply eq_reflexive_unfolded. apply eq_reflexive_unfolded. (* astepl (nth_coeff ? n0 (Im_poly c)). *) apply eq_transitive_unfolded with (nth_coeff n0 (Im_poly c)). apply eq_reflexive_unfolded. (* Step_final (Im (nth_coeff CC n0 c)). *) apply eq_transitive_unfolded with (Im (nth_coeff (R:=CC) n0 c)). apply H. apply eq_reflexive_unfolded. Qed. (** %\begin{convention}% Let [a,b : IR], [b_ : (b [#] [0])] and [n : nat]. %\end{convention}% *) Variables a b : IR. Hypothesis b_ : b [#] [0]. Variable n : nat. Definition nrCC3_poly'' := (_X_[+]_C_ II) [^]n. Lemma nrCC3_a3 : forall r : IR, nrCC3_poly'' ! (cc_IR r) [=] (r[+I*][1]) [^]n. Proof. intros. unfold nrCC3_poly'' in |- *. (* astepl ((_X_[+] (_C_ II))!(cc_IR r)) [^]n. *) apply eq_transitive_unfolded with ((_X_[+]_C_ II) ! (cc_IR r) [^]n). apply nexp_apply. (* astepl ((_X_!(cc_IR r)) [+] ((_C_) II)!(cc_IR r)) [^]n. *) apply eq_transitive_unfolded with ((_X_ ! (cc_IR r) [+] (_C_ II) ! (cc_IR r)) [^]n). apply un_op_wd_unfolded. apply plus_apply. cut (forall c x : CC, _X_ ! x[+] (_C_ c) ! x [=] x[+]c); intros. (* astepl ((cc_IR r) [+]II) [^]n. *) apply eq_transitive_unfolded with ((cc_IR r[+]II) [^]n). apply un_op_wd_unfolded. apply H. (* astepl ((r[+I*][0]) [+] ([0][+I*][1])) [^]n. *) apply eq_transitive_unfolded with ((r[+I*][0][+][0][+I*][1]) [^]n). apply eq_reflexive_unfolded. (* Step_final ((r[+][0]) [+I*] ([0][+][1])) [^]n. *) apply eq_transitive_unfolded with (((r[+][0]) [+I*] ([0][+][1])) [^]n). apply eq_reflexive_unfolded. apply un_op_wd_unfolded. apply I_wd. apply cm_rht_unit_unfolded. apply cm_lft_unit_unfolded. (* algebra. *) apply bin_op_wd_unfolded. apply x_apply. apply c_apply. Qed. Lemma nrCC3_a4 : degree_le 1 (_X_[+]_C_ II). Proof. apply degree_imp_degree_le. cut (degree 1 (_C_ II[+]_X_)); intros. apply (degree_wd _ (_C_ II[+]_X_)). (* algebra. *) apply cag_commutes_unfolded. (* algebra. *) rename X into H. exact H. apply (degree_plus_rht _ (_C_ II) _X_ 0 1). apply degree_le_c_. apply degree_x_. auto with arith. Qed. Lemma nrCC3_a5 : degree_le n nrCC3_poly''. Proof. replace n with (1 * n). unfold nrCC3_poly'' in |- *. apply degree_le_nexp. exact nrCC3_a4. unfold mult in |- *. auto with arith. Qed. Lemma nrCC3_a6 : nth_coeff n nrCC3_poly'' [=] [1]. Proof. cut (monic n nrCC3_poly''); intros. unfold monic in H. elim H; intros; assumption. replace n with (1 * n). unfold nrCC3_poly'' in |- *. apply monic_nexp. unfold monic in |- *; split. (* algebra. *) apply eq_reflexive_unfolded. exact nrCC3_a4. unfold mult in |- *. auto with arith. Qed. Definition nrCC3_poly' := nrCC3_poly''[*]_C_ (a[+I*][--]b). Lemma nrCC3_a7 : forall r : IR, nrCC3_poly' ! (cc_IR r) [=] (r[+I*][1]) [^]n[*] (a[+I*][--]b). Proof. intros. unfold nrCC3_poly' in |- *. (* astepl (nrCC3_poly''!(cc_IR r)) [*] ((_C_ a[+I*][--]b)!(cc_IR r)). *) apply eq_transitive_unfolded with (nrCC3_poly'' ! (cc_IR r) [*] (_C_ (a[+I*][--]b)) ! (cc_IR r)). apply mult_apply. Hint Resolve nrCC3_a3: algebra. (* Step_final (nrCC3_poly''!(cc_IR r)) [*] (a[+I*][--]b). *) apply eq_transitive_unfolded with (nrCC3_poly'' ! (cc_IR r) [*] (a[+I*][--]b)). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply c_apply. apply bin_op_wd_unfolded. apply nrCC3_a3. apply eq_reflexive_unfolded. Qed. Lemma nrCC3_a8 : degree_le n nrCC3_poly'. Proof. replace n with (n + 0). unfold nrCC3_poly' in |- *. apply degree_le_mult. exact nrCC3_a5. apply degree_le_c_. auto with arith. Qed. Lemma nrCC3_a9 : nth_coeff n nrCC3_poly' [=] a[+I*][--]b. Proof. unfold nrCC3_poly' in |- *. Hint Resolve nth_coeff_p_mult_c_: algebra. (* astepl (nth_coeff n nrCC3_poly'') [*] (a[+I*][--]b). *) apply eq_transitive_unfolded with (nth_coeff n nrCC3_poly''[*] (a[+I*][--]b)). apply nth_coeff_p_mult_c_. Hint Resolve nrCC3_a6: algebra. (* Step_final [1][*] (a[+I*][--]b). *) apply eq_transitive_unfolded with ([1][*] (a[+I*][--]b)). apply bin_op_wd_unfolded. exact nrCC3_a6. apply eq_reflexive_unfolded. apply one_mult. Qed. Definition nrootCC_3_poly := Im_poly nrCC3_poly'. Lemma nrootCC_3_ : forall r : IR, nrootCC_3_poly ! r [=] Im ((r[+I*][1]) [^]n[*] (a[+I*][--]b)). Proof. intros. unfold nrootCC_3_poly in |- *. Hint Resolve nrCC3_a1 nrCC3_a7: algebra. (* Step_final (Im (nrCC3_poly'!(cc_IR r))). *) apply eq_transitive_unfolded with (Im nrCC3_poly' ! (cc_IR r)). apply nrCC3_a1. apply Im_wd. apply nrCC3_a7. Qed. Lemma nrootCC_3 : forall r : IR, cc_IR nrootCC_3_poly ! r[*] (Two[*]II) [=] (r[+I*][1]) [^]n[*] (a[+I*][--]b) [-] (r[+I*][--][1]) [^]n[*] (a[+I*]b). Proof. intros. cut (CC_conj ((r[+I*][1]) [^]n[*] (a[+I*][--]b)) [=] (r[+I*][--][1]) [^]n[*] (a[+I*]b)); intros. Hint Resolve nrootCC_3_: algebra. (* astepl (cc_IR (Im (r[+I*][1]) [^]n[*] (a[+I*][--]b))) [*] (Two[*]II). *) apply eq_transitive_unfolded with (cc_IR (Im ((r[+I*][1]) [^]n[*] (a[+I*][--]b))) [*] (Two[*]II)). apply bin_op_wd_unfolded. apply cc_IR_wd. apply nrootCC_3_. apply eq_reflexive_unfolded. Hint Resolve calculate_Im: algebra. (* Step_final (r[+I*][1]) [^]n[*] (a[+I*][--]b) [-] (CC_conj (r[+I*][1]) [^]n[*] (a[+I*][--]b)). *) apply eq_transitive_unfolded with ((r[+I*][1]) [^]n[*] (a[+I*][--]b) [-] CC_conj ((r[+I*][1]) [^]n[*] (a[+I*][--]b))). apply calculate_Im. apply cg_minus_wd. apply eq_reflexive_unfolded. exact H. (* astepl (CC_conj (r[+I*][1]) [^]n) [*] (CC_conj a[+I*][--]b). *) apply eq_transitive_unfolded with (CC_conj ((r[+I*][1]) [^]n) [*]CC_conj (a[+I*][--]b)). apply CC_conj_mult. (* Step_final (CC_conj r[+I*][1]) [^]n[*]a[+I*][--][--]b. *) apply eq_transitive_unfolded with (CC_conj (r[+I*][1]) [^]n[*] (a[+I*][--][--]b)). apply bin_op_wd_unfolded. apply CC_conj_nexp. apply eq_reflexive_unfolded. apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply I_wd. apply eq_reflexive_unfolded. apply cg_inv_inv. Qed. Lemma nrootCC_3_degree : degree n nrootCC_3_poly. Proof. unfold degree in |- *. split. cut (nth_coeff n nrootCC_3_poly [=] [--]b); intros. (* astepl [--]b. *) apply ap_wdl_unfolded with ( [--]b). apply zero_minus_apart. apply minus_ap_zero. apply inv_resp_ap_zero. exact b_. apply eq_symmetric_unfolded. exact H. unfold nrootCC_3_poly in |- *. Hint Resolve nrCC3_a2: algebra. (* astepl (Im (nth_coeff n nrCC3_poly')). *) apply eq_transitive_unfolded with (Im (nth_coeff n nrCC3_poly')). apply nrCC3_a2. Hint Resolve nrCC3_a9: algebra. (* Step_final (Im a[+I*][--]b). *) apply eq_transitive_unfolded with (Im (a[+I*][--]b)). apply Im_wd. exact nrCC3_a9. apply eq_reflexive_unfolded. cut (forall (p : cpoly CC) (n : nat), degree_le n p -> degree_le n (Im_poly p)); intros. unfold nrootCC_3_poly in |- *. apply H. exact nrCC3_a8. unfold degree_le in |- *. unfold degree_le in H. intros. (* astepl (Im (nth_coeff m p)). *) apply eq_transitive_unfolded with (Im (nth_coeff m p)). apply nrCC3_a2. (* Step_final (Im ([0]::CC)). *) apply eq_transitive_unfolded with (Im ([0]:CC)). apply Im_wd. apply H. exact H0. apply eq_reflexive_unfolded. Qed. End NRootCC_3. Section NRootCC_3'. (** %\begin{convention}% Let [c:IR], [n:nat] and [n_:(lt (0) n)]. %\end{convention}% *) Variable c : IR. Variable n : nat. Hypothesis n_ : 0 < n. Definition nrootCC_3'_poly := _X_[^]n[-]_C_ c. Lemma nrootCC_3' : forall x : IR, nrootCC_3'_poly ! x [=] x[^]n[-]c. Proof. intros. unfold nrootCC_3'_poly in |- *. cut ((_X_[^]n) ! x [=] x[^]n). intros. (* Step_final (_X_[^]n)!x[-] (_C_ c)!x. *) apply eq_transitive_unfolded with ((_X_[^]n) ! x[-] (_C_ c) ! x). apply minus_apply. apply cg_minus_wd. exact H. apply c_apply. (* Step_final (_X_!x) [^]n. *) apply eq_transitive_unfolded with (_X_ ! x[^]n). apply nexp_apply. apply un_op_wd_unfolded. apply x_apply. Qed. Lemma nrootCC_3'_degree : degree n nrootCC_3'_poly. Proof. unfold nrootCC_3'_poly in |- *. apply (degree_minus_lft _ (_C_ c) (_X_[^]n) 0 n). apply degree_le_c_. (* Replace (degree IR n) with (degree IR (mult (1) n)). *) pattern n at 1 in |- *; replace n with (1 * n). apply degree_nexp. apply degree_x_. replace (1 * n) with n; [auto|..]. unfold mult in |- *. auto with arith. assumption. Qed. End NRootCC_3'. Section NRootCC_4. Section NRootCC_4_ap_real. (** %\begin{convention}% Let [a,b : IR], [b_ : (b [#] [0])], [n : nat] and [n_:(odd n)]; define [c := a[+I*]b]. %\end{convention}% *) Variables a b : IR. Hypothesis b_ : b [#] [0]. Variable n : nat. Hypothesis n_ : Nat.Odd n. (* begin hide *) Let c := a[+I*]b. (* end hide *) Section NRootCC_4_solutions. Lemma nrCC4_a1 : {r : IR | (r[+I*][1]) [^]n[*]CC_conj c[-] (r[+I*][--][1]) [^]n[*]c [=] [0]}. Proof. elim (realpolyn_oddhaszero (nrootCC_3_poly a b n)). intro r. intro H. exists r. (* astepl (r[+I*][1]) [^]n[*] (a[+I*][--]b) [-] (r[+I*][--][1]) [^]n[*] (a[+I*]b). *) apply eq_transitive_unfolded with ((r[+I*][1]) [^]n[*] (a[+I*][--]b) [-] (r[+I*][--][1]) [^]n[*] (a[+I*]b)). apply eq_reflexive_unfolded. Hint Resolve nrootCC_3: algebra. (* astepl (cc_IR ((nrootCC_3_poly a b n)!r)) [*] (Two[*]II). *) apply eq_transitive_unfolded with (cc_IR (nrootCC_3_poly a b n) ! r[*] (Two[*]II)). apply eq_symmetric_unfolded. apply nrootCC_3. (* astepl (cc_IR [0]) [*] (Two[*]II). *) apply eq_transitive_unfolded with (cc_IR [0][*] (Two[*]II)). apply bin_op_wd_unfolded. apply cc_IR_wd. exact H. apply eq_reflexive_unfolded. (* Step_final [0][*] (Two[*]II). *) apply eq_transitive_unfolded with ([0][*] (Two[*]II)). apply eq_reflexive_unfolded. apply cring_mult_zero_op. unfold odd_cpoly in |- *. exists n. apply to_Codd. assumption. apply (nrootCC_3_degree a b b_ n). Qed. (** %\begin{convention}% Let [r2',c2 : IR] and [r2'_ : (r2' [#] [0])]. %\end{convention}% *) Variables r2' c2 : IR. Hypothesis r2'_ : r2' [#] [0]. Lemma nrCC4_a1' : {y2 : IR | (y2[*]r2') [^]n [=] c2}. Proof. elim (realpolyn_oddhaszero (nrootCC_3'_poly c2 n)). intro y2r2'. intros. exists (y2r2'[/] r2'[//]r2'_). (* astepl y2r2'[^]n. *) apply eq_transitive_unfolded with (y2r2'[^]n). apply un_op_wd_unfolded. apply div_1. (* astepl y2r2'[^]n[+][0]. *) apply eq_transitive_unfolded with (y2r2'[^]n[+][0]). apply eq_symmetric_unfolded. apply cm_rht_unit_unfolded. (* astepl y2r2'[^]n[+] ( [--]c2[+]c2). *) apply eq_transitive_unfolded with (y2r2'[^]n[+] ( [--]c2[+]c2)). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply cg_lft_inv_unfolded. (* astepl (y2r2'[^]n[+][--]c2) [+]c2. *) apply eq_transitive_unfolded with (y2r2'[^]n[+][--]c2[+]c2). apply plus_assoc_unfolded. (* astepl (y2r2'[^]n[-]c2) [+]c2. *) apply eq_transitive_unfolded with (y2r2'[^]n[-]c2[+]c2). apply eq_reflexive_unfolded. Hint Resolve nrootCC_3': algebra. (* astepl (nrootCC_3'_poly c2 n)!y2r2'[+]c2. *) apply eq_transitive_unfolded with ((nrootCC_3'_poly c2 n) ! y2r2'[+]c2). apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply nrootCC_3'. apply eq_reflexive_unfolded. (* Step_final [0][+]c2. *) apply eq_transitive_unfolded with ([0][+]c2). apply bin_op_wd_unfolded. assumption. apply eq_reflexive_unfolded. apply cm_lft_unit_unfolded. unfold odd_cpoly in |- *. exists n. apply to_Codd. assumption. apply nrootCC_3'_degree. destruct n_ as [k ->]; rewrite Nat.add_1_r; exact (Nat.lt_0_succ _). Qed. End NRootCC_4_solutions. Section NRootCC_4_equations. (** %\begin{convention}% Let [r,y2 : IR] be such that [(r[+I*][1]) [^]n[*] (CC_conj c) [-] (r[+I*][--][1]) [^]n[*]c [=] [0]] and [(y2[*] (r[^] (2) [+][1])) [^]n [=] a[^] (2) [+]b[^] (2)]. %\end{convention}% *) Variable r : IR. Hypothesis r_property : (r[+I*][1]) [^]n[*]CC_conj c[-] (r[+I*][--][1]) [^]n[*]c [=] [0]. Variable y2 : IR. Hypothesis y2_property : (y2[*] (r[^]2[+][1])) [^]n [=] a[^]2[+]b[^]2. Lemma nrCC4_a2 : [0] [<] a[^]2[+]b[^]2. Proof. apply plus_resp_nonneg_pos. apply sqr_nonneg. apply pos_square. assumption. Qed. Lemma nrCC4_a3 : [0] [<] r[^]2[+][1]. Proof. apply plus_resp_nonneg_pos. apply sqr_nonneg. apply pos_one. Qed. Lemma nrCC4_a4 : [0] [<] y2. Proof. apply mult_cancel_pos_lft with (r[^]2[+][1]). apply odd_power_cancel_pos with n. assumption. apply (pos_wd _ _ _ y2_property). apply nrCC4_a2. apply less_leEq; apply nrCC4_a3. Qed. Definition nrCC4_y := sqrt y2 (less_leEq _ _ _ nrCC4_a4). Let y := nrCC4_y. Definition nrCC4_x := y[*]r. Let x := nrCC4_x. Lemma nrCC4_a5 : x [=] y[*]r. Proof. unfold x in |- *. unfold nrCC4_x in |- *. (* algebra. *) apply eq_reflexive_unfolded. Qed. Lemma nrCC4_a6 : (x[^]2[+]y[^]2) [^]n [=] a[^]2[+]b[^]2. Proof. unfold x in |- *. unfold nrCC4_x in |- *. cut ((y[*]r) [^]2[+]y[^]2 [=] y[^]2[*] (r[^]2[+][1])). intro. (* astepl (y[^] (2) [*] (r[^] (2) [+][1])) [^]n. *) apply eq_transitive_unfolded with ((y[^]2[*] (r[^]2[+][1])) [^]n). apply un_op_wd_unfolded. exact H. cut (y[^]2 [=] y2). intro. (* Step_final (y2[*] (r[^] (2) [+][1])) [^]n. *) apply eq_transitive_unfolded with ((y2[*] (r[^]2[+][1])) [^]n). apply un_op_wd_unfolded. apply bin_op_wd_unfolded. exact H0. apply eq_reflexive_unfolded. exact y2_property. unfold y in |- *. unfold nrCC4_y in |- *. apply sqrt_sqr. (* Step_final y[^] (2) [*]r[^] (2) [+]y[^] (2) [*][1]. *) apply eq_transitive_unfolded with (y[^]2[*]r[^]2[+]y[^]2[*][1]). apply bin_op_wd_unfolded. apply mult_nexp. apply eq_symmetric_unfolded. apply mult_one. apply eq_symmetric_unfolded. apply ring_dist_unfolded. Qed. Definition nrCC4_z := x[+I*]y. Let z := nrCC4_z. Lemma nrCC4_a7 : z[^]n[*]CC_conj c[-]CC_conj z[^]n[*]c [=] [0]. Proof. unfold z in |- *. unfold nrCC4_z in |- *. (* astepl (x[+I*]y) [^]n[*] (CC_conj c) [-] (x[+I*][--]y) [^]n[*]c. *) apply eq_transitive_unfolded with ((x[+I*]y) [^]n[*]CC_conj c[-] (x[+I*][--]y) [^]n[*]c). apply eq_reflexive_unfolded. unfold x in |- *. unfold nrCC4_x in |- *. cut ((y[*]r[+I*]y) [^]n[*]CC_conj c [=] cc_IR y[^]n[*] ((r[+I*][1]) [^]n[*]CC_conj c)). intro. cut ((y[*]r[+I*][--]y) [^]n[*]c [=] cc_IR y[^]n[*] ((r[+I*][--][1]) [^]n[*]c)). intro. (* astepl (cc_IR y) [^]n[*] ((r[+I*][1]) [^]n[*] (CC_conj c)) [-] (cc_IR y) [^]n[*] ((r[+I*][--][1]) [^]n[*]c). *) apply eq_transitive_unfolded with (cc_IR y[^]n[*] ((r[+I*][1]) [^]n[*]CC_conj c) [-] cc_IR y[^]n[*] ((r[+I*][--][1]) [^]n[*]c)). apply cg_minus_wd. exact H. exact H0. (* astepl (cc_IR y) [^]n[*] (((r[+I*][1]) [^]n[*] (CC_conj c)) [-] ((r[+I*][--][1]) [^]n[*]c)). *) apply eq_transitive_unfolded with (cc_IR y[^]n[*] ((r[+I*][1]) [^]n[*]CC_conj c[-] (r[+I*][--][1]) [^]n[*]c)). apply eq_symmetric_unfolded. apply dist_2a. (* Step_final (cc_IR y) [^]n[*][0]. *) apply eq_transitive_unfolded with (cc_IR y[^]n[*][0]). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. exact r_property. apply cring_mult_zero. cut ((y[*]r[+I*][--]y) [^]n [=] cc_IR y[^]n[*] (r[+I*][--][1]) [^]n). intro. (* Step_final ((cc_IR y) [^]n[*] (r[+I*][--][1]) [^]n) [*]c. *) apply eq_transitive_unfolded with (cc_IR y[^]n[*] (r[+I*][--][1]) [^]n[*]c). apply bin_op_wd_unfolded. exact H0. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply mult_assoc_unfolded. cut (y[*]r[+I*][--]y [=] cc_IR y[*] (r[+I*][--][1])). intro. (* Step_final ((cc_IR y) [*] (r[+I*][--][1])) [^]n. *) apply eq_transitive_unfolded with ((cc_IR y[*] (r[+I*][--][1])) [^]n). apply un_op_wd_unfolded. exact H0. apply mult_nexp. cut ( [--]y [=] y[*][--][1]). intro. (* Step_final (y[*]r) [+I*] (y[*][--][1]). *) apply eq_transitive_unfolded with (y[*]r[+I*]y[*][--][1]). apply I_wd. apply eq_reflexive_unfolded. exact H0. apply eq_symmetric_unfolded. apply cc_IR_mult_rht. (* Step_final [--] (y[*][1]). *) apply eq_transitive_unfolded with ( [--] (y[*][1])). apply un_op_wd_unfolded. apply eq_symmetric_unfolded. apply mult_one. apply eq_symmetric_unfolded. apply cring_inv_mult_lft. cut ((y[*]r[+I*]y) [^]n [=] cc_IR y[^]n[*] (r[+I*][1]) [^]n). intro. (* Step_final ((cc_IR y) [^]n[*] (r[+I*][1]) [^]n) [*] (CC_conj c). *) apply eq_transitive_unfolded with (cc_IR y[^]n[*] (r[+I*][1]) [^]n[*]CC_conj c). apply bin_op_wd_unfolded. exact H. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply mult_assoc_unfolded. cut (y[*]r[+I*]y [=] cc_IR y[*] (r[+I*][1])). intro. (* Step_final ((cc_IR y) [*] (r[+I*][1])) [^]n. *) apply eq_transitive_unfolded with ((cc_IR y[*] (r[+I*][1])) [^]n). apply un_op_wd_unfolded. exact H. apply mult_nexp. (* Step_final (y[*]r) [+I*] (y[*][1]). *) apply eq_transitive_unfolded with (y[*]r[+I*]y[*][1]). apply I_wd. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply mult_one. apply eq_symmetric_unfolded. apply cc_IR_mult_rht. Qed. Lemma nrCC4_a8 : (z[*]CC_conj z) [^]n [=] c[*]CC_conj c. Proof. unfold z in |- *. unfold nrCC4_z in |- *. unfold c in |- *. (* astepl (cc_IR x[^] (2) [+]y[^] (2)) [^]n. *) apply eq_transitive_unfolded with (cc_IR (x[^]2[+]y[^]2) [^]n). apply un_op_wd_unfolded. apply calculate_norm. (* astepl (cc_IR (x[^] (2) [+]y[^] (2)) [^]n). *) apply eq_transitive_unfolded with (cc_IR ((x[^]2[+]y[^]2) [^]n)). apply cc_IR_nexp. Hint Resolve nrCC4_a6: algebra. (* Step_final (cc_IR (a[^] (2) [+]b[^] (2))). *) apply eq_transitive_unfolded with (cc_IR (a[^]2[+]b[^]2)). apply cc_IR_wd. exact nrCC4_a6. apply eq_symmetric_unfolded. apply calculate_norm. Qed. Lemma nrCC4_a9 : z[^]n [=] c or z[^]n [=] [--]c. Proof. apply nrootCC_2. right. (* astepl b. *) apply ap_wdl_unfolded with b. exact b_. apply eq_reflexive_unfolded. apply nrCC4_a8. apply nrCC4_a7. Qed. End NRootCC_4_equations. Lemma nrCC4_a10 : forall c, {z : CC | z[^]n [=] c or z[^]n [=] [--]c} -> {z : CC | z[^]n [=] c}. Proof. intros c0 H. elim H. intros x H0. elim H0; intro H1. exists x. assumption. exists ( [--]x). (* astepl [--] (x[^]n). *) apply eq_transitive_unfolded with ( [--] (x[^]n)). apply inv_nexp_odd. assumption. (* Step_final [--][--]c0. *) apply eq_transitive_unfolded with ( [--][--]c0). apply un_op_wd_unfolded. exact H1. apply cg_inv_inv. Qed. Lemma nrootCC_4_ap_real : {z : CC | z[^]n [=] c}. Proof. apply nrCC4_a10. elim nrCC4_a1. intro r. intro H. elim (nrCC4_a1' (r[^]2[+][1]) (a[^]2[+]b[^]2)). intro y2. intro H0. exists (nrCC4_z r y2 H0). apply nrCC4_a9. assumption. change (r[^]2[+][1] [#] [0]) in |- *. apply pos_ap_zero. apply nrCC4_a3. Qed. End NRootCC_4_ap_real. Section NRootCC_4_ap_imag. (** %\begin{convention}% Let [a,b : IR] and [n : nat] with [a [#] [0]] and [(odd n)]; define [c' := (a[+I*]b) [*]II := a'[+I*]b']. %\end{convention}% *) Variables a b : IR. Hypothesis a_ : a [#] [0]. Variable n : nat. Hypothesis n_ : Nat.Odd n. (* begin hide *) Let c' := (a[+I*]b) [*]II. Let a' := Re c'. Let b' := Im c'. (* end hide *) Lemma nrootCC_4_ap_real' : {z' : CC | z'[^]n [=] a'[+I*]b'}. Proof. apply nrootCC_4_ap_real; try assumption. apply (imag_to_real a b a' b'). (* algebra. *) apply eq_reflexive_unfolded. (* algebra. *) exact a_. Qed. Lemma nrootCC_4_ap_imag : {z : CC | z[^]n [=] a[+I*]b}. Proof. elim nrootCC_4_ap_real'. intro z'. intro H. exists (z'[*]nroot_minus_I n n_). (* astepl z'[^]n[*] (nroot_minus_I n on) [^]n. *) apply eq_transitive_unfolded with (z'[^]n[*]nroot_minus_I n n_[^]n). apply mult_nexp. Hint Resolve nroot_minus_I_nexp: algebra. (* astepl (a'[+I*]b') [*][--]II. *) apply eq_transitive_unfolded with ((a'[+I*]b') [*][--]II). apply bin_op_wd_unfolded. exact H. apply nroot_minus_I_nexp. (* astepl ((a[+I*]b) [*]II) [*][--]II. *) apply eq_transitive_unfolded with ((a[+I*]b) [*]II[*][--]II). apply eq_reflexive_unfolded. (* astepl (a[+I*]b) [*] (II[*][--]II). *) apply eq_transitive_unfolded with ((a[+I*]b) [*] (II[*][--]II)). apply eq_symmetric_unfolded. apply mult_assoc_unfolded. (* Step_final (a[+I*]b) [*][1]. *) apply eq_transitive_unfolded with ((a[+I*]b) [*][1]). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. exact I_recip_rht. apply mult_one. Qed. End NRootCC_4_ap_imag. Lemma nrootCC_4 : forall c, c [#] [0] -> forall n, Nat.Odd n -> {z : CC | z[^]n [=] c}. Proof. intros. pattern c in |- *. apply C_cc_ap_zero; try assumption; intros. apply nrootCC_4_ap_imag; try assumption. apply nrootCC_4_ap_real; try assumption. Qed. End NRootCC_4. (** Finally, the general definition of nth root. *) Section NRootCC_5. Lemma nrCC_5a2 : forall n : nat, Nat.double n = 2 * n. Proof. intros. unfold Nat.double in |- *. unfold mult in |- *. auto with arith. Qed. Lemma nrCC_5a3 : forall (n : nat) (z : CC), (z[^]2) [^]n [=] z[^]Nat.double n. Proof. intros. (* astepl z[^] (mult (2) n). *) apply eq_transitive_unfolded with (z[^] (2 * n)). apply nexp_mult. rewrite <- nrCC_5a2. (* algebra. *) apply eq_reflexive_unfolded. Qed. Hint Resolve nrCC_5a3: algebra. (** %\begin{convention}% Let [c : CC] with [c [#] [0]]. %\end{convention}% *) Variable c : CC. Hypothesis c_ : c [#] [0]. Lemma nrCC_5a4 : forall n, 0 < n -> {z : CC | z[^]n [=] c} -> {z : CC | z[^]Nat.double n [=] c}. Proof. intros n H H0. elim H0. intros x H1. elim (nrootCC_1 x). intros x0 H2. exists x0. (* astepl (x0[^] (2)) [^]n. *) apply eq_transitive_unfolded with ((x0[^]2) [^]n). apply eq_symmetric_unfolded. apply nrCC_5a3. (* Step_final x[^]n. *) apply eq_transitive_unfolded with (x[^]n). apply un_op_wd_unfolded. exact H2. exact H1. apply (cs_un_op_strext _ (nexp_op (R:=CC) n)). (* astepl c. *) apply ap_wdl_unfolded with c. 2: apply eq_symmetric_unfolded. 2: exact H1. (* astepr ([0]::CC). *) apply ap_wdr_unfolded with ([0]:CC). exact c_. apply eq_symmetric_unfolded. apply zero_nexp. exact H. Qed. Lemma nrootCC_5 : forall n : nat, 0 < n -> {z : CC | z[^]n [=] c}. Proof. intros. pattern n in |- *. apply odd_double_ind. exact (nrootCC_4 c c_). exact nrCC_5a4. assumption. Qed. End NRootCC_5. (** Final definition *) Definition CnrootCC : forall c, c [#] [0] -> forall n, 0 < n -> {z : CC | z[^]n [=] c} := nrootCC_5. corn-8.20.0/configure.sh000077500000000000000000000005011473720167500150720ustar00rootroot00000000000000#!/usr/bin/env sh # Produce files Make and Makefile cp -f Make.in Make DIRECTORIES="algebra complex coq_reals fta ftc liouville logic metrics model raster reals tactics transc order metric2 stdlib_omissions util classes ode write_image" find $DIRECTORIES -name "*.v" >>Make ${COQBIN}coq_makefile -f Make -o Makefile corn-8.20.0/coq-corn.opam000066400000000000000000000043301473720167500151550ustar00rootroot00000000000000opam-version: "2.0" maintainer: "b.a.w.spitters@gmail.com" version: "dev" homepage: "https://github.com/coq-community/corn" dev-repo: "git+https://github.com/coq-community/corn.git" bug-reports: "https://github.com/coq-community/corn/issues" license: "GPL-2.0" synopsis: "The Coq Constructive Repository at Nijmegen." description: """ CoRN includes the following parts: - Algebraic Hierarchy An axiomatic formalization of the most common algebraic structures, including setoids, monoids, groups, rings, fields, ordered fields, rings of polynomials, real and complex numbers - Model of the Real Numbers Construction of a concrete real number structure satisfying the previously defined axioms - Fundamental Theorem of Algebra A proof that every non-constant polynomial on the complex plane has at least one root - Real Calculus A collection of elementary results on real analysis, including continuity, differentiability, integration, Taylor's theorem and the Fundamental Theorem of Calculus - Exact Real Computation Fast verified computation inside Coq. This includes: real numbers, functions, integrals, graphs of functions, differential equations. """ build: [ ["./configure.sh"] [make "-j%{jobs}%"] ] install: [make "install"] depends: [ "coq" {(>= "8.18" & < "8.20~") | (= "dev")} "coq-math-classes" {(>= "8.8.1") | (= "dev")} "coq-elpi" {(>= "1.18.0") | (= "dev")} "coq-bignums" ] tags: [ "category:Mathematics/Algebra" "category:Mathematics/Real Calculus and Topology" "category:Mathematics/Exact Real computation" "keyword:constructive mathematics" "keyword:algebra" "keyword:real calculus" "keyword:real numbers" "keyword:Fundamental Theorem of Algebra" "logpath:CoRN" ] authors: [ "Evgeny Makarov" "Robbert Krebbers" "Eelis van der Weegen" "Bas Spitters" "Jelle Herold" "Russell O'Connor" "Cezary Kaliszyk" "Dan Synek" "Luís Cruz-Filipe" "Milad Niqui" "Iris Loeb" "Herman Geuvers" "Randy Pollack" "Freek Wiedijk" "Jan Zwanenburg" "Dimitri Hendriks" "Henk Barendregt" "Mariusz Giero" "Rik van Ginneken" "Dimitri Hendriks" "Sébastien Hinderer" "Bart Kirkels" "Pierre Letouzey" "Lionel Mamane" "Nickolay Shmyrev" "Vincent Semeria" ] corn-8.20.0/coq_reals/000077500000000000000000000000001473720167500145265ustar00rootroot00000000000000corn-8.20.0/coq_reals/Rreals.v000066400000000000000000000264741473720167500161620ustar00rootroot00000000000000(* Copyright © 2008-2008 * Cezary Kaliszyk * Russell O'Connor * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Import CoRN.algebra.CSetoids. Require Import CoRN.algebra.CSemiGroups. Require Import CoRN.algebra.CMonoids. Require Import CoRN.algebra.CGroups. Require Import CoRN.tactics.CornTac. Require Import CoRN.algebra.CAbGroups. Require Import CoRN.algebra.CRings. Require Import CoRN.algebra.CFields. Require Import CoRN.algebra.COrdFields. Require Import CoRN.reals.CReals. Require Import Coq.Reals.RIneq. Require Import Coq.Reals.Rcomplete. Require Import Coq.Reals.Rlimit. Require Import Coq.Reals.Rbasic_fun. From Coq Require Import Lra. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Open Scope R_scope. (** * Coq Real Numbers Warning: The Coq real numbers depend on classical logic. Importing this module will give you classical logic, the axioms of Coq's real number structure, plus all the logical consquences of these axioms. To avoid these consequences, use CoRN's real number structure [IR] instead. Here we show that the real numbers from the Coq standard library form a real number structure. This is done in the usual way by building up the algebraic heirarchy. *) (** ** Coq real numbers form a setoid *) Lemma R_is_CSetoid: is_CSetoid R (@eq R) (fun x y : R => x <> y). Proof. constructor. unfold irreflexive. intros x H. apply H; reflexivity. unfold Csymmetric. intros x y H. auto. unfold cotransitive. intros x y H z. elim (total_order_T x z); intro H1. elim H1; intro H2. left. apply Rlt_not_eq; assumption. right. rewrite <- H2. assumption. left. apply Rgt_not_eq; assumption. unfold tight_apart. intros x y. constructor. intro xy. elim (total_order_T x y); intro H1. elim H1; clear H1; intro H2. exfalso. apply xy. apply Rlt_not_eq; assumption. assumption. exfalso. apply xy. apply Rgt_not_eq; assumption. intros H H0. apply H0; assumption. Qed. Definition RCSetoid : CSetoid := Build_CSetoid R (@eq R) (fun x y => x <> y) R_is_CSetoid. Canonical Structure RCSetoid. Canonical Structure RSetoid := cs_crr RCSetoid. (** ** Coq real numbers form a semigroup *) (** addition *) Lemma RPlus_is_setoid_bin_fun: bin_fun_strext RCSetoid RCSetoid RCSetoid Rplus. Proof. unfold bin_fun_strext. intros x1 x2 y1 y2 H. elim (total_order_T x1 x2); intro H1. elim H1; clear H1; intro H2. left. apply: Rlt_not_eq; assumption. right. intro H0. apply H. rewrite H2. rewrite H0. reflexivity. left. apply: Rgt_not_eq; assumption. Qed. Definition RPlus_sbinfun : CSetoid_bin_op RCSetoid := Build_CSetoid_bin_op RCSetoid Rplus RPlus_is_setoid_bin_fun. Lemma R_is_CSemiGroup : is_CSemiGroup RCSetoid RPlus_sbinfun. Proof. unfold is_CSemiGroup. unfold associative. intros x y z. apply eq_symmetric. apply Rplus_assoc. Qed. Definition RSemiGroup : CSemiGroup := Build_CSemiGroup RCSetoid RPlus_sbinfun R_is_CSemiGroup. Canonical Structure RSemiGroup. (** ** Coq real numbers form a monoid *) Lemma R_is_CMonoid : is_CMonoid RSemiGroup (0%R). Proof. constructor. unfold is_rht_unit. intro x. apply Rplus_0_r. unfold is_lft_unit. apply Rplus_0_l. Qed. Definition RMonoid : CMonoid := Build_CMonoid _ _ R_is_CMonoid. Canonical Structure RMonoid. (** ** Coq real numbers form a group *) (** negation *) Lemma RNeg_sunop : fun_strext (S1:=RCSetoid) (S2:=RCSetoid) Ropp. Proof. unfold fun_strext. intros x y H H0. apply H. rewrite H0. reflexivity. Qed. Definition RNeg_op : CSetoid_un_op RMonoid := Build_CSetoid_un_op RCSetoid Ropp RNeg_sunop. Lemma R_is_Group : is_CGroup RMonoid RNeg_op. Proof. unfold is_CGroup. intro x. unfold is_inverse. split. apply Rplus_opp_r. apply Rplus_opp_l. Qed. Definition RGroup := Build_CGroup _ _ R_is_Group. Canonical Structure RGroup. (** ** Coq real numbers form an abelian group *) Lemma R_is_AbGroup : is_CAbGroup RGroup. Proof. unfold is_CAbGroup. unfold commutes. intros x y. apply Rplus_comm. Qed. Definition RAbGroup := Build_CAbGroup _ R_is_AbGroup. Canonical Structure RAbGroup. (** ** Coq real numbers form a ring *) (** multiplication *) Lemma RMul_is_csbinop : bin_fun_strext RCSetoid RCSetoid RCSetoid Rmult. Proof. unfold bin_fun_strext. intros x1 x2 y1 y2 H. elim (total_order_T x1 x2); intro H1. elim H1; clear H1; intro H2. left. apply: Rlt_not_eq; assumption. right. Focus 2. left. apply: Rgt_not_eq; assumption. intro H0. apply H. rewrite H0. rewrite H2. reflexivity. Qed. Definition RMul_op : CSetoid_bin_op RMonoid := Build_CSetoid_bin_op RCSetoid Rmult RMul_is_csbinop. Lemma RMul_assoc : associative (S:=RAbGroup) RMul_op. Proof. unfold associative. intros x y z. apply eq_symmetric. apply Rmult_assoc. Qed. Lemma R_is_Ring : is_CRing RAbGroup (1%R) RMul_op. Proof. exists RMul_assoc. constructor. unfold is_rht_unit; intro x. apply Rmult_1_r. unfold is_lft_unit; intro x. apply Rmult_1_l. unfold commutes. apply Rmult_comm. unfold distributive; intros x y z. apply Rmult_plus_distr_l. apply R1_neq_R0. Qed. Definition RRing := Build_CRing _ _ _ R_is_Ring. Canonical Structure RRing. (** ** Coq real numbers form a field *) (** reciprocal *) Definition Rrecip : forall x : RRing, x [#] [0] -> RRing := fun x _ => Rinv x. Lemma R_is_Field : is_CField RRing Rrecip. Proof. constructor. apply Rinv_r. assumption. apply Rinv_l. assumption. Qed. Lemma R_is_Field2: forall (x y : RRing) (x_ : x[#][0]) (y_ : y[#][0]), Rrecip x x_[#]Rrecip y y_ -> x[#]y. Proof. intros x y x1 y1 H. intro. apply H. clear H. unfold Rrecip. rewrite H0. trivial. Qed. Definition RField : CField := Build_CField _ _ R_is_Field R_is_Field2. Canonical Structure RField. (** ** Coq real numbers form an ordered field *) (** less-than *) Lemma Rlt_strext : Crel_strext RField Rlt. Proof. unfold Crel_strext. intros x1 x2 y1 y2 H. elim (total_order_T x2 y2); intro H1. elim H1; clear H1; intro H2. left; assumption. right. elim (total_order_T x1 x2); intro H1. elim H1; clear H1; intro H3. left. apply: Rlt_not_eq; assumption. right. rewrite <- H2. rewrite <- H3. apply: Rgt_not_eq; assumption. left. apply: Rgt_not_eq; assumption. right. elim (total_order_T x1 x2); intro H2. elim H2; clear H2; intro H3. left; apply: Rlt_not_eq; assumption. right. apply: Rgt_not_eq. apply Rgt_trans with x1. assumption. rewrite H3; assumption. left; apply: Rgt_not_eq; assumption. Qed. Definition Rless_rel : CCSetoid_relation RField := Build_CCSetoid_relation RField Rlt Rlt_strext. (** greater-than *) Lemma Rgt_strext : Crel_strext RField Rgt. Proof. intros x1 x2 y1 y2. pose (G := Rlt_strext y1 y2 x1 x2). tauto. Qed. Definition Rgt_rel : CCSetoid_relation RField := Build_CCSetoid_relation RField Rgt Rgt_strext. Lemma R_is_OrdField : is_COrdField RField Rless_rel Rle Rgt_rel Rge. Proof. constructor. constructor. unfold Ctransitive. apply Rlt_trans. unfold CSetoids.antisymmetric. apply Rlt_asym. intros x y xy z. apply Rplus_lt_compat_r. assumption. intros x y x0 y0. apply Rmult_gt_0_compat; assumption. intros x y. constructor. intro xy. elim (total_order_T x y); intro H2. elim H2; clear H2; intro H3. left; assumption. exfalso; apply xy; assumption. right; assumption. intro H; destruct H. apply: Rlt_not_eq; assumption. apply: Rgt_not_eq; assumption. intros x y. simpl in *. unfold Not; split. intros; lra. intro. apply Rnot_lt_le. assumption. auto with *. auto with *. Qed. Definition ROrdField : COrdField := Build_COrdField _ _ _ _ _ R_is_OrdField. Canonical Structure ROrdField. (** ** Coq real numbers form a real number structure *) Lemma cauchy_prop_cauchy_crit : (CauchySeq ROrdField) -> forall s : (nat -> ROrdField), (Cauchy_prop (R:=ROrdField) s) -> (Rseries.Cauchy_crit s). Proof. intros x seq cprop. unfold Cauchy_prop in cprop. unfold Rseries.Cauchy_crit. intros eps epsgt. elim (cprop ((eps / 2 / 2)%R) (eps2_Rgt_R0 _ (eps2_Rgt_R0 _ epsgt))). intros N NProp. exists N. intros n m ngt mgt. assert (AbsSmall (eps / 2) ((seq n) - (seq m)) )%R. stepr ((seq n - seq N) + (seq N - seq m))%R. stepl (eps / 2 / 2 + eps / 2 / 2)%R. apply AbsSmall_plus. apply NProp; assumption. apply (AbsSmall_minus). apply NProp; assumption. simpl; field. simpl; ring. destruct H. unfold Rfunctions.R_dist. apply Rabs_def1. clear - H0 epsgt. simpl in *. lra. clear - H epsgt. simpl in *. lra. Qed. (** limit *) Definition RLim : CauchySeq ROrdField -> ROrdField. Proof. intro x. elim x. intros seq cprop. cut (Rseries.Cauchy_crit seq). intro crit. elim (R_complete seq crit). intros lim uncv. exact lim. apply (cauchy_prop_cauchy_crit x). exact cprop. Defined. (** INR is isomorphic to nring *) Lemma R_INR_as_IR : forall n : nat, INR n = nring (R:=RRing) n. Proof. induction n. simpl; trivial. induction n. simpl; auto with *. simpl in *. rewrite IHn. trivial. Qed. #[global] Hint Rewrite R_INR_as_IR : RtoIR. Lemma RisReals : is_CReals ROrdField RLim. Proof. constructor. intros [s hs]. unfold SeqLimit. unfold RLim. intros e e0. simpl. destruct (R_complete s ((cauchy_prop_cauchy_crit (Build_CauchySeq ROrdField s hs) s hs))). unfold Rseries.Un_cv in u. simpl in *. destruct (hs (e/4)) as [N HN]. simpl. lra. exists N. intros m Hm. destruct (u (e/2)). lra. set (z:=Nat.max x0 m). rstepr (((s m[-]s N)[+](s N[-]s z))[+](s z[-]x)). apply AbsSmall_eps_div_two. apply AbsSmall_eps_div_two. stepl (e/4). apply HN; auto. change (e / 4 = e * / (0 + 1 + 1) * / (0 + 1 + 1)). field. apply AbsSmall_minus. stepl (e/4). unfold z. apply HN; eauto with *. change (e / 4 = e * / (0 + 1 + 1) * / (0 + 1 + 1)). field. assert (Hz:(z >= x0)%nat). unfold z; eauto with *. destruct (Rabs_def2 _ _ (H _ Hz)) as [A0 A1]. stepl (e/2). split; unfold cg_minus; simpl; auto with *. change (e / 2 = e * / (0 + 1 + 1)). field. intro x. exists (Z.abs_nat (up x)). unfold Z.abs_nat. elim (archimed x). destruct (up x). simpl; intros; lra. rewrite <- positive_nat_Z. intros H _. apply Rlt_le. rewrite <- R_INR_as_IR. now rewrite INR_IZR_INZ. intros I _. cut (x < 0%R). intro H; clear I. rewrite <- R_INR_as_IR. cut (0 <= INR (nat_of_P p)). intro. apply Rlt_le. lra. apply pos_INR. cut (0 <= INR (nat_of_P p)). rewrite INR_IZR_INZ. intro. change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))) in I. rewrite <- positive_nat_Z in I. lra. apply pos_INR. Qed. Definition RReals : CReals := Build_CReals ROrdField RLim RisReals. Canonical Structure RReals. corn-8.20.0/coq_reals/Rreals_iso.v000066400000000000000000000625601473720167500170300ustar00rootroot00000000000000(* Copyright © 2008-2008 * Cezary Kaliszyk * Russell O'Connor * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) From Coq Require Import QArith. From Coq Require Import Qreals. From Coq Require Import QArith_base. Require Import CoRN.tactics.CornTac. From Coq Require Import RIneq. From Coq Require Import Rcomplete. From Coq Require Import Rlimit. From Coq Require Import Rbasic_fun. Require Import CoRN.coq_reals.Rreals. Require Import CoRN.reals.iso_CReals. Require Import CoRN.reals.CauchySeq. From Coq Require Import Rtrigo_def. Require Import CoRN.transc.PowerSeries. From Coq Require Import ConstructiveEpsilon. From Coq Require Import Rlogic. From Coq Require Export Reals. Require Import CoRN.transc.Pi. Require Import CoRN.transc.MoreArcTan. Require Import CoRN.logic.PropDecid. Require Import CoRN.transc.Exponential. From Coq Require Import Lia Lra. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". (* This changed in RLogic and should probably be moved there: *) Lemma forall_dec : forall P:nat->Prop, (forall n, {P n} + {~ P n}) -> {forall n, P n} + {~forall n, P n}. intros. case (sig_forall_dec _ H) as [[n H1] | H1];intuition. Qed. (** * Coq Real Numbers and IR isomorphisms Warning: The Coq real numbers depend on classical logic. Importing this module will give you classical logic, the axioms of Coq's real number structure, plus all the logical consquences of these axioms. To avoid these consequences, use CoRN's real number structure [IR] instead. All real number structures are isomorphic. This module uses this isomorphis to create a rewrite database [RtoIR] for converting many problems over [R] into problems over [IR] where constructive methods may be employed. *) (** ** The isomorphism *) Lemma RIR_iso : Isomorphism RReals IR. Proof. exact (Canonic_Isomorphism_between_CReals RReals IR). Qed. Definition RasIR : R -> IR := iso_map_lft _ _ RIR_iso. Definition IRasR : IR -> R := iso_map_rht _ _ RIR_iso. Lemma RasIRasR_id : forall (x:R), (IRasR (RasIR x)=x). Proof. apply (inversity_rht _ _ RIR_iso). Qed. Lemma IRasRasIR_id : forall (x:IR), (RasIR (IRasR x)[=]x). Proof. apply (inversity_lft _ _ RIR_iso). Qed. (** equality *) Lemma R_eq_as_IR : forall x y, (x = y -> RasIR x [=] RasIR y). Proof. apply: map_wd_unfolded. Qed. (** apartness *) Lemma R_eq_as_IR_back : forall x y, (RasIR x [=] RasIR y -> x = y). Proof. intros x y H. replace x with (IRasR (RasIR x)) by apply RasIRasR_id. replace y with (IRasR (RasIR y)) by apply RasIRasR_id. apply: map_wd_unfolded; assumption. Qed. Lemma R_ap_as_IR : forall x y, (RasIR x [#] RasIR y -> x <> y). Proof. intros x y H. replace x with (IRasR (RasIR x)) by apply RasIRasR_id. replace y with (IRasR (RasIR y)) by apply RasIRasR_id. change (IRasR (RasIR x) [#] IRasR (RasIR y)). apply: map_pres_apartness; assumption. Qed. Lemma R_ap_as_IR_back : forall x y, (x <> y -> RasIR x [#] RasIR y). Proof. intros x y H. apply map_pres_apartness. assumption. Qed. Lemma IR_ap_as_R : forall x y, (x <> y -> RasIR x [#] RasIR y). Proof. intro. apply: map_pres_apartness. Qed. (** less-than *) Open Scope R_scope. Lemma R_lt_as_IR : forall x y, (RasIR x [<] RasIR y -> x < y). Proof. intros x y H. replace x with (IRasR (RasIR x)) by apply RasIRasR_id. replace y with (IRasR (RasIR y)) by apply RasIRasR_id. change (IRasR (RasIR x) [<] IRasR (RasIR y)). apply: map_pres_less; assumption. Qed. Lemma R_lt_as_IR_back : forall x y, (x [<] y -> IRasR x < IRasR y). Proof. intros x y H. change (IRasR x [<] IRasR y). apply: map_pres_less. assumption. Qed. Lemma IR_lt_as_R : forall x y, (x < y -> RasIR x [<] RasIR y). Proof. intro. apply: map_pres_less. Qed. Lemma IR_lt_as_R_back : forall x y, (IRasR x < IRasR y -> x [<] y). Proof. intros. stepl (RasIR (IRasR x)); [| now apply IRasRasIR_id]. stepr (RasIR (IRasR y)); [| now apply IRasRasIR_id]. apply map_pres_less. assumption. Qed. (** le *) Lemma R_le_as_IR : forall x y, (RasIR x [<=] RasIR y -> x <= y). Proof. intros x y H. cut (~ (y < x)). apply Rnot_lt_le. intro xy. revert H. rewrite -> leEq_def. intro H. apply H. apply IR_lt_as_R. assumption. Qed. Lemma IR_le_as_R : forall x y, (x <= y -> RasIR x [<=] RasIR y). Proof. intros x y H. rewrite -> leEq_def. intro xy. assert (~ (y < x)). apply RIneq.Rle_not_lt; assumption. apply H0. apply R_lt_as_IR. assumption. Qed. Lemma IR_le_as_R_back : forall x y, (IRasR x <= IRasR y -> x [<=] y). Proof. intros. rewrite -> leEq_def. intro xy. cut (~ (IRasR y < IRasR x)); intro. apply H0. apply R_lt_as_IR. stepl y; [| now rewrite -> IRasRasIR_id; reflexivity]. stepr x; [| now rewrite -> IRasRasIR_id; reflexivity]. assumption . apply (RIneq.Rle_not_lt (IRasR y) (IRasR x)). assumption. assumption. Qed. (** zero *) Lemma R_Zero_as_IR : (RasIR R0 [=] [0]). Proof. apply map_pres_zero_unfolded. Qed. Lemma IR_Zero_as_R : (IRasR [0] = 0). Proof. apply: map_pres_zero_unfolded. Qed. #[global] Hint Rewrite R_Zero_as_IR : RtoIR. (** one *) Lemma R_One_as_IR : (RasIR R1 [=] [1]). Proof. apply map_pres_one_unfolded. Qed. #[global] Hint Rewrite R_One_as_IR : RtoIR. Lemma IR_One_as_R : (IRasR [1] = R1). Proof. apply: map_pres_one_unfolded. Qed. (** addition *) Lemma R_plus_as_IR : forall x y, (RasIR (x+y) [=] RasIR x [+] RasIR y). Proof. apply: map_pres_plus. Qed. #[global] Hint Rewrite R_plus_as_IR : RtoIR. Lemma IR_plus_as_R : forall x y, (IRasR (x[+]y) [=] IRasR x + IRasR y). Proof. apply: map_pres_plus_unfolded. Qed. (** negation *) Lemma R_opp_as_IR : forall x, (RasIR (- x) [=] ([--] (RasIR x))). Proof. apply: map_pres_minus. Qed. #[global] Hint Rewrite R_opp_as_IR : RtoIR. Lemma IR_opp_as_R : forall x, (IRasR ([--] x) [=] (- (IRasR x))). Proof. apply: map_pres_minus_unfolded. Qed. (** subtraction *) Lemma R_minus_as_IR : forall x y, (RasIR (x-y) [=] RasIR x [-] RasIR y). Proof. intros x y. unfold cg_minus. rewrite <- R_opp_as_IR. rewrite <- R_plus_as_IR. reflexivity. Qed. #[global] Hint Rewrite R_minus_as_IR : RtoIR. Lemma IR_minus_as_R : forall x y, (IRasR (x[-]y) [=] IRasR x - IRasR y). Proof. intros x y. unfold Rminus. rewrite <- IR_opp_as_R. rewrite <- IR_plus_as_R. reflexivity. Qed. (** multiplication *) Lemma R_mult_as_IR : forall x y, (RasIR (x*y) [=] RasIR x [*] RasIR y). Proof. apply: map_pres_mult. Qed. #[global] Hint Rewrite R_mult_as_IR : RtoIR. Lemma IR_mult_as_R : forall x y, (IRasR (x[*]y) = IRasR x * IRasR y). Proof. apply: map_pres_mult_unfolded. Qed. (** reciprocal *) Lemma R_recip_as_IR : forall y Hy, (RasIR (1 / y) [=] ([1] [/] RasIR y [//] Hy)). Proof. intros y Hy. simpl in Hy. assert (y [#] 0). apply: R_ap_as_IR. stepr ([0]:IR). assumption. symmetry. apply R_Zero_as_IR. change (1/y) with ([1] [/] y [//] X). eapply eq_transitive. unfold RasIR. apply (map_pres_inv_unfolded RReals IR). apply div_wd; reflexivity. Qed. #[global] Hint Rewrite R_recip_as_IR : RtoIR. (** division *) Lemma R_div_as_IR : forall x y Hy, (RasIR (x/y) [=] (RasIR x [/] RasIR y [//] Hy)). Proof. intros x y Hy. unfold Rdiv. rewrite -> R_mult_as_IR. rstepr ((RasIR x) [*] ([1] [/]RasIR y[//]Hy)). replace (/ y) with (1 / y). rewrite <- R_recip_as_IR; reflexivity. unfold Rdiv. ring. Qed. (** absolute value *) Lemma R_abs_as_IR : forall x, RasIR (Rabs x) [=] AbsIR (RasIR x). Proof. intro x. unfold Rabs. destruct (Rcase_abs x) as [Hx | Hx]. cut (RasIR x[<=][0]). intro Hxn. rewrite -> (AbsIR_eq_inv_x (RasIR x) Hxn). autorewrite with RtoIR; reflexivity. stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply less_leEq. apply IR_lt_as_R. assumption. cut ([0] [<=] RasIR x). intro Hxn. rewrite -> (AbsIR_eq_x _ Hxn). reflexivity. stepl (RasIR 0); [| now apply R_Zero_as_IR]. apply IR_le_as_R. lra. Qed. #[global] Hint Rewrite R_abs_as_IR : RtoIR. (** parital sum *) Lemma R_sum_as_IR : forall a m, RasIR (sum_f_R0 a m) [=] (seq_part_sum (fun i : nat => RasIR (a i)) (S m)). Proof. intros a m. induction m. simpl. rational. simpl. autorewrite with RtoIR. rewrite -> IHm. simpl. reflexivity. Qed. (** infinite sum *) Lemma R_infsum_as_IR_convergent : forall (y: R) a, infinit_sum a y -> convergent (fun i : nat => RasIR (a i)). Proof. unfold infinit_sum. unfold convergent. intros y a conv. assert (cauchy := CV_Cauchy _ (exist _ y conv)). clear conv. unfold Cauchy_crit in cauchy. unfold Cauchy_prop. intros e e0. pose (new_e0 := R_lt_as_IR_back _ _ e0). rewrite -> IR_Zero_as_R in new_e0. assert (sig (fun N => forall n m : nat, (n >= N)%nat -> (m >= N)%nat -> R_dist (sum_f_R0 a n) (sum_f_R0 a m) < IRasR e )). apply constructive_indefinite_description_nat. intros N. apply forall_dec. intros n0. apply forall_dec. intros n1. apply imp_dec. unfold ge. destruct (le_gt_dec N n0). left; auto with *. right; auto with *. apply imp_dec. destruct (le_gt_dec N n1). left; auto with *. right; auto with *. apply Rlt_dec. apply cauchy; auto with *. destruct H as [N HN]. exists (S N). intros m Hm. assert (N <= pred m)%nat by auto with *. assert (HH := HN (pred m) N H (Nat.le_refl N)). clear - HH Hm. destruct m. exfalso. auto with *. rewrite <- R_sum_as_IR. rewrite <- R_sum_as_IR. rewrite <- R_minus_as_IR. apply AbsIR_imp_AbsSmall. stepl (RasIR (Rabs(sum_f_R0 a m - sum_f_R0 a N))); [| now apply R_abs_as_IR]. apply less_leEq. unfold R_dist in HH. stepr (RasIR (IRasR e)); [| now apply IRasRasIR_id]. apply IR_lt_as_R. assumption. Qed. Lemma R_infsum_as_IR : forall (y: R) a, Rfunctions.infinit_sum a y -> forall prf, RasIR y [=] series_sum (fun i : nat => RasIR (a i)) prf. Proof. intros y a Hay prf. unfold series_sum. unfold infinit_sum in *. apply Limits_unique. unfold Cauchy_Lim_prop2. simpl. clear prf. intros e He. assert (sig (fun N => forall n : nat, (n >= N)%nat -> R_dist (sum_f_R0 a n) y < IRasR e )). apply constructive_indefinite_description_nat. intros N. apply forall_dec. intros n0. apply imp_dec. unfold ge. destruct (le_gt_dec N n0). left; auto with *. right; auto with *. apply Rlt_dec. apply (Hay). unfold Rgt. apply R_lt_as_IR. stepl ([0]:IR); [| now symmetry;apply R_Zero_as_IR]. stepr (e); [| now symmetry; apply IRasRasIR_id]. assumption. destruct H as [N HN]. exists (S N). intros m Hm. assert (N <= pred m)%nat. auto with *. assert (HH := HN (pred m) H). clear - HH Hm. destruct m. exfalso. auto with *. rewrite <- R_sum_as_IR. rewrite <- R_minus_as_IR. apply AbsIR_imp_AbsSmall. unfold R_dist in HH. simpl in HH. apply less_leEq. stepl (RasIR (Rabs(sum_f_R0 a m - y))); [| apply R_abs_as_IR]. stepr (RasIR (IRasR e)); [| apply IRasRasIR_id]. apply IR_lt_as_R. assumption. Qed. Lemma R_infsum_f_as_IR : forall (x y: R) f, Rfunctions.infinit_sum (f x) y -> forall prf, RasIR y [=] series_sum (fun i : nat => RasIR (f x i)) prf. Proof. intros x y f cprf rprf. apply R_infsum_as_IR. assumption. Qed. (** factorial *) Lemma R_nring_as_IR : forall i, RasIR (nring i) [=] nring i. Proof. induction i. simpl. apply R_Zero_as_IR. simpl. autorewrite with RtoIR. rewrite -> IHi. reflexivity. Qed. #[global] Hint Rewrite R_nring_as_IR : RtoIR. Add Morphism RasIR with signature (@cs_eq _) ==> (@cs_eq _) as R_as_IR_wd. Proof. intros. rewrite H. reflexivity. Qed. (** integers *) Lemma R_pring_as_IR : forall x, RasIR (pring _ x) [=] pring _ x. Proof. intro x. (*rewrite pring_convert.*) stepr (nring (R := IR) (nat_of_P x)). stepl (RasIR (nring (R := RReals) (nat_of_P x))). apply R_nring_as_IR. apply R_as_IR_wd. symmetry. apply (pring_convert RReals x). symmetry. apply (pring_convert IR x). Qed. Lemma R_zring_as_IR : forall x, RasIR (zring x) [=] zring x. Proof. induction x; simpl. apply R_Zero_as_IR. apply R_pring_as_IR. rewrite -> R_opp_as_IR. rewrite -> R_pring_as_IR. reflexivity. Qed. Lemma INR_as_nring : forall x, INR x = nring (R:=RRing) x. Proof. induction x. reflexivity. simpl nring. rewrite <- IHx. apply S_INR. Qed. Lemma IZR_as_zring : forall x, IZR x = zring (R:=RRing) x. Proof. induction x. reflexivity. rewrite <- positive_nat_Z, <- INR_IZR_INZ. rewrite INR_as_nring. (* rewrite pring_convert *) symmetry. rewrite positive_nat_Z. apply (pring_convert RRing p). change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))). rewrite <- positive_nat_Z, <- INR_IZR_INZ. rewrite INR_as_nring. apply Ropp_eq_compat. symmetry. apply (pring_convert RRing p). Qed. Lemma R_IZR_as_IR : forall x, RasIR (IZR x) [=] zring x. Proof. induction x. apply R_Zero_as_IR. rewrite <- positive_nat_Z, <- INR_IZR_INZ. rewrite R_INR_as_IR. rewrite -> R_nring_as_IR. auto with *. change (IZR (Zneg p)) with (Ropp (IZR (Zpos p))). rewrite <- positive_nat_Z, <- INR_IZR_INZ. rewrite -> R_opp_as_IR. rewrite R_INR_as_IR. rewrite -> R_nring_as_IR. simpl zring. auto with *. Qed. #[global] Hint Rewrite R_IZR_as_IR : RtoIR. (** exponents *) Lemma R_pow_as_IR : forall x i, RasIR (Rpow_def.pow x i)[=] nexp _ i (RasIR x). Proof. intros x i. induction i. simpl. apply R_One_as_IR. simpl. autorewrite with RtoIR. rewrite -> IHi. auto with *. Qed. #[global] Hint Rewrite R_pow_as_IR : RtoIR. Lemma R_exp_as_IR : forall x, RasIR (exp x) [=] Exp (RasIR x). Proof. unfold exp. unfold projT1. intro x; case (exist_exp x). unfold exp_in. intros y rsums. rewrite -> ( R_infsum_f_as_IR x y ((fun x i => / INR (fact i) * Rpow_def.pow x i)) rsums (R_infsum_as_IR_convergent _ _ rsums) ). simpl. apply series_sum_wd. intro i. autorewrite with RtoIR. replace (/ nring (fact i)) with (1 / nring (fact i)). 2: field; apply (nring_fac_ap_zero RReals i). cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact i)))). intro Hy. rewrite -> (R_recip_as_IR (nring (fact i)) Hy). clear. rewrite -> (cg_inv_zero IR (RasIR x)). apply mult_wdl. apply div_wd. reflexivity. apply (R_nring_as_IR (fact i)). simpl. stepl (nring (R:=IR) (fact i)). apply (nring_fac_ap_zero IR i). symmetry. apply (R_nring_as_IR). Qed. #[global] Hint Rewrite R_exp_as_IR : RtoIR. (** trigonometry *) Lemma R_cos_as_IR : forall x, RasIR (cos x) [=] Cos (RasIR x). Proof. unfold cos. intro x. case (exist_cos (Rsqr x)). unfold cos_in. intros y rsums. rewrite -> (R_infsum_f_as_IR x y (fun x i => cos_n i * Rsqr x ^ i) rsums (R_infsum_as_IR_convergent _ _ rsums) ). simpl. unfold series_sum. apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat. intros; lia. intros n; exists (S n); lia. induction n. reflexivity. simpl in *. rewrite -> IHn. rewrite (Nat.add_comm n (S (n + 0))). simpl. rstepr ( seq_part_sum (fun n0 : nat => (cos_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*] nexp IR n0 (RasIR x[-][0])) (n + 0 + n)[+] ( (cos_seq (n + 0 + n)[/]nring (R:=IR) (fact (n + 0 + n))[//] nring_fac_ap_zero IR (n + 0 + n))[*]nexp IR (n + 0 + n) (RasIR x[-][0])[+] (cos_seq (S (n + 0 + n))[/] nring (R:=IR) (fact (n + 0 + n) + (n + 0 + n) * fact (n + 0 + n))[//] nring_fac_ap_zero IR (S (n + 0 + n)))[*] (nexp IR (n + 0 + n) (RasIR x[-][0])[*](RasIR x[-][0]))) ). apply bin_op_wd_unfolded. rewrite Nat.add_comm. reflexivity. replace (n + 0 + n)%nat with (n + n)%nat by auto with *. unfold Rsqr. unfold cos_n. simpl. unfold cos_seq. simpl. destruct (even_or_odd_plus (n + n)). destruct (even_or_odd_plus (S(n + n))). simpl. destruct s; [ | exfalso; auto with *]. destruct s0; simpl. exfalso; auto with *. autorewrite with RtoIR. stepr ( (nexp IR x0 [--][1][/]nring (R:=IR) (fact (n + n))[//] nring_fac_ap_zero IR (n + n))[*]nexp IR (n + n) (RasIR x[-][0]) ). apply bin_op_wd_unfolded. replace (n + 0)%nat with n by auto with *. assert (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact (n + n))))). simpl. stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply R_ap_as_IR_back. apply (nring_fac_ap_zero RReals (n + n)). rewrite -> (R_div_as_IR ((-1)^n) (nring (R := RRing) (fact (n + n))) X). apply div_wd. autorewrite with RtoIR. replace n with x0 by lia. reflexivity. autorewrite with RtoIR. reflexivity. clear. induction n; simpl. reflexivity. rewrite -> IHn. replace (n + S n)%nat with (S (n + n))%nat by auto with *. simpl. rstepr ( nexp IR (n + n) (RasIR x[-][0])[*]((RasIR x[-][0])[*](RasIR x[-][0])) ). apply bin_op_wd_unfolded. reflexivity. rational. setoid_replace (([0][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//] nring_fac_ap_zero IR (S (n + n)))[*] (nexp IR (n + n) (RasIR x[-][0])[*](RasIR x[-][0]))) with ([0]:IR). rational. rational. Qed. #[global] Hint Rewrite R_cos_as_IR : RtoIR. Lemma R_sin_as_IR : forall x, RasIR (sin x) [=] Sin (RasIR x). Proof. unfold sin. intro x. case (exist_sin (Rsqr x)). unfold sin_in. intros y rsums. rewrite -> R_mult_as_IR. rewrite -> (R_infsum_f_as_IR x y (fun x i => sin_n i * Rsqr x ^ i) rsums (R_infsum_as_IR_convergent _ _ rsums) ). assert (convergent (fun n : nat => RasIR x[*](fun i : nat => RasIR (sin_n i * Rsqr x ^ i)) n)). apply conv_series_mult_scal. apply (R_infsum_as_IR_convergent _ _ rsums). rewrite <- (series_sum_mult_scal (fun i : nat => RasIR (sin_n i * Rsqr x ^ i)) (R_infsum_as_IR_convergent _ _ rsums) (RasIR x) X). simpl. unfold series_sum. apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat. intros; lia. intros n; exists (S n); lia. induction n. reflexivity. simpl in *. rewrite -> IHn. rewrite (Nat.add_comm n (S (n + 0))). simpl. replace (n + 0 + n)%nat with (n + n)%nat by auto with *. unfold sin_n. simpl. replace (n + 0)%nat with (n)%nat by auto with *. unfold sin_seq at 3. unfold sin_seq at 3. simpl. destruct (even_or_odd_plus (n + n)). destruct (even_or_odd_plus (S(n + n))). destruct s; [ | exfalso; auto with *]. destruct s0; simpl. exfalso; auto with *. rstepr ( seq_part_sum (fun n0 : nat => (sin_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*] nexp IR n0 (RasIR x[-][0])) (n + n)[+]( ([0][/]nring (R:=IR) (fact (n + n))[//]nring_fac_ap_zero IR (n + n))[*] nexp IR (n + n) (RasIR x[-][0])[+] (nexp IR x1 [--][1][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//] nring_fac_ap_zero IR (S (n + n)))[*] (nexp IR (n + n) (RasIR x[-][0])[*](RasIR x[-][0]))) ). apply bin_op_wd_unfolded. reflexivity. setoid_replace (RasIR x [-] [0]) with (RasIR x);[|rational]. replace x1 with n by lia. clear. setoid_replace (([0][/]nring (R:=IR) (fact (n + n))[//]nring_fac_ap_zero IR (n + n))[*] nexp IR (n + n) (RasIR x)) with ([0]:IR);[|rational]. rstepr ( RasIR x [*] ( (nexp IR n [--][1][/]nring (R:=IR) (fact (n + n) + (n + n) * fact (n + n))[//] nring_fac_ap_zero IR (S (n + n)))[*](nexp IR (n + n) (RasIR x))) ). apply bin_op_wd_unfolded. reflexivity. autorewrite with RtoIR. unfold Rsqr. apply bin_op_wd_unfolded. cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (fact (n + n + 1))))). intro X. rewrite -> (R_div_as_IR ((-1)^n) (nring (R:=RRing) (fact (n + n + 1))) X). apply div_wd. autorewrite with RtoIR; reflexivity. autorewrite with RtoIR. apply nring_wd. replace (n + n + 1)%nat with (S (n + n)) by lia. simpl. reflexivity. simpl. stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply R_ap_as_IR_back. apply (nring_fac_ap_zero RReals (n + n + 1)). induction n; simpl. reflexivity. replace (n + S n)%nat with (S(n + n)) by lia. simpl. rewrite -> IHn. autorewrite with RtoIR. rational. Qed. #[global] Hint Rewrite R_sin_as_IR : RtoIR. Lemma R_tan_as_IR : forall x dom, RasIR (tan x) [=] Tan (RasIR x) dom. Proof. intros x dom. unfold tan. cut (Dom (f_rcpcl' IR) (RasIR (cos x))). intro Hdiv. rewrite -> (R_div_as_IR (sin x) (cos x) Hdiv). cut (Dom (f_rcpcl' IR) (Cos (RasIR x))). intro ndom. stepl (Sin(RasIR x) [/] Cos(RasIR x) [//] ndom). unfold Tan. unfold Tang. apply: div_wd. apply: pfwdef. reflexivity. apply: pfwdef. reflexivity. apply div_wd. symmetry; apply R_sin_as_IR. symmetry; apply R_cos_as_IR. unfold pfdom,f_rcpcl' in *. stepl (RasIR (cos x)); [| now apply R_cos_as_IR]. assumption. unfold pfdom,f_rcpcl', Tang,Fdiv in *. destruct dom. destruct e. stepl (Cos (RasIR x)); [| now symmetry; apply R_cos_as_IR]. apply: c. Qed. (** logarithm *) Lemma R_ln_as_IR : forall x prf, RasIR (ln x) [=] Log (RasIR x) prf. Proof. intros x prf. apply Exp_cancel. rewrite -> Exp_Log. rewrite <- R_exp_as_IR. apply R_as_IR_wd. apply exp_ln. apply R_lt_as_IR. stepl ([0]:IR); [| now symmetry; apply R_Zero_as_IR]. assumption. Qed. (** pi *) Lemma R_pi_as_IR : RasIR (PI) [=] Pi. Proof. assert (Sin (RasIR PI) [=] [0]). rewrite <- R_sin_as_IR. rewrite sin_PI. apply R_Zero_as_IR. assert (Not (forall z : Z, RasIR PI[#]zring (R:=IR) z[*]Pi)). unfold Not. intro X. apply ((eq_imp_not_ap _ _ _ H) (Sin_ap_Zero (RasIR (PI)) X)). clear H. apply (not_ap_imp_eq). intro PiNot. elim H0. intro z. elim z. simpl. rstepr ([0]:IR). stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply R_ap_as_IR_back. apply PI_neq0. intro p. rewrite <- convert_is_POS. stepr (nring (R := IR) (nat_of_P p) [*] Pi); [| now apply mult_wdl; symmetry; apply (zring_plus_nat IR)]. case (nat_of_P p). simpl. rstepr ([0]:IR). stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply R_ap_as_IR_back. apply PI_neq0. intro n. case n. simpl. rstepr (Pi). assumption. intro n0. apply less_imp_ap. apply leEq_less_trans with Four. rstepr (([1] [+] [1]) [*] ([1] [+] [1]):IR). rewrite <- R_One_as_IR. rewrite <- R_plus_as_IR. rewrite <- R_mult_as_IR. apply IR_le_as_R. apply PI_4. apply less_leEq_trans with (Two [*] Pi). rstepl (Two [*] Two:IR). apply mult_resp_less_lft. apply Pi_gt_2. rstepr (([0] [+] [1]) [+] [1] : IR). apply plus_one_ext_less. apply zero_lt_posplus1. apply eq_imp_leEq. reflexivity. apply mult_resp_leEq_rht. simpl. apply (plus_resp_leEq). apply (plus_resp_leEq). stepl (nring (R := IR) 0); [| now auto with *]. apply nring_leEq; auto with *. apply less_leEq. apply pos_Pi. intro p. apply Greater_imp_ap. simpl. apply leEq_less_trans with ([0]:IR). rewrite -> pring_convert. apply less_leEq. apply inv_cancel_less. rstepl ([0][*][0]:IR). rstepr ((nring (R:=IR) (nat_of_P p))[*]Pi). apply mult_resp_less_both. apply eq_imp_leEq. reflexivity. rstepl (nring (R := IR) 0) . apply nring_less. auto with *. apply eq_imp_leEq. reflexivity. auto with *. stepl (RasIR 0); [| now apply R_Zero_as_IR]. apply IR_lt_as_R. apply PI_RGT_0. Qed. Lemma R_pi_alt_as_IR : RasIR (Alt_PI) [=] pi. Proof. unfold Alt_PI. unfold pi. destruct (exist_PI) as [x prf]. unfold pi_series. unfold tg_alt in prf. unfold PI_tg in prf. rewrite -> R_mult_as_IR. apply mult_wd. change 4 with ((1 + 1) * (1 + 1)). rewrite -> R_mult_as_IR. rewrite -> R_plus_as_IR. rewrite -> R_One_as_IR. rational. rewrite -> (R_infsum_as_IR x ( (fun i : nat => (-1) ^ i * / INR (2 * i + 1)) ) prf (R_infsum_as_IR_convergent _ _ prf) ). apply series_sum_wd. intro n. autorewrite with RtoIR. apply mult_wd. simpl; reflexivity. stepr (RasIR (1 / nring (R:=RRing) (2 * n + 1))). apply R_as_IR_wd. unfold Rdiv. simpl; auto with *. cut (n + (n + 0) + 1 = S (n + n))%nat. intro DF. cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RReals) (2 * n + 1)))). intro H. rewrite -> (R_recip_as_IR (nring (R:=RReals) (2 * n + 1)) H). apply div_wd. reflexivity. rewrite -> R_nring_as_IR. apply nring_wd. rewrite <- DF. simpl. auto. simpl. stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply R_ap_as_IR_back. apply Rgt_not_eq. rewrite DF. unfold Rgt. change ([0] [<] nring (R:=RRing) (S (n + n))). apply pos_nring_S. auto with *. Qed. #[global] Hint Rewrite R_pi_as_IR : RtoIR. (** rationals *) Lemma R_Q2R_as_IR : forall q, RasIR (Q2R q) [=] inj_Q IR q. Proof. intro q. destruct q. unfold Q2R. cut (Dom (f_rcpcl' IR) (RasIR (nring (R:=RRing) (nat_of_P Qden)))). intro Hy. stepr (RasIR (zring (R:=RRing) Qnum)[/]RasIR (nring (R:=RRing) (nat_of_P Qden))[//]Hy). stepl (RasIR (zring (R:=RRing) Qnum / nring (R:=RRing) (nat_of_P Qden))). apply (R_div_as_IR (zring Qnum) (nring (nat_of_P Qden))). apply R_as_IR_wd. unfold Rdiv. replace (nring (R:=RRing) (nat_of_P Qden)) with (INR (nat_of_P Qden)). replace (zring (R:=RRing) Qnum) with (IZR Qnum). now rewrite <- positive_nat_Z, INR_IZR_INZ. apply IZR_as_zring. apply INR_as_nring. apply div_wd. apply R_zring_as_IR. apply R_nring_as_IR. simpl. stepr (RasIR 0); [| now apply R_Zero_as_IR]. apply IR_ap_as_R. apply Rgt_not_eq. unfold Rgt. replace 0 with (nring (R:=RRing) 0). change ((nring (R:=RRing) 0 [<] nring (R:=RRing) (nat_of_P Qden))). apply nring_less. auto with *. auto with *. Qed. #[global] Hint Rewrite R_Q2R_as_IR : RtoIR. Close Scope R_scope. corn-8.20.0/coq_reals/Rsign.v000066400000000000000000000016001473720167500157740ustar00rootroot00000000000000Require Import CoRN.coq_reals.Rreals_iso. Require Import CoRN.reals.fast.CRsign. Ltac R_dec_precompute := try apply Rlt_le; apply R_lt_as_IR; match goal with | |- (Ccsr_rel ?A ?B ?X ?Y) => let X0 := fresh "R_dec" in pose (X0:=X); let Y0 := fresh "R_dec" in pose (Y0:=Y); change (Ccsr_rel A B X0 Y0); let XH := fresh "R_dec" in assert (XH:(X[=]X0)) by apply eq_reflexive; let YH := fresh "R_dec" in assert (YH:(Y[=]Y0)) by apply eq_reflexive; autorewrite with RtoIR in XH, YH; apply (fun z z0 => @Ccsr_wdl A B _ z _ z0 XH); apply (fun z z0 => @Ccsr_wdr A B z _ _ z0 YH); clear X0 Y0 XH YH end. Ltac R_solve_ineq P := R_dec_precompute; IR_solve_ineq P. corn-8.20.0/doc/000077500000000000000000000000001473720167500133235ustar00rootroot00000000000000corn-8.20.0/doc/doc_coqdocpre.tex000066400000000000000000000023451473720167500166550ustar00rootroot00000000000000\usepackage{a4wide,amstext,amssymb} \def\RR{\ensuremath{\mathbb{R}}} \def\QQ{\ensuremath{\mathbb{Q}}} \def\NN{\ensuremath{\mathbb{N}}} \def\ZZ{\ensuremath{\mathbb{Z}}} \def\noto{\mathrel{\#}} \newcommand{\ac}{^{\prime}} \def\eqqe{\leftrightarrow} \newcommand{\maxx}{\mbox{max}} \newcommand{\newenvs}[1]{\begin{list}{}{\setlength{\leftmargin}{0pt} \setlength{\rightmargin}{0pt}}\item {#1}} \newcommand{\newenve}[1]{{#1}\end{list}} \newcommand{\newenv}[3]{\newenvironment{#1}{\newenvs{#2}}{\newenve{#3}}} \newenv{convention}{\bf Convention:}{} \newenv{nameconvention}{\bf Name convention:}{} \newenv{shortcoming}{\bf Coq shortcoming:}{} \newenv{notation}{\bf Notation:}{} \newtheorem{numnotation}{Notation} \newtheorem{numconvention}[numnotation]{Convention} \newtheorem{definition}{Definition}[section] \newtheorem{lemma}[definition]{Lemma} \newtheorem{conjecture}[definition]{Conjecture} \newtheorem{proposition}[definition]{Proposition} \newtheorem{theorem}[definition]{Theorem} \newtheorem{corollary}[definition]{Corollary} \newtheorem{remark}[definition]{Remark} \newtheorem{fact}[definition]{Fact} \newtheorem{example}[definition]{Example} \newtheorem{examples}[definition]{Examples} \newtheorem{claim}[definition]{Claim} corn-8.20.0/doc/extradeps000066400000000000000000000074071473720167500152550ustar00rootroot00000000000000./model/structures/Npossec.v /reals/fast/LazyNat.v ./reals/fast/LazyNat.v ./model/structures/Zsec.v ./model/structures/Zsec.v ./model/Zmod/ZBasics.v ./model/Zmod/Cmod.v ./model/structures/Qsec.v ./model/structures/Qsec.v ./algebra/RSetoid.v ./order/TotalOrder.v ./algebra/CSetoids.v ./algebra/CSetoidInc.v ./model/setoids/Nsetoid.v ./model/setoids/Npossetoid.v ./model/setoids/Zsetoid.v ./model/setoids/Zsetoid.v ./model/setoids/Qsetoid.v ./model/setoids/Qsetoid.v ./model/setoids/twoelemsetoid.v ./model/setoids/twoelemsetoid.v ./model/setoids/Nfinsetoid.v ./model/setoids/Nfinsetoid.v ./model/setoids/Zfinsetoid.v ./model/setoids/Zfinsetoid.v ./algebra/CSemiGroups.v ./model/semigroups/Npossemigroup.v ./model/semigroups/Zsemigroup.v ./model/semigroups/Zsemigroup.v ./model/semigroups/Qsemigroup.v ./model/semigroups/Qsemigroup.v ./model/semigroups/twoelemsemigroup.v ./model/semigroups/twoelemsemigroup.v ./algebra/CMonoids.v ./model/monoids/Nmonoid.v ./model/monoids/Nposmonoid.v ./model/monoids/Nposmonoid.v ./model/monoids/Zmonoid.v ./model/monoids/Zmonoid.v ./model/monoids/Qmonoid.v ./model/monoids/Qmonoid.v ./model/non_examples/Npos_no_monoid.v ./model/non_examples/Npos_no_monoid.v ./algebra/CMonoidCyc.v ./algebra/CMonoidCyc.v ./algebra/CAbMonoids.v ./algebra/CAbMonoids.v ./algebra/CGroups.v ./model/rings/Qring.v ./algebra/CRing_Homomorphisms.v ./algebra/CRing_Homomorphisms.v ./algebra/CIdeals.v ./algebra/CQuotient_Rings.v ./algebra/CModules.v ./algebra/CHomomorphism_Theorems.v ./algebra/CFields.v ./algebra/CFields.v ./tactics/AlgReflection.v ./tactics/GroupReflection.v ./algebra/COrdFields.v ./tactics/RingReflection.v ./algebra/COrdFields.v ./tactics/FieldReflection.v ./algebra/COrdFields.v ./algebra/COrdCauchy.v ./model/ordfields/Qordfield.v ./model/ordfields/Qordfield.v ./algebra/Expon.v ./algebra/Expon.v ./model/structures/Qpossec.v ./model/abgroups/Qposabgroup.v ./algebra/CPolynomials.v ./algebra/CPoly_ApZero.v ./reals/CReals.v ./reals/CReals.v ./algebra/Cauchy_COF.v ./model/reals/Cauchy_IR.v ./reals/CauchySeq.v ./reals/Bridges_iso.v ./complex/CComplex.v ./fta/CC_Props.v ./fta/KeyLemma.v ./complex/NRootCC.v ./fta/KeyLemma.v ./fta/KneserLemma.v ./fta/CPoly_Rev.v ./fta/KneserLemma.v ./fta/CPoly_Shift.v ./fta/KneserLemma.v ./fta/CPoly_Contin1.v ./fta/FTA.v ./tactics/DiffTactics1.v ./tactics/DiffTactics1.v ./reals/Intervals.v ./ftc/Taylor.v ./reals/Series.v ./reals/Series.v ./ftc/FunctSequence.v ./ftc/Composition.v ./ftc/Partitions.v ./ftc/Partitions.v ./ftc/COrdLemmas.v ./ftc/CalculusTheorems.v ./ftc/WeakIVT.v ./ftc/StrongIVT.v ./ftc/FTC.v ./ftc/IntegrationRules.v ./transc/PowerSeries.v ./transc/RealPowers.v ./transc/Trigonometric.v ./complex/Complex_Exponential.v ./transc/InvTrigonom.v ./transc/InvTrigonom.v ./transc/ArTanH.v ./transc/ArTanH.v ./coq_reals/Rreals.v ./coq_reals/Rreals_iso.v ./metrics/CPseudoMSpaces.v ./metrics/CPMSTheory.v ./metric2/Metric.v ./metric2/CompleteProduct.v ./metric2/Limit.v ./metric2/Limit.v ./model/metric2/Qmetric.v ./model/metric2/Qmetric.v ./metric2/Hausdorff.v ./metric2/Graph.v ./model/metric2/CRmetric.v ./model/metric2/CRmetric.v ./reals/fast/Compress.v ./reals/fast/Compress.v ./reals/fast/CRGroupOps.v ./reals/fast/CRsign.v ./reals/fast/CRAlternatingSum.v ./reals/fast/CRseries.v ./reals/fast/ContinuousCorrect.v ./reals/fast/ContinuousCorrect.v ./reals/fast/ModulusDerivative.v ./reals/fast/CRexp.v ./reals/fast/CRarctan_small.v ./reals/fast/CRarctan.v ./reals/fast/CRsin.v ./reals/fast/CRcos.v ./reals/fast/CRartanh_slow.v ./reals/fast/CRtrans.v ./model/structures/OpenUnit.v ./model/metric2/L1metric.v ./model/metric2/LinfMetricMonad.v ./model/metric2/IntegrableFunction.v ./model/metric2/LinfDistMonad.v ./model/metric2/LinfDistMonad.v ./reals/fast/Integration.v ./reals/fast/Integration.v ./reals/fast/Interval.v ./reals/fast/Interval.v ./raster/Raster.v corn-8.20.0/doc/skel/000077500000000000000000000000001473720167500142615ustar00rootroot00000000000000corn-8.20.0/doc/skel/CComplex.tex000066400000000000000000000040011473720167500165100ustar00rootroot00000000000000\section{Complex numbers} \begin{definition} A structure for the complex numbers consists of $$\CC=\RR\times \RR,$$ % where $\RR$ is a structure for the real numbers. On a structure of the complex numbers one defines \begin{eqnarray*} (r,s)+_\CC(r',s')&=&(r+r',s+s');\\ (r,s)*_\CC(r',s')&=&(r*r'-s*s',r*s'+r'*s);\\ 0_\CC&=&(0,0);\\ 1_\CC&=&(1,0);\\ i&=&(0,1),\\ (r,s)=_\CC(r',s')&=&r= r' \wedge s= s',\\ (r,s)\noto_\CC(r',s')&=&r\noto r' \vee s\noto s'. \end{eqnarray*} Here $+,*,0,1,=,\noto$ denote the usual operations and relations on the structure for the reals. \end{definition} \begin{notation} As a corollary of the definition, an element $z=(r,s)\in \CC$ will also be denoted by $r + is$. \end{notation} \begin{proposition} \begin{enumerate} \item With the definitions \begin{eqnarray*} -_\CC(r,s)&=&(-r,-s);\\ (r,s)^{-1}&=&(\frac{r}{r^2+s^2},\frac{-s}{r^2+s^2}). \end{eqnarray*} a structure for the reals becomes a constructive field. \item Moreover $i^2=-1$. \end{enumerate} \end{proposition} Let in the following $\CC$ be a structure for the complex numbers. \begin{definition} For $z=(r,s)\in \CC$ define \begin{eqnarray*} |z|&=&\sqrt{(r^2+s^2)};\\ \overline{z}&=&(r,-s). \end{eqnarray*} \end{definition} \begin{lemma}For $z\in\CC$ one has $$z\noto 0 \eqqe |z| \noto 0,$$ where the second $\noto$ and $0$ are taken from the structure of reals. \end{lemma} \begin{proposition} For $z_1,z_2\in \CC$ one has \begin{eqnarray*} \overline{z_1*_\CC z_2}&=&\overline{z_1}*_\CC\overline{z_2}.\\ |z_1*_\CC z_2|&=&|z_1|*|z_2|.\\ |z_1+_\CC z_2|&\leq& |z_1|+|z_2|. \end{eqnarray*} \end{proposition} \begin{lemma} For $z_1, z_2\in\CC$ one has $$\frac{z_1}{z_2}< 0 \implies |z_1+z_2| = |z_1|-|z_2|,$$ where the statement $ \frac{z_1}{z_2}< 0$ denotes that the complex number $ \frac{z_1}{z_2}$ is of the form $(r,0)$ with $r<0$.. \end{lemma} \begin{proof} $|a+b| = |a(1+\frac{b}{a})| = |a| |1+\frac{b}{a}| = |a| (1-\frac{b}{a}) = |a|-|b|$. \qed \end{proof} \begin{lemma} For $z\in \CC$ one has $$z*\overline{z} = |z|^2.$$ \end{lemma} corn-8.20.0/doc/skel/CFields.tex000066400000000000000000000220421473720167500163140ustar00rootroot00000000000000\begin{definition}[Constructive Field]\label{deffield} A {\em constructive field\/} is a tuple \struct{S,0,1,+,-,*,^{-1},=,\noto} such that \struct{S,0,1,+,-,*,=,\noto} is a constructive ring and $^{-1}$ is an operation on the subsetoid $\{x\in S\mid x\noto 0\}$, such that \begin{enumerate} \item $x^{-1}$ is inverse of $x$ with respect to $*$:\quad $\forall x[x\noto 0 \implies x x^{-1}=1]$. \end{enumerate} \end{definition} We have not introduces Integral Domains as a seperate algebraic notion, but constructive fields are indeed constructive integral domains, as they satisfy the following property. \begin{lemma}[Integral Domain Property]\label{lemidfield} In a constructive field we have $$\forall x,y [x\noto 0 \wedge y\noto 0 \implies x y \noto 0],$$ that is, a constructive field is a constructive integral domain. \end{lemma} \begin{proof} Suppose $x\noto 0, y\noto 0$. Then $(x y) y^{-1} =x \noto 0= 0 y^{-1}$, so $x y \noto 0$, by strong extensionality of $*$. \qed. \end{proof} \begin{lemma}\label{nonzsetoid} If \struct{S,0,1,+,-,*,^{-1},=,\noto} is a constructive field, then \struct{\{x\in S\,|\, x\noto 0\},1,*,=,\noto} forms a constructive monoid. \end{lemma} \begin{lemma}\label{intmulrespap} In a constructive field, $*$ respects $\noto$, i.e. \[ \forall x,y,z[x\noto y \wedge z\noto 0 \implies x z \noto y z]. \] \end{lemma} \begin{proof} Suppose $x\noto y$ and $z\noto 0$. By lemma \ref{lemgrstrext}, we have that $x-y \noto 0$. Hence $x z-y z=(x-y)z\noto 0$, and $z x\noto z y$ using lemma \ref{lemgrstrext} again. \qed \end{proof} \begin{lemma}\label{lempropid} The following hold in a constructive field. \begin{eqnarray*} x\neq 0 \wedge y\neq 0 &\implies& x y \neq 0,\\ x\neq y \wedge z\neq 0 &\implies& x z \neq y z,\\ x\neq0 \wedge x y = 0 &\implies & y=0. \end{eqnarray*} \end{lemma} \begin{proof} For the first, suppose $\neg\neg(x\noto 0)$ and $\neg\neg(y\noto 0)$ and suppose $\neg(x y\noto 0)$. If $x\not 0$, then if $y\noto 0$ we would have $x y \noto 0$, contradiction, so $\neg(y\noto 0$. But this is a contradiction, so $\neg(x\noto 0)$. Contradiction, so $\neg\neg(x y\noto 0)$. For the second, suppose $x\neq y$ and $z\neq 0$. Then $x-y \neq 0$ (using Lemma \ref{lemstrextneq}). Now, $z (x-y) \neq 0$ using the first and hence $z x \neq z y$ using distributivity and again Lemma \ref{lemstrextneq}.\\ For the third, suppose $x\neq 0$ and $x y=0$. If $y\neq 0$, then $x y \neq 0$ by the first. Contradiction, so $\neg(y\neq 0)$, which implies $y=0$. \qed \end{proof} \begin{remark} It is in general not the case that in a constructive integral domain, $$xy = 0 \implies x =0 \vee y =0.$$ This is just because the $\vee$ has a strong interpretation. A weak counterexample is given by defining the real numbers $x$ and $y$ respectively by the following Cauchy sequences of rationals $(x_i)_{i\in\NN}$, resp.\ $(y_i)_{i\in\NN}$. (In this definition we use $k_{99}$ as abbreviation of `the number $k$ where we have just completed a sequence of $99$ $9$s in the decimal series of $\pi$. Similarly $i0 \implies a c < b c.$$ \end{lemma} \begin{proof} Using Axioms 3, 4 and distributivity. \qed \end{proof} \begin{lemma}\label{lemminless} $$a>b \eqqe -a < -b.$$ \end{lemma} \begin{proof} Using Axiom 3. \qed \end{proof} \begin{corollary} $$0 < 1.$$ \end{corollary} \begin{proof} $0<1\vee 1<0$. If $1<0$, then $-1 > 0$ (by \ref{lemminless}), so $1 = (-1) (-1) > 0$. \qed \end{proof} \begin{lemma}\label{leminvpos} $$a> 0 \eqqe a^{-1} > 0.$$ \end{lemma} \begin{proof} If $a> 0$, then $a\noto 0$, so $a^{-1} \noto 0$, i.e.\ $a^{-1}>0 \vee a^{-1}< 0$. Now, if $a^{-1}< 0$, then $-a^{-1}>0$ (Lemma \ref{lemminless}), so $-1 >0$ (Lemma \ref{lempres1}), contradiction. Hence $a^{-1}>0$. \qed \end{proof} \begin{lemma}\label{leminvless} \begin{eqnarray*} a>b>0 &\eqqe& b^{-1} > a^{-1} > 0\\ 0>a>b &\eqqe& 0> b^{-1} > a^{-1}. \end{eqnarray*} \end{lemma} \begin{proof} The first using Lemma \ref{lempres1} and Lemma \ref{leminvpos}. The second using Lemma \ref{lemminless} and the first. \qed \end{proof} \begin{definition}\label{defleq} We define the relation $\leq$ by $$x\leq y := \neg(y< x).$$ \end{definition} \begin{lemma}\label{lemmulpresgeq} \begin{eqnarray*} x\leq y &\implies& x+z \leq y+z,\\ x\leq y \wedge z>0 &\implies& x z \leq y z. \end{eqnarray*} \end{lemma} \begin{proof} If $x+z > y +z$, then $x>y$ by Axiom 3. If $x z > y z$ and $z>0$, then $x>y$ by Lemma \ref{lempres1}, using Lemma \ref{leminvpos}. \qed \end{proof} \begin{lemma}\label{lemgtgeq} $x\geq y \eqqe \forall z[y>z \implies x>z]$. \end{lemma} \begin{proof} From right to left: Suppose $xz$. Then $y>x\vee x>z$. As $y\leq x$, we conclude that $x>z$. \qed \end{proof} \begin{lemma}\label{lemgeqprop} \begin{eqnarray*} x\leq y \wedge y\leq x &\implies& x=y,\\ x> y \vee y=x &\implies& x\geq y \end{eqnarray*} \end{lemma} \begin{proof} Both trivial. \qed \end{proof} \begin{lemma}\label{lemgeqtrans} \begin{eqnarray*} x< y \wedge y\leq z &\implies& xz$. The $x>z$ using the second, contradiction. \qed \end{proof} \begin{lemma}\label{lemsqpos} $x^2 \geq 0$. \end{lemma} \begin{proof} Suppose $x^2 < 0$. Then $x^2 \noto 0$, so $x\noto 0$ (using \ref{lemHeyt}), so $x>0$ or $x<0$. In the first case $x^2 >0$. In the second case $-x >0$, so $(-x)^2 = x^2 >0$. Contradiction in both cases, so $\neg(x^2 < 0)$. \qed \end{proof} corn-8.20.0/doc/skel/CGroups.tex000066400000000000000000000065271473720167500163770ustar00rootroot00000000000000\section{Constructive Commutative Algebra} We define the notions of commutative monoid, group, ring, integral domain and field in a constructive way. In doing so, we follow \cite{Ruit82} and \cite{TvD882}, by requiring the basic operations to be strongly extensional. In the end this choice does not effect our work, because in a real number structure, it can be proved from the axioms that all basic operations and relations are strongly extensional. \begin{convention}\label{convstrext} Without stating it explicitly, we require all operations on setoids to respect the equality. %, that is, for $f$ an operation in the structure we require %$\forall x, y [x = y \implies f(x) = f(y)].$ We also require all basic operations and relations on setoids to be strongly extensional (Definition \ref{defstrext}). \end{convention} \subsection{Groups: One associative operation} \begin{definition}[Constructive Semi-Group]\label{defsemigrp} A {\em constructive semi-group\/} is a tuple \struct{S,+,=,\noto} with \struct{S,=,\noto} a constructive setoid, $+$ a binary operation on $S$ such that \begin{enumerate} \item $+$ is {\em associative}: $\forall x, y,z[(x+y)+z = x+(y+z)]$. \end{enumerate} \end{definition} \begin{definition}[Constructive Monoid]\label{defmonoid} A {\em constructive monoid\/} is a tuple \struct{S,0,+,=,\noto} with \struct{S,+,=,\noto} a constructive semi-group and $0$ an element of $S$ such that \begin{enumerate} \item $0$ is the {\em identity\/} w.r.t.\ $+$: $\forall x[x+0=x]$. \end{enumerate} \end{definition} \begin{definition}[Constructive Group]\label{defgroup} A {\em constructive group\/} is a tuple \struct{S,0,+,-,=,\noto} with \struct{S,0,+,=,\noto} a constructive monoid, $-$ a unary operation on $S$ such that \begin{enumerate} \item $-x$ is the inverse of $x$: $\forall x[x+(-x)=0]$. \end{enumerate} In practice we write ``$x-y$'' for ``$x+(-y)$''. \end{definition} \begin{lemma}[Inverses are unique]\label{lemuninv} The inverse of $+$ is unique, i.e.\ for all $x,y$, $$x + y = 0 \implies y = -x.$$ As a consequence we find immediately that for all $x,y$, \begin{eqnarray*} -(-x) &=& x,\\ -(x+y) &=& (-y)+(-x). \end{eqnarray*} \end{lemma} \begin{lemma}[Cancellation]\label{lemcanc} For all $x, y, z$, \[ x+y=x+z \implies x=y. \] \end{lemma} \subsubsection{Apartness in Groups} \begin{lemma}\label{lemGrpHeyt} For all $x,y$, \[ x+y\noto 0 \implies x\noto 0 \vee y\noto 0. \] \end{lemma} \begin{proof} By strong extensionality of $+$, $x+y\noto 0+0$ implies $x\noto 0\vee y\noto 0$. \qed \end{proof} \begin{lemma}\label{lemgrstrext} The operations of a group respect $\noto$, i.e.\ for all $x,y,z$, \begin{eqnarray*} x\noto y & \eqqe & x+z \noto y+z,\\ x\noto y & \eqqe & x-y \noto 0,\\ x\noto 0 & \eqqe & -x \noto 0. \end{eqnarray*} \end{lemma} \begin{proof} For direction $\implies$, $(x+z)-z = x\noto y = (y+z)-z$ (using that $\noto$ respects $=$, \ref{lemaprespeq}), so by strong extensionality of $+$, $x+z\noto y+z$. The converse uses the forward direction with $-z$. The second part follows from the first part noting that $0=y-y$. \qed \end{proof} \begin{remark}As has already been pointed out, we {\em always} require functions to respect the equality and to be strongly extensional. In general, you'd want a function to respect the inequality or the apartness only if it has an inverse. See Lemma \ref{lemstrextinv}. \end{remark} corn-8.20.0/doc/skel/CIntDomains.tex000066400000000000000000000071271473720167500171620ustar00rootroot00000000000000\begin{definition}[Constructive Integral Domain]\label{defintdom} A {\em constructive integral domain\/} is a constructive ring \struct{S,0,1,+,-,*,=,\noto} such that \begin{enumerate} \item $\forall x,y [x\noto 0 \wedge y\noto 0 \implies x y \noto 0]$. \end{enumerate} \end{definition} \begin{lemma}\label{nonzsetoid} If \struct{S,0,1,+,-,*,=,\noto} is a constructive integral domain, then \struct{\{x\in S\,|\, x\noto 0\},1,*,=,\noto} forms a constructive monoid. \end{lemma} \begin{lemma}\label{intmulrespap} In a constructive integral domain, $*$ respects $\noto$, i.e. \[ \forall x,y,z[x\noto y \wedge z\noto 0 \implies x z \noto y z]. \] \end{lemma} \begin{proof} Suppose $x\noto y$ and $z\noto 0$. By lemma \ref{lemgrstrext}, we have that $x-y \noto 0$. Hence $x z-y z=(x-y)z\noto 0$, and $z x\noto z y$ using lemma \ref{lemgrstrext} again. \qed \end{proof} \begin{lemma}\label{lempropid} \begin{eqnarray*} x\neq 0 \wedge y\neq 0 &\implies& x y \neq 0,\\ x\neq y \wedge z\neq 0 &\implies& x z \neq y z,\\ x\neq0 \wedge x y = 0 &\implies & y=0. \end{eqnarray*} \end{lemma} \begin{proof} For the first, suppose $\neg\neg(x\noto 0)$ and $\neg\neg(y\noto 0)$ and suppose $\neg(x y\noto 0)$. If $x\not 0$, then if $y\noto 0$ we would have $x y \noto 0$, contradiction, so $\neg(y\noto 0$. But this is a contradiction, so $\neg(x\noto 0)$. Contradiction, so $\neg\neg(x y\noto 0)$. For the second, suppose $x\neq y$ and $z\neq 0$. Then $x-y \neq 0$ (using Lemma \ref{lemstrextneq}). Now, $z (x-y) \neq 0$ using the first and hence $z x \neq z y$ using distributivity and again Lemma \ref{lemstrextneq}.\\ For the third, suppose $x\neq 0$ and $x y=0$. If $y\neq 0$, then $x y \neq 0$ by the first. Contradiction, so $\neg(y\neq 0)$, which implies $y=0$. \qed \end{proof} \begin{remark} It is in general not the case that in a constructive integral domain, $$xy = 0 \implies x =0 \vee y =0.$$ This is just because the $\vee$ has a strong interpretation. A weak counterexample is given by defining the real numbers $x$ and $y$ respectively by the following Cauchy sequences of rationals $(x_i)_{i\in\NN}$, resp.\ $(y_i)_{i\in\NN}$. (In this definition we use $k_{99}$ as abbreviation of `the number $k$ where we have just completed a sequence of $99$ $9$s in the decimal series of $\pi$. Similarly $in$ (resp.\ $j>m$). The zero and unit are defined by \begin{eqnarray*} 0 &:=& \langle\; \rangle, (\mbox{the empty sequence}),\\ 1&:=&\langle 1\rangle. \end{eqnarray*} The apartness relation on $R[X]$ is defined by $$ f \noto g \; := \; \exists i(f_i \noto g_i).$$ \end{definition} Note that we use the terminology {\em length of a polynomial\/} when talking about the length of the list of coefficients. The length of a polynomial may not be the same as its {\em degree} (defined precisely in \ref{defdegpol})may be $0$. It is easy to see that $$ f =g \; \eqqe \; \forall i(f_i = g_i).$$ \begin{definition}\label{defdegpol} Let $f(X)=f_n X^n+f_{n-1}X^{n-1}+\ldots + f_1 X+f_0$ be a polynomial. \begin{enumerate} \item $f(X)$ {\em has degree $k$}, notation $\deg(f) = k$, if $k\leq n$, $f_k \noto 0$ and $i=0$ for all $i$ with $k< i \leq n$,\\ \item $f(X)$ {\em has degree at most $k$}, notation $\deg(f) \leq k$, if $k\leq n $, and $i=0$ for all $i$ with $k< i \leq n$,\\ \item $f(X)$ {\em has degree at least $k$}, notation $\deg(f) \geq k$, if $k\leq n $, $f_k \noto 0$. \end{enumerate} So, not all polynomials have a degree: `degree' is not a function on polynomials but a relation between polynomials and natural numbers. However, it is always the case that the degree of $f(X)=f_n X^n+f_{n-1}X^{n-1}+\ldots + f_1 X+f_0$ is {\em at most $n$}, and if we know that $f_k \noto 0$, it is {\em at least $k$}. \end{definition} \begin{definition}\label{defregpol} A polynomial $f(X)=f_n X^n+f_{n-1}X^{n-1}+\ldots + f_1 X+f_0$ is called {\em regular} if for its leading coefficient one has $f_n\noto 0$. (That is: the polynomial has a degree, which is the same as its length, $n$.) \end{definition} \begin{lemma}\label{lempolring} For $R$ a ring, $R[X]$ is a ring. \end{lemma} In the following, unless stated otherwise, $R$ is a ring. \begin{notation} A polynomial $f= \langle f_0, \ldots, f_n\rangle$ will often be denoted by $ f(X) = f_n X^n + f_{n-1} X^{n-1} + \ldots + f_0$ or by $f(X)= \Sigma_{j=0}^n f_j X^j$.\\ The multiplication operation $*$ will usually be omitted. \end{notation} \begin{definition}\label{defpolyfun} For every polynomial $f(X)= f_n X^n + f_{n-1} X^{n-1} + \ldots + f_0$ over $R$ we define a function $\overline{f}:R\rightarrow R$ in the canonical way: $$f(a):=f_n a^n + f_{n-1} a^{n-1} + \ldots + f_0.$$ In the following, we will often just write $f$ for this function $\overline{f}$. \end{definition} The following two Lemmas already hold for integral domains (rings with the additional property $x\noto 0 \wedge y\noto 0 \implies xy \noto 0$, see Lemma \ref{lemidfield}), but we have not introduced that notion here. \begin{lemma}\label{lempolid} Let $F$ be a field and let $f = f_n X^n + \ldots + f_0$ and $g= g_m X^m + \ldots + g_0$ be polynomials over $F$. Write $h_{m+n} X^{m+n} + \ldots + h_0$ for $fg$. Then $$f_i g_j \noto 0 \implies \exists k[ i+j \leq k \leq n+m \wedge h_k \noto 0].$$ \end{lemma} \begin{proof} See \cite{TvD882}, p.\ 417. \end{proof} \begin{theorem}\label{thmpolid} If $F$ is a field, then $F[X]$ satisfies the integral domain property, i.e.\ for all $f, g \in F[X]$, if $f\noto 0$ and $g\noto 0$, then $fg\noto 0$. \end{theorem} \begin{proof} Suppose $f= f_n X^n + \ldots + f_0 \noto 0$ and $g= g_m X^m + \ldots + g_0\noto 0$ and let $h_{m+n} X^{m+n} + \ldots + h_0$ be $fg$. Then $f_i g_j \noto 0$ for some $i,j$, but then $h_k\noto 0$ for some $k$. \qed \end{proof} \subsection{Factorization and zeros} Let $R$ be a constructive ring. \begin{lemma}\label{lemremainder} Let $f = f_n X^n + \ldots + f_0$ and $g= g_m X^m + \ldots + g_0$ be polynomials over $R$. Then there exist $k\in \NN, q,r \in R[X]$ such that $$(g_m)^k f(X) = q(X) g(X) + r(X)$$ and $r(X)$ has length less then $m$ or $0$. \end{lemma} \begin{proof} See \cite{TvD882}, p.\ 418. \end{proof} \begin{theorem}\label{thmremainder} Let $f(X)\in R[X]$ and $a\in R$. Then $$\exists ! q(X)\in R[X] ( f(X) = (X-a) q(X) + f(a)).$$ \end{theorem} \begin{proof} By Lemma \ref{lemremainder}, $f(X) =q(X) (X-a) + c$, for some polynomial $q(X)$ and $c\in R$. By taking the value of the function $f$ in $a$, we find that $c= f(a)$. Furthermore, $q(X) = q_{n-1} X^{n-1} + \ldots + q_0$ and we can determine the coefficients of $q(X)$ uniquely from the equation $f(X) =q(X) (X-a) + f(a)$. \qed \end{proof} \begin{corollary}\label{corremainder} For $f(X)\in R[X]$ and $a\in R$, $$ (X-a) | f(X) \eqqe f(a) = 0.$$ Moreover, if $f(X)$ has length $n$ and $f$ has $n+1$ zeros, then $f= 0$. \end{corollary} We now prove that if the polynomial $f$ has degree at least $k$ ($n\geq k>0$) and we are given $n+1$ distinct elements $(a_i)_{1\leq i \leq n+1}$, then $f(a_i)\noto 0$ for one of the $i$. This will be used to prove the Intermediate Value Theorem for polynomials. \begin{lemma}\label{lempolagrnpts} Let $f(X), g(X)\in R[X]$, both of length $n$. Let $(a_i)_{0\leq i \leq n-1}$ be distinct elements of $R$ (I.e.\ $a_i \noto a_j$ if $i\neq j$.). If $f(a_i)=g(a_i)$ for all $i$ ($0\leq i \leq n-1$), then $f=g$. \end{lemma} \begin{proof} The polynomial $h:= f-g$ has length $n$ and has $n$ zeros, so $h=0$ by Corollary \ref{corremainder}. Hence, $f=g$.\qed \end{proof} Let $F$ be a constructive field. \begin{lemma}\label{lempolnptsform} Let $f(X) \in R[X]$ of length $n$ and let $(a_i)_{1\leq i \leq n}$ be distinct elements of $R$. Then \begin{eqnarray*} f(X) &=& f(a_1) \frac{(X-a_2)(X-a_3) \cdots (X-a_{n})}{(a_1-a_2)(a_1 -a_3) \cdots (a_1-a_{n})} +\\ && f(a_2) \frac{(X-a_1)(X-a_3) \cdots (X-a_{n})}{(a_2-a_1)(a_2 -a_3) \cdots (a_2-a_{n})} +\\ &&\cdots\\ && f(a_{n}) \frac{(X-a_1)(X-a_2) \cdots (X-a_{n-1})}{(a_{n}-a_1)(a_{n} -a_2) \cdots (a_{n}-a_{n-1})}.\\ \end{eqnarray*} \end{lemma} \begin{proof} The right hand side of the equation is a polynomial $h(X)$ of length $n$ (note that all the fractions are defined, because all $a_i$ are distinct). Furthermore $f$ and $h$ agree on all $a_i$, hence $f=h$ by Lemma \ref{lempolagrnpts}. \qed \end{proof} \begin{lemma}\label{lempolnpts} Let $f(X) \in R[X]$ of degree at least $k$ ($n\geq k > 0$) and let $(a_i)_{1\leq i \leq n+1}$ be distinct elements of $R$. Then $$f(a_i) \noto 0$$ for some $i$. \end{lemma} \begin{proof} Write $f(X) = f_n X^n + \ldots + f_0$. By Lemma \ref{lempolnptsform} we find that for the coefficient $f_k$ we have %$$f_k = \Sigma_{1\leq i \leq n+1} f(a_i)\frac{1}{\Pi_{1\leq j \leq %n+1, i\neq j} (a_i - a_j)}.$$ $$f_k = \Sigma_{1\leq i \leq n+1} f(a_i) h_k^i,$$ where $h_k^i$ is the $k$-th coefficient of the $i$-th polynomial as above: $$\frac{(X-a_1) \cdots (X-a_{i-1})(X-a_{i+1})\cdots(X-a_{n})}{(a_{i}-a_1)\cdots (a_{i} -a_{i-1})(a_{i} -a_{i+1}) \cdots (a_{i}-a_{n+1})}$$ As $f_k \noto 0$, we find that $f(a_i) \noto 0$ for at least one $i$. \qed \end{proof} \subsection{Operations on polynomials} We need some formal operations on polynomials. Let $F$ be an ordered field (to make sure that always $n!\noto 0$; as ordered field are infinite this is the case). \begin{definition} For $f(X) = a_n X^n+a_{n-1}X^{n-1}+\ldots +a_1 X +a_0$ a polynomial, we define the {\em derivative of $f$}, $f\ac$ as follows. $$f\ac (X) := na_n X^{n-1}+(n-1)a_{n-1}X^{n-2}+\ldots +a_1.$$ Taking $k$-times the deriavtive of $f$ is denoted as $f^{(k)}$. \end{definition} \begin{definition}\label{defpolyop} Let $f(x)=a_nx^n+a_{n-1}x^{n-1}+\ldots +a_0$ be a polynomial over $R$ and $c\in R$. Define the polynomials $f{{\verb+~+}}$ and $f_c$ as follows. \begin{eqnarray*} f{{\verb+~+}}(X)&=&a_0 X^n+\ldots +a_{n-1}X+a_n,\\ f_c(X)&=&\frac{f^{(n)}(c)}{n!}X^n+\frac{f^{(n-1)}(c)}{(n-1)!}X^{n-1}+ \ldots +\frac{f\ac(c)}{1!}X + f(c) \end{eqnarray*} \end{definition} \begin{lemma}\label{lempolyop} Let $f(X)=a_n X^n+a_{n-1}X^{n-1}+\ldots +a_0$ be a polynomial over $R$ and $c\in R$. For the function $\overline{f}$ associated to this polynomial (\ref{defpolyfun}) we have \begin{eqnarray*} \overline{f{{\verb+~+}}}(x)= x^n \overline{f}(x^{-1}),\mbox{ if }x\noto 0,\\ \overline{f{{\verb+~+}}}(0)= a_n, \\ \overline{f_c}(x)=\overline{f}(x+c). \end{eqnarray*} \end{lemma} \begin{proof} We informally write $f$ where we refer to the function $\overline{f}$ etcetera. \beqn x^nf(\frac{1}{x})&=&x^n(a_nx^{-n}+\ldots+a_0)\\ &=&a_n+a_{n-1}+\ldots+a_0x^n\\ &=&f{{\verb+~+}}(x). \eeqn Clearly $f_c(x)$ is a polynomial of maximal degree $n$. Hence, $$f_c(x)=b_nx^n+\ldots+b_0.$$ It follows that \beqn f(c)&=& f_c(0)\;=\;b_0,\hfill \mbox{ hence }b_0\;=\;f(c),\\ f\ac(c)&=&f\ac_c(0)\;=\;b_1,\mbox{ hence }b_1\;=\;f\ac(c)\\ f^{(2)}(c)&=&f^{(2)}_c(0)\;=\;2!b_2,\mbox{ hence } b_2\;=\;\frac{f^{(2)}(c)}{2!}\\ \ldots&&\\ f^{(n)}(c)&=&f^{(n)}_c(0)\;=\;n!b_n,\mbox{ hence } b_n\;=\;\frac{f^{(n)}(c)}{n!}. \qed \eeqn \end{proof} \weg{ \begin{lemma}\label{1.6} Let $f(X) = a_n X^n+a_{n-1}X^{n-1}+\ldots +a_1 X +a_0,$ be a polynomial over an infinite field $F$ in which $i\neq 0, a\noto 0 \implies ia\noto 0$. Suppose that $a_k\unneq 0,$ for some $00.$ By the induction hypothesis there exists an infinite subset $A_{l-1}\subset F$ such that $$a\in A_{l-1}\Rightarrow f(a)\unneq 0,\;f'(a)\unneq 0,\ldots,f^{(l-1)}(a)\unneq 0.$$ We only need to show the existence of an infinite subset $A_l\subset A_{l-1}$ such that $$a\in A_l\Rightarrow f^{(l)}(a)\unneq 0.$$ The coefficient of degree $k-l$ in $f^{(l)}$ is $k(k-1)\ldots(k-l+1)a_k\unneq 0.$ Hence if we choose $u_0,\ldots,u_{n-l}\in A_{l-1},\;\; u_i\noto u_j \mbox{ if } i\neq j,$ then it follows similarly to the {\em Case }$l=0$ that $f^{(l)}(u_i)\unneq 0$ for some $i,\;\; 0\leq i \leq n-l.$ This shows the existence of $A_l.\hfill\qed$ \end{proof} } corn-8.20.0/doc/skel/CReals.tex000066400000000000000000000361221473720167500161600ustar00rootroot00000000000000\section{The Reals} We give a constructive axiomatization of the reals $\RR$. The intention is that the axioms can be instantiated by any specific construction of $\RR$. In our axiomatization, the reals form a constructive ordered field, for which Cauchy-completeness and the axiom of Archimedes hold. \begin{definition} A {\em structure for real numbers\/} is a constructive abelian ordered field $\langle \RR, 0, 1, +, *, -, ^{-1}, =, <, \noto\rangle$ that \begin{enumerate} %\item $\langle \RR, 0, 1, +, *, -, ^{-1}, =, <, \noto\rangle$ is an abelian %constructive ordered field, %\item $<$ is transitive, irreflexive, anti-symmetric, %\item $+$ respects $<$, i.e.\ $\forall x,y [x0 \exists N\in\NN \forall m>N(-\epsilon 0$ or $x<0$ and using Lemma \ref{leminvless}. \qed \end{proof} \begin{definition} A sequence of reals $x_1, x_2,\ldots$ is called a {\em Cauchy sequence\/} if $$\forall \epsilon>0 \exists N\in\NN \forall m>N(-\epsilon < x_m - x_N < \epsilon).$$ \end{definition} \begin{lemma}\label{lemCauchy} A sequence of reals $x_1, x_2,\ldots$ is a Cauchy-sequence iff $$\forall k\in\NN \exists N\in\NN \forall m>N(-\frac{1}{k} 0$. The reverse implication uses the axiom of Archimedes. Assume $\forall k\in\NN \exists N\in\NN \forall m>N(-\frac{1}{k} 0$. Then $ \epsilon^{-1} \in \RR$, so there is a $k\in\NN$ such that $\epsilon^{-1} < k$ and hence $\epsilon > \frac{1}{k}$. Now we find $N$ by our assumption. \qed \end{proof} \weg{ \begin{lemma}\label{lemrealseqrat} For every $x\in \RR$ there exists a sequence of rational numbers $q_0, q_1, q_2, \ldots$ such that $$ x = \lim_{n\rightarrow\infty} q_n.$$ \end{lemma} \begin{proof} Let $x\in \RR$. Then there are $m, n\in \NN$ such that $x0$, there exists $x'\in\RR$ such that $$-\epsilon < x-x'< \epsilon \wedge x'\noto y.$$ \end{lemma} \begin{proof} $y< x+\frac{\epsilon}{2} \vee y> x-\frac{\epsilon}{2}$. In the first case take $x' := x+\frac{\epsilon}{2}$, in the second case take $x' := x-\frac{\epsilon}{2}$. \qed \end{proof} We now define the {\em maximum\/} of two real numbers. This is not straightfoward, because we have no trichotomy. (Classically, the maximum can be defined in an ordered field, but constructively that is in general not the case: one needs the Cauchy property.) In a situation where the reals are constructed out of the rationals, say, $x = (x_i)_{i\in \NN}$, one can use the maximum of two rationals ($\max(x_i,y_i)$) to define a Cauchy sequence of the maximum of $x$ and $y$, namely $(\max(x_i,y_i)_{i\in \NN}$. Here we can not do that. Instead when defining the maximum of $x$ and $y$ we first have to define an auxiliary sequence of reals $(y_i)_{i\in\NN}$ that has $y$ as a limit and such that $x\noto y_i$ for all $i$. \begin{definition}\label{defmax} We construct a sequence $(y_i)_{i\in\NN}$ such that $$\forall i\in \NN[-\frac{1}{i}< y-y_i <\frac{1}{i} \wedge y_i \noto x].$$ This is is possible, due to Lemma \ref{lemapy}. Note that $(y_i)_{i\in\NN}$ is a Cauchy sequence and $y=\lim_{i\rightarrow \infty} y_i$. Now define the sequence $(s_i)_{i\in\NN}$ by $$s_i := \left\{ \begin{array}{rcl} x &\mbox{if}& x>y_i,\\ y_i &\mbox{if}& xx \wedge \maxx(x,y)>y)]$. \end{lemma} \begin{proof} From the Definition of \maxx.\qed \end{proof} \begin{lemma}\label{lemmaxcomm} \maxx\ is commutative, i.e.\ $\forall x,y\in\RR[\maxx(x,y)=\maxx(y,x)]$. \end{lemma} \begin{lemma}\label{lemmaxisupb} \maxx\ gives an upperbound, i.e.\ $\forall x,y\in\RR[\maxx(x,y)\geq x \wedge \maxx(x,y)\geq y]$. \end{lemma} \begin{lemma}\label{lemmaxislub} \maxx\ give a least upperbound, i.e.\ $\forall x,y,z\in\RR[z\geq x \wedge z\geq y \rightarrow z\geq\maxx(x,y)]$. \end{lemma} \begin{proof} Suppose $z< \maxx(x,y)$. Then $zy$. Then $x\geq y$ and hence $\maxx(x,y) = x$ by the previous. Hence $x=y$, contradiction. So $x\leq y$. \qed \end{proof} \begin{definition}\label{defabs} For $x\in\RR$, we define $$|x| := \maxx(x, -x).$$ \end{definition} \begin{lemma} \label{lemabsid} $\forall x\in \RR[x\geq 0 \rightarrow |x|=x].$ \end{lemma} \begin{proof} If $x\geq 0$, then $-x \leq 0$, hence $-x\leq x$. So $\maxx(x,-x)= x$ by Lemma \ref{lemmaxgeq}. \qed \end{proof} \begin{lemma}\label{lemabseps} $\forall x,y,r\in\RR [|x-y| \leq r \leftrightarrow x-r \leq y\leq x+r]$. \end{lemma} \begin{proof} Immediate using the intermediate equivalent statement $x-y\leq r \wedge -x+y \leq r$. \qed \end{proof} \begin{lemma}\label{lemtriangle} $\forall x,y\in\RR[ |x+y| \leq |x|+|y|]$. \end{lemma} \begin{proof} $\maxx(x,-x)+\maxx(y,-y) \geq x+y$ and $\maxx(x,-x)+\maxx(y,-y) \geq -x-y$. Hence $|x|+|y| = \maxx(x,-x)+\maxx(y,-y) \geq \maxx(x+y, -x-y) = |x+y|$. \qed \end{proof} \begin{lemma}\label{lemabsmin} $\forall x,y,z,r,q\in\RR[ |x-y|\leq r \wedge |y-z|\leq q \rightarrow |x-z|\leq r+q$. \end{lemma} \begin{proof} $|x-z| =|x-y+y-z| \leq |x-y|+|y-z| \leq r+q$. \qed \end{proof} \weg{ \begin{remark}\label{remtris} The construction of the two sequences $p_0, p_1, p_2, \ldots$ and $q_0, q_1, q_2, \ldots$ in the proof above is a standard technique. We will refer to it as the {\em method of succesive trisection}. If we want to define a Cauchy sequence with limit $x$, this method works in general if we have a fixed $p_0$ and $q_0$ such that $p_0 < x < q_0$ and we can decide whether $\frac{2p + q}{3} x$ (proof by induction on $n$). Define the sequences $(p_i)_{i\in\NN}$ and $(q_i)_{i\in\NN}$ as follows. \begin{eqnarray*} p_0 &:=& 0,\\ q_0 &:=& x+1,\\ p_{i+1} &:=& \left\{\begin{array}{rcl} p_i &\mbox{if}&(\frac{2p_i + q_i}{3})^nx \end{array}\right.\\ q_{i+1} &:=& \left\{\begin{array}{rcl} q_i &\mbox{if}&(\frac{p_i + 2q_i}{3})^n>x,\\ \frac{p_i + 2q_i}{3} &\mbox{if}&(\frac{2p_i + q_i}{3})^n0\wedge z<0)\vee(y<0 \wedge z>0)$. Contradiction. So $y=z$. \qed \end{proof} \weg{ \begin{lemma}\label{lemdecQroot} Equality on the set $\{ x\,|\, \exists y\in\QQ\exists k\in\NN[y = x^k]\}$ is decidable. \end{lemma} } corn-8.20.0/doc/skel/CRings.tex000066400000000000000000000022351473720167500161720ustar00rootroot00000000000000\subsection{Rings: Two associative operations} \begin{definition}[Constructive Ring]\label{defring} A non-trivial {\em constructive ring\/} is a tuple \struct{S,0,1,+,-,*,=,\noto} with \struct{S,0,+,-,=,\noto} a constructive group and \struct{S,1,*,=,\noto} a constructive monoid such that \begin{enumerate} \item Non-triviality: $1\noto 0$. \item $+$ distributes over $*$:\quad $\forall x,y,z[x*(y+z) = (x*y)+(x*z)]$. \end{enumerate} \end{definition} \begin{notation} When dealing with rings we replace the operation $*$ by juxtaposition, writing $xy$ for $x*y$. \end{notation} \begin{lemma}\label{lemring}For all $x, y$: \begin{eqnarray*} x 0 &=& 0,\\ x (- y) &=& -(x y). \end{eqnarray*} \end{lemma} \begin{proof} The first by cancellation: $x0=x(0+0)=x0+x0$. The second (using the first) by uniqueness of inverses \ref{lemuninv}. \qed \end{proof} \begin{lemma}\label{lemHeyt} For all $x,y$, \begin{eqnarray*} x y \noto 0 &\implies& x\noto 0 \wedge y\noto 0. \end{eqnarray*} \end{lemma} \begin{proof} Suppose $x y \noto 0$. As $*$ is strongly extensional, we know $x y \noto x 0\implies y\noto 0$ and $x y \noto 0 y \implies x\noto 0$. \qed \end{proof} corn-8.20.0/doc/skel/CSetoids.tex000066400000000000000000000312221473720167500165200ustar00rootroot00000000000000\section{Setoids} A basic ingredient of constructive real numbers is the {\em apartness\/} relation $\noto$. This is a constructive version of the (classical) inequality on reals: two real numbers are apart if it can positively be decided that they are distinct from each other. In constructive analysis, the apartness is more basic than equality. We therefore take the notion of apartness as a basic ingredient of our structures Usually this apartness is taken to be {\em tight}, saying that the negation of apartness is the equality. In \cite{Ruit82} and \cite{MRR88} also apartness relations occur that are not necessarily tight, but in the formalization of reals one can restrict to a tight apartness. This also implies that, in the formalization, we could have done without an equality alltogether (and replace it with the negation of $\noto$). For reasons of exposition and for relating to a more classical set-up we choose to take equality as a primitive. \begin{definition} A binary relation $\noto$ on a set $S$ is an {\em apartness\/} relation if \begin{enumerate} \item $\noto$ is {\em consistent}, i.e.\ $\neg a \noto a$ for all $a$. \item $\noto$ is {\em symmetric}, i.e.\ $ a \noto b \implies b \noto a$ for all $a, b$. \item $\noto$ is cotransitive, i.e.\ $a\noto b \rightarrow\forall z[a\noto z \vee z\noto b]$ for all $a, b$. \end{enumerate} An apartness relation is {\em tight\/} if its negation is the equality, i.e.\ $\neg(a\noto b) \eqqe a = b$ for all $a, b$. \end{definition} \begin{fact} The negation of an apartness relation on $S$ is an equivalence relation on $S$ which is stable, i.e.\ $\neg\neg\neg(a\noto b) \implies \neg(a\noto b)$. \end{fact} \begin{lemma}\label{lemaprespeq} A tight apartness relation respects the equality, i.e. $$a\noto b \wedge b=b' \implies a\noto b' \mbox{ for all } a,b,b'.$$ \end{lemma} \begin{proof} If $a\noto b$, then $a\noto b' \vee b\noto b'$. The latter is false, because $b=b'$. \qed \end{proof} \begin{definition}\label{defset} A {\em constructive setoid\/} is a triple $\langle S, =, \noto \rangle$, with $S$ a set, $=$ an equivalence relation on $S$ and $\noto$ a tight apartness relation on $S$. \end{definition} In a structure, we want the operations and relations to respect the equality and the apartness. For the equality this means that we want to have the {\em replacement property\/} for all predicates: $$R(x_1,\ldots , x_n)\wedge x_1 = y_1 \wedge \ldots \wedge x_n = y_n \implies R(y_1,\ldots , y_n).$$ \begin{fact} The replacement property is closed under $\vee, \wedge, \neg, \implies, \exists$ and $\forall$. \end{fact} So, we only have to require that the basic relations satisfy the replacement property and that all basic operations are {\em well-defined\/} with respect to the equality, i.e.\ for $f$ of arity $n$ we have the following. $$x_1 = y_1 \wedge \ldots \wedge x_n = y_n \implies f(x_1,\ldots , x_n) = f(y_1,\ldots , y_n).$$ If we have a tight apartness relation, this immediately implies $$\neg(x_1 \noto y_1) \wedge \ldots \wedge \neg(x_n \noto y_n) \implies \neg(f(x_1,\ldots , x_n) \noto f(y_1,\ldots , y_n)),$$ but one would like to have a more positive formulation saying $$f(x_1,\ldots , x_n) \noto f(y_1,\ldots , y_n)\implies (x_1 \noto y_1) \vee \ldots \vee (x_n \noto y_n).$$ This property is called {\em strong extensionality\/} of $f$. \begin{definition}\label{defstrext} Let $S$ be a set with an apartness relation $\noto$ defined on it. For $f$ a $n$-ary function on $S$, we say that $f$ is {\em strongly extensional\/} if $$\forall x_1, \ldots, x_n, y_1, \ldots, y_n [f(\vec{x}) \noto f(\vec{y}) \implies (x_1\noto y_1 \vee \ldots \vee x_n \noto y_n)].$$ For $R$ a $n$-ary relation on $S$, we say that $R$ is {\em strongly extensional\/} if $$\forall x_1, \ldots, x_n, y_1, \ldots, y_n [R(\vec{x}) \implies (R(\vec{y}) \vee x_1\noto y_1 \vee \ldots \vee x_n \noto y_n)].$$ \end{definition} \begin{fact} Strong extensionality of functions is closed under composition. Strong extensionality of relations is closed under $\vee$, $\wedge$, $\exists$ and the substitution of strongly extensional terms. \end{fact} \begin{lemma} Strong extensionality implies well-definedness for functions. \end{lemma} \begin{proof} Suppose $f(\vec{x}) \noto f(\vec{y}) \implies (x_1\noto y_1 \vee \ldots \vee x_n \noto y_n)$ for all $x_1, \ldots, x_n, y_1, \ldots, y_n$. Suppose $x_1 = y_1\wedge \ldots \wedge x_n = y_n$ and $f(\vec{x}) \noto f(\vec{y})$. Then $x_1\noto y_1 \vee \ldots \vee x_n \noto y_n$ by strong extensionality of $f$. Contradiction, so $\neg(f(\vec{x}) \noto f(\vec{y}))$, i.e.\ $f(\vec{x}) = f(\vec{y})$. \qed \end{proof} \begin{remark} Strong extensionality (for functions) says that a function can only distinguish elements that can already be distinguished. We will require all basic functions in constructive structures to be strongly extensional. As a consequence, all composed functions will be strongly extensional. % %Strong extensionality for relations says -- roughly -- %that a relation can only distinguish elements that can already be %distinguished. This intuition can be made more precise if we define %an apartness relation $\noto'$ on formulas by %$$ \phi \noto'\psi := (\phi\wedge \neg \psi)\vee(\neg \phi \vee %\psi),$$ %and we define a relation to be {\em modified strongly extensional\/} %if %$$ \forall x_1, \ldots, x_n, y_1, \ldots, y_n [R(\vec{x}) \noto' %R(\vec{y}) \implies (x_1\noto y_1 \vee \ldots \vee x_n \noto y_n)].$$ %Now, strong extensionality implies modified strong extensionality, but %not the other way around (QUESTION: Give CEX!). Obviously, both %notions are classically equivalent. We do not want all relations to be strongly extensional. For example, equality is not strongly extensional: if it were, then $x = y \implies p=q\vee x\noto p\vee y\noto q$ for all $x,y,p,q$, which implies the decidability of equality (take $x$ for $y$ and $p$). \end{remark} \begin{lemma}\label{lemstrextarg} If a binary function $f$ is strongly extensional in both arguments, i.e.\ \begin{eqnarray*} \forall x_1, x_2, y [f(x_1,y) \noto f(x_2, y) \implies (x_1\noto x_2)],\\ \forall x, y_1,y_2 [f(x,y_1) \noto f(x, y_2) \implies (y_1\noto y_2)], \end{eqnarray*} then it is strongly extensional. Similarly for functions of higher arity. \end{lemma} \begin{proof} Suppose the binary function $f$ is strongly extensional in both arguments and suppose $f(x_1,y_1) \noto f(x_2, y_2)$. Then $f(x_1,y_1) \noto f(x_1, y_2) \vee f(x_1,y_2) \noto f(x_2, y_2)$ by cotransitivity. Hence $ y_1 \noto y_2 \vee x_1 \noto x_2$. \qed \end{proof} \begin{lemma}\label{lemstrextneq} If $f$ is strongly extensional, then $$ f(\vec{x}) \neq f(\vec{y}) \implies \neg(x_1 = y_1 \wedge \ldots \wedge x_n = y_n).$$ \end{lemma} \begin{proof} Suppose $ f(\vec{x}) \neq f(\vec{y})$, i.e. $\neg\neg(f(\vec{x}) \neq f(\vec{y}))$. Suppose also that $x_1 = y_1 \wedge \ldots \wedge x_n = y_n$. Now, if $f(\vec{x}) \noto f(\vec{y})$, then $x_1 \noto y_1 \vee \ldots \vee x_n \noto y_n$, contradicting $x_1 = y_1 \wedge \ldots \wedge x_n = y_n$. So $\neg(f(\vec{x}) \noto f(\vec{y}))$, contradicting $ f(\vec{x}) \neq f(\vec{y})$. So we conclude that $\neg(x_1 = y_1 \wedge \ldots \wedge x_n = y_n)$. \qed \end{proof} If a function $f$ has an inverse, we want it to {\em respect\/} the apartness. Note that, if $f$ has no inverse we do not want that in general (e.g.\ consider multiplication in $\ZZ_4$). That $f$ respects $\noto$ comes as a consequence of strong extensionality and the existence of an inverse. \begin{lemma}\label{lemstrextinv} Suppose that the unary function $f$ has an inverse $g$ which is strongly extensional. Then $f$ respects the apartness, i.e.\ $$x\noto y \implies f(x) \noto f(y).$$ \end{lemma} \begin{proof} We know that $g(x) \noto g(y) \implies x\noto y$ and that $g(f(x))=x$. Now suppose $x\noto y$, i.e.\ $g(f(x))\noto g(f(y))$. Then $f(x) \noto f(y)$ by strong extensionality of $g$. \qed \end{proof} \begin{lemma}\label{respneq} If $f$ respects the apartness, then $f$ respects the inequality \end{lemma} \begin{proof} Let $f$ respect the apartness(i.e.\ $(x_1\noto y_1 \vee \ldots \vee x_n \noto y_n) \implies f(\vec{x}) \noto f(\vec{y})$). Suppose $x_1\neq y_1 \vee \ldots \vee x_n \neq y_n$ and suppose $f(\vec{x} = f(\vec{y})$. Now, if $x_i \noto y_i$ for some $i$, then $f(\vec{x} \noto f(\vec{y})$, contradiction, so $x_i = y_i$ for all $i$. This is again a contradiction, so $f(\vec{x}) \neq f(\vec{y})$. \qed \end{proof} \begin{lemma} If a relation $R$ is strongly extensional in each of its arguments, it is strongly extensional. \end{lemma} \begin{proof} We give the proof for a binary relation $R$. Suppose $R$ is strongly extensional in both arguments, i.e. \begin{eqnarray*} R(x,y) &\implies & R(x,q)\vee y\noto q,\\ R(x,y) &\implies & R(p,y)\vee p\noto x. \end{eqnarray*} for all $x,y,p,q$. Now, if $R(x,y)$, then $R(x,q)\vee y\noto q$. If $R(x,q)$, then $R(p,q)\vee p\noto x$, so $R(p,q)\vee p\noto x\vee y\noto q$. \qed \end{proof} \begin{lemma}\label{tapstrext} Apartness is strongly extensional. \end{lemma} \begin{proof} Suppose $x\noto y$. Then $x\noto p \vee y\noto p$ by cotransitivity and hence $x\noto p \vee y\noto q \vee p\noto q$ by again cotransitivity. \qed \end{proof} \subsection{On the choice of the primitives} In view of the fact that we require an apartness relation in a setoid to be tight, we could have chosen to define a setoid as a pair $\langle S, \noto\rangle$ with $\noto$ an apartness relation and then {\em define\/} equality by $$x=y \;\;\;\; := \;\;\;\; \neg(x\noto y).$$ Then the following can be shown. \begin{enumerate} \item If an operation $f$ is strongly extensional, then it respects $=$. \item If a relation $R$ is strongly extensional, then it satisfies the replacement property. \item Hence all relations satisfy the replacement property. \end{enumerate} So, we could have done without an equality alltogether. However, we have not chosen this option, because equality is a natural primitive. Furthermore one may at some point encounter structures in which apartness is not tight. \subsection{Subsetoids and Quotient Setoids} \begin{definition}\label{defsubset} Given a constructive setoid $\langle S, =, \noto \rangle$ and a predicate $P$ on $S$, we define the {\em subsetoid of the $x\in S$ that satisfy $P$\/} as the setoid $\langle \{ x\in S \mid P (x) \}, =', \noto' \rangle$, where $='$ and $\noto'$ are the equality and apartness inherited from $S$, i.e.\ for $q,t\in \{ x\in S \mid P (x) \}$, \begin{eqnarray*} t='q &\iff & t =q,\\ t\noto'q &\iff & t \noto q,\\ \end{eqnarray*} We denote this subsetoid just by $\{ x\in S \mid P (x) \}$. \end{definition} For this definition to be correct, it has to be shown that $='$ is indeed an equivalence relation and that $\noto'$ is a tight apartness relation (w.r.t.\ $=$) on $\{ x\in S \mid P (x) \}$. This is trivially the case. As the equivalence and apartness are directly inherited from $S$, we never write them explicitly, but use the ones from $S$. \begin{definition}\label{quotset} Given a constructive setoid $\langle S, =, \noto \rangle$ and a strongly extensional apartness relation $Q$ on $S$, we define the {\em co-quotient setoid $S/R$\/} as the setoid $\langle S,\overline{R} , R \rangle$, where $\overline{R}$ is the complement of $R$, i.e.\ $\overline{R} (x,y)$ iff $\neg R(x,y)$. \end{definition} For this definition to be correct, it has to be shown that $\overline{R}$ is an equivalence relation and that $R$ is a tight apartness relation (w.r.t.\ $\overline{R}$) on $\{ x\in S \mid P (x) \}$. This follows trivially from the definition of $\overline{R}$ and the fact that $R$ is an apartness. If we do not require $R$ to be strongly extensional, $S/R$ as defined above is still a constructive setoid. However, we only want to consider the situation where the new apartness $R$ is a subset of the old one, i.e.\ $R(x,y) \implies x\noto y$. This is a consequence of strong extensionality of $R$: take $x$ for $p$ and for $q$ in $R(x,y) \implies (R(p,q) \vee x\noto p \vee y \noto q)$. As a consequence we then find that $=$ is a subset of $\overline{R}$, so the new equality is a refinement of the old one. So, the definition of co-quotient setoid subsumes the ordinary definition of quotient set. For a strongly extensional function $f$ on a setoid $\langle S, =,\noto\rangle$ we find that, if $f$ is strongly extensional w.r.t.\ $R$, with $R$ a strongly extensional apartness relation on $S$, then $f$ is also strongly extensional on the co-quotient setoid. The real numbers form a primary example of a co-quotient setoid. They can be seen as the setoid $(\NN \arr \QQ)/R$, where $\NN\arr \QQ$ is the set of infinite sequences of rational numbers and $R$ is the apartness relation between such sequences: for $r$ and $s$ two sequences, $R(r,s)$ iff $\exists k, N\in\NN\forall m>N (|r_m - s_m| >\frac{1}{k})$. corn-8.20.0/doc/skel/CVectorSpace.tex000066400000000000000000000041111473720167500173210ustar00rootroot00000000000000\subsection{Vector Spaces: An external operation} \begin{definition} Let $F$ be a field. An $F$-{\em vector space\/} is a tuple \struct{G,\cdot}, with $G$ an abelian group and $\cdot$ an operation from $F\times G$ to $G$ satisfying \begin{eqnarray*} (\alpha\beta) \cdot a &=& \alpha\cdot(\beta\cdot a),\\ 1\cdot a &=& a,\\ (\alpha+\beta)\cdot a &=& (\alpha\cdot a) + (\beta\cdot a),\\ \alpha\cdot(a+b) &=& (\alpha\cdot a) + (\beta\cdot a). %\alpha\cdot a \noto 0 &\implies& \alpha\noto 0 \wedge a\noto 0, \end{eqnarray*} where $\alpha,\beta$ range over $F$ (\emph{scalars}) and $a,b$ range over $G$ (\emph{vectors}). Where no confusion arises we will omit the operation $\cdot$, replacing it with juxtaposition. \end{definition} Note that $\cdot$ is strongly extensional, due to our Convention \ref{convstrext}. \begin{lemma} For all $\alpha,a$, \begin{eqnarray*} & \alpha 0 = 0,\\ & 0 a = 0,\\ & \alpha a \noto 0 \implies \alpha\noto 0 \wedge a\noto 0,\\ & (-\alpha)a = -(\alpha a) = \alpha(-a). \end{eqnarray*} \end{lemma} \begin{proof} For the first, by cancellation in the group G, it suffices to note $(\alpha 0)+(\alpha 0)=\alpha (0+0)=\alpha 0$. The argument for the second is similar. For the third we use the first and the second. Suppose $\alpha a \noto 0=0 a$. By strong extensionality of $\cdot$, $\alpha\noto 0$ or $a\noto a$; the latter is absurd. Similarly, $a\noto 0$. \qed \end{proof} \begin{lemma} For all $\alpha,\beta,a,b$, \begin{eqnarray*} \alpha\noto 0\wedge a\noto b&\implies & \alpha\cdot a \noto \alpha\cdot b,\\ \alpha\noto 0\wedge a\noto 0&\implies & \alpha\cdot a \noto 0,\\ \alpha\noto \beta\wedge a\noto 0&\implies & \alpha\cdot a \noto \beta\cdot a. \end{eqnarray*} \end{lemma} \begin{proof} For the first we have: $\alpha^{-1}(\alpha a)=a\noto b=\alpha^{-1}(\alpha b)$, so $\alpha a \noto\alpha b$ by strong extensionality of $\cdot$. The second follows by taking $b=0$. For the third, we have $\alpha-\beta\noto 0$ (from \ref{lemgrstrext}), and $a\noto 0$, so $\alpha a-\beta a=(\alpha-\beta)a\noto 0$, and $\alpha a\noto\beta a$ by \ref{lemgrstrext} again. \qed \end{proof} corn-8.20.0/doc/skel/FTA.tex000066400000000000000000000055441473720167500154250ustar00rootroot00000000000000\begin{proposition}\label{propfactpoly} Let $f(x)=a_n x^n+a_{n-1}x^{n-1}+\ldots + a_1 x+a_0$, with $a_i\in\CC$. Suppose that $a_k\noto 0$, for some $0|b_0|\exists z\in\CC[ |z| < c^{1/n} \wedge |f(z)|< qc].$$ \end{proposition} Before proving the Kneser Lemma, we state the so called `Main Lemma' that gives the main ingredients for proving the Kneser Lemma. The advantage of the Main Lemma is that it is just about real numbers; the complex numbers only come in with the Kneser Lemma. There is a `Key Lemma' that proves the Main Lemma. We state the Key Lemma first. \begin{lemma}[Key Lemma]\label{lemma:seq} For every $n\geq 2$, $\epsilon >0$ and $a_0, \ldots , a_n \geq 0$ with $a_n = 1$, $a_0>\epsilon$, there exists \begin{enumerate} \item $t>0$ \item $k_0\geq k_1,\geq k_2 \geq \ldots$, \end{enumerate} such that $$ a_{k_0} t^{k_0} = a_0 +\epsilon $$ and moreover for every $j$, if we let $k = k_j$ and $r = 3^{-j} t$: $$a_k r^k > a_i r^i - \epsilon \makebox[0pt][l]{\qquad\it for all $i\in\{1,\ldots,n\}$}$$ \end{lemma} From the Key Lemma we obtain the Main Lemma \begin{lemma}[Main Lemma]\label{lemma:est1} For every $n\geq 2$, $\epsilon >0$ and $a_0, \ldots , a_n \geq 0$ with $a_n = 1$, $a_0> \epsilon$, there exists \begin{enumerate} \item $k\in \{1, \ldots, n\}$, \item $r>0$ \end{enumerate} such that \begin{eqnarray} r^n &< & a_0, \label{ineq:est1}\\ a_k r^k &<& a_0, \label{ineq:est2}\\ 3^{-2n^2} a_0 - 2\epsilon &<& a_k r^k, \label{ineq:est3}\\ \sum_{i=1\atop i\ne k}^n a_i r^i &<& (1 - 3^{-n}) a_k r^k + 3^n\epsilon. \label{ineq:est4} \end{eqnarray} \end{lemma} The Main Lemma is the crucial property about reals to prove the Kneser Lemma. \paragraph{Proof of the Key Lemma, \ref{lemma:seq}} We prove the Key Lemma in a sequence of smaller Lemmata, some specifically related to FTA, some of a more general nature. \begin{lemma}\label{lemma:max} For $n>0$, $a_1,\ldots,a_n\in\RR$ and $\epsilon > 0$ there always is a $k\in \{1, \ldots ,n\}$ such that for all $i\in\{1,\ldots,n\}$: $$a_k > a_i - \epsilon$$ \end{lemma} \begin{proof} Induction with respect to $n$. \end{proof} \begin{lemma}\label{lemma:sel} For each sequence $k_0 \ge k_1 \ge k_2 \ge \ldots\in\{1,\ldots,n\}$ there is a $j\in\NN$ with $j < 2n$ such that $k_{j-1} = k_j = k_{j+1}$. \end{lemma} \begin{proof} Induction with respect to $n$. \end{proof} \begin{lemma}\label{lemma:ttt} Let $n>0$ and $\epsilon > 0$. Then for every $a_0,\ldots,a_n \ge 0$ with $a_0 > \epsilon$ and $a_n = 1$, there exist $t > 0$ and $k\in\{1,\ldots,n\}$ such that: $$a_k t^k = a_0 - \epsilon$$ and such that for all $i\in\{1,\ldots,n\}$: $$a_i t^i < a_0$$ \end{lemma} \begin{proof} Start with $k = n$ and $t = \root n\of{a_0 - \epsilon}$. Then consider in turn for $i$ the values $n-1$ down to $1$. At each $i$ either $a_i t^i < a_0$ or $a_i t^i > a_0 - \epsilon$ (for the value of $t$ that is current at that time.) In the first case do nothing, but in the second case set $k$ to $i$ and $t$ to $\root i\of{(a_0 - \epsilon)/a_i}$ (in which case $t$ will decrease.) This will give at the end a suitable $k$ and $t$. \end{proof} \begin{proof}[of the Key Lemma, \ref{lemma:seq}] Let $n\geq 2$, $\epsilon>0$ and $a_0, \ldots , a_n \geq 0$ with $a_n = 1$, $a_0>0$ be given. Choose $t$ and $k_0$ according to Lemma \ref{lemma:ttt}. To get $k_{j+1}$ from $k_j$, let $k = k_j$, $r = 3^j t$ and apply lemma \ref{lemma:max} with $\epsilon/2$ to the sequence $$a_1 (r/3),a_2 (r/3)^2,\ldots,a_k (r/3)^k$$ to get $k' = k_{j+1}$. Then for $i\le k$ the inequality for $k_{j+1}$ directly follows, while for $i > k$ we have: $$a_k (r/3)^k = 3^{-k} a_k r^k > 3^{-k}\left(a_i r^i - \epsilon\right) = 3^{-k} a_i r^i - 3^{-k}\epsilon > a_i (r/3)^i - \epsilon/2$$ and so: $$a_{k'} (r/3)^{k'} > a_k (r/3)^k - \epsilon/2 > a_i (r/3)^i - \epsilon$$ \end{proof} \paragraph{Proof of the Main Lemma, \ref{lemma:est1}} We also prove the Main Lemma in a sequence of smaller Lemmata. \begin{lemma}\label{lemma:bou} For every $n\geq 2$, $\epsilon >0$ and $a_0, \ldots , a_n \geq 0$ with $a_n = 1$, $a_0> \epsilon$, if there exist \begin{enumerate} \item $t>0$ \item $k_0\geq k_1,\geq k_2 \geq \ldots$, \end{enumerate} such that $$ a_{k_0} t^{k_0} = a_0 +\epsilon $$ and moreover for every $j$, if we let $k = k_j$ and $r = 3^{-j} t$: $$a_k r^k > a_i r^i - \epsilon \makebox[0pt][l]{\qquad\it for all $i\in\{1,\ldots,n\}$}$$ then we have for all $j$, writing again $k = k_j$ and $r = 3^{-j} t$, \begin{eqnarray*} r^n &<& a_0\\ a_k r^k &<& a_0\\ 3^{-jn} a_0 - 2\epsilon &<& a_k r^k \end{eqnarray*} \end{lemma} \begin{proof} We have $r \le t$ and so for all $i$ we have $a_i r^i \le a_i t^i < a_{k_0} t^{k_0} + \epsilon = a_0$. Of this statement $r^n < a_0$ and $a_k r^k < a_0$ are special cases. Finally, from $a_{k_0} r^{k_0} = 3^{-jk_0} a_{k_0} t^{k_0} \ge 3^{-jn} a_{k_0} t^{k_0} = 3^{-jn} (a_0 - \epsilon) > 3^{-jn} a_0 - \epsilon$ it follows that $a_k r^k > a_{k_0} r^{k_0} - \epsilon > 3^{-jn} a_0 - 2\epsilon$. \end{proof} \begin{lemma}\label{lemma:strongmaj} For every $n\geq 2$, $\epsilon >0$ and $a_0, \ldots , a_n \geq 0$ with $a_n = 1$, $a_0> \epsilon$, if there exist \begin{enumerate} \item $t>0$ \item $k_0\geq k_1,\geq k_2 \geq \ldots$, \end{enumerate} such that for every $j$, if we let $k = k_j$ and $r = 3^{-j} t$: $$a_k r^k > a_i r^i - \epsilon \makebox[0pt][l]{\qquad\it for all $i\in\{1,\ldots,n\}$}$$ then there is a $j_0<2n$ such that, writing $k = k_{j_0}$ and $r = 3^{-j_0} t$, \begin{eqnarray*} a_k (r/3)^k &>& a_i (r/3)^i - \epsilon\makebox[0pt][l]{\qquad\it for all $i\in\{1,\ldots,n\}$}\\ a_k (3r)^k &>& a_i (3r)^i - \epsilon\makebox[0pt][l]{\qquad\it for all $i\in\{1,\ldots,n\}$} \end{eqnarray*} \end{lemma} \begin{proof} From Lemma \ref{lemma:sel} it follows that there is a $j_0<2n$ such that $k_{j_0 -1} = k_{j_0} = k_{j_0+1}$. Writing $k$ for $k_{j_0}$, it immediately follows from $k_{j_0 -1} = k_{j_0}$ and the properties of the $k$-sequence that $a_k (3r)^k > a_i (3r)^i - \epsilon$. Similarly, it follows from $k_{j_0} = k_{j_0 +1}$ and the properties of the $k$-sequence that $a_k (r/3)^k > a_i (r/3)^i - \epsilon$. \end{proof} \begin{lemma}\label{lemma:est_a} For every $\epsilon > 0$, $a_1,\ldots,a_n \ge 0$, $k\in\{1,\ldots,n\}$ and $r > 0$ such that for all $i\in\{1,\ldots,n\}$: $$a_k (r/3)^k > a_i (r/3)^i - \epsilon$$ holds: $$\sum_{i=1}^{k-1} a_i r^i < \frac{1}{2}(1 - 3^{-n}) a_k r^k + \frac{1}{2} 3^n\epsilon$$ \end{lemma} \begin{proof} From the assumption it follows that \begin{eqnarray*} a_i r^i &=& 3^i a_i (r/3)^i\\ &<& 3^i (a_k (r/3)^k + \epsilon)\\ &<& 3^{i-k} a_k r^k + 3^i\epsilon \end{eqnarray*} and therefore \begin{eqnarray*} \sum_{i=1}^{k-1} a_i r^i &<& \sum_{i=1}^{k-1} \left(3^{i-k} a_k r^k + 3^i\epsilon\right)\\ &=& \big(\sum_{i=1}^{k-1} 3^{i-k}\big) a_k r^k + \big(\sum_{i=1}^{k-1} 3^i\big)\epsilon\\ &=& {1\over 2}(1-3^{1-k}) a_k r^k + {1\over 2}(3^k-3^1)\epsilon\\ &<& {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon \end{eqnarray*} \end{proof} \begin{lemma}\label{lemma:est_b} For every $\epsilon > 0$, $a_1,\ldots,a_n \ge 0$, $k\in\{1,\ldots,n\}$ and $r > 0$ such that for all $i\in\{1,\ldots,n\}$: $$a_k (3r)^k > a_i (3r)^i - \epsilon$$ holds: $$\sum_{i=k+1}^n a_i r^i < {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon$$ \end{lemma} \begin{proof} From the assumption it follows that \begin{eqnarray*} a_i r^i &=& 3^{-i} a_i (3r)^i\\ &<& 3^{-i} (a_k (3r)^k + \epsilon)\\ &<& 3^{k-i} a_k r^k + 3^{-i}\epsilon \end{eqnarray*} and therefore \begin{eqnarray*} \sum_{i=k+1}^{n} a_i r^i &<& \sum_{i=k+1}^{n} \left(3^{k-i} a_k r^k + 3^{-i}\epsilon\right)\\ &=& \big(\sum_{i=k+1}^{n} 3^{k-i}\big) a_k r^k + \big(\sum_{i=k+1}^{n} 3^{-i}\big)\epsilon\\ &=& {3\over 2}(3^{-1}-3^{k-n-1}) a_k r^k + {3\over 2}(3^{-k-1}-3^{-n-1})\epsilon\\ &=& {1\over 2}(1 - 3^{k-n}) a_k r^k + {1\over 2}(3^{-k}-3^{-n})\epsilon\\ &<& {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon \end{eqnarray*} \end{proof} \begin{lemma}\label{lemma:est} For every $\epsilon > 0$, $a_1,\ldots,a_n \ge 0$, $k\in\{1,\ldots,n\}$ and $r > 0$ such that for all $i\in\{1,\ldots,n\}$: \begin{eqnarray*} a_k (r/3)^k &>& a_i (r/3)^i - \epsilon\\ a_k (3r)^k &>& a_i (3r)^i - \epsilon \end{eqnarray*} holds: $$\sum_{i=1\atop i\ne k}^n a_i r^i < (1 - 3^{-n}) a_k r^k + 3^n\epsilon$$ \end{lemma} \begin{proof} This follows immediately from Lemmata \ref{lemma:est_a}, \ref{lemma:est_b}. \end{proof} \begin{proof}[of the Main Lemma, \ref{lemma:est1}] Take $t$ and $k_0, k_1, \ldots$ according to the Key Lemma \ref{lemma:seq}. According to Lemma \ref{lemma:strongmaj} there is a $j_0 < 2n$ such that for $k= k_{j_0}$ and $r = 3^{-j_0} t$ the premises of Lemma \ref{lemma:est} hold. Hence inequality (\ref{ineq:est4}) of the Main Lemma holds: $$\sum_{i=1\atop i\ne k}^n a_i r^i < (1 - 3^{-n}) a_k r^k + 3^n\epsilon$$ Then inequalities (\ref{ineq:est1}), (\ref{ineq:est2}) and (\ref{ineq:est3}) are given by lemma \ref{lemma:bou} (the inequality $3^{-2n^2} a_0 < 3^{-j_0 n} a_0$ holds because $j_0 < 2n$). \end{proof} \paragraph{Proof of the Kneser Lemma, Proposition \ref{prop:kneser}} We prove the Kneser Lemma in a sequence of steps. Let $n\geq 2$. We will show that $$ q:= 1-\frac{1}{3^{2n^2 +n}}$$ is a good choice for $q$. Let $$f(x)=x^n+b_{n-1}x^{n-1}+\ldots + b_1 x+b_0$$ be a polynomial over $\CC$ and let $c\in \RR^+$ be such that $c > |b_0|$. We want to apply the Main Lemma taking $a_i := |b_i|$. However, we don't know if $|b_0|\noto 0$. Hence we will approximate $b_0$ by a $b_0'\noto 0$ such that $|b_0 - b_0'|$ is sufficiently small and $|b_0'|& |b_0'|,\\ |b_0 - b_0'| &<& \frac{c}{3^{2n^2 +n}} \end{eqnarray*} } Then we will define the real numbers $a_0, \ldots, a_{n}$ by $a_0 := |b_0'|$, $a_i := |b_i|$ for $1\leq i < n$ and $a_n := 1$. Now, for a specific choice of $z$ (with $|z|^n < a_0$) the Main Lemma will give an approximation of $|f(z)|$ in terms of $a_0$ and hence in terms of $c$. In particular, it will be shown that $|f(z)| < qc$, with $q$ as above. \begin{lemma}\label{lemma:est2} Let $a_0,\ldots,a_n\ge 0$ and $b_0,\ldots,b_n\in\CC$ with $a_i = |b_i|$ for $i=1,\ldots,n$. Furthermore, let $k\in\{1,\ldots,n\}$\weg{, $r > 0$} and $z\in\CC$ with $r = |z|$. Then: $$\big|\sum_{i=0}^n b_i z^i\big| < \left|b_0 + b_k z^k\right| + \sum_{i=1\atop i\ne k}^n a_i r^i$$ \end{lemma} \begin{proof} Repeated application of the triangle inquality for the complex numbers. \end{proof} The Main Lemma will take care that the second term on the right hand side of the conclusion of Lemma \ref{lemma:est2} is sufficiently small. To assure that the first term is also small enough, a specific value of $z$ can be chosen in such a way that $b_0$ and $b_k z^k$ cancel eachother out. \begin{lemma}\label{lemma:est3} Given $a_0,\,a_k > 0$, $b_0,\,b_0',\,b_k\in\CC$, $k\in\{1,\ldots,n\}$, $r > 0$ and $\eta > 0$ such that: \begin{eqnarray*} |b_0'| &=& a_0 \\ |b_k| &=& a_k \\ |b_0 - b_0'| &<& \eta\\ a_k r^k &<& a_0 \end{eqnarray*} then there exists a $z\in\CC$ such that $|z| = r$ and: $$\left|b_0 + b_k z^k\right| < a_0 - a_k r^k + \eta$$ \end{lemma} \begin{proof} Take $$z = r\,\root k\of{-{a_k\over a_0}{b_0'\over b_k}}$$ Then we have: $$\Big|{-{a_k\over a_0}{b_0'\over b_k}}\Big| = {a_k\left|b_0'\right|\over a_0\left|b_k\right|} = {a_k a_0\over a_0 a_k} = 1$$ so $$\Bigg|\root k\of{-{a_k\over a_0}{b_0'\over b_k}}\Bigg| = 1$$ and so $|z| = r$. Because $a_k r^k < a_0$ we get $\big|a_0 - a_k r^k\big| = a_0 - a_k r^k$ and therefore \begin{eqnarray*} |b_0' + b_k z^k| &=& \Big|b_0' + b_k r^k \big(-{a_k\over a_0}{b_0'\over b_k}\big)\Big|\\ &=& \big|{b_0'\over a_0}(a_0 - a_k r^k)\big|\\ &=& {|b_0'|\over a_0}|a_0 - a_k r^k|\\ &=& a_0 - a_k r^k \end{eqnarray*} From this it follows that $\left|b_0 + b_k z^k\right| \le \left|b_0 + b_k z^k\right| + |b_0 - b_0'| < a_0 - a_k r^k + \eta$. \end{proof} \begin{lemma}\label{lemma:nzc} For $\eta > 0$ and $z\in\CC$ there is a $z'\in\CC$ with $z' \mathrel{\#} 0$ and $|z' - z| < \eta$. \end{lemma} \begin{proof} Because $z + \eta/2 \mathrel{\#} z - \eta/2$, either $z + \eta/2 \mathrel{\#} 0$ or $z - \eta/2 \mathrel{\#} 0$. For both choices $|z' - z| = \eta/2 < \eta$. \end{proof} \weg{ \begin{lemma}\label{lemma:eps0} Given a finite list of inequalities \begin{eqnarray*} p_0\epsilon &<& q_0\\ p_1\epsilon &<& q_1\\ p_2\epsilon &<& q_2\\ \ldots \end{eqnarray*} with $p_i,q_i > 0$, there is an $\epsilon > 0$ that satisfies it. \end{lemma} \begin{proof} Induction with respect to the length of the list. \end{proof} } \begin{lemma}\label{lemma:eps} Let be given $b_0\in\CC$ and $c\in\RR$ with $|b_0| < c$. Then there are $b_0'\in\CC$, $a_0$ and $\eta > 0$ such that: \begin{eqnarray} |b_0 - b_0'| &<& \eta\\ |b_0'| &=& a_0\\ a_0 &>& 0\\ a_0 + 3\eta &<& c \label{ineq:eta} \end{eqnarray} and an $\epsilon > 0$ such that: \begin{eqnarray} 2(3^n + 1)\epsilon &<& \eta \label{ineq:epsilon}\\ 2\epsilon &<& 3^{-2n^2} a_0\\ \epsilon &<& a_0 \end{eqnarray} \end{lemma} \begin{proof} Take $$\eta = {1\over 4}(c - |b_0|)$$ so $|b_0| = c - 4\eta$. Then choose an arbitrary $b_0' \mathrel{\#} 0$ with $|b_0' - b_0| < \eta$ and take $a_0 = |b_0'|$. To see that (\ref{ineq:eta}) is satisfied, calculate: $$a_0 = |b_0'| \le |b_0' - b_0| + |b_0| < \eta + c - 4\eta = c - 3\eta$$ % The existence of a suitable $\epsilon$ then follows easily: take $\epsilon>0$ smaller then $\minn(\frac{\eta}{2(3^{n}+1)}, \frac{a_0}{2\;3^{2n^2}})$. \end{proof} \begin{lemma}\label{lemma:eps1} For: $$q = 1 - 3^{-2n^2-n}$$ we have that $q > {1\over 2}$ and because of that inequalities (\ref{ineq:eta}) and (\ref{ineq:epsilon}) imply: $$q a_0 + 3^n \epsilon + \epsilon + \eta < qc$$ \end{lemma} \begin{proof} We get $$a_0 + 2\cdot 3^n\epsilon + 2\epsilon + 2\eta = a_0 + 2(3^n + 1)\epsilon + 2\eta < a_0 + \eta + 2\eta < c$$ Using that $1 < 2q$, this gives $$q a_0 + 3^n\epsilon + \epsilon + \eta < q a_0 + 2q 3^n\epsilon + 2q \epsilon + 2q \eta\ = q (a_0 + 2\cdot 3^n\epsilon + 2\epsilon + 2\eta) < qc $$ \end{proof} \weg{ \begin{lemma}\label{lemma:key} Let be given $b_0,\ldots,b_n\in\CC$ with $b_n = 1$ and $c\in\RR$ with $|b_0| < c$. Let $q$ be as in the previous lemma. Then there is a $z\in\CC$ with $$|z| < c^{1/n}$$ and: $$\big|\sum_{i=0}^n b_i z^i\big| < qc$$ \end{lemma} } \begin{proof}[of the Kneser Lemma, Proposition \ref{prop:kneser}] Take $b_0'$, $a_0$, $\eta$ and $\epsilon$ as in lemma \ref{lemma:eps}. Take $a_i = |b_i|$ for $i\in\{1,\ldots,n\}$. Take $r$ and $k$ as in lemma \ref{lemma:est1}. Finally take $z$ as in lemma \ref{lemma:est3}. Then plugging all conditions and results of lemmas \ref{lemma:est1}, \ref{lemma:est2}, \ref{lemma:est3}, \ref{lemma:eps} and \ref{lemma:eps1} together we get $$r^n < a_0 < c - 3\eta < c$$ so $$|z| = r < c^{1/n}$$ and \begin{eqnarray*} \big|\sum_{i=0}^n b_i z^i\big| &<& \left|b_0 + b_k z^k\right| + \sum_{i=1\atop i\ne k}^n a_i r^i\\ &<& \left(a_0 - a_k r^k + \eta\right) + \left((1 - 3^{-n}) a_k r^k + 3^n\epsilon\right)\\ &=& a_0 - 3^{-n} a_k r^k + 3^n\epsilon + \eta\\ &<& a_0 - 3^{-n} (3^{-2n^2} a_0 - 2\epsilon) + 3^n\epsilon + \eta\\ &=& (1 - 3^{-2n^2-n}) a_0 + 3^n\epsilon + 3^{-n} 2\epsilon +\eta\\ &<& (1 - 3^{-2n^2-n}) a_0 + 3^n\epsilon + \epsilon + \eta\\ &=& q a_0 + 3^n\epsilon + \epsilon + \eta\\ &<& q c \end{eqnarray*} \end{proof} \weg{ !! \begin{proof} to this $(a_i)_{i\in\{1,\ldots,n \} }$, taking $$\epsilon := \minn(\frac{c}{n 3^{2n^2 +2n+1}}, \frac{a_0}{3^{2n^2 +1}}).$$ We obtain a $r\in\RR^+$ and a $k\in \{1, \ldots, n\}$, such that \begin{eqnarray*} r&\leq & a_0^{1/n}\\ \frac{1}{3^{2n^2}} a_0 - \epsilon &\leq& a_k r^k \leq a_0,\\ \Sigma_{1\leq i < k} a_i r^i &\leq&\frac{ 1}{2 }(1-3^{1-k}) a_k r^k +n 3^n\epsilon \\ \Sigma_{k < i \leq n} a_i r^i &\leq&\frac{ 1}{2 }(1-3^{k-n}) a_k r^k + n3^{-1}\epsilon. \end{eqnarray*} Note that $\frac{1}{3^{2n^2}} a_0 - \epsilon \geq \frac{1}{3^{2n^2}} a_0 - \frac{a_0}{3^{2n^2 +1}}>0$, and so $a_k > 0$. We determine $z\in\CC$ such that \begin{eqnarray*} |z| &=& r,\\ (b_0')^{-1} b_k z^k &<& 0. \end{eqnarray*} That is: we want the complex number $(b_0')^{-1} b_k z^k$ to be on the negative $x$-axis, which can be achieved by taking $z:=r(\frac{a_k}{a_0})^{1/k}(\frac{-b_0'}{b_k})^{1/k}$. As $r^n \leq a_0 = |b_0'| < c$, we conclude that $|z| < c^{1/n}$. We also have the following. \begin{eqnarray*} |f(z)| &\leq& |b_0 + b_k z^k| + \Sigma_{1\leq i\leq n, i\neq k} a_i |z^i|\\ &\leq& |b_0 -b_0'| + |b_0'+ b_k z^k| + \Sigma_{1\leq i\leq n, i\neq k} a_i |z^i|\\ &\stackrel{(i)}{<}&\frac{c}{3^{2n^2 +n}} + a_0 - a_k |z^k| + \Sigma_{1\leq i\leq n, i\neq k} a_i r^i\\ &\leq& a_0 - a_k t^k +\frac{ 1}{2 }(1-3^{1-k}) a_k r^k + \frac{ 1}{2 }(1-3^{k-n}) a_k r^k + n 3^n\epsilon + n3^{-1}\epsilon + \frac{c}{3^{2n^2 +n}} \\ &\stackrel{(ii)}{\leq}& a_0 -3^{1-n}a_k r^k +n (3^{n}+3^{-1})\epsilon + \frac{c}{3^{2n^2 +n}}\\ &\leq& a_0 -3^{1-n}(\frac{1}{3^{2n^2}} a_0 - \epsilon) +n (3^{n}+3^{-1})\epsilon+ \frac{c}{3^{2n^2 +n}}\\ &=& a_0(1-\frac{1}{3^{2n^2 +n -1}})+3^{1-n}\epsilon + n (3^{n}+3^{-1})\epsilon + \frac{c}{3^{2n^2 +n}}\\ &<& c(1-\frac{1}{3^{2n^2 +n -1}})+ n 3^{n+1}\epsilon + \frac{c}{3^{2n^2 +n}}\\ &=& c(1-\frac{1}{3^{2n^2 +n -1}})+ n 3^{n+1}\frac{c}{n 3^{2n^2 +2n +1}} + \frac{c}{3^{2n^2 +n}}\\ &=& c(1-\frac{1}{3^{2n^2 +n -1}})+ \frac{2c}{3^{2n^2 +n}}\\ &=& c(1-\frac{1}{3^{2n^2 +n}}) \end{eqnarray*} Inequality (i) is by $|b_0'+ b_k z^k| = |b_0'|\cdot |1 +\frac{b_k z^k}{b_0'}| \leq |b_0'|(1 +|\frac{b_k z^k}{b_0'}|) = |b_0'|(1 -\frac{a_k r^k}{|b_0'|}) = |b_0'|- a_k r^k$. Inequality (ii) is by $3^{1-k} + 3^{k-n} \geq 2\cdot 3^{1-n}$, which follows from $3^{n-k} + 3^{k-1} \geq 2$. So our choice for $q := (1-\frac{1}{3^{2n^2 +n}})$ works: $|f(z)| < qc$. \qed \end{proof} } \weg{ \begin{sublemma}\label{slem} Given $n\in\NN$, $b_0\in\CC$ and $c\in\RR$ with $c> |b_0|$, we can choose $\eta >0$ and $b_0' \in\CC$ such that \begin{eqnarray*} \eta &<& \frac{c}{3^{-n}\cdot 4 +2},\\ \eta &<& |b_0'|,\\ 0&<& |b_0'| < c,\\ |b_0 - b_0'| &<& 4\eta. \end{eqnarray*} \end{sublemma} \begin{proof} Define $\eta : = \frac{c}{3^n\cdot 4 + 3}$. Then $|b_0| > c - 4\eta$ or $|b_0| < c_3\eta$. In the first case define $b_0' := b_0 -(\eta, i\eta)$. In the second case define $b_0' := b_0 +(\eta, i\eta)$. \qed \end{proof} } \paragraph{Fundamental Theorem for regular polynomials} \begin{proposition} Let $f(x)=x^n+a_{n-1}x^{n-1}+\ldots + a_1x+a_0$, with $a_i\in\CC$. Then for some $z\in\CC$ one has $f(z)=0$. \end{proposition} \begin{proof} Let $c\in\RR^+$ with $c> |a_0|$. We will construct a Cauchy sequence $z_i\in\CC$ such that for all $m$ \benum \item $|f(z_m)|< q^m c$ \item $|z_{m+1}-z_m|\leq (q^m c)^{1/n}$ \eenum for some $q\in(0,1)$. Then $z=\lim_{i\arr\infty} z_i$ exists and by continuity of $f$ one has $$|f(z)|=\lim_{i\arr\infty} |f(z_i)|\leq \lim_{i\arr\infty} q^i c=0,$$ so $f(z)=0$. Now, if 1 and 2 are satisfied, then indeed the $z_i$ form a Cauchy seqence: \beqn |z_{m+k}-z_m|&\leq&|z_{m+k}-z_{m+k-1}|+\ldots+|z_{m+1}-z_m|\\ &\leq&(q^{\frac{m+k-1}{n}}+q^{\frac{m+k-2}{n}}+\ldots+q^{\frac{m}{n}})c^{1/n}\\ &=&\frac{q^\frac{m}{n}-q^{\frac{m+k}{n}}}{1-q^{1/n}} c^{1/n}\\ &=&q^{\frac{m}{n}}\frac{1-q^\frac{k}{n}}{1-q^{1/n}}c^{1/n}\\ &\leq&q^{\frac{m}{n}}\frac{c^{1/n}}{1-q^{1/n}}. \eeqn By choosing $m$ sufficiently large ($n$ is fixed), this last expression can be made arbitrarily small. The construction of $z_i$ is as follows. Take $z_0=0$. Then indeed $|f(z_0)|=|f(0)| < q^0 c$. Now suppose $z_m$ is defined satisfying 1. Apply the Kneser Lemma to $f_{z_m}$ where $$f_{z_m}(x)=f(x+z_m)$$ and taking $q^m c$ for $c$. (Note that $f_{z_m}$ has the same degree as $f$.) We obtain a $z$ such that $$|z| < (q^m c)^{1/n} \wedge |f_{z_m}(z)| < q^{m+1} c.$$ Now take $z_{m+1}=z+z_m$. Then we have that 1 is valid: $|f(z_{m+1})|=|f(z+z_m)| = |f_{z_m}(z)|< q^{m+1}c.$ Moreover, we also have 2: $|z_{m+1}-z_m|=|z| < (q^{m} c)^{1/n}$. \qed \end{proof} \begin{corollary} \begin{enumerate} \item Every regular polynomial $f(x)=a_nx^n+a_{n-1}x^{n-1}+\ldots + a_1x+a_0$ over $\CC$ has a root. \item Moreover, such $f$ can be factorized as follows $$\overline{f}(x)=a_n(x-\alpha_1)\ldots(x-\alpha_n).$$ \end{enumerate} \end{corollary} \begin{proof}\begin{enumerate} \item Divide $f$ by $a_n$ to obtain a polynomial $g$ with leading coefficient 1, satisfying $a_ng(x)=f(x)$. Then any root of $g$ is a root of $f$. \item If $\alpha_1$ is a root of $f$, then $$f(x)=(x-\alpha_1)f_{n-1}(x),$$ by the Remainder Theorem (\ref{corremainder}) with $f_{n-1}$ being equal to $a_nx^{n-1}+\ldots$, hence also regular. By (i) $f_{n-1}$ has a root $\alpha_2$ and hence $$f_{n-1}(x)=(x-\alpha_2)f_{n-2}(x).$$ Continuing this way one obtains $$f(x)=(x-\alpha_1)\ldots(x-\alpha_n)a_n.\qed$$ \end{enumerate} \end{proof} \weg{\begin{lemma}\label{apartness.prop} Let $a,b\in\CC$. Then \begin{enumerate}\item $a+b\noto 0\implies a\noto 0\vee b\noto 0.$ \item $ab\noto 0\implies a\noto 0 \wedge b\noto 0.$ \end{enumerate}\end{lemma} } %\begin{lemma}\label{1.6} %Let $f(x)=a_nx^n+a_{n-1}x^{n-1}+\ldots + a_1x+a_0$, with $a_i\in\CC$. %Suppose that $a_k\noto 0$, for some $0 %Lemma 1.6 in proof of Fundamental Theorem \weg{ \begin{lemma}\label{1.6} Let $f(x) = a_nx^n+a_{n-1}x^{n-1}+\ldots a_1x+a_0,$ with $a_i \in\CC.$ Suppose that $a_k\unneq 0,$ for some $00.$ By the induction hypothesis there exists an infinite subset $A_{l-1}\subset\NN$ such that $$a\in A_{l-1}\Rightarrow f(a)\unneq 0,\;f'(a)\unneq 0,\ldots,f^{(l-1)}(a)\unneq 0.$$ We only need to show the existence of an infinite subset $A_l\subset A_{l-1}$ such that $$a\in A_l\Rightarrow f^{(l)}(a)\unneq 0.$$ The coefficient of degree $k-l$ in $f^{(l)}$ is $k(k-1)\ldots(k-l+1)a_k\unneq 0.$ Hence if we choose $u_0,\ldots,u_{n-l}\in A_{l-1},\;\; u_i\neq u_j \mbox{ if } i\neq j,$ then it follows similarly to the {\em Case }$l=0$ that $f^{(l)}(u_i)\unneq 0$ for some $i,\;\; 0\leq i \leq n-l.$ This shows the existence of $A_l.\hfill\qed$ \end{proof} } \weg{ \begin{lemma}[Vandermonde] Let for $n>0$ $$D_n = \left| \begin{array}{llll} 1 &1 &\ldots &1 \\ u_0 &u_1 &\ldots &u_n \\ &&& \\ &&& \\ u_0^n &u_1^n &\ldots &u_n^n \end{array} \right|.$$ Then $\quad D_n = \prod\limits_{0\leq j < i\leq n}(u_i - u_j).$ \end{lemma} \begin{proof} By induction on $n.$\\[1ex] {\em Case }$n=1.$\\ $$D_1 = \left|\begin{array}{ll} 1 &1 \\ u_0 &u_1 \end{array}\right| = u_1 - u_0.$$ {\em Case }$n>1.$\\ By subtracting $u_n$ times row $n-(m+1)$ from row $n-m$, successively for $m = 0,1,\ldots ,n-2$, we get $$D_n = \left| \begin{array}{lllll} 1 &1 &\ldots &1 &1\\ u_0 - u_n &u_1 - u_n &\ldots &u_{n-1} - u_n &0\\ &&& \\ &&& \\ u_0^{n-2}(u_0-u_n) &u_1^{n-2}(u_1-u_n) &\ldots &u_{n-1}^{n-2}(u_{n-1}-u_n) &0\\ u_0^{n-1}(u_0-u_n) &u_1^{n-1}(u_1-u_n) &\ldots &u_{n-1}^{n-2}(u_{n-1}-u_n) &0 \end{array} \right|.$$ $ = (-1)^n(u_0-u_n)(u_1-u_n)\ldots(u_{n-1}-u_n)D_{n-1} =$ (by induction hypothesis)\\ $(u_n-u_0)\ldots(u_n-u_{n-1}) \prod\limits_{0\leq j < i\leq n-1}(u_i - u_j) = \prod\limits_{0\leq j < i\leq n}(u_i - u_j).\hfill\qed$ \end{proof} \begin{lemma}\label{1.6} Let $f(x) = a_nx^n+a_{n-1}x^{n-1}+\ldots a_1x+a_0,$ with $a_i \in\CC.$ Suppose that $a_k\unneq 0,$ for some $0From $a_k\unneq 0$ follows $f(u_i)\unneq 0$ for some $i.$ This shows the existence of the set $A_0.$\\[1ex] {\em Case }$l>0.$ By the induction hypothesis there exists an infinite subset $A_{l-1}\subset\NN$ such that $$a\in A_{l-1}\Rightarrow f(a)\unneq 0,\;f'(a)\unneq 0,\ldots,f^{(l-1)}(a)\unneq 0.$$ We only need to show the existence of an infinite subset $A_l\subset A_{l-1}$ such that $$a\in A_l\Rightarrow f^{(l)}(a)\unneq 0.$$ The coefficient of degree $k-l$ in $f^{(l)}$ is $k(k-1)\ldots(k-l+1)a_k\unneq 0.$ Hence if we choose $u_0,\ldots,u_{n-l}\in A_{l-1},\;\; u_i\neq u_j \mbox{ if } i\neq j,$ then it follows similarly to the {\em Case }$l=0$ that $f^{(l)}(u_i)\unneq 0$ for some $i,\;\; 0\leq i \leq n-l.$ This shows the existence of $A_l.\hfill\qed$ \end{proof} } %%< corn-8.20.0/doc/skel/IVT.tex000066400000000000000000000113311473720167500154440ustar00rootroot00000000000000\section{Real valued functions} In the proof of the Fundamental Theorem of Algebra, we use a strong version of the Intermediate Value Theorem (with a strong conclusion and a strong premise). This is Theorem 6.1.5 of \cite{TvD881}. \begin{definition} Intervals (closed and open) in $\RR$. \end{definition} \begin{definition} Continuity of functions $f:\RR^n\rightarrow \RR$ ($n\in\NN$). \end{definition} \begin{lemma} The identity and a constant function are continuous. Continuity is preserved under $+$, $*$, composition and maximum (of finitely many functions). \end{lemma} \begin{corollary} If $f(X)$ is a polynomial over $\RR$, then the associated function $f$ is continuous. \end{corollary} \begin{theorem}[Intermediate Value Theorem]\label{thmIVT} Let $a,b\in \RR$, $a 0.$$ then in each interval $[c,d] \subset [a,b]$ with $c 0.$$ \end{lemma} \begin{proof} ?? Or prove that the premises of the Intermediate Value Theorem \ref{thmIVT} hold for polynomials (and skip \ref{lemTvD2.6} and this Lemma). \end{proof} } \begin{corollary}[Intermediate Value Theorem for regular polynomials]\label{corimvpol} Let $f$ be a regular polynomial over $\RR$ and let $a,b\in \RR$ such that $a0\mbox{ then }\exists z\in[a,b](f(z)=0).$$ \end{corollary} \begin{proof} The premise in Theorem \ref{thmIVT} is satisfied: if $n$ is the degree of $f$, we choose $n+1$ distinct points in the interval $[x,y]$; due to Lemma \ref{lempolnpts} the value of $f$ is apart from $0$ for one of these points. \qed \end{proof} \begin{proposition}[Roots of polynomials over $\RR$ of odd degree] \label{proppolRodd} Every polynomial of odd degree over $\RR$ has a root. \end{proposition} \begin{proof} Let $f$ be a polynomial of odd degree. We only have to show that for $x$ sufficiently small, $f(x) <0$ and for $x$ sufficiently large, $f(x) >0$. Then Corollary \ref{corimvpol} does the job. \qed. \end{proof} \begin{lemma}[Intermediate Value Theorem for stricly monotonic functions]\label{lemivtstrmon} If $f:\RR\arr\RR$ is strictly monotonic and continuous on some interval $I$, and $a,b\in I$ with $a0$, then there is a $c\in (a,b)$ with $f(c)=0$. \end{lemma} \begin{proof} We show that the premise of Theorem \ref{thmIVT} is satisfied. Let $x, y \in [a,b]$ with $x0$. \qed \end{proof} \begin{definition} Let $n\in\NN$, $n\geq 1$, $a_1, \ldots , a_n \in \{ x\in \RR| x\geq 0\}$ with $a_n = 1$. Define $m : [0, \infty) \rightarrow [0, \infty)$ as follows. $$ m(s) := \maxx \{ a_i s^i \, |\, 1\leq i \leq n \}.$$ \end{definition} \begin{lemma}\label{lemstrmonm} The function $m$ is strictly monotonic on $(0,\infty)$. \end{lemma} \begin{proof} We prove that for every $x,y\in(0,\infty)$, if $x1$ and hence $m(y)>m(x)$.) Let $x,y\in(0,\infty)$, $x0$ $$D_n = \left| \begin{array}{llll} 1 &1 &\ldots &1 \\ u_0 &u_1 &\ldots &u_n \\ &&& \\ &&& \\ u_0^n &u_1^n &\ldots &u_n^n \end{array} \right|.$$ Then $\quad D_n = \prod\limits_{0\leq j < i\leq n}(u_i - u_j).$ \end{lemma} \begin{proof} By induction on $n.$\\[1ex] {\em Case }$n=1.$\\ $$D_1 = \left|\begin{array}{ll} 1 &1 \\ u_0 &u_1 \end{array}\right| = u_1 - u_0.$$ {\em Case }$n>1.$\\ By subtracting $u_n$ times row $n-(m+1)$ from row $n-m$, successively for $m = 0,1,\ldots ,n-2$, we get $$D_n = \left| \begin{array}{lllll} 1 &1 &\ldots &1 &1\\ u_0 - u_n &u_1 - u_n &\ldots &u_{n-1} - u_n &0\\ &&& \\ &&& \\ u_0^{n-2}(u_0-u_n) &u_1^{n-2}(u_1-u_n) &\ldots &u_{n-1}^{n-2}(u_{n-1}-u_n) &0\\ u_0^{n-1}(u_0-u_n) &u_1^{n-1}(u_1-u_n) &\ldots &u_{n-1}^{n-2}(u_{n-1}-u_n) &0 \end{array} \right|.$$ $ = (-1)^n(u_0-u_n)(u_1-u_n)\ldots(u_{n-1}-u_n)D_{n-1} =$ (by induction hypothesis)\\ $(u_n-u_0)\ldots(u_n-u_{n-1}) \prod\limits_{0\leq j < i\leq n-1}(u_i - u_j) = \prod\limits_{0\leq j < i\leq n}(u_i - u_j).\hfill\qed$ \end{proof} corn-8.20.0/doc/skel/Makefile000066400000000000000000000010421473720167500157160ustar00rootroot00000000000000TEXFILES=\ CSetoids.tex \ CGroups.tex \ CRings.tex \ CIntDomains.tex \ CFields.tex \ CVectorSpace.tex \ LinearAlgebra.tex \ CReals.tex \ CPolynomials.tex \ IVT.tex \ CComplex.tex \ NRootCC.tex \ FTAreg.tex \ FTA.tex \ header.tex bibliography.tex skel.tex pdf: skel.pdf ps: skel.ps dvi: skel.dvi skel.dvi: ${TEXFILES} skel.aux latex skel.tex skel.aux: latex skel.tex skel.ps: skel.dvi dvips -f < skel.dvi > skel.ps skel.pdf: ${TEXFILES} skel.aux pdflatex skel.tex clean: rm -f skel.aux skel.log skel.dvi skel.ps skel.pdf corn-8.20.0/doc/skel/NRootCC.tex000066400000000000000000000076301473720167500162600ustar00rootroot00000000000000\subsection{Roots of complex numbers} We show that for $c \in\CC$, $c \noto 0$ and $n\in\NN^+$, $\sqrt[n]{c}$ exists in $\CC$. To prove this we rely just on the following two facts: 1. Every positive number in $\RR$ has a square root, 2. Every polynomial of odd degree over $\RR$ has a root in $\RR$. The proof avoids the use of polar coordinates, exponentials and arctan. We have learned this proof from \cite{Litt41}; thanks to R.\ Kortram who made us aware of this proof. Let in the following $\CC$ be a structure for the complex numbers. \begin{lemma} For each $c = a+ib \in\CC$ with $c \noto 0$, there exists a solution to $z^2 = c$. In particular, %for the special case that $b \noto 0$, a solution is given by: \begin{eqnarray*} z = \sqrt{\frac{\sqrt{a^2 + b^2} +a}{2}} + i \sqrt{\frac{\sqrt{a^2 + b^2} -a}{2}}&&\mbox{for}\quad b \geq 0\\ z = \sqrt{\frac{\sqrt{a^2 + b^2} +a}{2}} - i \sqrt{\frac{\sqrt{a^2 + b^2} -a}{2}}&&\mbox{for}\quad b \leq 0 \end{eqnarray*} \end{lemma} \begin{proof} The second statement, including the fact that all square roots that occur take positive numbers, is a straightforward computation (using that $\sqrt{b^2} = b$ when $b\geq 0$, and that $\sqrt{b^2} = -b$ when $b\leq 0$.) For the first statement, because $c \noto 0$, we have either $a \noto 0$ or $b \noto 0$. The second case we explicitly solved, and the first case reduces to the second by multiplying $c$ by $i$. \qed \end{proof} \begin{lemma}\label{lemCrootequiv} Let $z, c\in\CC$, $c\noto 0$, $n\in\NN$. Then $$z^n = c \vee z^n = -c,$$ if the conjunction of the following two equations holds. \begin{eqnarray} (|z|^2)^n &=& |c|^2,\\ z^n \bar{c} - \bar{z}^n c &=&0. \end{eqnarray} (If $n>0$, the first determines a circle in the complex plane, while the second determines a number of lines through the origin.) \end{lemma} \begin{proof} Given these two equations, $z^n \bar{c} = \bar{z}^n c$, and so $$(z^n)^2 \bar{c} = z^n z^n \bar{c} = z^n \bar{z}^n c = (|z|^2)^n c = |c|^2 c = c^2 \bar{c}.$$ Because $c\noto 0$ we can divide by $\bar{c}$ and hence $(z^n)^2 = c^2$. Again because $c\noto 0$ from this it follows that $z^n = c \vee z^n = -c$. \qed \end{proof} \begin{lemma}\label{lemCrootoddpoly} For $a, b\in\RR$, $b\noto 0$, $n\in\NN$, $$\frac{(r+i)^n(a-ib)-(r-i)^n(a+ib)}{2i}$$ is a polynomial in $r$ of degree $n$ with real coefficients. \end{lemma} \begin{proof} This is equal to $\mbox{\it Im }(r+i)^n(a-ib)$, so it will be real. Now $(r+i)^n(a-ib)$ clearly has degree $n$, and because its head coefficient is $a-ib$ and $b\noto 0$, its imaginary part will have head coefficient $-b$, and so it also will have degree $n$. \qed \end{proof} \begin{proposition} For $c=a+ib\in\CC$, $c\noto 0$, and $n\in \NN$, $n$ odd, there exists a $z\in\CC$ such that $z^n = c$. \end{proposition} \begin{proof} We first treat the case that $b\noto 0$. Then by Lemma \ref{lemCrootoddpoly}, $f(r)\equiv\big((r+i)^n(a-ib)-(r-i)^n(a+ib)\big)/2i$ is a polynomial of odd degree with real coefficients. Hence it has a root in $\RR$. We now solve the following two equations in $x$ and $y$. \begin{eqnarray*} r &=& x/y,\\ (x^2+y^2)^n &=& a^2+b^2. \end{eqnarray*} From the fact that $r$ is a root of $f$, by multiplying with $2iy^n$ we find that $(x+iy)^n(a-ib)-(x-iy)^n(a+ib)=0$, and from Lemma \ref{lemCrootequiv} then $(x+iy)^n = a + ib \vee(x+iy)^n = -a -ib$. In the first case $z=x+iy$, and in the second case $z=-x-iy$ will be a solution to $z^n=c$. The case that $a\noto 0$ reduces to the other one by multiplying $c$ by $i$. \qed \end{proof} \begin{theorem} For $c\in\CC$, $c\noto 0$ and $n\in\NN^+$ there exists an $z\in\CC$ such that $z^n = c$. \end{theorem} \begin{proof} This combines the ability to take square and odd roots. Write $n$ as the product of a power of 2 and an odd factor and iterate taking roots. (Note that this uses strong extensionality of taking powers: we need that the result of taking a root is again $\noto 0$.) \qed \end{proof} corn-8.20.0/doc/skel/algorithm.tex000066400000000000000000000044301473720167500167720ustar00rootroot00000000000000\documentclass{article} \usepackage{amssymb} \def\NN{\mathbb{N}} \def\RR{\mathbb{R}} \def\CC{\mathbb{C}} \begin{document} \title{Kneser} \author{} \date{} \maketitle \section{Classical} \subsection{Input} $$n\ge 2$$ $$b_0,\ldots,b_n\in\CC$$ $$b_0 \ne 0$$ $$b_n = 1$$ \subsection{Output} $$z\in\CC$$ \subsection{Algorithm} \begin{enumerate} \item define $a_i = |b_i|$ for $i\in\{0,\ldots,n\}$ \item\label{step:amb1} find $t$ and $k_0$ with $a_{k_0} t^{k_0} = a_0$ and $a_i t^i \le a_0$ for all $i\in\{1,\ldots,n\}$ \item\label{step:amb2} for each $j$ take $r_j = t/3^j$ and find $k_j$ such that $a_i {r_j}^i \le a_{k_j} {r_j}^{k_j}$ for all $i\in\{1,\ldots,n\}$ \item take the first $j$ for which $k_{j-1} = k_j = k_{j+1}$ \item define $k = k_j$ and $r = t/3^j$ \item\label{step:und} define $z$ such that $|z| = r$ and $b_k z^k$ points against $b_0$ in the complex plane \end{enumerate} \subsection{Remark} Steps \ref{step:amb1} and \ref{step:amb2} are ambiguous, because there might be more than one $k_j$ that satisfies the conditions. To disambiguate this algorithm some choices have to be made there. \section{Constructive} \subsection{Input} $$n\ge 2$$ $$b_0,\ldots,b_n\in\CC$$ $$b_n = 1$$ $$c > |b_0|$$ $$q = 1 - 3^{-2n^2-n}$$ The number $c$ should be thought of as `the norm of the value of the polynomial in $0$' (it is a real number arbitrarily close to that.) \subsection{Output} $$z\in\CC$$ such that: $$|z| < c^{1/n}$$ (so if the value of the polynomial in 0 gets small, $z$ gets small) and: $$\sum_{i=0}^n b_i z^i < qc$$ (so the value of the polynomial in $z$ is sufficiently smaller than the value in $0$.) \subsection{Algorithm} \begin{enumerate} \item choose some sufficiently small $\eta > 0$ \item choose some $b_0' \mathrel{\#} 0$ sufficiently close to $b_0$ \item choose some sufficiently small $\epsilon > 0$ \item define $a_0 = |b_0'|$ and $a_i = |b_i|$ for $i\in\{1,\ldots,n\}$ (this gives a real polynomial that `estimates' the complex polynomial) \item find $t$ with some properties \item find $j$ and $k$ with some more properties (basically: $j$ is not too big and $a_k r^k$ strongly dominates all other terms in the polynomial) \item define $r = t/3^j$ \item define $z$ such that $|z| = r$ and $b_k z^k$ points against $b_0'$ in the complex plane. \end{enumerate} \end{document} corn-8.20.0/doc/skel/bibliography.tex000066400000000000000000000016531473720167500174630ustar00rootroot00000000000000\begin{thebibliography}{10} \bibitem{Heyt56} Heyting, {\em Intuitionism, an introduction}, North-Holland, 1956, 133 pp. \bibitem{Litt41} J.E.\ Littlewood, Every polynomial has a root, Journal of the London Math.\ Soc.\ 16 (1941), pp.\ 95 -- 98. \bibitem{Ruit82} Ruitenburg, {\em Intuitionistic Algebra, Theory and Sheaf Models}, Ph.D.\ Thesis, Utrecht University, June 1982, 143 pp. \bibitem{MRR88} Mines, Richman and Ruitenburg, {\em A Course in Constructive Algebra}, Universitext, Springer-Verlag, 344 pp. \bibitem{TvD881} Troelstra and van Dalen, {\em Constructivism in Mathematics, an Introduction, Vol 1}, volume 121 in Studies in Logica and The Foundations of Mathematics, North-Holland, 1988, 342 pp. \bibitem{TvD882} Troelstra and van Dalen, {\em Constructivism in Mathematics, an Introduction, Vol 2}, volume 123 in Studies in Logica and The Foundations of Mathematics, North-Holland, 1988, 879 pp. \end{thebibliography} corn-8.20.0/doc/skel/header.tex000066400000000000000000000030431473720167500162330ustar00rootroot00000000000000\def\qed{~\rule{2mm}{2mm}} \newcommand{\maxx}{\mbox{max}} \newcommand{\minn}{\mbox{min}} \newcommand{\weg}[1]{} \def\unneq{{\;=\!\!\!\!\!\!/\!\!/\;}} \def\phi{\varphi} \def\CC{\mathbb{C}} \def\RR{\mathbb{R}} \def\QQ{\mathbb{Q}} \def\NN{\mathbb{N}} \def\ZZ{\mathbb{Z}} \def\noto{\mathrel{\#}} \def\arr{{\rightarrow}} \def\implies{\rightarrow} \def\eqqe{\leftrightarrow} \def\deg{{\rm deg}} \def\eps{\epsilon} \newtheorem{definition}{Definition}[section] \newtheorem{lemma}[definition]{Lemma} \newtheorem{conjecture}[definition]{Conjecture} \newtheorem{proposition}[definition]{Proposition} \newtheorem{theorem}[definition]{Theorem} \newtheorem{corollary}[definition]{Corollary} \newtheorem{remark}[definition]{Remark} \newtheorem{fact}[definition]{Fact} \newtheorem{example}[definition]{Example} \newtheorem{examples}[definition]{Examples} \newtheorem{notation}[definition]{Notation} \newtheorem{claim}[definition]{Claim} \newenvironment{proof}{\begin{trivlist} \item[\hskip \labelsep% {\bf Proof}]}{\end{trivlist}} \newcommand{\ac}{^{\prime}} \newcommand{\benum}{\begin{enumerate}} \newcommand{\eenum}{\end{enumerate}} \newcommand{\beqn}{\begin{eqnarray*}} \newcommand{\eeqn}{\end{eqnarray*}} \newcommand{\mkbox}[1]{\mbox{$#1$}} \newcommand{\struct}[1]{\mkbox{\langle #1 \rangle}} \newcommand{\Eq}[2]{\mkbox{#1 = #2}} \newcommand{\Ap}[2]{\mkbox{#1 \noto #2}} \newcommand{\Not}[1]{\mkbox{\neg #1}} \newtheorem{sublemma}[definition]{Sublemma} \newtheorem{convention}[definition]{Convention} \newcommand{\Sp}{\mbox{Sp}} \newcommand{\lro}[1]{\lfloor#1\rfloor} corn-8.20.0/doc/skel/skel.tex000066400000000000000000000010451473720167500157410ustar00rootroot00000000000000\documentclass{article} \usepackage{a4wide,amstext,amssymb} \sloppy \input header \begin{document} \date{\today} \title{Skeleton for the Proof development leading to the Fundamental Theorem of Algebra} \author{Herman Geuvers, Randy Pollack, Freek Wiedijk, Jan Zwanenburg} \maketitle \input CSetoids \input CGroups \input CRings %\input CIntDomains \input CFields %\input CVectorSpace %\input LinearAlgebra \input CReals \input CPolynomials \input IVT \input CComplex \input NRootCC \input FTAreg \input FTA \input bibliography \end{document} corn-8.20.0/doc/skel/split.tex000066400000000000000000000243521473720167500161440ustar00rootroot00000000000000\documentclass{article} \usepackage{amssymb} \def\NN{\mathbb{N}} \def\RR{\mathbb{R}} \def\CC{\mathbb{C}} \newtheorem{lemma}{Lemma} \newtheorem{corollary}[lemma]{Corollary} \newenvironment{proof}{\trivlist \item[\hskip \labelsep{\bf Proof$\,$}]}{\hfill\rlap{$\sqcap$}$\sqcup$\par} \begin{document} \begin{lemma}\label{lemma:ttt} Let be given $n\in\NN_{\ge 2}$ and $\epsilon > 0$. Then for every $a_0,\ldots,a_n \ge 0$ with $a_0 > \epsilon$ and $a_n = 1$, there exist $t > 0$ and $k\in\{1,\ldots,n\}$ such that: $$a_k t^k = a_0 - \epsilon$$ and such that for all $i\in\{1,\ldots,n\}$: $$a_i t^i < a_0$$ \end{lemma} \begin{proof} Start with $k = n$ and $t = \root n\of{a_0 - \epsilon}$. Then consider in turn for $i$ the values $n-1$ down to $1$. At each $i$ either $a_i t^i < a_0$ or $a_i t^i > a_0 - \epsilon$ (for the value of $t$ that is current at that time.) In the first case do nothing, but in the second case set $k$ to $i$ and $t$ to $\root i\of{(a_0 - \epsilon)/a_i}$ (in which case $t$ will decrease.) This will give at the end a suitable $k$ and $t$. \end{proof} \begin{lemma}\label{lemma:max} For $\epsilon > 0$ and $a_1,\ldots,a_n\in\RR$ there always is a $k$ such that for all $i\in\{1,\ldots,n\}$: $$a_k > a_i - \epsilon$$ \end{lemma} \begin{proof} Induction with respect to $n$. \end{proof} \begin{lemma}\label{lemma:seq} Let be given $n\in\NN_{\ge 2}$ and $\epsilon > 0$. Then for every $a_0,\ldots,a_n\ge 0$ with $a_0 > \epsilon$ and $a_n = 1$, there exist: \begin{enumerate} \item $t > 0$ \item $k_0\ge k_1\ge k_2\ge\ldots \in\{1,\ldots,n\}$ \end{enumerate} such that: $$a_{k_0} t^{k_0} = a_0 - \epsilon$$ and such that for every $j$, if we let $k = k_j$ and $r = 3^{-j} t$: $$a_k r^k > a_i r^i - \epsilon \makebox[0pt][l]{\qquad\it for all $i\in\{1,\ldots,n\}$}$$ \end{lemma} \begin{proof} Choose $t$ and $k_0$ according to lemma \ref{lemma:ttt}. To get $k_{j+1}$ from $k_j$, let $k = k_j$, $r = 3^j t$ and apply lemma \ref{lemma:max} with $\epsilon/2$ to the sequence $$a_1 (r/3),a_2 (r/3)^2,\ldots,a_k (r/3)^k$$ to get $k' = k_{j+1}$. Then for $i\le k$ the inequality for $k_{j+1}$ directly follows, while for $i > k$ we have: $$a_k (r/3)^k = 3^{-k} a_k r^k > 3^{-k}\left(a_i r^i - \epsilon\right) = 3^{-k} a_i r^i - 3^{-k}\epsilon > a_i (r/3)^i - \epsilon/2$$ and so: $$a_{k'} (r/3)^{k'} > a_k (r/3)^k - \epsilon/2 > a_i (r/3)^i - \epsilon$$ \end{proof} \begin{lemma}\label{lemma:bou} In the situation of the previous lemma, if again we take $k = k_j$ and $r = 3^{-j} t$, we have: \begin{eqnarray*} r^n &<& a_0\\ a_k r^k &<& a_0\\ 3^{-jn} a_0 - 2\epsilon &<& a_k r^k \end{eqnarray*} \end{lemma} \begin{proof} We have $r \le t$ and so for all $i$ we have $a_i r^i \le a_i t^i < a_{k_0} t^{k_0} + \epsilon = a_0$. Of this statement $r^n < a_0$ and $a_k r^k < a_0$ are special cases. Finally, from $a_{k_0} r^{k_0} = 3^{-jk_0} a_{k_0} t^{k_0} \ge 3^{-jn} a_{k_0} t^{k_0} = 3^{-jn} (a_0 - \epsilon) > 3^{-jn} a_0 - \epsilon$ it follows that $a_k r^k > a_{k_0} r^{k_0} - \epsilon > 3^{-jn} a_0 - 2\epsilon$. \end{proof} \begin{lemma}\label{lemma:sel} For each sequence $k_0 \ge k_1 \ge k_2 \ge \ldots\in\{1,\ldots,n\}$ there is a $j\in\NN$ with $j < 2n$ such that $k_{j-1} = k_j = k_{j+1}$. \end{lemma} \begin{proof} Induction with respect to $n$. \end{proof} \begin{lemma}\label{lemma:est} For every $\epsilon > 0$, $a_1,\ldots,a_n \ge 0$, $k\in\{1,\ldots,n\}$ and $r > 0$ such that for all $i\in\{1,\ldots,n\}$: \begin{eqnarray*} a_k (r/3)^k &>& a_i (r/3)^i - \epsilon\\ a_k (3r)^k &>& a_i (3r)^i - \epsilon \end{eqnarray*} holds: $$\sum_{i=1\atop i\ne k}^n a_i r^i < (1 - 3^{-n}) a_k r^k + 3^n\epsilon$$ \end{lemma} \begin{proof} From the first assumption follows that \begin{eqnarray*} a_i r^i &=& 3^i a_i (r/3)^i\\ &<& 3^i (a_k (r/3)^k + \epsilon)\\ &<& 3^{i-k} a_k r^k + 3^i\epsilon \end{eqnarray*} and therefore \begin{eqnarray*} \sum_{i=1}^{k-1} a_i r^i &<& \sum_{i=1}^{k-1} \left(3^{i-k} a_k r^k + 3^n\epsilon\right)\\ &=& \big(\sum_{i=1}^{k-1} 3^{i-k}\big) a_k r^k + \big(\sum_{i=1}^{k-1} 3^i\big)\epsilon\\ &=& {1\over 2}(1-3^{1-k}) a_k r^k + {1\over 2}(3^k-3^1)\epsilon\\ &<& {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon \end{eqnarray*} % In exactly the same way it follows from the other assumption that $$a_i r^i < 3^{k-i} a_k r^k + 3^{-i}\epsilon$$ and $$\sum_{i=k+1}^n a_i r^i < {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon$$ % Together this gives \begin{eqnarray*} \sum_{i=1\atop i\ne k}^n a_i r^i &=& \sum_{i=1}^{k-1} a_i r^i + \sum_{i=k+1}^n a_i r^i\\ &<& {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon + {1\over 2}(1 - 3^{-n}) a_k r^k + {1\over 2}3^n\epsilon\\ &=& (1 - 3^{-n}) a_k r^k + 3^n\epsilon \end{eqnarray*} as required. \end{proof} \begin{lemma}\label{lemma:est1} For every $\epsilon > 0$ and $a_0,\ldots,a_n \ge 0$ with $a_0 > 0$, there exist $r > 0$ and $k\in\{1,\ldots,n\}$ such that: \begin{eqnarray} r^n &<& a_0 \label{ineq:est1}\\ a_k r^k &<& a_0 \label{ineq:est2}\\ 3^{-2n^2} a_0 - 2\epsilon &<& a_k r^k \label{ineq:est3}\\ \sum_{i=1\atop i\ne k}^n a_i r^i &<& (1 - 3^{-n}) a_k r^k + 3^n\epsilon \label{ineq:est4} \end{eqnarray} \end{lemma} \begin{proof} Take $t$ and $k_0, k_1, \ldots$ as in lemma \ref{lemma:seq}. According to lemma \ref{lemma:sel} there is a $j < 2n$ such that $k_{j-1} = k_j = k_{j+1}$. Take $k = k_j$ and $r = 3^{-j} t$. Then inequalities (\ref{ineq:est1}), (\ref{ineq:est2}) and (\ref{ineq:est3}) are given by lemma \ref{lemma:bou} (the inequality $3^{-2n^2} a_0 < 3^{-jn} a_0$ holds because $j < 2n$), and inequality (\ref{ineq:est4}) is given by lemma \ref{lemma:est}. \end{proof} \begin{lemma}\label{lemma:est2} Let $a_0,\ldots,a_n\ge 0$ and $b_0,\ldots,b_n\in\CC$ with $a_i = |b_i|$ for $i=1,\ldots,n$. Furthermore, let $k\in\{1,\ldots,n\}$, $r > 0$ and $z\in\CC$ with $r = |z|$. Then: $$\big|\sum_{i=0}^n b_i z^i\big| < \left|b_0 + b_k z^k\right| + \sum_{i=1\atop i\ne k}^n a_i r^i$$ \end{lemma} \begin{proof} Repeated application of the triangle inquality for the complex numbers. \end{proof} \begin{lemma}\label{lemma:est3} Given $a_0,\,a_k > 0$, $b_0,\,b_0',\,b_k\in\CC$, $k\in\{1,\ldots,n\}$, $r > 0$ and $\eta > 0$ such that: \begin{eqnarray*} |b_0'| &=& a_0 \\ |b_k| &=& a_k \\ |b_0 - b_0'| &<& \eta\\ a_k r^k &<& a_0 \end{eqnarray*} then there exists a $z\in\CC$ such that $|z| = r$ and: $$\left|b_0 + b_k z^k\right| < a_0 - a_k r^k + \eta$$ \end{lemma} \begin{proof} Take $$z = r\,\root k\of{-{a_k\over a_0}{b_0'\over b_k}}$$ Then we have: $$\Big|{-{a_k\over a_0}{b_0'\over b_k}}\Big| = {a_k\left|b_0'\right|\over a_0\left|b_k\right|} = {a_k a_0\over a_0 a_k} = 1$$ so $$\Bigg|\root k\of{-{a_k\over a_0}{b_0'\over b_k}}\Bigg| = 1$$ and so $|z| = r$. Because $a_k r^k < a_0$ we get $\big|a_0 - a_k r^k\big| = a_0 - a_k r^k$ and therefore \begin{eqnarray*} |b_0' + b_k z^k| &=& \Big|b_0' + b_k r^k \big(-{a_k\over a_0}{b_0'\over b_k}\big)\Big|\\ &=& \big|{b_0'\over a_0}(a_0 - a_k r^k)\big|\\ &=& {|b_0'|\over a_0}|a_0 - a_k r^k|\\ &=& a_0 - a_k r^k \end{eqnarray*} From this it follows that $\left|b_0 + b_k z^k\right| \le \left|b_0' + b_k z^k\right| + |b_0 - b_0'| < a_0 - a_k r^k + \eta$. \end{proof} \begin{lemma}\label{lemma:nzc} For $\eta > 0$ and $z\in\CC$ there is a $z'\in\CC$ with $z' \mathrel{\#} 0$ and $|z' - z| < \eta$. \end{lemma} \begin{proof} Because $z + \eta/2 \mathrel{\#} z - \eta/2$, either $z + \eta/2 \mathrel{\#} 0$ or $z - \eta/2 \mathrel{\#} 0$. For both choices $|z' - z| = \eta/2 < \eta$. \end{proof} \begin{lemma}\label{lemma:eps0} Given a finite list of inequalities \begin{eqnarray*} p_0\epsilon &<& q_0\\ p_1\epsilon &<& q_1\\ p_2\epsilon &<& q_2\\ \ldots \end{eqnarray*} with $p_i,q_i > 0$, there is an $\epsilon > 0$ that satisfies it. \end{lemma} \begin{proof} Induction with respect to the length of the list. \end{proof} \begin{lemma}\label{lemma:eps} Let be given $b_0,\ldots,b_n\in\CC$ with $b_n = 1$ and $c\in\RR$ with $|b_0| < c$. Then there are $b_0'\in\CC$, $a_0$ and $\eta > 0$ such that: \begin{eqnarray} |b_0 - b_0'| &<& \eta\\ |b_0'| &=& a_0\\ a_0 &>& 0\\ a_0 + 3\eta &<& c \label{ineq:eta} \end{eqnarray} and an $\epsilon > 0$ such that: \begin{eqnarray} 2(3^n + 1)\epsilon &<& \eta \label{ineq:epsilon}\\ 2\epsilon &<& 3^{-2n^2} a_0\\ \epsilon &<& a_0 \end{eqnarray} \end{lemma} \begin{proof} Take $$\eta = {1\over 4}(c - |b_0|)$$ so $|b_0| = c - 4\eta$. Then choose an arbitrary $b_0' \mathrel{\#} 0$ with $|b_0' - b_0| < \eta$ and take $a_0 = |b_0'|$. To see that (\ref{ineq:eta}) is satisfied, calculate: $$a_0 = |b_0'| \le |b_0' - b_0| + |b_0| < \eta + c - 4\eta = c - 3\eta$$ % The existence of a suitable $\epsilon$ then follows from lemma \ref{lemma:eps0}. \end{proof} \begin{lemma}\label{lemma:eps1} For: $$q = 1 - 3^{-2n^2-n}$$ we have that $q > {1\over 2}$ and because of that inequalities (\ref{ineq:eta}) and (\ref{ineq:epsilon}) imply: $$q a_0 + 3^n \epsilon + \epsilon + \eta < qc$$ \end{lemma} \begin{proof} We get $$a_0 + 2\cdot 3^n\epsilon + 2\epsilon + 2\eta = a_0 + 2(3^n + 1)\epsilon + 2\eta < a_0 + \eta + 2\eta < c$$ Using that $1 < 2q$, this gives $$q a_0 + 3^n\epsilon + \epsilon + \eta < q a_0 + 2q 3^n\epsilon + 2q \epsilon + 2q \eta\ = q (a_0 + 2\cdot 3^n\epsilon + 2\epsilon + 2\eta) < qc $$ \end{proof} \begin{lemma}\label{lemma:key} Let be given $b_0,\ldots,b_n\in\CC$ with $b_n = 1$ and $c\in\RR$ with $|b_0| < c$. Let $q$ be as in the previous lemma. Then there is a $z\in\CC$ with $$|z| < c^{1/n}$$ and: $$\big|\sum_{i=0}^n b_i z^i\big| < qc$$ \end{lemma} \begin{proof} Take $b_0'$, $a_0$, $\eta$ and $\epsilon$ as in lemma \ref{lemma:eps}. Take $a_i = |b_i|$ for $i\in\{1,\ldots,n\}$. Take $r$ and $k$ as in lemma \ref{lemma:est1}. Finally take $z$ as in lemma \ref{lemma:est3}. Then plugging all conditions and results of lemmas \ref{lemma:est1}, \ref{lemma:est2}, \ref{lemma:est3}, \ref{lemma:eps} and \ref{lemma:eps1} together we get $$r^n < a_0 < c - 3\eta < c$$ so $$|z| = r < c^{1/n}$$ and \begin{eqnarray*} \big|\sum_{i=0}^n b_i z^i\big| &<& \left|b_0 + b_k z^k\right| + \sum_{i=1\atop i\ne k}^n a_i r^i\\ &<& \left(a_0 - a_k r^k + \eta\right) + \left((1 - 3^{-n}) a_k r^k + 3^n\epsilon\right)\\ &=& a_0 - 3^{-n} a_k r^k + 3^n\epsilon + \eta\\ &<& a_0 - 3^{-n} (3^{-2n^2} a_0 - 2\epsilon) + 3^n\epsilon + \eta\\ &=& (1 - 3^{-2n^2-n}) a_0 + 3^n\epsilon + 3^{-n} 2\epsilon +\eta\\ &<& (1 - 3^{-2n^2-n}) a_0 + 3^n\epsilon + \epsilon + \eta\\ &=& q a_0 + 3^n\epsilon + \epsilon + \eta\\ &<& q c \end{eqnarray*} \end{proof} \end{document} corn-8.20.0/doc/style.css000066400000000000000000000020131473720167500151710ustar00rootroot00000000000000a:visited {color : #416DFF; text-decoration : none; } a:link {color : #416DFF; text-decoration : none; font-weight : bold} a:hover {color : Red; text-decoration : underline; } a:active {color : Red; text-decoration : underline; } .keyword { font-weight : bold ; color : Red } .keywordsign { color : #C04600 } .superscript { font-size : 4 } .subscript { font-size : 4 } .comment { color : Green } .constructor { color : Blue } .string { color : Maroon } .warning { color : Red ; font-weight : bold } .info { margin-left : 3em; margin-right : 3em } .title1 { font-size : 20pt ; background-color : #416DFF } .title2 { font-size : 20pt ; background-color : #418DFF } .title3 { font-size : 20pt ; background-color : #41ADFF } .title4 { font-size : 20pt ; background-color : #41CDFF } .title5 { font-size : 20pt ; background-color : #41EDFF } .title6 { font-size : 20pt ; background-color : #41FFFF } body { background-color : White } tr { background-color : White } # .doc { background-color :#aaeeff } .doc { background-color :#66ff66 } corn-8.20.0/examples/000077500000000000000000000000001473720167500143745ustar00rootroot00000000000000corn-8.20.0/examples/Calculemus2011.v000066400000000000000000000117031473720167500171660ustar00rootroot00000000000000Require Import CRtrans Compress. Require Import ARtrans ARbigD. Definition eval (n:positive) (r : CR) : Q := let m := iter_pos n _ (Pmult 10) 1%positive in approximate r (1#m)%Qpos. Definition deval (n:positive) (r : ARbigD) : bigD := let m := iter_pos n _ (Pmult 10) 1%positive in approximate r (1#m)%Qpos. Let ARtest1 : ARbigD := ARpi. Let CRtest1 : CR := CRpi. Let ARtest2 : ARbigD := ARexp (ARcompress (ARexp (ARcompress (AQexp (1 ≪ (-1)))))). Let CRtest2 : CR := exp (compress (exp (compress (rational_exp (1#2))))). Let ARtest3 : ARbigD := ARexp (ARcompress ARpi) - ARpi. Let CRtest3 : CR := exp (compress CRpi) - CRpi. Let ARtest4 : ARbigD := ARarctan (ARcompress ARpi). Let CRtest4 : CR := arctan (compress CRpi). Let ARtest5 : ARbigD := ARcos ('(10^50)%Z). Let CRtest5 : CR := cos ('inject_Z (10^50)%Z). Let ARtest6 : ARbigD := ARsin (ARcompress (ARsin (ARcompress (AQsin 1)))). Let CRtest6 : CR := sin (compress (sin (compress (rational_sin (1#1))))). Time Eval vm_compute in (deval 300 ARtest1). Time Eval vm_compute in (eval 300 CRtest1). Time Eval vm_compute in (deval 2100 ARtest1). Time Eval vm_compute in (deval 25 ARtest2). Time Eval vm_compute in (eval 25 CRtest2). Time Eval vm_compute in (deval 425 ARtest2). Time Eval vm_compute in (deval 25 ARtest3). Time Eval vm_compute in (eval 25 CRtest3). Time Eval vm_compute in (deval 425 ARtest3). Time Eval vm_compute in (deval 25 ARtest4). Time Eval vm_compute in (eval 25 CRtest4). Time Eval vm_compute in (deval 85 ARtest4). Time Eval vm_compute in (deval 40 ARtest5). Time Eval vm_compute in (eval 40 CRtest5). Time Eval vm_compute in (deval 3000 ARtest5). Time Eval vm_compute in (deval 25 ARtest6). Time Eval vm_compute in (eval 25 CRtest6). Time Eval vm_compute in (deval 425 ARtest6). (* Finally, we compare our sqrt with an implementation not using type classes *) Require Import ARroot dyadics. Let n := Eval compute in (10 * 10 * 10 * 10)%nat. Let ARroot_test : nat -> bigD * bigD := AQsqrt_loop (a:=2). Time Eval vm_compute in ( (fun _ _ _ _ _ _ _ _ _ _ => true) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n)) (snd (ARroot_test n))). Require Import BigZ. Open Scope bigZ_scope. Definition BigD_0 : bigD := (0 $ 0). Definition BigD_1 : bigD := (1 $ 0). Definition BigD_2 : bigD := (2 $ 0). Definition BigD_4 : bigD := (4 $ 0). Definition BigD_plus (x y : bigD) : bigD := match BigZ.compare (expo x) (expo y) with | Gt => BigZ.shiftl (mant x) (expo x - expo y) + mant y $ BigZ.min (expo x) (expo y) | _ => mant x + BigZ.shiftl (mant y) (expo y - expo x) $ BigZ.min (expo x) (expo y) end. Definition BigD_opp (x : bigD) : bigD := -mant x $ expo x. Definition BigD_mult (x y : bigD) : bigD := mant x * mant y $ expo x + expo y. Definition BigD_shiftl (x : bigD) (n : bigZ) : bigD := mant x $ expo x + n. Definition BigD_compare (x y : bigD) : comparison := match BigZ.compare (expo x) (expo y) with | Gt => BigZ.compare (BigZ.shiftl (mant x) (expo x - expo y)) (mant y) | _ => BigZ.compare (mant x) (BigZ.shiftl (mant y) (expo y - expo x)) end. Fixpoint root_loop_alt (x : bigD) (n : nat) : bigD * bigD := match n with | O => (x, BigD_0) | S n => let (r, s) := root_loop_alt x n in match BigD_compare (BigD_plus s BigD_1) r with | Gt => (BigD_shiftl r 2, BigD_shiftl s 1) | _ => (BigD_shiftl (BigD_plus r (BigD_opp (BigD_plus s BigD_1))) 2, BigD_shiftl (BigD_plus s BigD_2) 1) end end. Time Eval vm_compute in ( (fun _ _ _ _ _ _ _ _ _ _ => true) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n)) (snd (root_loop_alt BigD_2 n))). (* As suggested by Laurent Théry, mult is more efficient than shiftl in case the size of bigN is large enough. By increasing size in theories/Numbers/Natural/BigN/NMake_gen.ml to 12 the following is faster. *) Fixpoint root_loop_alt_mult (x : bigD) (n : nat) : bigD * bigD := match n with | O => (x, BigD_0) | S n => let (r, s) := root_loop_alt_mult x n in match BigD_compare (BigD_plus s BigD_1) r with | Gt => (BigD_mult BigD_4 r, BigD_mult BigD_2 s) | _ => (BigD_mult BigD_4 (BigD_plus r (BigD_opp (BigD_plus s BigD_1))), BigD_mult BigD_2 (BigD_plus s BigD_2)) end end. Time Eval vm_compute in ( (fun _ _ _ _ _ _ _ _ _ _ => true) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n)) (snd (root_loop_alt_mult BigD_2 n))). corn-8.20.0/examples/Circle.v000066400000000000000000000055271473720167500157750ustar00rootroot00000000000000(** Plotting graphs in the plane *) (* This file is based on examples/Plot.v *) (* I define the image of a path, a [Compact] subset of the plane.*) (* Finally, plot a hi-res Circle*) From CoRN Require Import Plot RasterQ Qmetric. Require Import CoRN.reals.fast.Interval. Require Import CoRN.metric2.MetricMorphisms. Require Import CoRN.reals.faster.ARArith. From CoRN Require Import ARplot. Require Import CoRN.reals.faster.ARcos CoRN.reals.faster.ARsin CoRN.reals.faster.ARexp CoRN.reals.faster.ARbigD CoRN.reals.faster.ARinterval. Require Import CoRN.reals.fast.CRtrans. Require Import CoRN.write_image.WritePPM. Local Open Scope uc_scope. Section PlotCirclePath. Context `{AppRationals AQ}. Definition CirclePath_faster : AQ_as_MetricSpace --> Complete (ProductMS AQ_as_MetricSpace AQ_as_MetricSpace) := (uc_compose (uc_compose Couple (together ARcos_uc ARsin_uc)) (diag AQ_as_MetricSpace)). Definition CosPath_faster : AQ_as_MetricSpace --> Complete (ProductMS AQ_as_MetricSpace AQ_as_MetricSpace) := (uc_compose (uc_compose Couple (together Cunit ARcos_uc)) (diag AQ_as_MetricSpace)). (* 7 is above 2 pi, which finishes a circle. *) (* Lemma zeroSeven : (0 <= 7)%Q. Proof. discriminate. Qed. *) Definition Circle_faster : sparse_raster _ _ := let (_,r) := ARplot.PlotPath 0 7 (-(1)) 1 (reflexivity _) (-(1)) 1 (reflexivity _) 200 CirclePath_faster in r. Definition Cos_faster : sparse_raster _ _ := let (_,r) := ARplot.PlotPath 0 7 0 7 (reflexivity _) (-(1)) 1 (reflexivity _) 800 CosPath_faster in r. End PlotCirclePath. Definition Circle_bigD : sparse_raster _ _ := @Circle_faster bigD _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ bigD_appRat. (* 3.7s on Apple M1 - this is mostly the creation of the sparse raster *) Time Elpi WritePPM "Circle.ppm" ( Circle_bigD ). (* Now have a look at Circle.ppm *) Definition Cos_bigD : sparse_raster _ _ := @Cos_faster bigD _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ bigD_appRat. (* 3.1s on Apple M1 *) Time Elpi WritePPM "Cos.ppm" ( Cos_bigD ). (* Now have a look at Cos.ppm *) Definition CircleFunction_aux : ProductMS Q_as_MetricSpace Q_as_MetricSpace --> ProductMS CR CR := together cos_uc sin_uc. Definition CirclePath : Q_as_MetricSpace --> Complete Q2:= (uc_compose (uc_compose Couple CircleFunction_aux) (diag Q_as_MetricSpace)). (* The following hangs: TODO this does not even compile Definition CirclePath': UCFunction Q R2:= ucFunction (fun q:Q => Couple (cos_uc q, sin_uc q)). *) Definition Circle : sparse_raster _ _ := (let (_,r) := Plot.PlotPath 0 7 (-(1)) 1 (reflexivity _) (-(1)) 1 (reflexivity _) 200 CirclePath in r). (* 16.3 seconds on Apple M1 *) Time Elpi WritePPM "Circle2.ppm" ( Circle ). (* Now have a look at Circle2.ppm *) corn-8.20.0/examples/IntegrationExamples.v000066400000000000000000000062261473720167500205530ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import Integration. Require Import AbstractIntegration. Require SimpleIntegration. (*Require SimpsonIntegration.*) Require Import CRtrans. Require QnonNeg. Import QnonNeg.notations. (* The answer function returns an approximation of r within 10^-n. Take the resulting integer and divide by 10^n to get the actual rational approximation. answer is useful for because it displays a familar list of digits rather than an unfamiliar fraction that approximate would return *) Definition answer (n:positive) (r:CR) : Z := let m := (iter_pos n _ (Pmult 10) 1%positive) in let (a,b) := (approximate r (1#m)%Qpos)*m in Zdiv a b. (* This file illustrates how to use the computational integration *) (* Please review RealFast.v for examples on how to compute with CR *) (* Integrate01 requires that we integrate uniformly continuous functions. Therefore we cannot integerate (sin : CR -> CR), we must instead integrate the UniformlyContinuousFunction (sin_uc : Q --> CR). *) Time Eval vm_compute in answer 3 (Integrate sin_uc 3 (1#2)). (*Time Eval vm_compute in answer 3 (SimpleIntegration.integrate sin_uc 3 (1#2)%Qnn).*) (* 1 is a bound for the absolute value of sin's fourth derivative *) (*Time Eval vm_compute in answer 10 (SimpsonIntegration.integrate sin_uc 1 3 (1#2)%Qnn).*) (* Integrate01 the x^2 function Time Eval vm_compute in answer 3 (Integrate01 (uc_compose (CRpower_positive_bounded 2 (1#1)) Cunit)). Time Eval vm_compute in answer 4 (Integrate01 (uc_compose (CRpower_positive_bounded 2 (1#1)) Cunit)). *) (* find the supremum of cos on [0,1] *) Time Eval vm_compute in answer 3 (ContinuousSup01 cos_uc). (* find the supremum of id on [0,1] *) Time Eval vm_compute in answer 3 (ContinuousSup01 Cunit). (* An example of an elliptic integral that cannot be solved symbolically \int_0^1 (1-\fract{1}{4}\sin^2\phi)^{-\fract{1}{2}} d\phi *) Definition sinsquare:= (uc_compose (CRpower_positive_bounded 2 (1#1)) sin_uc). Definition quartersinsquare:=(uc_compose (scale (1#4)) sinsquare). Definition body:=(uc_compose (translate 1) quartersinsquare). Definition rootbody:=(uc_compose CRsqrt body). Time Eval vm_compute in answer 1 (Integrate01 rootbody). corn-8.20.0/examples/LMCS2011.v000066400000000000000000000041061473720167500156260ustar00rootroot00000000000000Require Import CRtrans Compress. Require Import ARtrans ARbigD. Definition eval (n:positive) (r : CR) := let m := iter_pos n _ (Pmult 10) 1%positive in let _ := approximate r (1#m)%Qpos in tt. Definition deval (n:positive) (r : ARbigD) := let m := iter_pos n _ (Pmult 10) 1%positive in let _ := approximate r (1#m)%Qpos in tt. Definition P01 : CR := sin (compress (sin (compress (rational_sin 1)))). Definition dP01 : ARbigD := ARsin (ARsin (AQsin 1)). Definition P02 : CR := CRsqrt (compress CRpi). Definition dP02 : ARbigD := ARsqrt (ARcompress ARpi). Definition P03 : CR := sin (compress (rational_exp 1)). Definition dP03 : ARbigD := ARsin (AQexp 1). Definition P04 : CR := exp (compress (CRpi * rational_sqrt ('163%Z))). Definition dP04 : ARbigD := ARexp (ARcompress (ARpi * AQsqrt ('163%Z))). Definition P05 : CR := exp (compress (exp (compress (rational_exp 1)))). Definition dP05 : ARbigD := ARexp (ARexp (AQexp 1)). Definition P07 : CR := rational_exp ('1000%Z). Definition dP07 : ARbigD := AQexp ('1000%Z). Definition P08 : CR := cos (cast Q CR (cast Z Q (10^50)%Z)). Definition dP08 : ARbigD := AQcos ('(10^50)%Z). Require Import String. Eval compute in "old"%string. Time Eval vm_compute in (eval 25 P01). Time Eval vm_compute in (eval 25 P02). Time Eval vm_compute in (eval 25 P03). Time Eval vm_compute in (eval 10 P04). Time Eval vm_compute in (eval 10 P05). Time Eval vm_compute in (eval 10 P07). Time Eval vm_compute in (eval 25 P08). Eval compute in "new"%string. Time Eval vm_compute in (deval 25 dP01). Time Eval vm_compute in (deval 25 dP02). Time Eval vm_compute in (deval 25 dP03). Time Eval vm_compute in (deval 10 dP04). Time Eval vm_compute in (deval 10 dP05). Time Eval vm_compute in (deval 10 dP07). Time Eval vm_compute in (deval 25 dP08). Eval compute in "new bigger"%string. Time Eval vm_compute in (deval 500 dP01). Time Eval vm_compute in (deval 500 dP02). Time Eval vm_compute in (deval 500 dP03). Time Eval vm_compute in (deval 500 dP04). Time Eval vm_compute in (deval 500 dP05). Time Eval vm_compute in (deval 2000 dP07). Time Eval vm_compute in (deval 2000 dP08). corn-8.20.0/examples/Picard.v000066400000000000000000000130701473720167500157660ustar00rootroot00000000000000Require Import CRtrans. Require Import Qmetric. (* For comparison with Pattison's paper: The ODE: f'=λx.2f(x)+1 f(0)=0 *) Section ODE. Open Scope uc_scope. Require Import ProductMetric CompleteProduct. Require Import Unicode.Utf8. Require Import CPoly_Newton. Require Import metric2.Classified. Require Import Circle. Notation "X * Y":=(ProductMS X Y). Notation " f >> g ":= (Cbind_slow f ∘ g) (at level 50). Notation " x >>= f ":= (Cbind_slow f x) (at level 50). Section Picard_op. Require Import AbstractIntegration. (* Require Import stdlib_omissions.Pair. For diagonal*) Variable v: (Q*Q) -->CR. Variable f:Q-->CR. Notation "( f , g )":= (together f g). Definition vxfx:= (v >> Couple ∘ (Cunit, f) ∘ diag _). Require Import SimpleIntegration. (* Uniformly continuous function should be a type class so that we can define functions using Program Instance *) (* Integration takes a width, need the integral from a to b.*) Definition integral: ((Q-->CR) * Q * Q) -> CR. intros [[g a] b]. destruct (QMinMax.Qlt_le_dec_fast b a). assert (a_min_b:Qpos). exists (a-b) . admit. exact (- ∫ g b (a_min_b))%CR. (* Do the zero case *) assert (b_min_a:Qpos). exists (b-a). admit. exact ( ∫ g a (b_min_a))%CR. Defined. (* Need continuous Q--> CR then continuous CR --> CR *) (* The integral is locally uniformly continuous *) (* Context (f: Q -> CR) `{!LocallyUniformlyContinuous_mu f} `{!LocallyUniformlyContinuous f}.*) (* Definition intregral_uc:= (is_UniformlyContinuousFunction integral (fun e => e)%Qpos ). *) Definition Picard_raw:=fun t:Q => integral (f, 0, t). Lemma Picard_uc: (is_UniformlyContinuousFunction Picard_raw (fun e => e)%Qpos). admit. Qed. (* Locally Lipschitz: ∫ 0 t f - ∫ 0 s f = ∫ s t f ≤ |t-s| sup_[s,t] f Hence the constant is: r sup_B f on the ball B(t,r). differentiable maps are Lipschitz. Locally Lipschitz functions compose on B(x,r), | f x - f y | ≤ L_B |x -y| Hence fB ⊂ B(f x, L r) and g is Lipschitz cont on this ball. *) Definition Picard:=(Cbind_slow (Build_UniformlyContinuousFunction Picard_uc)). End Picard_op. Section Banach_it. Context {X} `(F:X-->X). Fixpoint Banach_seq (n : nat) : X --> X := match n with | O => F | S m => F ∘ (Banach_seq m) end. Variable f:CR-->CR. Check Picard. Fixpoint Picard_seq (n : nat) : Q --> CR := match n with | O => f ∘ Cunit | S m => (Picard (Picard_seq m) )∘ Cunit end. End Banach_it. Section Picard. Variable L:Qpos. Variable c:Qpos. Hypothesis c_unit:1-c>0. Program Definition oneminc:=(1-c):Qpos. Next Obligation. admit. Defined. Variables a K:Q. Hypothesis aL_le_c:(a*LCR. Hypothesis Lipschitz: forall x, -a<=x -> x<=a -> forall y, -K<=y -> y<=K -> forall y':Q, -K<=y' -> y <=K -> ((CRabs ((v (x, y)) - (v (x, y'))))<= 'L* 'Qabs (y-y'))%CR. Section BanachFPT. Context (X: MetricSpace). Context (d:X->X->CR). (* Notation Qset:=QArith.QArith_base.Q. Coercion inject_Q:Qset>-> (msp_is_setoid CR). *) Variable metric_function: forall e x y, ball e x y <-> ((d x y) <='e)%CR. Class Contraction `(F:X-->X)`(c:Qpos):= contraction: c<1-> forall x x', ((d x x') <= 'c*(d (F x) (F x')))%CR. (* forall ϵ, (ball ϵ x x')-> (ball (c*ϵ) (F x) (F x' )) *) Context {F}`{conF: Contraction F}. Require Export CRGeometricSum. (* Definition InfiniteSum_raw_F rec (err_prop: (Stream X) -> bool) (s:Stream X) : X := if (err_prop s) then 0 else (Qplus' (hd s) (rec err_prop (tl s))). Definition InfiniteGeometricSum_raw series (e:QposInf) : X := match e with | ∞ => 0 | Qpos2QposInf err => InfiniteSum_raw_N (InfiniteGeometricSum_maxIter series err) (fun err s => 0) (err_prop err) series end. *) Lemma bla: forall n m:nat, forall x:X, (ball (c^m) (@Banach_seq _ F n x) (@Banach_seq _ F (n+m) x)). Admitted. Lemma bla2: forall n:nat, forall x:X, (ball (Qpos_inv oneminc) x (@Banach_seq _ F n x)). Admitted. Lemma bla3: forall n m:nat, forall x:X, forall e, (ball e x (F x)) -> (ball (c^m*(Qpos_inv oneminc)*e) (@Banach_seq _ F n x) (@Banach_seq _ F m x)). Admitted. Variable x:X. Definition DiffSeries:=fun n => d (@Banach_seq _ F n x) (@Banach_seq _ F (S n) x). Require Import StreamMemo. Definition DiffStream:=(memo_list _ DiffSeries). Require Import CoqStreams. (* ForAll_map in CoqStreams ?? *) Definition GeometricSeriesCR (c:CR):= (ForAll (fun s:Stream CR => (CRabs ((hd (tl s))) <= c*(CRabs(hd s)))%CR)). Lemma GeomDiff:GeometricSeriesCR ('c)%CR DiffStream. unfold GeometricSeriesCR. unfold DiffStream. unfold memo_list. unfold memo_make. simpl. admit. Qed. (* The Banach sequence is a Cauchy sequence.*) (* Use: Lemma GeometricCovergenceLemma : forall (n:positive) (e:Qpos), /(e*(1 - a)) <= n -> a^n <= e. with e:=ϵ *oneminc/ (d x0 x1) *) Lemma BanachCauchy: forall ϵ:Qpos, exists N, forall n m:nat , n >=N-> m>= N -> (ball ϵ (@Banach_seq _ F n x) (@Banach_seq _ F m x)). intros. (* Needs to be of type Qpos, want Qpos as a type class *) (* A rational number bigger than (d x0 x1) *) set ceil:=(Qabs (approximate (d (@Banach_seq _ F 0 x) (@Banach_seq _ F 1 x)) (Qpos2QposInf (1#1))))+1:Qpos. exists ( /((ϵ*oneminc/ceil)(oneminc))). (* Note that to apply the geomSum we do compute all the norms *) End BanachFPT. Section BanachFPT2. Context {X} (F:Complete X--> Complete X) `{conF: Contraction (Complete X) F}. Theorem BanachFPT : exists x, (F x) =x. eexists y. Admitted. (* x= lim F^n F x - x = F lim F^n - lim F^n = lim F^n+1 - lim F^n. *) (* Moreover, it is unique *) Theorem PicardFPT: exists f, (Picard f) = (f ∘ Cunit). apply BanachFPT. Qed.corn-8.20.0/examples/PlotExamples.v000066400000000000000000000052541473720167500172060ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import Plot. Require Import CRtrans. (* `∗' is used for trival proofs that a some concrete number is less than another *) Notation star := (@refl_equal _ Lt). Notation "∗" := star. Local Open Scope Q_scope. Local Open Scope uc_scope. Local Open Scope raster. (* This file illustrates how to plot funcitons *) (* PlotQ requires that we plot uniformly continuous functions. Therefore we cannot plot (sin : CR -> CR), me must instead plot the UniformlyContinuousFunction (sin_uc : Q --> CR). *) (* Here we plot sin on [-3,3] with range [-1,1] on a 36x12 raster *) Time Eval vm_compute in PlotQ (- (3)) 3 star (- (1)) 1 star sin_uc 36 12. (* Here we explore the proof that plots are correct *) Goal True. (* Plot_correct is a proof that the plot is correct.*) (* below we plot exp on [-3, 0] with range [0,1] *) (* (exp_bound_uc 0) is exp on ]-inf,0] which is one domain where it is uniformly continuous *) assert (X:=@Plot_correct (-(3)) 0 star 0 1 star (exp_bound_uc 0) 45 15 refl_equal refl_equal). (* No plot is seen. It is hidden in the uncomputed PlotQ (- (3)) 0 ∗ 0 1 ∗ (exp_bound_uc 0) 45 15 *) (* We use patern matchin to extract the parts of the statement we wish to normalize *) match goal with [X:ball ?e ?a (@ucFun _ _ _ (_⇱?b⇲_))|-_] => set (E:=e) in X; set (B:=b) in X end. (* E is the error; a bound on the distance between our plot and the actual function *) set (E' := E: Q). vm_compute in E'. (* The error is 90/1800 *) (* B is the plot *) Time vm_compute in B. (* The plot is a 45 by 15 raster. *) (* The plot and error can be reinserted into the statement if you wish *) unfold E, B in X. clear E B. (* end this example *) split. Qed. corn-8.20.0/examples/RealFast.v000066400000000000000000000104451473720167500162700ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CRtrans. Local Open Scope Q_scope. (* This file illustrates how to use the computational reals CR *) (* `∗' is used for trival proofs that a some concrete number is less than another *) Definition star := @refl_equal _ Lt. Notation "∗" := star. (* The answer function returns an approximation of r within 10^-n. Take the resulting integer and divide by 10^n to get the actual rational approximation. answer is useful for because it displays a familar list of digits rather than an unfamiliar fraction that approximate would return *) Definition answer (n:positive) (r:CR) : Z := let m := (iter_pos _ (Pmult 10) 1%positive n) in let (a,b) := (approximate r (Qpos2QposInf (1#m)))*(Zpos m#1) in Z.div a (Zpos b). (* Here are some example approximations to real numbers *) (* approximate the integer 7 *) Time Eval vm_compute in answer 10 ('7)%CR. (* approximate the rational 0.5 *) Time Eval vm_compute in answer 10 ('(1#2))%CR. (* approximate pi *) Time Eval vm_compute in answer 50 (CRpi)%CR. (* approximate e *) Time Eval vm_compute in answer 50 (rational_exp 1)%CR. (* approximate e^-1 *) Time Eval vm_compute in answer 50 (rational_exp (-(1)))%CR. (* approximate e^pi - pi. May take a minute *) Time Eval vm_compute in answer 20 (exp (compress CRpi) - CRpi)%CR. (* The following expressions are taken from the Many Digits friendly competition practice set, which in turn are taken from the CCA 2000 competition *) (* sin (sin (sin(1))) *) Time Eval vm_compute in answer 20 (sin (compress (sin (compress (rational_sin 1)))))%CR. (* sqrt (pi) *) Time Eval vm_compute in answer 20 (CRsqrt (compress CRpi))%CR. (* sin e *) Time Eval vm_compute in answer 20 (sin (compress (rational_exp 1)))%CR. (* exp (pi * sqrt(163)) : Takes upt 3 minutes Time Eval vm_compute in answer 1 (exp (compress (rational_sqrt 163 * CRpi)))%CR. *) (* exp (exp (exp (1))) *) Time Eval vm_compute in answer 1 (exp (compress (exp (compress (rational_exp 1)))))%CR. (* The following expressions are taken from the Many Digits friendly competition problem set *) (* sqrt (e/pi) *) Time Eval vm_compute in answer 20 (CRsqrt (compress (rational_exp (1))*compress (CRinv_pos (3#1) CRpi)))%CR. (* sin((e+1)^3) *) Time Eval vm_compute in answer 20 (sin (compress (CRpower_slow (translate (1#1) (compress (rational_exp (1)))) 3)))%CR. (* sin(10^22) still takes too long, see http://www.derekroconnor.net/DAMQ/FPArithSlidesHO.pdf *) Time Eval vm_compute in answer 10 (rational_sin (10^14))%CR. (* exp (exp (exp (1/2))) *) Time Eval vm_compute in answer 10 (exp (compress (exp (compress (rational_exp (1#2))))))%CR. Require Import CRsign. (* This example shows how to automatically solve inequalites for CR *) Example xkcd217A : (exp (CRpi) - CRpi < '(20#1))%CR. unfold CRlt. Time CR_solve_pos (1#1000)%Qpos. Qed. Require Import Exponential. Require Import Pi. (* This example shows how to automatically solve inequalites for IR *) Example xkcd217B : (Exp Pi [-] Pi [<] (nring 20)). Time IR_solve_ineq (1#1000)%Qpos. Qed. Require Import MultivariatePolynomials. (* approximate 4*(1/e)*(1-(1/e)) while sharing the expression (1/e) using multivariable polynomial library (which only uses one variable in this case). *) (* Time Eval vm_compute in answer 20 (MVP_uc_fun 1 ((_C_ (4#1))[*]_X_[*](One[-]_X_)) (rational_exp (-1#1))%CR). *) corn-8.20.0/examples/RealFaster.v000066400000000000000000000050041473720167500166120ustar00rootroot00000000000000Require Import Bignums.BigZ.BigZ CRArith model.totalorder.QposMinMax ARbigD ARbigQ ARQ ARtrans ARsign. Definition myAR := ARbigD. Definition answer (n : positive) (r : ARbigD) : bigZ := let m := iter_pos _ (Pmult 10) 1%positive n in let (a, b) := (approximate r (Qpos2QposInf (1#m)) : bigD) * 'Zpos m in BigZ.shiftl a b. (* To avoid timing the printing mechanism *) Definition no_answer (n : positive) (r : myAR) := let m := iter_pos _ (Pmult 10) 1%positive n in let _ := approximate r (Qpos2QposInf (1#m)) in tt. (* xkcd.org/217 *) Definition xkcd : myAR := (ARexp ARpi)-ARpi. Time Eval vm_compute in (answer 10 xkcd). Example xkcd217A : ARltT xkcd ('20%Z). Proof. Time AR_solve_ltT (-8)%Z. Defined. (* Many of the following expressions are taken from the "Many Digits friendly competition" problem set *) (* Instance resolution takes 3s *) Time Definition P01 : myAR := ARsin (ARsin (AQsin 1)). Time Eval vm_compute in (answer 500 P01). Time Eval vm_compute in (no_answer 500 P01). Definition P02 : myAR := ARsqrt (ARcompress ARpi). Time Eval vm_compute in (answer 500 P02). Definition P03 : myAR := ARsin (AQexp 1). Time Eval vm_compute in (answer 500 P03). Definition P04 : myAR := ARexp (ARcompress (ARpi * AQsqrt ('163%Z))). Time Eval vm_compute in (answer 500 P04). Definition P05 : myAR := ARexp (ARexp (AQexp 1)). Time Eval vm_compute in (answer 500 P05). Definition P07 : myAR := AQexp ('1000%Z). Time Eval vm_compute in (answer 2000 P07). Definition P08 : myAR := AQcos ('(10^50)%Z). Time Eval vm_compute in (answer 2000 P08). Definition C02_prf : ARapartT (ARpi : myAR) (0 : myAR). Proof. AR_solve_apartT (-8)%Z. Defined. Definition C02 : myAR := ARsqrt (AQexp 1 * ARinvT ARpi C02_prf). Time Eval vm_compute in (answer 250 C02). Definition C03 : myAR := ARsin (ARcompress ((AQexp 1 + 1) ^ (3:N))). Time Eval vm_compute in (answer 500 C03). Definition C04 : myAR := ARexp (ARcompress (ARpi * AQsqrt ('2011%Z))). Time Eval vm_compute in (answer 500 C04). Definition C05 : myAR := ARexp (ARexp (ARsqrt (AQexp 1))). Time Eval vm_compute in (answer 500 C05). (* slow *) (* Definition C07 : myAR := ARpi ^ 1000%N. Time Eval vm_compute in (answer 50 C07). *) Definition ARtest1 : myAR := ARpi. Time Eval vm_compute in (answer 1500 ARtest1). Definition ARtest2 : myAR := ARarctan (ARcompress ARpi). Time Eval vm_compute in (answer 100 ARtest2). Definition ARtest3 : myAR := ARsqrt 2. Time Eval vm_compute in (answer 1000 ARtest3). Definition ARtest4 : myAR := ARsin ARpi. Time Eval vm_compute in (answer 500 ARtest4). corn-8.20.0/examples/bigD.v000066400000000000000000000016101473720167500154260ustar00rootroot00000000000000Require Import Program QArith ZArith Bignums.BigZ.BigZ. From CoRN Require Import Qpossec MetricMorphisms Qmetric Qdlog ARArith. From MathClasses.implementations Require Import stdlib_rationals stdlib_binary_integers fast_integers dyadics. Add Field Q : (dec_fields.stdlib_field_theory Q). Notation bigD := (Dyadic bigZ). Print Dyadic. (* We want to avoid timing the printing mechanism *) Definition test:bigD->True. intro x;auto. Defined. Definition x:bigD:= (dyadic (10000000%bigZ) (100000%bigZ)). Definition square:bigD-> bigD:=fun x:bigD => (dy_mult x x) . Check dy_pow. Check (Z⁺). Check NonNeg. Search NonNeg. Check ((1 _):(Z⁺)). (* Time Eval vm_compute in (test (dy_pow x (((40%Z) _)))).*) Time Eval native_compute in (test (square x)). From CoRN Require Import ARbigD. Time Eval vm_compute in (test (bigD_div (square x) x (10000%Z))). From CoRN Require Import ApproximateRationals. corn-8.20.0/fta/000077500000000000000000000000001473720167500133305ustar00rootroot00000000000000corn-8.20.0/fta/CC_Props.v000066400000000000000000000201631473720167500151710ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.complex.AbsCC. From Coq Require Import Lia. (** * More properties of complex numbers ** Sequences and limits *) #[global] Hint Resolve AbsIR_sqrt_sqr: algebra. Lemma absCC_absIR_re : forall x : CC, AbsIR (Re x) [<=] AbsCC x. Proof. intros. astepl (sqrt (Re x[^]2) (sqr_nonneg _ (Re x))). unfold AbsCC in |- *. apply power_cancel_leEq with 2. auto. apply sqrt_nonneg. astepl (Re x[^]2). astepr (Re x[^]2[+]Im x[^]2). astepl (Re x[^]2[+][0]). apply plus_resp_leEq_lft. apply sqr_nonneg. Qed. Lemma absCC_absIR_im : forall x : CC, AbsIR (Im x) [<=] AbsCC x. Proof. intros. astepl (sqrt (Im x[^]2) (sqr_nonneg _ (Im x))). unfold AbsCC in |- *. apply power_cancel_leEq with 2. auto. apply sqrt_nonneg. astepl (Im x[^]2). astepr (Re x[^]2[+]Im x[^]2). astepl ([0][+]Im x[^]2). apply plus_resp_leEq. apply sqr_nonneg. Qed. Definition seq_re (s : nat -> CC) (n : nat) := Re (s n). Definition seq_im (s : nat -> CC) (n : nat) := Im (s n). Definition CC_Cauchy_prop (s : nat -> CC) : CProp := Cauchy_prop (seq_re s) and Cauchy_prop (seq_im s). Record CC_CauchySeq : Type := {CC_seq :> nat -> CC; CC_proof : CC_Cauchy_prop CC_seq}. Lemma re_is_Cauchy : forall s : CC_CauchySeq, Cauchy_prop (seq_re s). Proof. intro s; elim (CC_proof s); auto. Qed. Lemma im_is_Cauchy : forall s : CC_CauchySeq, Cauchy_prop (seq_im s). Proof. intro s; elim (CC_proof s); auto. Qed. Definition CC_Cauchy2re s := Build_CauchySeq _ _ (re_is_Cauchy s). Definition CC_Cauchy2im s := Build_CauchySeq _ _ (im_is_Cauchy s). Definition LimCC s : CC := (Lim (CC_Cauchy2re s)) [+I*] (Lim (CC_Cauchy2im s)). Definition CC_SeqLimit (seq : nat -> CC) (lim : CC) : CProp := forall e, [0] [<] e -> {N : nat | forall m, N <= m -> AbsCC (seq m[-]lim) [<=] e}. Lemma AbsSmall_sqr : forall x e : IR, AbsSmall e x -> x[^]2 [<=] e[^]2. Proof. unfold AbsSmall in |- *. intros. elim H. clear H. intros. astepl ([0][+]x[^]2). apply shift_plus_leEq. astepr ((e[-]x) [*] (e[+]x)). apply mult_resp_nonneg. apply shift_leEq_minus. astepl x. auto. rstepr (x[-][--]e). apply shift_leEq_minus. astepl ( [--]e). auto. Qed. Lemma AbsSmall_AbsCC : forall (z : CC) (e : IR), [0] [<] e -> AbsSmall (e [/]TwoNZ) (Re z) -> AbsSmall (e [/]TwoNZ) (Im z) -> AbsCC z [<=] e. Proof. intros. unfold AbsCC in |- *. apply power_cancel_leEq with 2. auto. apply less_leEq. auto. astepl (Re z[^]2[+]Im z[^]2). rstepr ((e [/]TwoNZ) [^]2[+] (e [/]TwoNZ) [^]2[+] (e[^]2) [/]TwoNZ). astepl (Re z[^]2[+]Im z[^]2[+][0]). apply plus_resp_leEq_both. apply plus_resp_leEq_both. apply AbsSmall_sqr. auto. apply AbsSmall_sqr. auto. apply less_leEq. apply div_resp_pos. apply pos_two. apply nexp_resp_pos. auto. Qed. Lemma LimCC_is_lim : forall s : CC_CauchySeq, CC_SeqLimit s (LimCC s). Proof. unfold CC_SeqLimit in |- *. unfold LimCC in |- *. intros s e H. cut (SeqLimit (seq_re s) (Lim (CC_Cauchy2re s))). unfold SeqLimit in |- *. intro H0. cut (SeqLimit (seq_im s) (Lim (CC_Cauchy2im s))). unfold SeqLimit in |- *. intro H1. cut ([0] [<] e [/]TwoNZ). intro H2. elim (H0 (e [/]TwoNZ) H2). unfold seq_re in |- *. intro N. intros H3. elim (H1 (e [/]TwoNZ) H2). unfold seq_im in |- *. intro N'. intros H4. cut {M : nat | N <= M | N' <= M}. intros H5. elim H5. clear H5. intro M. intros. exists M. intros. apply AbsSmall_AbsCC. auto. astepr (Re (CC_seq s m) [-]Lim (CC_Cauchy2re s)). apply H3. lia. astepr (Im (CC_seq s m) [-]Lim (CC_Cauchy2im s)). apply H4. lia. elim (le_lt_dec N N'); intros. exists N'; auto. exists N; auto with arith. apply div_resp_pos. apply pos_two. auto. apply Lim_Cauchy with (s := Build_CauchySeq IR (fun n : nat => Im (CC_seq s n)) (im_is_Cauchy s)). apply Lim_Cauchy with (s := Build_CauchySeq IR (fun n : nat => Re (CC_seq s n)) (re_is_Cauchy s)). Qed. Lemma CC_SeqLimit_uniq : forall (s : nat -> CC) (l l' : CC), CC_SeqLimit s l -> CC_SeqLimit s l' -> l [=] l'. Proof. unfold CC_SeqLimit in |- *. do 3 intro. intros H H0. apply cg_inv_unique_2. apply AbsCC_small_imp_eq. intros e H1. cut ([0] [<] e [/]ThreeNZ). intro H2. elim (H (e [/]ThreeNZ)). intro N. intros H3. elim (H0 (e [/]ThreeNZ)). intro N'. intros H4. cut {M : nat | N <= M | N' <= M}. intros H5. elim H5. clear H5. intro M. intros. apply leEq_less_trans with (AbsCC (s M[-]l) [+]AbsCC (s M[-]l')). apply leEq_wdl with (AbsCC ( [--] (s M[-]l) [+] (s M[-]l'))). apply leEq_wdr with (AbsCC [--] (s M[-]l) [+]AbsCC (s M[-]l')). apply triangle. algebra. apply AbsCC_wd. rational. rstepr (e [/]ThreeNZ[+]e [/]ThreeNZ[+]e [/]ThreeNZ). astepl ([0][+]AbsCC (s M[-]l) [+]AbsCC (s M[-]l')). apply plus_resp_less_leEq. apply plus_resp_less_leEq. auto. apply H3. auto. apply H4. auto. exists (Nat.max N N'); auto with arith. auto. auto. apply pos_div_three. auto. Qed. Lemma CC_SeqLimit_unq : forall (s : CC_CauchySeq) l, CC_SeqLimit s l -> l [=] LimCC s. Proof. intros. apply CC_SeqLimit_uniq with (CC_seq s). auto. apply LimCC_is_lim. Qed. (** ** Continuity for [CC] *) Section Continuity_for_CC. (** %\begin{convention}% Let [f : CC->CC]. %\end{convention}% *) Variable f : CC -> CC. (* (CSetoid_un_op CC). *) Definition CCfunLim (p l : CC) : CProp := forall e : IR, [0] [<] e -> {d : IR | [0] [<] d | forall x, AbsCC (p[-]x) [<=] d -> AbsCC (l[-]f x) [<=] e}. Definition CCcontinAt p : CProp := CCfunLim p (f p). Definition CCcontin : CProp := forall x : CC, CCcontinAt x. Lemma CCfunLim_SeqLimit : forall p l pn, CCfunLim p l -> CC_SeqLimit pn p -> CC_SeqLimit (fun n => f (pn n)) l. Proof. intros p l pn fl sl; unfold CC_SeqLimit in |- *. intros eps epos. elim (fl _ epos); intros del H H0. elim (sl _ H); intros N Nh. exists N. intros m leNm. apply leEq_wdl with (AbsCC (l[-]f (pn m))). apply H0. apply leEq_wdl with (AbsCC (pn m[-]p)). apply (Nh _ leNm). apply cc_minus_abs. apply cc_minus_abs. Qed. Definition f_seq (s : nat -> CC) (n : nat) : CC := f (s n). Lemma poly_pres_lim : CCcontin -> forall s : CC_CauchySeq, CC_SeqLimit (fun n => f (s n)) (f (LimCC s)). Proof. intros cp s. apply (CCfunLim_SeqLimit (LimCC s) (f (LimCC s))). unfold CCfunLim in |- *. intros e zlte. elim (cp (LimCC s) e zlte). intros d; exists d; auto. exact (LimCC_is_lim s). Qed. End Continuity_for_CC. Lemma seq_yields_zero : forall q : IR, [0] [<=] q -> q [<] [1] -> forall c : IR, [0] [<] c -> forall s, (forall i, AbsCC (s i) [<=] q[^]i[*]c) -> CC_SeqLimit s [0]. Proof. intros q zltq qlt1 c zltc s H. unfold CC_SeqLimit in |- *. intros e zlte. generalize (qi_lim_zero q zltq qlt1). intro Hqi. unfold SeqLimit in Hqi. elim (Hqi (e[/] c[//]pos_ap_zero _ c zltc)). intros N HN. exists N. intros m leNm. apply leEq_transitive with (q[^]m[*]c). astepl (AbsCC (s m)). apply H. generalize (HN m leNm). intro H0. unfold AbsSmall in H0. inversion_clear H0. rstepr ((e[/] c[//]pos_ap_zero IR c zltc) [*]c). apply mult_resp_leEq_rht. rstepl (q[^]m[-][0]). assumption. apply less_leEq. assumption. apply shift_less_div. assumption. rstepl ZeroR; assumption. Qed. corn-8.20.0/fta/CPoly_Contin1.v000066400000000000000000000114211473720167500161370ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.fta.CC_Props. (** * Continuity of complex polynomials *) Section Mult_CC_Continuous. Lemma mult_absCC : forall (x y : CC) (X Y : IR), AbsCC x [<=] X -> AbsCC y [<=] Y -> AbsCC (x[*]y) [<=] X[*]Y. Proof. intros. astepl (AbsCC x[*]AbsCC y). apply mult_resp_leEq_both. apply AbsCC_nonneg. apply AbsCC_nonneg. auto. auto. Qed. Lemma estimate_absCC : forall x : CC, {X : IR | [0] [<] X | AbsCC x [<=] X}. Proof. intros. exists (AbsCC x[+][1]). astepl ([0][+]ZeroR). apply plus_resp_leEq_less. apply AbsCC_nonneg. apply pos_one. astepl (AbsCC x[+][0]). apply less_leEq. apply plus_resp_less_lft. apply pos_one. Qed. Lemma mult_CC_contin : forall (x y : CC) (e : IR), [0] [<] e -> {c : IR | [0] [<] c | {d : IR | [0] [<] d | forall x' y', AbsCC (x[-]x') [<=] c -> AbsCC (y[-]y') [<=] d -> AbsCC (x[*]y[-]x'[*]y') [<=] e}}. Proof. do 3 intro. intro H. cut ([0] [<] e [/]TwoNZ). intro H0. elim (estimate_absCC x). intro X. intros H1 H2. elim (estimate_absCC y). intro Y. intros H3 H4. cut (Y[#][0]). intro H5. exists (e [/]TwoNZ[/] Y[//]H5). apply div_resp_pos. auto. auto. cut ([0] [<] X[+](e [/]TwoNZ[/] Y[//]H5)). intro. cut (X[+](e [/]TwoNZ[/] Y[//]H5)[#][0]). intro H7. exists (e [/]TwoNZ[/] X[+](e [/]TwoNZ[/] Y[//]H5)[//]H7). apply div_resp_pos. auto. auto. intros. apply leEq_wdl with (AbsCC ((x[-]x')[*]y[+]x'[*](y[-]y'))). apply leEq_transitive with (AbsCC ((x[-]x')[*]y)[+]AbsCC (x'[*](y[-]y'))). apply triangle. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). apply plus_resp_leEq_both. apply leEq_wdr with ((e [/]TwoNZ[/] Y[//]H5)[*]Y). apply mult_absCC; auto. rational. apply leEq_wdr with ((X[+](e [/]TwoNZ[/] Y[//]H5))[*] (e [/]TwoNZ[/] X[+](e [/]TwoNZ[/] Y[//]H5)[//]H7)). apply mult_absCC; auto. apply leEq_wdl with (AbsCC (x[+](x'[-]x))). apply leEq_transitive with (AbsCC x[+]AbsCC (x'[-]x)). apply triangle. apply plus_resp_leEq_both. auto. astepl (AbsCC [--](x'[-]x)). apply leEq_wdl with (AbsCC (x[-]x')). auto. apply AbsCC_wd. rational. apply AbsCC_wd. rational. rational. apply AbsCC_wd. rational. apply Greater_imp_ap. auto. apply plus_resp_pos; auto. apply div_resp_pos; auto. apply Greater_imp_ap. auto. apply pos_div_two. auto. Qed. End Mult_CC_Continuous. Section CPoly_CC_Continuous. (** %\begin{convention}% Let [g] be a polynomial over the complex numbers. %\end{convention}% *) Variable g : CCX. Lemma cpoly_CC_contin : forall (x : CC) (e : IR), [0] [<] e -> {d : IR | [0] [<] d | forall x', AbsCC (x[-]x') [<=] d -> AbsCC (g ! x[-]g ! x') [<=] e}. Proof. elim g. intros. exists OneR. intros. apply pos_one. intros. apply leEq_wdl with ZeroR. apply less_leEq. auto. cut ([0] [=] AbsCC ([0][-][0])). auto. Step_final (AbsCC [0]). intros a f. intro H. do 2 intro. intro H0. elim (mult_CC_contin x f ! x e H0). intro d1. intros H1 H2. elim H2. clear H2. intro c. intros H2 H3. elim (H x c H2). clear H. intro d2. intros H H4. exists (Min d1 d2). apply less_Min; auto. intros. simpl in |- *. cut (AbsCC (a[+]x[*]f ! x[-](a[+]x'[*]f ! x')) [<=] e). auto. apply leEq_wdl with (AbsCC (x[*]f ! x[-]x'[*]f ! x')). apply H3. clear H3. apply leEq_transitive with (Min d1 d2); auto. apply Min_leEq_lft. apply H4. clear H4. apply leEq_transitive with (Min d1 d2); auto. apply Min_leEq_rht. apply AbsCC_wd. rational. Qed. Lemma contin_polyCC : CCcontin (fun x => g ! x). Proof. unfold CCcontin in |- *. unfold CCcontinAt in |- *. unfold CCfunLim in |- *. intros. elim (cpoly_CC_contin x e); auto. intro d. intros H0 H1. exists d. auto. intros. apply H1; auto. Qed. End CPoly_CC_Continuous. corn-8.20.0/fta/CPoly_Rev.v000066400000000000000000000327661473720167500153770ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CPoly_Degree. Import CRing_Homomorphisms.coercions. From Coq Require Import Lia. (** * Reverse of polynomials *) Section Monomials. (** %\begin{convention}% Let [R] be a ring, and let [RX] be the polynomials over this ring. %\end{convention}% *) Variable R : CRing. (* begin hide *) Let RX := cpoly_cring R. (* end hide *) Fixpoint monom (a : R) (n : nat) {struct n} : cpoly_cring R := match n with | O => cpoly_linear _ a (cpoly_zero _) | S m => cpoly_linear _ [0] (monom a m) end. Lemma monom_coeff : forall (c : R) n, nth_coeff n (monom c n) [=] c. Proof. intros. induction n as [| n Hrecn]; intros. simpl in |- *. algebra. simpl in |- *. algebra. Qed. Lemma monom_coeff' : forall (c : R) m n, m <> n -> nth_coeff n (monom c m) [=] [0]. Proof. intros c m. induction m as [| m Hrecm]; intros. elim (O_or_S n); intro y. elim y. clear y. intros x y. rewrite <- y. simpl in |- *. algebra. elim (H y). elim (O_or_S n); intro y. elim y. clear y. intros x y. rewrite <- y. simpl in |- *. apply Hrecm. lia. rewrite <- y. simpl in |- *. algebra. Qed. Hint Resolve monom_coeff monom_coeff': algebra. Lemma monom_degree : forall (a : R) n, degree_le n (monom a n). Proof. unfold degree_le in |- *. intros. cut (n <> m). intro. algebra. lia. Qed. Lemma monom_S : forall (a : R) n, monom a (S n) [=] _X_[*]monom a n. Proof. intros. apply eq_transitive_unfolded with (cpoly_linear _ [0] (monom a n)). simpl in |- *. split. algebra. cut (monom a n [=] monom a n). auto. algebra. astepl (_X_[*]monom a n[+]_C_ [0]). Step_final (_X_[*]monom a n[+][0]). Qed. Hint Resolve monom_S: algebra. Lemma monom_wd_lft : forall (a b : R) n, a [=] b -> monom a n [=] monom b n. Proof. intros. induction n as [| n Hrecn]. simpl in |- *. split; auto. astepl (_X_[*]monom a n). Step_final (_X_[*]monom b n). Qed. Hint Resolve monom_wd_lft: algebra_c. Lemma monom_mult' : forall (a b : R) n, _C_ a[*]monom b n [=] monom (a[*]b) n. Proof. intros. induction n as [| n Hrecn]. simpl in |- *. split; algebra. astepl (_C_ a[*] (_X_[*]monom b n)). astepl (_C_ a[*]_X_[*]monom b n). astepl (_X_[*]_C_ a[*]monom b n). astepl (_X_[*] (_C_ a[*]monom b n)). Step_final (_X_[*]monom (a[*]b) n). Qed. Hint Resolve monom_mult': algebra. Lemma monom_mult : forall (a b : R) m n, monom a m[*]monom b n [=] monom (a[*]b) (m + n). Proof. intros. induction m as [| m Hrecm]; intros. replace (monom a 0) with (_C_ a). algebra. algebra. astepl (_X_[*]monom a m[*]monom b n). astepl (_X_[*] (monom a m[*]monom b n)). replace (S m + n) with (S (m + n)). Step_final (_X_[*]monom (a[*]b) (m + n)). auto. Qed. Lemma monom_sum : forall (p : RX) n, degree_le n p -> p [=] Sum 0 n (fun i => monom (nth_coeff i p) i). Proof. intros. unfold RX in |- *; apply all_nth_coeff_eq_imp. intros. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (Sum 0 n (fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) i0))). apply nth_coeff_sum with (p_ := fun i0 : nat => monom (nth_coeff i0 p) i0). elim (le_lt_dec i n); intros. apply eq_transitive_unfolded with (nth_coeff i (monom (nth_coeff i p) i)). apply Sum_term with (f := fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) i0)) (i := i). auto with arith. auto. intros. algebra. algebra. apply eq_transitive_unfolded with ([0]:R). apply Sum_zero. auto with arith. intros. cut (i0 <> i). intro. algebra. lia. algebra. Qed. End Monomials. #[global] Hint Resolve monom_coeff monom_coeff' monom_mult monom_sum: algebra. Arguments monom [R]. Section Poly_Reverse. Variable R : CRing. (* begin hide *) Let RX := cpoly_cring R. (* end hide *) Definition Rev (n : nat) (p : RX) := Sum 0 n (fun i => monom (nth_coeff i p) (n - i)). Lemma Rev_coeff : forall n p i, i <= n -> nth_coeff i (Rev n p) [=] nth_coeff (n - i) p. Proof. intros. unfold Rev in |- *. apply eq_transitive_unfolded with (Sum 0 n (fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) (n - i0)))). apply nth_coeff_sum with (p_ := fun i0 : nat => monom (nth_coeff i0 p) (n - i0)). apply eq_transitive_unfolded with (nth_coeff i (monom (nth_coeff (n - i) p) (n - (n - i)))). apply Sum_term with (i := n - i) (f := fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) (n - i0))). auto with arith. lia. intros. cut (n - j <> i). intro. algebra. lia. replace (n - (n - i)) with i. algebra. lia. Qed. Lemma Rev_coeff' : forall n p i, n < i -> nth_coeff i (Rev n p) [=] [0]. Proof. intros. unfold Rev in |- *. apply eq_transitive_unfolded with (Sum 0 n (fun i0 : nat => nth_coeff i (monom (nth_coeff i0 p) (n - i0)))). apply nth_coeff_sum with (p_ := fun i0 : nat => monom (nth_coeff (R:=R) i0 p) (n - i0)). apply Sum_zero. auto with arith. intros. cut (n - i0 <> i). intro. algebra. lia. Qed. Hint Resolve Rev_coeff Rev_coeff': algebra. Lemma Rev_wd : forall n p p', degree_le n p -> p [=] p' -> Rev n p [=] Rev n p'. Proof. unfold RX in |- *. intros. apply all_nth_coeff_eq_imp. intros. elim (le_lt_dec i n); intros. astepl (nth_coeff (n - i) p). Step_final (nth_coeff (n - i) p'). Step_final ([0]:R). Qed. Hint Resolve Rev_wd: algebra_c. Lemma Rev_rev : forall n p, degree_le n p -> Rev n (Rev n p) [=] p. Proof. unfold RX in |- *. intros. apply all_nth_coeff_eq_imp. intros. elim (le_lt_dec i n); intros. astepl (nth_coeff (n - i) (Rev n p)). pattern i at 2 in |- *. replace i with (n - (n - i)). apply Rev_coeff. lia. lia. unfold degree_le in H. Step_final ([0]:R). Qed. Hint Resolve Rev_rev: algebra. Lemma Rev_degree_le : forall n p, degree_le n (Rev n p). Proof. unfold degree_le in |- *. algebra. Qed. Lemma Rev_degree : forall n p, p ! [0] [#] [0] -> degree n (Rev n p). Proof. unfold degree_le in |- *. unfold degree in |- *. intros. split. astepl (nth_coeff (n - n) p). replace (n - n) with 0. astepl p ! [0]. auto. auto with arith. apply Rev_degree_le. Qed. Lemma Rev_monom : forall (c : R) m n, m <= n -> Rev n (monom c m) [=] monom c (n - m). Proof. intros. apply all_nth_coeff_eq_imp. intros. elim (le_lt_dec i n); intro y. astepl (nth_coeff (n - i) (monom c m)). elim (eq_nat_dec m (n - i)); intro H0. cut (i = n - m). intro y0. rewrite <- y0. rewrite H0. Step_final c. lia. cut (n - m <> i). intro. Step_final ([0]:R). lia. cut (n - m <> i). intro. Step_final ([0]:R). lia. Qed. Hint Resolve Rev_monom: algebra. Lemma Rev_zero : forall n, Rev n [0] [=] ([0]:RX). Proof. intros. apply all_nth_coeff_eq_imp. intros. elim (le_lt_dec i n); intros. astepl (nth_coeff (n - i) [0]:R). Step_final ([0]:R). Step_final ([0]:R). Qed. Hint Resolve Rev_zero: algebra. Lemma Rev_plus : forall p1 p2 n, Rev n (p1[+]p2) [=] Rev n p1[+]Rev n p2. Proof. intros. apply all_nth_coeff_eq_imp. intros. elim (le_lt_dec i n); intros. astepl (nth_coeff (n - i) (p1[+]p2)). unfold RX in |- *. astepl (nth_coeff (n - i) p1[+]nth_coeff (n - i) p2). Step_final (nth_coeff i (Rev n p1) [+]nth_coeff i (Rev n p2)). astepl ([0]:R). astepl ([0][+] ([0]:R)). Step_final (nth_coeff i (Rev n p1) [+]nth_coeff i (Rev n p2)). Qed. Hint Resolve Rev_plus: algebra. Lemma Rev_minus : forall p1 p2 n, Rev n (p1[-]p2) [=] Rev n p1[-]Rev n p2. Proof. intros. apply all_nth_coeff_eq_imp. intros. elim (le_lt_dec i n); intros. astepl (nth_coeff (n - i) (p1[-]p2)). unfold RX in |- *. astepl (nth_coeff (n - i) p1[-]nth_coeff (n - i) p2). Step_final (nth_coeff i (Rev n p1) [-]nth_coeff i (Rev n p2)). astepl ([0]:R). astepl ([0][-] ([0]:R)). Step_final (nth_coeff i (Rev n p1) [-]nth_coeff i (Rev n p2)). Qed. Hint Resolve Rev_minus: algebra. Lemma Rev_sum0 : forall a_ l n, Rev n (Sum0 l a_) [=] Sum0 l (fun i => Rev n (a_ i)). Proof. intros. induction l as [| l Hrecl]. replace (Sum0 0 a_) with ([0]:RX). replace (Sum0 0 (fun i : nat => Rev n (a_ i))) with ([0]:RX). algebra. auto. auto. replace (Sum0 (S l) a_) with (Sum0 l a_[+]a_ l). replace (Sum0 (S l) (fun i : nat => Rev n (a_ i))) with (Sum0 l (fun i : nat => Rev n (a_ i)) [+]Rev n (a_ l)). astepl (Rev n (Sum0 l a_) [+]Rev n (a_ l)). apply bin_op_wd_unfolded. auto. algebra. auto. auto. Qed. Hint Resolve Rev_sum0: algebra. Lemma Rev_sum : forall a_ k l n, Rev n (Sum k l a_) [=] Sum k l (fun i => Rev n (a_ i)). Proof. intros. unfold Sum in |- *. unfold Sum1 in |- *. astepl (Rev n (Sum0 (S l) a_) [-]Rev n (Sum0 k a_)). apply cg_minus_wd; apply Rev_sum0. Qed. Lemma Rev_mult : forall n1 n2 p1 p2, degree_le n1 p1 -> degree_le n2 p2 -> Rev (n1 + n2) (p1[*]p2) [=] Rev n1 p1[*]Rev n2 p2. Proof. intros. cut (degree_le (n1 + n2) (p1[*]p2)). intro. cut (p1[*]p2 [=] Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2)))). intro. cut (Rev (n1 + n2) (p1[*]p2) [=] Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 + n2 - (i1 + i2))))). intro. cut (Rev n1 p1 [=] Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1))). intro. cut (Rev n2 p2 [=] Sum 0 n2 (fun i2 : nat => monom (nth_coeff i2 p2) (n2 - i2))). intro. cut (Rev n1 p1[*]Rev n2 p2 [=] Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 + n2 - (i1 + i2))))). intro. Step_final (Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 + n2 - (i1 + i2))))). astepl (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1)) [*] Sum 0 n2 (fun i2 : nat => monom (nth_coeff i2 p2) (n2 - i2))). apply eq_transitive_unfolded with (Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1)) [*] monom (nth_coeff i2 p2) (n2 - i2))). apply eq_symmetric_unfolded. apply mult_distr_sum_lft with (f := fun i2 : nat => monom (nth_coeff i2 p2) (n2 - i2)). apply Sum_wd'. auto with arith. intro i2. intros. astepl (monom (nth_coeff i2 p2) (n2 - i2) [*] Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1))). apply eq_transitive_unfolded with (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i2 p2) (n2 - i2) [*]monom (nth_coeff i1 p1) (n1 - i1))). apply eq_symmetric_unfolded. apply mult_distr_sum_lft with (f := fun i1 : nat => monom (nth_coeff i1 p1) (n1 - i1)). apply Sum_wd'. auto with arith. intro i1. intros. astepl (monom (nth_coeff i1 p1) (n1 - i1) [*]monom (nth_coeff i2 p2) (n2 - i2)). astepl (monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (n1 - i1 + (n2 - i2))). replace (n1 - i1 + (n2 - i2)) with (n1 + n2 - (i1 + i2)). algebra. lia. unfold Rev in |- *. algebra. unfold Rev in |- *. algebra. astepl (Rev (n1 + n2) (Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2))))). apply eq_transitive_unfolded with (Sum 0 n2 (fun i2 : nat => Rev (n1 + n2) (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2))))). apply Rev_sum with (a_ := fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2))). apply Sum_wd'. auto with arith. intro i2. intros. apply eq_transitive_unfolded with (Sum 0 n1 (fun i1 : nat => Rev (n1 + n2) (monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2)))). apply Rev_sum with (a_ := fun i1 : nat => monom (nth_coeff i1 p1[*]nth_coeff i2 p2) (i1 + i2)). apply Sum_wd'. auto with arith. intro i1. intros. apply Rev_monom. lia. astepl (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) i1) [*] Sum 0 n2 (fun i2 : nat => monom (nth_coeff i2 p2) i2)). apply eq_transitive_unfolded with (Sum 0 n2 (fun i2 : nat => Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) i1) [*] monom (nth_coeff i2 p2) i2)). apply eq_symmetric_unfolded. apply mult_distr_sum_lft with (f := fun i2 : nat => monom (nth_coeff i2 p2) i2). apply Sum_wd'. auto with arith. intro i2. intros. astepl (monom (nth_coeff i2 p2) i2[*] Sum 0 n1 (fun i1 : nat => monom (nth_coeff i1 p1) i1)). apply eq_transitive_unfolded with (Sum 0 n1 (fun i1 : nat => monom (nth_coeff i2 p2) i2[*]monom (nth_coeff i1 p1) i1)). apply eq_symmetric_unfolded. apply mult_distr_sum_lft with (f := fun i1 : nat => monom (nth_coeff i1 p1) i1). apply Sum_wd'. auto with arith. intro i1. intros. Step_final (monom (nth_coeff i1 p1) i1[*]monom (nth_coeff i2 p2) i2). unfold RX in |- *. apply degree_le_mult; auto. Qed. End Poly_Reverse. #[global] Hint Resolve Rev_wd: algebra_c. #[global] Hint Resolve Rev_rev Rev_mult: algebra. Arguments Rev [R]. corn-8.20.0/fta/CPoly_Shift.v000066400000000000000000000150631473720167500157070ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.complex.CComplex. Import CRing_Homomorphisms.coercions. From Coq Require Import Lia. (** * Shifting polynomials This can be done for [CRings] in general, but we do it here only for [CC] because extensionality makes everything much easier, and we only need it for [CC]. *) Section Poly_Shifted. Definition Shift (a : CC) (p : CCX) := Sum 0 (lth_of_poly p) (fun i => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i). Lemma Shift_apply : forall a p (x : CC), (Shift a p) ! x [=] p ! (x[+]a). Proof. intros. unfold Shift in |- *. apply eq_transitive_unfolded with (Sum 0 (lth_of_poly p) (fun i : nat => (_C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i) ! x)). apply Sum_cpoly_ap with (f := fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i). apply eq_symmetric_unfolded. astepl (Sum 0 (lth_of_poly p) (fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i)) ! (x[+]a). apply eq_transitive_unfolded with (Sum 0 (lth_of_poly p) (fun i : nat => (_C_ (nth_coeff i p) [*]_X_[^]i) ! (x[+]a))). apply Sum_cpoly_ap with (f := fun i : nat => _C_ (nth_coeff i p) [*]_X_[^]i). apply Sum_wd. intros. astepl ((_C_ (nth_coeff i p)) ! (x[+]a) [*] (_X_[^]i) ! (x[+]a)). astepl (nth_coeff i p[*]_X_ ! (x[+]a) [^]i). astepl (nth_coeff i p[*] (x[+]a) [^]i). astepl (nth_coeff i p[*] (_X_ ! x[+] (_C_ a) ! x) [^]i). astepl (nth_coeff i p[*] (_X_[+]_C_ a) ! x[^]i). Step_final ((_C_ (nth_coeff i p)) ! x[*] ((_X_[+]_C_ a) [^]i) ! x). Qed. Hint Resolve Shift_apply: algebra. Lemma Shift_wdr : forall a p p', p [=] p' -> Shift a p [=] Shift a p'. Proof. intros. apply poly_CC_extensional. intros. astepl p ! (x[+]a). Step_final p' ! (x[+]a). Qed. Lemma Shift_shift : forall a p, Shift [--]a (Shift a p) [=] p. Proof. intros. apply poly_CC_extensional. intros. astepl (Shift a p) ! (x[+][--]a). astepl p ! (x[+][--]a[+]a). apply apply_wd. algebra. rational. Qed. Lemma Shift_mult : forall a p1 p2, Shift a (p1[*]p2) [=] Shift a p1[*]Shift a p2. Proof. intros. apply poly_CC_extensional. intros. astepl (p1[*]p2) ! (x[+]a). astepl (p1 ! (x[+]a) [*]p2 ! (x[+]a)). Step_final ((Shift a p1) ! x[*] (Shift a p2) ! x). Qed. Lemma Shift_degree_le : forall a p n, degree_le n p -> degree_le n (Shift a p). Proof. intros. unfold Shift in |- *. apply Sum_degree_le. auto with arith. intros. elim (le_lt_dec i n); intros. replace n with (0 + n). apply degree_le_mult. apply degree_le_c_. apply degree_le_mon with (1 * i). lia. apply degree_le_nexp. apply degree_imp_degree_le. apply degree_wd with (_C_ a[+]_X_). algebra. apply degree_plus_rht with 0. apply degree_le_c_. apply degree_x_. auto. auto. unfold degree_le in H. apply degree_le_wd with (_C_ ([0]:CC)). astepl ([0]:cpoly_cring CC). astepl ([0][*] (_X_[+]_C_ a) [^]i). apply bin_op_wd_unfolded. Step_final (_C_ ([0]:CC)). algebra. apply degree_le_mon with 0. auto with arith. apply degree_le_c_. Qed. Lemma Shift_monic : forall a p n, monic n p -> monic n (Shift a p). Proof. intros. unfold monic in H. elim H. clear H. intros H H0. unfold degree_le in H0. apply monic_wd with (Sum 0 n (fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i)). astepl (Sum 0 n (fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i) [+][0]). apply eq_transitive_unfolded with (Sum 0 n (fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i) [+] Sum (S n) (lth_of_poly p) (fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i)). apply bin_op_wd_unfolded. algebra. apply eq_symmetric_unfolded. apply Sum_zero. cut (n < lth_of_poly p). intro. auto with arith. apply lt_i_lth_of_poly. astepl ([1]:CC). algebra. intros. cut (n < i). intro. astepl (_C_ [0][*] (_X_[+]_C_ a) [^]i). Step_final ([0][*] (_X_[+]_C_ a) [^]i). auto with arith. unfold Shift in |- *. apply Sum_Sum. elim (O_or_S n); intro y. elim y. clear y. intros x y. rewrite <- y in H. rewrite <- y in H0. rewrite <- y. apply monic_wd with (Sum 0 x (fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i) [+] (_X_[+]_C_ a) [^]S x). apply eq_transitive_unfolded with (Sum 0 x (fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i) [+] _C_ (nth_coeff (S x) p) [*] (_X_[+]_C_ a) [^]S x). apply bin_op_wd_unfolded. algebra. astepl ([1][*] (_X_[+]_C_ a) [^]S x). apply bin_op_wd_unfolded. Step_final (_C_ ([1]:CC)). algebra. apply eq_symmetric_unfolded. apply Sum_last with (f := fun i : nat => _C_ (nth_coeff i p) [*] (_X_[+]_C_ a) [^]i). apply monic_plus with x. apply Sum_degree_le. auto with arith. intros. replace x with (0 + x). apply degree_le_mult. apply degree_le_c_. apply degree_le_mon with (1 * i). lia. apply degree_le_nexp. apply degree_imp_degree_le. apply degree_wd with (_C_ a[+]_X_). algebra. apply degree_plus_rht with 0. apply degree_le_c_. apply degree_x_. auto. auto. pattern (S x) at 1 in |- *. replace (S x) with (1 * S x). apply monic_nexp. apply monic_wd with (_C_ a[+]_X_). algebra. apply monic_plus with 0. apply degree_le_c_. apply monic_x_. auto. auto with arith. auto. rewrite <- y in H. rewrite <- y in H0. rewrite <- y. apply monic_wd with ([1]:CCX). unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. split. cut ([1] [=] nth_coeff 0 p[*][1][+][0]). auto. astepl (nth_coeff 0 p). rational. auto. apply monic_wd with (_C_ ([1]:CC)). algebra. apply monic_c_one. Qed. End Poly_Shifted. #[global] Hint Resolve Shift_wdr: algebra_c. #[global] Hint Resolve Shift_apply Shift_shift Shift_mult: algebra. corn-8.20.0/fta/FTA.v000066400000000000000000000174731473720167500141450ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.fta.CPoly_Rev. Require Export CoRN.fta.FTAreg. Import CRing_Homomorphisms.coercions. (** * Fundamental Theorem of Algebra %\begin{convention}% Let [n:nat] and [f] be a complex polynomial of degree [(S n)]. %\end{convention}% *) Section FTA_reg'. Variable f : cpoly_cring CC. Variable n : nat. Hypothesis f_degree : degree (S n) f. Lemma FTA_reg' : {f1 : CCX | degree 1 f1 | {f2 : CCX | degree n f2 | f [=] f1[*]f2}}. Proof. elim (FTA_reg f (S n)). intro c. intro H. cut (degree 1 (_X_[-]_C_ c)). intro. exists (_X_[-]_C_ c). auto. elim (poly_linear_factor _ _ _ H). intro f2. intros. exists f2. apply degree_mult_imp with (_X_[-]_C_ c) 1. auto. apply degree_wd with f; auto. auto. apply degree_minus_lft with 0. apply degree_le_c_. apply degree_x_. auto. auto with arith. auto. Qed. End FTA_reg'. (** %\begin{convention}% Let [n:nat], [f] be a complex polynomial of degree less than or equal to [(S n)] and [c] be a complex number such that [f!c [#] [0]]. %\end{convention}% *) Section FTA_1. Variable f : cpoly_cring CC. Variable n : nat. Hypothesis f_degree : degree_le (S n) f. Variable c : CC. Hypothesis f_c : f ! c [#] [0]. Lemma FTA_1a : degree_le (S n) (Shift c f). Proof. apply Shift_degree_le. auto. Qed. Let g := Rev (S n) (Shift c f). Lemma FTA_1b : degree (S n) g. Proof. unfold g in |- *. apply Rev_degree. astepl f ! c. auto. Step_final f ! ([0][+]c). Qed. Lemma FTA_1 : {f1 : CCX | {f2 : CCX | degree_le 1 f1 /\ degree_le n f2 /\ f [=] f1[*]f2}}. Proof. elim (FTA_reg' g n FTA_1b). intro g1. intros H H0. elim H0. clear H0. intro g2. intros H0 H1. cut (degree_le 1 g1). intro. cut (degree_le n g2). intro. exists (Shift [--]c (Rev 1 g1)). exists (Shift [--]c (Rev n g2)). split. apply Shift_degree_le. apply Rev_degree_le. split. apply Shift_degree_le. apply Rev_degree_le. cut (degree_le (1 + n) (g1[*]g2)). intro. cut (degree_le (1 + n) g). intro. cut (degree_le (1 + n) (Shift c f)). intro. astepl (Shift [--]c (Shift c f)). astepl (Shift [--]c (Rev (1 + n) (Rev (S n) (Shift c f)))). astepl (Shift [--]c (Rev (1 + n) g)). astepl (Shift [--]c (Rev (1 + n) (g1[*]g2))). Step_final (Shift [--]c (Rev 1 g1[*]Rev n g2)). exact FTA_1a. apply degree_le_wd with (g1[*]g2); algebra. apply degree_le_mult; auto. apply degree_imp_degree_le; auto. apply degree_imp_degree_le; auto. Qed. Lemma FTA_1' : {a : CC | {b : CC | {g : CCX | degree_le n g | f [=] (_C_ a[*]_X_[+]_C_ b) [*]g}}}. Proof. elim FTA_1. intro f1. intros H. elim H. clear H. intros f2 H0. elim H0. clear H0. intro H. intros H0. elim H0. clear H0. intros H0 H1. elim (degree_le_1_imp _ f1); auto. intro a. intros H2. exists a. elim H2. clear H2. intro b. intros. exists b. exists f2. auto. Step_final (f1[*]f2). Qed. End FTA_1. Section Fund_Thm_Alg. Lemma FTA' : forall n (f : CCX), degree_le n f -> nonConst _ f -> {z : CC | f ! z [=] [0]}. Proof. intro n. induction n as [| n Hrecn]. unfold nonConst in |- *. unfold degree_le in |- *. intros f H H0. elim H0. clear H0. intro n. intros H0 H1. elim (eq_imp_not_ap _ _ _ (H _ H0) H1). unfold nonConst in |- *. intros f H H0. elim H0. clear H0. intro m'. intros H0 H1. elim (poly_apzero_CC f). intro c. intros H2. elim (FTA_1' f n H c H2). intro a. intros H3. elim H3. clear H3. intro b. intros H3. elim H3. clear H3. intro g. intros H3 H4. elim (O_or_S m'); intro y. elim y. clear y. intro m. intro y. rewrite <- y in H0. rewrite <- y in H1. cut (a[*]nth_coeff m g [#] [0] or b[*]nth_coeff (S m) g [#] [0]). intro H5. elim H5; clear H5; intros H5. cut (a [#] [0]). intro H6. exists ( [--]b[/] a[//]H6). astepl ((_C_ a[*]_X_[+]_C_ b) [*]g) ! ( [--]b[/] a[//]H6). astepl ((_C_ a[*]_X_[+]_C_ b) ! ( [--]b[/] a[//]H6) [*]g ! ( [--]b[/] a[//]H6)). astepl (((_C_ a[*]_X_) ! ( [--]b[/] a[//]H6) [+] (_C_ b) ! ( [--]b[/] a[//]H6)) [*] g ! ( [--]b[/] a[//]H6)). astepl (((_C_ a) ! ( [--]b[/] a[//]H6) [*]_X_ ! ( [--]b[/] a[//]H6) [+]b) [*] g ! ( [--]b[/] a[//]H6)). astepl ((a[*] ( [--]b[/] a[//]H6) [+]b) [*]g ! ( [--]b[/] a[//]H6)). rational. apply cring_mult_ap_zero with (nth_coeff m g). auto. elim (Hrecn g); auto. intro z. intros. exists z. astepl ((_C_ a[*]_X_[+]_C_ b) [*]g) ! z. astepl ((_C_ a[*]_X_[+]_C_ b) ! z[*]g ! z). Step_final ((_C_ a[*]_X_[+]_C_ b) ! z[*][0]). unfold nonConst in |- *. exists (S m). auto. apply cring_mult_ap_zero_op with b. auto. apply cg_add_ap_zero. astepl (nth_coeff (S m) f). auto. Step_final (nth_coeff (S m) ((_C_ a[*]_X_[+]_C_ b) [*]g)). rewrite <- y in H0. elim (Nat.lt_irrefl 0 H0). apply nth_coeff_ap_zero_imp with m'. auto. Qed. Lemma FTA : forall f : CCX, nonConst _ f -> {z : CC | f ! z [=] [0]}. Proof. intros. elim (Cpoly_ex_degree _ f). intro n. intros. (* Set_ not necessary *) apply FTA' with n; auto. Qed. Lemma FTA_a_la_Henk : forall f : CCX, {x : CC | {y : CC | AbsCC (f ! x[-]f ! y) [>][0]}} -> {z : CC | f ! z [=] [0]}. Proof. intros f H. elim H. intros x H0. elim H0. intros y H1. pose (H1':=(CAnd_proj1 _ _ (greater_def _ _ _) H1)). clearbody H1'. clear H1. rename H1' into H1. generalize (less_imp_ap _ _ _ H1); intro H2. generalize (AbsCC_ap_zero _ H2); intro H3. cut (Sum 0 (lth_of_poly f) (fun i : nat => nth_coeff i f[*] (x[^]i[-]y[^]i)) [#] [0]). intro H4. assert (0 <= lth_of_poly f) as H5 by auto with zarith. generalize (Sum_apzero _ _ _ _ H5 H4); intro H6. elim H6; intros i H8 H9. elim H8; intros H10 H11. apply FTA. unfold nonConst in |- *. generalize (cring_mult_ap_zero _ _ _ H9); intro H12. exists i. elim (zerop i). intro H13. exfalso. elim (ap_irreflexive_unfolded _ ([0]:CC)). rstepl (nth_coeff i f[*] (x[^]0[-]y[^]0)). rewrite <- H13. assumption. auto. assumption. apply ap_wdl_unfolded with (Sum 0 (lth_of_poly f) (fun i : nat => nth_coeff i f[*]x[^]i[-]nth_coeff i f[*]y[^]i)). 2: apply Sum_wd. 2: intro. 2: algebra. apply ap_wdl_unfolded with (Sum 0 (lth_of_poly f) (fun i : nat => nth_coeff i f[*]x[^]i) [-] Sum 0 (lth_of_poly f) (fun i : nat => nth_coeff i f[*]y[^]i)). 2: apply eq_symmetric_unfolded. 2: change (Sum 0 (lth_of_poly f) (fun j : nat => (fun i : nat => nth_coeff i f[*]x[^]i) j[-] (fun i : nat => nth_coeff i f[*]y[^]i) j) [=] Sum 0 (lth_of_poly f) (fun i : nat => nth_coeff i f[*]x[^]i) [-] Sum 0 (lth_of_poly f) (fun i : nat => nth_coeff i f[*]y[^]i)) in |- *. 2: apply Sum_minus_Sum. apply ap_wdl_unfolded with (f ! x[-]f ! y). 2: unfold cg_minus in |- *. 2: apply csbf_wd_unfolded. 2: apply poly_as_sum. 2: apply poly_degree_lth. 2: apply csf_wd_unfolded. 2: apply poly_as_sum. 2: apply poly_degree_lth. assumption. Qed. End Fund_Thm_Alg. corn-8.20.0/fta/FTAreg.v000066400000000000000000000406201473720167500146310ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.fta.KneserLemma. Require Export CoRN.fta.CPoly_Shift. Require Export CoRN.fta.CPoly_Contin1. From Coq Require Import Lia. (** * FTA for regular polynomials ** The Kneser sequence %\begin{convention}% Let [n] be a positive natural number. %\end{convention}% *) Section Seq_Exists. Variable n : nat. Hypothesis lt0n : 0 < n. (** %\begin{convention}% Let [qK] be a real between 0 and 1, with [[ forall (p : CCX), (monic n p) -> forall (c : IR), ((AbsCC (p![0])) [<] c) -> {z:CC | ((AbsCC z) [^]n [<] c) | ((AbsCC (p!z)) [<] qK[*]c)}. ]] Let [p] be a monic polynomial over the complex numbers with degree [n], and let [c0] be such that [(AbsCC (p![0])) [<] c0]. %\end{convention}% *) Section Kneser_Sequence. Variable qK : IR. Variable zltq : [0] [<=] qK. Variable qlt1 : qK [<] [1]. Hypothesis q_prop : forall p : cpoly CC, monic n p -> forall c : IR, AbsCC p ! [0] [<] c -> {z : CC | AbsCC z[^]n [<=] c | AbsCC p ! z [<] qK[*]c}. Variable p : cpoly CC. Hypothesis mp : monic n p. Variable c0 : IR. Hypothesis p0ltc0 : AbsCC p ! [0] [<] c0. Record Knes_tup : Type := {z_el :> CC; c_el : IR; Kt_prop : AbsCC p ! z_el [<] c_el}. Record Knes_tupp (tup : Knes_tup) : Type := {Kntup :> Knes_tup; Ktp_prop : c_el Kntup [=] qK[*]c_el tup; Ktpp_prop : AbsCC (Kntup[-]tup) [^]n [<=] c_el tup}. Definition Knes_fun : forall tup : Knes_tup, Knes_tupp tup. Proof. intro tup. elim tup. intros z c pzltc. cut (AbsCC (Shift z p) ! [0] [<] c). intro Hsh. generalize (q_prop (Shift z p) (Shift_monic z p n mp) c Hsh). intro Hex. elim Hex. intros z'; intros. cut (AbsCC p ! (z'[+]z) [<] qK[*]c). intro HH. apply (Build_Knes_tupp (Build_Knes_tup z c pzltc) (Build_Knes_tup (z'[+]z) (qK[*]c) HH)). simpl in |- *; algebra. simpl in |- *; apply leEq_wdl with (AbsCC z'[^]n). assumption. apply (nexp_wd IR (AbsCC z') (AbsCC (z'[+]z[-]z)) n). apply AbsCC_wd. rational. apply less_wdl with (AbsCC (Shift z p) ! z'). assumption. apply AbsCC_wd. apply Shift_apply. apply less_wdl with (AbsCC p ! z). assumption. generalize (Shift_apply z p [0]). intro H3. apply eq_symmetric_unfolded. apply AbsCC_wd. apply eq_transitive_unfolded with p ! ([0][+]z). assumption. algebra. Defined. Fixpoint Knes_fun_it (i : nat) : Knes_tup := match i with | O => Build_Knes_tup [0] c0 p0ltc0 | S j => Knes_fun (Knes_fun_it j):Knes_tup end. Definition sK := Knes_fun_it:nat -> CC. Lemma sK_c : forall tup : Knes_tup, c_el (Knes_fun tup) [=] qK[*]c_el tup. Proof. intro tup. generalize (Ktp_prop tup (Knes_fun tup)). auto. Qed. Lemma sK_c0 : forall i : nat, c_el (Knes_fun_it i) [=] qK[^]i[*]c0. Proof. simple induction i. simpl in |- *. rational. intros. simpl in |- *. generalize (sK_c (Knes_fun_it n0)). intro H1. apply eq_transitive_unfolded with (qK[*]c_el (Knes_fun_it n0)). assumption. rstepr (qK[*] (nexp IR n0 qK[*]c0)). apply mult_wdr. exact H. Qed. Lemma sK_prop1 : forall i : nat, AbsCC p ! (sK i) [<=] qK[^]i[*]c0. Proof. unfold sK in |- *. simple induction i. simpl in |- *. rstepr c0. apply less_leEq; exact p0ltc0. intros. simpl in |- *. generalize (Kt_prop (Knes_fun (Knes_fun_it n0))). intro H2. apply leEq_wdr with (c_el (Knes_fun (Knes_fun_it n0))). apply less_leEq; assumption. generalize (sK_c (Knes_fun_it n0)). intro H3. eapply eq_transitive_unfolded. apply H3. generalize (sK_c0 n0). intro H4. rstepr (qK[*] (nexp IR n0 qK[*]c0)). apply mult_wdr. exact H4. Qed. Lemma sK_it : forall tup : Knes_tup, AbsCC (Knes_fun tup[-]tup) [^]n [<=] c_el tup. Proof. intro tup. generalize (Ktpp_prop tup (Knes_fun tup)). auto. Qed. Lemma sK_prop2 : forall i : nat, AbsCC (sK (S i) [-]sK i) [^]n [<=] qK[^]i[*]c0. Proof. unfold sK in |- *. simpl in |- *. intro i. generalize (sK_it (Knes_fun_it i)). intro H0. eapply leEq_wdr. apply H0. exact (sK_c0 i). Qed. End Kneser_Sequence. Section Seq_Exists_Main. (** ** Main results *) Lemma seq_exists : {q : IR | [0] [<=] q | q [<] [1] and (forall p : cpoly CC, monic n p -> forall c : IR, AbsCC p ! [0] [<] c -> {s : nat -> CC | forall i, AbsCC p ! (s i) [<=] q[^]i[*]c /\ AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c})}. Proof. elim (Kneser n lt0n). intros q; intros H H0. exists q. assumption. inversion_clear H0. rename X0 into H2. split. assumption. intros p mp c pzltc. exists (sK q H2 p mp c pzltc). split. exact (sK_prop1 q H2 p mp c pzltc i). exact (sK_prop2 q H2 p mp c pzltc i). Qed. End Seq_Exists_Main. End Seq_Exists. Section N_Exists. Variable n : nat. Hypothesis lt0n : 0 < n. Variable q : IR. Hypothesis zleq : [0] [<=] q. Hypothesis qlt1 : q [<] [1]. Variable c : IR. Hypothesis zltc : [0] [<] c. (* begin hide *) Let q_ : q[-][1] [#] [0] := qltone IR q qlt1. (* end hide *) Variable e : IR. Variable zlte : [0] [<] e. Lemma N_exists : {N : nat | forall m, N <= m -> (q[^]m[-]q[^]N[/] q[-][1][//]q_) [*]c [<=] e}. Proof. cut ([0] [<] [1][-]q). intro H0. cut ([1][-]q [#] [0]). intro H3. cut (c [#] [0]). intro H1. cut ([0] [<] ([1][-]q) [*] (e[/] c[//]H1)). intro H2. elim (qi_yields_zero q zleq qlt1 (([1][-]q) [*] (e[/] c[//]H1)) H2). intros N HN. exists N. intros m leNm. rstepl ((q[^]N[-]q[^]m[/] [1][-]q[//]H3) [*]c). apply shift_mult_leEq with H1. assumption. apply shift_div_leEq'. assumption. apply leEq_transitive with (q[^]N). rstepl ([0][+] (q[^]N[-]q[^]m)). apply shift_plus_leEq. rstepr (q[^]m). apply nexp_resp_nonneg. assumption. assumption. apply mult_resp_pos. assumption. apply div_resp_pos. assumption. assumption. apply ap_symmetric_unfolded. apply less_imp_ap. assumption. apply ap_symmetric_unfolded. apply less_imp_ap. assumption. apply shift_less_minus. rstepl q. assumption. Qed. End N_Exists. Section Seq_is_CC_CAuchy. (** ** The Kneser sequence is Cauchy in [CC] *) Variable n : nat. Hypothesis lt0n : 0 < n. Variable q : IR. Hypothesis zleq : [0] [<=] q. Hypothesis qlt1 : q [<] [1]. Variable c : IR. Hypothesis zltc : [0] [<] c. (** %\begin{convention}% Let: - [q_] prove [q[-][1] [#] [0]] - [nrtq := NRoot q n] - [nrtc := Nroot c n] - [nrtqlt1] prove [nrtq [<] [1]] - [nrtq_] prove [nrtq[-][1] [#] [0]] %\end{convention}% *) (* begin hide *) Let q_ : q[-][1] [#] [0] := qltone IR q qlt1. Let nrtq : IR := NRoot zleq lt0n. Let nrtc : IR := NRoot (less_leEq _ _ _ zltc) lt0n. Let nrtqlt1 : nrtq [<] [1] := NRoot_less_one q zleq n lt0n qlt1. Let nrtq_ : nrtq[-][1] [#] [0] := qltone IR nrtq nrtqlt1. (* end hide *) Lemma zlt_nrtq : [0] [<=] nrtq. Proof. unfold nrtq; apply NRoot_nonneg. Qed. Lemma zlt_nrtc : [0] [<] nrtc. Proof. unfold nrtc; apply NRoot_pos; auto. Qed. Lemma nrt_pow : forall i (H : [0] [<=] q[^]i[*]c), NRoot H lt0n [=] nrtq[^]i[*]nrtc. Proof. intros. apply root_unique with n. apply NRoot_nonneg. apply mult_resp_nonneg. apply nexp_resp_nonneg. exact zlt_nrtq. apply less_leEq. exact zlt_nrtc. auto. astepl (q[^]i[*]c). astepr ((nrtq[^]i) [^]n[*]nrtc[^]n). astepr (nrtq[^] (i * n) [*]nrtc[^]n). rewrite Nat.mul_comm. astepr ((nrtq[^]n) [^]i[*]nrtc[^]n). unfold nrtq in |- *. unfold nrtc in |- *. apply bin_op_wd_unfolded. apply un_op_wd_unfolded. algebra. algebra. Qed. Lemma abs_pow_ltRe : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> forall i, AbsIR (Re (s (S i)) [-]Re (s i)) [<=] nrtq[^]i[*]nrtc. Proof. intros s H i. apply leEq_wdl with (AbsIR (Re (s (S i) [-]s i))). apply leEq_transitive with (AbsCC (s (S i) [-]s i)). apply absCC_absIR_re. generalize (H i). intro Hi. cut ([0] [<=] q[^]i[*]c). intro H0. cut (AbsCC (s (S i) [-]s i) [<=] NRoot H0 lt0n). intro H1. apply leEq_wdr with (NRoot H0 lt0n). assumption. apply nrt_pow. apply power_cancel_leEq with n. auto with arith. apply NRoot_nonneg. apply leEq_wdr with (q[^]i[*]c). exact (H i). algebra. apply mult_resp_nonneg. apply nexp_resp_nonneg. assumption. apply less_leEq; assumption. apply ABSIR_wd. apply Re_resp_inv. Qed. Lemma abs_pow_ltIm : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> forall i, AbsIR (Im (s (S i)) [-]Im (s i)) [<=] nrtq[^]i[*]nrtc. Proof. intros s H i. apply leEq_wdl with (AbsIR (Im (s (S i) [-]s i))). apply leEq_transitive with (AbsCC (s (S i) [-]s i)). apply absCC_absIR_im. generalize (H i). intro Hi. cut ([0] [<=] q[^]i[*]c). intro H0. cut (AbsCC (s (S i) [-]s i) [<=] NRoot H0 lt0n). intro H1. apply leEq_wdr with (NRoot H0 lt0n). assumption. apply nrt_pow. apply power_cancel_leEq with n. auto with arith. apply NRoot_nonneg. apply leEq_wdr with (q[^]i[*]c). exact (H i). algebra. apply mult_resp_nonneg. apply nexp_resp_nonneg. assumption. apply less_leEq; assumption. apply ABSIR_wd. apply Im_resp_inv. Qed. Lemma SublemmaRe : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> forall N m, N <= m -> AbsIR (Re (s m) [-]Re (s N)) [<=] (nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc. Proof. intros s Hi N m leNm. elim (le_lt_eq_dec N m leNm). intro ltNm. generalize (diff_is_sum (fun j : nat => Re (s j)) N m ltNm). intro Hsum. generalize (ABSIR_wd _ _ Hsum). (* Use AbsIR_wd *) intro Habseq. apply leEq_wdl with (ABSIR (Sum N (pred m) (fun i : nat => Re (s (S i)) [-]Re (s i)))). 2: apply eq_symmetric_unfolded; apply Habseq. cut (N <= S (pred m)). intro leNm'. (* FIXME was 2:Lia *) 2: clear nrtq_ nrtqlt1 nrtc nrtq; lia. generalize (triangle_SumIR N (pred m) (fun i : nat => Re (s (S i)) [-]Re (s i)) leNm'). intro Htri. apply leEq_transitive with (Sum N (pred m) (fun i : nat => csf_fun IR IR AbsIR (Re (s (S i)) [-]Re (s i)))). exact Htri. generalize (Sum_pres_leEq (fun i : nat => AbsIR (Re (s (S i)) [-]Re (s i))) (fun i : nat => nrtq[^]i[*]nrtc) (abs_pow_ltRe s Hi) N ( pred m)). intro Hlt. apply leEq_transitive with (Sum N (pred m) (fun i : nat => nrtq[^]i[*]nrtc)). cut (N <= pred m). intro leNpm. exact (Hlt leNpm). generalize (Nat.lt_succ_pred N m ltNm). intro Heq. symmetry in Heq. apply Nat.lt_succ_r. rewrite <- Heq. assumption. generalize (Sum_c_exp nrtq nrtq_ N (pred m)). intro Hs. generalize (Sum_comm_scal (fun i : nat => nrtq[^]i) nrtc N (pred m)). intro Hs2. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Hs2. apply mult_resp_leEq_rht. generalize (Sum_c_exp nrtq nrtq_ N (pred m)). intro Hs3. cut (S (pred m) = m). intro Heq. rewrite Heq in Hs3. apply eq_imp_leEq; assumption. generalize (Nat.lt_succ_pred N m ltNm). auto. exact (less_leEq _ _ _ zlt_nrtc). intro HNm. rewrite HNm. apply leEq_wdl with (AbsIR [0]). apply leEq_wdl with ZeroR. apply leEq_wdr with ZeroR. exact (leEq_reflexive _ _). rational. apply eq_symmetric_unfolded; exact AbsIRz_isz. apply ABSIR_wd. rational. Qed. Lemma SublemmaIm : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> forall N m, N <= m -> AbsIR (Im (s m) [-]Im (s N)) [<=] (nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc. Proof. intros s Hi N m leNm. elim (le_lt_eq_dec N m leNm). intro ltNm. generalize (diff_is_sum (fun j : nat => Im (s j)) N m ltNm). intro HSum. generalize (ABSIR_wd _ _ HSum). (* Use AbsIR_wd *) intro Habseq. apply leEq_wdl with (ABSIR (Sum N (pred m) (fun i : nat => Im (s (S i)) [-]Im (s i)))). 2: apply eq_symmetric_unfolded; apply Habseq. cut (N <= S (pred m)). intro leNm'. (* FIXME was 2:Lia *) 2: clear nrtq_ nrtqlt1 nrtc nrtq; lia. generalize (triangle_SumIR N (pred m) (fun i : nat => Im (s (S i)) [-]Im (s i)) leNm'). intro Htri. apply leEq_transitive with (Sum N (pred m) (fun i : nat => csf_fun IR IR AbsIR (Im (s (S i)) [-]Im (s i)))). exact Htri. generalize (Sum_pres_leEq (fun i : nat => AbsIR (Im (s (S i)) [-]Im (s i))) (fun i : nat => nrtq[^]i[*]nrtc) (abs_pow_ltIm s Hi) N ( pred m)). intro Hlt. apply leEq_transitive with (Sum N (pred m) (fun i : nat => nrtq[^]i[*]nrtc)). cut (N <= pred m). intro leNpm. exact (Hlt leNpm). generalize (Nat.lt_succ_pred N m ltNm). intro Heq. symmetry in Heq. apply Nat.lt_succ_r. simpl in |- *. rewrite <- Heq. assumption. generalize (Sum_c_exp nrtq nrtq_ N (pred m)). intro Hs. generalize (Sum_comm_scal (fun i : nat => nrtq[^]i) nrtc N (pred m)). intro Hs2. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Hs2. apply mult_resp_leEq_rht. generalize (Sum_c_exp nrtq nrtq_ N (pred m)). intro Hs3. cut (S (pred m) = m). intro Heq. rewrite Heq in Hs3. apply eq_imp_leEq; assumption. generalize (Nat.lt_succ_pred N m ltNm). auto. exact (less_leEq _ _ _ zlt_nrtc). intro HNm. rewrite HNm. apply leEq_wdl with (AbsIR [0]). apply leEq_wdl with ZeroR. apply leEq_wdr with ZeroR. exact (leEq_reflexive _ _). rational. apply eq_symmetric_unfolded; exact AbsIRz_isz. apply ABSIR_wd. rational. Qed. Lemma seq_is_CC_Cauchy : forall s, (forall i, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*]c) -> CC_Cauchy_prop s. Proof. unfold CC_Cauchy_prop in |- *. split. (* Prove (Cauchy_prop (seq_re s)) *) unfold Cauchy_prop in |- *. intros e zlte. generalize (N_exists (*n lt0n*) nrtq zlt_nrtq nrtqlt1 nrtc zlt_nrtc e zlte). intro Hex. elim Hex. intros N HN. exists N. intros m leNm. apply AbsIR_imp_AbsSmall. generalize (SublemmaRe s H N m leNm). intro H2. generalize (HN m leNm). intro H3. eapply leEq_transitive. 2: apply H3. rstepr ((nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc). exact H2. (* Prove (Cauchy_prop (seq_im s)) *) unfold Cauchy_prop in |- *. intros e zlte. generalize (N_exists (*n lt0n*) nrtq zlt_nrtq nrtqlt1 nrtc zlt_nrtc e zlte). intro Hex. elim Hex. intros N HN. exists N. intros m leNm. apply AbsIR_imp_AbsSmall. generalize (SublemmaIm s H N m leNm). intro H2. generalize (HN m leNm). intro H3. eapply leEq_transitive. 2: apply H3. rstepr ((nrtq[^]m[-]nrtq[^]N[/] nrtq[-][1][//]nrtq_) [*]nrtc). exact H2. Qed. End Seq_is_CC_CAuchy. Lemma FTA_monic : forall (p : cpoly CC) (n : nat), 0 < n -> monic n p -> {c : CC | p ! c [=] [0]}. Proof. intros p n H0n mon. generalize (seq_exists n H0n). intro H. elim H. intros q qnonneg Hq1. elim Hq1. intros qlt10 Hq2. generalize (Hq2 p mon). intro Hq3. cut ([0] [<] AbsCC p ! [0][+][1]). intro Hp. elim (Hq3 (AbsCC p ! [0][+][1])). intros s Hs. cut (forall i : nat, AbsCC (s (S i) [-]s i) [^]n [<=] q[^]i[*] (AbsCC p ! [0][+][1])). intro Hs2. cut (CC_Cauchy_prop s). intro Hs3. exists (LimCC (Build_CC_CauchySeq s Hs3)). apply CC_SeqLimit_uniq with (fun n : nat => p ! (s n)). exact (poly_pres_lim (fun x : CC => p ! x) (contin_polyCC p) (Build_CC_CauchySeq s Hs3)). generalize (seq_yields_zero q qnonneg qlt10 (AbsCC p ! [0][+][1]) Hp (fun n0 : nat => p ! (s n0))). intro H0. apply H0. intro i. generalize (Hs i). intro H1; inversion_clear H1; assumption. exact (seq_is_CC_Cauchy n H0n q qnonneg qlt10 (AbsCC p ! [0][+][1]) Hp s Hs2). intro i; generalize (Hs i); intro Ha; elim Ha; intros; assumption. exact (less_plusOne _ (AbsCC p ! [0])). apply zero_lt_posplus1. apply AbsCC_nonneg. Qed. Lemma FTA_reg : forall (p : cpoly CC) (n : nat), 0 < n -> degree n p -> {c : CC | p ! c [=] [0]}. Proof. intros p n H H0. elim (FTA_monic (poly_norm _ p n H0) n); auto. intros. exists x. apply poly_norm_apply with n H0; auto. apply poly_norm_monic; auto. Qed. corn-8.20.0/fta/KeyLemma.v000066400000000000000000000324001473720167500152220ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) From Coq Require Export ZArith. From Coq Require Export Compare. Require Export CoRN.reals.NRootIR. From Coq Require Import Lia. (** printing p3m %\ensuremath{\frac13\hat{\ }}% *) (** printing Halfeps %\ensuremath{\frac\varepsilon2}% *) (** * Technical lemmas for the FTA ** Key Lemma *) Section Key_Lemma. (** %\begin{convention}% Let [a:nat->IR] and [n:nat] such that [0 < n], [forall (k : nat) ([0] [<=] (a k))], [(a n) [=] [1]] and [a_0 : IR], and [eps : IR] such that [([0] [<] eps)] and [(eps [<=] a_0)]. %\end{convention}% *) Variable a : nat -> IR. Variable n : nat. Hypothesis gt_n_0 : 0 < n. Variable eps : IR. Hypothesis eps_pos : [0] [<] eps. Hypothesis a_nonneg : forall k : nat, [0] [<=] a k. Hypothesis a_n_1 : a n [=] [1]. Variable a_0 : IR. Hypothesis eps_le_a_0 : eps [<=] a_0. Lemma a_0_eps_nonneg : [0] [<=] a_0[-]eps. Proof. apply shift_leEq_minus. astepl eps; auto. Qed. Lemma a_0_eps_fuzz : a_0[-]eps [<] a_0. Proof. astepr (a_0[-][0]). apply minus_resp_less_rht. apply eps_pos. Qed. Lemma lem_1a : n - (n - 1) = 1. Proof. cut (1 <= n). lia. auto with arith. Qed. Lemma lem_1b : forall n j : nat, n - S j <= n - j. Proof. intros. lia. Qed. Lemma lem_1c : forall n j : nat, n - j <= n. Proof. intros. lia. Qed. Lemma lem_1 : {t : IR | [0] [<=] t | {k : nat | 1 <= k /\ k <= n /\ a k[*]t[^]k [=] a_0[-]eps /\ (forall i, 1 <= i -> i <= n -> a i[*]t[^]i [<=] a_0)}}. Proof. cut (forall j : nat, let l := n - j in 1 <= l -> l <= n -> {t : IR | [0] [<=] t | {k : nat | l <= k /\ k <= n /\ a k[*]t[^]k [=] a_0[-]eps /\ (forall i : nat, l <= i -> i <= n -> a i[*]t[^]i [<=] a_0)}}). intro H. rewrite <- lem_1a. apply H; rewrite lem_1a; auto with arith. intro j. induction j as [| j Hrecj]. replace (n - 0) with n. 2: auto with arith. intros l H H0. exists (NRoot a_0_eps_nonneg gt_n_0). apply NRoot_nonneg. exists n. split. auto. split. auto. split. astepl ([1][*]NRoot a_0_eps_nonneg gt_n_0[^]n). Step_final (NRoot a_0_eps_nonneg gt_n_0[^]n). intros i H1 H2. replace i with n. 2: apply Nat.le_antisymm; auto. astepl ([1][*]NRoot a_0_eps_nonneg gt_n_0[^]n). astepl (NRoot a_0_eps_nonneg gt_n_0[^]n). astepl (a_0[-]eps). apply less_leEq; apply a_0_eps_fuzz. intros l H H0. cut (1 <= n - j). intro H1. 2: apply Nat.le_trans with (n - S j); [ auto | apply lem_1b ]. cut (n - j <= n). intro H2. 2: apply lem_1c. elim (Hrecj H1 H2). intros t' H4 H5. elim H5. intros k' H6. elim H6. intros H7 H8. elim H8. intros H9 H10. elim H10. intros H11 H12. clear H10 H8 H6 H5. elim (less_cotransitive_unfolded _ _ _ a_0_eps_fuzz (a (n - S j) [*]t'[^] (n - S j))); intro H14. cut ([0] [<] a (n - S j)). intro H15. cut (a (n - S j) [#] [0]). intro H16. 2: apply pos_ap_zero; auto. cut ([0] [<=] (a_0[-]eps[/] a (n - S j) [//]H16)). intro H17. cut (0 < n - S j). intro H18. 2: auto with arith. exists (NRoot H17 H18). apply NRoot_nonneg. exists (n - S j). split. auto. split. auto. split. astepl (a (n - S j) [*] (a_0[-]eps[/] a (n - S j) [//]H16)). rational. intros i H19 H20. elim (le_lt_eq_dec _ _ H19); intro H22. apply leEq_transitive with (a i[*]t'[^]i). apply mult_resp_leEq_lft. apply power_resp_leEq. apply NRoot_nonneg. apply power_cancel_leEq with (n - S j); auto. astepl (a_0[-]eps[/] a (n - S j) [//]H16). apply shift_div_leEq. auto. astepr (a (n - S j) [*]t'[^] (n - S j)). apply less_leEq; auto. apply a_nonneg. apply H12. replace (n - j) with (S (n - S j)); [auto with arith|]. rewrite <- Nat.sub_succ_l; auto with arith. auto. rewrite <- H22. astepl (a (n - S j) [*] (a_0[-]eps[/] a (n - S j) [//]H16)). astepl (a_0[-]eps). apply less_leEq; apply a_0_eps_fuzz. apply shift_leEq_div; auto. astepl ZeroR; apply a_0_eps_nonneg. cut ([0] [<] a (n - S j) [*]t'[^] (n - S j)). intro H15. 2: apply leEq_less_trans with (a_0[-]eps); auto. 2: apply a_0_eps_nonneg. apply leEq_not_eq. apply a_nonneg. apply ap_symmetric_unfolded. exact (cring_mult_ap_zero _ _ _ (pos_ap_zero _ _ H15)). exists t'. auto. exists k'. split. apply Nat.le_trans with (n - j). unfold l in |- *; apply lem_1b. auto. split. auto. split. auto. intros i H15 H16. elim (le_lt_eq_dec _ _ H15); intro H18. apply H12. replace (n - j) with (S (n - S j)); [auto with arith|]. rewrite <- Nat.sub_succ_l; auto with arith. auto. rewrite <- H18. apply less_leEq; auto. Qed. Definition p3m (i : nat) := ([1] [/]ThreeNZ) [^]i:IR. Lemma p3m_pos : forall i : nat, [0] [<] p3m i. Proof. intros. unfold p3m in |- *. apply nexp_resp_pos. apply div_resp_pos. apply pos_three. apply pos_one. Qed. Lemma p3m_S : forall i : nat, p3m (S i) [=] p3m i [/]ThreeNZ. Proof. intros. unfold p3m in |- *. astepl (([1] [/]ThreeNZ) [^]i[*] ([1] [/]ThreeNZ:IR)). rational. Qed. Hint Resolve p3m_S: algebra. Lemma p3m_P : forall i : nat, p3m i [=] p3m (S i) [*]Three. Proof. intros. Step_final (p3m i [/]ThreeNZ[*]Three). Qed. Lemma p3m_aux : forall i j : nat, p3m (S i) [^]j [=] p3m j[*]p3m i[^]j. Proof. intros. unfold p3m in |- *. astepl (([1] [/]ThreeNZ) [^] (S i * j):IR). replace (S i * j) with (j + i * j). Step_final (([1] [/]ThreeNZ) [^]j[*] ([1] [/]ThreeNZ) [^] (i * j):IR). reflexivity. Qed. Lemma p3m_pow : forall i j : nat, p3m i[^]j [=] p3m (i * j). Proof. intros. unfold p3m in |- *. algebra. Qed. Hint Resolve p3m_aux: algebra. Lemma p3m_0 : p3m 0 [=] [1]. Proof. unfold p3m in |- *. simpl in |- *. algebra. Qed. Hint Resolve p3m_0: algebra. Lemma third_pos : ZeroR [<] [1] [/]ThreeNZ. Proof. apply recip_resp_pos. apply pos_three. Qed. Hint Resolve third_pos: algebra. Lemma third_less_one : [1] [/]ThreeNZ [<] OneR. Proof. apply pos_div_three'. apply pos_one. Qed. Hint Resolve third_less_one: algebra. Lemma p3m_mon : forall i j : nat, i < j -> p3m j [<] p3m i. Proof. intros. unfold p3m in |- *. apply small_nexp_resp_lt; algebra. Qed. Lemma p3m_mon' : forall i j : nat, i <= j -> p3m j [<=] p3m i. Proof. intros. unfold p3m in |- *. apply small_nexp_resp_le; try apply less_leEq; algebra. Qed. Lemma p3m_small : forall i : nat, p3m i [<=] [1]. Proof. intro. astepr (p3m 0). apply p3m_mon'. auto with arith. Qed. Lemma p3m_smaller : forall i : nat, 0 < i -> p3m i [<=] Half. Proof. intros. apply leEq_transitive with (p3m 1). apply p3m_mon'. auto with arith. unfold p3m in |- *. astepl ([1] [/]ThreeNZ:IR). unfold Half in |- *. apply less_leEq. apply recip_resp_less. apply pos_two. apply two_less_three. Qed. Definition chfun (k : nat -> nat) (a j i : nat) : nat := match le_gt_dec i j with | left _ => k i | right _ => a end. Lemma chfun_1 : forall k a j i, i <= j -> k i = chfun k a j i. Proof. intros. unfold chfun in |- *. elim (le_gt_dec i j). auto. intro y. elim (proj1 (Nat.le_ngt _ _) H y). Qed. Lemma chfun_2 : forall k j a i, j < i -> a = chfun k a j i. Proof. intros. unfold chfun in |- *. elim (le_gt_dec i j). intro y. elim (proj1 (Nat.le_ngt _ _) y H). auto. Qed. Lemma chfun_3 : forall k j a, (forall i, 1 <= k i /\ k i <= n) -> 1 <= a -> a <= n -> forall i, 1 <= chfun k a j i /\ chfun k a j i <= n. Proof. intros. unfold chfun in |- *. elim (le_gt_dec i j). auto. auto. Qed. Lemma chfun_4 : forall k j a, (forall i, k (S i) <= k i) -> a <= k j -> forall i, chfun k a j (S i) <= chfun k a j i. Proof. intros. unfold chfun in |- *. elim (le_gt_dec i j); elim (le_gt_dec (S i) j); intros; auto. cut (i = j). intro. rewrite H1. auto. lia. lia. Qed. Definition Halfeps := Half[*]eps. Lemma Halfeps_pos : [0] [<] Halfeps. Proof. unfold Halfeps in |- *. apply mult_resp_pos. apply pos_half. apply eps_pos. Qed. Lemma Halfeps_Halfeps : forall x : IR, x[-]Halfeps[-]Halfeps [=] x[-]eps. Proof. intros. unfold Halfeps in |- *. unfold Half in |- *. rational. Qed. Hint Resolve Halfeps_Halfeps: algebra. Lemma Halfeps_eps : forall x y : IR, x[-]Halfeps [<=] y -> x[-]eps [<=] y. Proof. intros. astepl (x[-]Halfeps[-]Halfeps). apply leEq_transitive with (x[-]Halfeps). apply less_leEq. apply shift_minus_less. apply shift_less_plus'. astepl ZeroR. apply Halfeps_pos. auto. Qed. Lemma Halfeps_trans : forall x y z : IR, x[-]Halfeps [<=] y -> y[-]Halfeps [<=] z -> x[-]eps [<=] z. Proof. intros. astepl (x[-]Halfeps[-]Halfeps). apply leEq_transitive with (y[-]Halfeps). apply minus_resp_leEq. auto. auto. Qed. Lemma Key_1a : forall (i j : nat) (a t : IR), a[*] (t[*]p3m (S j)) [^]i [=] p3m i[*] (a[*] (t[*]p3m j) [^]i). Proof. intros. astepl (a0[*] (t[^]i[*]p3m (S j) [^]i)). astepl (a0[*] (t[^]i[*] (p3m i[*]p3m j[^]i))). astepr (p3m i[*] (a0[*] (t[^]i[*]p3m j[^]i))). rational. Qed. Hint Resolve Key_1a: algebra. Lemma Key_1b : forall k : nat, 1 <= k -> p3m k[*]eps [<=] Halfeps. Proof. intros. unfold Halfeps in |- *. apply mult_resp_leEq_rht. apply p3m_smaller. auto. apply less_leEq; apply eps_pos. Qed. Lemma Key_1 : forall (i k j : nat) (ai ak t : IR), 1 <= k -> k < i -> [0] [<=] ai -> [0] [<=] t -> ai[*] (t[*]p3m j) [^]i[-]eps [<=] ak[*] (t[*]p3m j) [^]k -> ai[*] (t[*]p3m (S j)) [^]i[-]Halfeps [<=] ak[*] (t[*]p3m (S j)) [^]k. Proof. intros i k j ai ak t H H0 H1 H2 H3. apply leEq_transitive with (p3m k[*] (ai[*] (t[*]p3m j) [^]i) [-]p3m k[*]eps). apply minus_resp_leEq_both. astepl (p3m i[*] (ai[*] (t[*]p3m j) [^]i)). apply mult_resp_leEq_rht. apply less_leEq. apply p3m_mon; auto. astepl (ai[*][0]). apply mult_resp_leEq_lft; auto. apply nexp_resp_nonneg. apply mult_resp_nonneg; auto. apply less_leEq; apply p3m_pos. apply Key_1b; auto. astepl (p3m k[*] (ai[*] (t[*]p3m j) [^]i[-]eps)). astepr (p3m k[*] (ak[*] (t[*]p3m j) [^]k)). apply mult_resp_leEq_lft; auto. apply less_leEq; apply p3m_pos. Qed. Lemma Key_2 : forall (i k k' j : nat) (ai ak ak' t : IR), 1 <= k -> k < i -> [0] [<=] ai -> [0] [<=] t -> ak[*] (t[*]p3m (S j)) [^]k[-]Halfeps [<=] ak'[*] (t[*]p3m (S j)) [^]k' -> ai[*] (t[*]p3m j) [^]i[-]eps [<=] ak[*] (t[*]p3m j) [^]k -> ai[*] (t[*]p3m (S j)) [^]i[-]eps [<=] ak'[*] (t[*]p3m (S j)) [^]k'. Proof. intros. apply Halfeps_trans with (ak[*] (t[*]p3m (S j)) [^]k). apply Key_1; auto. auto. Qed. Lemma Key : {t : IR | [0] [<=] t | forall J, {k : nat -> nat | (forall i, 1 <= k i /\ k i <= n) /\ (forall i, k (S i) <= k i) /\ (let k_0 := k 0 in a k_0[*]t[^]k_0 [=] a_0[-]eps) /\ (forall j, j <= J -> let k_j := k j in let r := t[*]p3m j in forall i, 1 <= i -> i <= n -> a i[*]r[^]i[-]eps [<=] a k_j[*]r[^]k_j)}}. Proof. (* begin hide *) Proof. elim lem_1. intro t. intros H0 H1. elim H1. intros k_0 H2. elim H2. intros H3 H4. elim H4. intros H5 H6. elim H6. intros H7 H8. clear H6 H4 H2 H1. exists t. auto. intro J. induction J as [| J HrecJ]. exists (fun j : nat => k_0). split. auto. split. auto. split. auto. intros j H9 k_j r i H10 H11. unfold k_j, r in |- *. rewrite (proj1 (Nat.le_0_r _) H9). replace (p3m 0) with OneR. 2: auto. astepr (a k_0[*] (t[^]k_0[*][1][^]k_0)). astepr (a k_0[*] (t[^]k_0[*][1])). astepr (a k_0[*]t[^]k_0). astepr (a_0[-]eps). apply minus_resp_leEq. astepl (a i[*] (t[^]i[*][1][^]i)). astepl (a i[*] (t[^]i[*][1])). astepl (a i[*]t[^]i); auto. elim HrecJ. intros k' H9. elim H9. intros H10 H11. elim H11. intros H12 H13. elim H13. intros H14 H15. clear H9 H11 H13. cut (0 < k' J). intro H16. 2: elim (H10 J); auto. elim (maj_upto_eps IR (fun i : nat => a i[*] (t[*]p3m (S J)) [^]i) ( k' J) Halfeps H16 Halfeps_pos). intros k_SJ H17. elim H17. intros H18 H19. elim H19. intros H20 H21. clear H17 H19. exists (chfun k' k_SJ J). split. intro i. apply chfun_3. auto. auto. apply Nat.le_trans with (k' J); auto. elim (H10 J). auto. split. intro i. apply chfun_4; auto. split. replace (chfun k' k_SJ J 0) with (k' 0); auto. intros j H22 k_j r i H23 H24. unfold k_j, r in |- *. elim (le_lt_eq_dec _ _ H22); intro H26. replace (chfun k' k_SJ J j) with (k' j). apply H15; auto with arith. apply chfun_1; auto with arith. replace (chfun k' k_SJ J j) with k_SJ. rewrite H26. elim (le_lt_dec i (k' J)); intro H28. apply Halfeps_eps. auto. apply Key_2 with (k' J) (a (k' J)); auto. apply chfun_2. rewrite H26. auto. Qed. (* end hide *) End Key_Lemma. #[global] Hint Resolve p3m_S p3m_P p3m_pow: algebra. corn-8.20.0/fta/KneserLemma.v000066400000000000000000000454611473720167500157340ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Smallest %\ensuremath{\frac13^{2n^2+n}}% *) (** printing eta_0 %\ensuremath{\eta_0}% #η0# *) Require Export CoRN.complex.NRootCC. Require Export CoRN.complex.AbsCC. Require Export CoRN.fta.MainLemma. (** ** Kneser Lemma *) Section Kneser_Lemma. (** %\begin{convention}% Let [b : nat->CC], [n : nat] and [c : IR] such that [0 < n], [b_0 := b 0], [b_n := (b n) [=] [1]] and [(AbsCC b_0) [<] c]. %\end{convention}% *) Variable b : nat -> CC. Variable n : nat. Hypothesis gt_n_0 : 0 < n. (* begin hide *) Let b_0 := b 0. Let b_n := b n. (* end hide *) Hypothesis b_n_1 : b_n [=] [1]. Variable c : IR. Hypothesis b_0_lt_c : AbsCC b_0 [<] c. (** %\begin{convention}% We define the following local abbreviations: - [two_n := 2 * n] - [Small := p3m n] - [Smaller := p3m (two_n * n)] - [Smallest := Small[*]Smaller] - [q := [1][-]Smallest] - [a i := AbsCC (b i)] %\end{convention}% *) (* begin hide *) Let two_n := 2 * n. Let Small := p3m n. Let Smaller := p3m (two_n * n). Let Smallest := Small[*]Smaller. Let q := [1][-]Smallest. (* end hide *) Lemma b_0'_exists : forall eta : IR, [0] [<] eta -> {b_0' : CC | AbsCC (b_0'[-]b_0) [<=] eta | b_0' [#] [0]}. Proof. intros. exact (Cexis_AFS_CC [0] b_0 eta X). Qed. Let eta_0 := ((c[-]AbsCC b_0) [/]FourNZ) [/]TwoNZ. Lemma eta_0_pos : [0] [<] eta_0. Proof. unfold eta_0 in |- *. apply pos_div_two. apply pos_div_four. apply shift_zero_less_minus. assumption. Qed. Lemma eta_exists : {eta : IR | [0] [<] eta | {b_0' : CC | AbsCC (b_0'[-]b_0) [<=] eta | b_0' [#] [0] and AbsCC b_0'[+]Three[*]eta [<] c}}. Proof. exists eta_0. exact eta_0_pos. generalize (b_0'_exists eta_0 eta_0_pos). intro H. elim H. intros b_0' H0 H1. exists b_0'. assumption. split. assumption. apply leEq_less_trans with ((AbsCC b_0[+]c) [/]TwoNZ). 2: apply Average_less_Greatest; auto. apply shift_plus_leEq. apply leEq_wdl with (AbsCC (b_0'[-]b_0[+]b_0)). 2: apply AbsCC_wd; rational. apply leEq_transitive with (AbsCC (b_0'[-]b_0) [+]AbsCC b_0). apply triangle. apply leEq_transitive with (eta_0[+]AbsCC b_0). apply plus_resp_leEq; auto. apply eq_imp_leEq. unfold eta_0 in |- *; rational. Qed. Lemma eps_exists_1 : forall eps x y : IR, [0] [<] eps -> [0] [<] x -> [0] [<] y -> {eps' : IR | [0] [<] eps' | eps' [<=] eps /\ x[*]eps' [<=] y}. Proof. intros eps x y Heps Hx Hy. cut ([0] [<] Half[*]eps). intro H2. cut (x [#] [0]). intro H3. 2: apply pos_ap_zero; auto. elim (less_cotransitive_unfolded _ _ _ H2 ((y[/] x[//]H3) [-]Half[*]eps)); intro H5. exists (Half[*]eps). auto. split. apply less_leEq; apply half_3. auto. astepr (x[*] (y[/] x[//]H3)). apply less_leEq. apply mult_resp_less_lft; auto. astepl ([0][+]Half[*]eps). apply shift_plus_less; auto. cut ([0] [<] (y[/] x[//]H3)). intro H4. 2: apply div_resp_pos; auto. exists (Half[*] (y[/] x[//]H3)). apply mult_resp_pos. apply pos_half. auto. split. apply leEq_transitive with (y[/] x[//]H3). apply less_leEq; apply half_3; auto. apply less_leEq. astepr ([1][*]eps). astepr ((Half[+]Half) [*]eps). astepr (Half[*]eps[+]Half[*]eps). apply shift_less_plus'; auto. rstepl (Half[*]y). apply less_leEq; apply half_3; auto. apply mult_resp_pos; auto. apply pos_half. Qed. (* less_cotransitive_unfolded on {[0] [<] y[/]x[//]H3[-]Half[*]eps} + {y[/]x[//]H3[-]Half[*]eps [<] Half[*]eps}. *) Lemma eps_exists : forall eta a_0 : IR, [0] [<] eta -> [0] [<] a_0 -> {eps : IR | [0] [<] eps | Two[*] (Three[^]n[+][1]) [*]eps [<=] eta /\ Three[*]eps [<=] Smaller[*]a_0 /\ eps [<=] a_0}. Proof. intros eta a_0 Heta Ha_0. elim (eps_exists_1 ((Smaller[*]a_0) [/]ThreeNZ) (Three[^]n[+][1]) (eta [/]TwoNZ)). intros eps H H0. elim H0; intros H1 H2. exists eps. auto. split. astepl (Two[*] ((Three[^]n[+][1]) [*]eps)). apply shift_mult_leEq' with (two_ap_zero IR); auto. apply pos_two. split. apply shift_mult_leEq' with (three_ap_zero IR); auto. apply pos_three. eapply leEq_transitive. apply H1. apply shift_div_leEq'. apply pos_three. apply mult_resp_leEq_rht. unfold Smaller in |- *; apply leEq_transitive with OneR. apply p3m_small. apply less_leEq; apply one_less_three. apply less_leEq; auto. apply pos_div_three. apply mult_resp_pos; auto. unfold Smaller in |- *; apply p3m_pos. apply plus_resp_pos. apply nexp_resp_pos. apply pos_three. apply pos_one. apply pos_div_two; auto. Qed. (* begin hide *) Let a (i : nat) : IR := AbsCC (b i). (* end hide *) Lemma z_exists : forall (b_0' : CC) (k : nat) (r eta : IR), let a_0 := AbsCC b_0' in [0] [<] a_0 -> [0] [<] a k -> 1 <= k -> k <= n -> [0] [<=] r -> [0] [<] eta -> AbsCC (b_0'[-]b_0) [<=] eta -> a k[*]r[^]k [<=] a_0 -> {z : CC | AbsCC z [=] r | AbsCC (b_0[+]b k[*]z[^]k) [<=] a_0[-]a k[*]r[^]k[+]eta}. Proof. (* begin hide *) intros b_0' k r eta a_0 H H0 H1 H2 H3 H4 H5 H6. cut (AbsCC b_0' [#] [0]). intro H7. 2: apply pos_ap_zero; auto. cut (cc_IR (AbsCC b_0') [#] [0]). intro H8. 2: astepr (cc_IR [0]); apply cc_IR_resp_ap; auto. cut (a k [#] [0]). intro H9. 2: apply pos_ap_zero; auto. cut (b k [#] [0]). intro H10. 2: apply AbsCC_ap_zero; apply ap_symmetric_unfolded; auto. cut (0 < k). intro H11. 2: auto with arith. cut ( [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10)) [#] [0]). intro H12. elim (CnrootCC [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10)) H12 k H11). intros w H13. cut (AbsCC w [=] [1]). intro H14. exists (cc_IR r[*]w). astepl (AbsCC (cc_IR r) [*]AbsCC w). astepl (r[*]AbsCC w). Step_final (r[*][1]). apply leEq_transitive with (AbsCC (b_0'[+]b k[*] (cc_IR r[*]w) [^]k) [+]AbsCC (b_0[-]b_0')). apply leEq_wdl with (AbsCC (b_0'[+]b k[*] (cc_IR r[*]w) [^]k[+] (b_0[-]b_0'))). apply triangle. apply AbsCC_wd; rational. apply leEq_wdl with (AbsCC b_0'[-]a k[*]r[^]k[+]AbsCC (b_0[-]b_0')). apply plus_resp_leEq_lft. astepl (AbsCC [--] (b_0[-]b_0')). apply leEq_wdl with (AbsCC (b_0'[-]b_0)); auto. apply AbsCC_wd; rational. apply bin_op_wd_unfolded. 2: algebra. apply eq_transitive_unfolded with (AbsCC ((b_0'[/] cc_IR (AbsCC b_0') [//]H8) [*] (cc_IR (AbsCC b_0') [-]cc_IR (a k) [*]cc_IR r[^]k))). astepl ([1][*] (AbsCC b_0'[-]a k[*]r[^]k)). astepr (AbsCC (b_0'[/] cc_IR (AbsCC b_0') [//]H8) [*] AbsCC (cc_IR (AbsCC b_0') [-]cc_IR (a k) [*]cc_IR r[^]k)). apply bin_op_wd_unfolded. astepl (AbsCC b_0'[/] AbsCC b_0'[//]H7). apply eq_symmetric_unfolded. apply cc_div_abs'. apply AbsCC_nonneg. apply eq_transitive_unfolded with (AbsCC (cc_IR (AbsCC b_0') [-]cc_IR (a k) [*]cc_IR (r[^]k))). 2: apply AbsCC_wd; algebra. astepr (AbsCC (cc_IR (AbsCC b_0') [-]cc_IR (a k[*]r[^]k))). astepr (AbsCC (cc_IR (AbsCC b_0'[-]a k[*]r[^]k))). cut ([0] [<=] AbsCC b_0'[-]a k[*]r[^]k). algebra. apply shift_leEq_lft; auto. apply AbsCC_wd. rstepl (b_0'[+] b k[*] (cc_IR r[^]k[*] [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10)))). apply bin_op_wd_unfolded. algebra. apply bin_op_wd_unfolded. algebra. Step_final (cc_IR r[^]k[*]w[^]k). apply root_one with k; auto. apply AbsCC_nonneg. astepl (AbsCC (w[^]k)). astepl (AbsCC [--] ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10))). astepl (AbsCC ((cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] (b_0'[/] b k[//]H10))). astepl (AbsCC (cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] AbsCC (b_0'[/] b k[//]H10)). astepl (AbsCC (cc_IR (a k) [/] cc_IR (AbsCC b_0') [//]H8) [*] AbsCC (b_0'[/] b k[//]H10)). cut ([0] [<=] AbsCC b_0'). intro. 2: apply AbsCC_nonneg. astepl ((AbsCC (cc_IR (a k)) [/] AbsCC b_0'[//]H7) [*]AbsCC (b_0'[/] b k[//]H10)). astepl ((AbsCC (cc_IR (a k)) [/] AbsCC b_0'[//]H7) [*]AbsCC (b_0'[/] b k[//]H10)). cut ([0] [<=] a k). intro. 2: apply less_leEq; auto. astepl ((a k[/] AbsCC b_0'[//]H7) [*]AbsCC (b_0'[/] b k[//]H10)). astepl ((a k[/] AbsCC b_0'[//]H7) [*] (AbsCC b_0'[/] AbsCC (b k) [//]H9)). unfold a in |- *; rational. apply ap_wdl_unfolded with (cc_IR [--] (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)). apply mult_resp_ap_zero. astepr (cc_IR [0]). apply cc_IR_resp_ap. apply inv_resp_ap_zero. apply div_resp_ap_zero_rev; auto. apply div_resp_ap_zero_rev. apply AbsCC_ap_zero. apply ap_symmetric_unfolded; auto. apply eq_transitive_unfolded with ( [--] (cc_IR (a k[/] AbsCC b_0'[//]H7)) [*] (b_0'[/] b k[//]H10)). apply mult_wdl. astepl (cc_IR ([0][-] (a k[/] AbsCC b_0'[//]H7))). astepr ([0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)). Step_final (cc_IR [0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)). astepl (([0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)) [*] (b_0'[/] b k[//]H10)). astepl ((cc_IR [0][-]cc_IR (a k[/] AbsCC b_0'[//]H7)) [*] (b_0'[/] b k[//]H10)). astepl (cc_IR [0][*] (b_0'[/] b k[//]H10) [-] cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)). astepl ([0][*] (b_0'[/] b k[//]H10) [-] cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)). astepl ([0][-]cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10)). astepl ( [--] (cc_IR (a k[/] AbsCC b_0'[//]H7) [*] (b_0'[/] b k[//]H10))). apply un_op_wd_unfolded. apply mult_wdl. unfold cc_IR in |- *; simpl in |- *; split; simpl in |- *; rational. Qed. (* end hide *) Lemma Kneser_1' : Half [<=] q. Proof. unfold q in |- *. apply shift_leEq_minus. astepl (Smallest[+]Half). apply shift_plus_leEq. unfold Half in |- *. rstepr ([1] [/]TwoNZ:IR). unfold Smallest, Small, Smaller in |- *. generalize (p3m_smaller n gt_n_0). intro Hn. generalize (p3m_smaller (two_n * n)). intro H2nn. apply leEq_transitive with (Half[*] (Half:IR)). apply mult_resp_leEq_both; auto. apply less_leEq; apply p3m_pos. apply less_leEq; apply p3m_pos. apply H2nn. unfold two_n in |- *. elim gt_n_0. auto with arith. intros. simpl in |- *. auto with arith. rstepr ([1] [/]TwoNZ[*]OneR). apply less_leEq. apply mult_resp_less_lft. exact (half_lt1 _). exact (pos_half _). Qed. Lemma Kneser_1'' : q [<] [1]. Proof. unfold q in |- *. apply shift_minus_less'. rstepl ([0][+]OneR). apply plus_resp_less_rht. unfold Smallest, Small, Smaller in |- *. apply mult_resp_pos; apply p3m_pos. Qed. Lemma Kneser_1 : forall a_0 eta eps : IR, [0] [<] eta -> [0] [<] eps -> a_0[+]Three[*]eta [<] c -> Two[*] (Three[^]n[+][1]) [*]eps [<=] eta -> q[*]a_0[+]Three[^]n[*]eps[+]eps[+]eta [<] q[*]c. Proof. intros. cut ([1] [/]TwoNZ[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta) [<=] q[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)). intro Hm. apply leEq_less_trans with (q[*] (a_0[+]Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)). rstepr (q[*]a_0[+]q[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)). rstepl (q[*]a_0[+][1] [/]TwoNZ[*] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)). apply plus_resp_leEq_lft; auto. apply mult_resp_less_lft. apply leEq_less_trans with (a_0[+]Three[*]eta); auto. rstepl (a_0[+] (Two[*]Three[^]n[*]eps[+]Two[*]eps[+]Two[*]eta)). apply plus_resp_leEq_lft. rstepl (Two[*] (Three[^]n[+][1]) [*]eps[+]Two[*]eta). rstepr (eta[+]Two[*]eta). apply plus_resp_leEq; auto. apply less_leEq_trans with (Half:IR). apply pos_half. exact Kneser_1'. apply mult_resp_leEq_rht. exact Kneser_1'. apply less_leEq. apply less_leEq_trans with ([0][+]Two[*]eta). rstepr (Two[*]eta). apply mult_resp_pos; auto. apply pos_two. apply less_leEq. apply plus_resp_less_rht. apply less_transitive_unfolded with ([0][+]Two[*]eps). rstepr (Two[*]eps). apply mult_resp_pos; auto. apply pos_two. apply plus_resp_less_rht. repeat apply mult_resp_pos; auto. apply pos_two. apply nexp_resp_pos; apply pos_three. Qed. Section with_CRing. (* We need a context so we can declare the ring structure. *) Variable R: CRing. Add Ring R: (CRing_Ring R). Lemma Kneser_2a : forall (m n i : nat) (f : nat -> R), 1 <= i -> Sum m n f [=] f m[+]f i[+] (Sum (S m) (pred i) f[+]Sum (S i) n f). Proof. intros. astepl (f m[+]Sum (S m) n0 f). astepl (f m[+] (Sum (S m) i f[+]Sum (S i) n0 f)). astepl (f m[+] (Sum (S m) (pred i) f[+]f i[+]Sum (S i) n0 f)). ring. Qed. End with_CRing. Lemma Kneser_2b : forall (k : nat) (z : CC), 1 <= k -> let p_ := fun i => b i[*]z[^]i in Sum 0 n (fun i => b i[*]z[^]i) [=] b_0[+]b k[*]z[^]k[+] (Sum 1 (pred k) p_[+]Sum (S k) n p_). Proof. (* begin hide *) intros. unfold p_ in |- *. unfold b_0 in |- *. apply eq_transitive_unfolded with (b 0[*]z[^]0[+]b k[*]z[^]k[+] (Sum 1 (pred k) p_[+]Sum (S k) n p_)); unfold p_ in |- *. apply Kneser_2a with (f := fun i : nat => b i[*]z[^]i). auto. rational. Qed. (* end hide *) Lemma Kneser_2c : forall (m n : nat) (z : CC), m <= S n -> let r := AbsCC z in AbsCC (Sum m n (fun i => b i[*]z[^]i)) [<=] Sum m n (fun i => a i[*]r[^]i). Proof. (* begin hide *) intros. unfold r in |- *. apply leEq_wdr with (Sum m n0 (fun i : nat => AbsCC (b i[*]z[^]i))). apply triangle_Sum with (z := fun i : nat => b i[*]z[^]i). auto. apply Sum_wd. intros. unfold a in |- *. Step_final (AbsCC (b i) [*]AbsCC (z[^]i)). Qed. (* end hide *) Lemma Kneser_2 : forall (k : nat) (z : CC), 1 <= k -> k <= n -> let r := AbsCC z in let p_ := fun i => a i[*]r[^]i in AbsCC (Sum 0 n (fun i => b i[*]z[^]i)) [<=] AbsCC (b_0[+]b k[*]z[^]k) [+] (Sum 1 (pred k) p_[+]Sum (S k) n p_). Proof. (* begin hide *) intros. unfold p_, r in |- *. set (p_' := fun i : nat => b i[*]z[^]i) in *. apply leEq_wdl with (AbsCC (b_0[+]b k[*]z[^]k[+] (Sum 1 (pred k) p_'[+]Sum (S k) n p_'))); unfold p_' in |- *. apply leEq_transitive with (AbsCC (b_0[+]b k[*]z[^]k) [+]AbsCC (Sum 1 (pred k) p_'[+]Sum (S k) n p_')); unfold p_' in |- *. apply triangle. apply plus_resp_leEq_lft. apply leEq_transitive with (AbsCC (Sum 1 (pred k) p_') [+]AbsCC (Sum (S k) n p_')); unfold p_' in |- *. apply triangle. apply plus_resp_leEq_both. apply Kneser_2c. auto with arith. apply Kneser_2c. auto with arith. apply AbsCC_wd. apply eq_symmetric_unfolded. apply Kneser_2b. auto. Qed. (* end hide *) Lemma Kneser_3 : {z : CC | AbsCC z[^]n [<=] c | AbsCC (Sum 0 n (fun i => b i[*]z[^]i)) [<] q[*]c}. Proof. elim eta_exists. intros eta H0 H1. elim H1. intros b_0' H3 H4. elim H4. intros H5 H6. clear H1 H4. cut ([0] [<] AbsCC b_0'). intro H7. 2: apply AbsCC_pos; auto. elim (eps_exists eta (AbsCC b_0') H0 H7). intros eps H9 H10. elim H10. intros H11 H12. elim H12. intros H13 H14. clear H10 H12. cut (forall k : nat, [0] [<=] a k). intro H15. 2: intro; unfold a in |- *; apply AbsCC_nonneg. cut (a n [=] [1]). intro H16. 2: unfold a in |- *; Step_final (AbsCC [1]). elim (Main a n gt_n_0 eps H9 H15 H16 (AbsCC b_0') H14). intro r. intros H18 H19. elim H19. intros k H20. elim H20. intros H21 H22. elim H22. intros H23 H24. elim H24. intros H25 H26. elim H26. intros H27 H28. elim H28. intros H29 H30. clear H19 H20 H22 H24 H26 H28. cut ([0] [<] a k). intro H31. elim (z_exists b_0' k r eta H7 H31 H21 H23 H18 H0 H3 H30). intro z. intros H33 H34. exists z. astepl (r[^]n). apply leEq_transitive with (AbsCC b_0'); auto. apply leEq_transitive with (AbsCC b_0'[+]Three[*]eta). 2: apply less_leEq; auto. astepl (AbsCC b_0'[+][0]). apply plus_resp_leEq_lft. apply less_leEq. apply mult_resp_pos; auto. apply pos_three. set (r' := AbsCC z) in *. unfold r' in H33, H34. set (p_' := fun i : nat => a i[*]r'[^]i) in *. apply leEq_less_trans with (eps[+] (q[*]AbsCC b_0'[+]Three[^]n[*]eps[+]eta)). 2: rstepl (q[*]AbsCC b_0'[+]Three[^]n[*]eps[+]eps[+]eta); apply Kneser_1; auto. apply leEq_transitive with (AbsCC (b_0[+]b k[*]z[^]k) [+] (Sum 1 (pred k) p_'[+]Sum (S k) n p_')); unfold p_', r' in |- *. apply Kneser_2; auto. set (p_'' := fun i : nat => a i[*]r[^]i) in *. apply leEq_wdl with (AbsCC (b_0[+]b k[*]z[^]k) [+] (Sum 1 (pred k) p_''[+]Sum (S k) n p_'')); unfold p_'' in |- *. 2: apply bin_op_wd_unfolded; [ algebra | apply bin_op_wd_unfolded; apply Sum_wd; algebra ]. apply leEq_transitive with (AbsCC (b_0[+]b k[*]z[^]k) [+] (([1][-]Small) [*] (a k[*]r[^]k) [+]Three[^]n[*]eps)). apply plus_resp_leEq_lft; auto. apply leEq_transitive with (AbsCC b_0'[-]AbsCC (b k) [*]r[^]k[+]eta[+] (([1][-]Small) [*] (a k[*]r[^]k) [+]Three[^]n[*]eps)). apply plus_resp_leEq; auto. unfold a in |- *. rstepl (AbsCC b_0'[+]Three[^]n[*]eps[+]eta[-]Small[*] (AbsCC (b k) [*]r[^]k)). apply leEq_transitive with (AbsCC b_0'[+]Three[^]n[*]eps[+]eta[-] Small[*] (Smaller[*]AbsCC b_0'[-]Two[*]eps)). apply minus_resp_leEq_rht. apply mult_resp_leEq_lft; auto. unfold Small in |- *. apply less_leEq; apply p3m_pos. apply leEq_wdl with (Small[*]Two[*]eps[+] (q[*]AbsCC b_0'[+]Three[^]n[*]eps[+]eta)). 2: unfold q, Smallest in |- *; rational. apply plus_resp_leEq. astepr ([1][*]eps). apply mult_resp_leEq_rht. 2: apply less_leEq; auto. astepr (Half[*] (Two:IR)). apply mult_resp_leEq_rht. unfold Small in |- *; apply p3m_smaller; auto. apply less_leEq; apply pos_two. apply mult_cancel_pos_lft with (r[^]k). 2: apply nexp_resp_nonneg; auto. apply less_leEq_trans with eps; auto. eapply leEq_transitive. 2: apply H29. apply shift_leEq_minus. rstepl (Three[*]eps). auto. Qed. End Kneser_Lemma. Lemma Kneser : forall n : nat, 0 < n -> {q : IR | [0] [<=] q | q [<] [1] and (forall p : cpoly CC, monic n p -> forall c : IR, AbsCC p ! [0] [<] c -> {z : CC | AbsCC z[^]n [<=] c | AbsCC p ! z [<] q[*]c})}. Proof. intros n H. exists ([1][-]p3m n[*]p3m (2 * n * n)). apply less_leEq. apply less_leEq_trans with (Half:IR). apply pos_half. apply Kneser_1'; auto. split. apply Kneser_1''. intros p H0 c H1. elim H0. intros H2 H3. cut (nth_coeff n p [=] [1]). intro H4. 2: auto. elim (Kneser_3 (fun i : nat => nth_coeff i p) n H H4 c). intros z H6 H7. 2: astepl (AbsCC p ! [0]); auto. exists z. auto. astepl (AbsCC (Sum 0 n (fun i : nat => nth_coeff i p[*]z[^]i))); auto. Qed. corn-8.20.0/fta/MainLemma.v000066400000000000000000000377331473720167500153740ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing two_n %\ensuremath{2n}% #2n# *) (** printing Small %\ensuremath{\frac13^n}% *) (** printing Smaller %\ensuremath{\frac13^{2n^2}}% *) Require Export CoRN.reals.CSumsReals. Require Export CoRN.fta.KeyLemma. Require Import CoRN.algebra.CRing_as_Ring. From Coq Require Import Lia. (** ** Main Lemma *) Section Main_Lemma. (** %\begin{convention}% Let [a : nat->IR], [n : nat], [a_0 : IR] and [eps : IR] such that [0 < n], [([0] [<] eps)], [forall (k : nat)([0] [<=] (a k))], [(a n) [=] [1]], and [(eps [<=] a_0)]. %\end{convention}% *) Variable a : nat -> IR. Variable n : nat. Hypothesis gt_n_0 : 0 < n. Variable eps : IR. Hypothesis eps_pos : [0] [<] eps. Hypothesis a_nonneg : forall k : nat, [0] [<=] a k. Hypothesis a_n_1 : a n [=] [1]. Variable a_0 : IR. Hypothesis eps_le_a_0 : eps [<=] a_0. Lemma a_0_pos : [0] [<] a_0. Proof. apply less_leEq_trans with eps; auto. Qed. (** %\begin{convention}% We define the following local abbreviations: - [two_n := 2 * n] - [Small := p3m n] - [Smaller := p3m (two_n * n)] %\end{convention}% *) (* begin hide *) Let two_n := 2 * n. Let Small := p3m n. Let Smaller := p3m (two_n * n). (* end hide *) Lemma Main_1a' : forall (t : IR) (j k : nat), let r' := t[*]p3m (S (S j)) in let r := t[*]p3m (S j) in (forall i, 1 <= i -> i <= n -> a i[*]r'[^]i[-]eps [<=] a k[*]r'[^]k) -> forall i : nat, 1 <= i -> i <= n -> a i[*] (r [/]ThreeNZ) [^]i[-]eps [<=] a k[*] (r [/]ThreeNZ) [^]k. Proof. (* begin hide *) intros. cut ((t[*]p3m (S j)) [/]ThreeNZ [=] t[*]p3m (S (S j))). intro. astepl (a i[*] (t[*]p3m (S (S j))) [^]i[-]eps). astepr (a k[*] (t[*]p3m (S (S j))) [^]k). auto. Step_final (t[*]p3m (S j) [/]ThreeNZ). Qed. (* end hide *) Lemma Main_1b' : forall (t : IR) (j k : nat), let r' := t[*]p3m j in let r := t[*]p3m (S j) in (forall i, 1 <= i -> i <= n -> a i[*]r'[^]i[-]eps [<=] a k[*]r'[^]k) -> forall i, 1 <= i -> i <= n -> a i[*] (r[*]Three) [^]i[-]eps [<=] a k[*] (r[*]Three) [^]k. Proof. (* begin hide *) intros. cut (t[*]p3m (S j) [*]Three [=] t[*]p3m j). intro. astepl (a i[*] (t[*]p3m j) [^]i[-]eps). astepr (a k[*] (t[*]p3m j) [^]k). auto. Step_final (t[*] (p3m (S j) [*]Three)). Qed. (* end hide *) Lemma Main_1a : forall (r : IR) (k : nat), [0] [<=] r -> 1 <= k -> k <= n -> (forall i, 1 <= i -> i <= n -> a i[*] (r [/]ThreeNZ) [^]i[-]eps [<=] a k[*] (r [/]ThreeNZ) [^]k) -> let p_ := fun i : nat => a i[*]r[^]i in let p_k := a k[*]r[^]k in Sum 1 (pred k) p_ [<=] Half[*] ([1][-]Small) [*]p_k[+]Half[*]Three[^]n[*]eps. Proof. (* begin hide *) intros r k H H0 H1 H2 p_ p_k. unfold p_, p_k in |- *. apply leEq_transitive with (Sum 1 (pred k) (fun i : nat => Three[^]i[*] (a k[*] (r [/]ThreeNZ) [^]k[+]eps))). apply Sum_resp_leEq. auto with arith. intros i H3 H4. cut (Three[^]i [#] ZeroR). intro H5. apply shift_leEq_mult' with H5. apply nexp_resp_pos. apply pos_three. astepl (a i[*] (r[^]i[/] Three[^]i[//]H5)). astepl (a i[*] (r [/]ThreeNZ) [^]i). astepr (eps[+]a k[*] (r [/]ThreeNZ) [^]k). apply shift_leEq_plus'. apply H2. assumption. lia. apply nexp_resp_ap_zero. apply three_ap_zero. apply leEq_wdl with (Sum 1 (pred k) (fun i : nat => Three[^]i) [*] (a k[*] (r [/]ThreeNZ) [^]k[+]eps)). cut (Three[-][1] [#] ZeroR). intro H3. astepl ((Three[^]S (pred k) [-]Three[^]1[/] Three[-][1][//]H3) [*] (a k[*] (r [/]ThreeNZ) [^]k[+]eps)). rewrite -> (Nat.lt_succ_pred _ _ H0). astepl ((Three[^]k[-]Three[/] Three[-][1][//]H3) [*] (a k[*] (r [/]ThreeNZ) [^]k[+]eps)). rstepl ([1] [/]TwoNZ[*] (Three[^]k[-]Three) [*] (a k[*] (r [/]ThreeNZ) [^]k) [+] [1] [/]TwoNZ[*] (Three[^]k[-]Three) [*]eps). apply leEq_transitive with (Half[*] ([1][-]Small) [*] (a k[*]r[^]k) [+] [1] [/]TwoNZ[*] (Three[^]k[-]Three) [*]eps). apply plus_resp_leEq. cut (Three[^]k [#] ZeroR). intro H4. astepl ([1] [/]TwoNZ[*] (Three[^]k[-]Three) [*] (a k[*] (r[^]k[/] Three[^]k[//]H4))). rstepl ([1] [/]TwoNZ[*]a k[*]r[^]k[*] ([1][-] (Three[/] Three[^]k[//]H4))). rstepr (Half[*]a k[*]r[^]k[*] ([1][-]Small)). unfold Half in |- *. apply mult_resp_leEq_lft. apply minus_resp_leEq_both. apply leEq_reflexive. unfold Small in |- *. unfold p3m in |- *. cut (Three[^]pred k [#] ZeroR). intro H5. apply leEq_wdr with ([1][/] Three[^]pred k[//]H5). cut (Three[^]n [#] ZeroR). intro H6. astepl ([1][/] Three[^]n[//]H6). apply recip_resp_leEq. apply nexp_resp_pos. apply pos_three. apply great_nexp_resp_le. apply less_leEq; apply one_less_three. lia. apply nexp_resp_ap_zero. apply three_ap_zero. apply eq_div. pattern k at 1 in |- *. rewrite <- (Nat.lt_succ_pred _ _ H0). astepl ([1][*] (Three[*]Three[^]pred k):IR). clear H3 H4 H5. astepl ((Three[*]Three[^]pred k):IR). reflexivity. apply nexp_resp_ap_zero. apply three_ap_zero. apply mult_resp_nonneg. apply mult_resp_nonneg. apply less_leEq. astepr (Half:IR). apply pos_half. apply a_nonneg. apply nexp_resp_nonneg; auto. apply nexp_resp_ap_zero. apply three_ap_zero. apply plus_resp_leEq_lft. rstepl ([1] [/]TwoNZ[*]eps[*] (Three[^]k[-]Three)). rstepr (Half[*]eps[*]Three[^]n). unfold Half in |- *. apply mult_resp_leEq_lft. apply leEq_transitive with (Three[^]k:IR). astepr (Three[^]k[-]ZeroR). apply minus_resp_leEq_rht. apply less_leEq; apply pos_three. apply great_nexp_resp_le; auto. apply less_leEq; apply one_less_three. apply less_leEq; apply mult_resp_pos; auto. astepr (Half:IR); apply pos_half. rstepl (Two:IR). apply two_ap_zero. apply eq_symmetric_unfolded. apply mult_distr_sum_rht with (f := fun i : nat => (Three:IR) [^]i). Qed. (* end hide *) Lemma Main_1b : forall (r : IR) (k : nat), [0] [<=] r -> 1 <= k -> k <= n -> (forall i, 1 <= i -> i <= n -> a i[*] (r[*]Three) [^]i[-]eps [<=] a k[*] (r[*]Three) [^]k) -> let p_ := fun i => a i[*]r[^]i in let p_k := a k[*]r[^]k in Sum (S k) n p_ [<=] Half[*] ([1][-]Small) [*]p_k[+]Half[*]Three[^]n[*]eps. Proof. (* begin hide *) intros r k H H0 H1 H2 p_ p_k. unfold p_, p_k in |- *. cut (forall i : nat, Three[^]i [#] ZeroR). intro H3. 2: intro i; apply pos_ap_zero. 2: apply nexp_resp_pos. 2: apply pos_three. apply leEq_transitive with (Sum (S k) n (fun i : nat => a k[*] (r[*]Three) [^]k[+]eps[/] Three[^]i[//]H3 i)). apply Sum_resp_leEq. auto with arith. intros i H4 H5. apply shift_leEq_div. apply nexp_resp_pos; apply pos_three. rstepr (eps[+]a k[*] (r[*]Three) [^]k). apply shift_leEq_plus'. rstepl (a i[*] (r[^]i[*]Three[^]i) [-]eps). astepl (a i[*] (r[*]Three) [^]i[-]eps). apply H2; auto with arith. apply Nat.le_trans with (S k); auto. astepl (Sum (S k) n (fun i : nat => (a k[*] (r[*]Three) [^]k[+]eps) [*][1][/] Three[^]i[//]H3 i)). astepl (Sum (S k) n (fun i : nat => (a k[*] (r[*]Three) [^]k[+]eps) [*] ([1][/] Three[^]i[//]H3 i))). apply leEq_wdl with ((a k[*] (r[*]Three) [^]k[+]eps) [*] Sum (S k) n (fun i : nat => [1][/] Three[^]i[//]H3 i)). 2: apply eq_symmetric_unfolded. 2: apply mult_distr_sum_lft with (f := fun i : nat => [1][/] Three[^]i[//]H3 i). astepl ((a k[*] (r[*]Three) [^]k[+]eps) [*] Sum (S k) n (fun i : nat => ([1] [/]ThreeNZ) [^]i)). cut ([1][-][1] [/]ThreeNZ [#] ZeroR). 2: rstepl ((Two:IR) [/]ThreeNZ). 2: apply div_resp_ap_zero_rev. 2: apply two_ap_zero. intro H4. astepl ((a k[*] (r[*]Three) [^]k[+]eps) [*] (([1] [/]ThreeNZ) [^]S k[-] ([1] [/]ThreeNZ) [^]S n[/] [1][-][1] [/]ThreeNZ[//]H4)). astepl ((a k[*] (r[*]Three) [^]k[+]eps) [*] ([1] [/]ThreeNZ[*] ([1] [/]ThreeNZ) [^]k[-] [1] [/]ThreeNZ[*] ([1] [/]ThreeNZ) [^]n[/] [1][-][1] [/]ThreeNZ[//]H4)). rstepl ([1] [/]TwoNZ[*] (a k[*] (r[*]Three) [^]k) [*] (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n) [+] [1] [/]TwoNZ[*]eps[*] (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n)). apply leEq_transitive with (Half[*] ([1][-]Small) [*] (a k[*]r[^]k) [+] [1] [/]TwoNZ[*]eps[*] (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n)). apply plus_resp_leEq. astepl ([1] [/]TwoNZ[*] (a k[*] (r[^]k[*]Three[^]k)) [*] (([1] [/]ThreeNZ) [^]k[-] ([1] [/]ThreeNZ) [^]n)). rstepl ([1] [/]TwoNZ[*]a k[*]r[^]k[*] (Three[^]k[*] ([1] [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n)). unfold Half in |- *. rstepr ([1] [/]TwoNZ[*]a k[*]r[^]k[*] ([1][-]Small)). apply mult_resp_leEq_lft. astepl (((Three:IR) [*][1] [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n). astepl ((((Three:IR) [*][1]) [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n). astepl (((Three:IR) [/]ThreeNZ) [^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n). astepl (OneR[^]k[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n). astepl (OneR[-]Three[^]k[*] ([1] [/]ThreeNZ) [^]n). apply less_leEq. apply minus_resp_less_rht. unfold Small in |- *. unfold p3m in |- *. rstepl (OneR[*] ([1] [/]ThreeNZ) [^]n). apply mult_resp_less. astepl (OneR[^]k). apply nexp_resp_less; auto. apply less_leEq; apply pos_one. apply one_less_three. apply nexp_resp_pos. apply pos_div_three; apply pos_one. apply mult_resp_nonneg. apply mult_resp_nonneg. apply less_leEq. apply pos_div_two; apply pos_one. apply a_nonneg. apply nexp_resp_nonneg; assumption. apply plus_resp_leEq_lft. rstepr (Half[*]eps[*]Three[^]n). unfold Half in |- *. apply mult_resp_leEq_lft. apply leEq_transitive with OneR. apply leEq_transitive with ((OneR [/]ThreeNZ) [^]k). astepr ((OneR [/]ThreeNZ) [^]k[-][0]). apply less_leEq. apply minus_resp_less_rht. apply nexp_resp_pos. apply pos_div_three; apply pos_one. astepr ([1][^]k:IR). apply nexp_resp_leEq. apply less_leEq; apply pos_div_three; apply pos_one. astepr (OneR [/]OneNZ). apply less_leEq; apply recip_resp_less. apply pos_one. apply one_less_three. astepl (OneR[^]n). apply nexp_resp_leEq; apply less_leEq. apply pos_one. apply one_less_three. apply less_leEq. apply mult_resp_pos; auto. apply pos_div_two; apply pos_one. Qed. (* end hide *) Lemma Main_1 : forall (r : IR) (k : nat), [0] [<=] r -> 1 <= k -> k <= n -> (forall i, 1 <= i -> i <= n -> a i[*] (r [/]ThreeNZ) [^]i[-]eps [<=] a k[*] (r [/]ThreeNZ) [^]k) -> (forall i, 1 <= i -> i <= n -> a i[*] (r[*]Three) [^]i[-]eps [<=] a k[*] (r[*]Three) [^]k) -> let p_ := fun i => a i[*]r[^]i in let p_k := a k[*]r[^]k in Sum 1 (pred k) p_[+]Sum (S k) n p_ [<=] ([1][-]Small) [*]p_k[+]Three[^]n[*]eps. Proof. (* begin hide *) intros r k H H0 H1 H2 H3 p_ p_k. unfold p_, p_k in |- *. set (h := Half[*] ([1][-]Small) [*]p_k[+]Half[*]Three[^]n[*]eps) in *. apply leEq_wdr with (h[+]h); unfold h, p_k in |- *. apply plus_resp_leEq_both. apply Main_1a; auto. apply Main_1b; auto. unfold Half in |- *; rational. Qed. (* end hide *) Lemma Main_2' : forall (t : IR) (i k : nat), a i[*] (t[*]p3m 0) [^]i[-]eps [<=] a k[*] (t[*]p3m 0) [^]k -> a i[*]t[^]i[-]eps [<=] a k[*]t[^]k. Proof. intros. cut (t[*]p3m 0 [=] t). intro. astepl (a i[*] (t[*]p3m 0) [^]i[-]eps). astepr (a k[*] (t[*]p3m 0) [^]k). auto. Step_final (t[*][1]). Qed. Lemma Main_2 : forall (t : IR) (j k : nat), let r := t[*]p3m j in [0] [<=] t -> a k[*]t[^]k [=] a_0[-]eps -> (forall i, 1 <= i -> i <= n -> a i[*]t[^]i[-]eps [<=] a k[*]t[^]k) -> forall i, 1 <= i -> i <= n -> a i[*]r[^]i [<=] a_0. Proof. (* begin hide *) intros. unfold r in |- *. apply leEq_transitive with (a i[*]t[^]i). astepl (a i[*] (t[^]i[*]p3m j[^]i)). rstepl (p3m j[^]i[*] (a i[*]t[^]i)). astepr ([1][*] (a i[*]t[^]i)). apply mult_resp_leEq_rht. astepr ([1][^]i:IR). apply nexp_resp_leEq. apply less_leEq; apply p3m_pos. apply p3m_small. astepl ([0][*]t[^]i). apply mult_resp_leEq_rht; auto. astepl ([0][^]i:IR). apply nexp_resp_leEq; auto. apply leEq_reflexive. apply leEq_wdr with (eps[+]a k[*]t[^]k). apply shift_leEq_plus'; auto. astepl (eps[+] (a_0[-]eps)); rational. Qed. (* end hide *) Lemma Main_3a : forall (t : IR) (j k k_0 : nat), let r := t[*]p3m j in k_0 <= n -> a k_0[*]t[^]k_0 [=] a_0[-]eps -> a k_0[*]r[^]k_0[-]eps [<=] a k[*]r[^]k -> p3m (j * n) [*]a_0[-]Two[*]eps [<=] a k[*]r[^]k. Proof. (* begin hide *) intros. unfold r in |- *. rstepl (p3m (j * n) [*]a_0[-]eps[-]eps). apply leEq_transitive with (a k_0[*] (t[*]p3m j) [^]k_0[-]eps); auto. apply minus_resp_leEq. astepr (a k_0[*] (t[^]k_0[*]p3m j[^]k_0)). astepr (a k_0[*] (t[^]k_0[*]p3m (j * k_0))). rstepr (p3m (j * k_0) [*] (a k_0[*]t[^]k_0)). astepr (p3m (j * k_0) [*] (a_0[-]eps)). astepr (p3m (j * k_0) [*]a_0[-]p3m (j * k_0) [*]eps). apply minus_resp_leEq_both. apply mult_resp_leEq_rht. apply p3m_mon'; auto with arith. apply less_leEq; apply a_0_pos. astepr ([1][*]eps). apply mult_resp_leEq_rht. apply p3m_small. apply less_leEq; auto. Qed. (* end hide *) Lemma Main_3 : forall (t : IR) (j k k_0 : nat), let r := t[*]p3m j in j < two_n -> k_0 <= n -> a k_0[*]t[^]k_0 [=] a_0[-]eps -> a k_0[*]r[^]k_0[-]eps [<=] a k[*]r[^]k -> Smaller[*]a_0[-]Two[*]eps [<=] a k[*]r[^]k. Proof. (* begin hide *) intros t j k k_0 r H H0 H1 H2. unfold r in |- *. apply leEq_transitive with (p3m (j * n) [*]a_0[-]Two[*]eps). apply minus_resp_leEq. apply mult_resp_leEq_rht. unfold Smaller in |- *. apply p3m_mon'. apply Nat.mul_le_mono_r; auto with arith. apply less_leEq; apply a_0_pos. apply Main_3a with k_0; auto. Qed. (* end hide *) Lemma Main : {r : IR | [0] [<=] r | {k : nat | 1 <= k /\ k <= n /\ (let p_ := fun i => a i[*]r[^]i in let p_k := a k[*]r[^]k in Sum 1 (pred k) p_[+]Sum (S k) n p_ [<=] ([1][-]Small) [*]p_k[+]Three[^]n[*]eps /\ r[^]n [<=] a_0 /\ Smaller[*]a_0[-]Two[*]eps [<=] p_k /\ p_k [<=] a_0)}}. Proof. (* begin hide *) Proof. elim (Key a n gt_n_0 eps eps_pos a_nonneg a_n_1 a_0 eps_le_a_0). intro t. intros H0 H1. elim (H1 two_n). intro k. intros H2. elim H2. intros H3 H4. elim H4. intros H5 H6. elim H6. intros H7 H8. elim (kseq_prop k n H3 H5). intro j. intros H9. elim H9. intros H10 H11. elim H11. intros H12 H13. clear H9 H6 H4 H2 H1. cut ([0] [<=] t[*]p3m (S j)). intro H14. 2: apply mult_resp_nonneg; auto. 2: apply less_leEq; apply p3m_pos. exists (t[*]p3m (S j)). auto. exists (k (S j)). elim (H3 (S j)); intros H3' H3''. split. auto. split. auto. intros p_ p_k. (* patch *) split; unfold p_, p_k in |- *. apply Main_1; auto. intros i H15 H16. apply Main_1a'; auto. intros i0 H17 H18. rewrite H13. apply H8; auto with arith. intros i H15 H16. apply Main_1b'; auto. intros i0 H17 H18. rewrite <- H12. apply H8; auto with arith. apply Nat.le_trans with (S j); auto with arith. split. astepl ([1][*] (t[*]p3m (S j)) [^]n). astepl (a n[*] (t[*]p3m (S j)) [^]n). apply Main_2 with (k 0); auto. intros i H15 H16. apply Main_2'. apply H8; auto with arith. elim (H3 0); intros H3''' H3''''. split. apply Main_3 with (k 0); auto. apply H8; auto with arith. apply Main_2 with (k 0); auto. intros i H15 H16. apply Main_2'; auto with arith. Qed. (* end hide *) End Main_Lemma. corn-8.20.0/ftc/000077500000000000000000000000001473720167500133325ustar00rootroot00000000000000corn-8.20.0/ftc/COrdLemmas.v000066400000000000000000000442771473720167500155250ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.COrdCauchy. From Coq Require Import Lia. Section Lemmas. (** * Lemmas for Integration Here we include several lemmas valid in any ordered field [F] which are useful for integration. ** Merging orders We first prove that any two strictly ordered sets of points which have an empty intersection can be ordered as one (this will be the core of the proof that any two partitions with no common point have a common refinement). *) Variable F : COrdField. Lemma om_fun_lt : forall m n : nat, S m < S n -> m < n. Proof. auto with zarith. Qed. Definition om_fun n m (f : forall i, i < n -> F) (g : forall i, i < m -> F) (Hfg : forall i j Hi Hj, f i Hi [#] g j Hj) : forall i, i < m + n -> F. Proof. revert m f g Hfg. induction n as [| n Hrecn]. intros. apply (g i). rewrite <- plus_n_O in H; auto. intro m. induction m as [| m Hrecm]. do 3 intro. apply f. intros. elim (ap_imp_less _ _ _ (Hfg n m (Nat.lt_succ_diag_r n) (Nat.lt_succ_diag_r m))); intro. set (h := fun (i : nat) (Hi : i < m) => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. elim (le_lt_eq_dec _ _ H); intro. apply Hrecm with (f := f) (g := h) (i := i); unfold h in |- *; auto. apply om_fun_lt; auto. apply (g m (Nat.lt_succ_diag_r m)). clear Hrecm. set (h := fun (i : nat) (Hi : i < n) => f i (Nat.lt_lt_succ_r _ _ Hi)) in *. elim (le_lt_eq_dec _ _ H); intro. apply Hrecn with (f := h) (g := g) (i := i); unfold h in |- *; auto. apply om_fun_lt. rewrite plus_n_Sm. auto. apply (f n (Nat.lt_succ_diag_r n)). Defined. Lemma om_fun_1 : forall n m f g Hfg, nat_less_n_fun f -> nat_less_n_fun g -> nat_less_n_fun (om_fun n m f g Hfg). Proof. intro n. induction n as [| n Hrecn]. red in |- *; simpl in |- *; auto. intro m; induction m as [| m Hrecm]. red in |- *; simpl in |- *; auto. red in |- *; intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro; repeat (elim le_lt_eq_dec; simpl in |- *; intro); try (exfalso; auto with zarith; fail); try apply eq_reflexive_unfolded. set (h := fun (i : nat) (Hi : i < m) => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. exact (Hrecm f h Hfh H Hh i j H1 (om_fun_lt _ _ a0) (om_fun_lt _ _ a1)). apply Hrecn; try red in |- *; auto. Qed. Lemma om_fun_2a : forall n m f g Hfg (x : F), (forall i Hi, f i Hi [<] x) -> (forall i Hi, g i Hi [<] x) -> forall i Hi, om_fun n m f g Hfg i Hi [<] x. Proof. intro n. induction n as [| n Hrecn]. simpl in |- *; auto. intro m; induction m as [| m Hrecm]. simpl in |- *; auto. intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro; elim le_lt_eq_dec; simpl in |- *; intro; auto. set (h := fun (i : nat) (Hi : i < m) => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. set (Hh := fun i Hi => X0 i (Nat.lt_lt_succ_r _ _ Hi)) in *. exact (Hrecm f h Hfh x X Hh i (om_fun_lt _ _ a0)). Qed. Lemma om_fun_2 : forall n m f g Hfg, nat_less_n_fun f -> nat_less_n_fun g -> (forall i i' Hi Hi', i < i' -> f i Hi [<] f i' Hi') -> (forall i i' Hi Hi', i < i' -> g i Hi [<] g i' Hi') -> forall i i' Hi Hi', i < i' -> om_fun n m f g Hfg i Hi [<] om_fun n m f g Hfg i' Hi'. Proof. intro n. induction n as [| n Hrecn]. simpl in |- *; auto. intro m; induction m as [| m Hrecm]. simpl in |- *; auto. intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro; repeat (elim le_lt_eq_dec; simpl in |- *; intro); try (exfalso; auto with zarith; fail). set (h := fun (i : nat) (Hi : i < m) => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. set (inch := fun i i' Hi Hi' Hii' => X0 i i' (Nat.lt_lt_succ_r _ _ Hi) (Nat.lt_lt_succ_r _ _ Hi') Hii') in *. exact (Hrecm f h Hfh H Hh X inch i i' (om_fun_lt _ _ a0) (om_fun_lt _ _ a1) H1). set (h := fun (i : nat) (Hi : i < m) => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. refine (om_fun_2a _ _ f h Hfh (g m (Nat.lt_succ_diag_r m)) _ _ i (om_fun_lt _ _ a0)). intros j Hj. elim (le_lt_eq_dec _ _ Hj); intro. apply less_transitive_unfolded with (f n (Nat.lt_succ_diag_r n)); auto with arith. apply less_wdl with (f n (Nat.lt_succ_diag_r n)); auto. apply H; auto. inversion b0. auto. unfold h in |- *; auto. apply Hrecn; auto. red in |- *; auto. apply om_fun_2a; auto. intros j Hj. elim (le_lt_eq_dec _ _ Hj); intro. apply less_transitive_unfolded with (g m (Nat.lt_succ_diag_r m)); auto with arith. apply less_wdl with (g m (Nat.lt_succ_diag_r m)); auto. apply H0; auto. inversion b1. auto. Qed. Lemma om_fun_3a : forall n m f g Hfg, nat_less_n_fun f -> nat_less_n_fun g -> forall i Hi, {j : nat | {Hj : j < m + n | f i Hi [=] om_fun n m f g Hfg j Hj}}. Proof. intro n. induction n as [| n Hrecn]. simpl in |- *; intros. exfalso; inversion Hi. intro m; induction m as [| m Hrecm]. simpl in |- *; intros. exists i. exists Hi. algebra. intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro. set (h := fun i Hi => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. elim (Hrecm f h Hfh H Hh i Hi); intros j Hj. elim Hj; clear Hj; intros Hj Hj'. exists j; exists (Nat.lt_lt_succ_r _ _ Hj). elim le_lt_eq_dec; simpl in |- *; intro. astepl (om_fun _ _ f h Hfh _ Hj). refine (om_fun_1 _ _ f h Hfh H Hh j j _ Hj (om_fun_lt _ _ a0)). auto. exfalso; auto with zarith. elim (le_lt_eq_dec _ _ Hi); intro. set (h := fun i Hi => f i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j (Nat.lt_lt_succ_r _ _ Hi) Hj) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. elim (Hrecn _ h g Hfh Hh H0 i (om_fun_lt _ _ a)); intros j Hj. elim Hj; clear Hj; intros Hj Hj'. cut (j < S (m + S n)). intro. 2: auto with zarith. exists j; exists H1. elim le_lt_eq_dec; simpl in |- *; intro. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply Hj'. unfold h in |- *; apply H; auto. apply om_fun_1; auto. exfalso; auto with zarith. exists (m + S n). exists (Nat.lt_succ_diag_r (m + S n)). elim le_lt_eq_dec; simpl in |- *; intro. exfalso; auto with zarith. apply H. inversion b0. auto. Qed. Lemma om_fun_3b : forall n m f g Hfg, nat_less_n_fun f -> nat_less_n_fun g -> forall i Hi, {j : nat | {Hj : j < m + n | g i Hi [=] om_fun n m f g Hfg j Hj}}. Proof. intro n. induction n as [| n Hrecn]. simpl in |- *; intros. exists i. assert (i < m + 0). rewrite <- plus_n_O. auto. exists H1. algebra. intro m; induction m as [| m Hrecm]. simpl in |- *; intros. exfalso; inversion Hi. intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro. elim (le_lt_eq_dec _ _ Hi); intro. set (h := fun i Hi => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. elim (Hrecm f h Hfh H Hh i (om_fun_lt _ _ a0)); intros j Hj. elim Hj; clear Hj; intros Hj Hj'. exists j; exists (Nat.lt_lt_succ_r _ _ Hj). elim le_lt_eq_dec; simpl in |- *; intro. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply Hj'. unfold h in |- *; apply H0; auto. refine (om_fun_1 _ _ f h Hfh H Hh j j _ Hj (om_fun_lt _ _ a1)). auto. exfalso; auto with zarith. exists (m + S n). exists (Nat.lt_succ_diag_r (m + S n)). elim le_lt_eq_dec; simpl in |- *; intro. exfalso; auto with zarith. apply H0. inversion b. auto. set (h := fun i Hi => f i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j (Nat.lt_lt_succ_r _ _ Hi) Hj) in *. assert (Hh : nat_less_n_fun h). red in |- *; unfold h in |- *; auto. elim (Hrecn _ h g Hfh Hh H0 i Hi); intros j Hj. elim Hj; clear Hj; intros Hj Hj'. cut (j < S (m + S n)). intro. 2: auto with zarith. exists j; exists H1. elim le_lt_eq_dec; simpl in |- *; intro. eapply eq_transitive_unfolded. apply Hj'. apply om_fun_1; auto. exfalso; auto with zarith. Qed. Lemma om_fun_4a : forall n m f g Hfg (P : F -> CProp), pred_wd F P -> (forall i Hi, P (f i Hi)) -> (forall j Hj, P (g j Hj)) -> forall k Hk, P (om_fun n m f g Hfg k Hk). Proof. intro n. induction n as [| n Hrecn]. simpl in |- *; auto. intro m; induction m as [| m Hrecm]. simpl in |- *; auto. intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro; elim le_lt_eq_dec; simpl in |- *; intro; auto. set (h := fun i Hi => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. set (Hh := fun i Hi => X1 i (Nat.lt_lt_succ_r _ _ Hi)) in *. exact (Hrecm f h Hfh P X X0 Hh k (om_fun_lt _ _ a0)). apply Hrecn; auto. Qed. Lemma om_fun_4b : forall n m f g Hfg (P : F -> Prop), pred_wd' F P -> (forall i Hi, P (f i Hi)) -> (forall j Hj, P (g j Hj)) -> forall k Hk, P (om_fun n m f g Hfg k Hk). Proof. intro n. induction n as [| n Hrecn]. simpl in |- *; auto. intro m; induction m as [| m Hrecm]. simpl in |- *; auto. intros. simpl in |- *; elim ap_imp_less; simpl in |- *; intro; elim le_lt_eq_dec; simpl in |- *; intro; auto. set (h := fun i Hi => g i (Nat.lt_lt_succ_r _ _ Hi)) in *. set (Hfh := fun i j Hi Hj => Hfg i j Hi (Nat.lt_lt_succ_r _ _ Hj)) in *. set (Hh := fun i Hi => H1 i (Nat.lt_lt_succ_r _ _ Hi)) in *. exact (Hrecm f h Hfh P H H0 Hh k (om_fun_lt _ _ a0)). apply Hrecn; auto. Qed. Lemma om_fun_4c : forall n m f g Hfg (P : F -> CProp), pred_wd F P -> nat_less_n_fun f -> nat_less_n_fun g -> {i : nat | {Hi : i < n | P (f i Hi)}} or {j : nat | {Hj : j < m | P (g j Hj)}} -> {k : nat | {Hk : k < m + n | P (om_fun n m f g Hfg k Hk)}}. Proof. intros n m f g Hfg P HP Hf Hg H. elim H; intro H'; elim H'; intros i Hi; elim Hi; clear H H' Hi; intros Hi Hi'. elim (om_fun_3a _ _ _ _ Hfg Hf Hg i Hi). intros j Hj. elim Hj; clear Hj. intros Hj Hj'. exists j; exists Hj; apply HP with (x := f i Hi); auto. elim (om_fun_3b _ _ _ _ Hfg Hf Hg i Hi). intros j Hj. elim Hj; clear Hj. intros Hj Hj'. exists j; exists Hj; apply HP with (x := g i Hi); auto. Qed. Lemma om_fun_4d : forall n m f g Hfg (P : F -> Prop), pred_wd' F P -> nat_less_n_fun f -> nat_less_n_fun g -> {i : nat | {Hi : i < n | P (f i Hi)}} or {j : nat | {Hj : j < m | P (g j Hj)}} -> {k : nat | {Hk : k < m + n | P (om_fun n m f g Hfg k Hk)}}. Proof. intros n m f g Hfg P HP Hf Hg H. elim H; intro H'; elim H'; intros i Hi; elim Hi; clear H H' Hi; intros Hi Hi'. elim (om_fun_3a _ _ _ _ Hfg Hf Hg i Hi). intros j Hj. elim Hj; clear Hj. intros Hj Hj'. exists j; exists Hj; apply HP with (x := f i Hi); auto. elim (om_fun_3b _ _ _ _ Hfg Hf Hg i Hi). intros j Hj. elim Hj; clear Hj. intros Hj Hj'. exists j; exists Hj; apply HP with (x := g i Hi); auto. Qed. (* begin hide *) Variable f : nat -> nat. Hypothesis f0 : f 0 = 0. Hypothesis f_mon : forall i j : nat, i < j -> f i < f j. Variable h : nat -> F. (* end hide *) (** ** Summations Also, some technical stuff on sums. The first lemma relates two different kinds of sums; the other two ones are variations, where the structure of the arguments is analyzed in more detail. *) Lemma Sumx_Sum_Sum : forall n, Sumx (fun i (H : i < n) => Sum (f i) (pred (f (S i))) h) [=] Sumx (fun i (H : i < f n) => h i). Proof. simple induction n. rewrite f0; simpl in |- *; algebra. clear n; intros. elim (le_lt_dec n 0); intro. cut (n = 0); [ clear a; intro | auto with arith ]. rewrite H0 in H. rewrite H0. clear H0. simpl in |- *. astepl (Sum (f 0) (pred (f 1)) h). rewrite f0. apply eq_symmetric. eapply eq_transitive. apply Sumx_to_Sum. pattern 0 at 1 in |- *; rewrite <- f0; apply f_mon; apply Nat.lt_succ_diag_r. intros i j H0 H1 H'; rewrite H0; algebra. clear H; apply Sum_wd'; unfold part_tot_nat_fun in |- *; auto with arith. intros. elim (le_lt_dec (f 1) i); intro; simpl in |- *. cut (0 < f 1). intro; exfalso; lia. pattern 0 at 1 in |- *; rewrite <- f0; apply f_mon; apply Nat.lt_succ_diag_r. algebra. cut (0 < f n); [ intro | rewrite <- f0; apply f_mon; assumption ]. simpl in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Sumx_to_Sum. apply eq_transitive_unfolded with (Sum 0 (pred (f n)) (part_tot_nat_fun _ _ (fun (i : nat) (H : i < f n) => h i)) [+] Sum (f n) (pred (f (S n))) h). apply bin_op_wd_unfolded. eapply eq_transitive_unfolded. apply H. apply Sumx_to_Sum; try assumption. red in |- *; intros; rewrite H1; algebra. algebra. cut (f n = S (pred (f n))); [ intro | symmetry; apply Nat.lt_succ_pred with 0; auto ]. setoid_rewrite H1 at 3. eapply eq_transitive_unfolded. 2: apply Sum_Sum with (m := pred (f n)). apply bin_op_wd_unfolded; apply Sum_wd'. rewrite <- H1; apply Nat.lt_le_incl; assumption. intros. elim (le_lt_dec (f n) i); intro; simpl in |- *. exfalso; lia. elim (le_lt_dec (f (S n)) i); intro; simpl in |- *. cut (f n < f (S n)); [ intro | apply f_mon; apply Nat.lt_succ_diag_r ]. exfalso; apply (Nat.le_ngt (f n) i); auto. apply Nat.le_trans with (f (S n)); auto with arith. intros; unfold part_tot_nat_fun in |- *; elim (le_lt_dec (f (S n)) i);elim (le_lt_dec (f n) i);simpl;intros; try reflexivity;try exfalso; try lia. rewrite <-H1; cut (0 < f (S n)); [ intro | rewrite <- f0; auto with arith ]; cut (f (S n) = S (pred (f (S n)))); [ intro | symmetry; apply Nat.lt_succ_pred with 0; auto ]; rewrite <- H3; apply Nat.lt_le_incl; auto with arith. intros; unfold part_tot_nat_fun in |- *;elim (le_lt_dec (f (S n)) i); [intro; simpl in |- *; exfalso; lia| reflexivity]. apply Nat.lt_trans with (f n); auto with arith. red in |- *; intros; rewrite -> H1; reflexivity. Qed. Lemma str_Sumx_Sum_Sum : forall n (g : (forall i Hi, nat -> F)), (forall i j Hi, f i <= j -> j < f (S i) -> g i Hi j [=] h j) -> forall m, m = f n -> Sumx (fun i (H : i < n) => Sum (f i) (pred (f (S i))) (g i H)) [=] Sumx (fun i (H : i < m) => h i). Proof. intros. rewrite H0. eapply eq_transitive_unfolded. 2: apply Sumx_Sum_Sum. apply Sumx_wd. intros. apply Sum_wd'. cut (0 < f (S i)); [ intro | rewrite <- f0; auto with arith ]. cut (f (S i) = S (pred (f (S i)))); [ intro | symmetry; apply Nat.lt_succ_pred with 0; auto ]. rewrite <- H3. apply Nat.lt_le_incl; auto with arith. intros; apply H. assumption. rewrite <- (Nat.lt_succ_pred 0 (f (S i))); auto with arith. rewrite <- f0; auto with arith. Qed. End Lemmas. Section More_Lemmas. (* begin hide *) Let f' (m : nat) (f : forall i, i <= m -> nat) : nat -> nat. Proof. intros i. elim (le_lt_dec i m); intro. apply (f i a). apply (f m (le_n m) + i). Defined. (* end hide *) Variable F : COrdField. Lemma str_Sumx_Sum_Sum' : forall (m : nat) (f : forall i, i <= m -> nat), f 0 (Nat.le_0_l _) = 0 -> (forall (i j : nat) Hi Hj, i = j -> f i Hi = f j Hj) -> (forall (i j : nat) Hi Hj, i < j -> f i Hi < f j Hj) -> forall (h : nat -> F) (n : nat) (g : forall i : nat, i < m -> nat -> F), (forall (i j : nat) Hi Hi' Hi'', f i Hi' <= j -> j < f (S i) Hi'' -> g i Hi j [=] h j) -> (forall H, n = f m H) -> Sumx (fun (i : nat) (H : i < m) => Sum (f i (Nat.lt_le_incl _ _ H)) (pred (f (S i) H)) (g i H)) [=] Sumx (fun (i : nat) (_ : i < n) => h i). Proof. intros. cut (forall (i : nat) (H : i <= m), f i H = f' m f i). intros. apply eq_transitive_unfolded with (Sumx (fun (i : nat) (H3 : i < m) => Sum (f' m f i) (pred (f' m f (S i))) (g i H3))). apply Sumx_wd; intros. rewrite <- (H4 i (Nat.lt_le_incl _ _ H5)); rewrite <- (H4 (S i) H5); apply Sum_wd'. rewrite -> (Nat.lt_succ_pred (f i (Nat.lt_le_incl _ _ H5)) (f (S i) H5) (H1 _ _ _ _ (Nat.lt_succ_diag_r i))) . apply Nat.lt_le_incl; apply H1; apply Nat.lt_succ_diag_r. intros; algebra. apply str_Sumx_Sum_Sum. unfold f' in |- *; simpl in |- *. elim (le_lt_dec 0 m); intro; simpl in |- *. transitivity (f 0 (Nat.le_0_l m)). apply H0; auto. apply H. exfalso; inversion b. intros; apply nat_local_mon_imp_mon. clear H5 j i; intros. unfold f' in |- *. elim (le_lt_dec i m); elim (le_lt_dec (S i) m); intros; simpl in |- *. apply H1; apply Nat.lt_succ_diag_r. cut (i = m); [ intro | apply Nat.le_antisymm; auto with arith ]. generalize a; clear a; pattern i at 1 2 in |- *; rewrite H5; intro. set (x := f m a) in *. cut (x = f m (le_n m)). 2: unfold x in |- *; apply H0; auto. intro. rewrite <- H6. rewrite <- plus_n_Sm; auto with arith. exfalso; apply (Nat.le_ngt i m); auto with arith. set (x := f m (le_n m)) in *; clearbody x; auto with arith. assumption. intros. apply H2 with (Hi' := Nat.lt_le_incl _ _ Hi) (Hi'' := Hi). rewrite H4; assumption. rewrite H4; assumption. unfold f' in |- *. elim (le_lt_dec m m); intro; simpl in |- *. apply H3. elim (Nat.lt_irrefl _ b). clear H3 H2 g n h; intros. unfold f' in |- *. elim (le_lt_dec i m); intro; simpl in |- *. apply H0; auto. lia; auto. Qed. End More_Lemmas. corn-8.20.0/ftc/CalculusTheorems.v000066400000000000000000000634731473720167500170200ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Rolle. Require Export CoRN.tactics.DiffTactics3. Opaque Min Max. Section Various_Theorems. (** * Calculus Theorems This file is intended to present a collection of miscellaneous, mostly technical results in differential calculus that are interesting or useful in future work. We begin with some properties of continuous functions. Every continuous function commutes with the limit of a numerical sequence (sometimes called Heine continuity). *) Lemma Continuous_imp_comm_Lim : forall F x e, [0] [<] e -> Continuous (clcr (Lim x[-]e) (Lim x[+]e)) F -> forall Hx Hxn H, F (Lim x) Hx [=] Lim (Build_CauchySeq IR (fun n => F (x n) (Hxn n)) H). Proof. intros F x e H H0 Hx Hxn H1. set (a := Lim x) in *. set (I := clcr (a[-]e) (a[+]e)) in *. cut (compact_ I). intro H2. 2: simpl in |- *. 2: apply less_leEq; apply less_transitive_unfolded with a. 2: apply shift_minus_less; apply shift_less_plus'. 2: astepl ZeroR; auto. 2: apply shift_less_plus'. 2: astepl ZeroR; auto. apply Limits_unique. simpl in |- *. intros eps H3. set (H2' := H2) in *. cut (Continuous_I (a:=Lend H2) (b:=Rend H2) H2' F). intro H4. 2: apply Int_Continuous; auto. elim (contin_prop _ _ _ _ H4 _ H3); intros d H5 H6. elim (Cauchy_complete x (Min d e)). 2: apply less_Min; auto. intros N HN. exists N; intros. fold a in HN. apply AbsIR_imp_AbsSmall. elim (HN m H7); intros. apply H6. split; simpl in |- *. unfold cg_minus in |- *; apply shift_plus_leEq'. eapply leEq_transitive. 2: apply H8. apply inv_resp_leEq; apply Min_leEq_rht. apply shift_leEq_plus'. eapply leEq_transitive. apply H9. apply Min_leEq_rht. split; simpl in |- *. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply shift_leEq_plus'; astepl ZeroR. apply less_leEq; auto. apply AbsSmall_imp_AbsIR. apply AbsSmall_leEq_trans with (Min d e). apply Min_leEq_lft. auto. Qed. (** This is a tricky result: if [F] is continuous and positive in both [[a,b]] and [(b,c]], then it is positive in [[a,c]]. *) Lemma Continuous_imp_pos : forall a b c (Hac : a [<=] c), a [<=] b -> b [<] c -> forall F, Continuous_I Hac F -> (forall t, a [<=] t -> t [<=] b -> forall Ht, [0] [<] F t Ht) -> (forall t, b [<] t -> t [<=] c -> forall Ht, [0] [<] F t Ht) -> forall t, a [<=] t -> t [<=] c -> forall Ht, [0] [<] F t Ht. Proof. intros a b c Hac H H0 F H1 H2 H3 t H4 H5 Ht. elim H1; intros H6 H7; clear H1. cut (Compact Hac b); [ intro H1 | split; auto ]. 2: apply less_leEq; auto. set (e := F b (H6 _ H1) [/]TwoNZ) in *. cut ([0] [<] e); intros. 2: unfold e in |- *; apply pos_div_two; apply H2; auto. 2: apply leEq_reflexive. elim H7 with e; auto. intros d H9 H10. cut (b[-]d [<] b). 2: apply shift_minus_less; apply shift_less_plus'. 2: astepl ZeroR; auto. intro H11. elim (less_cotransitive_unfolded _ _ _ H11 t); intro. clear H11. elim (less_cotransitive_unfolded _ _ _ H9 (t[-]b)); intro. apply H3. astepl ([0][+]b); apply shift_plus_less; auto. auto. apply cont_no_sign_change_pos with (Hab := Hac) (e := e) (Hx := H6 _ H1); auto. split; auto. apply H10; auto. split; auto. apply AbsSmall_imp_AbsIR. apply AbsIR_eq_AbsSmall. rstepr ( [--] (t[-]b)); apply inv_resp_leEq. apply less_leEq; auto. apply less_leEq; apply shift_minus_less; apply shift_less_plus'; auto. unfold e in |- *. eapply less_leEq_trans. apply pos_div_two'. apply H2; auto. apply leEq_reflexive. apply leEq_AbsIR. unfold e in |- *. apply pos_div_two'. apply H2; auto. apply leEq_reflexive. apply H2; auto. apply less_leEq; auto. Qed. (** Similar results for increasing functions: *) Lemma strict_inc_glues : forall a b c F (Hab : a [<=] b) (Hbc : b [<=] c) (Hac : a [<=] c), included (Compact Hac) (Dom F) -> (forall x y, Compact Hab x -> Compact Hab y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) -> (forall x y, Compact Hbc x -> Compact Hbc y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) -> forall x y, Compact Hac x -> Compact Hac y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy. Proof. do 7 intro. intros H H0 H1 x y H2 H3 H4 Hx Hy. cut (Dom F a); [ intro Ha | apply H; apply compact_inc_lft ]. cut (Dom F b); [ intro Hb | apply H; split; auto ]. cut (Dom F c); [ intro Hc | apply H; apply compact_inc_rht ]. elim (less_cotransitive_unfolded _ _ _ H4 b); intro. cut (Dom F (Min b y)); [ intro H5 | apply H; split ]. 2: apply leEq_Min; auto; elim H3; auto. 2: eapply leEq_transitive; [ apply Min_leEq_lft | auto ]. apply less_leEq_trans with (F _ H5). cut (Dom F (Min ((x[+]b) [/]TwoNZ) y)); [ intro Hxy | apply H; split ]. 3: elim H3; intros; eapply leEq_transitive; [ apply Min_leEq_rht | auto ]. 2: apply leEq_Min. 3: elim H3; auto. 2: apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ]. 2: apply plus_resp_leEq_both; elim H2; auto. apply less_leEq_trans with (F _ Hxy). apply H0; try split. elim H2; auto. apply less_leEq; auto. apply leEq_Min. 2: elim H3; auto. apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ]. apply plus_resp_leEq_both; elim H2; auto. eapply leEq_transitive. apply Min_leEq_lft. apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ]. apply plus_resp_leEq; apply less_leEq; auto. apply less_Min; auto. apply shift_less_div; [ apply pos_two | rstepl (x[+]x) ]. apply plus_resp_leEq_less; [ apply leEq_reflexive | auto ]. apply part_mon_imp_mon' with (Compact Hab); auto. intros x0 H6; apply H; inversion_clear H6; split; auto. apply leEq_transitive with b; auto. split. apply leEq_Min. apply shift_leEq_div; [ apply pos_two | rstepl (a[+]a) ]. apply plus_resp_leEq_both; auto; elim H2; auto. elim H3; auto. eapply leEq_transitive. apply Min_leEq_lft. apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ]. apply plus_resp_leEq; apply less_leEq; auto. split. apply leEq_Min; auto; elim H3; auto. apply Min_leEq_lft. apply leEq_Min. eapply leEq_transitive. apply Min_leEq_lft. apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ]. apply plus_resp_leEq; apply less_leEq; auto. apply Min_leEq_rht. rewrite -> leEq_def; intro H6. cut (y [<=] b). intro H7. apply (less_irreflexive_unfolded _ (F y Hy)). eapply less_wdr. apply H6. apply pfwdef; eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft; auto. rewrite -> leEq_def; intro H7. apply (less_irreflexive_unfolded _ (F y Hy)). eapply less_transitive_unfolded. apply H6. apply less_wdl with (F b Hb). 2: apply pfwdef; apply eq_symmetric_unfolded; apply leEq_imp_Min_is_lft; apply less_leEq; auto. apply H1; auto. apply compact_inc_lft. split; [ apply less_leEq | elim H3 ]; auto. cut (Dom F (Max b x)); [ intro H5 | apply H; split ]. 3: apply Max_leEq; auto; elim H2; auto. 2: eapply leEq_transitive; [ apply Hab | apply lft_leEq_Max ]. apply leEq_less_trans with (F _ H5). 2: cut (Dom F (Max ((y[+]b) [/]TwoNZ) x)); [ intro Hxy | apply H; split ]. 3: elim H2; intros; eapply leEq_transitive; [ apply a0 | apply rht_leEq_Max ]. 3: apply Max_leEq. 4: elim H2; auto. 3: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ]. 3: apply plus_resp_leEq_both; elim H3; auto. 2: apply leEq_less_trans with (F _ Hxy). 3: apply H1; try split. 6: elim H3; auto. 5: apply less_leEq; auto. 4: apply Max_leEq. 5: elim H2; auto. 4: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ]. 4: apply plus_resp_leEq_both; elim H3; auto. 3: eapply leEq_transitive. 4: apply lft_leEq_Max. 3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ]. 3: apply plus_resp_leEq; apply less_leEq; auto. 3: apply Max_less; auto. 3: apply shift_div_less; [ apply pos_two | rstepr (y[+]y) ]. 3: apply plus_resp_less_lft; auto. 2: apply part_mon_imp_mon' with (Compact Hbc); auto. 2: intros x0 H6; apply H; inversion_clear H6; split; auto. 2: apply leEq_transitive with b; auto. 3: split. 4: apply Max_leEq. 4: apply shift_div_leEq; [ apply pos_two | rstepr (c[+]c) ]. 4: apply plus_resp_leEq_both; auto; elim H3; auto. 4: elim H2; auto. 3: eapply leEq_transitive. 4: apply lft_leEq_Max. 3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ]. 3: apply plus_resp_leEq; apply less_leEq; auto. 2: split. 3: apply Max_leEq; auto; elim H2; auto. 2: apply lft_leEq_Max. 2: apply Max_leEq. 2: eapply leEq_transitive. 3: apply lft_leEq_Max. 2: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ]. 2: apply plus_resp_leEq; apply less_leEq; auto. 2: apply rht_leEq_Max. rewrite -> leEq_def; intro H6. cut (b [<=] x); rewrite -> leEq_def; intro H7. apply (less_irreflexive_unfolded _ (F x Hx)). eapply less_wdl. apply H6. apply pfwdef; apply leEq_imp_Max_is_rht; rewrite -> leEq_def; auto. apply (less_irreflexive_unfolded _ (F x Hx)). eapply less_transitive_unfolded. 2: apply H6. apply less_wdr with (F b Hb). 2: apply pfwdef; apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply Max_comm. 2: apply leEq_imp_Max_is_rht; apply less_leEq; auto. apply H0; auto. 2: apply compact_inc_rht. split; [ elim H2 | apply less_leEq ]; auto. Qed. Lemma strict_inc_glues' : forall a b c F, a [<] b -> b [<] c -> included (olor a c) (Dom F) -> (forall x y, olcr a b x -> olcr a b y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) -> (forall x y, clor b c x -> clor b c y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) -> forall x y, olor a c x -> olor a c y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy. Proof. intros a b c F Hab Hbc H H0 H1 x y H2 H3 H4 Hx Hy. cut (Dom F b); [ intro Hb | apply H; split; auto ]. elim (less_cotransitive_unfolded _ _ _ H4 b); intro. cut (Dom F (Min b y)); [ intro H5 | apply H; split ]. 2: apply less_Min; auto; elim H3; auto. 2: eapply leEq_less_trans; [ apply Min_leEq_lft | auto ]. apply less_leEq_trans with (F _ H5). cut (Dom F (Min ((x[+]b) [/]TwoNZ) y)); [ intro Hxy | apply H; split ]. 3: elim H3; intros; eapply leEq_less_trans; [ apply Min_leEq_rht | auto ]. 2: apply less_Min. 3: elim H3; auto. 2: apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ]. 2: apply plus_resp_less_both; elim H2; auto. apply less_leEq_trans with (F _ Hxy). apply H0; try split. elim H2; auto. apply less_leEq; auto. apply less_Min. 2: elim H3; auto. apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ]. apply plus_resp_less_both; elim H2; auto. eapply leEq_transitive. apply Min_leEq_lft. apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ]. apply plus_resp_leEq; apply less_leEq; auto. apply less_Min; auto. apply shift_less_div; [ apply pos_two | rstepl (x[+]x) ]. apply plus_resp_leEq_less; [ apply leEq_reflexive | auto ]. apply part_mon_imp_mon' with (iprop (olcr a b)); auto. intros x0 H6; apply H; inversion_clear H6; split; auto. apply leEq_less_trans with b; auto. split. apply less_Min. apply shift_less_div; [ apply pos_two | rstepl (a[+]a) ]. apply plus_resp_less_both; auto; elim H2; auto. elim H3; auto. eapply leEq_transitive. apply Min_leEq_lft. apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ]. apply plus_resp_leEq; apply less_leEq; auto. split. apply less_Min; auto; elim H3; auto. apply Min_leEq_lft. apply leEq_Min. eapply leEq_transitive. apply Min_leEq_lft. apply shift_div_leEq; [ apply pos_two | rstepr (b[+]b) ]. apply plus_resp_leEq; apply less_leEq; auto. apply Min_leEq_rht. rewrite -> leEq_def; intro H6. cut (y [<=] b); rewrite -> leEq_def; intro H7. apply (less_irreflexive_unfolded _ (F y Hy)). eapply less_wdr. apply H6. apply pfwdef; eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft; rewrite -> leEq_def; auto. apply (less_irreflexive_unfolded _ (F y Hy)). eapply less_transitive_unfolded. apply H6. apply less_wdl with (F b Hb). 2: apply pfwdef; apply eq_symmetric_unfolded; apply leEq_imp_Min_is_lft; apply less_leEq; auto. apply H1; auto. split; auto; apply leEq_reflexive. split; [ apply less_leEq | elim H3 ]; auto. cut (Dom F (Max b x)); [ intro H5 | apply H; split ]. 3: apply Max_less; auto; elim H2; auto. 2: eapply less_leEq_trans; [ apply Hab | apply lft_leEq_Max ]. apply leEq_less_trans with (F _ H5). 2: cut (Dom F (Max ((y[+]b) [/]TwoNZ) x)); [ intro Hxy | apply H; split ]. 3: elim H2; intros; eapply less_leEq_trans; [ apply a0 | apply rht_leEq_Max ]. 3: apply Max_less. 4: elim H2; auto. 3: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ]. 3: apply plus_resp_less_both; elim H3; auto. 2: apply leEq_less_trans with (F _ Hxy). 3: apply H1; try split. 6: elim H3; auto. 5: apply less_leEq; auto. 4: apply Max_less. 5: elim H2; auto. 4: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ]. 4: apply plus_resp_less_both; elim H3; auto. 3: eapply leEq_transitive. 4: apply lft_leEq_Max. 3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ]. 3: apply plus_resp_leEq; apply less_leEq; auto. 3: apply Max_less; auto. 3: apply shift_div_less; [ apply pos_two | rstepr (y[+]y) ]. 3: apply plus_resp_less_lft; auto. 2: apply part_mon_imp_mon' with (iprop (clor b c)); auto. 2: intros x0 H6; apply H; inversion_clear H6; split; auto. 2: apply less_leEq_trans with b; auto. 3: split. 4: apply Max_less. 4: apply shift_div_less; [ apply pos_two | rstepr (c[+]c) ]. 4: apply plus_resp_less_both; auto; elim H3; auto. 4: elim H2; auto. 3: eapply leEq_transitive. 4: apply lft_leEq_Max. 3: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ]. 3: apply plus_resp_leEq; apply less_leEq; auto. 2: split. 3: apply Max_less; auto; elim H2; auto. 2: apply lft_leEq_Max. 2: apply Max_leEq. 2: eapply leEq_transitive. 3: apply lft_leEq_Max. 2: apply shift_leEq_div; [ apply pos_two | rstepl (b[+]b) ]. 2: apply plus_resp_leEq; apply less_leEq; auto. 2: apply rht_leEq_Max. rewrite -> leEq_def; intro H6. cut (b [<=] x); rewrite -> leEq_def; intro H7. apply (less_irreflexive_unfolded _ (F x Hx)). eapply less_wdl. apply H6. apply pfwdef; apply leEq_imp_Max_is_rht; rewrite -> leEq_def; auto. apply (less_irreflexive_unfolded _ (F x Hx)). eapply less_transitive_unfolded. 2: apply H6. apply less_wdr with (F b Hb). 2: apply pfwdef; apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply Max_comm. 2: apply leEq_imp_Max_is_rht; apply less_leEq; auto. apply H0; auto. split; [ elim H2 | apply less_leEq ]; auto. split; auto; apply leEq_reflexive. Qed. Lemma strict_dec_glues : forall a b c F (Hab : a [<=] b) (Hbc : b [<=] c) (Hac : a [<=] c), included (Compact Hac) (Dom F) -> (forall x y, Compact Hab x -> Compact Hab y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) -> (forall x y, Compact Hbc x -> Compact Hbc y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) -> forall x y, Compact Hac x -> Compact Hac y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy. Proof. intros. apply inv_cancel_less. astepl ( {--}F y Hy); astepr ( {--}F x Hx). apply strict_inc_glues with a b c Hab Hbc Hac; auto. intros; simpl in |- *; apply inv_resp_less; auto. intros; simpl in |- *; apply inv_resp_less; auto. Qed. Lemma strict_dec_glues' : forall a b c F, a [<] b -> b [<] c -> included (olor a c) (Dom F) -> (forall x y, olcr a b x -> olcr a b y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) -> (forall x y, clor b c x -> clor b c y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy) -> forall x y, olor a c x -> olor a c y -> y[<]x -> forall Hx Hy, F x Hx [<] F y Hy. Proof. intros. apply inv_cancel_less. astepl ( {--}F y Hy); astepr ( {--}F x Hx). apply strict_inc_glues' with a b c; auto. intros; simpl in |- *; apply inv_resp_less; auto. intros; simpl in |- *; apply inv_resp_less; auto. Qed. (** More on glueing intervals. *) Lemma olor_pos_clor_nonneg : forall a b (F : PartIR), (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Ha, [0] [<=] F a Ha -> forall x, clor a b x -> forall Hx, [0] [<=] F x Hx. Proof. intros a b F H Ha H0 x H1 Hx. rewrite -> leEq_def; intros H2. cut (Not (olor a b x)); intro H3. cut (x [=] a). intro H4. rewrite -> leEq_def in H0; apply H0. eapply less_wdl; [ apply H2 | algebra ]. red in H3. apply not_ap_imp_eq; intro H4. inversion_clear H1. elim (ap_imp_less _ _ _ H4); intros. apply (less_irreflexive_unfolded _ a); apply leEq_less_trans with x; auto. apply H3; split; auto. apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto. Qed. Lemma olor_pos_olcr_nonneg : forall a b (F : PartIR), (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Hb, [0] [<=] F b Hb -> forall x, olcr a b x -> forall Hx, [0] [<=] F x Hx. Proof. intros a b F H Ha H0 x H1 Hx. rewrite -> leEq_def; intros H2. cut (Not (olor a b x)); intro H3. cut (x [=] b). intro H4. rewrite -> leEq_def in H0; apply H0. eapply less_wdl; [ apply H2 | algebra ]. red in H3. apply not_ap_imp_eq; intro H4. inversion_clear H1. elim (ap_imp_less _ _ _ H4); intros. apply H3; split; auto. apply (less_irreflexive_unfolded _ b); apply less_leEq_trans with x; auto. apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto. Qed. Lemma olor_pos_clcr_nonneg : forall a b (F : PartIR), a [<] b -> (forall x, olor a b x -> forall Hx, [0] [<] F x Hx) -> forall Ha, [0] [<=] F a Ha -> forall Hb, [0] [<=] F b Hb -> forall x, clcr a b x -> forall Hx, [0] [<=] F x Hx. Proof. intros a b F Hab H Ha H0 Hb H1 x H2 Hx. rewrite -> leEq_def; intros H3. cut (Not (olor a b x)); intro H4. elim (less_cotransitive_unfolded _ _ _ Hab x); intro H5. cut (x [=] b). intro H6. rewrite -> leEq_def in H1; apply H1. eapply less_wdl; [ apply H3 | algebra ]. red in H4. apply not_ap_imp_eq; intro H6. inversion_clear H2. elim (ap_imp_less _ _ _ H6); intros. apply H4; split; auto. apply (less_irreflexive_unfolded _ b); apply less_leEq_trans with x; auto. cut (x [=] a); intros. rewrite -> leEq_def in H0; apply H0. eapply less_wdl; [ apply H3 | algebra ]. red in H4. apply not_ap_imp_eq; intro. inversion_clear H2. elim (ap_imp_less _ _ _ X); intros. apply (less_irreflexive_unfolded _ a); apply leEq_less_trans with x; auto. apply H4; split; auto. apply (less_irreflexive_unfolded IR [0]); apply less_transitive_unfolded with (F x Hx); auto. Qed. (** Any function that has the null function as its derivative must be constant. *) Lemma FConst_prop : forall J pJ F', Derivative J pJ F' [-C-][0] -> {c : IR | Feq J F' [-C-]c}. Proof. intros J pJ F' H. elim (nonvoid_point _ (proper_nonvoid _ pJ)); intros x0 Hx0. exists (F' x0 (Derivative_imp_inc _ _ _ _ H x0 Hx0)). FEQ. rename X into H0. simpl in |- *. apply cg_inv_unique_2. apply AbsIR_approach_zero; intros e H1. simpl in Hx'. elim (Law_of_the_Mean _ _ _ _ H _ _ Hx0 H0 e H1). intros y H2 H3. eapply leEq_wdl. apply (H3 (Derivative_imp_inc _ _ _ _ H _ Hx0) Hx I). apply AbsIR_wd; simpl in |- *; rational. Qed. (** As a corollary, two functions with the same derivative must differ by a constant. *) Lemma Feq_crit_with_const : forall J pJ F G H, Derivative J pJ F H -> Derivative J pJ G H -> {c : IR | Feq J (F{-}G) [-C-]c}. Proof. intros. apply FConst_prop with pJ. Derivative_Help; FEQ. Qed. (** This yields the following known result: any differential equation of the form [f'=g] with initial condition [f(a) [=] b] has a unique solution. *) Lemma Feq_criterium : forall J pJ F G H, Derivative J pJ F H -> Derivative J pJ G H -> forall x, J x -> (forall Hx Hx', F x Hx [=] G x Hx') -> Feq J F G. Proof. do 5 intro. intros H0 H1 x H2 H3. elim (Feq_crit_with_const _ _ _ _ _ H0 H1); intros c Hc. apply Feq_transitive with (F{-}G{+}G). FEQ. apply Feq_transitive with ( [-C-][0]{+}G). 2: FEQ. apply Feq_plus. 2: apply Feq_reflexive; Included. apply Feq_transitive with ( [-C-]c). auto. FEQ. rename X into H4. simpl in |- *. elim Hc; intros H5 H6. elim H6; clear H6; intros H7 H6. clear Hc H5 H7 Hx' Hx. simpl in H6. cut (Conj (Dom F) (Dom G) x). intro H5. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply H6 with (Hx := H5); auto. apply eq_symmetric_unfolded; apply x_minus_x; auto. split. exact (Derivative_imp_inc _ _ _ _ H0 _ H2). exact (Derivative_imp_inc _ _ _ _ H1 _ H2). Qed. (** Finally, a well known result: any function with a (strictly) positive derivative is (strictly) increasing. Although the two lemmas look quite similar the proofs are completely different, both from the formalization and from the mathematical point of view. *) Lemma Derivative_imp_resp_less : forall J pJ a b F F', Derivative J pJ F F' -> a [<] b -> J a -> J b -> (forall contF', [0] [<] glb_funct _ _ (Min_leEq_Max a b) F' contF') -> forall Ha Hb, F a Ha [<] F b Hb. Proof. intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb. apply shift_zero_less_minus'. cut (Continuous_I (Min_leEq_Max a b) F'). intro H. 2: apply included_imp_Continuous with J; [ apply Derivative_imp_Continuous' with pJ F | apply included_interval ]; auto. elim (glb_is_glb _ _ _ _ H). simpl in |- *; intros Hglb1 Hglb2. cut ([0] [<] glb_funct _ _ _ _ H); [ intro H0 | auto ]. elim (Law_of_the_Mean _ _ _ _ derF a b) with (e := (glb_funct _ _ _ _ H[*] (b[-]a)) [/]TwoNZ); auto. intros x H1 H2. apply less_leEq_trans with (F' x (contin_imp_inc _ _ _ _ H x H1) [*] (b[-]a) [-] (glb_funct _ _ _ _ H[*] (b[-]a)) [/]TwoNZ). rstepr ((F' x (contin_imp_inc _ _ _ _ H x H1) [-]glb_funct _ _ _ _ H [/]TwoNZ) [*] (b[-]a)). apply mult_resp_pos. apply shift_less_minus; astepl (glb_funct _ _ _ _ H [/]TwoNZ). eapply less_leEq_trans. apply pos_div_two'; auto. apply glb_prop. auto. apply shift_less_minus; astepl a; auto. apply shift_minus_leEq; apply shift_leEq_plus'. rstepl ( [--] (Part _ _ Hb[-]Part _ _ Ha[-] Part _ _ (contin_imp_inc _ _ _ _ H _ H1) [*] (b[-]a))). eapply leEq_transitive. apply inv_leEq_AbsIR. apply H2. apply pos_div_two; apply mult_resp_pos; auto. apply shift_less_minus; astepl a; auto. Qed. Lemma Derivative_imp_resp_leEq : forall J pJ a b F F', Derivative J pJ F F' -> a [<=] b -> J a -> J b -> (forall contF', [0] [<=] glb_funct _ _ (Min_leEq_Max b a) F' contF') -> forall Ha Hb, F a Ha [<=] F b Hb. Proof. intros J pJ a b F F' derF Hab HaJ HbJ Hglb Ha Hb. astepr ([0][+]Part _ _ Hb); apply shift_leEq_plus. cut (Continuous_I (Min_leEq_Max b a) F'). intro H. 2: apply included_imp_Continuous with J; [ apply Derivative_imp_Continuous' with pJ F | apply included_interval ]; auto. elim (glb_is_glb _ _ _ _ H). simpl in |- *; intros Hglb1 Hglb2. cut ([0] [<=] glb_funct _ _ _ _ H); [ intro H0 | auto ]. apply approach_zero_weak. intros. elim (Law_of_the_Mean _ _ _ _ derF b a) with (e := e); auto. intros x H2 H3. eapply leEq_transitive. 2: apply (H3 Hb Ha (contin_imp_inc _ _ _ _ H x H2)). eapply leEq_transitive. 2: apply leEq_AbsIR. rstepl (Part _ _ Ha[-]Part _ _ Hb[-][--][0]). unfold cg_minus at 1 3 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. rstepl ( [--] (Part _ _ (contin_imp_inc _ _ _ _ H _ H2) [*] (b[-]a))). apply inv_resp_leEq. apply mult_resp_nonneg. eapply leEq_transitive; [ apply H0 | apply Hglb1 ]. exists x. split. auto. split; algebra. apply (contin_imp_inc _ _ _ _ H); auto. apply shift_leEq_minus; astepl a; auto. Qed. Lemma Derivative_imp_resp_less' : forall J pJ a b F F', Derivative J pJ F F' -> a [<] b -> J a -> J b -> (forall contF', [0] [<=] glb_funct _ _ (Min_leEq_Max b a) F' contF') -> forall Ha Hb, F a Ha [#] F b Hb -> F a Ha [<] F b Hb. Proof. intros J pJ a b F F' H H0 H1 H2 H3 Ha Hb H4. elim (ap_imp_less _ _ _ H4); intro; auto. exfalso. apply less_irreflexive_unfolded with (x := F a Ha). apply leEq_less_trans with (F b Hb); auto. apply Derivative_imp_resp_leEq with J pJ F'; auto. apply less_leEq; auto. Qed. (** From these results we can finally prove that exponentiation to a real power preserves the less or equal than relation! *) Lemma nexp_resp_leEq_odd : forall n, Nat.Odd n -> forall x y : IR, x [<=] y -> x[^]n [<=] y[^]n. Proof. intros [| n] H x y H'; [destruct H as [m H]; rewrite Nat.add_1_r in H; discriminate H |]. apply Nat.Odd_succ in H. astepl (Part (FId{^}S n) x I). astepr (Part (FId{^}S n) y I). apply Derivative_imp_resp_leEq with realline I (nring (R:=IR) (S n) {**}FId{^}n). Opaque nring. Derivative_Help. FEQ. Transparent nring. auto. split. split. intros. apply leEq_glb; intros. simpl in |- *. apply mult_resp_nonneg. apply less_leEq; eapply leEq_less_trans. 2: apply less_plusOne. apply nring_nonneg. astepr (y0[^]n); apply nexp_even_nonneg. inversion H; auto. Qed. End Various_Theorems. corn-8.20.0/ftc/Composition.v000066400000000000000000000765211473720167500160370ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.MoreFunctions. Require Export CoRN.ftc.MoreFunSeries. Section Maps_into_Compacts. Section Part_Funct. (** * Composition Preservation results for functional composition are treated in this separate file. We start by defining some auxiliary predicates, and then prove the preservation of continuity through composition and the chain rule for differentiation, both for compact and arbitrary intervals. %\begin{convention}% Throughout this section: - [a, b : IR] and [I] will denote [[a,b]]; - [c, d : IR] and [J] will denote [[c,d]]; - [F, F', G, G'] will be partial functions. %\end{convention}% ** Maps into Compacts Both continuity and differentiability proofs require extra hypothesis on the functions involved---namely, that every compact interval is mapped into another compact interval. We define this concept for partial functions, and prove some trivial results. *) Variables F G : PartIR. Variables a b : IR. Hypothesis Hab : a [<=] b. Variables c d : IR. Hypothesis Hcd : c [<=] d. (* begin hide *) Let I := Compact Hab. (* end hide *) (* begin show *) Hypothesis Hf : included (Compact Hab) (Dom F). (* end show *) Definition maps_into_compacts := included (Compact Hcd) (Dom G) and (forall x Hx, I x -> Compact Hcd (F x Hx)). (* begin show *) Hypothesis maps : maps_into_compacts. (* end show *) Lemma maps_lemma' : forall x Hx, I x -> Compact Hcd (F x Hx). Proof. inversion_clear maps. assumption. Qed. Lemma maps_lemma : forall x, I x -> forall Hx, Compact Hcd (F x Hx). Proof. intros. simpl in |- *. apply maps_lemma'. assumption. Qed. Lemma maps_lemma_inc : included (Compact Hcd) (Dom G). Proof. inversion_clear maps. assumption. Qed. End Part_Funct. End Maps_into_Compacts. Section Mapping. (** As was the case for division of partial functions, this condition completely characterizes the domain of the composite function. *) Variables F G : PartIR. Variables a b : IR. Hypothesis Hab : a [<=] b. Variables c d : IR. Hypothesis Hcd : c [<=] d. (* begin show *) Hypothesis Hf : included (Compact Hab) (Dom F). Hypothesis Hg : included (Compact Hcd) (Dom G). Hypothesis maps : maps_into_compacts F G a b Hab c d Hcd. (* end show *) Lemma included_comp : included (Compact Hab) (Dom (G[o]F)). Proof. intros x H. simpl in |- *. exists (Hf x H). apply Hg. apply maps_lemma' with G a b Hab; assumption. Qed. End Mapping. Section Interval_Continuity. (** ** Continuity We now prove that the composition of two continuous partial functions is continuous. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables c d : IR. Hypothesis Hcd : c [<=] d. Variables F G : PartIR. (* begin show *) Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hcd G. Hypothesis Hmap : maps_into_compacts F G a b Hab c d Hcd. (* end show *) Lemma Continuous_I_comp : Continuous_I Hab (G[o]F). Proof. red in |- *. elim contF; intros incF contF'. elim contG; intros incG contG'. split. exact (included_comp F G a b Hab c d Hcd incF incG Hmap). intros e H. elim (contG' e H). intros dh H0 H1. elim (contF' dh H0). intros df H2 H3. exists df. assumption. intros x y H4 H5 Hx Hy H6. simpl in |- *. cut (forall x : IR, Compact Hab x -> forall Hx, Compact Hcd (F x Hx)). intro H7. apply leEq_wdl with (AbsIR (G _ (incG _ (H7 x H4 (incF x H4))) [-] G _ (incG _ (H7 y H5 (incF y H5))))). apply H1; simpl in |- *. apply H7; assumption. apply H7; assumption. apply H3; assumption. apply AbsIR_wd; rational. intros. apply maps_lemma with G a b Hab; simpl in |- *; assumption. Qed. End Interval_Continuity. Section Derivative. (** ** Derivative We now work with the derivative relation and prove the chain rule for partial functions. *) Variables F F' G G' : PartIR. Variables a b : IR. Hypothesis Hab' : a [<] b. Variables c d : IR. Hypothesis Hcd' : c [<] d. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let Hcd := less_leEq _ _ _ Hcd'. Let I := Compact Hab. (* end hide *) (* begin show *) Hypothesis derF : Derivative_I Hab' F F'. Hypothesis derG : Derivative_I Hcd' G G'. Hypothesis Hmap : maps_into_compacts F G a b Hab c d Hcd. (* end show *) Lemma included_comp' : included (Compact Hab) (Dom (G'[o]F)). Proof. intros x H. simpl in |- *. exists (derivative_imp_inc _ _ _ _ _ derF x H). apply (derivative_imp_inc' _ _ _ _ _ derG). apply maps_lemma' with G a b Hab; assumption. Qed. Lemma maps' : maps_into_compacts F G' a b Hab c d Hcd. Proof. inversion_clear Hmap. split. unfold Hcd in |- *; apply derivative_imp_inc' with G; assumption. assumption. Qed. Lemma Derivative_I_comp : Derivative_I Hab' (G[o]F) ((G'[o]F) {*}F'). Proof. elim derF; intros incF H1. elim H1; intros incF' H2. elim derG; intros incG H4. elim H4; intros incG' H5. clear H1 H4. apply Derivative_I_char. exact (included_comp _ _ _ _ _ _ _ _ incF incG Hmap). exact (included_FMult _ _ _ _ (included_comp _ _ _ _ _ _ _ _ incF incG' maps') incF'). intros e He. set (contF' := deriv_imp_contin'_I _ _ _ _ _ Hab derF) in *. set (nF' := Norm_Funct contF') in *. cut ([0] [<] [1][+]nF'). intro H. cut ([1][+]nF'[#][0]). intro HnF'. 2: apply Greater_imp_ap; assumption. set (alpha := ([1][/] _[//]HnF') [*]e [/]TwoNZ) in *. set (contG' := deriv_imp_contin'_I _ _ _ _ _ Hcd derG) in *. set (nH' := Norm_Funct contG') in *. cut ([0] [<] alpha). intro Halpha. cut ([0] [<] alpha[+]nH'). intro H0. cut (alpha[+]nH'[#][0]). intro HnH'. 2: apply Greater_imp_ap; assumption. set (beta := ([1][/] _[//]HnH') [*]e [/]TwoNZ) in *. cut ([0] [<] beta). intro Hbeta. elim (H2 _ Hbeta). intros df H1 H3. elim (H5 _ Halpha). intros dg H4 H6. elim (contin_prop _ _ _ _ (deriv_imp_contin_I _ _ _ _ _ Hab derF) _ H4). intros dc H7 H8. exists (Min dc df). apply less_Min; assumption. intros x y H9 H10 Hx Hy Hx' H11. simpl in |- *. set (fx := F x (ProjT1 Hx)) in *. set (fy := F y (ProjT1 Hy)) in *. set (gfx := G fx (ProjT2 Hx)) in *. set (gfy := G fy (ProjT2 Hy)) in *. set (fx' := F' x (ProjIR2 Hx')) in *. set (gfx' := G' (F x (ProjT1 (ProjIR1 Hx'))) (ProjT2 (ProjIR1 Hx'))) in *. simpl in (value of fx'), (value of gfx'); fold fx' gfx' in |- *. apply leEq_wdl with (AbsIR (gfy[-]gfx[-]gfx'[*] (fy[-]fx) [+]gfx'[*] (fy[-]fx[-]fx'[*] (y[-]x)))). 2: apply AbsIR_wd; rational. eapply leEq_transitive. apply triangle_IR. apply leEq_transitive with (alpha[*]nF'[*]AbsIR (y[-]x) [+]alpha[*]AbsIR (fy[-]fx[-]fx'[*] (y[-]x)) [+] nH'[*]AbsIR (fy[-]fx[-]fx'[*] (y[-]x))). apply plus_resp_leEq_both. apply leEq_transitive with (alpha[*]AbsIR (fy[-]fx)). unfold gfx' in |- *. cut (Dom G' fx). intro H12. apply leEq_wdl with (AbsIR (gfy[-]gfx[-]G' fx H12[*] (fy[-]fx))). unfold gfy, gfx in |- *; apply H6; unfold fx, fy in |- *. apply maps_lemma with G a b Hab; assumption. apply maps_lemma with G a b Hab; assumption. apply H8; try assumption. eapply leEq_transitive. apply H11. apply Min_leEq_lft. apply AbsIR_wd; unfold fx, fy, gfx, gfy in |- *; rational. apply (dom_wd _ G' _ fx (ProjT2 (ProjIR1 Hx'))). unfold fx in |- *; rational. rstepr (alpha[*] (nF'[*]AbsIR (y[-]x) [+]AbsIR (fy[-]fx[-]fx'[*] (y[-]x)))). apply mult_resp_leEq_lft. 2: apply less_leEq; assumption. apply leEq_wdl with (AbsIR (fx'[*] (y[-]x) [+] (fy[-]fx[-]fx'[*] (y[-]x)))). 2: apply un_op_wd_unfolded; rational. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. unfold fx', nF', I in |- *; apply norm_bnd_AbsIR; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. unfold gfx', nH' in |- *; apply norm_bnd_AbsIR; apply maps_lemma with G a b Hab; assumption. rstepl (alpha[*]nF'[*]AbsIR (y[-]x) [+] (alpha[+]nH') [*]AbsIR (fy[-]fx[-]fx'[*] (y[-]x))). rstepr (e [/]TwoNZ[*]ABSIR (y[-]x) [+]e [/]TwoNZ[*]ABSIR (y[-]x)). apply plus_resp_leEq_both. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. unfold alpha in |- *. rstepl ((nF'[/] _[//]HnF') [*]e [/]TwoNZ). astepr ([1][*]e [/]TwoNZ). apply mult_resp_leEq_rht. 2: apply less_leEq; apply pos_div_two; assumption. apply shift_div_leEq'. apply leEq_less_trans with nF'. unfold nF' in |- *; apply positive_norm. astepr (nF'[+][1]); apply less_plusOne. apply less_leEq; rstepr (nF'[+][1]); apply less_plusOne. apply shift_mult_leEq' with HnH'. assumption. apply leEq_wdr with (beta[*]ABSIR (y[-]x)). 2: unfold beta in |- *; rational. unfold fx, fy, fx' in |- *; apply H3; try assumption. eapply leEq_transitive. apply H11. apply Min_leEq_rht. unfold beta in |- *. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive. apply recip_resp_pos; assumption. apply pos_div_two; assumption. apply leEq_less_trans with nH'. unfold nH' in |- *; apply positive_norm. astepl ([0][+]nH'); apply plus_resp_less_rht; assumption. unfold alpha in |- *. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive. apply recip_resp_pos; assumption. apply pos_div_two; assumption. apply leEq_less_trans with nF'. unfold nF' in |- *; apply positive_norm. astepr (nF'[+][1]); apply less_plusOne. Qed. (** The next lemma will be useful when we move on to differentiability. *) Lemma Diffble_I_comp_aux : Diffble_I Hab' (G[o]F). Proof. elim derF; intros incF H1. elim H1; intros incF' H2. elim derG; intros incG H4. elim H4; intros incG' H5. clear H1 H4. exists (IntPartIR (included_FMult _ _ _ _ (included_comp _ _ _ _ _ _ _ _ incF incG' maps') incF')). eapply Derivative_I_wdr. 2: apply Derivative_I_comp. FEQ. exact (included_FMult _ _ _ _ (included_comp _ _ _ _ _ _ _ _ incF incG' maps') incF'). Qed. End Derivative. Section Differentiability. (** ** Differentiability Finally, we move on to differentiability. *) Variables F G : PartIR. Variables a b : IR. Hypothesis Hab' : a [<] b. Variables c d : IR. Hypothesis Hcd' : c [<] d. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let Hcd := less_leEq _ _ _ Hcd'. Let I := Compact Hab. (* end hide *) (* begin show *) Hypothesis diffF : Diffble_I Hab' F. Hypothesis diffG : Diffble_I Hcd' G. Hypothesis Hmap : maps_into_compacts F G a b Hab c d Hcd. (* end show *) Lemma Diffble_I_comp : Diffble_I Hab' (G[o]F). Proof. elim diffF; intros f' derF. elim diffG; intros g' derG. apply Diffble_I_comp_aux with (PartInt f') (PartInt g') c d Hcd'; auto. Qed. End Differentiability. Section Sequences. (** **Sequences Here we show that the limit of sequences of compositions is the composition of the limits. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables c d : IR. Hypothesis Hcd : c [<=] d. Variable f : nat -> PartIR. Variable g : nat -> PartIR. Hypothesis contf : forall n, Continuous_I Hab (f n). Hypothesis contg : forall n, Continuous_I Hcd (g n). Hypothesis rangef : forall n, forall (x : IR) (Hx : Dom (f n) x), I x -> Compact Hcd (f n x Hx). (* begin hide *) Let incf (n : nat) := contin_imp_inc _ _ _ _ (contf n). Let incg (n : nat) := contin_imp_inc _ _ _ _ (contg n). (* end hide *) Section ExplicitLimit. Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hcd G. Hypothesis convF : conv_fun_seq' _ _ Hab f F contf contF. Hypothesis convG : conv_fun_seq' _ _ Hcd g G contg contG. (* end hide *) Let incF := contin_imp_inc _ _ _ _ contF. Let incG := contin_imp_inc _ _ _ _ contG. (* end hide *) (* begin show *) Hypothesis rangeF : forall (x : IR) (Hx : Dom F x), I x -> Compact Hcd (F x Hx). (* end show *) Lemma fun_Lim_seq_comp' : forall H H', conv_fun_seq' a b Hab (fun n => g n[o]f n) (G[o]F) H H'. Proof. intros H H'. intros e He. destruct (convG _ (pos_div_two _ _ He)) as [N HN]. destruct (CAnd_proj2 _ _ contG _ (pos_div_two _ _ He)) as [z Hz Hz0]. destruct (convF _ Hz) as [M HM]. exists (Nat.max N M). intros n Hn x Hx. assert (Hn0 : N <= n). apply Nat.le_trans with (Nat.max N M); auto with *. assert (Hn1 : M <= n). apply Nat.le_trans with (Nat.max N M); auto with *. apply AbsSmall_imp_AbsIR. assert (X:Continuous_I (a:=a) (b:=b) Hab (G[o]f n)). eapply Continuous_I_comp. apply contf. apply contG. (split; try assumption). apply (rangef n). rstepr (((g n[o]f n) x (contin_imp_inc a b Hab (g n[o]f n) (H n) x Hx)[-] ((G[o]f n) x (contin_imp_inc a b Hab _ X x Hx)))[+] (((G[o]f n) x (contin_imp_inc a b Hab _ X x Hx))[-] (G[o]F) x (contin_imp_inc a b Hab (G[o]F) H' x Hx))). apply AbsSmall_eps_div_two. apply AbsIR_imp_AbsSmall. simpl (AbsIR ((g n[o]f n) x (contin_imp_inc a b Hab (g n[o]f n) (H n) x Hx)[-] (G[o]f n) x (contin_imp_inc a b Hab (G[o]f n) X x Hx))). generalize (ProjT1 (contin_imp_inc a b Hab (g n[o]f n) (H n) x Hx)) (ProjT1 (contin_imp_inc a b Hab (G[o]f n) X x Hx)) (ProjT2 (contin_imp_inc a b Hab (g n[o]f n) (H n) x Hx)) (ProjT2 (contin_imp_inc a b Hab (G[o]f n) X x Hx)). intros Y0 Y1 Y2 Y3. assert (fnx := pfwdef _ _ _ _ Y0 Y1 (eq_reflexive _ x)). assert (Y4 : Dom (g n) (f n x Y1)). apply (dom_wd _ (g n) (f n x Y0));assumption. stepl (ABSIR (g n (f n x Y1) Y4[-]G (f n x Y1) Y3)); [| apply AbsIR_wd; rational]. generalize (rangef n x Y1 Hx). generalize (f n x Y1) Y4 Y3. clear Y0 Y1 Y2 Y3 fnx Y4. intros y Hy0 Hy1 Hy. stepl (ABSIR (g n y (contin_imp_inc c d Hcd (g n) (contg n) y Hy)[-] G y (contin_imp_inc c d Hcd G contG y Hy))); [| apply AbsIR_wd; rational]. apply HN. assumption. apply AbsIR_imp_AbsSmall. simpl. apply Hz0. apply rangef; assumption. apply rangeF; assumption. stepl (AbsIR (f n x (contin_imp_inc a b Hab (f n) (contf n) x Hx)[-] F x (contin_imp_inc a b Hab F contF x Hx))); [| apply AbsIR_wd; rational]. apply HM. assumption. Qed. End ExplicitLimit. (** The same is true if we don't make the limits explicit. *) (* begin hide *) Hypothesis Hf : Cauchy_fun_seq _ _ _ _ contf. Hypothesis Hg : Cauchy_fun_seq _ _ _ _ contg. (* end hide *) Lemma fun_Lim_seq_comp : forall H H', conv_fun_seq' a b Hab (fun n => g n[o]f n) (Cauchy_fun_seq_Lim _ _ _ _ _ Hg[o]Cauchy_fun_seq_Lim _ _ _ _ _ Hf) H H'. Proof. intros H H' e H0. set (F := Cauchy_fun_seq_Lim _ _ _ _ _ Hf) in *. cut (Continuous_I Hab F). intro H1. 2: unfold F in |- *; apply Cauchy_cont_Lim. cut (conv_fun_seq' _ _ _ _ _ contf H1). 2: unfold F in |- *; apply Cauchy_conv_fun_seq'; assumption. intro Hf'. set (G := Cauchy_fun_seq_Lim _ _ _ _ _ Hg) in *. cut (Continuous_I Hcd G). intro H2. 2: unfold G in |- *; apply Cauchy_cont_Lim. cut (conv_fun_seq' _ _ _ _ _ contg H2). 2: unfold G in |- *; apply Cauchy_conv_fun_seq'; assumption. intro Hg'. assert (X: (forall (x : IR) (Hx : Dom F x), I x -> Compact Hcd (F x Hx)) ). intros x Hx Hx'. assert (X:=fun_conv_imp_seq_conv _ _ Hab _ contf _ H1 Hf' _ Hx' (fun n => incf n _ Hx') Hx). assert (X0:Cauchy_prop2 (fun n : nat => Part (f n) x ((fun n0 : nat => incf n0 x Hx') n))). exists (F x Hx). assumption. pose (cs:= (Build_CauchySeq _ _ (Cauchy_prop2_prop _ X0))). assert (X1:=Limits_unique cs _ X). apply compact_wd with (Lim cs);[|apply eq_symmetric; assumption]. split;[apply leEq_seq_so_leEq_Lim|apply seq_leEq_so_Lim_leEq]; intros i; simpl; destruct (rangef i _ (incf i _ Hx') Hx'); assumption. apply (fun_Lim_seq_comp' _ _ H1 H2 Hf' Hg' X H); auto. Qed. End Sequences. Section Series. (** **Series Here we show that the limit of series of composition by a constant function (on the right) is the composition with the limit. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables c d : IR. Hypothesis Hcd : c [<=] d. Variable g : nat -> PartIR. Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. (* begin hide *) Let incF := contin_imp_inc _ _ _ _ contF. (* end hide *) Hypothesis convG : fun_series_convergent _ _ Hcd g. Hypothesis rangeF : forall (x : IR) (Hx : Dom F x), Compact Hab x -> (Compact Hcd) (F x Hx). Lemma conv_fun_series_comp : fun_series_convergent _ _ Hab (fun n => g n[o]F). Proof. destruct convG as [contg X]. assert (incg := fun (n : nat) => contin_imp_inc _ _ _ _ (contg n)). assert (incpsg : forall n : nat, included (Compact Hcd) (Dom (fun_seq_part_sum g n))). intros n. apply contin_imp_inc. apply fun_seq_part_sum_cont. assumption. assert (convG': forall H, Cauchy_fun_seq _ _ Hcd (fun_seq_part_sum g) H). intros H. eapply Cauchy_fun_seq_wd. intros n; apply Feq_reflexive. apply incpsg. apply X. clear X. assert (X0:forall n, maps_into_compacts F (g n) _ _ Hab _ _ Hcd). intros n. split. apply incg. apply rangeF. set (H' := fun n : nat => Continuous_I_comp _ _ _ _ _ _ _ _ contF (contg n) (X0 n)) in *. exists H'. cut (forall n : nat, Continuous_I Hcd (fun_seq_part_sum g n)); [ intro H0 | Contin ]. cut (forall n : nat, Continuous_I Hab ((fun_seq_part_sum g n)[o]F)); [ intro H1 |intros n; eapply Continuous_I_comp with _ _ Hcd; Contin; split;[apply incpsg|apply rangeF]]. apply Cauchy_fun_seq_wd with (fun n : nat => (fun_seq_part_sum g n)[o]F) H1. intros n. FEQ. apply contin_imp_inc; Contin. simpl. apply Sum0_wd; algebra. pose (G:=(Cauchy_fun_seq_Lim _ _ _ _ _ (convG' H0))). assert (contG:Continuous_I Hcd G). unfold G; Contin. assert (contGF:Continuous_I Hab (G[o]F)). apply Continuous_I_comp with c d Hcd; try assumption. split; try assumption. apply contin_imp_inc. assumption. apply conv_Cauchy_fun_seq' with (G[o]F) contGF. refine (fun_Lim_seq_comp' _ _ Hab _ _ Hcd _ _ (fun n => contF) H0 _ _ _ contF contG _ _ _ _ _). intros _; apply rangeF. apply fun_Lim_seq_const. apply (Cauchy_conv_fun_seq' _ _ _ _ _ (convG' H0)). assumption. Qed. Lemma Fun_Series_Sum_comp : forall H' : fun_series_convergent _ _ Hab (fun n => g n[o]F), Feq I (Fun_Series_Sum H') (Fun_Series_Sum convG[o]F). Proof. intros H'. FEQ. simpl. apply series_sum_wd. algebra. Qed. End Series. Section Generalized_Intervals. (** ** Generalizations We now generalize this results to arbitrary intervals. We begin by generalizing the notion of mapping compacts into compacts. %\begin{convention}% We assume [I,J] to be proper intervals. %\end{convention}% *) Variables I J : interval. Hypothesis pI : proper I. Hypothesis pJ : proper J. Definition maps_compacts_into_weak (F : PartIR) := forall a b Hab, included (compact a b Hab) I -> {c : IR | {d : IR | {Hcd : _ | included (Compact Hcd) J and (forall x Hx, Compact Hab x -> compact c d Hcd (F x Hx))}}}. (** Now everything comes naturally: *) Lemma comp_inc_lemma : forall F, maps_compacts_into_weak F -> forall x Hx, I x -> J (F x Hx). Proof. intros F H x Hx H0. cut (included (Compact (leEq_reflexive _ x)) I). intro H1. elim (H _ _ _ H1); intros c Hc. elim Hc; clear Hc; intros d Hd. elim Hd; clear Hd; intros Hcd Hmap'. elim Hmap'; intros H2 H3. apply H2; apply H3; auto. split; apply leEq_reflexive. intros x0 H1. inversion_clear H1. apply iprop_wd with x; auto. apply leEq_imp_eq; auto. Qed. Variables F F' G G' : PartIR. (* begin show *) Hypothesis Hmap : maps_compacts_into_weak F. (* end show *) Lemma Continuous_comp : Continuous I F -> Continuous J G -> Continuous I (G[o]F). Proof. intros H H0. elim H; clear H; intros incF contF. elim H0; clear H0; intros incG contG. split. intros x H. exists (incF _ H). apply incG. apply comp_inc_lemma; auto. intros a b Hab H. elim (Hmap _ _ Hab H); clear Hmap; intros c Hc. elim Hc; clear Hc; intros d Hd. elim Hd; clear Hd; intros Hcd Hmap'. inversion_clear Hmap'. apply Continuous_I_comp with c d Hcd; auto. red in |- *; intros. split; auto. Included. Qed. Definition maps_compacts_into (F : PartIR) := forall a b Hab, included (compact a b Hab) I -> {c : IR | {d : IR | {Hcd : _ | included (Compact (less_leEq _ _ _ Hcd)) J and (forall x Hx, Compact Hab x -> compact c d (less_leEq _ _ _ Hcd) (F x Hx))}}}. Lemma maps_compacts_into_strict_imp_weak : forall F, maps_compacts_into F -> maps_compacts_into_weak F. Proof. intros X HX a b Hab Hinc. destruct (HX a b Hab Hinc) as [c [d [Hcd Hcd0]]]. exists c. exists d. exists (less_leEq _ _ _ Hcd). assumption. Qed. (* begin show *) Hypothesis Hmap' : maps_compacts_into F. (* end show *) Lemma Derivative_comp : Derivative I pI F F' -> Derivative J pJ G G' -> Derivative I pI (G[o]F) ((G'[o]F) {*}F'). Proof. clear Hmap. assert (Hmap := maps_compacts_into_strict_imp_weak F Hmap'). intros H H0. elim H; clear H; intros incF H'. elim H'; clear H'; intros incF' derF. elim H0; clear H0; intros incG H'. elim H'; clear H'; intros incG' derG. split. simpl in |- *; red in |- *; intros x H; exists (incF _ H). apply incG; apply comp_inc_lemma; auto. split. apply included_FMult. simpl in |- *; red in |- *; intros x H; exists (incF _ H). apply incG'; apply comp_inc_lemma; auto. Included. intros a b Hab H. elim (Hmap' _ _ (less_leEq _ _ _ Hab) H); clear Hmap'; intros c Hc. elim Hc; clear Hc; intros d Hd. elim Hd; clear Hd; intros Hcd Hmap2. inversion_clear Hmap2. apply Derivative_I_comp with c d Hcd; auto. red in |- *; intros. split; auto. Included. Qed. Variable g : nat -> PartIR. (* begin show *) Hypothesis contF : Continuous I F. Hypothesis convG : fun_series_convergent_IR J g. (* end show *) Lemma FSeries_Sum_comp_conv : fun_series_convergent_IR I (fun n => g n[o]F). Proof. red in |- *; intros. destruct (Hmap a b Hab Hinc) as [c [d [Hcd [H0 H1]]]]. apply conv_fun_series_comp with c d Hcd; auto. eapply included_imp_Continuous. apply contF. auto. Qed. Lemma FSeries_Sum_comp : forall H' : fun_series_convergent_IR I (fun n => g n[o]F), Feq I (FSeries_Sum H') (FSeries_Sum convG[o]F). Proof. intros. apply included_Feq'; intros a b Hab Hinc. destruct (Hmap a b Hab Hinc) as [c [d [Hcd [H0 H1]]]]. assert (H2:Continuous_I Hab F). eapply included_imp_Continuous. apply contF. auto. eapply Feq_transitive. apply (FSeries_Sum_char _ _ H' a b Hab Hinc). apply Feq_transitive with (Fun_Series_Sum (a:=c) (b:=d) (Hab:=Hcd) (f:=g) (convG _ _ _ H0)[o]F). apply Fun_Series_Sum_comp. auto. apply H1. eapply Feq_comp; try apply H1. apply Feq_reflexive. Included. apply Feq_symmetric. apply FSeries_Sum_char. Qed. Variable f : nat -> PartIR. (* begin show *) Hypothesis contf : forall n, Continuous I (f n). Hypothesis contg : forall n, Continuous J (g n). Hypothesis contG : Continuous J G. Hypothesis Hmapf : forall a b Hab, included (compact a b Hab) I -> {c : IR | {d : IR | {Hcd : _ | included (Compact Hcd) J and (forall n x Hx, Compact Hab x -> compact c d Hcd (f n x Hx))}}}. (* end show *) Lemma fun_Lim_seq_comp'_IR : (conv_fun_seq'_IR _ _ _ contf contF) -> (conv_fun_seq'_IR _ _ _ contg contG) -> forall H H', conv_fun_seq'_IR I (fun n => g n[o]f n) (G[o]F) H H'. Proof. red in |- *; intros. destruct (Hmapf a b Hab Hinc) as [c [d [Hcd [Hcd0 Hcd1]]]]. eapply fun_Lim_seq_comp'. apply Hcd1. apply (X a b Hab Hinc). apply (X0 _ _ Hcd Hcd0). intros. assert (Y:forall n : nat, Dom (f n) x). intros n. refine (Continuous_imp_inc _ _ _ _ _). 1:apply contf. Included. rename H0 into X1. assert (Z:=fun_conv_imp_seq_conv _ _ _ _ _ _ _ (X a b Hab Hinc) x X1 Y Hx). pose (seq:= Build_CauchySeq2_y _ _ Z). assert (Z0:=Limits_unique seq (F x Hx) Z). apply (compact_wd c d Hcd (Lim seq)). assert (HcdX := fun n => Hcd1 n x (Y n) X1). split;[apply leEq_seq_so_leEq_Lim|apply seq_leEq_so_Lim_leEq]; intros i; simpl; destruct (HcdX i); assumption. apply eq_symmetric; assumption. Qed. (* begin show *) Hypothesis Hf : Cauchy_fun_seq_IR _ _ contf. Hypothesis Hg : Cauchy_fun_seq_IR _ _ contg. (* end show *) Lemma fun_Lim_seq_comp_IR : forall H H', conv_fun_seq'_IR I (fun n => g n[o]f n) (Cauchy_fun_seq_Lim_IR _ _ _ Hg[o]Cauchy_fun_seq_Lim_IR _ _ _ Hf) H H'. Proof. intros H H'. red; intros. destruct (Hmapf a b Hab Hinc) as [c [d [Hcd [Hcd0 Hcd1]]]]. assert (X:forall n : nat, Continuous_I (a:=a) (b:=b) Hab (g n[o]f n)). intros n. apply Continuous_I_comp with c d Hcd. destruct (contf n) as [A B]. apply B. assumption. destruct (contg n) as [A B]. apply B. assumption. split. destruct (contg n) as [A B]. eapply included_trans. apply Hcd0. assumption. apply Hcd1. assert (W:forall (x : IR) (Hx : Dom (Cauchy_fun_seq_Lim a b Hab f (fun n : nat => included_imp_Continuous I (f n) (contf n) a b Hab Hinc) (Hf a b Hab Hinc)) x), Compact Hab x -> Compact Hcd (Cauchy_fun_seq_Lim a b Hab f (fun n : nat => included_imp_Continuous I (f n) (contf n) a b Hab Hinc) (Hf a b Hab Hinc) x Hx)). intros x Hx Habx. pose (Z:=fun i => contin_imp_inc a b Hab (f i) (included_imp_Continuous I (f i) (contf i) a b Hab Hinc) x Hx). simpl. assert (HcdX := fun n => Hcd1 n x (Z n) Habx). split;[apply leEq_seq_so_leEq_Lim|apply seq_leEq_so_Lim_leEq]; intros i; simpl; destruct (HcdX i); assumption. assert (Z0:Continuous_I (a:=a) (b:=b) Hab (Cauchy_fun_seq_Lim c d Hcd g (fun n : nat => included_imp_Continuous J (g n) (contg n) c d Hcd Hcd0) (Hg c d Hcd Hcd0)[o] Cauchy_fun_seq_Lim a b Hab f (fun n : nat => included_imp_Continuous I (f n) (contf n) a b Hab Hinc) (Hf a b Hab Hinc))). apply Continuous_I_comp with c d Hcd; try apply Cauchy_cont_Lim. split. apply contin_imp_inc. apply Cauchy_cont_Lim. apply W. assert (Z:=fun_Lim_seq_comp _ _ Hab _ _ Hcd _ _ _ _ Hcd1 (Hf _ _ Hab Hinc) (Hg _ _ Hcd Hcd0) X Z0). eapply conv_fun_seq'_wdr;[|apply Z]. clear Z Z0. apply Feq_comp with (Compact Hcd). apply W. intros x Hx Habx. simpl. pose (Z:=fun i => (Continuous_imp_inc I (f i) (contf i) x Hx)). assert (HcdX := fun n => Hcd1 n x (Z n) Habx). split;[apply leEq_seq_so_leEq_Lim|apply seq_leEq_so_Lim_leEq]; intros i; simpl; destruct (HcdX i); assumption. apply Feq_symmetric. apply Cauchy_fun_seq_Lim_char. apply Feq_symmetric. apply Cauchy_fun_seq_Lim_char. Qed. End Generalized_Intervals. Section Corollaries. (** Finally, some criteria to prove that a function with a specific domain maps compacts into compacts: *) Definition positive_fun P F := included P (Dom F) and {c : IR | [0] [<] c | forall y, P y -> forall Hy, c [<=] F y Hy}. Definition negative_fun P F := included P (Dom F) and {c : IR | c [<] [0] | forall y, P y -> forall Hy, F y Hy [<=] c}. Lemma positive_imp_maps_compacts_into : forall (J : interval) F, positive_fun J F -> Continuous J F -> maps_compacts_into J (openl [0]) F. Proof. intros J F H H0 a b Hab H1. elim H; intros incF H2. elim H2; clear H H2 incF; intros MinF H H2. set (MaxF := Norm_Funct (included_imp_Continuous _ _ H0 _ _ _ H1) [+][1]) in *. cut (MinF [<] MaxF). intro H3. exists MinF; exists MaxF; exists H3. split. eapply included_trans. apply compact_map2 with (Hab' := Min_leEq_Max MinF MaxF). apply included_interval; simpl in |- *. auto. unfold MaxF in |- *; eapply leEq_less_trans. 2: apply less_plusOne. apply positive_norm. intros; split. auto. unfold MaxF in |- *; eapply leEq_transitive. 2: apply less_leEq; apply less_plusOne. eapply leEq_transitive. apply leEq_AbsIR. apply norm_bnd_AbsIR; auto. unfold MaxF in |- *; eapply leEq_less_trans. 2: apply less_plusOne. apply leEq_transitive with (F a (Continuous_imp_inc _ _ H0 _ (H1 a (compact_inc_lft _ _ Hab)))). apply H2; auto. apply H1; apply compact_inc_lft. eapply leEq_transitive. apply leEq_AbsIR. apply norm_bnd_AbsIR; apply compact_inc_lft. Qed. Lemma negative_imp_maps_compacts_into : forall (J : interval) F, negative_fun J F -> Continuous J F -> maps_compacts_into J (openr [0]) F. Proof. intros J F H H0 a b Hab H1. elim H; intros incF H2. elim H2; clear H H2 incF; intros MaxF H H2. set (MinF := [--] (Norm_Funct (included_imp_Continuous _ _ H0 _ _ _ H1)) [-][1]) in *. cut (MinF [<] MaxF). intro H3. exists MinF; exists MaxF; exists H3. split. eapply included_trans. apply compact_map2 with (Hab' := Min_leEq_Max MinF MaxF). apply included_interval; simpl in |- *. unfold MinF in |- *; eapply less_leEq_trans. apply minusOne_less. astepr ( [--]ZeroR); apply inv_resp_leEq; apply positive_norm. auto. intros; split. unfold MinF in |- *; eapply leEq_transitive. apply less_leEq; apply minusOne_less. astepr ( [--][--] (Part _ _ Hx)); apply inv_resp_leEq. eapply leEq_transitive. apply inv_leEq_AbsIR. apply norm_bnd_AbsIR; auto. auto. unfold MinF in |- *; eapply less_leEq_trans. apply minusOne_less. apply leEq_transitive with (F a (Continuous_imp_inc _ _ H0 _ (H1 a (compact_inc_lft _ _ Hab)))). 2: apply H2; auto. 2: apply H1; apply compact_inc_lft. astepr ( [--] [--] (Part _ _ (Continuous_imp_inc _ _ H0 _ (H1 _ (compact_inc_lft _ _ Hab))))); apply inv_resp_leEq. eapply leEq_transitive. apply inv_leEq_AbsIR. apply norm_bnd_AbsIR; apply compact_inc_lft. Qed. Lemma Continuous_imp_maps_compacts_into : forall J F, Continuous J F -> maps_compacts_into J realline F. Proof. intros J F H a b Hab H0. set (ModF := Norm_Funct (included_imp_Continuous _ _ H _ _ _ H0)) in *. cut ( [--]ModF [<] ModF[+][1]). intro H1. exists ( [--]ModF); exists (ModF[+][1]); exists H1; split. repeat split. intros; unfold ModF in |- *; split. astepr ( [--][--] (Part _ _ Hx)); apply inv_resp_leEq. eapply leEq_transitive; [ apply inv_leEq_AbsIR | apply norm_bnd_AbsIR ]; auto. eapply leEq_transitive. 2: apply less_leEq; apply less_plusOne. eapply leEq_transitive; [ apply leEq_AbsIR | apply norm_bnd_AbsIR ]; auto. unfold ModF in |- *. eapply leEq_less_trans; [ apply leEq_transitive with ZeroR | apply less_plusOne ]. astepr ( [--]ZeroR); apply inv_resp_leEq; apply positive_norm. apply positive_norm. Qed. (** As a corollary, we get the generalization of differentiability property. *) Lemma Diffble_comp : forall I J pI pJ F G, maps_compacts_into I J F -> Diffble I pI F -> Diffble J pJ G -> Diffble I pI (G[o]F). Proof. intros I J pI pJ F G H H0 H1. apply Derivative_imp_Diffble with ((Deriv _ _ _ H1[o]F) {*}Deriv _ _ _ H0). apply Derivative_comp with J pJ; auto; apply Deriv_lemma. Qed. End Corollaries. #[global] Hint Immediate included_comp: included. #[global] Hint Immediate Continuous_I_comp Continuous_comp: continuous. corn-8.20.0/ftc/Continuity.v000066400000000000000000001017511473720167500156730ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Norm_Funct %\ensuremath{\|\cdot\|}% *) Require Export CoRN.reals.NRootIR. Require Export CoRN.ftc.FunctSums. Require Import CoRN.tactics.CornTac. Section Definitions_and_Basic_Results. (** * Continuity Constructively, continuity is the most fundamental property of any function---so strongly that no example is known of a constructive function that is not continuous. However, the classical definition of continuity is not good for our purposes, as it is not true, for example, that a function which is continuous in a compact interval is uniformly continuous in that same interval (for a discussion of this see Bishop 1967). Thus, our notion of continuity will be the uniform one#. #%\footnote{%Similar remarks apply to convergence of sequences of functions, which we will define ahead, and elsewhere; we will refrain from discussing this issue at those places.%}.% %\begin{convention}% Throughout this section, [a] and [b] will be real numbers, [I] will denote the compact interval [[a,b]] and [F, G, H] will denote arbitrary partial functions with domains respectively [P, Q] and [R]. %\end{convention}% ** Definitions and Basic Results Here we define continuity and prove some basic properties of continuous functions. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable F : PartIR. (* begin hide *) Let P := Dom F. (* end hide *) Definition Continuous_I := included I P and (forall e, [0] [<] e -> {d : IR | [0] [<] d | forall x y, I x -> I y -> forall Hx Hy, AbsIR (x[-]y) [<=] d -> AbsIR (F x Hx[-]F y Hy) [<=] e}). (** For convenience, we distinguish the two properties of continuous functions. *) Lemma contin_imp_inc : Continuous_I -> included (Compact Hab) P. Proof. intro H; elim H; intros; assumption. Qed. Lemma contin_prop : Continuous_I -> forall e, [0] [<] e -> {d : IR | [0] [<] d | forall x y, I x -> I y -> forall Hx Hy, AbsIR (x[-]y) [<=] d -> AbsIR (F x Hx[-]F y Hy) [<=] e}. Proof. intro H; elim H; do 2 intro; assumption. Qed. (** Assume [F] to be continuous in [I]. Then it has a least upper bound and a greater lower bound on [I]. *) Hypothesis contF : Continuous_I. (* begin hide *) Let Hinc' := contin_imp_inc contF. (* end hide *) Lemma Continuous_I_imp_tb_image : totally_bounded (fun_image F I). Proof. assert (H := compact_is_totally_bounded a b Hab). elim contF; intros H0 H1. split. elim H; clear H; intros H2 H3. elim H2; clear H2; intros x H. exists (Part F x (H0 _ H)). exists x; split. auto. split. apply H0; auto. algebra. intros e H2. elim (H1 _ H2). intros d H3 H4. clear H1. elim H; clear H. intros non_empty H. elim H with d; clear H. intros l Hl' Hl. 2: assumption. exists (map2 F l (fun (x : IR) (Hx : member x l) => H0 x (Hl' x Hx))). intros x H. clear Hl; induction l as [| a0 l Hrecl]. exfalso; assumption. simpl in H; elim H; clear H; intro H1. cut (forall x : IR, member x l -> compact a b Hab x). intro H. apply Hrecl with H. eapply map2_wd. apply H1. intros x0 H. apply Hl'; left; assumption. exists a0. split. apply Hl'; right; algebra. split. apply H0; apply Hl'; right; algebra. intro; eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply H1. algebra. intros x H; simpl in |- *. elim H; intros x0 H1. elim H1; clear H1; intros Hy' H1. elim H1; intros Hy'' Hy. elim (Hl x0 Hy'); intros x1 Hx1 H5. exists (F x1 (H0 x1 (Hl' x1 Hx1))). apply map2_pres_member; assumption. astepr (F x0 Hy''[-]F x1 (H0 x1 (Hl' x1 Hx1))). apply AbsIR_imp_AbsSmall. apply H4. assumption. apply Hl'; assumption. apply AbsSmall_imp_AbsIR; assumption. Qed. Lemma Continuous_I_imp_lub : {x : IR | fun_lub_IR F I x}. Proof. unfold fun_lub_IR in |- *. apply totally_bounded_has_lub. apply Continuous_I_imp_tb_image. Qed. Lemma Continuous_I_imp_glb : {x : IR | fun_glb_IR F I x}. Proof. unfold fun_glb_IR in |- *. apply totally_bounded_has_glb. apply Continuous_I_imp_tb_image. Qed. (** We now make this glb and lub into operators. *) Definition lub_funct := ProjT1 Continuous_I_imp_lub. Definition glb_funct := ProjT1 Continuous_I_imp_glb. (** These operators have the expected properties. *) Lemma lub_is_lub : fun_lub_IR F I lub_funct. Proof. exact (ProjT2 Continuous_I_imp_lub). Qed. Lemma glb_is_glb : fun_glb_IR F I glb_funct. Proof. exact (ProjT2 Continuous_I_imp_glb). Qed. Lemma glb_prop : forall x : IR, I x -> forall Hx, glb_funct [<=] F x Hx. Proof. intros. elim glb_is_glb. intros. apply a0. exists x. split; algebra. Qed. Lemma lub_prop : forall x : IR, I x -> forall Hx, F x Hx [<=] lub_funct. Proof. intros. elim lub_is_lub. intros. apply a0. exists x. split; algebra. Qed. (** The norm of a function is defined as being the supremum of its absolute value; that is equivalent to the following definition (which is often more convenient to use). *) Definition Norm_Funct := Max lub_funct [--]glb_funct. (** The norm effectively bounds the absolute value of a function. *) Lemma norm_bnd_AbsIR : forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] Norm_Funct. Proof. intros. generalize lub_is_lub. generalize glb_is_glb. intros; simpl in |- *; unfold ABSIR in |- *. apply Max_leEq. apply leEq_transitive with lub_funct. apply lub_prop; auto. unfold Norm_Funct in |- *; apply lft_leEq_Max. apply leEq_transitive with ( [--]glb_funct). apply inv_resp_leEq. apply glb_prop; auto. unfold Norm_Funct in |- *; apply rht_leEq_Max. Qed. (** The following is another way of characterizing the norm: *) Lemma Continuous_I_imp_abs_lub : {z : IR | forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] z}. Proof. exists Norm_Funct. exact norm_bnd_AbsIR. Qed. (** We now prove some basic properties of the norm---namely that it is positive, and that it provides a least upper bound for the absolute value of its argument. *) Lemma positive_norm : [0] [<=] Norm_Funct. Proof. apply leEq_transitive with (AbsIR (FRestr Hinc' a (compact_inc_lft _ _ _))). apply AbsIR_nonneg. simpl in |- *; apply norm_bnd_AbsIR; unfold I in |- *; apply compact_inc_lft. Qed. Lemma norm_fun_lub : forall e, [0] [<] e -> {x : IR | I x and (forall Hx, Norm_Funct[-]e [<] AbsIR (F x Hx))}. Proof. intros e H. cut {x : IR | I x and (forall Hx' : P x, Norm_Funct [<] AbsIR (F x Hx') [+]e)}. intro H0. elim H0; intros y Hy. elim Hy; clear H0 Hy; intros Hy Hy'. exists y; split. auto. intro; apply shift_minus_less; apply Hy'. generalize lub_is_lub. generalize glb_is_glb. intros H0 H1. cut {x : IR | I x and (forall Hx' : P x, F x Hx' [<] glb_funct[+]e [/]TwoNZ)}. cut {x : IR | I x and (forall Hx' : P x, lub_funct[-]e [/]TwoNZ [<] F x Hx')}. intros H2 H3. elim H2; intros x Hx. elim Hx; clear H2 Hx; intros Hx Hx0. elim H3; intros x' Hx'. elim Hx'; clear H3 Hx'; intros Hx' Hx'0. elim (less_cotransitive_unfolded _ _ _ (pos_div_two _ _ H) ( [--]glb_funct[-]lub_funct)); intro H2. exists x'; split. auto. unfold Norm_Funct in |- *. intro; eapply less_wdl. 2: apply eq_symmetric_unfolded; apply leEq_imp_Max_is_rht. apply shift_less_plus. rstepl ( [--] (glb_funct[+]e)). eapply less_leEq_trans. 2: apply inv_leEq_AbsIR. apply inv_resp_less. eapply less_transitive_unfolded. apply Hx'0 with (Hx' := Hx'1). apply plus_resp_less_lft. apply pos_div_two'; assumption. astepl ([0][+]lub_funct); apply less_leEq; apply shift_plus_less. assumption. exists x; split. auto. unfold Norm_Funct in |- *. intro; apply less_leEq_trans with (lub_funct[+]e [/]TwoNZ). apply Max_less. apply shift_less_plus'; astepl ZeroR. apply pos_div_two; assumption. apply shift_less_plus'; assumption. apply shift_leEq_plus. rstepl (lub_funct[-]e [/]TwoNZ). eapply leEq_transitive. apply less_leEq; apply Hx0 with (Hx' := Hx'1). apply leEq_AbsIR. elim H1; clear H1; intros H2 H3. elim (H3 _ (pos_div_two _ _ H)). intros x Hx; elim Hx; clear Hx; intros y Hx'; elim Hx'; clear Hx'; intros Hx' Hx''; elim Hx''; clear Hx''; intros Hx'' Hx'''. exists y; split. auto. intro; apply shift_minus_less; apply shift_less_plus'. eapply less_wdl; [ apply q | algebra ]. elim H0; clear H0; intros H2 H3. elim (H3 _ (pos_div_two _ _ H)). intros x Hx; elim Hx; clear Hx; intros y Hx'; elim Hx'; clear Hx'; intros Hx' Hx''; elim Hx''; clear Hx''; intros Hx'' Hx'''. exists y; split. auto. intro; apply shift_less_plus'. eapply less_wdl; [ apply q | algebra ]. Qed. Lemma leEq_Norm_Funct : forall e, (forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] e) -> Norm_Funct [<=] e. Proof. intros e H. astepr ([0][+]e); apply shift_leEq_plus. apply approach_zero_weak. intros d Hd. apply shift_minus_leEq. elim (norm_fun_lub d Hd); intros x Hx. elim Hx; clear Hx; intros Hx Hx'. apply plus_cancel_leEq_rht with ( [--] (AbsIR (F x (Hinc' x Hx)))). astepl (Norm_Funct[-]AbsIR (F x (Hinc' x Hx))). apply less_leEq; apply less_leEq_trans with d. apply shift_minus_less; apply shift_less_plus'; apply Hx'. rstepr (d[+] (e[-]AbsIR (F x (Hinc' x Hx)))). astepl (d[+][0]); apply plus_resp_leEq_lft. apply shift_leEq_minus; astepl (AbsIR (F x (Hinc' x Hx))); apply H; assumption. Qed. Lemma less_Norm_Funct : forall e, (forall x, I x -> forall Hx, AbsIR (F x Hx) [<] e) -> Norm_Funct [<=] e. Proof. intros x H. apply leEq_Norm_Funct. intros; apply less_leEq; apply H; assumption. Qed. End Definitions_and_Basic_Results. Arguments Continuous_I [a b]. Arguments Norm_Funct [a b Hab F]. Section Local_Results. (** ** Algebraic Properties We now state and prove some results about continuous functions. Assume that [I] is included in the domain of both [F] and [G]. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables F G : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Hypothesis incF : included (Compact Hab) P. Hypothesis incG : included (Compact Hab) Q. (** The first result does not require the function to be continuous; however, its preconditions are easily verified by continuous functions, which justifies its inclusion in this section. *) Lemma cont_no_sign_change : forall e, [0] [<] e -> forall x y, I x -> I y -> forall Hx Hy, AbsIR (F x Hx[-]F y Hy) [<=] e -> e [<] AbsIR (F x Hx) -> ([0] [<] F x Hx -> [0] [<] F y Hy) and (F x Hx [<] [0] -> F y Hy [<] [0]). Proof. intros e H x y H0 H1 Hx Hy H2 H3. set (fx := F x Hx) in *. set (fy := F y Hy) in *. split; intro H4. cut (e [<] fx). intro H5. astepl (e[-]e). apply shift_minus_less; apply shift_less_plus'. apply less_leEq_trans with (fx[-]fy). apply minus_resp_less; assumption. eapply leEq_transitive; [ apply leEq_AbsIR | assumption ]. elim (less_AbsIR _ _ H H3); intro H6. assumption. exfalso. cut ([0] [<] [--]e). intro; cut (e [<] [0]). exact (less_antisymmetric_unfolded _ _ _ H). astepl ( [--][--]e); astepr ( [--]ZeroR); apply inv_resp_less; assumption. apply less_transitive_unfolded with fx; assumption. astepr (e[-]e). apply shift_less_minus. apply less_leEq_trans with (fy[-]fx). 2: eapply leEq_transitive. 3: apply H2. 2: eapply leEq_wdr; [ apply leEq_AbsIR | apply AbsIR_minus ]. unfold cg_minus in |- *; apply plus_resp_less_lft. elim (less_AbsIR _ _ H H3); intro H6. apply less_transitive_unfolded with ZeroR. apply less_transitive_unfolded with fx; assumption. astepl ( [--]ZeroR); apply inv_resp_less; assumption. astepl ( [--][--]e); apply inv_resp_less; assumption. Qed. Lemma cont_no_sign_change_pos : forall e, [0] [<] e -> forall x y, I x -> I y -> forall Hx Hy, AbsIR (F x Hx[-]F y Hy) [<=] e -> e [<] AbsIR (F x Hx) -> e [<] F x Hx -> [0] [<] F y Hy. Proof. intros e H x y H0 H1 Hx Hy H2 H3 H4. elim (cont_no_sign_change e H x y H0 H1 Hx Hy H2 H3); intros H5 H6. apply H5. apply less_transitive_unfolded with e; auto. Qed. Lemma cont_no_sign_change_neg : forall e, [0] [<] e -> forall x y, I x -> I y -> forall Hx Hy, AbsIR (F x Hx[-]F y Hy) [<=] e -> e [<] AbsIR (F x Hx) -> F x Hx [<] [--]e -> F y Hy [<] [0]. Proof. intros e H x y H0 H1 Hx Hy H2 H3 H4. elim (cont_no_sign_change e H x y H0 H1 Hx Hy H2 H3); intros H5 H6. apply H6. apply less_transitive_unfolded with ( [--]e). assumption. astepr ( [--]ZeroR); apply inv_resp_less; assumption. Qed. (** Being continuous is an extensional property. *) Lemma Continuous_I_wd : Feq I F G -> Continuous_I Hab F -> Continuous_I Hab G. Proof. intros H H0. elim H0; clear H0; intros Hinc H0. elim H; clear H; intros incF' H'. elim H'; clear H'; intros incG' H. split. apply incG'. intros e He; elim (H0 e He); clear H0; intros d H0 H1. exists d. assumption. intros x y H2 H3 Hx Hy H4. apply leEq_wdl with (AbsIR (F x (incF' x H2) [-]F y (incF' y H3))). apply H1; assumption. simpl in H. apply AbsIR_wd. apply cg_minus_wd; apply H; assumption. Qed. (** A continuous function remains continuous if you restrict its domain. *) Lemma included_imp_contin : forall c d Hcd, included (compact c d Hcd) (Compact Hab) -> Continuous_I Hab F -> Continuous_I Hcd F. Proof. intros c d Hcd H H0. elim H0; clear H0; intros incF' contF. split. apply included_trans with (Compact Hab); [ apply H | apply incF' ]. intros e He; elim (contF e He); intros e' H0 H1. exists e'. assumption. intros; apply H1. apply H; assumption. apply H; assumption. assumption. Qed. (** Constant functions and identity are continuous. *) Lemma Continuous_I_const : forall c : IR, Continuous_I Hab [-C-]c. Proof. intro. split. Included. intros; exists OneR. apply pos_one. intros. apply leEq_wdl with (AbsIR [0]). astepl ZeroR; apply less_leEq; assumption. algebra. Qed. Lemma Continuous_I_id : Continuous_I Hab FId. Proof. split. Included. intros; exists e. assumption. intros; assumption. Qed. (** Assume [F] and [G] are continuous in [I]. Then functions derived from these through algebraic operations are also continuous, provided (in the case of reciprocal and division) some extra conditions are met. *) Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. Lemma Continuous_I_plus : Continuous_I Hab (F{+}G). Proof. clear incF incG. elim contF; intros incF' contF'. elim contG; intros incG' contG'. split. Included. intros. elim (contF' (e [/]TwoNZ)). elim (contG' (e [/]TwoNZ)). clear contF contG contF' contG'. 2: apply pos_div_two; assumption. 2: apply pos_div_two; assumption. intros df H0 H1 dg H2 H3. exists (Min df dg). apply less_Min; assumption. intros. simpl in |- *. apply leEq_wdl with (AbsIR (F x (ProjIR1 Hx) [-]F y (ProjIR1 Hy) [+] (G x (ProjIR2 Hx) [-]G y (ProjIR2 Hy)))). rstepr (e [/]TwoNZ[+]e [/]TwoNZ). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. simpl in |- *; apply H3; try assumption. apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_rht ]. simpl in |- *; apply H1; try assumption. apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_lft ]. apply AbsIR_wd; rational. Qed. Lemma Continuous_I_inv : Continuous_I Hab {--}F. Proof. clear incF. elim contF; intros incF' contF'. split. Included. intros e H. elim (contF' e H). intros d H0 H1. exists d. assumption. intros; simpl in |- *. apply leEq_wdl with (AbsIR (F x Hx[-]F y Hy)). apply H1; assumption. eapply eq_transitive_unfolded. apply AbsIR_inv. apply AbsIR_wd; rational. Qed. Lemma Continuous_I_mult : Continuous_I Hab (F{*}G). Proof. clear incF incG. elim contF; intros incF' contF'. elim contG; intros incG' contG'. split; [ Included | intros e H ]. cut {xf : IR | forall (x : IR) (Hx : I x) (Hx' : P x), AbsIR (F x Hx') [<=] xf}. cut {xg : IR | forall (x : IR) (Hx : I x) (Hx' : Q x), AbsIR (G x Hx') [<=] xg}. 2: unfold I, Q in |- *; apply Continuous_I_imp_abs_lub; assumption. 2: unfold I, P in |- *; apply Continuous_I_imp_abs_lub; assumption. intros H0 H1. elim H0; clear H0; intros x H2. elim H1; clear H1; intros x0 H0. elim (contF' (e [/]TwoNZ[/] Max x [1][//]max_one_ap_zero _)); clear contF. elim (contG' (e [/]TwoNZ[/] Max x0 [1][//]max_one_ap_zero _)); clear contG. intros dg H1 H3 df H4 H5. 2: apply div_resp_pos. 2: apply pos_max_one. 2: apply pos_div_two; assumption. 2: apply div_resp_pos. 2: apply pos_max_one. 2: apply pos_div_two; assumption. exists (Min df dg). apply less_Min; assumption. intros; simpl in |- *. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). apply leEq_wdl with (AbsIR (F x1 (ProjIR1 Hx) [*] (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy)) [+] (F x1 (ProjIR1 Hx) [-]F y (ProjIR1 Hy)) [*]G y (ProjIR2 Hy))). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (x0[*]AbsIR (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy))). apply mult_resp_leEq_rht. apply H0; assumption. apply AbsIR_nonneg. apply leEq_transitive with (Max x0 [1][*]AbsIR (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy))). apply mult_resp_leEq_rht; [ apply lft_leEq_Max | apply AbsIR_nonneg ]. astepl (AbsIR (G x1 (ProjIR2 Hx) [-]G y (ProjIR2 Hy)) [*]Max x0 [1]). apply shift_mult_leEq with (max_one_ap_zero x0); [ apply pos_max_one | simpl in |- *; apply H3 ]; try assumption. apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_rht ]. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (AbsIR (F x1 (ProjIR1 Hx) [-]F y (ProjIR1 Hy)) [*]x). apply mult_resp_leEq_lft; [ apply H2 | apply AbsIR_nonneg ]; assumption. apply leEq_transitive with (AbsIR (F x1 (ProjIR1 Hx) [-]F y (ProjIR1 Hy)) [*]Max x [1]). apply mult_resp_leEq_lft; [ apply lft_leEq_Max with (y := OneR) | apply AbsIR_nonneg ]. apply shift_mult_leEq with (max_one_ap_zero x); [ apply pos_max_one | simpl in |- *; apply H5 ]; try assumption. apply leEq_transitive with (Min df dg); [ assumption | apply Min_leEq_lft ]. apply AbsIR_wd; rational. Qed. Lemma Continuous_I_max : Continuous_I Hab (FMax F G). Proof. clear incF incG. elim contF; intros incF contF'. elim contG; intros incG contG'. split. Included. intros e He. elim (contF' (e [/]TwoNZ) (pos_div_two _ _ He)); intros dF dFpos HdF. elim (contG' (e [/]TwoNZ) (pos_div_two _ _ He)); intros dG dGpos HdG. clear contF contG contF' contG'. exists (Min dF dG). apply less_Min; auto. intros x y Hx' Hy' Hx Hy Hxy. assert (AbsIR (x[-]y) [<=] dF). eapply leEq_transitive; [ apply Hxy | apply Min_leEq_lft ]. assert (AbsIR (x[-]y) [<=] dG). eapply leEq_transitive; [ apply Hxy | apply Min_leEq_rht ]. assert (HF := HdF x y Hx' Hy' (ProjIR1 Hx) (ProjIR1 Hy) H). assert (HG := HdG x y Hx' Hy' (ProjIR2 Hx) (ProjIR2 Hy) H0). Opaque AbsIR Max. simpl in |- *. Transparent AbsIR Max. set (Fx := F x (ProjIR1 Hx)) in *. set (Fy := F y (ProjIR1 Hy)) in *. set (Gx := G x (ProjIR2 Hx)) in *. set (Gy := G y (ProjIR2 Hy)) in *. elim (AbsIR_imp_AbsSmall _ _ HF); intros HF1 HF2. elim (AbsIR_imp_AbsSmall _ _ HG); intros HG1 HG2. apply leEq_wdl with (AbsIR (Max Fx Gx[-]Max Fx Gy[+] (Max Fx Gy[-]Max Fy Gy))). 2: apply AbsIR_wd; rational. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both; apply AbsSmall_imp_AbsIR; split. apply shift_zero_leEq_minus'. rstepr (e [/]TwoNZ[+]Max Fx Gx[-]Max Fx Gy). apply shift_zero_leEq_minus. apply Max_leEq. apply leEq_transitive with (e [/]TwoNZ[+]Fx). apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto. apply plus_resp_leEq_lft; apply lft_leEq_Max. apply leEq_transitive with (e [/]TwoNZ[+]Gx). 2: apply plus_resp_leEq_lft; apply rht_leEq_Max. apply shift_leEq_plus. apply inv_cancel_leEq; rstepr (Gx[-]Gy); auto. apply shift_minus_leEq; apply Max_leEq. apply leEq_transitive with (e [/]TwoNZ[+]Fx). apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto. apply plus_resp_leEq_lft; apply lft_leEq_Max. apply leEq_transitive with (e [/]TwoNZ[+]Gy). 2: apply plus_resp_leEq_lft; apply rht_leEq_Max. apply shift_leEq_plus; auto. apply shift_zero_leEq_minus'. rstepr (e [/]TwoNZ[+]Max Fx Gy[-]Max Fy Gy). apply shift_zero_leEq_minus. apply Max_leEq. apply leEq_transitive with (e [/]TwoNZ[+]Fx). apply shift_leEq_plus. apply inv_cancel_leEq; rstepr (Fx[-]Fy); auto. apply plus_resp_leEq_lft; apply lft_leEq_Max. apply leEq_transitive with (e [/]TwoNZ[+]Gy). 2: apply plus_resp_leEq_lft; apply rht_leEq_Max. apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto. apply shift_minus_leEq; apply Max_leEq. apply leEq_transitive with (e [/]TwoNZ[+]Fy). apply shift_leEq_plus; auto. apply plus_resp_leEq_lft; apply lft_leEq_Max. apply leEq_transitive with (e [/]TwoNZ[+]Gy). apply shift_leEq_plus; astepl ZeroR; apply less_leEq; apply pos_div_two; auto. apply plus_resp_leEq_lft; apply rht_leEq_Max. Qed. (* begin show *) Hypothesis Hg' : bnd_away_zero I G. Hypothesis Hg'' : forall x Hx, I x -> G x Hx [#] [0]. (* end show *) Lemma Continuous_I_recip : Continuous_I Hab {1/}G. Proof. clear incF incG. elim contG; intros incG' contG'. split. Included; assumption. elim Hg'; intros Haux Hg2. elim Hg2; clear Haux Hg2; intros c H H0. intros. elim contG' with (c[*]c[*]e); clear contG contG'. intros d H2 H3. exists d. assumption. intros x y H4 H5 Hx Hy H6. simpl in |- *. set (Hxx := incG' x H4) in *. set (Hyy := incG' y H5) in *. apply leEq_wdl with (AbsIR (G y Hyy[-]G x Hxx[/] _[//] mult_resp_ap_zero _ _ _ (Hg'' x Hxx H4) (Hg'' y Hyy H5))). apply leEq_wdl with (AbsIR (G y Hyy[-]G x Hxx) [/] _[//] AbsIR_resp_ap_zero _ (mult_resp_ap_zero _ _ _ (Hg'' x Hxx H4) (Hg'' y Hyy H5))). apply leEq_transitive with (AbsIR (G y Hyy[-]G x Hxx) [/] _[//] mult_resp_ap_zero _ _ _ (pos_ap_zero _ _ H) (pos_ap_zero _ _ H)). rstepl (AbsIR (G y Hyy[-]G x Hxx) [*] ([1][/] _[//] AbsIR_resp_ap_zero _ (mult_resp_ap_zero _ _ _ (Hg'' x Hxx H4) (Hg'' y Hyy H5)))). rstepr (AbsIR (G y Hyy[-]G x Hxx) [*] ([1][/] _[//] mult_resp_ap_zero _ _ _ (pos_ap_zero _ _ H) (pos_ap_zero _ _ H))). apply mult_resp_leEq_lft. apply recip_resp_leEq. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try (apply less_leEq; assumption). eapply leEq_wdr; [ apply (H0 x Hxx H4) | algebra ]. eapply leEq_wdr; [ apply (H0 y Hyy H5) | algebra ]. apply AbsIR_nonneg. apply shift_div_leEq'. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption. eapply leEq_wdl. 2: apply AbsIR_minus. apply H3; assumption. apply eq_symmetric_unfolded; apply AbsIR_division. apply AbsIR_wd. rational. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption. assumption. Qed. Lemma Continuous_I_NRoot : forall n Hn, (forall x Hx, I x -> [0][<=]F x Hx) -> Continuous_I Hab (FNRoot F n Hn). Proof. intros n Hn H. split. Included. intros e He. destruct contF as [contF'' contF']. destruct (contF' (e[^]n)) as [d Hd H0]; clear contF contF'. apply nexp_resp_pos; assumption. exists d. assumption. intros x y Hx0 Hy0 Hx Hy Hxy. set (x':=FNRoot F n Hn x Hx). set (y':=FNRoot F n Hn y Hy). stepl (Max x' y'[-]Min x' y'); [|apply eq_symmetric;apply Abs_Max]. apply shift_minus_leEq. apply power_cancel_leEq with n; try assumption. apply plus_resp_nonneg. apply less_leEq; assumption. apply leEq_Min; apply: NRoot_nonneg. apply leEq_transitive with (e[^]n[+]Min x' y'[^]n). apply shift_leEq_plus. set (Hx':=(ProjT1 (ext2_a IR (Dom F) (fun (x0 : IR) (Hx1 : Dom F x0) => [0][<=]F x0 Hx1) x Hx))). set (Hy':=(ProjT1 (ext2_a IR (Dom F) (fun (x0 : IR) (Hx1 : Dom F x0) => [0][<=]F x0 Hx1) y Hy))). stepl (AbsIR (F x Hx'[-]F y Hy')). apply H0; try assumption. stepr (AbsIR (x'[^]n[-]y'[^]n)). apply AbsIR_wd. apply: bin_op_wd_unfolded; apply eq_symmetric; try apply un_op_wd_unfolded; apply: NRoot_power. csetoid_rewrite (Abs_Max (x'[^]n) (y'[^]n)). apply: bin_op_wd_unfolded; try apply un_op_wd_unfolded. change (Max ((FId{^}n) x' True_constr) ((FId{^}n) y' True_constr)[=]((FId{^}n) (Max x' y') True_constr)). apply Max_monotone. simpl; intros r s _ _ X0 X1 X2. apply: nexp_resp_leEq; try assumption. eapply leEq_transitive;[|apply X0]. apply leEq_Min; apply: NRoot_nonneg. change (Min ((FId{^}n) x' True_constr) ((FId{^}n) y' True_constr)[=]((FId{^}n) (Min x' y') True_constr)). apply Min_monotone. simpl; intros r s _ _ X0 X1 X2. apply: nexp_resp_leEq; try assumption. eapply leEq_transitive;[|apply X0]. apply leEq_Min; apply: NRoot_nonneg. apply power_plus_leEq; try assumption. apply less_leEq; assumption. apply leEq_Min; apply: NRoot_nonneg. Qed. End Local_Results. #[global] Hint Resolve contin_imp_inc: included. Section Corolaries. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables F G : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. (** The corresponding properties for subtraction, division and multiplication by a scalar are easily proved as corollaries; exponentiation is proved by induction, appealing to the results on product and constant functions. *) Lemma Continuous_I_minus : Continuous_I Hab (F{-}G). Proof. apply Continuous_I_wd with (F{+}{--}G). FEQ. apply Continuous_I_plus. apply contF. apply Continuous_I_inv; apply contG. Qed. Lemma Continuous_I_scal : forall c : IR, Continuous_I Hab (c{**}F). Proof. intros. unfold Fscalmult in |- *. apply Continuous_I_mult. apply Continuous_I_const. apply contF. Qed. Lemma Continuous_I_nth : forall n : nat, Continuous_I Hab (F{^}n). Proof. simple induction n. apply Continuous_I_wd with ( [-C-]OneR). apply FNth_zero'; apply contin_imp_inc; auto. apply Continuous_I_const. clear n; intros. apply Continuous_I_wd with (F{*}F{^}n). apply FNth_mult'; apply contin_imp_inc; auto. apply Continuous_I_mult; assumption. Qed. Lemma Continuous_I_min : Continuous_I Hab (FMin F G). Proof. unfold FMin in |- *. apply Continuous_I_inv; apply Continuous_I_max; apply Continuous_I_inv; auto. Qed. Lemma Continuous_I_abs : Continuous_I Hab (FAbs F). Proof. unfold FAbs in |- *. apply Continuous_I_max; try apply Continuous_I_inv; auto. Qed. Hypothesis Hg' : bnd_away_zero I G. Hypothesis Hg'' : forall x Hx, I x -> G x Hx [#] [0]. Lemma Continuous_I_div : Continuous_I Hab (F{/}G). Proof. apply Continuous_I_wd with (F{*}{1/}G). FEQ. apply Continuous_I_mult. assumption. apply Continuous_I_recip; assumption. Qed. End Corolaries. Section Other. Section Sums. (** We finally prove that the sum of an arbitrary family of continuous functions is still a continuous function. *) Variables a b : IR. Hypothesis Hab : a [<=] b. Hypothesis Hab' : a [<] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Lemma Continuous_I_Sum0 : forall f : nat -> PartIR, (forall n, Continuous_I Hab (f n)) -> forall n, Continuous_I Hab (FSum0 n f). Proof. intros. induction n as [| n Hrecn]. eapply Continuous_I_wd. apply FSum0_0. 2: apply Continuous_I_const. intro; apply contin_imp_inc; auto. eapply Continuous_I_wd. apply FSum0_S. intro; apply contin_imp_inc; auto. apply Continuous_I_plus; auto. Qed. Lemma Continuous_I_Sumx : forall n (f : forall i, i < n -> PartIR), (forall i Hi, Continuous_I Hab (f i Hi)) -> Continuous_I Hab (FSumx n f). Proof. intro; induction n as [| n Hrecn]; intros f contF. simpl in |- *; apply Continuous_I_const. simpl in |- *; apply Continuous_I_plus. apply Hrecn. intros; apply contF. apply contF. Qed. Lemma Continuous_I_Sum : forall f : nat -> PartIR, (forall n, Continuous_I Hab (f n)) -> forall m n, Continuous_I Hab (FSum m n f). Proof. intros. eapply Continuous_I_wd. apply Feq_symmetric; apply FSum_FSum0'. intro; apply contin_imp_inc; auto. apply Continuous_I_minus; apply Continuous_I_Sum0; auto. Qed. End Sums. (** For practical purposes, these characterization results are useful: *) Lemma lub_charact : forall a b Hab F (contF : Continuous_I Hab F) z, fun_lub_IR F (compact a b Hab) z -> z [=] lub_funct a b Hab F contF. Proof. intros a b Hab F contF z H. elim H; intros Hz Hz'; clear H. assert (H := lub_is_lub _ _ _ _ contF). set (y := lub_funct _ _ _ _ contF) in *. elim H; intros Hy Hy'; clear H. apply leEq_imp_eq; apply shift_zero_leEq_minus'; apply inv_cancel_leEq; astepr ZeroR; apply approach_zero; intros e He. rstepl (z[-]y). apply shift_minus_less. elim (Hz' e He); intros x Hx. intro H. apply less_leEq_trans with (x[+]e). apply shift_less_plus'; auto. astepr (y[+]e). apply plus_resp_leEq; apply Hy. auto. rstepl (y[-]z). apply shift_minus_less. elim (Hy' e He); intros x Hx. intro H. apply less_leEq_trans with (x[+]e). apply shift_less_plus'; auto. astepr (z[+]e). apply plus_resp_leEq; apply Hz. auto. Qed. Lemma glb_charact : forall a b Hab F (contF : Continuous_I Hab F) z, fun_glb_IR F (compact a b Hab) z -> z [=] glb_funct a b Hab F contF. Proof. intros a b Hab F contF z H. elim H; intros Hz Hz'; clear H. assert (H := glb_is_glb _ _ _ _ contF). set (y := glb_funct _ _ _ _ contF) in *. elim H; intros Hy Hy'; clear H. apply leEq_imp_eq; apply shift_zero_leEq_minus'; apply inv_cancel_leEq; astepr ZeroR; apply approach_zero; intros e He. rstepl (z[-]y). apply shift_minus_less. elim (Hy' e He); intros x Hx. intro H. apply leEq_less_trans with x. apply Hz; auto. apply shift_less_plus; auto. rstepl (y[-]z). apply shift_minus_less. elim (Hz' e He); intros x Hx. intro H. apply leEq_less_trans with x. apply Hy; auto. apply shift_less_plus; auto. Qed. (** The following result is also extremely useful, as it allows us to set a lower bound on the glb of a function. *) Lemma leEq_glb : forall a b Hab (F : PartIR) contF x, (forall y, Compact Hab y -> forall Hy, x [<=] F y Hy) -> x [<=] glb_funct a b Hab F contF. Proof. intros a b Hab F contF x H. elim (glb_is_glb _ _ _ _ contF); intros. astepr (glb_funct _ _ _ _ contF[+][0]); apply shift_leEq_plus'. apply approach_zero_weak. intros e H0. elim (b0 _ H0); intro y; intros. apply less_leEq; eapply leEq_less_trans. 2: apply q. apply minus_resp_leEq. elim p; intros z Hz. elim Hz; intros H1 H2. elim H2; intros H3 H4. astepr (F z H3); auto. Qed. (** The norm is also an extensional property. *) Lemma Norm_Funct_wd : forall a b Hab F G, Feq (compact a b Hab) F G -> forall contF contG, Norm_Funct (Hab:=Hab) (F:=F) contF [=] Norm_Funct (Hab:=Hab) (F:=G) contG. Proof. intros a b Hab F G H contF contG. elim H; intros incF H''. elim H''; clear H''; intros incG H''. unfold Norm_Funct in |- *; apply bin_op_wd_unfolded. generalize (lub_is_lub _ _ _ _ contF); intro Hlub. apply lub_charact. elim Hlub; clear Hlub; intros H0 H1. split. intros x H2. apply H0. apply fun_image_wd with G. apply Feq_symmetric; auto. auto. intros e H2. elim (H1 e H2); intro x; intros. exists x. apply fun_image_wd with F; auto. auto. apply un_op_wd_unfolded. generalize (glb_is_glb _ _ _ _ contF); intro Hglb. apply glb_charact. elim Hglb; intros H0 H1. split. intros x H2. apply H0. apply fun_image_wd with G. apply Feq_symmetric; auto. auto. intros e H2. elim (H1 e H2); intro x; intros. exists x. apply fun_image_wd with F; auto. auto. Qed. (** The value of the norm is covariant with the length of the interval. *) Lemma included_imp_norm_leEq : forall a b c d Hab Hcd F contF1 contF2, included (compact c d Hcd) (compact a b Hab) -> Norm_Funct (Hab:=Hcd) (F:=F) contF2 [<=] Norm_Funct (Hab:=Hab) (F:=F) contF1. Proof. intros. apply leEq_Norm_Funct; intros. apply norm_bnd_AbsIR; auto. Qed. End Other. #[global] Hint Resolve Continuous_I_const Continuous_I_id Continuous_I_plus Continuous_I_inv Continuous_I_minus Continuous_I_mult Continuous_I_scal Continuous_I_recip Continuous_I_max Continuous_I_min Continuous_I_div Continuous_I_nth Continuous_I_abs Continuous_I_NRoot: continuous. corn-8.20.0/ftc/Derivative.v000066400000000000000000000312011473720167500156200ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Continuity. Section Definitions. (** * Derivatives We will now proceed toward the development of differential calculus. To begin with, the main notion is that of derivative. At this stage we will not define a notion of differentiable function, mainly because the natural definition (that of being a function which has some derivative) poses some technical problems; thus, we will postpone that part of our work to a subsequent stage. Derivative is a binary relation in the type of partial functions, dependent (once again) on a compact interval with distinct endpoints#. #%\footnote{%As before, we do not define pointwise differentiability, mainly for coherence reasons. See Bishop [1967] for a discussion on the relative little interest of that concept.%}.% The reason for requiring the endpoints to be apart is mainly to be able to derive the usual properties of the derivative relation---namely, that any two derivatives of the same function must coincide. %\begin{convention}% Let [a,b:IR] with [a [<] b] and denote by [I] the interval [[a,b]]. Throughout this chapter, [F, F', G, G'] and [H] will be partial functions with domains respectively [P, P', Q, Q'] and [R]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Variable F : PartIR. (* begin hide *) Let P := Dom F. (* end hide *) Definition Derivative_I F' (P':=Dom F') := included I (Dom F) and included I (Dom F') and (forall e, [0] [<] e -> {d : IR | [0] [<] d | forall x y, I x -> I y -> forall Hx Hy Hx', AbsIR (x[-]y) [<=] d -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e[*]AbsIR (y[-]x)}). End Definitions. Arguments Derivative_I [a b]. Section Basic_Properties. (** ** Basic Properties *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) (** Like we did for equality, we begin by stating a lemma that makes proofs of derivation easier in practice. *) Lemma Derivative_I_char : forall F F' (P:=Dom F) (P':=Dom F'), included I (Dom F) -> included I (Dom F') -> (forall e, [0] [<] e -> {d : IR | [0] [<] d | forall x y, I x -> I y -> forall Hx Hy Hx', AbsIR (x[-]y) [<=] d -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e[*]AbsIR (y[-]x)}) -> Derivative_I Hab' F F'. Proof. (* begin hide *) unfold Hab in |- *. intros. repeat (split; auto). Qed. (* end hide *) (** Derivative is a well defined relation; we will make this explicit for both arguments: *) Variables F G H : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. Let R := Dom H. (* end hide *) Lemma Derivative_I_wdl : Feq I F G -> Derivative_I Hab' F H -> Derivative_I Hab' G H. Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; intros incG Heq. elim H1; intros incF' H2. elim H2; intros incH H3. clear H0' H1 H2. apply Derivative_I_char; auto. intros e He. elim (H3 e He); clear H3; intros d H1 H2. exists d; auto. intros x y H3 H4 Hx Hy Hx' H5. astepl (AbsIR (F y (incF y H4) [-]F x (incF x H3) [-]H x Hx'[*] (y[-]x))); auto. Qed. Lemma Derivative_I_wdr : Feq I F G -> Derivative_I Hab' H F -> Derivative_I Hab' H G. Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; intros incG Heq. elim H1; intros incH H2. elim H2; intros incF0 H3. apply Derivative_I_char; auto. intros e He. elim (H3 e He); clear H3; intros d H3 H4. exists d; auto. intros x y H5 H6 Hx Hy Hx' H7. astepl (AbsIR (H y Hy[-]H x Hx[-]F x (incF x H5) [*] (y[-]x))); auto. Qed. (* begin hide *) Let Derivative_I_unique_lemma : forall x : IR, Compact Hab x -> forall d : IR, [0] [<] d -> {y : IR | AbsIR (x[-]y) [<=] d | Compact Hab y and y[-]x [#] [0]}. Proof. intros x Hx d Hd. elim (less_cotransitive_unfolded _ _ _ Hab' x); intro. exists (Max a (x[-]d [/]TwoNZ)); auto. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply less_leEq; apply shift_minus_less'; apply shift_less_plus. apply less_leEq_trans with (x[-]d [/]TwoNZ). apply minus_resp_less_rht. apply pos_div_two'; assumption. simpl in |- *. apply rht_leEq_Max. apply shift_leEq_minus. simpl in |- *. astepl (Max a (x[-]d [/]TwoNZ)). apply less_leEq. apply Max_less; [ assumption | astepr (x[-][0]) ]. apply minus_resp_less_rht; apply pos_div_two; assumption. split. split. apply lft_leEq_Max. apply Max_leEq. apply less_leEq; assumption. apply leEq_transitive with x. apply shift_minus_leEq; apply shift_leEq_plus'; astepl ZeroR. apply less_leEq; apply pos_div_two; assumption. inversion_clear Hx; assumption. apply less_imp_ap; apply shift_minus_less; astepr x; apply Max_less. assumption. apply shift_minus_less; apply shift_less_plus'; astepl ZeroR. apply pos_div_two with (eps := d); assumption. exists (Min b (x[+]d [/]TwoNZ)). apply leEq_wdl with (Min b (x[+]d [/]TwoNZ) [-]x). apply less_leEq. apply shift_minus_less. rstepr (x[+]d). eapply leEq_less_trans. apply Min_leEq_rht. apply plus_resp_less_lft. apply pos_div_two'; assumption. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded; [ apply AbsIR_minus | apply AbsIR_eq_x ]. apply less_leEq; apply shift_less_minus; astepl x; apply less_Min. assumption. astepl (x[+][0]); apply plus_resp_less_lft. apply pos_div_two; assumption. split. split. apply leEq_Min. auto. apply leEq_transitive with x. inversion_clear Hx; auto. astepl (x[+]ZeroR); apply plus_resp_leEq_lft; apply less_leEq; apply pos_div_two; assumption. apply Min_leEq_lft. apply Greater_imp_ap. apply shift_less_minus; astepl x. astepr (Min b (x[+]d [/]TwoNZ)); apply less_Min. assumption. astepl (x[+][0]); apply plus_resp_less_lft; apply pos_div_two; assumption. Qed. (* end hide *) (** Derivative is unique. *) Lemma Derivative_I_unique : Derivative_I Hab' F G -> Derivative_I Hab' F H -> Feq I G H. Proof. intros H0 H1. elim H0; intros incF H2. elim H2; intros incG H3. elim H1; intros incF' H6. elim H6; intros incH H4. clear H0 H2 H6. apply eq_imp_Feq; auto. intros x H0 Hx Hx'. apply cg_inv_unique_2. apply AbsIR_approach_zero; intros e H2. elim (H3 _ (pos_div_two _ _ H2)). intros dg H6 H7. elim (H4 _ (pos_div_two _ _ H2)). clear H4 H3; intros dh H3 H4. set (d := Min (Min dg dh) [1]) in *. elim (Derivative_I_unique_lemma x H0 d). intros y Hy' Hy''. elim Hy''; clear Hy''; intros Hy'' Hy. apply mult_cancel_leEq with (AbsIR (y[-]x)). apply AbsIR_pos; assumption. eapply leEq_wdl. 2: apply AbsIR_resp_mult. set (Hxx := incF x H0) in *. set (Hyy := incF y Hy'') in *. apply leEq_wdl with (AbsIR (F y Hyy[-]F x Hxx[-]H x Hx'[*] (y[-]x) [-] (F y Hyy[-]F x Hxx[-]G x Hx[*] (y[-]x)))). 2: apply un_op_wd_unfolded; rational. eapply leEq_transitive. apply triangle_IR_minus. rstepr (e [/]TwoNZ[*]AbsIR (y[-]x) [+]e [/]TwoNZ[*]AbsIR (y[-]x)). apply plus_resp_leEq_both; [ apply H4 | apply H7 ]; try assumption; eapply leEq_transitive; try apply Hy'; unfold d in |- *; eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_rht. apply Min_leEq_lft. apply Min_leEq_lft. unfold d in |- *; repeat apply less_Min; [ assumption | assumption | apply pos_one ]. Qed. (** Finally, the set where we are considering the relation is included in the domain of both functions. *) Lemma derivative_imp_inc : Derivative_I Hab' F G -> included I P. Proof. intro H0. inversion_clear H0; assumption. Qed. Lemma derivative_imp_inc' : Derivative_I Hab' F G -> included I Q. Proof. intro H0. elim H0; intros H1 H2. inversion_clear H2; assumption. Qed. (** Any function that is or has a derivative is continuous. *) Variable Hab'' : a [<=] b. Lemma deriv_imp_contin'_I : Derivative_I Hab' F G -> Continuous_I Hab'' G. Proof. intro derF. elim derF; intros incF H0. elim H0; intros incG derivFG. clear derF H0. split. Included. intros e He. elim (derivFG _ (pos_div_two _ _ He)); intros d posd Hde; clear derivFG. exists d. auto. intros x y H0 H1 Hx Hy H2. set (Hx' := incF _ H0) in *. set (Hy' := incF _ H1) in *. apply equal_less_leEq with (a := ZeroR) (b := AbsIR (y[-]x)); intros. 3: apply AbsIR_nonneg. apply mult_cancel_leEq with (AbsIR (y[-]x)); auto. rstepr (e [/]TwoNZ[*]AbsIR (y[-]x) [+]e [/]TwoNZ[*]AbsIR (y[-]x)). eapply leEq_wdl. 2: apply AbsIR_resp_mult. apply leEq_wdl with (AbsIR (F y Hy'[-]F x Hx'[-]G x Hx[*] (y[-]x) [+] (F x Hx'[-]F y Hy'[-]G y Hy[*] (x[-]y)))). 2: eapply eq_transitive_unfolded. 2: apply AbsIR_inv. 2: apply AbsIR_wd; rational. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. auto. apply leEq_wdr with (e [/]TwoNZ[*]AbsIR (x[-]y)). apply Hde; auto. eapply leEq_wdl. apply H2. apply AbsIR_minus. apply mult_wdr; apply AbsIR_minus. apply leEq_wdl with ZeroR. apply less_leEq; auto. astepl (AbsIR [0]). apply AbsIR_wd. apply eq_symmetric_unfolded; apply x_minus_x. apply pfwdef. apply cg_inv_unique_2. apply AbsIR_eq_zero. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. apply H3. apply AbsIR_minus. Qed. Lemma deriv_imp_contin_I : Derivative_I Hab' F G -> Continuous_I Hab'' F. Proof. intro derF. elim derF; intros incF H2; elim H2; clear H2; intros incG deriv. split; auto. intros e He. elim deriv with e; auto. clear deriv; intros d posd Hd. set (contG := deriv_imp_contin'_I derF) in *. set (M := Norm_Funct contG) in *. set (D := Min d (Min ([1] [/]TwoNZ) (e[/] _[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (max_one_ap_zero M)))) in *. exists D. unfold D in |- *; repeat apply less_Min. auto. apply (pos_half IR). apply div_resp_pos; auto. apply shift_less_mult' with (two_ap_zero IR). apply pos_two. astepl ZeroR. eapply less_leEq_trans. 2: apply rht_leEq_Max. apply pos_one. intros x y H0 H1 Hx Hy H2. apply leEq_wdl with (AbsIR (F x Hx[-]F y Hy[-]G y (incG _ H1) [*] (x[-]y) [+] G y (incG _ H1) [*] (x[-]y))). 2: apply AbsIR_wd; rational. eapply leEq_transitive. apply triangle_IR. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). apply plus_resp_leEq_both. apply leEq_transitive with (e[*]AbsIR (x[-]y)). apply Hd; auto. apply leEq_transitive with D. eapply leEq_wdl; [ apply H2 | apply AbsIR_minus ]. unfold D in |- *; apply Min_leEq_lft. rstepr (e[*][1] [/]TwoNZ). apply mult_resp_leEq_lft. apply leEq_transitive with D; auto. unfold D in |- *; eapply leEq_transitive; [ apply Min_leEq_rht | apply Min_leEq_lft ]. apply less_leEq; auto. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (Max M [1][*]AbsIR (x[-]y)). apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. eapply leEq_transitive. 2: apply lft_leEq_Max. unfold M in |- *; apply norm_bnd_AbsIR; auto. apply shift_mult_leEq' with (max_one_ap_zero M). eapply less_leEq_trans; [ apply pos_one | apply rht_leEq_Max ]. eapply leEq_wdr. eapply leEq_transitive. apply H2. unfold D in |- *. eapply leEq_transitive; apply Min_leEq_rht. rational. Qed. End Basic_Properties. (** If [G] is the derivative of [F] in a given interval, then [G] is also the derivative of [F] in any smaller interval. *) Lemma included_imp_deriv : forall a b Hab c d Hcd F F', included (compact c d (less_leEq _ _ _ Hcd)) (compact a b (less_leEq _ _ _ Hab)) -> Derivative_I Hab F F' -> Derivative_I Hcd F F'. Proof. intros a b Hab c d Hcd F F' H H0. elim H0; clear H0; intros incF H0. elim H0; clear H0; intros incF' H0. apply Derivative_I_char. apply included_trans with (Compact (less_leEq _ _ _ Hab)); auto. apply included_trans with (Compact (less_leEq _ _ _ Hab)); auto. intros e He; elim (H0 e He); intros e' He'. exists e'; auto. Qed. corn-8.20.0/ftc/DerivativeOps.v000066400000000000000000000522721473720167500163150ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Derivative. Section Lemmas. (** ** Algebraic Operations We will now prove the main results about deriving functions built from the algebraic operators#. #%\footnote{%Composition presents some tricky questions, and is therefore discussed in a separated context.%}.% [F'] and [G'] will be the derivatives, respectively, of [F] and [G]. We begin with some technical stuff that will be necessary for division. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable F : PartIR. (* begin hide *) Let P := Dom F. (* end hide *) (* begin show *) Hypothesis Fbnd : bnd_away_zero I F. (* end show *) Lemma bnd_away_zero_square : bnd_away_zero I (F{*}F). Proof. elim Fbnd; clear Fbnd; intros H H0. elim H0; clear H0; intros x H1 H2. split. Included. exists (x[*]x). astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; assumption. intros y Hy H0. unfold I in H; apply leEq_wdr with (AbsIR (FRestr H y H0)[*]AbsIR (FRestr H y H0)). apply mult_resp_leEq_both; try (apply less_leEq; assumption); simpl in |- *; apply H2; try assumption. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply AbsIR_wd; simpl in |- *; rational. Qed. End Lemmas. #[global] Hint Resolve bnd_away_zero_square: included. Section Local_Results. (** ** Local Results We can now derive all the usual rules for deriving constant and identity functions, sums, inverses and products of functions with a known derivative. *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Lemma Derivative_I_const : forall c : IR, Derivative_I Hab' [-C-]c [-C-][0]. Proof. intros. apply Derivative_I_char. Included. Included. intros e He. exists OneR. apply pos_one. intros. simpl in |- *. apply leEq_wdl with ZeroR. astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive. apply less_leEq; assumption. apply AbsIR_nonneg. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIRz_isz. apply AbsIR_wd; rational. Qed. Lemma Derivative_I_id : Derivative_I Hab' FId [-C-][1]. Proof. intros. apply Derivative_I_char. Included. Included. intros e He. exists e. assumption. intros. apply leEq_wdl with ZeroR. astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive. apply less_leEq; assumption. apply AbsIR_nonneg. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIRz_isz. apply AbsIR_wd; simpl in |- *; rational. Qed. Variables F F' G G' : PartIR. Hypothesis derF : Derivative_I Hab' F F'. Hypothesis derG : Derivative_I Hab' G G'. Lemma Derivative_I_plus : Derivative_I Hab' (F{+}G) (F'{+}G'). Proof. elim derF; intros incF H1. elim H1; intros incF' H2. elim derG; intros incG H5. elim H5; intros incG' H6. clear H5 H1. apply Derivative_I_char. Included. Included. intros e He. elim (H2 _ (pos_div_two _ _ He)). intros df H H0. elim (H6 _ (pos_div_two _ _ He)). intros dg H1 H3. clear H2 H6. exists (Min df dg). apply less_Min; assumption. intros. rstepr (e [/]TwoNZ[*]AbsIR (y[-]x)[+]e [/]TwoNZ[*]AbsIR (y[-]x)); simpl in |- *. set (fx := F x (ProjIR1 Hx)) in *. set (fy := F y (ProjIR1 Hy)) in *. set (gx := G x (ProjIR2 Hx)) in *. set (gy := G y (ProjIR2 Hy)) in *. set (f'x := F' x (ProjIR1 Hx')) in *. set (g'x := G' x (ProjIR2 Hx')) in *. apply leEq_wdl with (AbsIR (fy[-]fx[-]f'x[*](y[-]x)[+](gy[-]gx[-]g'x[*](y[-]x)))). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both; unfold fx, fy, gx, gy, f'x, g'x in |- *; [ apply H0 | apply H3 ]; try assumption; apply leEq_transitive with (Min df dg). assumption. apply Min_leEq_lft. assumption. apply Min_leEq_rht. apply AbsIR_wd; rational. Qed. Lemma Derivative_I_inv : Derivative_I Hab' {--}F {--}F'. Proof. clear derG. elim derF; intros incF H1. elim H1; intros incF' H2. clear H1. apply Derivative_I_char. Included. Included. intros e He. elim (H2 e He); intros d H0 H1. exists d. assumption. intros. simpl in |- *. apply leEq_wdl with (AbsIR [--](F y Hy[-]F x Hx[-]F' x Hx'[*](y[-]x))). eapply leEq_wdl. 2: apply AbsIR_inv. auto. apply AbsIR_wd; rational. Qed. Lemma Derivative_I_mult : Derivative_I Hab' (F{*}G) (F{*}G'{+}F'{*}G). Proof. elim derF; intros incF H1. elim H1; intros incF' H2. elim derG; intros incG H5. elim H5; intros incG' H6. clear H5 H1. set (contF := deriv_imp_contin_I _ _ _ _ _ (less_leEq _ _ _ Hab') derF) in *. set (contG := deriv_imp_contin_I _ _ _ _ _ (less_leEq _ _ _ Hab') derG) in *. set (contG' := deriv_imp_contin'_I _ _ _ _ _ (less_leEq _ _ _ Hab') derG) in *. set (nF := Norm_Funct contF) in *. set (nG := Norm_Funct contG) in *. set (nG' := Norm_Funct contG') in *. apply Derivative_I_char. Contin. Contin. intros e He. set (M := Max (Max nF nG) nG'[+][1]) in *. cut ([0] [<] M). intro HM'. cut (M [#] [0]). intro HM. 2: apply Greater_imp_ap; assumption. cut (Three[*]M [#] [0]). intro H3M. 2: apply mult_resp_ap_zero; [ apply three_ap_zero | assumption ]. cut ([0] [<] (e[/] _[//]H3M)). intro HeM. elim (contin_prop _ _ _ _ contF _ HeM); intros dc H H0. elim (H2 _ HeM); intros df H1 H3. elim (H6 _ HeM); intros dg H4 H5. clear H2 H6. set (d := Min (Min df dg) dc) in *. exists d. unfold d in |- *; repeat apply less_Min; assumption. intros x y H2 H6 Hx Hy Hx' H7. simpl in |- *. set (fx := F x (ProjIR1 Hx)) in *. set (fy := F y (ProjIR1 Hy)) in *. set (gx := G x (ProjIR2 Hx)) in *. set (gy := G y (ProjIR2 Hy)) in *. set (f'x := F' x (ProjIR1 (ProjIR2 Hx'))) in *. set (g'x := G' x (ProjIR2 (ProjIR1 Hx'))) in *. apply leEq_wdl with (AbsIR (fy[*]gy[-]fx[*]gx[-](fx[*]g'x[+]f'x[*]gx)[*](y[-]x))). 2: apply AbsIR_wd; unfold fx, f'x, gx, g'x in |- *; rational. apply leEq_wdl with (AbsIR (fy[*](gy[-]gx[-]g'x[*](y[-]x))[+](fy[-]fx)[*]g'x[*](y[-]x)[+] gx[*](fy[-]fx[-]f'x[*](y[-]x)))). astepr (e[*]AbsIR (y[-]x)). rstepr (e [/]ThreeNZ[*]AbsIR (y[-]x)[+]e [/]ThreeNZ[*]AbsIR (y[-]x)[+] e [/]ThreeNZ[*]AbsIR (y[-]x)). eapply leEq_transitive; [ apply triangle_IR | apply plus_resp_leEq_both ]. eapply leEq_transitive; [ apply triangle_IR | apply plus_resp_leEq_both ]. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (M[*]AbsIR (gy[-]gx[-]g'x[*](y[-]x))). apply mult_resp_leEq_rht; [ apply leEq_transitive with nF | apply AbsIR_nonneg ]. unfold nF, I, fy in |- *; apply norm_bnd_AbsIR. assumption. unfold M in |- *; eapply leEq_transitive. 2: apply less_leEq; apply less_plusOne. eapply leEq_transitive. 2: apply lft_leEq_Max. apply lft_leEq_Max. apply shift_mult_leEq' with HM. assumption. rstepr ((e[/] _[//]H3M)[*]AbsIR (y[-]x)). unfold gx, gy, g'x in |- *; apply H5; try assumption. apply leEq_transitive with d. assumption. unfold d in |- *; eapply leEq_transitive; [ apply Min_leEq_lft | apply Min_leEq_rht ]. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (AbsIR (fy[-]fx)[*]M). apply mult_resp_leEq_lft. unfold M in |- *; eapply leEq_transitive. 2: apply less_leEq; apply less_plusOne. eapply leEq_transitive. 2: apply rht_leEq_Max. unfold nG', I, g'x in |- *; apply norm_bnd_AbsIR; assumption. apply AbsIR_nonneg. apply shift_mult_leEq with HM. assumption. rstepr (e[/] _[//]H3M). unfold fx, fy in |- *; apply H0; try assumption. apply leEq_transitive with d. 2: unfold d in |- *; apply Min_leEq_rht. eapply leEq_wdl. apply H7. apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (M[*]AbsIR (fy[-]fx[-]f'x[*](y[-]x))). apply mult_resp_leEq_rht; [ apply leEq_transitive with nG | apply AbsIR_nonneg ]. unfold nG, I, gx in |- *; apply norm_bnd_AbsIR; assumption. unfold M in |- *; eapply leEq_transitive. 2: apply less_leEq; apply less_plusOne. eapply leEq_transitive. 2: apply lft_leEq_Max. apply rht_leEq_Max. apply shift_mult_leEq' with HM. assumption. rstepr ((e[/] _[//]H3M)[*]AbsIR (y[-]x)). unfold fx, fy, f'x in |- *; apply H3; try assumption. apply leEq_transitive with d. assumption. unfold d in |- *; eapply leEq_transitive; [ apply Min_leEq_lft | apply Min_leEq_lft ]. apply AbsIR_wd; rational. apply div_resp_pos. astepl (Three[*]ZeroR); apply mult_resp_less_lft. assumption. apply pos_three. assumption. unfold M in |- *; eapply leEq_less_trans. 2: apply less_plusOne. eapply leEq_transitive. 2: apply rht_leEq_Max. unfold nG' in |- *; apply positive_norm. Qed. (** As was the case for continuity, the rule for the reciprocal function has a side condition. *) (* begin show *) Hypothesis Fbnd : bnd_away_zero I F. (* end show *) Lemma Derivative_I_recip : Derivative_I Hab' {1/}F {--} (F'{/}F{*}F). Proof. cut (forall (x : IR) (Hx : I x) Hx', F x Hx' [#] [0]). cut (forall (x : IR) (Hx : I x) Hx', (F{*}F) x Hx' [#] [0]). intros Hff Hf. clear derG. elim derF; intros incF H1. elim H1; intros incF' H2. assert (contF := deriv_imp_contin_I _ _ _ _ _ Hab derF). assert (contF' := deriv_imp_contin'_I _ _ _ _ _ Hab derF). assert (contF_ := contin_prop _ _ _ _ contF). clear H1. apply Derivative_I_char. Contin. Contin. intros e He. cut (Continuous_I Hab {1/}F); [ intro H | Contin ]. set (nF1 := Norm_Funct H) in *. set (nF' := Norm_Funct contF') in *. set (M := Max nF1 nF'[+][1]) in *. cut ([0] [<] M). intro HM. cut (M [#] [0]). intro H0. 2: apply Greater_imp_ap; assumption. cut (Two[*]M[*]M [#] [0]). intro HM2. cut (Two[*]M[*]M[*]M[*]M [#] [0]). intro HM4. cut ([0] [<] (e[/] _[//]HM2)). intro HeM2. cut ([0] [<] (e[/] _[//]HM4)). intro HeM4. elim (contF_ _ HeM4). intros d1 H1 H3. elim (H2 _ HeM2). intros d2 H4 H5. clear H2. exists (Min d1 d2). apply less_Min; assumption. intros x y H2 H6 Hx Hy Hx' H7. cut (forall (x : IR) (Hx : I x) Hx', AbsIR ([1][/] _[//]Hf x Hx Hx') [<=] M). intro leEqM. 2: intros z Hz Hz'. 2: apply leEq_wdl with (AbsIR ( {1/}F z (contin_imp_inc _ _ _ _ H z Hz))). 2: unfold M in |- *; eapply leEq_transitive. 3: apply less_leEq; apply less_plusOne. 2: eapply leEq_transitive. 3: apply lft_leEq_Max. 2: unfold nF1 in |- *; apply norm_bnd_AbsIR; assumption. 2: apply AbsIR_wd; simpl in |- *; algebra. cut (Dom F x); [ intro Hxx | simpl in Hx; unfold extend in Hx; inversion_clear Hx; assumption ]. cut (Dom F y); [ intro Hyy | simpl in Hy; unfold extend in Hy; inversion_clear Hy; assumption ]. cut (Dom F' x); [ intro Hxx' | simpl in Hx'; unfold extend in Hx'; inversion_clear Hx'; assumption ]. apply leEq_wdl with (AbsIR (([1][/] _[//]Hf y H6 Hyy)[-]([1][/] _[//]Hf x H2 Hxx)[+] (F' x Hxx'[/] _[//] mult_resp_ap_zero _ _ _ (Hf x H2 Hxx) (Hf x H2 Hxx))[*]( y[-]x))). apply leEq_wdl with (AbsIR ([--]([1][/] _[//]mult_resp_ap_zero _ _ _ (Hf x H2 Hxx) (Hf y H6 Hyy))[*] (F y Hyy[-]F x Hxx[-]F' x Hxx'[*](y[-]x)[+] F' x Hxx'[*](F x Hxx[-]F y Hyy[/] _[//]Hf x H2 Hxx)[*](y[-]x)))). 2: apply AbsIR_wd; rational. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. rstepr (M[*]M[*]((e[/] _[//]mult_resp_ap_zero _ _ _ H0 H0)[*]AbsIR (y[-]x))). apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_wdl. 2: apply AbsIR_inv. apply leEq_wdl with (AbsIR (([1][/] _[//]Hf x H2 Hxx)[*]([1][/] _[//]Hf y H6 Hyy))). 2: apply AbsIR_wd; rational. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg; apply leEqM. eapply leEq_transitive. apply triangle_IR. rstepr ((e[/] _[//]HM2)[*]AbsIR (y[-]x)[+](e[/] _[//]HM2)[*]AbsIR (y[-]x)). apply plus_resp_leEq_both. apply H5; try assumption. eapply leEq_transitive. apply H7. apply Min_leEq_rht. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. apply leEq_wdl with (AbsIR ((F x Hxx[-]F y Hyy)[*](F' x Hxx'[/] _[//]Hf x H2 Hxx))). 2: apply AbsIR_wd; rational. rstepr ((e[/] _[//]HM4)[*](M[*]M)). eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. apply H3; try assumption. eapply leEq_transitive. apply H7. apply Min_leEq_lft. apply leEq_wdl with (AbsIR (F' x Hxx'[*]([1][/] _[//]Hf x H2 Hxx))). 2: apply AbsIR_wd; rational. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. unfold M in |- *; eapply leEq_transitive. 2: apply less_leEq; apply less_plusOne. eapply leEq_transitive. 2: apply rht_leEq_Max. unfold nF' in |- *; apply norm_bnd_AbsIR; assumption. apply leEqM. apply AbsIR_wd. simpl in |- *; rational. apply div_resp_pos. repeat (astepl (ZeroR[*][0]); apply mult_resp_less_both); try apply leEq_reflexive; try assumption. apply pos_two. assumption. apply div_resp_pos. repeat (astepl (ZeroR[*][0]); apply mult_resp_less_both); try apply leEq_reflexive; try assumption. apply pos_two. assumption. repeat apply mult_resp_ap_zero; try assumption. apply two_ap_zero. repeat apply mult_resp_ap_zero; try assumption. apply two_ap_zero. unfold M in |- *; eapply leEq_less_trans. 2: apply less_plusOne. eapply leEq_transitive. 2: apply lft_leEq_Max. unfold nF1 in |- *; apply positive_norm. intros. apply bnd_imp_ap_zero with I; auto. unfold I in |- *; Included. intros. apply bnd_imp_ap_zero with I; auto. Qed. End Local_Results. #[global] Hint Immediate derivative_imp_inc derivative_imp_inc': included. #[global] Hint Resolve Derivative_I_const Derivative_I_id Derivative_I_plus Derivative_I_inv Derivative_I_mult Derivative_I_recip: derivate. Section Corolaries. Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Variables F F' G G' : PartIR. Hypothesis derF : Derivative_I Hab' F F'. Hypothesis derG : Derivative_I Hab' G G'. (** From this lemmas the rules for the other algebraic operations follow directly. *) Lemma Derivative_I_minus : Derivative_I Hab' (F{-}G) (F'{-}G'). Proof. apply Derivative_I_wdl with (F{+}{--}G). FEQ. apply Derivative_I_wdr with (F'{+}{--}G'). FEQ. Deriv. Qed. Lemma Derivative_I_scal : forall c : IR, Derivative_I Hab' (c{**}F) (c{**}F'). Proof. intro. unfold Fscalmult in |- *. apply Derivative_I_wdr with ([-C-]c{*}F'{+}[-C-][0]{*}F). FEQ. Deriv. Qed. Lemma Derivative_I_nth : forall n, Derivative_I Hab' (F{^}S n) (nring (S n) {**} (F'{*}F{^}n)). Proof. unfold Fscalmult in |- *. intro; induction n as [| n Hrecn]. apply Derivative_I_wdl with F. FEQ. apply Derivative_I_wdr with F'. FEQ. assumption. apply Derivative_I_wdl with (F{*}F{^}S n). apply FNth_mult'; Included. apply Derivative_I_wdr with (F{*} ([-C-](nring (S n)) {*} (F'{*}F{^}n)) {+}F'{*}F{^}S n). apply eq_imp_Feq. Included. Included. intros; simpl in |- *. set (fx := F x (ProjIR1 (ProjIR1 Hx))) in *; simpl in (value of fx); fold fx in |- *. set (f'x := F' x (ProjIR1 (ProjIR2 (ProjIR2 (ProjIR1 Hx))))) in *; simpl in (value of f'x); fold f'x in |- *. set (fx' := F x (ProjIR2 (ProjIR2 (ProjIR2 (ProjIR1 Hx))))) in *; simpl in (value of fx'); fold fx' in |- *. set (f'x' := F' x (ProjIR1 (ProjIR2 Hx))) in *; simpl in (value of f'x'); fold f'x' in |- *. set (fx'' := F x (ProjIR2 (ProjIR2 Hx))) in *; simpl in (value of fx''); fold fx'' in |- *. set (f'x'' := F' x (ProjIR1 (ProjIR2 Hx'))) in *; simpl in (value of f'x''); fold f'x'' in |- *. set (fx''' := F x (ProjIR2 (ProjIR2 Hx'))) in *; simpl in (value of fx'''); fold fx''' in |- *. apply eq_transitive_unfolded with (fx[*]((nring n[+][1])[*](f'x[*]fx[^]n))[+]f'x[*](fx[^]n[*]fx)). astepl (fx[*]((nring n[+][1])[*](f'x[*]fx'[^]n))[+]f'x'[*](fx''[^]n[*]fx'')). repeat apply bin_op_wd_unfolded; try apply nexp_wd; unfold fx, f'x, fx', f'x', fx'' in |- *; rational. rstepl ((nring n[+][1][+][1])[*](f'x[*](fx[^]n[*]fx))). astepr ((nring n[+][1][+][1])[*](f'x''[*](fx'''[^]n[*]fx'''))). repeat apply bin_op_wd_unfolded; try apply nexp_wd; unfold fx, f'x, f'x'', fx''' in |- *; rational. Deriv. Qed. Lemma Derivative_I_poly : forall p, Derivative_I Hab' (FPoly _ p) (FPoly _ (_D_ p)). Proof. induction p. apply Derivative_I_wdl with ([-C-] [0]). FEQ. apply Derivative_I_wdr with ([-C-] [0]). FEQ. Deriv. simpl. change (FPoly IR (cpoly_linear IR s p)) with (FPoly IR (s[+X*]p)). change (FPoly IR (cpoly_plus_cs IR p (cpoly_linear IR [0] (cpoly_diff IR p)))) with (FPoly IR (p[+]([0][+X*](_D_ p)))). apply Derivative_I_wdl with ([-C-] s{+}FId{*}(FPoly IR p)). repeat constructor. reflexivity. apply Derivative_I_wdr with ([-C-][0]{+}(FId{*}(FPoly IR (_D_ p)){+}[-C-][1]{*}(FPoly IR p))). repeat constructor. simpl. intros x _ _ _. change ([0][+](x[*](_D_ p)!x[+][1][*]p!x)[=] (p[+]([0][+X*](_D_ p)))!x). rewrite -> cpoly_lin. autorewrite with apply. rational. Deriv. Qed. Hypothesis Gbnd : bnd_away_zero I G. Lemma Derivative_I_div : Derivative_I Hab' (F{/}G) ((F'{*}G{-}F{*}G') {/}G{*}G). Proof. cut (Derivative_I Hab' (F{/}G) (F{*}{--} (G'{/}G{*}G) {+}F'{*}{1/}G)). intro H. eapply Derivative_I_wdr. 2: apply H. apply eq_imp_Feq. Included. apply included_FDiv. Included. Included. intros; apply bnd_imp_ap_zero with I; unfold I in |- *; Included. intros; simpl in |- *; rational. apply Derivative_I_wdl with (F{*}{1/}G). FEQ. Deriv. Qed. End Corolaries. #[global] Hint Resolve Derivative_I_minus Derivative_I_nth Derivative_I_scal Derivative_I_div Derivative_I_poly: derivate. Section Derivative_Sums. (** The derivation rules for families of functions are easily proved by induction using the constant and addition rules. *) Variables a b : IR. Hypothesis Hab : a [<=] b. Hypothesis Hab' : a [<] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Lemma Derivative_I_Sum0 : forall f f' : nat -> PartIR, (forall n, Derivative_I Hab' (f n) (f' n)) -> forall n, Derivative_I Hab' (FSum0 n f) (FSum0 n f'). Proof. intros. induction n as [| n Hrecn]. eapply Derivative_I_wdl. apply FSum0_0; Included. eapply Derivative_I_wdr. apply FSum0_0; Included. apply Derivative_I_const. eapply Derivative_I_wdl. apply FSum0_S; Included. eapply Derivative_I_wdr. apply FSum0_S; Included. apply Derivative_I_plus; auto. Qed. Lemma Derivative_I_Sumx : forall n (f f' : forall i, i < n -> PartIR), (forall i Hi Hi', Derivative_I Hab' (f i Hi) (f' i Hi')) -> Derivative_I Hab' (FSumx n f) (FSumx n f'). Proof. intro; induction n as [| n Hrecn]; intros f f' derF. simpl in |- *; apply Derivative_I_const; auto. simpl in |- *; apply Derivative_I_plus; auto. Qed. Lemma Derivative_I_Sum : forall f f' : nat -> PartIR, (forall n, Derivative_I Hab' (f n) (f' n)) -> forall m n, Derivative_I Hab' (FSum m n f) (FSum m n f'). Proof. intros. eapply Derivative_I_wdl. apply Feq_symmetric; apply FSum_FSum0'; Included. eapply Derivative_I_wdr. apply Feq_symmetric; apply FSum_FSum0'; Included. apply Derivative_I_minus; apply Derivative_I_Sum0; auto. Qed. End Derivative_Sums. #[global] Hint Resolve Derivative_I_Sum0 Derivative_I_Sum Derivative_I_Sumx: derivate. corn-8.20.0/ftc/Differentiability.v000066400000000000000000000260171473720167500171640ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.PartInterval. Require Export CoRN.ftc.DerivativeOps. Section Definitions. (** * Differentiability We will now use our work on derivatives to define a notion of differentiable function and prove its main properties. %\begin{convention}% Throughout this section, [a,b] will be real numbers with [a [<] b], [I] will denote the interval [[a,b]] and [F,G,H] will be differentiable functions. %\end{convention}% Usually a function [F] is said to be differentiable in a proper compact interval [[a,b]] if there exists another function [F'] such that [F'] is a derivative of [F] in that interval. There is a problem in formalizing this definition, as we pointed out earlier on, which is that if we simply write it down as is we are not able to get such a function [F'] from a hypothesis that [F] is differentiable. However, it turns out that this is not altogether the best definition for the following reason: if we say that [F] is differentiable in [[a,b]], we mean that there is a partial function [F'] which is defined in [[a,b]] and satisfies a certain condition in that interval but nothing is required of the behaviour of the function outside [[a,b]]. Thus we can argue that, from a mathematical point of view, the [F'] that we get eliminating a hypothesis of differentiability should be defined exactly on that interval. If we do this, we can quantify over the set of setoid functions in that interval and eliminate the existencial quantifier without any problems. *) Definition Diffble_I (a b : IR) (Hab : a [<] b) (F : PartIR) := {f' : CSetoid_fun (subset (Compact (less_leEq _ _ _ Hab))) IR | Derivative_I Hab F (PartInt f')}. End Definitions. Arguments Diffble_I [a b]. Section Local_Properties. (** From this point on, we just prove results analogous to the ones for derivability. A function differentiable in [[a,b]] is differentiable in every proper compact subinterval of [[a,b]]. *) Lemma included_imp_diffble : forall a b Hab c d Hcd F, included (compact c d (less_leEq _ _ _ Hcd)) (compact a b (less_leEq _ _ _ Hab)) -> Diffble_I Hab F -> Diffble_I Hcd F. Proof. intros a b Hab c d Hcd F H H0. elim H0; clear H0; intros f' derF. exists (IntPartIR (F:=(Frestr (F:=PartInt f') (compact_wd _ _ _) H)) (included_refl _ _)). apply Derivative_I_wdr with (PartInt f'). FEQ. simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. exact (included_imp_deriv _ _ _ _ _ _ _ _ H derF). Qed. (** A function differentiable in an interval is everywhere defined in that interval. *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Lemma diffble_imp_inc : forall F, Diffble_I Hab' F -> included I (Dom F). Proof. intros F H. inversion_clear H. unfold I, Hab in |- *; Included. Qed. (** If a function has a derivative in an interval then it is differentiable in that interval. *) Lemma deriv_imp_Diffble_I : forall F F', Derivative_I Hab' F F' -> Diffble_I Hab' F. Proof. intros F F' H. exists (IntPartIR (derivative_imp_inc' _ _ _ _ _ H)). apply Derivative_I_wdr with F'. apply int_part_int. assumption. Qed. End Local_Properties. #[global] Hint Resolve diffble_imp_inc: included. Section Operations. (** All the algebraic results carry on. *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Section Constants. Lemma Diffble_I_const : forall c : IR, Diffble_I Hab' [-C-]c. Proof. intros. exists (IConst (Hab:=Hab) [0]). apply Derivative_I_wdr with ( [-C-][0]:PartIR). apply part_int_const. Deriv. Qed. Lemma Diffble_I_id : Diffble_I Hab' FId. Proof. exists (IConst (Hab:=Hab) [1]). apply Derivative_I_wdr with ( [-C-][1]:PartIR). apply part_int_const. Deriv. Qed. Lemma Diffble_I_poly : forall p, Diffble_I Hab' (FPoly _ p). Proof. intros p. exists (@IntPartIR (FPoly _ (_D_ p)) _ _ Hab (included_IR _)). apply Derivative_I_wdr with (FPoly _ (_D_ p)). apply int_part_int. Deriv. Qed. End Constants. Section Well_Definedness. Variables F H : PartIR. Hypothesis diffF : Diffble_I Hab' F. Lemma Diffble_I_wd : Feq (Compact Hab) F H -> Diffble_I Hab' H. Proof. intro H0. exists (ProjT1 diffF). eapply Derivative_I_wdl. apply H0. apply projT2. Qed. End Well_Definedness. Variables F G : PartIR. Hypothesis diffF : Diffble_I Hab' F. Hypothesis diffG : Diffble_I Hab' G. Lemma Diffble_I_plus : Diffble_I Hab' (F{+}G). Proof. elim diffF; intros F' derF. elim diffG; intros G' derG. exists (IPlus F' G'). eapply Derivative_I_wdr. apply part_int_plus with (F := PartInt F') (G := PartInt G'). apply Feq_reflexive; Included. apply Feq_reflexive; Included. Deriv. Qed. Lemma Diffble_I_inv : Diffble_I Hab' {--}F. Proof. elim diffF; intros F' derF. exists (IInv F'). eapply Derivative_I_wdr. apply part_int_inv with (F := PartInt F'). apply Feq_reflexive; Included. Deriv. Qed. Lemma Diffble_I_mult : Diffble_I Hab' (F{*}G). Proof. elim diffF; intros F' derF. elim diffG; intros G' derG. exists (IPlus (IMult (IntPartIR (diffble_imp_inc _ _ _ _ diffF)) G') (IMult F' (IntPartIR (diffble_imp_inc _ _ _ _ diffG)))). eapply Derivative_I_wdr. apply part_int_plus with (F := PartInt (IMult (IntPartIR (diffble_imp_inc _ _ _ _ diffF)) G')) (G := PartInt (IMult F' (IntPartIR (diffble_imp_inc _ _ _ _ diffG)))). apply Feq_reflexive; Included. apply Feq_reflexive; Included. eapply Derivative_I_wdr. apply Feq_plus with (F := F{*}PartInt G') (G := PartInt F'{*}G). apply part_int_mult. FEQ. apply Feq_reflexive; Included. apply part_int_mult. apply Feq_reflexive; Included. FEQ. Deriv. Qed. (* begin show *) Hypothesis Gbnd : bnd_away_zero I G. (* end show *) Lemma Diffble_I_recip : Diffble_I Hab' {1/}G. Proof. elim diffG; intros G' derG. cut (included I (Dom G)); [ intro Hg' | unfold I, Hab in |- *; Included ]. unfold I in Hg'; cut (forall x : subset I, IMult (IntPartIR Hg') (IntPartIR Hg') x [#] [0]). intro H. exists (IInv (IDiv G' _ H)). eapply Derivative_I_wdr. apply part_int_inv with (F := PartInt (IDiv G' _ H)). apply Feq_reflexive; Included. eapply Derivative_I_wdr. apply Feq_inv with (F := PartInt G'{/}PartInt (IMult (IntPartIR Hg') (IntPartIR Hg'))). apply part_int_div. apply Feq_reflexive; Included. apply Feq_reflexive; simpl in |- *; Included. red in |- *; intros. split. simpl in |- *; Included. elim Gbnd; intros Hinc c. elim c; clear c; intros c H0 H1. exists (c[*]c). apply mult_resp_pos; assumption. intros. simpl in |- *. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; auto; apply less_leEq; assumption. eapply Derivative_I_wdr. apply Feq_inv with (F := PartInt G'{/}G{*}G). apply Feq_div. Included. apply Feq_reflexive; Included. apply part_int_mult. FEQ. FEQ. Deriv. intro x. simpl in |- *. apply mult_resp_ap_zero; apply bnd_imp_ap_zero with I; auto; apply scs_prf. Qed. End Operations. Section Corollaries. Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Variables F G : PartIR. Hypothesis diffF : Diffble_I Hab' F. Hypothesis diffG : Diffble_I Hab' G. Lemma Diffble_I_minus : Diffble_I Hab' (F{-}G). Proof. apply Diffble_I_wd with (F{+}{--}G). apply Diffble_I_plus. assumption. apply Diffble_I_inv; assumption. FEQ. Qed. Lemma Diffble_I_scal : forall c : IR, Diffble_I Hab' (c{**}F). Proof. intro. unfold Fscalmult in |- *. apply Diffble_I_mult. apply Diffble_I_const. assumption. Qed. Lemma Diffble_I_nth : forall n : nat, Diffble_I Hab' (F{^}n). Proof. intro. induction n as [| n Hrecn]. eapply Diffble_I_wd. 2: apply FNth_zero'; Included. apply Diffble_I_const. eapply Diffble_I_wd. 2: apply FNth_mult'; Included. apply Diffble_I_mult; assumption. Qed. Hypothesis Gbnd : bnd_away_zero I G. Lemma Diffble_I_div : Diffble_I Hab' (F{/}G). Proof. apply Diffble_I_wd with (F{*}{1/}G). apply Diffble_I_mult. assumption. apply Diffble_I_recip; assumption. FEQ. Qed. End Corollaries. Section Other_Properties. (** Differentiability of families of functions is proved by induction using the constant and addition rules. *) Variables a b : IR. Hypothesis Hab' : a [<] b. Lemma Diffble_I_Sum0 : forall (f : nat -> PartIR), (forall n, Diffble_I Hab' (f n)) -> forall n, Diffble_I Hab' (FSum0 n f). Proof. intros f diffF. induction n as [| n Hrecn]. apply Diffble_I_wd with (Fconst (S:=IR) [0]). apply Diffble_I_const. FEQ. red in |- *; simpl in |- *; intros. apply (diffble_imp_inc _ _ _ _ (diffF n)); assumption. apply Diffble_I_wd with (FSum0 n f{+}f n). apply Diffble_I_plus. auto. auto. FEQ. simpl in |- *; red in |- *; intros. apply (diffble_imp_inc _ _ _ _ (diffF n0)); assumption. simpl in |- *. apply bin_op_wd_unfolded; try apply Sum0_wd; intros; rational. Qed. Lemma Diffble_I_Sumx : forall n (f : forall i, i < n -> PartIR), (forall i Hi, Diffble_I Hab' (f i Hi)) -> Diffble_I Hab' (FSumx n f). Proof. intro; induction n as [| n Hrecn]; intros. simpl in |- *; apply Diffble_I_const. simpl in |- *. apply Diffble_I_plus; auto. Qed. Lemma Diffble_I_Sum : forall (f : nat -> PartIR), (forall n, Diffble_I Hab' (f n)) -> forall m n, Diffble_I Hab' (FSum m n f). Proof. intros. eapply Diffble_I_wd. 2: apply Feq_symmetric; apply FSum_FSum0'; Included. apply Diffble_I_minus; apply Diffble_I_Sum0; auto. Qed. End Other_Properties. (** Finally, a differentiable function is continuous. %\begin{convention}% Let [F] be a partial function with derivative [F'] on [I]. %\end{convention}% *) Lemma diffble_imp_contin_I : forall a b (Hab' : a [<] b) (Hab : a [<=] b) F, Diffble_I Hab' F -> Continuous_I Hab F. Proof. intros a b Hab' Hab F H. apply deriv_imp_contin_I with Hab' (PartInt (ProjT1 H)). apply projT2. Qed. #[global] Hint Immediate included_imp_contin deriv_imp_contin_I deriv_imp_contin'_I diffble_imp_contin_I: continuous. #[global] Hint Immediate included_imp_deriv: derivate. corn-8.20.0/ftc/FTC.v000066400000000000000000000511151473720167500141400ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [-S-] %\ensuremath{\int}% #∫# *) Require Export CoRN.ftc.MoreIntegrals. Require Export CoRN.ftc.CalculusTheorems. Opaque Min. Section Indefinite_Integral. (** * The Fundamental Theorem of Calculus Finally we can prove the fundamental theorem of calculus and its most important corollaries, which are the main tools to formalize most of real analysis. ** Indefinite Integrals We define the indefinite integral of a function in a proper interval in the obvious way; we just need to state a first lemma so that the continuity proofs become unnecessary. %\begin{convention}% Let [I : interval], [F : PartIR] be continuous in [I] and [a] be a point in [I]. %\end{convention}% *) Variable I : interval. Variable F : PartIR. Hypothesis contF : Continuous I F. Variable a : IR. Hypothesis Ha : I a. Lemma prim_lemma : forall x : IR, I x -> Continuous_I (Min_leEq_Max a x) F. Proof. intros. elim contF; intros incI contI. Included. Qed. Lemma Fprim_strext : forall x y Hx Hy, Integral (prim_lemma x Hx) [#] Integral (prim_lemma y Hy) -> x [#] y. Proof. intros x y Hx Hy H. elim (Integral_strext' _ _ _ _ _ _ _ _ _ H). intro; exfalso. generalize a0; apply ap_irreflexive_unfolded. auto. Qed. Definition Fprim : PartIR. apply Build_PartFunct with (pfpfun := fun (x : IR) (Hx : I x) => Integral (prim_lemma x Hx)). Proof. apply iprop_wd. exact Fprim_strext. Defined. End Indefinite_Integral. Arguments Fprim [I F]. Notation "[-S-] F" := (Fprim F) (at level 20). Section FTC. (** ** The FTC We can now prove our main theorem. We begin by remarking that the primitive function is always continuous. %\begin{convention}% Assume that [J : interval], [F : PartIR] is continuous in [J] and [x0] is a point in [J]. Denote by [G] the indefinite integral of [F] from [x0]. %\end{convention}% *) Variable J : interval. Variable F : PartIR. Hypothesis contF : Continuous J F. Variable x0 : IR. Hypothesis Hx0 : J x0. (* begin hide *) Let G := ( [-S-]contF) x0 Hx0. (* end hide *) Lemma Continuous_prim : Continuous J G. Proof. split. Included. intros a b Hab H. split. Included. intros e H0. simpl in |- *; simpl in H. exists (e[/] _[//] max_one_ap_zero (Norm_Funct (included_imp_Continuous _ _ contF _ _ _ H))). apply div_resp_pos. apply pos_max_one. assumption. intros x y H1 H2 Hx Hy H3. cut (included (Compact (Min_leEq_Max y x)) (Compact Hab)). intro Hinc. cut (Continuous_I (Min_leEq_Max y x) F). intro H4. apply leEq_wdl with (AbsIR (Integral H4)). eapply leEq_transitive. apply Integral_leEq_norm. apply leEq_transitive with (Max (Norm_Funct (included_imp_Continuous _ _ contF _ _ _ H)) [1][*] AbsIR (x[-]y)). apply mult_resp_leEq_rht. apply leEq_transitive with (Norm_Funct (included_imp_Continuous _ _ contF _ _ _ H)). apply leEq_Norm_Funct. intros. apply norm_bnd_AbsIR. apply Hinc; auto. apply lft_leEq_Max. apply AbsIR_nonneg. eapply shift_mult_leEq'. apply pos_max_one. apply H3. apply AbsIR_wd. rstepl (Integral (prim_lemma J F contF x0 Hx0 y Hy) [+]Integral H4[-] Integral (prim_lemma J F contF x0 Hx0 y Hy)). apply cg_minus_wd. apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 x0 x y). apply included_imp_Continuous with J; auto. apply included3_interval; auto. apply Integral_wd. apply Feq_reflexive. apply (included_trans _ (Compact (Min_leEq_Max x0 y)) J); Included. apply included_imp_Continuous with J; auto. Included. Included. Qed. (** The derivative of [G] is simply [F]. *) Hypothesis pJ : proper J. Theorem FTC1 : Derivative J pJ G F. Proof. split; Included. split; Included. intros; apply Derivative_I_char. Included. inversion_clear contF. Included. intros. red in contF. inversion_clear contF. elim (contin_prop _ _ _ _ (X2 _ _ _ X) e X0); intros d H3 H4. exists d. assumption. intros x y X3 X4 Hx Hy Hx' H. simpl in |- *. rename Hab into Hab'. set (Hab := less_leEq _ _ _ Hab') in *. cut (included (Compact (Min_leEq_Max x y)) (Compact Hab)). intro Hinc. cut (Continuous_I (Min_leEq_Max x y) F). 2: apply included_imp_Continuous with J; auto. intro H8. apply leEq_wdl with (AbsIR (Integral H8[-] Integral (Continuous_I_const _ _ (Min_leEq_Max x y) (F x Hx')))). apply leEq_wdl with (AbsIR (Integral (Continuous_I_minus _ _ _ _ _ H8 (Continuous_I_const _ _ _ (F x Hx'))))). eapply leEq_transitive. apply Integral_leEq_norm. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. apply leEq_Norm_Funct. intros z Hz Hz1. simpl in |- *. apply leEq_wdl with (AbsIR (F z (X1 z (X z (Hinc z Hz))) [-]F x Hx')). 2: apply AbsIR_wd; algebra. apply H4; auto. eapply leEq_transitive. 2: apply H. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply Abs_Max. eapply leEq_wdr. 2: apply AbsIR_eq_x; apply shift_leEq_minus. 2: astepl (Min x y); apply Min_leEq_Max. apply compact_elements with (Min_leEq_Max x y); auto. apply compact_Min_lft. apply AbsIR_wd; apply Integral_minus. apply AbsIR_wd; apply cg_minus_wd. rstepl (Integral (prim_lemma _ _ contF x0 Hx0 _ Hx) [+]Integral H8[-] Integral (prim_lemma _ _ contF x0 Hx0 _ Hx)). apply cg_minus_wd. apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 x0 y x). apply included_imp_Continuous with J; auto. apply included3_interval; auto. apply Integral_wd. apply Feq_reflexive. apply (included_trans _ (Compact (Min_leEq_Max x0 x)) J); try apply included_interval; auto. apply Integral_const. Included. Included. Qed. (** Any other function [G0] with derivative [F] must differ from [G] by a constant. *) Variable G0 : PartIR. Hypothesis derG0 : Derivative J pJ G0 F. Theorem FTC2 : {c : IR | Feq J (G{-}G0) [-C-]c}. Proof. apply FConst_prop with pJ. apply Derivative_wdr with (F{-}F). FEQ. apply Derivative_minus; auto. apply FTC1. Qed. (** The following is another statement of the Fundamental Theorem of Calculus, also known as Barrow's rule. *) (* begin hide *) Let G0_inc := Derivative_imp_inc _ _ _ _ derG0. (* end hide *) End FTC. Theorem Barrow : forall J F (contF : Continuous J F) (pJ:proper J) G0 (derG0 : Derivative J pJ G0 F) a b (H : Continuous_I (Min_leEq_Max a b) F) Ha Hb, let Ha' := Derivative_imp_inc _ _ _ _ derG0 a Ha in let Hb' := Derivative_imp_inc _ _ _ _ derG0 b Hb in Integral H [=] G0 b Hb'[-]G0 a Ha'. Proof. (* begin hide *) intros J F contF pJ G0 derG0 a b H1 Ha Hb; intros. pose (x0:=a). pose (Hx0:=Ha). set (G := ( [-S-]contF) x0 Hx0). elim (@FTC2 J F contF x0 Hx0 pJ G0 derG0); intros c Hc. elim Hc; intros H2 H. elim H; clear H Hc; intros H3 H0. (* Allow G0a to be G0 of a. Allow G0b to be G0 of b. *) set (G0a := G0 a Ha') in *. set (G0b := G0 b Hb') in *. rstepr (G0b[+]c[-] (G0a[+]c)). (* Allow Ga to be G of a. Allow Gb to be G of b.*) set (Ga := G a Ha) in *. set (Gb := G b Hb) in *. apply eq_transitive_unfolded with (Gb[-]Ga). unfold Ga, Gb, G in |- *; simpl in |- *. cut (forall x y z : IR, z [=] x[+]y -> y [=] z[-]x). intro H5. apply H5. apply Integral_plus_Integral with (Min3_leEq_Max3 x0 b a). apply included_imp_Continuous with J. auto. apply included3_interval; auto. intros; apply eq_symmetric_unfolded. rstepr (x[+]y[-]x); algebra. cut (forall x y z : IR, x[-]y [=] z -> x [=] y[+]z); intros. fold G in H0. apply cg_minus_wd; unfold Ga, Gb, G0a, G0b in |- *; apply H; auto. simpl in H0. apply eq_transitive_unfolded with ((G{-}G0) b (Hb, Hb')). 2: apply H0 with (Hx := (Hb, Hb')). simpl. apply cg_minus_wd. apply Integral_wd. apply Feq_reflexive. destruct H1 as [H1 _]. apply H1. algebra. auto. auto. change c with ([-C-]c a I). apply eq_transitive_unfolded with ((G{-}G0) a (Ha, Ha')). 2: apply H0 with (Hx := (Ha, Ha')). simpl. apply cg_minus_wd. apply Integral_wd. apply Feq_reflexive. destruct H1 as [H1 _]. intros y Hy. apply H1. apply (compact_wd _ _ (Min_leEq_Max a b) a). apply compact_Min_lft. unfold compact, x0 in Hy. destruct Hy. apply leEq_imp_eq. astepl (Min a a). assumption. apply Min_id. stepr(Max a a). assumption. apply Max_id. algebra. auto. rstepl (y[+] (x[-]y)). algebra. Qed. (* end hide *) #[global] Hint Resolve Continuous_prim: continuous. #[global] Hint Resolve FTC1: derivate. Section Limit_of_Integral_Seq. (** ** Corollaries With these tools in our hand, we can prove several useful results. %\begin{convention}% From this point onwards: - [J : interval]; - [f : nat->PartIR] is a sequence of continuous functions (in [J]); - [F : PartIR] is continuous in [J]. %\end{convention}% In the first place, if a sequence of continuous functions converges then the sequence of their primitives also converges, and the limit commutes with the indefinite integral. *) Variable J : interval. Variable f : nat -> PartIR. Variable F : PartIR. Hypothesis contf : forall n : nat, Continuous J (f n). Hypothesis contF : Continuous J F. Section Compact. (** We need to prove this result first for compact intervals. %\begin{convention}% Assume that [a, b, x0 : IR] with [(f n)] and [F] continuous in [[a,b]], $x0\in[a,b]$#x0∈[a,b]#; denote by [(g n)] and [G] the indefinite integrals respectively of [(f n)] and [F] with origin [x0]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. Hypothesis contIf : forall n : nat, Continuous_I Hab (f n). Hypothesis contIF : Continuous_I Hab F. (* begin show *) Hypothesis convF : conv_fun_seq' a b Hab f F contIf contIF. (* end show *) Variable x0 : IR. Hypothesis Hx0 : J x0. Hypothesis Hx0' : Compact Hab x0. (* begin hide *) Let g (n : nat) := ( [-S-]contf n) x0 Hx0. Let G := ( [-S-]contF) x0 Hx0. (* end hide *) (* begin show *) Hypothesis contg : forall n : nat, Continuous_I Hab (g n). Hypothesis contG : Continuous_I Hab G. (* end show *) Lemma fun_lim_seq_integral : conv_fun_seq' a b Hab g G contg contG. Proof. assert (H : conv_norm_fun_seq _ _ _ _ _ contIf contIF). apply conv_fun_seq'_norm; assumption. intros e H0. elim (Archimedes (AbsIR (b[-]a) [/] _[//]pos_ap_zero _ _ H0)); intros k Hk. elim (H k); intros N HN. exists N; intros. assert (H2 : included (Compact (Min_leEq_Max x0 x)) (Compact Hab)). apply included2_compact; auto. simpl in |- *. apply leEq_wdl with (AbsIR (Integral (Continuous_I_minus _ _ _ _ _ (prim_lemma _ _ (contf n) x0 Hx0 _ (contin_imp_inc _ _ _ _ (contg n) _ Hx)) (prim_lemma _ _ contF x0 Hx0 _ (contin_imp_inc _ _ _ _ contG _ Hx))))). 2: apply AbsIR_wd; apply Integral_minus. eapply leEq_transitive. apply Integral_leEq_norm. apply leEq_transitive with (one_div_succ k[*]AbsIR (b[-]a)). apply mult_resp_leEq_both. apply positive_norm. apply AbsIR_nonneg. eapply leEq_transitive. 2: apply (HN n H1). apply leEq_Norm_Funct; intros. apply norm_bnd_AbsIR. apply H2; auto. apply compact_elements with Hab; auto. unfold one_div_succ, Snring in |- *. rstepl (AbsIR (b[-]a) [/] _[//]nring_ap_zero _ _ (sym_not_eq (O_S k))). apply shift_div_leEq. apply pos_nring_S. eapply shift_leEq_mult'. assumption. apply less_leEq; eapply leEq_less_trans. apply Hk. simpl in |- *. apply less_plusOne. Qed. End Compact. (** And now we can generalize it step by step. *) Lemma limit_of_integral : conv_fun_seq'_IR J f F contf contF -> forall x y Hxy, included (Compact Hxy) J -> forall Hf HF, Cauchy_Lim_prop2 (fun n => integral x y Hxy (f n) (Hf n)) (integral x y Hxy F HF). Proof. intros H x y Hxy H0 Hf HF. assert (Hx : J x). apply H0; apply compact_inc_lft. assert (Hy : J y). apply H0; apply compact_inc_rht. set (g := fun n : nat => ( [-S-]contf n) x Hx) in *. set (G := ( [-S-]contF) x Hx) in *. set (Hxg := fun n : nat => Hy) in *. apply Lim_wd with (Part G y Hy). simpl in |- *; apply Integral_integral. apply Cauchy_Lim_prop2_wd with (fun n : nat => Part (g n) y (Hxg n)). 2: intro; simpl in |- *; apply Integral_integral. cut (forall n : nat, Continuous_I Hxy (g n)). intro H1. cut (Continuous_I Hxy G). intro H2. apply fun_conv_imp_seq_conv with (contf := H1) (contF := H2). set (H4 := fun n : nat => included_imp_Continuous _ _ (contf n) _ _ _ H0) in *. set (H5 := included_imp_Continuous _ _ contF _ _ _ H0) in *. unfold g, G in |- *. apply fun_lim_seq_integral with H4 H5. unfold H4, H5 in |- *. apply H; auto. apply compact_inc_lft. apply compact_inc_rht. unfold G in |- *; apply included_imp_Continuous with J; Contin. intro; unfold g in |- *; apply included_imp_Continuous with J; Contin. Qed. Lemma limit_of_Integral : conv_fun_seq'_IR J f F contf contF -> forall x y, included (Compact (Min_leEq_Max x y)) J -> forall Hxy Hf HF, Cauchy_Lim_prop2 (fun n => Integral (a:=x) (b:=y) (Hab:=Hxy) (F:=f n) (Hf n)) (Integral (Hab:=Hxy) (F:=F) HF). Proof. intros convF x y H. set (x0 := Min x y) in *. intros. assert (Hx0 : J x0). apply H; apply compact_inc_lft. assert (Hx0' : Compact Hxy x0). apply compact_inc_lft. set (g := fun n : nat => ( [-S-]contf n) x0 Hx0) in *. set (G := ( [-S-]contF) x0 Hx0) in *. unfold Integral in |- *; fold x0 in |- *. apply (Cauchy_Lim_minus (fun n : nat => integral _ _ _ _ (Integral_inc2 _ _ _ _ (Hf n))) (fun n : nat => integral _ _ _ _ (Integral_inc1 _ _ _ _ (Hf n)))); fold x0 in |- *. apply limit_of_integral with (Hf := fun n : nat => Integral_inc2 _ _ Hxy _ (Hf n)); auto. apply included_trans with (Compact (Min_leEq_Max x y)); Included. apply included_compact. apply compact_inc_lft. apply compact_Min_rht. apply limit_of_integral with (Hf := fun n : nat => Integral_inc1 _ _ Hxy _ (Hf n)); auto. apply included_trans with (Compact (Min_leEq_Max x y)); auto. apply included_compact. apply compact_inc_lft. apply compact_Min_lft. Qed. Section General. (** Finally, with [x0, g, G] as before, *) (* begin show *) Hypothesis convF : conv_fun_seq'_IR J f F contf contF. (* end show *) Variable x0 : IR. Hypothesis Hx0 : J x0. (* begin hide *) Let g (n : nat) := ( [-S-]contf n) x0 Hx0. Let G := ( [-S-]contF) x0 Hx0. (* end hide *) Hypothesis contg : forall n : nat, Continuous J (g n). Hypothesis contG : Continuous J G. Lemma fun_lim_seq_integral_IR : conv_fun_seq'_IR J g G contg contG. Proof. red in |- *; intros. unfold g, G in |- *. cut (J a). intro H. set (h := fun n : nat => [-C-] (Integral (prim_lemma _ _ (contf n) x0 Hx0 a H))) in *. set (g' := fun n : nat => h n{+} ( [-S-]contf n) a H) in *. set (G' := [-C-] (Integral (prim_lemma _ _ contF x0 Hx0 a H)) {+} ( [-S-]contF) a H) in *. assert (H0 : forall n : nat, Continuous_I Hab (h n)). intro; unfold h in |- *; Contin. cut (forall n : nat, Continuous_I Hab (( [-S-]contf n) a H)). intro H1. assert (H2 : forall n : nat, Continuous_I Hab (g' n)). intro; unfold g' in |- *; Contin. cut (Continuous_I Hab (( [-S-]contF) a H)). intro H3. assert (H4 : Continuous_I Hab G'). unfold G' in |- *; Contin. apply conv_fun_seq'_wdl with g' H2 (included_imp_Continuous _ _ contG _ _ _ Hinc). intro; FEQ. simpl in |- *. apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 x0 x a). apply included_imp_Continuous with J; Contin. apply conv_fun_seq'_wdr with H2 G' H4. FEQ. simpl in |- *. apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 x0 x a). apply included_imp_Continuous with J; Contin. unfold g', G' in |- *. apply conv_fun_seq'_wdl with (f := g') (contf := fun n : nat => Continuous_I_plus _ _ _ _ _ (H0 n) (H1 n)) (contF := H4). unfold g' in H2. intro; apply Feq_reflexive; Included. unfold g', G' in |- *. apply (fun_Lim_seq_plus' _ _ Hab h (fun n : nat => ( [-S-]contf n) a H) H0 H1 _ _ (Continuous_I_const _ _ _ (Integral (prim_lemma _ _ contF x0 Hx0 a H))) H3). unfold h in |- *. apply seq_conv_imp_fun_conv with (x := fun n : nat => Integral (prim_lemma _ _ (contf n) x0 Hx0 a H)). apply limit_of_Integral with (Hf := fun n : nat => prim_lemma _ _ (contf n) x0 Hx0 a H); auto. Included. apply fun_lim_seq_integral with (fun n : nat => included_imp_Continuous _ _ (contf n) _ _ _ Hinc) (included_imp_Continuous _ _ contF _ _ _ Hinc). apply convF; auto. apply compact_inc_lft. apply included_imp_Continuous with J; Contin. intro; apply included_imp_Continuous with J; Contin. apply Hinc; apply compact_inc_lft. Qed. End General. End Limit_of_Integral_Seq. Section Limit_of_Derivative_Seq. (** Similar results hold for the sequence of derivatives of a converging sequence; this time the proof is easier, as we can do it directly for any kind of interval. %\begin{convention}% Let [g] be the sequence of derivatives of [f] and [G] be the derivative of [F]. %\end{convention}% *) Variable J : interval. Hypothesis pJ : proper J. Variables f g : nat -> PartIR. Variables F G : PartIR. Hypothesis contf : forall n : nat, Continuous J (f n). Hypothesis contF : Continuous J F. Hypothesis convF : conv_fun_seq'_IR J f F contf contF. Hypothesis contg : forall n : nat, Continuous J (g n). Hypothesis contG : Continuous J G. Hypothesis convG : conv_fun_seq'_IR J g G contg contG. Hypothesis derf : forall n : nat, Derivative J pJ (f n) (g n). Lemma fun_lim_seq_derivative : Derivative J pJ F G. Proof. elim (nonvoid_point _ (proper_nonvoid _ pJ)); intros a Ha. set (h := fun n : nat => ( [-S-]contg n) a Ha) in *. set (H := ( [-S-]contG) a Ha) in *. assert (H0 : Derivative J pJ H G). unfold H in |- *; apply FTC1. assert (H1 : forall n : nat, Derivative J pJ (h n) (g n)). intro; unfold h in |- *; apply FTC1. assert (H2 : conv_fun_seq'_IR J _ _ (fun n : nat => Derivative_imp_Continuous _ _ _ _ (H1 n)) (Derivative_imp_Continuous _ _ _ _ H0)). unfold h, H in |- *. eapply fun_lim_seq_integral_IR with (contf := contg); auto. cut {c : IR | Feq J (F{-}H) [-C-]c}. intro H3. elim H3; clear H3; intros c Hc. apply Derivative_wdl with (H{+} [-C-]c). apply Feq_transitive with (H{+} (F{-}H)). apply Feq_plus. apply Feq_reflexive; Included. apply Feq_symmetric; assumption. clear Hc H2 H1; clearbody H. FEQ. apply Derivative_wdr with (G{+} [-C-][0]). FEQ. apply Derivative_plus; auto. apply Derivative_const. assert (H3 : forall n : nat, {c : IR | Feq J (f n{-}h n) [-C-]c}). intro; apply FConst_prop with pJ. apply Derivative_wdr with (g n{-}g n). FEQ. apply Derivative_minus; auto. assert (contw : forall n : nat, Continuous J (f n{-}h n)). unfold h in |- *; Contin. assert (contW : Continuous J (F{-}H)). unfold H in |- *; Contin. apply fun_const_Lim with (fun n : nat => f n{-}h n) contw contW. auto. eapply fun_Lim_seq_minus'_IR. apply convF. apply H2. assumption. Qed. End Limit_of_Derivative_Seq. Section Derivative_Series. (** As a very important case of this result, we get a rule for deriving series. *) Variable J : interval. Hypothesis pJ : proper J. Variables f g : nat -> PartIR. (* begin show *) Hypothesis convF : fun_series_convergent_IR J f. Hypothesis convG : fun_series_convergent_IR J g. (* end show *) Hypothesis derF : forall n : nat, Derivative J pJ (f n) (g n). Lemma Derivative_FSeries : Derivative J pJ (FSeries_Sum convF) (FSeries_Sum convG). Proof. apply fun_lim_seq_derivative with (f := fun n : nat => FSum0 n f) (contf := Continuous_Sum0 _ _ (convergent_imp_Continuous _ _ convF)) (contF := Continuous_FSeries_Sum _ _ convF) (g := fun n : nat => FSum0 n g) (contg := Continuous_Sum0 _ _ (convergent_imp_Continuous _ _ convG)) (contG := Continuous_FSeries_Sum _ _ convG). 3: Deriv. apply FSeries_conv. apply FSeries_conv. Qed. End Derivative_Series. corn-8.20.0/ftc/FunctSequence.v000066400000000000000000001027541473720167500163020ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Continuity. Require Export CoRN.ftc.PartInterval. Section Definitions. (** * Sequences of Functions In this file we define some more operators on functions, namely sequences and limits. These concepts are defined only for continuous functions. %\begin{convention}% Throughout this section: - [a] and [b] will be real numbers and the interval [[a,b]] will be denoted by [I]; - [f, g] and [h] will denote sequences of continuous functions; - [F, G] and [H] will denote continuous functions. %\end{convention}% ** Definitions A sequence of functions is simply an object of type [nat->PartIR]. However, we will be interested mostly in convergent and Cauchy sequences. Several definitions of these concepts will be formalized; they mirror the several different ways in which a Cauchy sequence can be defined. For a discussion on the different notions of convergent see Bishop 1967. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. Variable F : PartIR. Hypothesis contf : forall n : nat, Continuous_I Hab (f n). Hypothesis contF : Continuous_I Hab F. (* begin hide *) Let incf (n : nat) := contin_imp_inc _ _ _ _ (contf n). Let incF := contin_imp_inc _ _ _ _ contF. (* end hide *) Definition Cauchy_fun_seq := forall e, [0] [<] e -> {N : nat | forall m n, N <= m -> N <= n -> forall x Hx, AbsIR (f m x (incf m x Hx) [-]f n x (incf n x Hx)) [<=] e}. Definition conv_fun_seq' := forall e, [0] [<] e -> {N : nat | forall n, N <= n -> forall x Hx, AbsIR (f n x (incf n x Hx) [-]F x (incF x Hx)) [<=] e}. Definition conv_norm_fun_seq := forall k, {N : nat | forall n, N <= n -> Norm_Funct (Continuous_I_minus _ _ _ _ _ (contf n) contF) [<=] one_div_succ k}. Definition Cauchy_fun_seq1 := forall k, {N : nat | forall m n, N <= m -> N <= n -> Norm_Funct (Continuous_I_minus _ _ _ _ _ (contf m) (contf n)) [<=] one_div_succ k}. Definition Cauchy_fun_seq' := forall k, {N : nat | forall m n, N <= m -> N <= n -> forall x Hx, AbsIR (Part _ _ (incf m x Hx) [-]Part _ _ (incf n x Hx)) [<=] one_div_succ k}. Definition Cauchy_fun_seq2 := forall e, [0] [<] e -> {N : nat | forall m, N <= m -> forall x Hx, AbsIR (Part _ _ (incf m x Hx) [-]Part _ _ (incf N x Hx)) [<=] e}. (** These definitions are all shown to be equivalent. *) Lemma Cauchy_fun_seq_seq' : Cauchy_fun_seq -> Cauchy_fun_seq'. Proof. intro H. red in |- *; red in H. intro. exact (H (one_div_succ k) (one_div_succ_pos _ k)). Qed. Lemma Cauchy_fun_seq'_seq : Cauchy_fun_seq' -> Cauchy_fun_seq. Proof. intro H. red in |- *; red in H. intros e He. elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ He)). intros i Hei. cut ([0] [<] nring (R:=IR) i). intro Hi. elim (H i). intros N HN; exists N. intros. apply leEq_transitive with (one_div_succ (R:=IR) i). apply HN; assumption. unfold one_div_succ in |- *. rstepr ([1][/] _[//]recip_ap_zero _ _ (pos_ap_zero _ _ He)). unfold Snring in |- *. apply recip_resp_leEq. apply recip_resp_pos; assumption. apply less_leEq; apply leEq_less_trans with (nring (R:=IR) i). assumption. simpl in |- *; apply less_plusOne. apply less_leEq_trans with ([1][/] e[//]pos_ap_zero _ _ He). apply recip_resp_pos; assumption. assumption. Qed. Lemma conv_Cauchy_fun_seq' : conv_fun_seq' -> Cauchy_fun_seq. Proof. intro H. red in |- *; red in H. intros e He. elim (H _ (pos_div_two _ _ He)). intros N HN. exists N; intros. apply leEq_wdl with (AbsIR (f m x (incf m x Hx) [-]F x (incF x Hx) [+] (F x (incF x Hx) [-]f n x (incf n x Hx)))). 2: apply AbsIR_wd; rational. eapply leEq_transitive. apply triangle_IR. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). apply plus_resp_leEq_both. apply HN; assumption. eapply leEq_wdl. 2: apply AbsIR_minus. apply HN; assumption. Qed. Lemma Cauchy_fun_seq_seq2 : Cauchy_fun_seq -> Cauchy_fun_seq2. Proof. intro H. red in |- *; red in H. intros e H0. elim (H e H0); intros N HN; exists N. intros; apply HN; auto with arith. Qed. Lemma Cauchy_fun_seq2_seq : Cauchy_fun_seq2 -> Cauchy_fun_seq. Proof. intro H. red in |- *; red in H. intros e H0. elim (H _ (pos_div_two _ _ H0)); intros N HN; exists N; intros. apply leEq_wdl with (AbsIR (Part _ _ (incf m x Hx) [-]Part _ _ (incf N x Hx) [-] (Part _ _ (incf n x Hx) [-]Part _ _ (incf N x Hx)))). 2: apply AbsIR_wd; rational. eapply leEq_transitive. apply triangle_IR_minus. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). apply plus_resp_leEq_both; apply HN; auto with arith. Qed. Lemma conv_fun_seq'_norm : conv_fun_seq' -> conv_norm_fun_seq. Proof. intro H. red in |- *; red in H. intro. elim (H (one_div_succ k) (one_div_succ_pos _ k)). intros N HN. exists N. intros. apply leEq_Norm_Funct. fold I in |- *; intros x H1 Hx. eapply leEq_wdl. apply (HN n H0 x H1). apply AbsIR_wd; simpl in |- *; rational. Qed. Lemma conv_fun_norm_seq : conv_norm_fun_seq -> conv_fun_seq'. Proof. intro H. red in |- *; red in H. intros e He. elim (Archimedes ([1][/] _[//]pos_ap_zero _ _ He)). intros k Hk. elim (H k); clear H. intros N HN. exists N. intros. cut (Dom (f n{-}F) x). intro H0. apply leEq_wdl with (AbsIR ((f n{-}F) x H0)). eapply leEq_transitive. 2: apply leEq_transitive with (one_div_succ (R:=IR) k). 2: apply HN with (n := n); assumption. apply norm_bnd_AbsIR; assumption. unfold one_div_succ in |- *. unfold Snring in |- *. apply less_leEq; apply swap_div with (pos_ap_zero _ _ He). apply pos_nring_S. assumption. eapply leEq_less_trans. apply Hk. simpl in |- *; apply less_plusOne. apply AbsIR_wd; simpl in |- *; rational. split. apply incf; assumption. apply incF; assumption. Qed. Lemma Cauchy_fun_seq1_seq' : Cauchy_fun_seq1 -> Cauchy_fun_seq'. Proof. intro H. red in |- *; red in H. intro. elim (H k); clear H; intros N HN. exists N; intros. eapply leEq_transitive. 2: apply HN with (m := m) (n := n); assumption. cut (Dom (f m{-}f n) x). intro H1. apply leEq_wdl with (AbsIR (Part _ _ H1)). apply norm_bnd_AbsIR; assumption. apply AbsIR_wd; simpl in |- *; rational. split; simpl in |- *; apply incf; assumption. Qed. Lemma Cauchy_fun_seq'_seq1 : Cauchy_fun_seq' -> Cauchy_fun_seq1. Proof. intro H. red in |- *; red in H. intro. elim (H k); clear H; intros N HN. exists N; intros. apply leEq_Norm_Funct. intros x H1 Hx. eapply leEq_wdl. apply (HN m n H H0 x H1). apply AbsIR_wd; simpl in |- *; rational. Qed. Lemma Cauchy_fun_seq_seq1 : Cauchy_fun_seq -> Cauchy_fun_seq1. Proof. intro. apply Cauchy_fun_seq'_seq1. apply Cauchy_fun_seq_seq'. assumption. Qed. Lemma Cauchy_fun_seq1_seq : Cauchy_fun_seq1 -> Cauchy_fun_seq. Proof. intro. apply Cauchy_fun_seq'_seq. apply Cauchy_fun_seq1_seq'. assumption. Qed. (** A Cauchy sequence of functions is pointwise a Cauchy sequence. *) Lemma Cauchy_fun_real : Cauchy_fun_seq -> forall x Hx, Cauchy_prop (fun n => Part _ _ (incf n x Hx)). Proof. intros H x Hx. red in |- *; red in H. intros e He. elim (H _ He); clear H; intros N HN. exists N. intros. apply AbsIR_imp_AbsSmall. apply HN. assumption. apply le_n. Qed. End Definitions. Section More_Definitions. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. Hypothesis contf : forall n : nat, Continuous_I Hab (f n). (** We can also say that [f] is simply convergent if it converges to some continuous function. Notice that we do not quantify directly over partial functions, for reasons which were already explained. *) Definition conv_fun_seq := {f' : CSetoid_fun (subset (Compact Hab)) IR | {contf' : Continuous_I Hab (PartInt f') | conv_fun_seq' a b Hab f (PartInt f') contf contf'}}. (** It is useful to extract the limit as a partial function: *) (* begin show *) Hypothesis H : Cauchy_fun_seq _ _ _ f contf. (* end show *) Definition Cauchy_fun_seq_Lim : PartIR. Proof. apply Build_PartFunct with (pfpfun := fun x Hx => Lim (Build_CauchySeq _ (fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contf n) x Hx)) (Cauchy_fun_real _ _ _ _ contf H x Hx))). unfold I in |- *; apply compact_wd. intros x y Hx Hy H0. elim (Lim_strext _ _ H0). intros n Hn. simpl in Hn. exact (pfstrx _ _ _ _ _ _ Hn). Defined. End More_Definitions. Section Irrelevance_of_Proofs. (** ** Irrelevance of Proofs This section contains a number of technical results stating mainly that being a Cauchy sequence or converging to some limit is a property of the sequence itself and independent of the proofs we supply of its continuity or the continuity of its limit. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. (* begin show *) Hypotheses contf contf0 : forall n : nat, Continuous_I Hab (f n). (* end show *) Variable F : PartIR. (* begin show *) Hypotheses contF contF0 : Continuous_I Hab F. (* end show *) Lemma conv_fun_seq'_wd : conv_fun_seq' _ _ _ _ _ contf contF -> conv_fun_seq' _ _ _ _ _ contf0 contF0. Proof. intros H e H0. elim (H e H0); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H1 x Hx). apply AbsIR_wd; rational. Qed. Lemma Cauchy_fun_seq'_wd : Cauchy_fun_seq' _ _ _ _ contf -> Cauchy_fun_seq' _ _ _ _ contf0. Proof. intros H k. elim (H k); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN m n H0 H1 x Hx). apply AbsIR_wd; rational. Qed. Lemma Cauchy_fun_seq2_wd : Cauchy_fun_seq2 _ _ _ _ contf -> Cauchy_fun_seq2 _ _ _ _ contf0. Proof. intros H e H0. elim (H e H0); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN m H1 x Hx). apply AbsIR_wd; rational. Qed. Lemma conv_norm_fun_seq_wd : conv_norm_fun_seq _ _ _ _ _ contf contF -> conv_norm_fun_seq _ _ _ _ _ contf0 contF0. Proof. intros H k. elim (H k); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H0). apply Norm_Funct_wd. apply Feq_reflexive; Included. Qed. Lemma Cauchy_fun_seq1_wd : Cauchy_fun_seq1 _ _ _ _ contf -> Cauchy_fun_seq1 _ _ _ _ contf0. Proof. intros H k. elim (H k); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN m n H0 H1). apply Norm_Funct_wd. apply Feq_reflexive; Included. Qed. End Irrelevance_of_Proofs. Section More_Proof_Irrelevance. Lemma conv_fun_seq_wd : forall a b Hab f contf contf0, conv_fun_seq a b Hab f contf -> conv_fun_seq a b Hab f contf0. Proof. intros a b Hab f contf contf0 H. elim H; intros f' Hf'. exists f'. elim Hf'; intros contf' H0. exists contf'. eapply conv_fun_seq'_wd. apply H0. Qed. End More_Proof_Irrelevance. Section More_Properties. (** ** Other Properties Still more technical details---a convergent sequence converges to its limit; the limit is a continuous function; and convergence is well defined with respect to functional equality in the interval [[a,b]]. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables f g : nat -> PartIR. (* begin show *) Hypotheses contf contf0 : forall n, Continuous_I Hab (f n). Hypotheses contg contg0 : forall n, Continuous_I Hab (g n). (* end show *) Lemma Cauchy_conv_fun_seq' : forall H contf', conv_fun_seq' _ _ _ _ (Cauchy_fun_seq_Lim _ _ _ f contf H) contf contf'. Proof. intros H contf' e H0. elim (H e H0). intros N HN. exists N. intros. set (incf := fun n : nat => contin_imp_inc _ _ _ _ (contf n)) in *. set (incf' := contin_imp_inc _ _ _ _ contf') in *. apply leEq_wdl with (AbsIR (Lim (Cauchy_const (f n x (incf n x Hx))) [-] Part (Cauchy_fun_seq_Lim _ _ _ _ _ H) x (incf' x Hx))). 2: apply AbsIR_wd; apply cg_minus_wd. 2: apply eq_symmetric_unfolded; apply Lim_const. 2: algebra. simpl in |- *. apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq IR _ (Cauchy_minus (Cauchy_const (Part _ _ (incf n x Hx))) (Build_CauchySeq _ _ (Cauchy_fun_real _ _ _ _ _ H x (incf' x Hx))))))). 2: apply AbsIR_wd; apply Lim_minus. eapply leEq_wdl. 2: apply Lim_abs. simpl in |- *. apply str_seq_leEq_so_Lim_leEq. exists N; intros. simpl in |- *. eapply leEq_wdl. apply (HN n i H1 H2 x Hx). apply AbsIR_wd; rational. Qed. Variables F G : PartIR. (* begin show *) Hypotheses contF contF0 : Continuous_I Hab F. Hypotheses contG contG0 : Continuous_I Hab G. (* end show *) Lemma conv_fun_seq'_wdl : (forall n, Feq I (f n) (g n)) -> conv_fun_seq' _ _ _ _ _ contf contF -> conv_fun_seq' _ _ _ _ _ contg contF0. Proof. intros H H0 e H1. elim (H0 e H1); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H2 x Hx). apply AbsIR_wd; apply cg_minus_wd. elim (H n); intros Haux inc. inversion_clear inc. auto. algebra. Qed. Lemma conv_fun_seq'_wdr : Feq I F G -> conv_fun_seq' _ _ _ _ _ contf contF -> conv_fun_seq' _ _ _ _ _ contf0 contG. Proof. intros H H0 e H1. elim (H0 e H1); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H2 x Hx). apply AbsIR_wd; apply cg_minus_wd. algebra. elim H; intros Haux inc. inversion_clear inc. auto. Qed. Lemma conv_fun_seq'_wdl' : (forall n, Feq I (f n) (g n)) -> conv_fun_seq' _ _ _ _ _ contf contF -> conv_fun_seq' _ _ _ _ _ contg contF. Proof. intros H H0 e H1. elim (H0 e H1); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H2 x Hx). apply AbsIR_wd; apply cg_minus_wd. elim (H n); intros Haux inc. inversion_clear inc. auto. algebra. Qed. Lemma conv_fun_seq'_wdr' : Feq I F G -> conv_fun_seq' _ _ _ _ _ contf contF -> conv_fun_seq' _ _ _ _ _ contf contG. Proof. intros H H0 e H1. elim (H0 e H1); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H2 x Hx). apply AbsIR_wd; apply cg_minus_wd. algebra. elim H; intros Haux inc. inversion_clear inc. auto. Qed. Lemma Cauchy_fun_seq_wd : (forall n, Feq I (f n) (g n)) -> Cauchy_fun_seq _ _ _ _ contf -> Cauchy_fun_seq _ _ _ _ contg. Proof. intros H H0 e H1. elim (H0 e H1); clear H0; intros N HN. exists N; intros. eapply leEq_wdl. apply (HN m n H0 H2 x Hx). elim (H n); intros. inversion_clear b0. elim (H m); intros. inversion_clear b0. apply AbsIR_wd; algebra. Qed. Lemma Cauchy_cont_Lim : forall H : Cauchy_fun_seq a b Hab f contf, Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ contf H). Proof. intros. split. Included. intros e He. elim (H _ (pos_div_three _ _ He)); intros N HN. elim (contf N); intros incf contf'. elim (contf' _ (pos_div_three _ _ He)). intros d H0 H1. exists d. assumption. intros x y H2 H3 Hx Hy H4. cut (forall x y z w : IR, AbsIR (x[-]w) [=] AbsIR (x[-]y[+] (y[-]z) [+] (z[-]w))); intros. 2: apply AbsIR_wd; rational. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply H5 with (y := Part _ _ (incf x H2)) (z := Part _ _ (incf y H3)). rstepr (e [/]ThreeNZ[+]e [/]ThreeNZ[+]e [/]ThreeNZ). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. apply leEq_wdl with (AbsIR (Part _ _ Hx[-]Lim (Cauchy_const (Part _ _ (incf x H2))))). 2: apply AbsIR_wd; apply cg_minus_wd. 2: algebra. 2: apply eq_symmetric_unfolded; apply Lim_const. simpl in |- *. apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq IR _ (Cauchy_minus (Build_CauchySeq _ _ (Cauchy_fun_real _ _ _ _ _ H x Hx)) (Cauchy_const (Part _ _ (incf x H2))))))). 2: apply AbsIR_wd; apply Lim_minus. eapply leEq_wdl. 2: apply Lim_abs. simpl in |- *. apply str_seq_leEq_so_Lim_leEq. exists N; intros. simpl in |- *. eapply leEq_wdl. apply (HN i N) with (x := x) (Hx := Hx); auto with arith. apply AbsIR_wd; rational. apply H1; assumption. apply leEq_wdl with (AbsIR (Lim (Cauchy_const (Part _ _ (incf y H3))) [-] Part (Cauchy_fun_seq_Lim _ _ _ _ _ H) y Hy)). 2: apply AbsIR_wd; apply cg_minus_wd. 2: apply eq_symmetric_unfolded; apply Lim_const. 2: algebra. simpl in |- *. apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq IR _ (Cauchy_minus (Cauchy_const (Part _ _ (incf y H3))) (Build_CauchySeq _ _ (Cauchy_fun_real _ _ _ _ _ H y Hy)))))). 2: apply AbsIR_wd; apply Lim_minus. eapply leEq_wdl. 2: apply Lim_abs. simpl in |- *. apply str_seq_leEq_so_Lim_leEq. exists N; intros. simpl in |- *. eapply leEq_wdl. apply (HN N i) with (x := y) (Hx := Hy); auto. apply AbsIR_wd; rational. Qed. Lemma Cauchy_conv_fun_seq : Cauchy_fun_seq _ _ _ _ contf -> conv_fun_seq _ _ _ _ contf. Proof. intro H. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ H)). intro H0. exists (IntPartIR (contin_imp_inc _ _ _ _ H0)). cut (Continuous_I Hab (PartInt (IntPartIR (contin_imp_inc _ _ _ _ H0)))). 2: eapply Continuous_I_wd. 3: apply Cauchy_cont_Lim with (H := H). 2: FEQ. 2: simpl in |- *; apply Lim_wd'; intros; algebra. intro H2; exists H2. intros e H1. elim (Cauchy_conv_fun_seq' H H0 e H1); intros N HN. exists N; intros. eapply leEq_wdl. apply (HN n H3 x Hx). apply AbsIR_wd; apply cg_minus_wd. algebra. simpl in |- *; apply Lim_wd'; intros; simpl in |- *; rational. simpl in |- *; algebra. simpl in |- *; apply Cauchy_cont_Lim. Qed. Lemma conv_Cauchy_fun_seq : conv_fun_seq _ _ _ _ contf -> Cauchy_fun_seq _ _ _ _ contf. Proof. intro H. elim H; intros ff Hff. inversion_clear Hff. apply conv_Cauchy_fun_seq' with (PartInt ff) x. unfold I in |- *; eapply conv_fun_seq'_wd. apply X. Qed. (** More interesting is the fact that a convergent sequence of functions converges pointwise as a sequence of real numbers. *) Lemma fun_conv_imp_seq_conv : conv_fun_seq' _ _ _ _ _ contf contF -> forall x, Compact Hab x -> forall Hxf HxF, Cauchy_Lim_prop2 (fun n => f n x (Hxf n)) (F x HxF). Proof. intros H x H0 Hxf HxF eps H1. elim (H eps H1). intros N HN. exists N; intros. apply AbsIR_imp_AbsSmall. eapply leEq_wdl. apply (HN m H2 x H0). apply AbsIR_wd; algebra. Qed. (** And a sequence of real numbers converges iff the corresponding sequence of constant functions converges to the corresponding constant function. *) Lemma seq_conv_imp_fun_conv : forall x y, Cauchy_Lim_prop2 x y -> forall Hf HF, conv_fun_seq' a b Hab (fun n => [-C-] (x n)) [-C-]y Hf HF. Proof. intros x y H Hf HF e H0. elim (H e H0); intros N HN. exists N; intros; simpl in |- *. apply AbsSmall_imp_AbsIR. auto. Qed. End More_Properties. #[global] Hint Resolve Cauchy_cont_Lim: continuous. Section Algebraic_Properties. (** ** Algebraic Properties We now study how convergence is affected by algebraic operations, and some algebraic properties of the limit function. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables f g : nat -> PartIR. Hypothesis contf : forall n, Continuous_I Hab (f n). Hypothesis contg : forall n, Continuous_I Hab (g n). (** First, the limit function is unique. *) Lemma FLim_unique : forall F G HF HG, conv_fun_seq' a b Hab f F contf HF -> conv_fun_seq' a b Hab f G contf HG -> Feq (Compact Hab) F G. Proof. intros F G HF HG H H0. cut (Cauchy_fun_seq _ _ Hab _ contf). intro H1. apply Feq_transitive with (Cauchy_fun_seq_Lim _ _ _ _ _ H1). FEQ. simpl in |- *. apply Limits_unique. simpl in |- *. eapply fun_conv_imp_seq_conv with (Hab := Hab) (Hxf := fun n : nat => contin_imp_inc _ _ Hab _ (contf n) x Hx'); auto. apply H. apply Feq_symmetric. FEQ. simpl in |- *. apply Limits_unique. simpl in |- *. eapply fun_conv_imp_seq_conv with (Hab := Hab) (Hxf := fun n : nat => contin_imp_inc _ _ Hab _ (contf n) x Hx'); auto. apply H0. apply conv_Cauchy_fun_seq' with F HF; auto. Qed. (** Constant sequences (not sequences of constant functions!) always converge. *) Lemma fun_Lim_seq_const : forall H contH contH', conv_fun_seq' a b Hab (fun n => H) H contH contH'. Proof. exists 0; intros. eapply leEq_wdl. 2: eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply AbsIRz_isz. apply less_leEq; assumption. apply AbsIR_wd; rational. Qed. Lemma fun_Cauchy_prop_const : forall H (contH:Continuous_I Hab H), Cauchy_fun_seq a b Hab (fun n => H) (fun n => contH). Proof. intros. apply conv_Cauchy_fun_seq' with H contH. apply fun_Lim_seq_const. Qed. (** We now prove that if two sequences converge than their sum (difference, product) also converge to the sum (difference, product) of their limits. *) Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. (* begin show *) Hypothesis convF : conv_fun_seq' a b Hab f F contf contF. Hypothesis convG : conv_fun_seq' a b Hab g G contg contG. (* end show *) (* begin hide *) Let incf (n : nat) := contin_imp_inc _ _ _ _ (contf n). Let incg (n : nat) := contin_imp_inc _ _ _ _ (contg n). Let incF := contin_imp_inc _ _ _ _ contF. Let incG := contin_imp_inc _ _ _ _ contG. (* end hide *) Lemma fun_Lim_seq_plus' : forall H H', conv_fun_seq' a b Hab (fun n => f n{+}g n) (F{+}G) H H'. Proof. intros H H' e H0. elim (convF _ (pos_div_two _ _ H0)); intros Nf HNf. elim (convG _ (pos_div_two _ _ H0)); intros Ng HNg. cut (Nf <= Nat.max Nf Ng); [ intro | apply Nat.le_max_l ]. cut (Ng <= Nat.max Nf Ng); [ intro | apply Nat.le_max_r ]. exists (Nat.max Nf Ng); intros. apply leEq_wdl with (AbsIR (Part _ _ (incf n x Hx) [+]Part _ _ (incg n x Hx) [-] (Part _ _ (incF x Hx) [+]Part _ _ (incG x Hx)))). 2: apply AbsIR_wd; simpl in |- *; algebra. apply leEq_wdl with (AbsIR (Part _ _ (incf n x Hx) [-]Part _ _ (incF x Hx) [+] (Part _ _ (incg n x Hx) [-]Part _ _ (incG x Hx)))). 2: apply AbsIR_wd; simpl in |- *; rational. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. unfold incf in |- *; apply HNf; apply Nat.le_trans with (Nat.max Nf Ng); auto. unfold incg in |- *; apply HNg; apply Nat.le_trans with (Nat.max Nf Ng); auto. Qed. Lemma fun_Lim_seq_minus' : forall H H', conv_fun_seq' a b Hab (fun n => f n{-}g n) (F{-}G) H H'. Proof. intros H H' e H0. elim (convF _ (pos_div_two _ _ H0)); intros Nf HNf. elim (convG _ (pos_div_two _ _ H0)); intros Ng HNg. cut (Nf <= Nat.max Nf Ng); [ intro | apply Nat.le_max_l ]. cut (Ng <= Nat.max Nf Ng); [ intro | apply Nat.le_max_r ]. exists (Nat.max Nf Ng); intros. apply leEq_wdl with (AbsIR (Part _ _ (incf n x Hx) [-]Part _ _ (incg n x Hx) [-] (Part _ _ (incF x Hx) [-]Part _ _ (incG x Hx)))). 2: apply AbsIR_wd; simpl in |- *; algebra. apply leEq_wdl with (AbsIR (Part _ _ (incf n x Hx) [-]Part _ _ (incF x Hx) [-] (Part _ _ (incg n x Hx) [-]Part _ _ (incG x Hx)))). 2: apply AbsIR_wd; simpl in |- *; rational. rstepr (e [/]TwoNZ[+]e [/]TwoNZ). eapply leEq_transitive. apply triangle_IR_minus. apply plus_resp_leEq_both. unfold incf in |- *; apply HNf; apply Nat.le_trans with (Nat.max Nf Ng); auto. unfold incg in |- *; apply HNg; apply Nat.le_trans with (Nat.max Nf Ng); auto. Qed. Lemma fun_Lim_seq_mult' : forall H H', conv_fun_seq' a b Hab (fun n => f n{*}g n) (F{*}G) H H'. Proof. intros. set (nF := Norm_Funct contF) in *. set (nG := Norm_Funct contG) in *. red in |- *; intros. set (ee := Min e [1]) in *. cut ([0] [<] ee); intros. set (eg := ee [/]ThreeNZ[/] _[//]max_one_ap_zero nF) in *. set (ef := ee [/]ThreeNZ[/] _[//]max_one_ap_zero nG) in *. cut ([0] [<] eg). intro Heg. cut ([0] [<] ef). intro Hef. elim (convF _ Hef); intros NF HNF; clear convF. elim (convG _ Heg); intros NG HNG; clear convG. cut (NF <= Nat.max NF NG); [ intro | apply Nat.le_max_l ]. cut (NG <= Nat.max NF NG); [ intro | apply Nat.le_max_r ]. exists (Nat.max NF NG); intros. apply leEq_transitive with ee. 2: unfold ee in |- *; apply Min_leEq_lft. apply leEq_wdl with (AbsIR (Part _ _ (incf n x Hx) [*]Part _ _ (incg n x Hx) [-] Part _ _ (incF x Hx) [*]Part _ _ (incG x Hx))). 2: apply AbsIR_wd; simpl in |- *; algebra. apply leEq_wdl with (AbsIR (Part _ _ (incF x Hx) [*] (Part _ _ (incg n x Hx) [-]Part _ _ (incG x Hx)) [+] (Part _ _ (incf n x Hx) [-]Part _ _ (incF x Hx)) [*] (Part _ _ (incg n x Hx) [-]Part _ _ (incG x Hx)) [+] Part _ _ (incG x Hx) [*] (Part _ _ (incf n x Hx) [-]Part _ _ (incF x Hx)))). 2: apply AbsIR_wd; simpl in |- *; rational. rstepr (ee [/]ThreeNZ[+]ee [/]ThreeNZ[+]ee [/]ThreeNZ). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (Max nF [1][*]AbsIR (Part _ _ (incg n x Hx) [-]Part _ _ (incG x Hx))). apply mult_resp_leEq_rht. apply leEq_transitive with nF. unfold nF in |- *; apply norm_bnd_AbsIR; assumption. apply lft_leEq_Max. apply AbsIR_nonneg. eapply shift_mult_leEq'. apply pos_max_one. unfold eg in HNG; unfold incg in |- *; apply HNG; apply Nat.le_trans with (Nat.max NF NG); auto. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (ee [/]ThreeNZ[*]ee [/]ThreeNZ). 2: astepr (ee [/]ThreeNZ[*][1]); apply mult_resp_leEq_lft. apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_transitive. unfold incf in |- *; apply HNF; apply Nat.le_trans with (Nat.max NF NG); auto. unfold ef in |- *. apply shift_div_leEq. apply pos_max_one. astepl (ee [/]ThreeNZ[*][1]); apply mult_resp_leEq_lft. apply rht_leEq_Max. apply less_leEq; apply shift_less_div; astepl ZeroR; [ apply pos_three | assumption ]. eapply leEq_transitive. unfold incg in |- *; apply HNG; apply Nat.le_trans with (Nat.max NF NG); auto. unfold eg in |- *. apply shift_div_leEq. apply pos_max_one. astepl (ee [/]ThreeNZ[*][1]); apply mult_resp_leEq_lft. apply rht_leEq_Max. apply less_leEq; apply shift_less_div; astepl ZeroR; [ apply pos_three | assumption ]. apply shift_div_leEq. apply pos_three. astepr (Three:IR). unfold ee in |- *; apply leEq_transitive with OneR. apply Min_leEq_rht. apply less_leEq; apply one_less_three. apply less_leEq; apply shift_less_div. apply pos_three. astepl ZeroR; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_transitive with (Max nG [1][*]AbsIR (Part _ _ (incf n x Hx) [-]Part _ _ (incF x Hx))). apply mult_resp_leEq_rht. apply leEq_transitive with nG. unfold nG in |- *; apply norm_bnd_AbsIR; assumption. apply lft_leEq_Max. apply AbsIR_nonneg. eapply shift_mult_leEq'. apply pos_max_one. unfold ef in HNF; unfold incf in |- *; apply HNF; apply Nat.le_trans with (Nat.max NF NG); auto. unfold ef in |- *. apply div_resp_pos. apply pos_max_one. apply shift_less_div; astepl ZeroR; [ apply pos_three | assumption ]. unfold eg in |- *. apply div_resp_pos. apply pos_max_one. apply shift_less_div; astepl ZeroR; [ apply pos_three | assumption ]. unfold ee in |- *; apply less_Min. assumption. apply pos_one. Qed. End Algebraic_Properties. Section More_Algebraic_Properties. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables f g : nat -> PartIR. Hypothesis contf : forall n : nat, Continuous_I Hab (f n). Hypothesis contg : forall n : nat, Continuous_I Hab (g n). (** The same is true if we don't make the limits explicit. *) (* begin hide *) Hypothesis Hf : Cauchy_fun_seq _ _ _ _ contf. Hypothesis Hg : Cauchy_fun_seq _ _ _ _ contg. (* end hide *) Lemma fun_Lim_seq_plus : forall H H', conv_fun_seq' a b Hab (fun n => f n{+}g n) (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{+}Cauchy_fun_seq_Lim _ _ _ _ _ Hg) H H'. Proof. intros H H' e H0. set (F := Cauchy_fun_seq_Lim _ _ _ _ _ Hf) in *. cut (Continuous_I Hab F). intro H1. 2: unfold F in |- *; apply Cauchy_cont_Lim. cut (conv_fun_seq' _ _ _ _ _ contf H1). 2: unfold F in |- *; apply Cauchy_conv_fun_seq'; assumption. intro Hf'. set (G := Cauchy_fun_seq_Lim _ _ _ _ _ Hg) in *. cut (Continuous_I Hab G). intro H2. 2: unfold G in |- *; apply Cauchy_cont_Lim. cut (conv_fun_seq' _ _ _ _ _ contg H2). 2: unfold G in |- *; apply Cauchy_conv_fun_seq'; assumption. intro Hg'. apply fun_Lim_seq_plus' with contf contg H1 H2; auto. Qed. Lemma fun_Cauchy_prop_plus : forall H, Cauchy_fun_seq a b Hab (fun n => f n{+}g n) H. Proof. intro. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{+}Cauchy_fun_seq_Lim _ _ _ _ _ Hg)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq' with (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{+}Cauchy_fun_seq_Lim _ _ _ _ _ Hg) H0. apply fun_Lim_seq_plus. Qed. Lemma fun_Lim_seq_minus : forall H H', conv_fun_seq' a b Hab (fun n => f n{-}g n) (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{-}Cauchy_fun_seq_Lim _ _ _ _ _ Hg) H H'. Proof. intros. set (F := Cauchy_fun_seq_Lim _ _ _ _ _ Hf) in *. cut (Continuous_I Hab F). intro H0. 2: unfold F in |- *; apply Cauchy_cont_Lim. cut (conv_fun_seq' _ _ _ _ _ contf H0). 2: unfold F in |- *; apply Cauchy_conv_fun_seq'; assumption. intro Hf'. set (G := Cauchy_fun_seq_Lim _ _ _ _ _ Hg) in *. cut (Continuous_I Hab G). intro H1. 2: unfold G in |- *; apply Cauchy_cont_Lim. cut (conv_fun_seq' _ _ _ _ _ contg H1). 2: unfold G in |- *; apply Cauchy_conv_fun_seq'; assumption. intro Hg'. apply fun_Lim_seq_minus' with contf contg H0 H1; auto. Qed. Lemma fun_Cauchy_prop_minus : forall H, Cauchy_fun_seq a b Hab (fun n => f n{-}g n) H. Proof. intro. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{-}Cauchy_fun_seq_Lim _ _ _ _ _ Hg)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq' with (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{-}Cauchy_fun_seq_Lim _ _ _ _ _ Hg) H0. apply fun_Lim_seq_minus. Qed. Lemma fun_Lim_seq_mult : forall H H', conv_fun_seq' a b Hab (fun n => f n{*}g n) (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{*}Cauchy_fun_seq_Lim _ _ _ _ _ Hg) H H'. Proof. intros. set (F := Cauchy_fun_seq_Lim _ _ _ _ _ Hf) in *. cut (Continuous_I Hab F); [ intro H0 | unfold F in |- *; Contin ]. cut (conv_fun_seq' _ _ _ _ _ contf H0). 2: unfold F in |- *; apply Cauchy_conv_fun_seq'; assumption. intro convF. set (G := Cauchy_fun_seq_Lim _ _ _ _ _ Hg) in *. cut (Continuous_I Hab G); [ intro H1 | unfold G in |- *; Contin ]. cut (conv_fun_seq' _ _ _ _ _ contg H1). 2: unfold G in |- *; apply Cauchy_conv_fun_seq'; assumption. intro convG. cut (Continuous_I Hab F); [ intro HF' | unfold F, I in |- *; apply Cauchy_cont_Lim; assumption ]. cut (Continuous_I Hab G); [ intro HG' | unfold G, I in |- *; apply Cauchy_cont_Lim; assumption ]. apply fun_Lim_seq_mult' with contf contg H0 H1; auto. Qed. Lemma fun_Cauchy_prop_mult : forall H, Cauchy_fun_seq a b Hab (fun n => f n{*}g n) H. Proof. intro H. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{*}Cauchy_fun_seq_Lim _ _ _ _ _ Hg)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq' with (Cauchy_fun_seq_Lim _ _ _ _ _ Hf{*}Cauchy_fun_seq_Lim _ _ _ _ _ Hg) H0. apply fun_Lim_seq_mult. Qed. End More_Algebraic_Properties. Section Still_More_Algebraic_Properties. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. Hypothesis contf : forall n, Continuous_I Hab (f n). Hypothesis Hf : Cauchy_fun_seq _ _ _ _ contf. (** As a corollary, we get the analogous property for the sequence of algebraic inverse functions. *) Lemma fun_Lim_seq_inv : forall H H', conv_fun_seq' a b Hab (fun n => {--} (f n)) {--} (Cauchy_fun_seq_Lim _ _ _ _ _ Hf) H H'. Proof. intros. cut (forall n : nat, Continuous_I Hab ( [-C-][0]{-}f n)). intro H0. unfold I in |- *; eapply conv_fun_seq'_wdl with (fun n : nat => [-C-][0]{-}f n) H0 H'. intro H1; FEQ; try (apply contin_imp_inc; apply contf). cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (fun_Cauchy_prop_const a b Hab [-C-][0] (Continuous_I_const _ _ _ _)) {-} Cauchy_fun_seq_Lim _ _ _ _ _ Hf)). intros H1. apply conv_fun_seq'_wdr with H0 (Cauchy_fun_seq_Lim _ _ _ _ _ (fun_Cauchy_prop_const a b Hab [-C-][0] (Continuous_I_const _ _ _ _)) {-} Cauchy_fun_seq_Lim _ _ _ _ _ Hf) H1. apply eq_imp_Feq. Included. Included. intros; simpl in |- *. astepr ([0][-]Lim (Build_CauchySeq _ _ (Cauchy_fun_real _ _ _ _ contf Hf x Hx'))). apply cg_minus_wd. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Lim_const. apply Lim_wd'; intros; simpl in |- *; algebra. apply Lim_wd'; intros; simpl in |- *; rational. apply fun_Lim_seq_minus with (f := fun n : nat => [-C-][0]:PartIR). Contin. Contin. Qed. Lemma fun_Cauchy_prop_inv : forall H, Cauchy_fun_seq a b Hab (fun n => {--} (f n)) H. Proof. intro. cut (Continuous_I Hab {--} (Cauchy_fun_seq_Lim _ _ _ _ _ Hf)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq' with ( {--} (Cauchy_fun_seq_Lim _ _ _ _ _ Hf)) H0. apply fun_Lim_seq_inv. Qed. End Still_More_Algebraic_Properties. #[global] Hint Resolve Continuous_I_Sum Continuous_I_Sumx Continuous_I_Sum0: continuous. corn-8.20.0/ftc/FunctSeries.v000066400000000000000000000627221473720167500157640ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.FunctSequence. Require Export CoRN.reals.Series. (** printing fun_seq_part_sum %\ensuremath{\sum^n}% #∑n# *) (** printing Fun_Series_Sum %\ensuremath{\sum_0^{\infty}}% #∑0∞# *) Section Definitions. (** * Series of Functions We now turn our attention to series of functions. Like it was already the case for sequences, we will mainly rewrite the results we proved for series of real numbers in a different way. %\begin{convention}% Throughout this section: - [a] and [b] will be real numbers and the interval [[a,b]] will be denoted by [I]; - [f, g] and [h] will denote sequences of continuous functions; - [F, G] and [H] will denote continuous functions. %\end{convention}% ** Definitions As before, we will consider only sequences of continuous functions defined in a compact interval. For this, partial sums are defined and convergence is simply the convergence of the sequence of partial sums. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. Definition fun_seq_part_sum (n : nat) := FSum0 n f. Lemma fun_seq_part_sum_cont : (forall n, Continuous_I Hab (f n)) -> forall n, Continuous_I Hab (fun_seq_part_sum n). Proof. intros; unfold fun_seq_part_sum in |- *. Contin. Qed. Definition fun_series_convergent := {contf : _ | Cauchy_fun_seq _ _ Hab fun_seq_part_sum (fun_seq_part_sum_cont contf)}. (** For what comes up next we need to know that the convergence of a series of functions implies pointwise convergence of the corresponding real number series. *) Lemma fun_series_conv_imp_conv : fun_series_convergent -> forall x, I x -> forall Hx, convergent (fun n => f n x (Hx n)). Proof. intros H x H0 Hx e He. elim H; intros incF convF. elim (convF _ He). intros N HN. exists N; intros. apply AbsIR_imp_AbsSmall. simpl in HN. eapply leEq_wdl. apply (HN m N H1 (le_n N) x H0). apply AbsIR_wd. apply cg_minus_wd; unfold seq_part_sum in |- *; apply Sum0_wd; intros; rational. Qed. (** We then define the sum of the series as being the pointwise sum of the corresponding series. *) (* begin show *) Hypothesis H : fun_series_convergent. (* end show *) (* begin hide *) Let contf := ProjT1 H. Let incf (n : nat) := contin_imp_inc _ _ _ _ (contf n). (* end hide *) Lemma Fun_Series_Sum_strext : forall x y Hx Hy, series_sum _ (fun_series_conv_imp_conv H x Hx (fun n => incf n x Hx)) [#] series_sum _ (fun_series_conv_imp_conv H y Hy (fun n => incf n y Hy)) -> x [#] y. Proof. intros x y Hx Hy H0. unfold series_sum in H0. elim (Lim_strext _ _ H0); intros m Hm. simpl in Hm; unfold seq_part_sum in Hm. elim (Sum0_strext _ _ _ _ Hm); intros i H1 H2. exact (pfstrx _ _ _ _ _ _ H2). Qed. Definition Fun_Series_Sum : PartIR. Proof. apply Build_PartFunct with (pfpfun := fun (x : IR) (Hx : I x) => series_sum _ (fun_series_conv_imp_conv H x Hx (fun n : nat => incf n x Hx))). unfold I in |- *; apply compact_wd. exact Fun_Series_Sum_strext. Defined. End Definitions. Arguments Fun_Series_Sum [a b Hab f]. #[global] Hint Resolve fun_seq_part_sum_cont: continuous. Section More_Definitions. Variables a b : IR. Hypothesis Hab : a [<=] b. Variable f : nat -> PartIR. (** A series can also be absolutely convergent. *) Definition fun_series_abs_convergent := fun_series_convergent _ _ Hab (fun n => FAbs (f n)). End More_Definitions. Section Operations. (* **Algebraic Properties All of these are analogous to the properties for series of real numbers, so we won't comment much about them. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Lemma fun_seq_part_sum_n : forall f (H' : forall n, Continuous_I Hab (f n)) m n, 0 < n -> m <= n -> Feq I (fun_seq_part_sum f n{-}fun_seq_part_sum f m) (FSum m (pred n) f). Proof. intros. unfold fun_seq_part_sum in |- *. apply eq_imp_Feq. unfold I in |- *; apply contin_imp_inc; Contin. unfold I in |- *; apply contin_imp_inc; Contin. intros; simpl in |- *. unfold Sum, Sum1 in |- *. rewrite <- (Nat.lt_succ_pred 0 n); auto. apply cg_minus_wd; apply Sum0_wd; intros; rational. Qed. Lemma conv_fun_const_series : forall x, convergent x -> fun_series_convergent _ _ Hab (fun n => [-C-] (x n)). Proof. intros x H. exists (fun n : nat => Continuous_I_const _ _ Hab (x n)). apply Cauchy_fun_seq2_seq. red in |- *; intros e He. elim (H e He); intros N HN. exists N; intros. simpl in |- *. apply AbsSmall_imp_AbsIR. apply AbsSmall_wdr_unfolded with (seq_part_sum x m[-]seq_part_sum x N). apply HN; assumption. unfold seq_part_sum in |- *; simpl in |- *. apply cg_minus_wd; apply Sum0_wd; algebra. Qed. Lemma fun_const_series_sum : forall y H (H' : fun_series_convergent _ _ Hab (fun n => [-C-] (y n))) x Hx, Fun_Series_Sum H' x Hx [=] series_sum y H. Proof. intros. simpl in |- *. apply series_sum_wd. algebra. Qed. Lemma conv_zero_fun_series : fun_series_convergent _ _ Hab (fun n => [-C-][0]). Proof. apply conv_fun_const_series with (x := fun n : nat => ZeroR). apply conv_zero_series. Qed. Lemma Fun_Series_Sum_zero : forall (H : fun_series_convergent _ _ Hab (fun n => [-C-][0])) x Hx, Fun_Series_Sum H x Hx [=] [0]. Proof. intros. simpl in |- *. apply series_sum_zero. Qed. (* begin show *) Variables f g : nat -> PartIR. (* end show *) Lemma fun_series_convergent_wd : (forall n, Feq I (f n) (g n)) -> fun_series_convergent _ _ Hab f -> fun_series_convergent _ _ Hab g. Proof. intros H H0. elim H0; intros contF convF. cut (forall n : nat, Continuous_I Hab (g n)). intro H1. exists H1. apply Cauchy_fun_seq_wd with (fun_seq_part_sum f) (fun_seq_part_sum_cont _ _ _ _ contF). 2: assumption. intros. apply eq_imp_Feq. apply contin_imp_inc; Contin. apply contin_imp_inc; Contin. intros x H2 Hx Hx'; simpl in |- *. apply Sum0_wd. intro i; elim (H i); intros. inversion_clear b0; auto. intro; apply Continuous_I_wd with (f n); auto. Qed. (* begin show *) Hypothesis convF : fun_series_convergent _ _ Hab f. Hypothesis convG : fun_series_convergent _ _ Hab g. (* end show *) Lemma Fun_Series_Sum_wd' : (forall n, Feq I (f n) (g n)) -> Feq I (Fun_Series_Sum convF) (Fun_Series_Sum convG). Proof. intro H. apply eq_imp_Feq. Included. Included. intros x H0 Hx Hx'; simpl in |- *. apply series_sum_wd. intro; elim (H n); intros. inversion_clear b0; auto. Qed. Lemma conv_fun_series_plus : fun_series_convergent _ _ Hab (fun n => f n{+}g n). Proof. elim convF; intros contF convF'. elim convG; intros contG convG'. assert (H := fun n : nat => Continuous_I_plus _ _ _ _ _ (contF n) (contG n)); exists H. cut (forall n : nat, Continuous_I Hab (fun_seq_part_sum f n{+}fun_seq_part_sum g n)); [ intro H0 | Contin ]. apply Cauchy_fun_seq_wd with (f := fun n : nat => fun_seq_part_sum f n{+}fun_seq_part_sum g n) (contf := H0). 2: eapply fun_Cauchy_prop_plus; auto; [ apply convF' | apply convG' ]. intros; apply eq_imp_Feq. Included. apply contin_imp_inc; Contin. intros; simpl in |- *. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply Sum0_plus_Sum0. apply Sum0_wd; intros; rational. Qed. Lemma Fun_Series_Sum_plus : forall H : fun_series_convergent _ _ Hab (fun n => f n{+}g n), Feq I (Fun_Series_Sum H) (Fun_Series_Sum convF{+}Fun_Series_Sum convG). Proof. intros. apply eq_imp_Feq. Included. Included. intros x H0 Hx Hx'; simpl in |- *. elim convF; intros contF convF'. elim convG; intros contG convG'. cut (convergent (fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contF n) x (ProjIR1 Hx')) [+] Part _ _ (contin_imp_inc _ _ _ _ (contG n) x (ProjIR2 Hx')))). intro H1. eapply eq_transitive_unfolded. 2: apply series_sum_plus with (x := fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contF n) x (ProjIR1 Hx'))) (y := fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contG n) x (ProjIR2 Hx'))) (H := H1). apply series_sum_wd; intro; rational. intros e H1. elim H; intros cont H'. elim (H' _ H1); intros N HN. exists N; intros. apply AbsIR_imp_AbsSmall. eapply leEq_wdl. apply (HN m N H2 (le_n N) x H0). apply AbsIR_wd; unfold fun_seq_part_sum in |- *. simpl in |- *. unfold seq_part_sum in |- *; apply cg_minus_wd; apply Sum0_wd; intros; rational. Qed. Lemma conv_fun_series_minus : fun_series_convergent _ _ Hab (fun n => f n{-}g n). Proof. elim convF; intros contF convF'. elim convG; intros contG convG'. assert (H := fun n : nat => Continuous_I_minus _ _ _ _ _ (contF n) (contG n)); exists H. cut (forall n : nat, Continuous_I Hab (fun_seq_part_sum f n{-}fun_seq_part_sum g n)); [ intro H0 | Contin ]. apply Cauchy_fun_seq_wd with (f := fun n : nat => fun_seq_part_sum f n{-}fun_seq_part_sum g n) (contf := H0). 2: eapply fun_Cauchy_prop_minus; auto; [ apply convF' | apply convG' ]. intros; apply eq_imp_Feq. Included. apply contin_imp_inc; Contin. intros; simpl in |- *. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (Sum0 n (fun i : nat => f i x (ProjIR1 Hx i)) [+] Sum0 n (fun i : nat => [--] (g i x (ProjIR2 Hx i)))). eapply eq_transitive_unfolded. 2: apply Sum0_plus_Sum0. apply Sum0_wd; intros; rational. unfold cg_minus in |- *. apply bin_op_wd_unfolded. algebra. eapply eq_transitive_unfolded. 2: apply inv_Sum0. apply Sum0_wd; algebra. Qed. Lemma Fun_Series_Sum_min : forall H : fun_series_convergent _ _ Hab (fun n => f n{-}g n), Feq I (Fun_Series_Sum H) (Fun_Series_Sum convF{-}Fun_Series_Sum convG). Proof. intros. apply eq_imp_Feq. Included. Included. intros x H0 Hx Hx'; simpl in |- *. elim convF; intros contF convF'. elim convG; intros contG convG'. cut (convergent (fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contF n) x (ProjIR1 Hx')) [-] Part _ _ (contin_imp_inc _ _ _ _ (contG n) x (ProjIR2 Hx')))). intro H1. apply eq_transitive_unfolded with (series_sum _ (fun_series_conv_imp_conv _ _ _ _ convF x (ProjIR1 Hx') (fun n : nat => contin_imp_inc _ _ _ _ (contF n) x (ProjIR1 Hx'))) [-] series_sum _ (fun_series_conv_imp_conv _ _ _ _ convG x (ProjIR2 Hx') (fun n : nat => contin_imp_inc _ _ _ _ (contG n) x (ProjIR2 Hx')))). eapply eq_transitive_unfolded. 2: apply series_sum_minus with (x := fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contF n) x (ProjIR1 Hx'))) (y := fun n : nat => Part _ _ (contin_imp_inc _ _ _ _ (contG n) x (ProjIR2 Hx'))) (H := H1). apply series_sum_wd; intro; rational. apply cg_minus_wd; apply series_sum_wd; intro; rational. intros e H1. elim H; intros cont H'. elim (H' _ H1); intros N HN. exists N; intros. apply AbsIR_imp_AbsSmall. eapply leEq_wdl. apply (HN m N H2 (le_n N) x H0). apply AbsIR_wd; unfold fun_seq_part_sum in |- *. simpl in |- *. unfold seq_part_sum in |- *; apply cg_minus_wd; apply Sum0_wd; intros; rational. Qed. (** %\begin{convention}% Let [c:IR]. %\end{convention}% *) Variable c : IR. Variable H : PartIR. Hypothesis contH : Continuous_I Hab H. Lemma conv_fun_series_scal : fun_series_convergent _ _ Hab (fun n => H{*}f n). Proof. elim convF; intros contF convF'. set (H' := fun n : nat => Continuous_I_mult _ _ _ _ _ contH (contF n)) in *; exists H'. cut (forall n : nat, Continuous_I Hab (fun_seq_part_sum f n)); [ intro H0 | Contin ]. cut (forall n : nat, Continuous_I Hab (H{*}fun_seq_part_sum f n)); [ intro H1 | Contin ]. unfold I in |- *; apply Cauchy_fun_seq_wd with (fun n : nat => H{*}fun_seq_part_sum f n) H1. 2: apply fun_Cauchy_prop_mult with (f := fun n : nat => H) (contf := fun n : nat => contH) (g := fun_seq_part_sum f) (contg := H0). intro; FEQ. apply contin_imp_inc; Contin. simpl in |- *. unfold seq_part_sum in |- *. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply Sum0_comm_scal' with (s := fun m : nat => f m x (ProjIR2 Hx m)). apply Sum0_wd; intros; rational. apply fun_Cauchy_prop_const. apply Cauchy_fun_seq_wd with (f := fun_seq_part_sum f) (contf := fun_seq_part_sum_cont _ _ _ _ contF). 2: assumption. intro; apply Feq_reflexive; Included. Qed. Lemma Fun_Series_Sum_scal : forall H' : fun_series_convergent _ _ Hab (fun n => H{*}f n), Feq I (Fun_Series_Sum H') (H{*}Fun_Series_Sum convF). Proof. elim convF; intros contF convF'. intros. unfold I in |- *; FEQ. try rename X into H0. cut (convergent (fun n : nat => Part H x (ProjIR1 Hx') [*] f n x (contin_imp_inc _ _ _ _ (contF n) _ (ProjIR2 Hx')))). intro H1. apply eq_transitive_unfolded with (series_sum (fun n : nat => Part H x (ProjIR1 Hx') [*] f n x (contin_imp_inc _ _ _ _ (contF n) _ (ProjIR2 Hx'))) H1). 2: simpl in |- *; apply series_sum_mult_scal with (x := fun n : nat => f n x (contin_imp_inc _ _ _ _ (contF n) _ (ProjIR2 Hx'))). simpl in |- *; unfold series_sum in |- *. apply Lim_wd'; intros; simpl in |- *. unfold seq_part_sum in |- *; apply Sum0_wd; intros; rational. intros e H1. elim H'; intros H'' H'''. elim (H''' _ H1); intros N HN. exists N; intros. apply AbsIR_imp_AbsSmall. eapply leEq_wdl. apply (HN m N H2 (le_n N) x Hx). apply AbsIR_wd; simpl in |- *. unfold seq_part_sum in |- *; apply cg_minus_wd; apply Sum0_wd; intros; rational. Qed. End Operations. Section More_Operations. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. Hypothesis convF : fun_series_convergent _ _ Hab f. Lemma conv_fun_series_inv : fun_series_convergent _ _ Hab (fun n => {--} (f n)). Proof. elim convF; intros contF convF'. exists (fun n : nat => Continuous_I_inv _ _ _ _ (contF n)). cut (forall n : nat, Continuous_I Hab {--} (fun_seq_part_sum f n)). intro H. apply Cauchy_fun_seq_wd with (f := fun n : nat => {--} (fun_seq_part_sum f n)) (contf := H). 2: apply fun_Cauchy_prop_inv with (fun_seq_part_sum_cont _ _ _ _ contF). intro; FEQ. apply contin_imp_inc; Contin. simpl in |- *; unfold seq_part_sum in |- *. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply inv_Sum0. apply Sum0_wd; intro; rational. assumption. Contin. Qed. Lemma Fun_Series_Sum_inv : forall H : fun_series_convergent _ _ Hab (fun n => {--} (f n)), Feq I (Fun_Series_Sum H) {--} (Fun_Series_Sum convF). Proof. intros. FEQ. try rename X into H0. cut (convergent (fun n : nat => [--] (f n x (contin_imp_inc _ _ _ _ (ProjT1 convF n) x Hx')))). intro H1. simpl in |- *; apply eq_transitive_unfolded with (series_sum _ H1). 2: apply series_sum_inv with (x := fun n : nat => f n x (contin_imp_inc _ _ _ _ (ProjT1 convF n) x Hx')). unfold series_sum in |- *; apply Lim_wd'; intros; simpl in |- *. unfold seq_part_sum in |- *; apply Sum0_wd; intros. rational. apply conv_series_inv with (x := fun n : nat => f n x (contin_imp_inc _ _ _ _ (ProjT1 convF n) x Hx')). apply fun_series_conv_imp_conv with (Hab := Hab) (Hx := fun n : nat => contin_imp_inc _ _ _ _ (ProjT1 convF n) x Hx'); assumption. Qed. End More_Operations. Section Other_Results. Variables a b : IR. Hypothesis Hab : a [<=] b. Variable f : nat -> PartIR. Hypothesis convF : fun_series_convergent a b Hab f. (** The following relate the sum series with the limit of the sequence of partial sums; as a corollary we get the continuity of the sum of the series. *) Lemma Fun_Series_Sum_char' : forall contf H, Feq (Compact Hab) (Fun_Series_Sum convF) (Cauchy_fun_seq_Lim _ _ Hab (fun_seq_part_sum f) contf H). Proof. intros. FEQ. simpl in |- *; unfold series_sum in |- *. apply Lim_wd'; simpl in |- *; intros. unfold seq_part_sum in |- *; apply Sum0_wd; intros; algebra. Qed. Lemma fun_series_conv : forall H H', conv_fun_seq' a b Hab (fun_seq_part_sum f) (Fun_Series_Sum convF) H H'. Proof. intros. inversion_clear convF. try rename X into H0. apply conv_fun_seq'_wdr with (contf := fun_seq_part_sum_cont _ _ _ _ x) (contF := Cauchy_cont_Lim _ _ _ _ _ H0). 2: apply Cauchy_conv_fun_seq'. apply Feq_symmetric; apply Fun_Series_Sum_char'. Qed. Lemma Fun_Series_Sum_cont : Continuous_I Hab (Fun_Series_Sum convF). Proof. intros. inversion_clear convF. try rename X into H. eapply Continuous_I_wd. apply Feq_symmetric; apply (Fun_Series_Sum_char' (fun n : nat => fun_seq_part_sum_cont _ _ _ _ x n) H). Contin. Qed. Lemma Fun_Series_Sum_char : Feq (Compact Hab) (Cauchy_fun_seq_Lim _ _ Hab (fun_seq_part_sum f) _ (ProjT2 convF)) (Fun_Series_Sum convF). Proof. intros. FEQ. simpl in |- *. unfold series_sum in |- *; apply Lim_wd'. intro; simpl in |- *. unfold seq_part_sum in |- *; apply Sum0_wd; intros; algebra. Qed. Lemma Fun_Series_Sum_as_Lim : forall Hf H', conv_fun_seq' _ _ Hab (fun_seq_part_sum f) (Fun_Series_Sum convF) Hf H'. Proof. intros. apply conv_fun_seq'_wdr with (fun_seq_part_sum_cont _ _ _ _ (ProjT1 convF)) (Cauchy_fun_seq_Lim _ _ _ _ _ (ProjT2 convF)) (Cauchy_cont_Lim _ _ _ _ _ (ProjT2 convF)). apply Fun_Series_Sum_char. apply Cauchy_conv_fun_seq'. Qed. End Other_Results. #[global] Hint Resolve Fun_Series_Sum_cont: continuous. Section Convergence_Criteria. (** ** Convergence Criteria Most of the convergence criteria for series of real numbers carry over to series of real-valued functions, so again we just present them without comments. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable f : nat -> PartIR. Hypothesis contF : forall n : nat, Continuous_I Hab (f n). Lemma fun_str_comparison : forall g, fun_series_convergent _ _ Hab g -> {k : nat | forall n, k <= n -> forall x, I x -> forall Hx Hx', AbsIR (f n x Hx) [<=] g n x Hx'} -> fun_series_convergent _ _ Hab f. Proof. set (H0 := contF) in *. intros g H H1. elim H1; intros k Hk. exists H0. apply Cauchy_fun_seq2_seq. intros e H2. elim H; intros contG convG. cut {N : nat | k < N /\ (forall m : nat, N <= m -> forall x : IR, I x -> forall Hx Hx', AbsSmall e (Part (fun_seq_part_sum g m) x Hx[-]Part (fun_seq_part_sum g N) x Hx'))}. intro H3. elim H3; clear H3. intros N HN; elim HN; clear HN; intros HN' HN. exists N; intros. assert (H' := fun n : nat => contin_imp_inc _ _ _ _ (fun_seq_part_sum_cont _ _ _ _ contG n)). apply leEq_transitive with (Part (fun_seq_part_sum g m) x (H' m x Hx) [-] Part (fun_seq_part_sum g N) x (H' N x Hx)). cut (forall n : nat, included (Compact Hab) (Dom (FAbs (f n)))). intro H4. cut (Dom (FSum N (pred m) (fun n : nat => FRestr (H4 n))) x). intro H5. apply leEq_transitive with (Part (FSum N (pred m) (fun n : nat => FRestr (H4 n))) x H5). cut (Dom (FSum N (pred m) (fun n : nat => FRestr (contin_imp_inc _ _ _ _ (H0 n)))) x). intro H6. apply leEq_wdl with (AbsIR (Part (FSum N (pred m) (fun n : nat => FRestr (contin_imp_inc _ _ _ _ (H0 n)))) x H6)). Opaque Frestr. simpl in |- *. Transparent Frestr. eapply leEq_wdr. apply triangle_SumIR. rewrite -> (Nat.lt_succ_pred k m); auto; apply Nat.lt_le_trans with N; auto. apply Sum_wd; intros. Opaque FAbs. simpl in |- *. Transparent FAbs. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply FAbs_char with (Hx' := contin_imp_inc _ _ _ _ (contF i) x Hx). apply AbsIR_wd; rational. apply AbsIR_wd; apply eq_symmetric_unfolded. cut (Dom (fun_seq_part_sum f m{-}fun_seq_part_sum f N) x). intro H7. Opaque fun_seq_part_sum. apply eq_transitive_unfolded with (Part _ _ H7). simpl in |- *; rational. unfold Frestr in |- *. apply Feq_imp_eq with I. apply Feq_transitive with (FSum N (pred m) f). unfold I in |- *; apply fun_seq_part_sum_n; auto with arith. apply Nat.le_lt_trans with k; [ idtac | apply Nat.lt_le_trans with N ]; auto with arith. apply eq_imp_Feq. unfold I in |- *; apply contin_imp_inc; Contin. simpl in |- *. red in |- *; intros; auto. simpl in |- *. intros. apply Sum_wd; intros; rational. auto. split; simpl in |- *. apply (contin_imp_inc _ _ _ _ (fun_seq_part_sum_cont _ _ _ _ H0 m)); auto. apply (contin_imp_inc _ _ _ _ (fun_seq_part_sum_cont _ _ _ _ H0 N)); auto. simpl in |- *; auto. cut (Dom (FSum N (pred m) g) x). intro H6. apply leEq_wdr with (Part _ _ H6). apply FSum_resp_leEq. rewrite -> (Nat.lt_succ_pred k m); auto; apply Nat.lt_le_trans with N; auto. intros. Opaque FAbs. simpl in |- *. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply FAbs_char with (Hx' := contin_imp_inc _ _ _ _ (contF i) x0 (HxF i)). apply Hk. apply Nat.le_trans with N; auto with arith. simpl in HxF. apply (HxF 0). cut (Dom (fun_seq_part_sum g m{-}fun_seq_part_sum g N) x). intro H7. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (Part _ _ H7). simpl in |- *; rational. apply Feq_imp_eq with I. unfold I in |- *; apply fun_seq_part_sum_n; auto with arith. apply Nat.le_lt_trans with k; [ idtac | apply Nat.lt_le_trans with N ]; auto with arith. auto. split; simpl in |- *. apply (contin_imp_inc _ _ _ _ (fun_seq_part_sum_cont _ _ _ _ contG m)); auto. apply (contin_imp_inc _ _ _ _ (fun_seq_part_sum_cont _ _ _ _ contG N)); auto. simpl in |- *; intro; apply (contin_imp_inc _ _ _ _ (contG n)); auto. Transparent FAbs. simpl in |- *; auto. Opaque FAbs. unfold I in |- *; simpl in |- *; Included. eapply leEq_transitive. apply leEq_AbsIR. apply AbsSmall_imp_AbsIR. apply HN; assumption. elim (convG _ H2). intros N HN; exists (S (Nat.max N k)). cut (N <= Nat.max N k); [ intro | apply Nat.le_max_l ]. cut (k <= Nat.max N k); [ intro | apply Nat.le_max_r ]. split. auto with arith. intros m H5 x H6 Hx Hx'. apply AbsIR_imp_AbsSmall. cut (N <= m); [ intro | apply Nat.le_trans with (Nat.max N k); auto with arith ]. eapply leEq_wdl. Transparent fun_seq_part_sum. simpl in Hx'. apply (HN m _ H7 (le_S _ _ H3) x H6). Opaque fun_seq_part_sum. apply AbsIR_wd; rational. Qed. Transparent FAbs. Lemma fun_comparison : forall g, fun_series_convergent _ _ Hab g -> (forall n x, I x -> forall Hx Hx', AbsIR (f n x Hx) [<=] g n x Hx') -> fun_series_convergent _ _ Hab f. Proof. intros g H H0. apply fun_str_comparison with g; auto. exists 0; intros; apply H0; auto. Qed. Lemma abs_imp_conv : fun_series_abs_convergent _ _ Hab f -> fun_series_convergent _ _ Hab f. Proof. intro H. apply fun_comparison with (fun n : nat => FAbs (f n)). apply H. intros; apply eq_imp_leEq; apply eq_symmetric_unfolded; apply FAbs_char. Qed. Lemma fun_ratio_test_conv : {N : nat | {c : IR | c [<] [1] | [0] [<=] c /\ (forall x, I x -> forall n, N <= n -> forall Hx Hx', AbsIR (f (S n) x Hx') [<=] c[*]AbsIR (f n x Hx))}} -> fun_series_convergent _ _ Hab f. Proof. intro H. elim H; clear H; intros N H. elim H; clear H; intros c Hc1 H. elim H; clear H; intros H0c H. cut (forall x : IR, I x -> forall n : nat, N <= n -> forall Hx Hx', AbsIR (f n x Hx') [<=] AbsIR (f N x Hx) [*]c[^] (n - N)). intro H0. apply fun_str_comparison with (fun n : nat => FAbs (f N) {*} [-C-] (c[^] (n - N))). 2: exists N; intros. 2: eapply leEq_wdr. 2: apply H0 with (Hx' := Hx) (Hx := ProjIR1 (ProjIR1 Hx')); auto with arith. Opaque FAbs. 2: simpl in |- *; apply mult_wd; [ apply eq_symmetric_unfolded; apply FAbs_char | algebra ]. apply conv_fun_series_scal with (f := fun n : nat => [-C-] (c[^] (n - N))). apply conv_fun_const_series with (x := fun n : nat => c[^] (n - N)). apply join_series with (power_series c). apply power_series_conv. apply AbsIR_less. assumption. apply less_leEq_trans with [0]. rstepr ([--][0]:IR). apply inv_resp_less. apply pos_one. assumption. exists N. exists 0. intro. rewrite Nat.add_sub. algebra. Contin. intros x H0 n; induction n as [| n Hrecn]. intro. cut (N = 0); [ intro | auto with arith ]. rewrite H2. intros. apply eq_imp_leEq. simpl in |- *. astepl (AbsIR (Part _ _ Hx') [*][1]); apply mult_wdl; apply AbsIR_wd; algebra. intro. elim (le_lt_eq_dec _ _ H1); intro. intros; apply leEq_transitive with (c[*]AbsIR (f n x (contin_imp_inc _ _ _ _ (contF n) x H0))). apply H; auto with arith. apply leEq_wdr with (AbsIR (f N x Hx) [*]c[^] (n - N) [*]c). rstepr (c[*] (AbsIR (Part _ _ Hx) [*]c[^] (n - N))). apply mult_resp_leEq_lft. apply Hrecn; auto with arith. assumption. rewrite Nat.sub_succ_l. simpl in |- *; rational. auto with arith. rewrite b0; intros. rewrite Nat.sub_diag. apply eq_imp_leEq. simpl in |- *; eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply mult_one. apply AbsIR_wd; algebra. Qed. End Convergence_Criteria. corn-8.20.0/ftc/FunctSums.v000066400000000000000000000377551473720167500154710ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing FSum0 %\ensuremath{\sum_0}% #∑0# *) (** printing FSum %\ensuremath{\sum}% #∑# *) (** printing FSumx %\ensuremath{\sum'}% #∑'&*) Require Export CoRN.reals.CSumsReals. Require Export CoRN.ftc.PartFunEquality. (** * Sums of Functions In this file we define sums are defined of arbitrary families of partial functions. Given a countable family of functions, their sum is defined on the intersection of all the domains. As is the case for groups, we will define three different kinds of sums. We will first consider the case of a family $\{f_i\}_{i\in\NN}$#{fi}# of functions; we can both define $\sum_{i=0}^{n-1}f_i$#the sum of the first n functions# ( [FSum0]) or $\sum_{i=m}^nf_i$#the sum of fm through fn# ( [FSum]). *) Definition FSum0 (n : nat) (f : nat -> PartIR) : PartIR. Proof. intros. apply Build_PartFunct with (fun x : IR => forall n : nat, Dom (f n) x) (fun (x : IR) (Hx : forall n : nat, Dom (f n) x) => Sum0 n (fun n : nat => Part (f n) x (Hx n))). intros x y H H0 n0. apply (dom_wd _ (f n0) x). apply H. assumption. intros x y Hx Hy H. elim (Sum0_strext' _ _ _ _ H); intros i Hi. apply pfstrx with (f i) (Hx i) (Hy i); assumption. Defined. Definition FSum (m n : nat) (f : nat -> PartIR) : PartIR. Proof. intros. apply Build_PartFunct with (fun x : IR => forall n : nat, Dom (f n) x) (fun (x : IR) (Hx : forall n : nat, Dom (f n) x) => Sum m n (fun n : nat => Part (f n) x (Hx n))). intros x y H H0 n0. apply (dom_wd _ (f n0) x). apply H. assumption. intros x y Hx Hy H. elim (Sum_strext' _ _ _ _ _ H); intros i Hi. apply pfstrx with (f i) (Hx i) (Hy i); assumption. Defined. (** Although [FSum] is here defined directly, it has the same relationship to the [FSum0] operator as [Sum] has to [Sum0]. Also, all the results for [Sum] and [Sum0] hold when these operators are replaced by their functional equivalents. This is an immediate consequence of the fact that the partial functions form a group; however, as we already mentioned, their forming too big a type makes it impossible to use those results. *) Lemma FSum_FSum0 : forall m n (f : nat -> PartIR) x Hx Hx' Hx'', FSum m n f x Hx [=] FSum0 (S n) f x Hx'[-]FSum0 m f x Hx''. Proof. intros. simpl in |- *; unfold Sum, Sum1 in |- *; simpl in |- *. apply cg_minus_wd; try apply bin_op_wd_unfolded; try apply Sum0_wd; intros; algebra. Qed. Lemma FSum0_wd : forall m (f g : nat -> PartIR), (forall x HxF HxG i, f i x (HxF i) [=] g i x (HxG i)) -> forall x HxF HxG, FSum0 m f x HxF [=] FSum0 m g x HxG. Proof. intros. simpl in |- *. apply Sum0_wd. intros; simpl in |- *; algebra. Qed. Lemma FSum_one : forall n (f : nat -> PartIR) x Hx Hx', FSum n n f x Hx' [=] f n x Hx. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. apply Sum_one. simpl in |- *; rational. Qed. Lemma FSum_FSum : forall l m n (f : nat -> PartIR) x Hx Hx' Hx'', FSum l m f x Hx[+]FSum (S m) n f x Hx' [=] FSum l n f x Hx''. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply Sum_Sum with (l := l) (m := m). apply bin_op_wd_unfolded; apply Sum_wd; intros; rational. Qed. Lemma FSum_first : forall m n (f : nat -> PartIR) x Hx Hx' Hx'', FSum m n f x Hx [=] f m x Hx'[+]FSum (S m) n f x Hx''. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. apply Sum_first. apply bin_op_wd_unfolded; try apply Sum_wd; intros; rational. Qed. Lemma FSum_last : forall m n (f : nat -> PartIR) x Hx Hx' Hx'', FSum m (S n) f x Hx [=] FSum m n f x Hx'[+]f (S n) x Hx''. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. apply Sum_last. apply bin_op_wd_unfolded; try apply Sum_wd; intros; rational. Qed. Lemma FSum_last' : forall m n (f : nat -> PartIR) x Hx Hx' Hx'', 0 < n -> FSum m n f x Hx [=] FSum m (pred n) f x Hx'[+]f n x Hx''. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. apply Sum_last'. assumption. apply bin_op_wd_unfolded; try apply Sum_wd; intros; rational. Qed. Lemma FSum_wd : forall m n (f g : nat -> PartIR), (forall x HxF HxG i, f i x (HxF i) [=] g i x (HxG i)) -> forall x HxF HxG, FSum m n f x HxF [=] FSum m n g x HxG. Proof. intros. simpl in |- *. apply Sum_wd. algebra. Qed. Lemma FSum_plus_FSum : forall (f g : nat -> PartIR) m n x Hx HxF HxG, FSum m n (fun i => f i{+}g i) x Hx [=] FSum m n f x HxF[+]FSum m n g x HxG. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply Sum_plus_Sum. apply Sum_wd; intros; rational. Qed. Lemma inv_FSum : forall (f : nat -> PartIR) m n x Hx Hx', FSum m n (fun i => {--} (f i)) x Hx [=] [--] (FSum m n f x Hx'). Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply inv_Sum. apply Sum_wd; intros; rational. Qed. Lemma FSum_minus_FSum : forall (f g : nat -> PartIR) m n x Hx HxF HxG, FSum m n (fun i => f i{-}g i) x Hx [=] FSum m n f x HxF[-]FSum m n g x HxG. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply Sum_minus_Sum. apply Sum_wd; intros; rational. Qed. Lemma FSum_wd' : forall m n, m <= S n -> forall f g : nat -> PartIR, (forall x HxF HxG i, m <= i -> i <= n -> f i x (HxF i) [=] g i x (HxG i)) -> forall x HxF HxG, FSum m n f x HxF [=] FSum m n g x HxG. Proof. intros. simpl in |- *. apply Sum_wd'; try assumption. algebra. Qed. Lemma FSum_resp_less : forall (f g : nat -> PartIR) m n, m <= n -> (forall x HxF HxG i, m <= i -> i <= n -> f i x (HxF i) [<] g i x (HxG i)) -> forall x HxF HxG, FSum m n f x HxF [<] FSum m n g x HxG. Proof. intros f g m n H H0 x HxF HxG. simpl in |- *. apply Sum_resp_less; try assumption. intros; apply H0; assumption. Qed. Lemma FSum_resp_leEq : forall (f g : nat -> PartIR) m n, m <= S n -> (forall x HxF HxG i, m <= i -> i <= n -> f i x (HxF i) [<=] g i x (HxG i)) -> forall x HxF HxG, FSum m n f x HxF [<=] FSum m n g x HxG. Proof. intros f g m n H H0 x HxF HxG. simpl in |- *. apply Sum_resp_leEq; try assumption. intros; apply H0; assumption. Qed. Lemma FSum_comm_scal : forall (f : nat -> PartIR) c m n x Hx Hx', FSum m n (fun i => f i{*} [-C-]c) x Hx [=] (FSum m n f{*} [-C-]c) x Hx'. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply (Sum_comm_scal (fun n : nat => f n x (ProjIR1 Hx' n)) c m n). apply Sum_wd; intros; rational. Qed. Lemma FSum_comm_scal' : forall (f : nat -> PartIR) c m n x Hx Hx', FSum m n (fun i => [-C-]c{*}f i) x Hx [=] ( [-C-]c{*}FSum m n f) x Hx'. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply (Sum_comm_scal' (fun n : nat => f n x (ProjIR2 Hx' n)) c m n). apply Sum_wd; intros; rational. Qed. (** Also important is the case when we have a finite family $\{f_i\}_{i=0}^{n-1}$ of #exactly n# functions; in this case we need to use the [FSumx] operator. *) Fixpoint FSumx (n : nat) : (forall i, i < n -> PartIR) -> PartIR := match n return ((forall i, i < n -> PartIR) -> PartIR) with | O => fun _ => [-C-][0] | S p => fun f => FSumx p (fun i l => f i (Nat.lt_lt_succ_r i p l)) {+} f p (Nat.lt_succ_diag_r p) end. (** This operator is well defined, as expected. *) Lemma FSumx_wd : forall n (f g : forall i, i < n -> PartIR), (forall i Hi x HxF HxG, f i Hi x HxF [=] g i Hi x HxG) -> forall x HxF HxG, FSumx n f x HxF [=] FSumx n g x HxG. Proof. intro; case n. intros; simpl in |- *; algebra. clear n. simple induction n. intros; simpl in |- *; algebra. clear n; intro. cut {p : nat | S n = p}; [ intro H | exists (S n); auto ]. elim H; intros p Hp. rewrite Hp; intros. simpl in |- *. apply bin_op_wd_unfolded. apply H0. intros; apply H1. apply H1. Qed. Lemma FSumx_wd' : forall (P : IR -> CProp) n (f g : forall i, i < n -> PartIR), (forall i H H', Feq P (f i H) (g i H')) -> Feq P (FSumx n f) (FSumx n g). Proof. intros; induction n as [| n Hrecn]. simpl in |- *; apply Feq_reflexive; apply included_IR. simpl in |- *; apply Feq_plus; auto. Qed. (** As was already the case for [Sumx], in many cases we will need to explicitly assume that $f_i$#f1# is independent of the proof that [i [<] n]. This holds both for the value and the domain of the partial function $f_i$#fi#. *) Definition ext_fun_seq n (f : forall i, i < n -> PartIR) := forall i j, i = j -> forall Hi Hj x y, x [=] y -> forall Hx Hy, f i Hi x Hx [=] f j Hj y Hy. Definition ext_fun_seq' n (f : forall i, i < n -> PartIR) := forall i j, i = j -> forall Hi Hj x y, x [=] y -> Dom (f i Hi) x -> Dom (f j Hj) y. Arguments ext_fun_seq [n]. Arguments ext_fun_seq' [n]. (** Under these assumptions, we can characterize the domain and the value of the sum function from the domains and values of the summands: *) Lemma FSumx_pred : forall n (f : forall i, i < n -> PartIR), ext_fun_seq' f -> forall x, Dom (FSumx n f) x -> forall i Hi, Dom (f i Hi) x. Proof. intros n f H x H0 i Hi; red in H; induction n as [| n Hrecn]. exfalso; inversion Hi. elim (le_lt_eq_dec _ _ Hi); intro. cut (i < n); [ intro | auto with arith ]. set (g := fun i Hi => f i (Nat.lt_lt_succ_r _ _ Hi)) in *. apply H with i (Nat.lt_lt_succ_r _ _ H1) x. auto. algebra. change (Dom (g i H1) x) in |- *. apply Hrecn. unfold g in |- *; intros. apply H with i0 (Nat.lt_lt_succ_r i0 n Hi0) x0; auto. inversion_clear H0; assumption. elim H0; intros H1 H2; clear H0 H1. apply H with n (Nat.lt_succ_diag_r n) x; auto. symmetry in |- *; auto. algebra. Qed. Lemma FSumx_pred' : forall n (f : forall i, i < n -> PartIR), ext_fun_seq' f -> forall x, (forall i Hi, Dom (f i Hi) x) -> Dom (FSumx n f) x. Proof. intros n f H x H0; induction n as [| n Hrecn]. simpl in |- *; auto. split. apply Hrecn. red in |- *; intros. red in H. exact (H _ _ H1 _ _ _ _ H2 X). intros; auto. apply H0. Qed. Lemma FSumx_char : forall n f x Hx Hf, FSumx n f x Hx [=] Sumx (fun i Hi => f i Hi x (FSumx_pred n f Hf x Hx i Hi)). Proof. intro; induction n as [| n Hrecn]. algebra. intros; simpl in |- *. apply bin_op_wd_unfolded; algebra. cut (ext_fun_seq' (fun i Hi => f i (Nat.lt_lt_succ_r i n Hi))). intro H. eapply eq_transitive_unfolded. apply Hrecn with (Hf := H). apply Sumx_wd; intros; simpl in |- *; algebra. intros i j H H0 H' x0 y H1 H2. apply Hf with i (Nat.lt_lt_succ_r i n H0) x0; auto. Qed. (** As we did for arbitrary groups, it is often useful to rewrite this sums as ordinary sums. *) Definition FSumx_to_FSum n : (forall i, i < n -> PartIR) -> nat -> PartIR. Proof. intros f i. elim (le_lt_dec n i); intro. apply ( [-C-][0]:PartIR). apply (f i b). Defined. Lemma FSumx_lt : forall n (f : forall i, i < n -> PartIR), ext_fun_seq f -> forall i Hi x Hx Hx', FSumx_to_FSum n f i x Hx [=] f i Hi x Hx'. Proof. do 6 intro. unfold FSumx_to_FSum in |- *. elim (le_lt_dec n i); intro; simpl in |- *. exfalso; apply (Nat.le_ngt n i); auto. intros; apply H; auto. algebra. Qed. Lemma FSumx_le : forall n (f : forall i, i < n -> PartIR), ext_fun_seq f -> forall i x Hx, n <= i -> FSumx_to_FSum n f i x Hx [=] [0]. Proof. do 5 intro. unfold FSumx_to_FSum in |- *. elim (le_lt_dec n i); intro; simpl in |- *. intro; algebra. intros; exfalso; apply (Nat.le_ngt n i); auto. Qed. Lemma FSum_FSumx_to_FSum : forall n (f : forall i, i < S n -> PartIR), ext_fun_seq f -> ext_fun_seq' f -> forall x Hx Hx', FSum 0 n (FSumx_to_FSum _ f) x Hx [=] FSumx _ f x Hx'. Proof. simple induction n. intros; simpl in |- *. eapply eq_transitive_unfolded. apply Sum_one. simpl in |- *. cut (0 < 1); [ intro | apply Nat.lt_succ_diag_r ]. astepr (Part (f 0 (Nat.lt_succ_diag_r 0)) x (ProjIR2 Hx')). apply FSumx_lt; assumption. clear n; intros n H f H0 H1 x Hx Hx'. simpl in |- *. eapply eq_transitive_unfolded. apply Sum_last. apply bin_op_wd_unfolded. set (g := fun i (l : i < S n) => f i (Nat.lt_lt_succ_r _ _ l)) in *. cut (ext_fun_seq g); intros. cut (ext_fun_seq' g). intro H3. astepr (FSumx n (fun i (l : i < n) => g i (Nat.lt_lt_succ_r _ _ l)) x (ProjIR1 (ProjIR1 Hx')) [+]g n (Nat.lt_succ_diag_r n) x (ProjIR2 (ProjIR1 Hx'))). cut (Dom (FSumx _ g) x). intro H4; cut (forall m : nat, Dom (FSumx_to_FSum (S n) g m) x). intro Hx''. simpl in H. apply eq_transitive_unfolded with (Sum 0 n (fun m : nat => FSumx_to_FSum (S n) g m x (Hx'' m))). 2: apply H with (f := g); try assumption. apply Sum_wd'. auto with arith. intros. cut (i < S (S n)); [ intro | auto with arith ]. apply eq_transitive_unfolded with (f i H7 x (FSumx_pred _ _ H1 x Hx' i H7)). apply FSumx_lt; assumption. cut (i < S n); [ intro | auto with arith ]. apply eq_transitive_unfolded with (g i H8 x (FSumx_pred _ _ H3 x H4 i H8)). 2: apply eq_symmetric_unfolded; apply FSumx_lt; assumption. unfold g in |- *; apply H0; auto. algebra. intro. simpl in Hx. generalize (Hx m); clear H4 H3 H2 Hx. unfold FSumx_to_FSum in |- *. elim (le_lt_dec (S n) m); elim (le_lt_dec (S (S n)) m); do 2 intro; simpl in |- *; intro. auto. auto. unfold g in |- *; apply FSumx_pred with (n := S (S n)); assumption. unfold g in |- *; apply FSumx_pred with (n := S (S n)); assumption. simpl in Hx'. unfold g in |- *; inversion_clear Hx'; intros; assumption. unfold g in |- *; red in |- *; intros. red in H1; apply H1 with i (Nat.lt_lt_succ_r _ _ Hi) x0; auto. unfold g in |- *; red in |- *; intros. red in H0; apply H0; auto. apply FSumx_lt; auto. Qed. (** Some useful lemmas follow. *) Lemma FSum0_0 : forall P f, (forall n, included P (Dom (f n))) -> Feq P [-C-][0] (FSum0 0 f). Proof. intros P f H. FEQ. simpl in |- *. red in |- *; intros; apply (H n); auto. Qed. Lemma FSum0_S : forall P f n, (forall m, included P (Dom (f m))) -> Feq P (FSum0 n f{+}f n) (FSum0 (S n) f). Proof. intros P f n H. FEQ. apply included_FPlus; auto. simpl in |- *; red in |- *; intros. apply (H n0); auto. simpl in |- *. red in |- *; intros; apply (H n0); auto. simpl in |- *; apply bin_op_wd_unfolded; algebra. apply Sum0_wd; algebra. Qed. Lemma FSum_0 : forall P f n, (forall i, included P (Dom (f i))) -> Feq P (f n) (FSum n n f). Proof. intros P f n H. FEQ. simpl in |- *. red in |- *; intros; apply (H n0); auto. simpl in |- *. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply Sum_one. algebra. Qed. Lemma FSum_S : forall P f m n, (forall i, included P (Dom (f i))) -> Feq P (FSum m n f{+}f (S n)) (FSum m (S n) f). Proof. intros P f m n H. apply eq_imp_Feq. apply included_FPlus; auto. simpl in |- *. red in |- *; intros; apply (H n0); auto. simpl in |- *. red in |- *; intros; apply (H n0); auto. intros; simpl in |- *; apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply Sum_last. algebra. Qed. Lemma FSum_FSum0' : forall P f m n, (forall i, included P (Dom (f i))) -> Feq P (FSum m n f) (FSum0 (S n) f{-}FSum0 m f). Proof. intros P f m n H. apply eq_imp_Feq. red in |- *; intros; intro; apply (H n0); auto. apply included_FMinus; red in |- *; intros; intro; apply (H n0); auto. intros. apply eq_transitive_unfolded with (Part _ _ (ProjIR1 Hx') [-]FSum0 m f _ (ProjIR2 Hx')). apply FSum_FSum0. simpl in |- *; rational. Qed. corn-8.20.0/ftc/Integral.v000066400000000000000000001442611473720167500152760ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.RefLemma. From Coq Require Import Lia. (** printing integral %\ensuremath{\int_I}% #∫I# *) (** printing Integral %\ensuremath{\int_I}% #∫I# *) (* begin hide *) Section Lemmas. Let Sumx_wd_weird : forall n m : nat, m = S n -> forall (f : forall i : nat, i < n -> IR) (g : forall i : nat, i < m -> IR), (forall H, g 0 H [=] [0]) -> (forall (i : nat) H H', f i H [=] g (S i) H') -> Sumx f [=] Sumx g. Proof. intro; induction n as [| n Hrecn]. do 2 intro. rewrite H. intros; simpl in |- *; apply eq_symmetric_unfolded. astepr (g 0 (Nat.lt_succ_diag_r 0)); algebra. do 2 intro; rewrite H; intros. astepl (Sumx (fun (i : nat) (Hi : i < n) => f i (Nat.lt_lt_succ_r _ _ Hi)) [+]f n (Nat.lt_succ_diag_r n)). Step_final (Sumx (fun (i : nat) (Hi : i < S n) => g i (Nat.lt_lt_succ_r _ _ Hi)) [+] g (S n) (Nat.lt_succ_diag_r (S n))). Qed. Lemma Sumx_weird_lemma : forall n m l : nat, l = S (m + n) -> forall (f1 : forall i : nat, i < n -> IR) (f2 : forall i : nat, i < m -> IR) (f3 : forall i : nat, i < l -> IR), nat_less_n_fun f1 -> nat_less_n_fun f2 -> nat_less_n_fun f3 -> (forall (i : nat) Hi Hi', f1 i Hi [=] f3 i Hi') -> (forall (i : nat) Hi Hi', f2 i Hi [=] f3 (S (n + i)) Hi') -> (forall Hi, f3 n Hi [=] [0]) -> Sumx f1[+]Sumx f2 [=] Sumx f3. Proof. intros n m. induction m as [| m Hrecm]. intros l Hl. simpl in Hl; rewrite Hl; intros f1 f2 f3 Hf1 Hf2 Hf3 Hf1_f3 Hf2_f3 Hf3_f3. astepl (Sumx f1[+][0]). simpl in |- *; apply bin_op_wd_unfolded. apply Sumx_wd; intros; apply Hf1_f3. apply eq_symmetric_unfolded; apply Hf3_f3. set (l' := S m + n) in *. intros l Hl. rewrite Hl; intros f1 f2 f3 Hf1 Hf2 Hf3 Hf1_f3 Hf2_f3 Hf3_f3. apply eq_transitive_unfolded with (Sumx f1[+]Sumx (fun (i : nat) (Hi : i < m) => f2 i (Nat.lt_lt_succ_r _ _ Hi)) [+] f2 m (Nat.lt_succ_diag_r m)). simpl in |- *; algebra. astepr (Sumx (fun (i : nat) (Hi : i < l') => f3 i (Nat.lt_lt_succ_r _ _ Hi)) [+] f3 l' (Nat.lt_succ_diag_r l')). apply bin_op_wd_unfolded. apply Hrecm. unfold l' in |- *; auto. assumption. red in |- *; intros; apply Hf2; auto. red in |- *; intros; apply Hf3; auto. red in |- *; intros; apply Hf1_f3. red in |- *; intros; apply Hf2_f3. red in |- *; intros; apply Hf3_f3. unfold l' at 1 in |- *. cut (S (n + m) < S l'); [ intro | unfold l' in |- *; simpl in |- *; rewrite Nat.add_comm; auto ]. apply eq_transitive_unfolded with (f3 _ H). apply Hf2_f3. apply Hf3; simpl in |- *; auto with arith. Qed. End Lemmas. (* end hide *) Section Integral. (** * Integral Having proved the main properties of partitions and refinements, we will define the integral of a continuous function [F] in the interval [[a,b]] as the limit of the sequence of Sums of $F$ for even partitions of increasing number of points. %\begin{convention}% All throughout, [a,b] will be real numbers, the interval [[a,b]] will be denoted by [I] and [F,G] will be continuous functions in [I]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. Let contF' := contin_prop _ _ _ _ contF. (* end hide *) Section Darboux_Sum. Definition integral_seq : nat -> IR. Proof. intro n. apply Even_Partition_Sum with a b Hab F (S n). assumption. auto. Defined. Lemma Cauchy_Darboux_Seq : Cauchy_prop integral_seq. Proof. red in |- *; intros e He. set (e' := e[/] _[//]mult_resp_ap_zero _ _ _ (two_ap_zero _) (max_one_ap_zero (b[-]a))) in *. cut ([0] [<] e'). intro He'. set (d := proj1_sig2T _ _ _ (contF' e' He')) in *. generalize (proj2b_sig2T _ _ _ (contF' e' He')); generalize (proj2a_sig2T _ _ _ (contF' e' He')); fold d in |- *; intros H0 H1. set (N := ProjT1 (Archimedes (b[-]a[/] _[//]pos_ap_zero _ _ H0))) in *. exists N; intros. apply AbsIR_imp_AbsSmall. apply leEq_transitive with (Two[*]e'[*] (b[-]a)). rstepr (e'[*] (b[-]a) [+]e'[*] (b[-]a)). unfold integral_seq in |- *. elim (even_partition_refinement _ _ Hab _ _ (O_S m) (O_S N)). intros w Hw. elim Hw; clear Hw; intros Hw H2 H3. unfold Even_Partition_Sum in |- *. unfold I in |- *; apply second_refinement_lemma with (a := a) (b := b) (F := F) (contF := contF) (Q := Even_Partition Hab w Hw) (He := He') (He' := He'). assumption. assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply even_partition_Mesh. apply shift_div_leEq. apply pos_nring_S. apply shift_leEq_mult' with (pos_ap_zero _ _ H0). assumption. apply leEq_transitive with (nring (R:=IR) N). exact (ProjT2 (Archimedes (b[-]a[/] d[//]pos_ap_zero _ _ H0))). apply nring_leEq; apply le_S; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply even_partition_Mesh. apply shift_div_leEq. apply pos_nring_S. apply shift_leEq_mult' with (pos_ap_zero _ _ H0). assumption. apply leEq_transitive with (nring (R:=IR) N). exact (ProjT2 (Archimedes (b[-]a[/] d[//]pos_ap_zero _ _ H0))). apply nring_leEq; apply Nat.le_succ_diag_r. unfold e' in |- *. rstepl (e[*] (b[-]a) [/] _[//]max_one_ap_zero (b[-]a)). apply shift_div_leEq. apply pos_max_one. apply mult_resp_leEq_lft. apply lft_leEq_Max. apply less_leEq; assumption. unfold e' in |- *. apply div_resp_pos. apply mult_resp_pos. apply pos_two. apply pos_max_one. assumption. Qed. Definition integral := Lim (Build_CauchySeq _ _ Cauchy_Darboux_Seq). End Darboux_Sum. Section Integral_Thm. (** The following shows that in fact the integral of [F] is the limit of any sequence of partitions of mesh converging to 0. %\begin{convention}% Let [e] be a positive real number and [P] be a partition of [I] with [n] points and mesh smaller than the modulus of continuity of [F] for [e]. Let [fP] be a choice of points respecting [P]. %\end{convention}% *) Variable n : nat. Variable P : Partition Hab n. Variable e : IR. Hypothesis He : [0] [<] e. (* begin hide *) Let d := proj1_sig2T _ _ _ (contF' e He). (* end hide *) Hypothesis HmeshP : Mesh P [<] d. Variable fP : forall i : nat, i < n -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Hypothesis incF : included (Compact Hab) (Dom F). Lemma partition_Sum_conv_integral : AbsIR (Partition_Sum HfP incF[-]integral) [<=] e[*] (b[-]a). apply leEq_wdl with (AbsIR (Partition_Sum HfP (contin_imp_inc _ _ _ _ contF) [-]integral)). Proof. apply leEq_wdl with (AbsIR (Lim (Cauchy_const (Partition_Sum HfP (contin_imp_inc _ _ _ _ contF))) [-] integral)). 2: apply AbsIR_wd; apply cg_minus_wd; [ apply eq_symmetric_unfolded; apply Lim_const | algebra ]. unfold integral in |- *. apply leEq_wdl with (AbsIR (Lim (Build_CauchySeq _ _ (Cauchy_minus (Cauchy_const (Partition_Sum HfP (contin_imp_inc _ _ _ _ contF))) (Build_CauchySeq _ _ Cauchy_Darboux_Seq))))). 2: apply AbsIR_wd; apply Lim_minus. eapply leEq_wdl. 2: apply Lim_abs. astepr ([0][+]e[*] (b[-]a)); apply shift_leEq_plus; apply approach_zero_weak. intros e' He'. set (ee := e'[/] _[//]max_one_ap_zero (b[-]a)) in *. apply leEq_transitive with (ee[*] (b[-]a)). cut ([0] [<] ee). intro Hee. set (d' := proj1_sig2T _ _ _ (contF' _ Hee)) in *. generalize (proj2b_sig2T _ _ _ (contF' _ Hee)); generalize (proj2a_sig2T _ _ _ (contF' _ Hee)); fold d' in |- *; intros Hd' Hd'0. elim (Archimedes (b[-]a[/] _[//]pos_ap_zero _ _ Hd')); intros k Hk. apply shift_minus_leEq. eapply leEq_wdr. 2: apply cag_commutes_unfolded. apply str_seq_leEq_so_Lim_leEq. exists k; simpl in |- *; intros. unfold integral_seq, Even_Partition_Sum in |- *. apply refinement_lemma with contF He Hee. assumption. fold d' in |- *. eapply less_wdl. 2: apply eq_symmetric_unfolded; apply even_partition_Mesh. apply shift_div_less. apply pos_nring_S. apply shift_less_mult' with (pos_ap_zero _ _ Hd'). assumption. apply leEq_less_trans with (nring (R:=IR) k). assumption. apply nring_less; auto with arith. assumption. red in |- *; do 3 intro. rewrite H0; intros; simpl in |- *; algebra. unfold ee in |- *; apply div_resp_pos. apply pos_max_one. assumption. unfold ee in |- *. rstepl (e'[*] (b[-]a[/] _[//]max_one_ap_zero (b[-]a))). rstepr (e'[*][1]). apply mult_resp_leEq_lft. apply shift_div_leEq. apply pos_max_one. astepr (Max (b[-]a) [1]); apply lft_leEq_Max. apply less_leEq; assumption. apply AbsIR_wd; apply cg_minus_wd. unfold Partition_Sum in |- *. apply Sumx_wd; intros. algebra. algebra. Qed. End Integral_Thm. End Integral. Section Basic_Properties. (** The usual extensionality and strong extensionality results hold. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Notation Integral := (integral _ _ Hab). Section Well_Definedness. Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. Lemma integral_strext : Integral F contF [#] Integral G contG -> {x : IR | I x | forall Hx Hx', F x Hx [#] G x Hx'}. Proof. intro H. unfold integral in H. elim (Lim_ap_imp_seq_ap' _ _ H); intros N HN; clear H. simpl in HN. unfold integral_seq, Even_Partition_Sum, Partition_Sum in HN. set (f' := fun (i : nat) (H : i < S N) => Part F _ (contin_imp_inc _ _ _ _ contF _ (compact_partition_lemma _ _ Hab _ (O_S N) _ (Nat.lt_le_incl _ _ H))) [*] (Even_Partition Hab _ (O_S N) _ H[-] Even_Partition Hab _ (O_S N) i (Nat.lt_le_incl _ _ H))) in *. set (g' := fun (i : nat) (H : i < S N) => Part G _ (contin_imp_inc _ _ _ _ contG _ (compact_partition_lemma _ _ Hab _ (O_S N) _ (Nat.lt_le_incl _ _ H))) [*] (Even_Partition Hab _ (O_S N) _ H[-] Even_Partition Hab _ (O_S N) i (Nat.lt_le_incl _ _ H))) in *. cut (nat_less_n_fun f'); intros. cut (nat_less_n_fun g'); intros. cut (Sumx f' [#] Sumx g'). intros H1. elim (Sumx_strext _ _ _ _ H H0 H1). intros n Hn. elim Hn; clear Hn; intros Hn H'. exists (a[+]nring n[*] (b[-]a[/] nring _[//]nring_ap_zero' _ _ (O_S N))). unfold I in |- *; apply compact_partition_lemma; auto. apply Nat.lt_le_incl; assumption. intros. elim (bin_op_strext_unfolded _ _ _ _ _ _ H'); clear H'; intro. eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply a0. algebra. algebra. exfalso; generalize b0; exact (ap_irreflexive_unfolded _ _). eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply HN. unfold g', Partition_imp_points in |- *; apply Sumx_wd; intros; simpl in |- *; rational. unfold f', Partition_imp_points in |- *; apply Sumx_wd; intros; simpl in |- *; rational. do 3 intro. rewrite H0; unfold g' in |- *; intros; algebra. do 3 intro. rewrite H; unfold f' in |- *; intros; algebra. Qed. Lemma integral_strext' : forall c d Hcd HF1 HF2, integral a b Hab F HF1 [#] integral c d Hcd F HF2 -> a [#] c or b [#] d. Proof. intros c d Hcd HF1 HF2 H. clear contF contG. unfold integral in H. elim (Lim_strext _ _ H). clear H; intros N HN. simpl in HN. unfold integral_seq, Even_Partition_Sum, Partition_Sum in HN. set (f1 := fun (i : nat) (Hi : i < S N) => Part _ _ (contin_imp_inc _ _ _ _ HF1 _ (Pts_part_lemma _ _ _ _ _ _ (Partition_imp_points_1 _ _ _ _ (Even_Partition Hab _ (O_S N))) i Hi)) [*] (Even_Partition Hab _ (O_S N) _ Hi[-] Even_Partition Hab _ (O_S N) _ (Nat.lt_le_incl _ _ Hi))) in *. set (f2 := fun (i : nat) (Hi : i < S N) => Part _ _ (contin_imp_inc _ _ _ _ HF2 _ (Pts_part_lemma _ _ _ _ _ _ (Partition_imp_points_1 _ _ _ _ (Even_Partition Hcd _ (O_S N))) i Hi)) [*] (Even_Partition Hcd _ (O_S N) _ Hi[-] Even_Partition Hcd _ (O_S N) _ (Nat.lt_le_incl _ _ Hi))) in *. cut (nat_less_n_fun f1); intros. cut (nat_less_n_fun f2); intros. elim (Sumx_strext _ _ _ _ H H0 HN). clear H0 H HN; intros i Hi. elim Hi; clear Hi; intros Hi Hi'. unfold f1, f2 in Hi'; clear f1 f2. elim (bin_op_strext_unfolded _ _ _ _ _ _ Hi'); clear Hi'; intro. assert (H := pfstrx _ _ _ _ _ _ a0). clear a0; simpl in H. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); clear H; intro. left; auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ b0); clear b0; intro. exfalso; generalize a0; apply ap_irreflexive_unfolded. elim (div_strext _ _ _ _ _ _ _ b0); clear b0; intro. elim (cg_minus_strext _ _ _ _ _ a0); clear a0; intro. right; auto. left; auto. exfalso; generalize b0; apply ap_irreflexive_unfolded. elim (cg_minus_strext _ _ _ _ _ b0); clear b0; intro. simpl in a0. elim (bin_op_strext_unfolded _ _ _ _ _ _ a0); clear a0; intro. left; auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ b0); clear b0; intro. exfalso; generalize a0; apply ap_irreflexive_unfolded. elim (div_strext _ _ _ _ _ _ _ b0); clear b0; intro. elim (cg_minus_strext _ _ _ _ _ a0); clear a0; intro. right; auto. left; auto. exfalso; generalize b0; apply ap_irreflexive_unfolded. elim (bin_op_strext_unfolded _ _ _ _ _ _ b0); clear b0; intro. left; auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ b0); clear b0; intro. exfalso; generalize a0; apply ap_irreflexive_unfolded. elim (div_strext _ _ _ _ _ _ _ b0); clear b0; intro. elim (cg_minus_strext _ _ _ _ _ a0); clear a0; intro. right; auto. left; auto. elim (bin_op_strext_unfolded _ _ _ _ _ _ b0); clear b0; intro. exfalso; generalize a0; apply ap_irreflexive_unfolded. exfalso; generalize b0; apply ap_irreflexive_unfolded. red in |- *. do 3 intro. rewrite H0; clear H0; intros. unfold f2 in |- *. algebra. red in |- *. do 3 intro. rewrite H; clear H; intros. unfold f1 in |- *. algebra. Qed. Lemma integral_wd : Feq (Compact Hab) F G -> Integral F contF [=] Integral G contG. Proof. intro H. apply not_ap_imp_eq. intro H0. elim (integral_strext H0). intros x H1 H2. elim H; intros H3 H4. inversion_clear H4. generalize (H2 (contin_imp_inc _ _ _ _ contF x H1) (contin_imp_inc _ _ _ _ contG x H1)). apply eq_imp_not_ap. auto. Qed. Lemma integral_wd' : forall a' b' Hab' contF', a [=] a' -> b [=] b' -> Integral F contF [=] integral a' b' Hab' F contF'. Proof. intros. unfold integral in |- *. apply Lim_wd'. intro; simpl in |- *. unfold integral_seq, Even_Partition_Sum, Partition_Sum in |- *. apply Sumx_wd; intros; apply mult_wd. apply pfwdef; simpl in |- *; algebra. simpl in |- *. repeat first [ apply cg_minus_wd | apply bin_op_wd_unfolded | apply mult_wd | apply div_wd ]; algebra. Qed. End Well_Definedness. Section Linearity_and_Monotonicity. Opaque Even_Partition. (** The integral is a linear and monotonous function; in order to prove these facts we also need the important equalities $\int_a^bdx=b-a$#∫abdx=b-a# and $\int_a^af(x)dx=0$#∫aa=0#. *) Lemma integral_one : forall H, Integral ( [-C-] [1]) H [=] b[-]a. Proof. intro. unfold integral in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Lim_const. apply Lim_wd'. intro; simpl in |- *. unfold integral_seq, Even_Partition_Sum, Partition_Sum in |- *. eapply eq_transitive_unfolded. apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= S n) => Even_Partition Hab _ (O_S n) i Hi). red in |- *; intros. apply prf1; auto. intros; simpl in |- *; rational. apply cg_minus_wd; [ apply finish | apply start ]. Qed. Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. Lemma integral_comm_scal : forall (c : IR) Hf', Integral (c{**}F) Hf' [=] c[*]Integral F contF. Proof. intros. apply eq_transitive_unfolded with (Lim (Cauchy_const c) [*]Integral F contF); unfold integral in |- *. eapply eq_transitive_unfolded. 2: apply Lim_mult. apply Lim_wd'; intro; simpl in |- *. unfold integral_seq, Even_Partition_Sum, Partition_Sum in |- *. eapply eq_transitive_unfolded. 2: apply Sumx_comm_scal'. apply Sumx_wd; intros; simpl in |- *; rational. apply mult_wdl. apply eq_symmetric_unfolded; apply Lim_const. Qed. Lemma integral_plus : forall Hfg, Integral (F{+}G) Hfg [=] Integral F contF[+]Integral G contG. Proof. intros. unfold integral in |- *. eapply eq_transitive_unfolded. 2: apply Lim_plus. apply Lim_wd'; intro; simpl in |- *. unfold integral_seq, Even_Partition_Sum, Partition_Sum in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Sumx_plus_Sumx. apply Sumx_wd; intros; simpl in |- *; rational. Qed. Transparent Even_Partition. Lemma integral_empty : a [=] b -> Integral F contF [=] [0]. Proof. intros. unfold integral in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Lim_const. apply Lim_wd'. intros; simpl in |- *. unfold integral_seq, Even_Partition_Sum, Partition_Sum in |- *. apply eq_transitive_unfolded with (Sumx (fun (i : nat) (H : i < S n) => ZeroR)). apply Sumx_wd; intros; simpl in |- *. eapply eq_transitive_unfolded. apply dist_2a. apply x_minus_x. apply mult_wdr. apply bin_op_wd_unfolded. algebra. astepl (nring (S i) [*] (b[-]b[/] _[//]nring_ap_zero' _ _ (O_S n))). astepr (nring i[*] (b[-]b[/] _[//]nring_ap_zero' _ _ (O_S n))). rational. eapply eq_transitive_unfolded. apply sumx_const. algebra. Qed. End Linearity_and_Monotonicity. Section Linearity_and_Monotonicity'. Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. (** %\begin{convention}% Let [alpha, beta : IR] and assume that [h := alpha{**}F{+}beta{**}G] is continuous. %\end{convention}% *) Variables alpha beta : IR. (* begin hide *) Let h := alpha{**}F{+}beta{**}G. (* end hide *) Hypothesis contH : Continuous_I Hab h. Lemma linear_integral : Integral h contH [=] alpha[*]Integral F contF[+]beta[*]Integral G contG. Proof. assert (H : Continuous_I Hab (alpha{**}F)). Contin. assert (H0 : Continuous_I Hab (beta{**}G)). Contin. apply eq_transitive_unfolded with (Integral _ H[+]Integral _ H0). unfold h in |- *. apply integral_plus. apply bin_op_wd_unfolded; apply integral_comm_scal. Qed. Lemma monotonous_integral : (forall x, I x -> forall Hx Hx', F x Hx [<=] G x Hx') -> Integral F contF [<=] Integral G contG. Proof. intros. unfold integral in |- *. apply Lim_leEq_Lim. intro n; simpl in |- *. unfold integral_seq, Even_Partition_Sum, Partition_Sum in |- *. apply Sumx_resp_leEq; intros i Hi. apply mult_resp_leEq_rht. apply H. Opaque nring. unfold I, Partition_imp_points in |- *; simpl in |- *. apply compact_partition_lemma; auto with arith. apply leEq_transitive with (AntiMesh (Even_Partition Hab (S n) (O_S n))). apply AntiMesh_nonneg. apply AntiMesh_lemma. Qed. Transparent nring. End Linearity_and_Monotonicity'. Section Corollaries. Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. (** As corollaries we can calculate integrals of group operations applied to functions. *) Lemma integral_const : forall c H, Integral ( [-C-]c)H [=] c[*] (b[-]a). Proof. intros. assert (H0 : Continuous_I Hab (c{**}[-C-][1])). Contin. apply eq_transitive_unfolded with (Integral _ H0). apply integral_wd; FEQ. eapply eq_transitive_unfolded. apply integral_comm_scal with (contF := Continuous_I_const a b Hab [1]). apply mult_wdr. apply integral_one. Qed. Lemma integral_minus : forall H, Integral (F{-}G) H [=] Integral F contF[-]Integral G contG. Proof. intro. assert (H0 : Continuous_I Hab ([1]{**}F{+}[--][1]{**}G)). Contin. apply eq_transitive_unfolded with (Integral _ H0). apply integral_wd; FEQ. eapply eq_transitive_unfolded. apply linear_integral with (contF := contF) (contG := contG). rational. Qed. Lemma integral_inv : forall H, Integral ( {--}F) H [=] [--] (Integral F contF). Proof. intro. assert (H0 : Continuous_I Hab ([0]{**}F{+}[--][1]{**}F)). Contin. apply eq_transitive_unfolded with (Integral _ H0). apply integral_wd; FEQ. eapply eq_transitive_unfolded. apply linear_integral with (contF := contF) (contG := contF). rational. Qed. (** We can also bound integrals by bounding the integrated functions. *) Lemma lb_integral : forall c, (forall x, I x -> forall Hx, c [<=] F x Hx) -> c[*] (b[-]a) [<=] Integral F contF. Proof. intros. apply leEq_wdl with (Integral _ (Continuous_I_const a b Hab c)). 2: apply integral_const. apply monotonous_integral. simpl in |- *; auto. Qed. Lemma ub_integral : forall c, (forall x, I x -> forall Hx, F x Hx [<=] c) -> Integral F contF [<=] c[*] (b[-]a). Proof. intros. apply leEq_wdr with (Integral _ (Continuous_I_const a b Hab c)). 2: apply integral_const. apply monotonous_integral. simpl in |- *; auto. Qed. Lemma integral_leEq_norm : AbsIR (Integral F contF) [<=] Norm_Funct contF[*] (b[-]a). Proof. simpl in |- *; unfold ABSIR in |- *. apply Max_leEq. apply ub_integral. intros; eapply leEq_transitive. apply leEq_AbsIR. unfold I in |- *; apply norm_bnd_AbsIR; assumption. astepr ( [--][--] (Norm_Funct contF[*] (b[-]a))). astepr ( [--] ( [--] (Norm_Funct contF) [*] (b[-]a))). apply inv_resp_leEq. apply lb_integral. intros; astepr ( [--][--] (Part F x Hx)). apply inv_resp_leEq. eapply leEq_transitive. apply inv_leEq_AbsIR. unfold I in |- *; apply norm_bnd_AbsIR; assumption. Qed. End Corollaries. Section Integral_Sum. (** We now relate the sum of integrals in adjoining intervals to the integral over the union of those intervals. %\begin{convention}% Let [c] be a real number such that $c\in[a,b]$#c∈[a,b]#. %\end{convention}% *) Variable F : PartIR. Variable c : IR. Hypothesis Hac : a [<=] c. Hypothesis Hcb : c [<=] b. Hypothesis Hab' : Continuous_I Hab F. Hypothesis Hac' : Continuous_I Hac F. Hypothesis Hcb' : Continuous_I Hcb F. Section Partition_Join. (** We first prove that every pair of partitions, one of [[a,c]] and another of [[c,b]] defines a partition of [[a,b]] the mesh of which is less or equal to the maximum of the mesh of the original partitions (actually it is equal, but we don't need the other inequality). %\begin{convention}% Let [P,Q] be partitions respectively of [[a,c]] and [[c,b]] with [n] and [m] points. %\end{convention}% *) Variables n m : nat. Variable P : Partition Hac n. Variable Q : Partition Hcb m. (* begin hide *) Lemma partition_join_aux : forall i n m, n < i -> i <= S (n + m) -> i - S n <= m. Proof. intros; lia. Qed. (* end hide *) Definition partition_join_fun : forall i, i <= S (n + m) -> IR. Proof. intros. elim (le_lt_dec i n); intros. apply (P i a0). cut (i - S n <= m); [ intro | apply partition_join_aux; assumption ]. apply (Q _ H0). Defined. (* begin hide *) Lemma pjf_1 : forall (i : nat) Hi Hi', partition_join_fun i Hi [=] P i Hi'. Proof. intros; unfold partition_join_fun in |- *. elim le_lt_dec; intro; simpl in |- *. apply prf1; auto. exfalso; apply Nat.le_ngt with i n; auto. Qed. Lemma pjf_2 : forall (i : nat) Hi, i = n -> partition_join_fun i Hi [=] c. Proof. intros; unfold partition_join_fun in |- *. generalize Hi; clear Hi. rewrite H; clear H; intro. elim le_lt_dec; intro; simpl in |- *. apply finish. exfalso; apply Nat.lt_irrefl with n; auto. Qed. Lemma pjf_2' : forall (i : nat) Hi, i = S n -> partition_join_fun i Hi [=] c. Proof. intros; unfold partition_join_fun in |- *. generalize Hi; clear Hi. rewrite H; clear H; intro. elim le_lt_dec; intro; simpl in |- *. exfalso; apply (Nat.nle_succ_diag_l _ a0). cut (forall H, Q (n - n) H [=] c); auto. cut (n - n = 0); [ intro | auto with arith ]. rewrite H; intros; apply start. Qed. Lemma pjf_3 : forall (i j : nat) Hi Hj, n < i -> j = i - S n -> partition_join_fun i Hi [=] Q j Hj. Proof. intros; unfold partition_join_fun in |- *. generalize Hj; rewrite H0; clear Hj; intros. elim le_lt_dec; intro; simpl in |- *. exfalso; apply Nat.le_ngt with i n; auto. apply prf1; auto. Qed. Lemma partition_join_prf1 : forall i j : nat, i = j -> forall Hi Hj, partition_join_fun i Hi [=] partition_join_fun j Hj. Proof. intros. unfold partition_join_fun in |- *. elim (le_lt_dec i n); elim (le_lt_dec j n); intros; simpl in |- *. apply prf1; auto. exfalso; apply Nat.le_ngt with i n. assumption. rewrite H; assumption. exfalso; apply Nat.le_ngt with j n. assumption. rewrite <- H; assumption. apply prf1; auto. Qed. Lemma partition_join_prf2 : forall (i : nat) H H', partition_join_fun i H [<=] partition_join_fun (S i) H'. Proof. intros. unfold partition_join_fun in |- *. elim (le_lt_dec i n); elim (le_lt_dec (S i) n); intros; simpl in |- *. apply prf2. cut (n = i); [ intro | apply Nat.le_antisymm; auto with arith ]. change (P i a0 [<=] Q (S i - S n) (partition_join_aux _ _ _ b0 H')) in |- *. generalize H' a0 b0; clear H' a0 b0. rewrite <- H0; intros. apply eq_imp_leEq. apply eq_transitive_unfolded with c. apply finish. apply eq_transitive_unfolded with (Q 0 (Nat.le_0_l _)). apply eq_symmetric_unfolded; apply start. apply prf1; auto with arith. exfalso; apply Nat.le_ngt with n i; auto with arith. cut (i - n = S (i - S n)); [ intro | lia ]. cut (S (i - S n) <= m); [ intro | lia ]. apply leEq_wdr with (Q _ H1). apply prf2. apply prf1; auto. Qed. Lemma partition_join_start : forall H, partition_join_fun 0 H [=] a. Proof. intro. unfold partition_join_fun in |- *. elim (le_lt_dec 0 n); intro; simpl in |- *. apply start. exfalso; apply (Nat.nlt_0_r _ b0). Qed. Lemma partition_join_finish : forall H, partition_join_fun (S (n + m)) H [=] b. Proof. intro. unfold partition_join_fun in |- *. elim le_lt_dec; intro; simpl in |- *. exfalso; apply Nat.nle_succ_diag_l with n; apply Nat.le_trans with (S (n + m)); auto with arith. apply eq_transitive_unfolded with (Q _ (le_n _)). apply prf1; auto with arith. apply finish. Qed. Definition partition_join : Partition Hab (S (n + m)). Proof. intros. apply Build_Partition with partition_join_fun. exact partition_join_prf1. exact partition_join_prf2. exact partition_join_start. exact partition_join_finish. Defined. (* end hide *) (** %\begin{convention}% [fP, fQ] are choices of points respecting [P] and [Q]. %\end{convention}% *) Variable fP : forall i : nat, i < n -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Variable fQ : forall i : nat, i < m -> IR. Hypothesis HfQ : Points_in_Partition Q fQ. Hypothesis HfQ' : nat_less_n_fun fQ. (* begin hide *) Lemma partition_join_aux' : forall i n m, n < i -> i < S (n + m) -> i - S n < m. Proof. intros; lia. Qed. (* end hide *) Definition partition_join_pts : forall i, i < S (n + m) -> IR. Proof. intros. elim (le_lt_dec i n); intros. elim (le_lt_eq_dec _ _ a0); intro. apply (fP i a1). apply c. cut (i - S n < m); [ intro | apply partition_join_aux'; assumption ]. apply (fQ _ H0). Defined. (* begin hide *) Lemma pjp_1 : forall (i : nat) Hi Hi', partition_join_pts i Hi [=] fP i Hi'. Proof. intros; unfold partition_join_pts in |- *. elim le_lt_dec; intro; simpl in |- *. elim le_lt_eq_dec; intro; simpl in |- *. algebra. exfalso; rewrite b0 in Hi'; apply (Nat.lt_irrefl _ Hi'). exfalso; apply Nat.le_ngt with i n; auto with arith. Qed. Lemma pjp_2 : forall (i : nat) Hi, i = n -> partition_join_pts i Hi [=] c. Proof. intros; unfold partition_join_pts in |- *. elim le_lt_dec; intro; simpl in |- *. elim le_lt_eq_dec; intro; simpl in |- *. exfalso; rewrite H in a1; apply (Nat.lt_irrefl _ a1). algebra. exfalso; rewrite H in b0; apply (Nat.lt_irrefl _ b0). Qed. Lemma pjp_3 : forall (i : nat) Hi Hi', n < i -> partition_join_pts i Hi [=] fQ (i - S n) Hi'. Proof. intros; unfold partition_join_pts in |- *. elim le_lt_dec; intro; simpl in |- *. exfalso; apply Nat.le_ngt with i n; auto. cut (fQ _ (partition_join_aux' _ _ _ b0 Hi) [=] fQ _ Hi'). 2: apply HfQ'; auto. algebra. Qed. (* end hide *) Lemma partition_join_Pts_in_partition : Points_in_Partition partition_join partition_join_pts. Proof. red in |- *; intros. rename Hi into H. cut (forall H', compact (partition_join i (Nat.lt_le_incl _ _ H)) (partition_join (S i) H) H' (partition_join_pts i H)); auto. unfold partition_join in |- *; simpl in |- *. unfold partition_join_fun in |- *. elim le_lt_dec; elim le_lt_dec; intros; simpl in |- *. elim (le_lt_eq_dec _ _ a1); intro. elim (HfP _ a2); intros. apply compact_wd with (fP i a2). 2: apply eq_symmetric_unfolded; apply pjp_1. split. eapply leEq_wdl. apply a3. apply prf1; auto. eapply leEq_wdr. apply b0. apply prf1; auto. exfalso; clear H'; rewrite b0 in a0; apply (Nat.nle_succ_diag_l _ a0). cut (i = n); [ intro | clear H'; apply Nat.le_antisymm; auto with arith ]. generalize H a0 b0 H'; clear H' a0 b0 H; rewrite H0; intros. apply compact_wd with c. 2: apply eq_symmetric_unfolded; apply pjp_2; auto. split. apply eq_imp_leEq; apply finish. apply eq_imp_leEq; apply eq_symmetric_unfolded. cut (forall H, Q (n - n) H [=] c); auto. cut (n - n = 0); [ intro | auto with arith ]. rewrite H1; intros; apply start. exfalso; apply Nat.le_ngt with n i; auto with arith. elim (HfQ _ (partition_join_aux' _ _ _ b1 H)); intros. apply compact_wd with (fQ _ (partition_join_aux' _ _ _ b1 H)). 2: apply eq_symmetric_unfolded; apply pjp_3; assumption. split. eapply leEq_wdl. apply a0. apply prf1; auto. eapply leEq_wdr. apply b2. apply prf1; rewrite <- Nat.sub_succ_l; auto with arith. Qed. Lemma partition_join_Pts_wd : forall i j, i = j -> forall Hi Hj, partition_join_pts i Hi [=] partition_join_pts j Hj. Proof. intros. elim (le_lt_dec i n); intro. elim (le_lt_eq_dec _ _ a0); intro. cut (j < n); [ intro | rewrite <- H; assumption ]. eapply eq_transitive_unfolded. apply pjp_1 with (Hi' := a1). eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply pjp_1 with (Hi' := H0). apply HfP'; auto. cut (j = n); [ intro | rewrite <- H; assumption ]. eapply eq_transitive_unfolded. apply pjp_2; auto. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply pjp_2; auto. algebra. cut (n < j); [ intro | rewrite <- H; assumption ]. cut (i - S n < m); [ intro | lia ]. cut (j - S n < m); [ intro | lia ]. eapply eq_transitive_unfolded. apply pjp_3 with (Hi' := H1); assumption. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply pjp_3 with (Hi' := H2); assumption. apply HfQ'; auto. Qed. Lemma partition_join_Sum_lemma : Partition_Sum HfP (contin_imp_inc _ _ _ _ Hac') [+] Partition_Sum HfQ (contin_imp_inc _ _ _ _ Hcb') [=] Partition_Sum partition_join_Pts_in_partition (contin_imp_inc _ _ _ _ Hab'). Proof. unfold Partition_Sum in |- *; apply Sumx_weird_lemma. auto with arith. Opaque partition_join. red in |- *; intros; apply mult_wd; algebra; apply cg_minus_wd; apply prf1; auto. red in |- *; intros; apply mult_wd; algebra; apply cg_minus_wd; apply prf1; auto. red in |- *; intros; apply mult_wd; try apply cg_minus_wd; try apply pfwdef; algebra. apply partition_join_Pts_wd; auto. apply prf1; auto. apply prf1; auto. Transparent partition_join. intros; apply mult_wd. apply pfwdef; apply eq_symmetric_unfolded; apply pjp_1. apply cg_minus_wd; simpl in |- *. unfold partition_join_fun in |- *; elim le_lt_dec; simpl in |- *; intro; [ apply prf1; auto | exfalso; apply Nat.le_ngt with n i; auto with arith ]. unfold partition_join_fun in |- *; elim le_lt_dec; simpl in |- *; intro; [ apply prf1; auto | exfalso; apply Nat.le_ngt with i n; auto with arith ]. intros; apply mult_wd. apply pfwdef. cut (i = S (n + i) - S n); [ intro | lia ]. generalize Hi; clear Hi; pattern i at 1 2 in |- *; rewrite H; intro. apply eq_symmetric_unfolded; apply pjp_3; auto with arith. apply cg_minus_wd; simpl in |- *. Opaque minus. unfold partition_join, partition_join_fun in |- *. elim le_lt_dec; simpl in |- *; intro. exfalso; apply Nat.nle_succ_diag_l with n; eapply Nat.le_trans. 2: apply a0. auto with arith. Transparent minus. apply prf1; transitivity (S (n + i) - n); auto with arith. Opaque minus. unfold partition_join, partition_join_fun in |- *. elim le_lt_dec; simpl in |- *; intro. exfalso; apply Nat.nle_succ_diag_l with n; eapply Nat.le_trans. 2: apply a0. auto with arith. Transparent minus. apply prf1; transitivity (n + i - n); auto with arith. intro; apply x_mult_zero. astepr (partition_join _ Hi[-]partition_join _ Hi). apply cg_minus_wd. algebra. unfold partition_join in |- *; simpl in |- *. apply eq_transitive_unfolded with c; unfold partition_join_fun in |- *; elim le_lt_dec; simpl in |- *. intro; apply finish. intro; exfalso; apply (Nat.lt_irrefl _ b0). intro; exfalso; apply (Nat.nle_succ_diag_l _ a0). intro; apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (Q _ (Nat.le_0_l _)). apply prf1; auto with arith. apply start. Qed. Lemma partition_join_mesh : Mesh partition_join [<=] Max (Mesh P) (Mesh Q). Proof. unfold Mesh at 1 in |- *. apply maxlist_leEq. apply length_Part_Mesh_List. apply Nat.lt_0_succ. intros x H. elim (Part_Mesh_List_lemma _ _ _ _ _ _ H); intros i Hi. elim Hi; clear Hi; intros Hi Hi'. elim Hi'; clear Hi'; intros Hi' Hx. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Hx. unfold partition_join in |- *; simpl in |- *. unfold partition_join_fun in |- *. elim le_lt_dec; intro; simpl in |- *. elim le_lt_dec; intro; simpl in |- *. eapply leEq_transitive. apply Mesh_lemma. apply lft_leEq_Max. exfalso; apply Nat.le_ngt with i n; auto with arith. elim le_lt_dec; intro; simpl in |- *. cut (i = n); [ intro | apply Nat.le_antisymm; auto with arith ]. generalize a0 b0 Hi'; clear Hx Hi Hi' a0 b0. rewrite H0; intros. apply leEq_wdl with ZeroR. eapply leEq_transitive. 2: apply lft_leEq_Max. apply Mesh_nonneg. astepl (c[-]c). apply eq_symmetric_unfolded; apply cg_minus_wd. cut (forall H, Q (n - n) H [=] c); auto. cut (n - n = 0); [ intro | auto with arith ]. rewrite H1; intros; apply start. apply finish. cut (i - n = S (i - S n)); [ intro | lia ]. cut (forall H, Q (i - n) H[-]Q _ (partition_join_aux _ _ _ b1 Hi) [<=] Max (Mesh P) (Mesh Q)); auto. rewrite H0; intros; eapply leEq_transitive. apply Mesh_lemma. apply rht_leEq_Max. Qed. End Partition_Join. (** With these results in mind, the following is a trivial consequence: *) Lemma integral_plus_integral : integral _ _ Hac _ Hac'[+]integral _ _ Hcb _ Hcb' [=] Integral _ Hab'. Proof. unfold integral at 1 2 in |- *. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply Lim_plus. apply cg_inv_unique_2. apply AbsIR_approach_zero. intros e' He'. set (e := e'[/] _[//]max_one_ap_zero (b[-]a)) in *. cut ([0] [<] e). intro He. set (d := proj1_sig2T _ _ _ (contin_prop _ _ _ _ Hab' e He)) in *. generalize (proj2b_sig2T _ _ _ (contin_prop _ _ _ _ Hab' e He)); generalize (proj2a_sig2T _ _ _ (contin_prop _ _ _ _ Hab' e He)). fold d in |- *; intros Hd Haux. clear Haux. apply leEq_transitive with (e[*] (b[-]a)). elim (Archimedes (b[-]c[/] _[//]pos_ap_zero _ _ Hd)); intros n1 Hn1. elim (Archimedes (c[-]a[/] _[//]pos_ap_zero _ _ Hd)); intros n2 Hn2. apply leEq_wdl with (Lim (Build_CauchySeq _ _ (Cauchy_abs (Build_CauchySeq _ _ (Cauchy_plus (Build_CauchySeq _ _ (Cauchy_plus (Build_CauchySeq _ _ (Cauchy_Darboux_Seq _ _ Hac _ Hac')) (Build_CauchySeq _ _ (Cauchy_Darboux_Seq _ _ Hcb _ Hcb')))) (Cauchy_const [--] (Integral _ Hab'))))))). apply str_seq_leEq_so_Lim_leEq. set (p := Nat.max n1 n2) in *; exists p; intros. astepl (AbsIR (integral_seq _ _ Hac _ Hac' i[+]integral_seq _ _ Hcb _ Hcb' i[-] Integral _ Hab')). unfold integral_seq, Even_Partition_Sum in |- *. set (EP1 := Even_Partition Hac (S i) (O_S i)) in *. set (EP2 := Even_Partition Hcb (S i) (O_S i)) in *. set (P := partition_join _ _ EP1 EP2) in *. cut (nat_less_n_fun (Partition_imp_points _ _ _ _ EP1)); [ intro | apply Partition_imp_points_2 ]. cut (nat_less_n_fun (Partition_imp_points _ _ _ _ EP2)); [ intro | apply Partition_imp_points_2 ]. apply leEq_wdl with (AbsIR (Partition_Sum (partition_join_Pts_in_partition _ _ _ _ _ (Partition_imp_points_1 _ _ _ _ EP1) H0 _ (Partition_imp_points_1 _ _ _ _ EP2) H1) (contin_imp_inc _ _ _ _ Hab') [-]Integral _ Hab')). apply partition_Sum_conv_integral with He; fold d in |- *. eapply leEq_less_trans. apply partition_join_mesh. apply Max_less. unfold EP1 in |- *; eapply less_wdl. 2: apply eq_symmetric_unfolded; apply even_partition_Mesh. apply swap_div with (pos_ap_zero _ _ Hd). apply pos_nring_S. assumption. apply leEq_less_trans with (nring (R:=IR) n2). assumption. apply nring_less. apply Nat.le_lt_trans with p. unfold p in |- *; apply Nat.le_max_r. auto with arith. unfold EP2 in |- *; eapply less_wdl. 2: apply eq_symmetric_unfolded; apply even_partition_Mesh. apply swap_div with (pos_ap_zero _ _ Hd). apply pos_nring_S. assumption. apply leEq_less_trans with (nring (R:=IR) n1). assumption. apply nring_less. apply Nat.le_lt_trans with p. unfold p in |- *; apply Nat.le_max_l. auto with arith. red in |- *; do 3 intro. rewrite H2; clear H2; intros. apply partition_join_Pts_wd; auto. apply AbsIR_wd. apply cg_minus_wd. 2: algebra. apply eq_symmetric_unfolded. unfold Partition_Sum in |- *; apply Sumx_weird_lemma. auto. red in |- *; do 3 intro. rewrite H2; clear H2; intros; algebra. red in |- *; do 3 intro. rewrite H2; clear H2; intros; algebra. red in |- *; do 3 intro. rewrite H2; clear H2; intros; algebra. Opaque Even_Partition. intros; apply mult_wd. apply pfwdef; unfold partition_join_pts in |- *. elim le_lt_dec; intro; simpl in |- *. elim le_lt_eq_dec; intro; simpl in |- *. apply Partition_imp_points_2; auto. exfalso; rewrite b0 in Hi; apply (Nat.lt_irrefl _ Hi). exfalso; apply Nat.le_ngt with i0 (S i); auto with arith. apply cg_minus_wd; simpl in |- *. apply eq_symmetric_unfolded; apply pjf_1. apply eq_symmetric_unfolded; apply pjf_1. intros; apply mult_wd. apply pfwdef; unfold Partition_imp_points in |- *. unfold partition_join_pts in |- *. elim le_lt_dec; intro; simpl in |- *. elim le_lt_eq_dec; intro; simpl in |- *. exfalso; apply Nat.nle_succ_diag_l with (S i); eapply Nat.le_trans. 2: apply a0. auto with arith. exfalso; apply Nat.lt_irrefl with (S i); pattern (S i) at 2 in |- *; rewrite <- b0; auto with arith. unfold Partition_imp_points in |- *; apply prf1. auto with arith. apply cg_minus_wd; simpl in |- *. apply eq_symmetric_unfolded; apply pjf_3; [ auto with arith | lia ]. apply eq_symmetric_unfolded; apply pjf_3; auto with arith. intro; apply x_mult_zero. astepr (c[-]c). apply cg_minus_wd. simpl in |- *; apply pjf_2'; auto. simpl in |- *; apply pjf_2; auto. eapply eq_transitive_unfolded. apply Lim_abs. apply AbsIR_wd. unfold cg_minus in |- *. eapply eq_transitive_unfolded. apply Lim_plus. apply bin_op_wd_unfolded. algebra. apply eq_symmetric_unfolded; apply Lim_const. unfold e in |- *. rstepl (e'[*] (b[-]a) [/] _[//]max_one_ap_zero (b[-]a)). apply shift_div_leEq. apply pos_max_one. apply mult_resp_leEq_lft. apply lft_leEq_Max. apply less_leEq; assumption. unfold e in |- *. apply div_resp_pos. apply pos_max_one. assumption. Qed. End Integral_Sum. Transparent Even_Partition. End Basic_Properties. (** The following are simple consequences of this result and of previous ones. *) Lemma integral_less_norm : forall a b Hab (F : PartIR) contF, let N := Norm_Funct contF in a [<] b -> forall x, Compact Hab x -> forall Hx, AbsIR (F x Hx) [<] N -> AbsIR (integral a b Hab F contF) [<] N[*] (b[-]a). Proof. (* begin hide *) intros a b Hab F contF N Hless x H Hx H0. set (e := (N[-]AbsIR (F x Hx)) [/]TwoNZ) in *. cut ([0] [<] e); intros. 2: unfold e in |- *; apply pos_div_two; apply shift_less_minus. 2: astepl (AbsIR (F x Hx)); auto. elim (contin_prop _ _ _ _ contF e); auto. intros d H2 H3. set (mid1 := Max a (x[-]d)) in *. set (mid2 := Min b (x[+]d)) in *. cut (a [<=] mid1); [ intro leEq1 | unfold mid1 in |- *; apply lft_leEq_Max ]. cut (mid1 [<=] mid2); [ intro leEq2 | unfold mid1, mid2 in |- *; inversion_clear H; apply leEq_transitive with x ]. 2: apply Max_leEq; auto. 2: apply less_leEq; apply shift_minus_less. 2: apply shift_less_plus'; astepl ZeroR; auto. 2: apply leEq_Min; auto. 2: apply less_leEq; apply shift_less_plus'. 2: astepl ZeroR; auto. cut (mid2 [<=] b); [ intro leEq3 | unfold mid2 in |- *; apply Min_leEq_lft ]. cut (Continuous_I leEq1 F). cut (Continuous_I leEq2 F). cut (Continuous_I leEq3 F). intros cont3 cont2 cont1. cut (Continuous_I (leEq_transitive _ _ _ _ leEq1 leEq2) F). intro H4. apply less_wdl with (AbsIR (integral _ _ _ _ cont1[+]integral _ _ _ _ cont2[+] integral _ _ _ _ cont3)). 2: apply AbsIR_wd. 2: apply eq_transitive_unfolded with (integral _ _ _ _ H4[+]integral _ _ _ _ cont3). 2: apply bin_op_wd_unfolded. 2: apply integral_plus_integral. 2: algebra. 2: apply integral_plus_integral. rstepr (N[*] (mid1[-]a) [+]N[*] (mid2[-]mid1) [+]N[*] (b[-]mid2)). eapply leEq_less_trans. apply triangle_IR. apply plus_resp_less_leEq. eapply leEq_less_trans. apply triangle_IR. apply plus_resp_leEq_less. eapply leEq_transitive. apply integral_leEq_norm. unfold N in |- *; apply mult_resp_leEq_rht. 2: apply shift_leEq_minus; astepl a; auto. apply included_imp_norm_leEq. apply included_compact. apply compact_inc_lft. split. unfold mid1 in |- *; apply lft_leEq_Max. apply leEq_transitive with mid2; auto. 2: eapply leEq_transitive. 2: apply integral_leEq_norm. 2: unfold N in |- *; apply mult_resp_leEq_rht. 3: apply shift_leEq_minus; astepl mid2; auto. 2: apply included_imp_norm_leEq. 2: apply included_compact. 2: split. 2: apply leEq_transitive with mid1; auto. 2: auto. 2: apply compact_inc_rht. eapply leEq_less_trans. apply integral_leEq_norm. apply mult_resp_less. apply leEq_less_trans with (N[-]e). 2: apply shift_minus_less; apply shift_less_plus'. 2: astepl ZeroR; auto. apply leEq_Norm_Funct; intros y Hy Hy'. apply leEq_wdr with (AbsIR (F x Hx) [+]e). 2: unfold e in |- *; rational. apply AbsIR_bnd_AbsIR. apply H3; auto. cut (included (Compact leEq2) (Compact Hab)); auto. apply included_compact. split; auto. apply leEq_transitive with mid2; auto. split; auto. apply leEq_transitive with mid1; auto. cut (x[-]d [<=] x[+]d). intro H5. apply compact_bnd_AbsIR with H5. cut (included (Compact leEq2) (Compact H5)); auto. apply included_compact; unfold mid1, mid2 in |- *; split. apply rht_leEq_Max. apply leEq_transitive with mid2; auto. unfold mid2 in |- *; apply Min_leEq_rht. apply leEq_transitive with mid1; auto. unfold mid1 in |- *; apply rht_leEq_Max. apply Min_leEq_rht. apply leEq_transitive with x. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. unfold mid2, mid1 in |- *. astepl (x[-]x). unfold cg_minus at 1 2 in |- *. inversion_clear H. elim (less_cotransitive_unfolded _ _ _ Hless x); intro. apply plus_resp_leEq_less. apply leEq_Min; auto. apply shift_leEq_plus'; astepl ZeroR; apply less_leEq; auto. apply inv_resp_less; apply Max_less; auto. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; auto. apply plus_resp_less_leEq. apply less_Min; auto. apply shift_less_plus'; astepl ZeroR; auto. apply inv_resp_leEq; apply Max_leEq; auto. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply included_imp_contin with a b Hab; auto. apply included_compact. apply compact_inc_lft. split; auto. apply leEq_transitive with mid1; auto. apply included_imp_contin with a b Hab; auto. apply included_compact. split; auto. apply leEq_transitive with mid1; auto. apply compact_inc_rht. apply included_imp_contin with a b Hab; auto. apply included_compact. split; auto. apply leEq_transitive with mid2; auto. split; auto. apply leEq_transitive with mid1; auto. apply included_imp_contin with a b Hab; auto. apply included_compact. apply compact_inc_lft. split; auto. apply leEq_transitive with mid2; auto. Qed. (* end hide *) Lemma integral_gt_zero : forall a b Hab (F : PartIR) contF, let N := Norm_Funct contF in a [<] b -> forall x, Compact Hab x -> forall Hx, [0] [<] F x Hx -> (forall x, Compact Hab x -> forall Hx, [0] [<=] F x Hx) -> [0] [<] integral a b Hab F contF. Proof. (* begin hide *) intros a b Hab F contF N Hless x H Hx H0. set (e := F x Hx [/]TwoNZ) in *. cut ([0] [<] e). intros H1 H2. 2: unfold e in |- *; apply pos_div_two; auto. elim (contin_prop _ _ _ _ contF e); auto. intros d H3 H4. set (mid1 := Max a (x[-]d)) in *. set (mid2 := Min b (x[+]d)) in *. cut (a [<=] mid1); [ intro leEq1 | unfold mid1 in |- *; apply lft_leEq_Max ]. cut (mid1 [<=] mid2); [ intro leEq2 | unfold mid1, mid2 in |- *; inversion_clear H; apply leEq_transitive with x ]. 2: apply Max_leEq; auto. 2: apply less_leEq; apply shift_minus_less. 2: apply shift_less_plus'; astepl ZeroR; auto. 2: apply leEq_Min; auto. 2: apply less_leEq; apply shift_less_plus'. 2: astepl ZeroR; auto. cut (mid2 [<=] b); [ intro leEq3 | unfold mid2 in |- *; apply Min_leEq_lft ]. cut (Continuous_I leEq1 F). cut (Continuous_I leEq2 F). cut (Continuous_I leEq3 F). intros cont3 cont2 cont1. cut (Continuous_I (leEq_transitive _ _ _ _ leEq1 leEq2) F). intro H5. apply less_wdr with (integral _ _ _ _ cont1[+]integral _ _ _ _ cont2[+]integral _ _ _ _ cont3). 2: apply eq_transitive_unfolded with (integral _ _ _ _ H5[+]integral _ _ _ _ cont3). 2: apply bin_op_wd_unfolded. 2: apply integral_plus_integral. 2: algebra. 2: apply integral_plus_integral. rstepl ([0][*] (mid1[-]a) [+][0][*] (mid2[-]mid1) [+][0][*] (b[-]mid2)). apply plus_resp_less_leEq. apply plus_resp_leEq_less. apply lb_integral. intros x0 H6 Hx0. apply H2. inversion_clear H6; split; auto. apply leEq_transitive with mid1; auto. apply leEq_transitive with mid2; auto. apply less_leEq_trans with (F x Hx [/]TwoNZ[*] (mid2[-]mid1)). apply mult_resp_less. apply pos_div_two; auto. apply shift_less_minus; astepl mid1. elim (less_cotransitive_unfolded _ _ _ Hless x); intro; unfold mid1, mid2 in |- *. apply less_leEq_trans with x. apply Max_less. auto. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; auto. apply leEq_Min. inversion_clear H; auto. apply less_leEq; apply shift_less_plus'. astepl ZeroR; auto. apply leEq_less_trans with x. apply Max_leEq. inversion_clear H; auto. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply less_Min. auto. apply shift_less_plus'. astepl ZeroR; auto. apply lb_integral. intros x0 H6 Hx0. rstepl (F x Hx[-]F x Hx [/]TwoNZ). apply shift_minus_leEq; apply shift_leEq_plus'. fold e in |- *; eapply leEq_transitive; [ apply leEq_AbsIR | apply H4 ]. auto. inversion_clear H6; split; auto. apply leEq_transitive with mid1; auto. apply leEq_transitive with mid2; auto. cut (x[-]d [<=] x[+]d); intros. apply compact_bnd_AbsIR with H7. cut (included (Compact leEq2) (Compact H7)); auto. apply included_compact; unfold mid1, mid2 in |- *; split. apply rht_leEq_Max. apply leEq_transitive with mid2; auto. unfold mid2 in |- *; apply Min_leEq_rht. apply leEq_transitive with mid1; auto. unfold mid1 in |- *; apply rht_leEq_Max. apply Min_leEq_rht. apply leEq_transitive with x. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply lb_integral. intros x0 H6 Hx0. apply H2. inversion_clear H6; split; auto. apply leEq_transitive with mid1; auto. apply leEq_transitive with mid2; auto. apply included_imp_contin with a b Hab; auto. apply included_compact. apply compact_inc_lft. split; auto. apply leEq_transitive with mid1; auto. apply included_imp_contin with a b Hab; auto. apply included_compact. split; auto. apply leEq_transitive with mid1; auto. apply compact_inc_rht. apply included_imp_contin with a b Hab; auto. apply included_compact. split; auto. apply leEq_transitive with mid2; auto. split; auto. apply leEq_transitive with mid1; auto. apply included_imp_contin with a b Hab; auto. apply included_compact. apply compact_inc_lft. split; auto. apply leEq_transitive with mid2; auto. Qed. (* end hide *) (** remove printing Integral *) corn-8.20.0/ftc/IntegrationRules.v000066400000000000000000000237141473720167500170260ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.ftc.FTC. Require Export CoRN.ftc.Composition. (** ** Integration by substitution Here we prove integration by substition. Simply put, this lemma shows that int((F[o]G)*G', a .. b) = int(F, G(a) .. G(b)), assuming that G is differentiable on [[c, d]] and that F is continuous on [[c0, d0]] and that G maps compact intervals into [[c0, d0]]. *) Lemma IntegrationBySubstition : forall a b (Hab: Min a b[<=]Max a b) c d (Hcd: c[<]d) (Habcd: included (Compact Hab) (Compact (less_leEq _ _ _ Hcd))) G (HGa: Dom G a) (HGb: Dom G b) G' (HGG': Derivative_I Hcd G G') (HGaGb: Min (G a HGa) (G b HGb)[<=]Max (G a HGa) (G b HGb)) F c0 d0 (Hc0d0: c0[<=]d0) (HGF: maps_into_compacts G F _ _ Hab _ _ Hc0d0) (HFG: Continuous_I Hab ((F[o]G){*}G')) (HF: Continuous_I HGaGb F) (HFc0d0: Continuous_I Hc0d0 F), Integral HFG[=]Integral HF. Proof. intros. assert(X1:=leEq_less_or_equal _ _ _ Hab). apply not_ap_imp_eq. intros X0. apply X1. clear X1. intros X1. revert X0. apply (eq_imp_not_ap). destruct X1 as [X1|X1]. assert(X:=leEq_less_or_equal _ _ _ Hc0d0). apply not_ap_imp_eq. intros X0. apply X. clear X. intros X. revert X0. apply (eq_imp_not_ap). destruct X as [X|X]. set (J:=clcr c0 d0). assert (HFJ:Continuous J F). eapply (Continuous_Int J Hc0d0 Hc0d0); apply HFc0d0. assert (Jc0:J c0). split. apply leEq_reflexive. assumption. set (F0:=([-S-]HFJ) _ Jc0). assert (dF : Derivative J X F0 F). unfold F0; apply FTC1. apply eq_symmetric. assert (HF':Continuous_I (Min_leEq_Max (G a HGa) (G b HGb)) F). Contin. apply eq_transitive with (Integral HF'). apply Integral_wd'; apply eq_reflexive. set (FGx:=Derivative_imp_inc J X F0 F dF). assert (JGa:J (G a HGa)). destruct HGF as [HGF0 HGF1]. change (Compact Hc0d0 (G a HGa)). apply HGF1. apply compact_Min_lft. assert (JGb:J (G b HGb)). destruct HGF as [HGF0 HGF1]. change (Compact Hc0d0 (G b HGb)). apply HGF1. apply compact_Min_rht. apply eq_transitive with ((F0 (G b HGb) (FGx _ JGb))[-](F0 (G a HGa) (FGx _ JGa))). unfold FGx. apply Barrow. apply HFJ. apply eq_symmetric. assert (HFG':Continuous_I (Min_leEq_Max a b) ((F[o]G){*}G')). Contin. apply eq_transitive with (Integral HFG'). apply Integral_wd'; apply eq_reflexive. set (I:=clcr (Min a b) (Max a b)). assert (dFG:Derivative I X1 (F0[o]G) ((F[o]G){*}G')). apply (Derivative_Int I Hab X1 X1). assert (dF0 : Derivative_I X F0 F). apply (Int_Derivative J Hc0d0 X). assumption. eapply Derivative_I_comp. eapply (included_imp_deriv _ _ Hcd). apply Habcd. apply HGG'. apply dF0. destruct HGF as [HGF0 HGF1]. split. Included. exact HGF1. set (HFGx := Derivative_imp_inc I X1 _ _ dFG). stepr (((F0[o]G) b (HFGx b (compact_Min_rht _ _ Hab)))[-] ((F0[o]G) a (HFGx a (compact_Min_lft _ _ Hab)))). unfold HFGx. apply Barrow. eapply (Continuous_Int I Hab Hab). apply HFG. generalize (HFGx a (compact_Min_lft a b Hab)) (HFGx b (compact_Min_rht a b Hab)). generalize (FGx (G b HGb) JGb) (FGx (G a HGa) JGa). generalize F0 G HGb HGa. clear -a b. intros F G p1 p2 p3 p4 p5 p6. simpl. algebra. assert (Y:G a HGa[=]G b HGb). destruct HGF as [HGF0 HGF1]. apply leEq_imp_eq. apply leEq_transitive with d0. destruct (HGF1 _ HGa (compact_Min_lft _ _ Hab)); assumption. stepl c0; [| assumption]. destruct (HGF1 _ HGb (compact_Min_rht _ _ Hab)); assumption. apply leEq_transitive with d0. destruct (HGF1 _ HGb (compact_Min_rht _ _ Hab)); assumption. stepl c0; [| assumption]. destruct (HGF1 _ HGa (compact_Min_lft _ _ Hab)); assumption. stepl ([0]:IR). apply eq_symmetric; apply Integral_empty. assumption. assert (Z:(Continuous_I Hab [-C-][0])). Contin. stepr (Integral Z). rstepl ([0][*](b[-]a)). apply eq_symmetric. apply Integral_const. apply Integral_wd. FEQ. simpl. simpl in Hx'. apply eq_symmetric. apply x_mult_zero. change ([0]:IR) with ([-C-][0] x I). apply Feq_imp_eq with (I:=Compact (less_leEq _ _ _ X1)); auto. apply Derivative_I_unique with G. eapply included_imp_deriv;[|apply HGG']. auto. apply Derivative_I_wdl with ([-C-](G a HGa)); [|apply Derivative_I_const]. FEQ. eapply included_trans. apply Habcd. eapply derivative_imp_inc. apply HGG'. rename H0 into X2. destruct HGF as [HGF0 HGF1]. simpl. apply leEq_imp_eq. apply leEq_transitive with d0. destruct (HGF1 _ HGa (compact_Min_lft _ _ Hab)); assumption. stepl c0; [| assumption]. destruct (HGF1 _ Hx'0 X2); assumption. apply leEq_transitive with d0. destruct (HGF1 _ Hx'0 X2); assumption. stepl c0; [| assumption]. destruct (HGF1 _ HGa (compact_Min_lft _ _ Hab)); assumption. assert (Hab':a[=]b). apply not_ap_imp_eq. intros X0. apply (eq_imp_not_ap _ _ _ X1). apply less_imp_ap. apply ap_imp_Min_less_Max. assumption. apply eq_transitive with ([0]:IR). apply Integral_empty. assumption. apply eq_symmetric. apply Integral_empty. algebra. Qed. (** This lemma is a special instance of substituion that ties integration on [[0, 1]] with general integration on [[a, b]]. It says that int(F((b-a)*x+a), x=0 .. 1) = int(F, a .. b). *) Lemma IntegrationSubs01 : forall a b (Hab: Min a b[<=]Max a b) (H01: [0][<=][1]) F (HFG: Continuous_I H01 ((F[o]([-C-](b[-]a){*}(Fid IR){+}[-C-]a)))) (HF: Continuous_I Hab F), (b[-]a)[*]integral _ _ _ _ HFG[=]Integral HF. Proof. intros. assert (HFG0:Continuous_I (a:=[0]) (b:=[1]) H01 ((b[-]a){**}(F[o][-C-](b[-]a){*}FId{+}[-C-]a))). Contin. stepr (integral _ _ _ _ HFG0). apply eq_symmetric. apply integral_comm_scal. assert (HFG1:Continuous_I (a:=[0]) (b:=[1]) H01 ((F[o][-C-](b[-]a){*}FId{+}[-C-]a){*}[-C-](b[-]a))). Contin. stepr (integral _ _ _ _ HFG1). apply integral_wd. FEQ. assert (H01':Min [0] [1][<=]Max [0] [1]). apply Min_leEq_Max. assert (HFG2:Continuous_I H01' ((F[o][-C-](b[-]a){*}FId{+}[-C-]a){*}[-C-](b[-]a))). apply (included_imp_contin _ _ H01). apply included2_compact. apply compact_inc_lft. apply compact_inc_rht. assumption. stepr (Integral HFG2). apply eq_symmetric. apply Integral_integral. clear - H01. set (G:=[-C-](b[-]a){*}FId{+}[-C-]a) in *. assert (HG0 : Dom G [0]). repeat constructor. assert (HG1 : Dom G [1]). repeat constructor. assert (Hab':Min (G [0] HG0) (G [1] HG1)[<=]Max (G [0] HG0) (G [1] HG1)). apply Min_leEq_Max. assert (HF':Continuous_I Hab' F). apply (included_imp_contin _ _ Hab). unfold G. apply included2_compact. apply (compact_wd _ _ Hab a). apply compact_Min_lft. simpl. rational. apply (compact_wd _ _ Hab b). apply compact_Min_rht. simpl. rational. assumption. stepl (Integral HF'). apply Integral_wd'; simpl; rational. apply eq_symmetric. assert (X:included (Compact H01') (Compact (less_leEq _ _ _ (pos_one IR)))). apply included2_compact. apply compact_inc_lft. apply compact_inc_rht. eapply (IntegrationBySubstition). apply X. unfold G. New_Deriv. apply Feq_reflexive. repeat constructor. apply (included_Feq (Compact (less_leEq IR [0] [1] (pos_one IR))) realline). repeat constructor. FEQ. split. apply contin_imp_inc. apply HF'. intros x Hx [H0 H1]. assert (H0':[0][<=]x). stepl (Min [0] [1]);[assumption|]. apply leEq_imp_Min_is_lft. apply (less_leEq _ _ _ (pos_one IR)). assert (H1':x[<=][1]). stepr (Max [0] [1]);[assumption|]. apply leEq_imp_Max_is_rht. apply (less_leEq _ _ _ (pos_one IR)). unfold G. simpl. split. stepl (Min a b); [| apply MIN_wd; rational]. assert (Z:=leEq_or_leEq _ a b). rewrite -> leEq_def. intros Z0. apply Z. clear Z. intros Z. revert Z0. change (Not ((b[-]a)[*]x[+]a[<]Min a b)). rewrite <- leEq_def. destruct Z. stepl a; [| apply eq_symmetric; apply leEq_imp_Min_is_lft; auto]. apply shift_leEq_plus. rstepl ([0]:IR). apply mult_resp_nonneg; auto. apply shift_leEq_lft. assumption. stepl (Min b a); [| apply Min_comm]. stepl b; [| apply eq_symmetric; apply leEq_imp_Min_is_lft; auto]. apply shift_leEq_plus. apply shift_leEq_rht. rstepr ((a[-]b)[*]([1][-]x)). apply mult_resp_nonneg; apply shift_leEq_lft; assumption. stepr (Max a b); [| apply MAX_wd;rational]. assert (Z:=leEq_or_leEq _ a b). rewrite -> leEq_def. intros Z0. apply Z. clear Z. intros Z. revert Z0. change (Not (Max a b[<](b[-]a)[*]x[+]a)). rewrite <- leEq_def. destruct Z. stepr b; [| apply eq_symmetric; apply leEq_imp_Max_is_rht; auto]. apply shift_plus_leEq. apply shift_leEq_rht. rstepr ((b[-]a)[*]([1][-]x)). apply mult_resp_nonneg; apply shift_leEq_lft; assumption. stepr (Max b a); [| apply Max_comm]. stepr a; [| apply eq_symmetric; apply leEq_imp_Max_is_rht; auto]. apply shift_plus_leEq. rstepr ([0]:IR). apply shift_leEq_rht. rstepr ((a[-]b)[*]x). apply mult_resp_nonneg; auto. apply shift_leEq_lft. assumption. assumption. Qed. corn-8.20.0/ftc/IntervalFunct.v000066400000000000000000000163211473720167500163100ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.PartFunEquality. Section Operations. (** * Functions with compact domain In this section we concern ourselves with defining operations on the set of functions from an arbitrary interval [[a,b]] to [IR]. Although these are a particular kind of partial function, they have the advantage that, given [a] and [b], they have type [Set] and can thus be quantified over and extracted from existential hypothesis. This will be important when we want to define concepts like differentiability, which involve the existence of an object satisfying some given properties. Throughout this section we will focus on a compact interval and define operators analogous to those we already have for arbitrary partial functions. %\begin{convention}% Let [a,b] be real numbers and denote by [I] the compact interval [[a,b]]. Let [f, g] be setoid functions of type [I -> IR]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables f g : CSetoid_fun (subset I) IR. Section Const. (** Constant and identity functions are defined. %\begin{convention}% Let [c:IR]. %\end{convention}% *) Variable c : IR. Lemma IConst_strext : forall x y : subset I, c [#] c -> x [#] y. Proof. intros x y H. elim (ap_irreflexive_unfolded _ c H). Qed. Definition IConst := Build_CSetoid_fun _ _ (fun x => c) IConst_strext. End Const. Lemma IId_strext : forall x y : subset I, scs_elem _ _ x [#] scs_elem _ _ y -> x [#] y. Proof. intros x y; case x; case y; intros; algebra. Qed. Definition IId := Build_CSetoid_fun _ _ _ IId_strext. (** Next, we define addition, algebraic inverse, subtraction and product of functions. *) Lemma IPlus_strext : forall x y : subset I, f x[+]g x [#] f y[+]g y -> x [#] y. Proof. intros x y H. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); intro H0; exact (csf_strext_unfolded _ _ _ _ _ H0). Qed. Definition IPlus := Build_CSetoid_fun _ _ (fun x => f x[+]g x) IPlus_strext. Lemma IInv_strext : forall x y : subset I, [--] (f x) [#] [--] (f y) -> x [#] y. Proof. intros x y H. generalize (un_op_strext_unfolded _ _ _ _ H); intro H0. exact (csf_strext_unfolded _ _ _ _ _ H0). Qed. Definition IInv := Build_CSetoid_fun _ _ (fun x => [--] (f x)) IInv_strext. Lemma IMinus_strext : forall x y : subset I, f x[-]g x [#] f y[-]g y -> x [#] y. Proof. intros x y H. elim (cg_minus_strext _ _ _ _ _ H); intro H0; exact (csf_strext_unfolded _ _ _ _ _ H0). Qed. Definition IMinus := Build_CSetoid_fun _ _ (fun x => f x[-]g x) IMinus_strext. Lemma IMult_strext : forall x y : subset I, f x[*]g x [#] f y[*]g y -> x [#] y. Proof. intros x y H. elim (bin_op_strext_unfolded _ _ _ _ _ _ H); intro H0; exact (csf_strext_unfolded _ _ _ _ _ H0). Qed. Definition IMult := Build_CSetoid_fun _ _ (fun x => f x[*]g x) IMult_strext. Section Nth_Power. (** Exponentiation to a natural power [n] is also useful. *) Variable n : nat. Lemma INth_strext : forall x y : subset I, f x[^]n [#] f y[^]n -> x [#] y. Proof. intros. apply csf_strext_unfolded with (IR:CSetoid) f. apply nexp_strext with n; assumption. Qed. Definition INth := Build_CSetoid_fun _ _ (fun x => f x[^]n) INth_strext. End Nth_Power. (** If a function is non-zero in all the interval then we can define its multiplicative inverse. *) Section Recip_Div. (* begin show *) Hypothesis Hg : forall x : subset I, g x [#] [0]. (* end show *) Lemma IRecip_strext : forall x y : subset I, ([1][/] g x[//]Hg x) [#] ([1][/] g y[//]Hg y) -> x [#] y. Proof. intros x y H. elim (div_strext _ _ _ _ _ _ _ H); intro H0. elim (ap_irreflexive_unfolded _ _ H0). exact (csf_strext_unfolded _ _ _ _ _ H0). Qed. Definition IRecip := Build_CSetoid_fun _ _ (fun x => [1][/] g x[//]Hg x) IRecip_strext. Lemma IDiv_strext : forall x y : subset I, (f x[/] g x[//]Hg x) [#] (f y[/] g y[//]Hg y) -> x [#] y. Proof. intros x y H. elim (div_strext _ _ _ _ _ _ _ H); intro H0; exact (csf_strext_unfolded _ _ _ _ _ H0). Qed. Definition IDiv := Build_CSetoid_fun _ _ (fun x => f x[/] g x[//]Hg x) IDiv_strext. End Recip_Div. (** Absolute value will also be needed at some point. *) Lemma IAbs_strext : forall x y : subset I, AbsIR (f x) [#] AbsIR (f y) -> x [#] y. Proof. intros x y H. apply csf_strext_unfolded with (IR:CSetoid) f. simpl in H; unfold ABSIR in H; elim (bin_op_strext_unfolded _ _ _ _ _ _ H). auto. intro; apply un_op_strext_unfolded with (cg_inv (c:=IR)); assumption. Qed. Definition IAbs := Build_CSetoid_fun _ _ (fun x => AbsIR (f x)) IAbs_strext. End Operations. (** The set of these functions form a ring with relation to the operations of sum and multiplication. As they actually form a set, this fact can be proved in Coq for this class of functions; unfortunately, due to a problem with the coercions, we are not able to use it (Coq will not recognize the elements of that ring as functions which can be applied to elements of [[a,b]]), so we merely state this fact here as a curiosity. Finally, we define composition; for this we need two functions with different domains. %\begin{convention}% [a',b'] be real numbers and denote by [I'] the compact interval [[a',b']], and let [g] be a setoid function of type [I' -> IR]. %\end{convention}% *) Section Composition. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variables a' b' : IR. Hypothesis Hab' : a' [<=] b'. (* begin hide *) Let I' := Compact Hab'. (* end hide *) Variable f : CSetoid_fun (subset I) IR. Variable g : CSetoid_fun (subset I') IR. Hypothesis Hfg : forall x : subset I, I' (f x). Lemma IComp_strext : forall x y : subset I, g (Build_subcsetoid_crr _ _ _ (Hfg x)) [#] g (Build_subcsetoid_crr _ _ _ (Hfg y)) -> x [#] y. Proof. intros x y H. apply csf_strext_unfolded with (IR:CSetoid) f. exact (csf_strext_unfolded _ _ _ _ _ H). Qed. Definition IComp := Build_CSetoid_fun _ _ (fun x => g (Build_subcsetoid_crr _ _ _ (Hfg x))) IComp_strext. End Composition. Arguments IConst [a b Hab]. Arguments IId {a b Hab}. Arguments IPlus [a b Hab]. Arguments IInv [a b Hab]. Arguments IMinus [a b Hab]. Arguments IMult [a b Hab]. Arguments INth [a b Hab]. Arguments IRecip [a b Hab]. Arguments IDiv [a b Hab]. Arguments IAbs [a b Hab]. Arguments IComp [a b Hab a' b' Hab']. corn-8.20.0/ftc/MoreFunSeries.v000066400000000000000000001003431473720167500162500ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.FunctSeries. Require Export CoRN.ftc.MoreFunctions. (** printing FSeries_Sum %\ensuremath{\sum_{\infty}}% #∑'∞# *) Section Definitions. (** * More on Sequences and Series We will now extend our convergence definitions and results for sequences and series of functions defined in compact intervals to arbitrary intervals. %\begin{convention}% Throughout this file, [J] will be an interval, [f, g] will be sequences of continuous (in [J]) functions and [F,G] will be continuous (in [J]) functions. %\end{convention}% ** Sequences First we will consider the case of sequences. *** Definitions Some of the definitions do not make sense in this more general setting (for instance, because the norm of a function is no longer defined), but the ones which do we simply adapt in the usual way. *) Variable J : interval. Variable f : nat -> PartIR. Variable F : PartIR. Hypothesis contf : forall n : nat, Continuous J (f n). Hypothesis contF : Continuous J F. Definition Cauchy_fun_seq_IR := forall a b Hab (Hinc : included (compact a b Hab) J), Cauchy_fun_seq _ _ _ f (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc). Definition conv_fun_seq_IR := forall a b Hab (Hinc : included (Compact Hab) J), conv_fun_seq a b Hab f (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc). Definition conv_fun_seq'_IR := forall a b Hab (Hinc : included (Compact Hab) J), conv_fun_seq' a b Hab f F (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc) (included_imp_Continuous _ _ contF _ _ _ Hinc). Definition Cauchy_fun_seq2_IR := forall a b Hab (Hinc : included (compact a b Hab) J), Cauchy_fun_seq2 _ _ _ f (fun n => included_imp_Continuous _ _ (contf n) _ _ _ Hinc). (** The equivalences between these definitions still hold. *) Lemma conv_Cauchy_fun_seq'_IR : conv_fun_seq'_IR -> Cauchy_fun_seq_IR. Proof. intro H. red in |- *; red in H. intros. apply conv_Cauchy_fun_seq' with F (included_imp_Continuous _ _ contF _ _ _ Hinc); auto. Qed. Lemma Cauchy_fun_seq_seq2_IR : Cauchy_fun_seq_IR -> Cauchy_fun_seq2_IR. Proof. intro H. red in |- *; red in H. intros. apply Cauchy_fun_seq_seq2; auto. Qed. Lemma Cauchy_fun_seq2_seq_IR : Cauchy_fun_seq2_IR -> Cauchy_fun_seq_IR. Proof. intro H. red in |- *; red in H. intros. apply Cauchy_fun_seq2_seq; auto. Qed. Lemma Cauchy_fun_real_IR : Cauchy_fun_seq_IR -> forall x Hx, Cauchy_prop (fun n => Part _ _ (Continuous_imp_inc _ _ (contf n) x Hx)). Proof. intros H x Hx. red in H. cut (included (compact_single x) J). intro H0. set (contf' := fun i : nat => included_imp_Continuous J (f i) (contf i) _ _ (leEq_reflexive _ x) H0) in *. apply Cauchy_prop_wd with (fun n : nat => Part (f n) x ((fun i : nat => contin_imp_inc _ _ (leEq_reflexive _ x) (f i) (contf' i)) n x (compact_single_prop x))). apply Cauchy_fun_real. unfold contf' in |- *; simpl in |- *; apply H. intro; simpl in |- *; algebra. apply compact_single_iprop; auto. Qed. End Definitions. Section More_Definitions. (** Limit is defined and works in the same way as before. *) Variable J : interval. Variable f : nat -> PartIR. Hypothesis contf : forall n : nat, Continuous J (f n). (* begin show *) Hypothesis conv : Cauchy_fun_seq_IR J f contf. (* end show *) Definition Cauchy_fun_seq_Lim_IR : PartIR. Proof. apply Build_PartFunct with (pfpfun := fun (x : IR) (Hx : J x) => Lim (Build_CauchySeq _ _ (Cauchy_fun_real_IR _ _ _ conv x Hx))). apply iprop_wd. intros x y Hx Hy H. elim (Lim_strext _ _ H). intros n Hn. simpl in Hn. exact (pfstrx _ _ _ _ _ _ Hn). Defined. Lemma Cauchy_fun_seq_Lim_char : forall a b Hab (Hinc : included (Compact Hab) J), Feq (Compact Hab) Cauchy_fun_seq_Lim_IR (Cauchy_fun_seq_Lim _ _ _ _ _ (conv a b Hab Hinc)). Proof. intros. FEQ. simpl in |- *. apply Lim_wd'; intros; simpl in |- *; algebra. Qed. End More_Definitions. Section Irrelevance_of_Proofs. (** *** Basic Properties Proofs are irrelevant as before---they just have to be present. *) Variable J : interval. Variable f : nat -> PartIR. (* begin show *) Hypotheses contf contf0 : forall n : nat, Continuous J (f n). (* end show *) Variable F : PartIR. (* begin show *) Hypotheses contF contF0 : Continuous J F. (* end show *) Lemma conv_fun_seq'_wd_IR : conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contf0 contF0. intro H. red in |- *; intros. eapply conv_fun_seq'_wd. apply (H a b Hab Hinc). Qed. Lemma Cauchy_fun_seq2_wd_IR : Cauchy_fun_seq2_IR _ _ contf -> Cauchy_fun_seq2_IR _ _ contf0. Proof. intro H. red in |- *; intros. eapply Cauchy_fun_seq2_wd. apply (H a b Hab Hinc). Qed. Lemma conv_fun_seq_wd_IR : conv_fun_seq_IR _ _ contf -> conv_fun_seq_IR _ _ contf0. Proof. intro H. red in |- *; intros. eapply conv_fun_seq_wd. apply (H a b Hab Hinc). Qed. End Irrelevance_of_Proofs. Opaque Cauchy_fun_seq_Lim_IR. Section More_Properties. Variable J : interval. Variables f g : nat -> PartIR. (* begin show *) Hypotheses contf contf0 : forall n : nat, Continuous J (f n). Hypotheses contg contg0 : forall n : nat, Continuous J (g n). (* end show *) Lemma Cauchy_conv_fun_seq'_IR : forall H contf', conv_fun_seq'_IR _ _ (Cauchy_fun_seq_Lim_IR _ _ contf H) contf contf'. Proof. intros. red in |- *; intros. eapply conv_fun_seq'_wdr. apply Feq_symmetric. apply (Cauchy_fun_seq_Lim_char J f contf H a b Hab Hinc). apply Cauchy_conv_fun_seq' with (H := H a b Hab Hinc) (contf' := Cauchy_cont_Lim _ _ _ _ _ (H a b Hab Hinc)). Qed. Variables F G : PartIR. (* begin show *) Hypotheses contF contF0 : Continuous J F. Hypotheses contG contG0 : Continuous J G. (* end show *) Lemma conv_fun_seq'_wdl_IR : (forall n, Feq J (f n) (g n)) -> conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contg contF0. Proof. intros H H0 a b Hab Hinc. eapply conv_fun_seq'_wdl with (f := f). 2: apply (H0 a b Hab Hinc). intro; elim (H n); intros. inversion_clear b0. apply eq_imp_Feq; Included. Qed. Lemma conv_fun_seq'_wdr_IR : Feq J F G -> conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contf0 contG. Proof. intros H H0 a b Hab Hinc. eapply conv_fun_seq'_wdr with (F := F). 2: apply (H0 a b Hab Hinc). apply included_Feq with J; auto. Qed. Lemma conv_fun_seq'_wdl'_IR : (forall n, Feq J (f n) (g n)) -> conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contg contF. Proof. intros H H0 a b Hab Hinc. eapply conv_fun_seq'_wdl' with (f := f); auto. intro; elim (H n); intros. inversion_clear b0. apply eq_imp_Feq; Included. Qed. Lemma conv_fun_seq'_wdr'_IR : Feq J F G -> conv_fun_seq'_IR _ _ _ contf contF -> conv_fun_seq'_IR _ _ _ contf contG. Proof. intros H H0 a b Hab Hinc. eapply conv_fun_seq'_wdr' with (F := F). 2: apply (H0 a b Hab Hinc). apply included_Feq with J; auto. Qed. Lemma Cauchy_cont_Lim_IR : forall H, Continuous J (Cauchy_fun_seq_Lim_IR _ _ contf H). Proof. intros. split; Included. intros a b Hab H0; eapply Continuous_I_wd. apply Feq_symmetric. apply (Cauchy_fun_seq_Lim_char J f contf H a b Hab H0). Contin. Qed. Lemma Cauchy_conv_fun_seq_IR : Cauchy_fun_seq_IR _ _ contf -> conv_fun_seq_IR _ _ contf. Proof. intros H a b Hab Hinc. eapply Cauchy_conv_fun_seq. apply (H a b Hab Hinc). Qed. Lemma conv_Cauchy_fun_seq_IR : conv_fun_seq_IR _ _ contf -> Cauchy_fun_seq_IR _ _ contf. Proof. intros H a b Hab Hinc. eapply conv_Cauchy_fun_seq. apply (H a b Hab Hinc). Qed. End More_Properties. #[global] Hint Resolve Cauchy_cont_Lim_IR: continuous. Section Algebraic_Properties. (** *** Algebraic Properties Algebraic operations still work well. *) Variable J : interval. Variables f g : nat -> PartIR. Hypothesis contf : forall n : nat, Continuous J (f n). Hypothesis contg : forall n : nat, Continuous J (g n). Lemma FLim_unique_IR : forall F G HF HG, conv_fun_seq'_IR J f F contf HF -> conv_fun_seq'_IR J f G contf HG -> Feq J F G. Proof. intros F G HF HG H H0. apply included_Feq'. intros a b Hab H1. apply FLim_unique with f (fun n : nat => included_imp_Continuous _ _ (contf n) _ _ _ H1) (included_imp_Continuous _ _ HF _ _ _ H1) (included_imp_Continuous _ _ HG _ _ _ H1); auto. Qed. Lemma Cauchy_fun_seq_wd_IR : (forall n, Feq J (f n) (g n)) -> Cauchy_fun_seq_IR _ _ contf -> Cauchy_fun_seq_IR _ _ contg. Proof. intros H H0 a b Hab Hinc. eapply Cauchy_fun_seq_wd with (f := f). 2: apply (H0 a b Hab Hinc). intro; apply included_Feq with J; auto. Qed. Lemma fun_Lim_seq_const_IR : forall H contH contH', conv_fun_seq'_IR J (fun n => H) H contH contH'. Proof. exists 0; intros. eapply leEq_wdl. 2: eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply AbsIRz_isz. apply less_leEq; assumption. apply AbsIR_wd; rational. Qed. Lemma fun_Cauchy_prop_const_IR : forall H (contH:Continuous J H), Cauchy_fun_seq_IR J (fun n => H) (fun n => contH). Proof. intros. apply conv_Cauchy_fun_seq'_IR with H (contH). apply fun_Lim_seq_const_IR. Qed. Variables F G : PartIR. Hypothesis contF : Continuous J F. Hypothesis contG : Continuous J G. (* begin show *) Hypothesis convF : conv_fun_seq'_IR _ _ _ contf contF. Hypothesis convG : conv_fun_seq'_IR _ _ _ contg contG. (* end show *) Lemma fun_Lim_seq_plus'_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{+}g n) (F{+}G) H H'. Proof. intros. red in |- *; intros. eapply fun_Lim_seq_plus'. apply (convF a b Hab Hinc). apply (convG a b Hab Hinc). Qed. Lemma fun_Lim_seq_minus'_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{-}g n) (F{-}G) H H'. Proof. intros. red in |- *; intros. eapply fun_Lim_seq_minus'. apply (convF a b Hab Hinc). apply (convG a b Hab Hinc). Qed. Lemma fun_Lim_seq_mult'_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{*}g n) (F{*}G) H H'. Proof. intros. red in |- *; intros. eapply fun_Lim_seq_mult'. apply (convF a b Hab Hinc). apply (convG a b Hab Hinc). Qed. End Algebraic_Properties. Section More_Algebraic_Properties. (** If we work with the limit function things fit in just as well. *) Variable J : interval. Variables f g : nat -> PartIR. Hypothesis contf : forall n : nat, Continuous J (f n). Hypothesis contg : forall n : nat, Continuous J (g n). (* begin show *) Hypothesis Hf : Cauchy_fun_seq_IR _ _ contf. Hypothesis Hg : Cauchy_fun_seq_IR _ _ contg. (* end show *) Lemma fun_Lim_seq_plus_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{+}g n) (Cauchy_fun_seq_Lim_IR _ _ _ Hf{+}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H H'. Proof. intros. red in |- *; intros. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ]. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hg a b Hab Hinc))); [ intro H1 | Contin ]. eapply conv_fun_seq'_wdr with (contF := Continuous_I_plus _ _ _ _ _ H0 H1). apply Feq_symmetric; apply Feq_plus; apply Cauchy_fun_seq_Lim_char. apply fun_Lim_seq_plus with (Hf := Hf a b Hab Hinc) (Hg := Hg a b Hab Hinc) (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc). Qed. Lemma fun_Cauchy_prop_plus : forall H, Cauchy_fun_seq_IR J (fun n => f n{+}g n) H. Proof. intro. cut (Continuous J (Cauchy_fun_seq_Lim_IR _ _ _ Hf{+}Cauchy_fun_seq_Lim_IR _ _ _ Hg)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq'_IR with (Cauchy_fun_seq_Lim_IR _ _ _ Hf{+}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H0. apply fun_Lim_seq_plus_IR. Qed. Lemma fun_Lim_seq_inv_IR : forall H H', conv_fun_seq'_IR J (fun n => {--} (f n)) {--} (Cauchy_fun_seq_Lim_IR _ _ _ Hf) H H'. Proof. intros. red in |- *; intros. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ]. intros. eapply conv_fun_seq'_wdr with (contF := Continuous_I_inv _ _ _ _ H0). apply Feq_symmetric; apply Feq_inv; apply Cauchy_fun_seq_Lim_char. apply fun_Lim_seq_inv with (Hf := Hf a b Hab Hinc) (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc). Qed. Lemma fun_Cauchy_prop_inv : forall H, Cauchy_fun_seq_IR J (fun n => {--} (f n)) H. Proof. intro. cut (Continuous J {--} (Cauchy_fun_seq_Lim_IR _ _ _ Hf)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq'_IR with ( {--} (Cauchy_fun_seq_Lim_IR _ _ _ Hf)) H0. apply fun_Lim_seq_inv_IR. Qed. Lemma fun_Lim_seq_minus_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{-}g n) (Cauchy_fun_seq_Lim_IR _ _ _ Hf{-}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H H'. Proof. intros. red in |- *; intros. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ]. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hg a b Hab Hinc))); [ intro H1 | Contin ]. intros. eapply conv_fun_seq'_wdr with (contF := Continuous_I_minus _ _ _ _ _ H0 H1). apply Feq_symmetric; apply Feq_minus; apply Cauchy_fun_seq_Lim_char. apply fun_Lim_seq_minus with (Hf := Hf a b Hab Hinc) (Hg := Hg a b Hab Hinc) (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc). Qed. Lemma fun_Cauchy_prop_minus : forall H, Cauchy_fun_seq_IR J (fun n => f n{-}g n) H. Proof. intro. cut (Continuous J (Cauchy_fun_seq_Lim_IR _ _ _ Hf{-}Cauchy_fun_seq_Lim_IR _ _ _ Hg)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq'_IR with (Cauchy_fun_seq_Lim_IR _ _ _ Hf{-}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H0. apply fun_Lim_seq_minus_IR. Qed. Lemma fun_Lim_seq_mult_IR : forall H H', conv_fun_seq'_IR J (fun n => f n{*}g n) (Cauchy_fun_seq_Lim_IR _ _ _ Hf{*}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H H'. Proof. intros. red in |- *; intros. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hf a b Hab Hinc))); [ intro H0 | Contin ]. cut (Continuous_I Hab (Cauchy_fun_seq_Lim _ _ _ _ _ (Hg a b Hab Hinc))); [ intro H1 | Contin ]. intros. eapply conv_fun_seq'_wdr with (contF := Continuous_I_mult _ _ _ _ _ H0 H1). apply Feq_symmetric; apply Feq_mult; apply Cauchy_fun_seq_Lim_char. apply fun_Lim_seq_mult with (Hf := Hf a b Hab Hinc) (Hg := Hg a b Hab Hinc) (H := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc). Qed. Lemma fun_Cauchy_prop_mult : forall H, Cauchy_fun_seq_IR J (fun n => f n{*}g n) H. Proof. intro. cut (Continuous J (Cauchy_fun_seq_Lim_IR _ _ _ Hf{*}Cauchy_fun_seq_Lim_IR _ _ _ Hg)); [ intro H0 | Contin ]. apply conv_Cauchy_fun_seq'_IR with (Cauchy_fun_seq_Lim_IR _ _ _ Hf{*}Cauchy_fun_seq_Lim_IR _ _ _ Hg) H0. apply fun_Lim_seq_mult_IR. Qed. End More_Algebraic_Properties. Section Other. (** *** Miscellaneous Finally, we define a mapping between sequences of real numbers and sequences of (constant) functions and prove that convergence is preserved. *) Definition seq_to_funseq (x : nat -> IR) n : PartIR := [-C-] (x n). Lemma funseq_conv : forall J x y, nonvoid J -> conv_fun_seq'_IR J (seq_to_funseq x) [-C-]y (fun n => Continuous_const _ _) (Continuous_const _ _) -> Cauchy_Lim_prop2 x y. Proof. intros J x y H H0 eps H1. elim (nonvoid_point J H); intros x0 Hx0. cut (included (compact_single x0) J). 2: apply compact_single_iprop; auto. intro H2. elim (H0 _ _ (leEq_reflexive _ _) H2 eps). intros N HN. exists N; intros. simpl in HN. apply AbsIR_imp_AbsSmall. apply HN with x0. auto. fold (compact_single x0) in |- *. apply compact_single_prop. auto. Qed. (** Another interesting fact: if a sequence of constant functions converges then it must converge to a constant function. *) Lemma fun_const_Lim : forall J f F contf contF, proper J -> conv_fun_seq'_IR J f F contf contF -> (forall n, {c : IR | Feq J (f n) [-C-]c}) -> {c : IR | Feq J F [-C-]c}. Proof. intros J f F contf contF pJ H H0. set (incF := Continuous_imp_inc _ _ contF) in *. set (incf := fun n : nat => Continuous_imp_inc _ _ (contf n)) in *. elim (nonvoid_point _ (proper_nonvoid _ pJ)); intros x0 Hx0. exists (Part F x0 (incF x0 Hx0)). FEQ. rename X into H1. simpl in |- *. apply cg_inv_unique_2; apply AbsIR_approach_zero. intros e H2. cut (included (Compact (Min_leEq_Max x x0)) J). 2: apply included_interval; auto. intro Hinc. elim (H _ _ _ Hinc _ (pos_div_two _ _ H2)); intros N HN. set (Fx := Part _ _ Hx) in *. set (Fa := Part _ _ (incF x0 Hx0)) in *. set (fx := Part _ _ (incf N x H1)) in *. set (fa := Part _ _ (incf N x0 Hx0)) in *. apply leEq_wdl with (AbsIR (Fx[-]fx[+] (fx[-]fa) [+] (fa[-]Fa))). 2: apply AbsIR_wd; rational. rstepr (e [/]TwoNZ[+][0][+]e [/]TwoNZ). eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_wdl. 2: apply AbsIR_minus. eapply leEq_wdl. apply (HN N (le_n N) x (compact_Min_lft _ _ _)). unfold Fx, fx in |- *; apply AbsIR_wd; rational. elim (H0 N); intros c Hc. apply eq_imp_leEq. eapply eq_transitive_unfolded. 2: apply AbsIRz_isz. elim Hc; clear Hc; intros H5 H3. elim H3; clear H3; intros H6 H4. apply AbsIR_wd; unfold fx, fa in |- *; astepr (c[-]c). apply cg_minus_wd; simpl in H4; apply H4; auto. eapply leEq_wdl. apply (HN N (le_n N) x0 (compact_Min_rht _ _ _)). unfold Fa, fa in |- *; apply AbsIR_wd; rational. Qed. End Other. Section Series_Definitions. (** ** Series We now consider series of functions defined in arbitrary intervals. Convergence is defined as expected---through convergence in every compact interval. *) Variable J : interval. Variable f : nat -> PartIR. Definition fun_series_convergent_IR := forall a b Hab (Hinc : included (Compact Hab) J), fun_series_convergent a b Hab f. Lemma fun_series_conv_imp_conv_IR : fun_series_convergent_IR -> forall x, J x -> forall Hx, convergent (fun n : nat => f n x (Hx n)). Proof. intros H x H0 Hx. apply fun_series_conv_imp_conv with (Hab := leEq_reflexive _ x). apply H. fold (compact_single x) in |- *; apply compact_single_iprop; auto. apply compact_single_prop. Qed. (* begin show *) Hypothesis H : fun_series_convergent_IR. (* end show *) Lemma fun_series_inc_IR : forall x, J x -> forall n, Dom (f n) x. Proof. intros x H0 n. elim (H _ _ (leEq_reflexive _ x) (compact_single_iprop J x H0)). intros contF CauchyF. apply (contin_imp_inc _ _ _ _ (contF n)). apply compact_single_prop. Qed. (** Assume [h(x)] is the pointwise series of [f(x)] *) (* begin hide *) Let h (x : IR) (Hx : J x) := series_sum _ (fun_series_conv_imp_conv _ _ _ _ (H _ _ (leEq_reflexive _ x) (compact_single_iprop J x Hx)) x (compact_single_prop x) (fun_series_inc_IR x Hx)). (* end hide *) Lemma FSeries_Sum_strext_IR : forall x y Hx Hy, h x Hx [#] h y Hy -> x [#] y. Proof. unfold h in |- *; clear h; intros x y Hx Hy H0. unfold series_sum in H0. elim (Lim_strext _ _ H0); intros N HN. simpl in HN; unfold seq_part_sum in HN. elim (Sum0_strext _ _ _ _ HN); intros. exact (pfstrx _ _ _ _ _ _ q). Qed. Definition FSeries_Sum : PartIR. Proof. apply Build_PartFunct with (pfpfun := h). apply iprop_wd. exact FSeries_Sum_strext_IR. Defined. Lemma FSeries_Sum_char : forall a b Hab (Hinc : included (Compact Hab) J), Feq (Compact Hab) FSeries_Sum (Fun_Series_Sum (H a b Hab Hinc)). Proof. intros; FEQ. simpl in |- *; Included. simpl in |- *; unfold h in |- *. apply series_sum_wd; intros; algebra. Qed. End Series_Definitions. Arguments FSeries_Sum [J f]. Section More_Series_Definitions. Variable J : interval. Variable f : nat -> PartIR. (** Absolute convergence still exists. *) Definition fun_series_abs_convergent_IR := fun_series_convergent_IR J (fun n => FAbs (f n)). End More_Series_Definitions. Section Convergence_Results. (** As before, any series converges to its sum. *) Variable J : interval. Variable f : nat -> PartIR. Lemma FSeries_conv : forall (convF : fun_series_convergent_IR J f) H H', conv_fun_seq'_IR J (fun n => FSum0 n f) (FSeries_Sum convF) H H'. Proof. intros. red in |- *; intros. elim (convF _ _ _ Hinc); intros Hcont Hconv. apply conv_fun_seq'_wdr with (f := fun n : nat => FSum0 n f) (contf := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc) (contF := Fun_Series_Sum_cont _ _ _ _ (convF _ _ _ Hinc)). apply Feq_symmetric; apply FSeries_Sum_char. apply conv_fun_seq'_wdl with (f := fun_seq_part_sum f) (contf := fun n : nat => included_imp_Continuous _ _ (H n) _ _ _ Hinc) (contF := Fun_Series_Sum_cont _ _ _ _ (convF _ _ _ Hinc)). intro; apply Feq_reflexive. red in |- *; intros. simpl in |- *; intros. apply (contin_imp_inc _ _ _ _ (Hcont n0)); auto. apply fun_series_conv. Qed. Lemma convergent_imp_inc : fun_series_convergent_IR J f -> forall n, included J (Dom (f n)). Proof. intros H n. apply included_imp_inc. intros a b Hab H0. red in H. elim (H _ _ _ H0); intros. apply contin_imp_inc; auto. Qed. Lemma convergent_imp_Continuous : fun_series_convergent_IR J f -> forall n, Continuous J (f n). Proof. intros H n. split. exact (convergent_imp_inc H n). intros a b Hab H0; auto. elim (H a b Hab H0); auto. Qed. Lemma Continuous_FSeries_Sum : forall H, Continuous J (FSeries_Sum (J:=J) (f:=f) H). Proof. intros. split; Included. intros a b Hab H0. eapply Continuous_I_wd. apply Feq_symmetric; apply (FSeries_Sum_char _ _ H _ _ _ H0). eapply Continuous_I_wd. apply Fun_Series_Sum_char. apply Cauchy_cont_Lim. Qed. End Convergence_Results. #[global] Hint Resolve convergent_imp_inc: included. #[global] Hint Resolve convergent_imp_Continuous Continuous_FSeries_Sum: continuous. Section Operations. (** ** Algebraic Operations Convergence is well defined and preserved by operations. *) Variable J : interval. Lemma conv_fun_const_series_IR : forall x : nat -> IR, convergent x -> fun_series_convergent_IR J (fun n => [-C-] (x n)). Proof. intros. red in |- *; intros. apply conv_fun_const_series; auto. Qed. Lemma fun_const_series_Sum_IR : forall y H (H' : fun_series_convergent_IR J (fun n => [-C-] (y n))) x Hx, FSeries_Sum H' x Hx [=] series_sum y H. Proof. intros. simpl in |- *. apply series_sum_wd. algebra. Qed. Lemma conv_zero_fun_series_IR : fun_series_convergent_IR J (fun n => [-C-][0]). Proof. apply conv_fun_const_series_IR with (x := fun n : nat => ZeroR). apply conv_zero_series. Qed. Lemma FSeries_Sum_zero_IR : forall (H : fun_series_convergent_IR J (fun n => [-C-][0])) x Hx, FSeries_Sum H x Hx [=] [0]. Proof. intros. simpl in |- *. apply series_sum_zero. Qed. Variables f g : nat -> PartIR. Lemma fun_series_convergent_wd_IR : (forall n, Feq J (f n) (g n)) -> fun_series_convergent_IR J f -> fun_series_convergent_IR J g. Proof. intros. red in |- *; intros. apply fun_series_convergent_wd with f. intros; apply included_Feq with J; auto. auto. Qed. (* begin show *) Hypothesis convF : fun_series_convergent_IR J f. Hypothesis convG : fun_series_convergent_IR J g. (* end show *) Lemma FSeries_Sum_wd' : (forall n, Feq J (f n) (g n)) -> Feq J (FSeries_Sum convF) (FSeries_Sum convG). Proof. intros H. apply included_Feq'; intros a b Hab H0. eapply Feq_transitive. apply (FSeries_Sum_char _ _ convF a b Hab H0). eapply Feq_transitive. 2: apply Feq_symmetric; apply (FSeries_Sum_char _ _ convG a b Hab H0). apply Fun_Series_Sum_wd'. intro; apply included_Feq with J; auto. Qed. Lemma FSeries_Sum_plus_conv : fun_series_convergent_IR J (fun n => f n{+}g n). Proof. red in |- *; intros. apply conv_fun_series_plus; auto. Qed. Lemma FSeries_Sum_plus : forall H : fun_series_convergent_IR J (fun n => f n{+}g n), Feq J (FSeries_Sum H) (FSeries_Sum convF{+}FSeries_Sum convG). Proof. intros. apply included_Feq'; intros a b Hab H0. eapply Feq_transitive. apply (FSeries_Sum_char _ _ H a b Hab H0). eapply Feq_transitive. apply Fun_Series_Sum_plus with (convF := convF a b Hab H0) (convG := convG a b Hab H0). apply Feq_symmetric; apply Feq_plus; apply FSeries_Sum_char. Qed. Lemma FSeries_Sum_inv_conv : fun_series_convergent_IR J (fun n => {--} (f n)). Proof. red in |- *; intros. apply conv_fun_series_inv; auto. Qed. Lemma FSeries_Sum_inv : forall H : fun_series_convergent_IR J (fun n => {--} (f n)), Feq J (FSeries_Sum H) {--} (FSeries_Sum convF). Proof. intros. apply included_Feq'; intros a b Hab H0. eapply Feq_transitive. apply (FSeries_Sum_char _ _ H a b Hab H0). eapply Feq_transitive. apply Fun_Series_Sum_inv with (convF := convF a b Hab H0). apply Feq_symmetric; apply Feq_inv; apply FSeries_Sum_char. Qed. Lemma FSeries_Sum_minus_conv : fun_series_convergent_IR J (fun n => f n{-}g n). Proof. red in |- *; intros. apply conv_fun_series_minus; auto. Qed. Lemma FSeries_Sum_minus : forall H : fun_series_convergent_IR J (fun n => f n{-}g n), Feq J (FSeries_Sum H) (FSeries_Sum convF{-}FSeries_Sum convG). Proof. intros. apply included_Feq'; intros a b Hab H0. eapply Feq_transitive. apply (FSeries_Sum_char _ _ H a b Hab H0). eapply Feq_transitive. apply Fun_Series_Sum_min with (convF := convF a b Hab H0) (convG := convG a b Hab H0). apply Feq_symmetric; apply Feq_minus; apply FSeries_Sum_char. Qed. (** %\begin{convention}% Let [c:IR] and [H:PartIR] be continuous in [J]. %\end{convention}% *) Variable c : IR. Variable H : PartIR. Hypothesis contH : Continuous J H. Lemma FSeries_Sum_scal_conv : fun_series_convergent_IR J (fun n => H{*}f n). Proof. red in |- *; intros. apply conv_fun_series_scal; auto. eapply included_imp_Continuous. apply contH. auto. Qed. Lemma FSeries_Sum_scal : forall H' : fun_series_convergent_IR J (fun n => H{*}f n), Feq J (FSeries_Sum H') (H{*}FSeries_Sum convF). Proof. intros. apply included_Feq'; intros a b Hab H0. cut (Continuous_I Hab H). intro H1. eapply Feq_transitive. apply (FSeries_Sum_char _ _ H' a b Hab H0). eapply Feq_transitive. apply Fun_Series_Sum_scal with (convF := convF a b Hab H0). auto. apply Feq_symmetric; apply Feq_mult. apply Feq_reflexive; Included. apply FSeries_Sum_char. eapply included_imp_Continuous. apply contH. auto. Qed. End Operations. Section Convergence_Criteria. (** *** Convergence Criteria The most important tests for convergence of series still apply: the comparison test (in both versions) and the ratio test. *) Variable J : interval. Variable f : nat -> PartIR. Hypothesis contF : forall n, Continuous J (f n). Lemma fun_str_comparison_IR : forall g : nat -> PartIR, fun_series_convergent_IR J g -> {k : nat | forall n, k <= n -> forall x, J x -> forall Hx Hx', AbsIR (f n x Hx) [<=] g n x Hx'} -> fun_series_convergent_IR J f. Proof. intros g H H0 a b Hab H1. apply fun_str_comparison with g. intro; apply included_imp_Continuous with J; auto. auto. elim H0; clear H0; intros k Hk. exists k; intros. apply Hk; auto. Qed. Lemma fun_comparison_IR : forall g : nat -> PartIR, fun_series_convergent_IR J g -> (forall n x, J x -> forall Hx Hx', AbsIR (f n x Hx) [<=] g n x Hx') -> fun_series_convergent_IR J f. Proof. intros g H H0. apply fun_str_comparison_IR with g; auto. exists 0; intros; apply H0; auto. Qed. Lemma abs_imp_conv_IR : fun_series_abs_convergent_IR J f -> fun_series_convergent_IR J f. Proof. intro H. apply fun_comparison_IR with (fun n => FAbs (f n)). apply H. intros; apply eq_imp_leEq; apply eq_symmetric_unfolded; apply FAbs_char. Qed. Lemma fun_ratio_test_conv_IR : {N : nat | {c : IR | c [<] [1] | [0] [<=] c /\ (forall x, J x -> forall n, N <= n -> forall Hx Hx', AbsIR (f (S n) x Hx') [<=] c[*]AbsIR (f n x Hx))}} -> fun_series_convergent_IR J f. Proof. intro H. red in |- *; intros. apply fun_ratio_test_conv. intro; apply included_imp_Continuous with J; auto. elim H; intros N HN. elim HN; clear H HN; intros c Hc H. inversion_clear H. exists N; exists c; repeat split; auto. Qed. End Convergence_Criteria. Section Power_Series. (** ***Power Series The geometric series converges on the open interval (-1, 1) *) Lemma fun_power_series_conv_IR : fun_series_convergent_IR (olor ([--][1]) [1]) (fun (i:nat) => Fid IR{^}i). Proof. intros a b Hab H. apply fun_ratio_test_conv. intros n. Contin. exists 0%nat. exists (Max (AbsIR a) (AbsIR b)). destruct (H a) as [Ha0 Ha1]. split; assumption || apply leEq_reflexive. destruct (H b) as [Hb0 Hb1]. split; assumption || apply leEq_reflexive. apply Max_less; apply AbsIR_less; assumption. split. eapply leEq_transitive. apply AbsIR_nonneg. apply lft_leEq_Max. simpl. intros x Hx n Hn _ _. rstepr (ABSIR (nexp IR n x)[*]MAX (ABSIR a) (ABSIR b)). change (AbsIR (nexp IR n x[*]x)[<=]AbsIR (nexp IR n x)[*]Max (AbsIR a) (AbsIR b)). stepl (AbsIR (nexp IR n x)[*]AbsIR x); [| apply eq_symmetric; apply AbsIR_resp_mult]. apply mult_resp_leEq_lft;[|apply AbsIR_nonneg]. apply AbsSmall_imp_AbsIR. destruct Hx. split. apply leEq_transitive with a;[|assumption]. rstepr ([--][--]a). apply inv_resp_leEq. apply leEq_transitive with (AbsIR a). apply inv_leEq_AbsIR. apply lft_leEq_Max. apply leEq_transitive with b;[assumption|]. apply leEq_transitive with (AbsIR b). apply leEq_AbsIR. apply rht_leEq_Max. Qed. End Power_Series. Section Insert_Series. (** *** Translation When working in particular with power series and Taylor series, it is sometimes useful to ``shift'' all the terms in the series one position forward, that is, replacing each $f_{i+1}$#fi+1# with $f_i$#fi# and inserting the null function in the first position. This does not affect convergence or the sum of the series. *) Variable J : interval. Variable f : nat -> PartIR. Hypothesis convF : fun_series_convergent_IR J f. Definition insert_series n : PartIR := match n with | O => [-C-][0] | S p => f p end. Lemma insert_series_cont : forall n, Continuous J (insert_series n). Proof. intro; elim n; intros. simpl in |- *; apply Continuous_const. simpl in |- *; apply convergent_imp_Continuous; auto. Qed. Lemma insert_series_sum_char : forall n x Hx Hx', fun_seq_part_sum f n x Hx [=] fun_seq_part_sum insert_series (S n) x Hx'. Proof. intro; induction n as [| n Hrecn]. intros; simpl in |- *; algebra. intros; simpl in |- *; simpl in Hrecn; algebra. Qed. Lemma insert_series_conv : fun_series_convergent_IR J insert_series. Proof. intros a b Hab Hinc. elim (convF _ _ _ Hinc); intros Hcont HCauchy. exists (fun n => included_imp_Continuous _ _ (insert_series_cont n) _ _ _ Hinc). intros e H. elim (HCauchy e H); intros N HN. exists (S N); do 4 intro. cut (m = S (pred m)); [ intro | symmetry; apply Nat.lt_succ_pred with 0; apply Nat.lt_le_trans with (S N); auto with arith ]. cut (n = S (pred n)); [ intro | symmetry; apply Nat.lt_succ_pred with 0; apply Nat.lt_le_trans with (S N); auto with arith ]. generalize H0 H1; clear H1 H0. rewrite H2; rewrite H3; clear H2 H3. intros. cut (N <= pred m); [ intro | auto with arith ]. cut (N <= pred n); [ intro | auto with arith ]. eapply leEq_wdl. apply (HN _ _ H2 H3 x Hx). apply AbsIR_wd. apply cg_minus_wd; apply insert_series_sum_char. Qed. Lemma insert_series_sum : Feq J (FSeries_Sum convF) (FSeries_Sum insert_series_conv). Proof. set (contF := convergent_imp_Continuous _ _ convF) in *. apply FLim_unique_IR with (fun n => FSum0 n f) (fun n => Continuous_Sum0 _ _ contF n) (Continuous_FSeries_Sum _ _ convF) (Continuous_FSeries_Sum _ _ insert_series_conv). apply FSeries_conv. red in |- *; intros. assert (convS := FSeries_conv _ _ insert_series_conv (Continuous_Sum0 _ _ insert_series_cont) (Continuous_FSeries_Sum _ _ insert_series_conv) _ _ _ Hinc). intros e H. elim (convS e H); intros N HN. clear convS; exists N; intros. eapply leEq_wdl. apply (HN (S n) (le_S _ _ H0) _ Hx). apply AbsIR_wd; apply cg_minus_wd. 2: algebra. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply (insert_series_sum_char n x (contin_imp_inc _ _ _ _ (included_imp_Continuous _ _ (Continuous_Sum0 _ _ contF n) _ _ _ Hinc) _ Hx) (contin_imp_inc _ _ _ _ (included_imp_Continuous _ _ (Continuous_Sum0 _ _ insert_series_cont (S n)) _ _ _ Hinc) _ Hx)). unfold fun_seq_part_sum in |- *; algebra. unfold fun_seq_part_sum in |- *; algebra. Qed. End Insert_Series. corn-8.20.0/ftc/MoreFunctions.v000066400000000000000000001107201473720167500163150ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing FNorm %\ensuremath{\|\cdot\|_{\infty}}% *) Require Export CoRN.ftc.MoreIntervals. Opaque Min Max. Section Basic_Results. (** * More about Functions Here we state all the main results about properties of functions that we already proved for compact intervals in the more general setting of arbitrary intervals. %\begin{convention}% Let [I:interval] and [F,F',G,G'] be partial functions. %\end{convention}% ** Continuity *) Variable I : interval. (** Trivial stuff. *) Lemma Continuous_imp_inc : forall F, Continuous I F -> included I (Dom F). Proof. intros F H; elim H; intros; auto. Qed. (** %\begin{convention}% Assume that [I] is compact and [F] is continuous in [I]. %\end{convention}% *) Hypothesis cI : compact_ I. Variable F : PartIR. Hypothesis contF : Continuous I F. Lemma continuous_compact : forall H, Continuous_I (a:=Lend cI) (b:=Rend cI) H F. Proof. intros. elim contF; intros incF contF'. Contin. Qed. (* begin show *) Hypothesis Hinc : included I (Dom F). (* end show *) Lemma Continuous_I_imp_tb_image : totally_bounded (fun_image F I). Proof. cut (Continuous_I (Lend_leEq_Rend _ cI) F). intro H. elim (Continuous_I_imp_tb_image _ _ _ _ H); intros. split; [ clear b | clear a ]. elim a; intros x Hx. elim Hx; intros y Hy. elim Hy; clear a Hx Hy; intros Hy Hx. elim Hx; clear Hx; intros Hy'' Hx. exists x; exists y. split. exact (compact_interval_inc _ _ _ _ Hy). auto. intros e He. elim (b e He); intros l H0 H1. exists l; clear b; [ clear H1 | clear H0 ]. intros x Hx. elim (H0 x Hx); intros y Hy. elim Hy; clear H0 Hy Hx; intros Hy Hx. elim Hx; clear Hx; intros Hy' Hx. exists y. split. exact (compact_interval_inc _ _ _ _ Hy). auto. intros x H0. apply H1. clear H1. elim H0; intros y Hy. elim Hy; clear H0 Hy; intros Hy Hx. elim Hx; clear Hx; intros Hy' Hx. exists y. split. exact (interval_compact_inc _ _ (Lend_leEq_Rend _ cI) _ Hy). auto. apply continuous_compact. Qed. Definition FNorm := Norm_Funct (continuous_compact (Lend_leEq_Rend _ cI)). Lemma FNorm_bnd_AbsIR : forall x, I x -> forall Hx, AbsIR (F x Hx) [<=] FNorm. Proof. intros; unfold FNorm in |- *. apply norm_bnd_AbsIR. apply interval_compact_inc; auto. Qed. End Basic_Results. #[global] Hint Resolve Continuous_imp_inc: included. Section Other_Results. (** The usual stuff. *) Variable I : interval. Variables F G : PartIR. Lemma Continuous_wd : Feq I F G -> Continuous I F -> Continuous I G. Proof. intros H H0. elim H; intros incF H'. elim H'; clear H H'; intros incG eqFG. elim H0; clear H0; intros incF' contF. split. auto. intros. apply Continuous_I_wd with F. FEQ. simpl in |- *; algebra. auto. Qed. (* begin show *) Hypothesis contF : Continuous I F. Hypothesis contG : Continuous I G. (* end show *) Lemma included_imp_Continuous : forall a b Hab, included (compact a b Hab) I -> Continuous_I Hab F. Proof. intros. elim contF; auto. Qed. Lemma Included_imp_Continuous : forall J : interval, included J I -> Continuous J F. Proof. intros J H. split. exact (included_trans _ _ _ _ H (Continuous_imp_inc _ _ contF)). intros. apply included_imp_Continuous; Included. Qed. Lemma Continuous_const : forall c : IR, Continuous I [-C-]c. Proof. split; Contin. Qed. Lemma Continuous_id : Continuous I FId. Proof. split; Contin. Qed. Lemma Continuous_plus : Continuous I (F{+}G). Proof. elim contF; intros incF' contF'. elim contG; intros incG' contG'. split; Contin. Qed. Lemma Continuous_inv : Continuous I {--}F. Proof. elim contF; intros incF' contF'. split; Contin. Qed. Lemma Continuous_minus : Continuous I (F{-}G). Proof. elim contF; intros incF' contF'. elim contG; intros incG' contG'. split; Contin. Qed. Lemma Continuous_mult : Continuous I (F{*}G). Proof. elim contF; intros incF' contF'. elim contG; intros incG' contG'. split; Contin. Qed. Lemma Continuous_nth : forall n : nat, Continuous I (F{^}n). Proof. elim contF; intros incF' contF'. split; Contin. Qed. Lemma Continuous_scal : forall c : IR, Continuous I (c{**}F). Proof. elim contF; intros incF' contF'. split; Contin. Qed. Lemma Continuous_abs : Continuous I (FAbs F). Proof. elim contF; intros incF' contF'. split; Contin. Qed. Lemma Continuous_recip : bnd_away_zero_in_P G I -> Continuous I {1/}G. Proof. intro H. elim contG; intros incG' contG'. cut (forall x : IR, I x -> forall Hx, G x Hx [#] [0]). intro H0. split; Contin. intros x H0 Hx. apply bnd_imp_ap_zero with (Compact (leEq_reflexive _ x)); auto. apply H; auto. exact (compact_single_iprop I x H0). exact (compact_single_prop x). Qed. Lemma Continuous_NRoot : forall n H, (forall x : IR, I x -> forall Hx, [0][<=]F x Hx) -> Continuous I (FNRoot F n H). Proof. intros n H. elim contF; intros incF' contF'. split; Contin. Qed. End Other_Results. #[global] Hint Resolve continuous_compact Continuous_const Continuous_id Continuous_plus Continuous_inv Continuous_minus Continuous_mult Continuous_scal Continuous_nth Continuous_recip Continuous_abs Continuous_NRoot: continuous. #[global] Hint Immediate included_imp_Continuous Included_imp_Continuous: continuous. Section Corollaries. Variable I : interval. Hypothesis cI : compact_ I. Variables F G : PartIR. Hypothesis contF : Continuous I F. Hypothesis contG : Continuous I G. Lemma Continuous_div : bnd_away_zero_in_P G I -> Continuous I (F{/}G). Proof. intros. apply Continuous_wd with (F{*}{1/}G). FEQ. Contin. Qed. Lemma FNorm_wd : Feq I F G -> FNorm I cI F contF [=] FNorm I cI G contG. Proof. intro H; unfold FNorm in |- *; apply Norm_Funct_wd. eapply included_Feq. 2: apply H. Included. Qed. End Corollaries. #[global] Hint Resolve Continuous_div: continuous. Section Sums. Variable I : interval. Lemma Continuous_Sumx : forall n (f : forall i, i < n -> PartIR), (forall i Hi, Continuous I (f i Hi)) -> Continuous I (FSumx n f). Proof. intro; induction n as [| n Hrecn]; intros f contF. simpl in |- *; Contin. simpl in |- *; Contin. Qed. (** %\begin{convention}% Assume [f] is a sequence of continuous functions. %\end{convention}% *) Variable f : nat -> PartIR. Hypothesis contF : forall n : nat, Continuous I (f n). Lemma Continuous_Sum0 : forall n : nat, Continuous I (FSum0 n f). Proof. intros. induction n as [| n Hrecn]. eapply Continuous_wd. apply FSum0_0; Included. Contin. eapply Continuous_wd. apply FSum0_S; Included. Contin. Qed. Lemma Continuous_Sum : forall m n : nat, Continuous I (FSum m n f). Proof. intros. eapply Continuous_wd. apply Feq_symmetric; apply FSum_FSum0'; Included. apply Continuous_minus; apply Continuous_Sum0. Qed. End Sums. #[global] Hint Resolve Continuous_Sum0 Continuous_Sumx Continuous_Sum: continuous. Section Basic_Properties. (** ** Derivative Derivative is not that much different. %\begin{convention}% From this point on we assume [I] to be proper. %\end{convention}% *) Variable I : interval. Hypothesis pI : proper I. Variables F G H : PartIR. Lemma Derivative_wdl : Feq I F G -> Derivative I pI F H -> Derivative I pI G H. Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; intros incG Heq. elim H1; intros incF' H1'. elim H1'; intros incH' derF. split. auto. split. auto. intros; apply Derivative_I_wdl with F; auto. apply included_Feq with I; auto. Qed. Lemma Derivative_wdr : Feq I F G -> Derivative I pI H F -> Derivative I pI H G. Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; intros incG Heq. elim H1; intros incF' H1'. elim H1'; intros incH' derF. split. auto. split. auto. intros; apply Derivative_I_wdr with F; auto. apply included_Feq with I; auto. Qed. Lemma Derivative_unique : Derivative I pI F G -> Derivative I pI F H -> Feq I G H. Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; intros incG derFG. elim H1; intros incF' H1'. elim H1'; intros incH derFH. apply included_Feq''; intros. auto. unfold Hab'; apply Derivative_I_unique with F; Deriv. Qed. Lemma Derivative_imp_inc : Derivative I pI F G -> included I (Dom F). Proof. intro H0. inversion_clear H0; auto. Qed. Lemma Derivative_imp_inc' : Derivative I pI F G -> included I (Dom G). Proof. intro H0. elim H0; intros H1 H2. inversion_clear H2; auto. Qed. Lemma Derivative_imp_Continuous : Derivative I pI F G -> Continuous I F. Proof. intro H0. elim H0; intros incF H'. elim H'; intros incG derF. clear H0 H'. split. Included. intros a b Hab H0. elim (compact_proper_in_interval _ _ _ Hab H0 pI); intros a' Ha. elim Ha; clear Ha; intros b' Hb. elim Hb; clear Hb; intros Hab' H2 H3. apply included_imp_contin with (Hab := less_leEq _ _ _ Hab'). auto. apply deriv_imp_contin_I with Hab' G; auto. Qed. Lemma Derivative_imp_Continuous' : Derivative I pI F G -> Continuous I G. Proof. intro H0. elim H0; intros incF H'. elim H'; intros incG derF. clear H0 H'. split. Included. intros a b Hab H0. elim (compact_proper_in_interval _ _ _ Hab H0 pI); intros a' Ha. elim Ha; clear Ha; intros b' Hb. elim Hb; clear Hb; intros Hab' H2 H3. apply included_imp_contin with (Hab := less_leEq _ _ _ Hab'). auto. apply deriv_imp_contin'_I with Hab' F; auto. Qed. End Basic_Properties. #[global] Hint Immediate Derivative_imp_inc Derivative_imp_inc': included. #[global] Hint Immediate Derivative_imp_Continuous Derivative_imp_Continuous': continuous. Section More_Results. Variable I : interval. Hypothesis pI : proper I. (** %\begin{convention}% Assume that [F'] and [G'] are derivatives of [F] and [G], respectively, in [I]. %\end{convention}% *) Variables F F' G G' : PartIR. Hypothesis derF : Derivative I pI F F'. Hypothesis derG : Derivative I pI G G'. Lemma included_imp_Derivative : forall a b Hab, included (Compact (less_leEq _ a b Hab)) I -> Derivative_I Hab F F'. Proof. intros. elim derF; intros incF H'. elim H'; auto. Qed. Lemma Included_imp_Derivative : forall J (pJ : proper J), included J I -> Derivative J pJ F F'. Proof. intros J pJ H. split. exact (included_trans _ _ _ _ H (Derivative_imp_inc _ _ _ _ derF)). split. exact (included_trans _ _ _ _ H (Derivative_imp_inc' _ _ _ _ derF)). intros. apply included_imp_Derivative; Included. Qed. Lemma Derivative_const : forall c : IR, Derivative I pI [-C-]c [-C-][0]. Proof. intros; split. Included. split; Deriv. Qed. Lemma Derivative_id : Derivative I pI FId [-C-][1]. Proof. split. Included. split; Deriv. Qed. Lemma Derivative_plus : Derivative I pI (F{+}G) (F'{+}G'). Proof. elim derF; intros incF H. elim H; intros incF' derivF. elim derG; intros incG H'. elim H'; intros incG' derivG. split. Included. split; Deriv. Qed. Lemma Derivative_inv : Derivative I pI {--}F {--}F'. Proof. elim derF; intros incF H. elim H; intros incF' derivF. split. Included. split; Deriv. Qed. Lemma Derivative_minus : Derivative I pI (F{-}G) (F'{-}G'). Proof. elim derF; intros incF H. elim H; intros incF' derivF. elim derG; intros incG H'. elim H'; intros incG' derivG. split. Included. split; Deriv. Qed. Lemma Derivative_mult : Derivative I pI (F{*}G) (F{*}G'{+}F'{*}G). Proof. elim derF; intros incF H. elim H; intros incF' derivF. elim derG; intros incG H'. elim H'; intros incG' derivG. split. Included. split. apply included_FPlus; Included. Deriv. Qed. Lemma Derivative_scal : forall c : IR, Derivative I pI (c{**}F) (c{**}F'). Proof. intro. elim derF; intros incF H. elim H; intros incF' derivF. split. Included. split; Deriv. Qed. Lemma Derivative_poly : forall p, Derivative I pI (FPoly _ p) (FPoly _ (_D_ p)). Proof. intro. split. Included. split; Deriv. Qed. Lemma Derivative_nth : forall n, Derivative I pI (F{^}S n) (nring (S n) {**} (F'{*}F{^}n)). Proof. elim derF; intros incF H. elim H; intros incF' derivF. split. Included. split; Deriv. Qed. Lemma Derivative_recip : bnd_away_zero_in_P G I -> Derivative I pI {1/}G {--} (G'{/}G{*}G). Proof. elim derG; intros incG H'. elim H'; intros incG' derivG. clear derF derG H'. intro. cut (forall x : IR, I x -> forall Hx, Part G x Hx [#] [0]); intros. cut (forall x : IR, I x -> forall Hx, (G{*}G) x Hx [#] [0]); intros. split. Included. split; Deriv. simpl in |- *; apply mult_resp_ap_zero; auto. Included. Qed. End More_Results. Section More_Corollaries. Variable I : interval. Hypothesis pI : proper I. Variables F F' G G' : PartIR. Hypothesis derF : Derivative I pI F F'. Hypothesis derG : Derivative I pI G G'. (* begin show *) Hypothesis Gbnd : bnd_away_zero_in_P G I. (* end show *) Lemma Derivative_div : Derivative I pI (F{/}G) ((F'{*}G{-}F{*}G') {/}G{*}G). Proof. elim derF; intros incF Hf. elim Hf; intros incF' Hf'. elim derG; intros incG derivG. elim derivG; intros incG' Hg'. clear Hf derivG. cut (forall x : IR, I x -> forall Hx, Part G x Hx [#] [0]); intros. split. Included. split. apply included_FDiv. apply included_FMinus; Included. Included. intros; simpl in |- *; apply mult_resp_ap_zero; auto. Deriv. Included. Qed. End More_Corollaries. Section More_Sums. Variable I : interval. Hypothesis pI : proper I. Lemma Derivative_Sumx : forall n (f f' : forall i, i < n -> PartIR), (forall i Hi Hi', Derivative I pI (f i Hi) (f' i Hi')) -> Derivative I pI (FSumx n f) (FSumx n f'). Proof. intro; induction n as [| n Hrecn]; intros f f' derF. simpl in |- *; apply Derivative_const; auto. simpl in |- *; apply Derivative_plus; auto. Qed. (* begin show *) Variables f f' : nat -> PartIR. Hypothesis derF : forall n : nat, Derivative I pI (f n) (f' n). (* end show *) Lemma Derivative_Sum0 : forall n, Derivative I pI (FSum0 n f) (FSum0 n f'). Proof. intros. induction n as [| n Hrecn]. eapply Derivative_wdl. apply FSum0_0; Included. eapply Derivative_wdr. apply FSum0_0; Included. apply Derivative_const. eapply Derivative_wdl. apply FSum0_S; Included. eapply Derivative_wdr. apply FSum0_S; Included. apply Derivative_plus; auto. Qed. Lemma Derivative_Sum : forall m n, Derivative I pI (FSum m n f) (FSum m n f'). Proof. intros. eapply Derivative_wdl. apply Feq_symmetric; apply FSum_FSum0'; Included. eapply Derivative_wdr. apply Feq_symmetric; apply FSum_FSum0'; Included. apply Derivative_minus; apply Derivative_Sum0. Qed. End More_Sums. Section Diffble_Basic_Properties. (** ** Differentiability Mutatis mutandis for differentiability. *) Variable I : interval. Hypothesis pI : proper I. Lemma Diffble_imp_inc : forall F, Diffble I pI F -> included I (Dom F). Proof. intros F H. inversion_clear H. auto. Qed. Lemma Derivative_imp_Diffble : forall F F', Derivative I pI F F' -> Diffble I pI F. Proof. intros F F' H. elim H; intros incF H'. elim H'; intros incF' derivF. split; auto. intros; apply deriv_imp_Diffble_I with F'; auto. Qed. Lemma Diffble_wd : forall F H, Feq I F H -> Diffble I pI F -> Diffble I pI H. Proof. intros F H H0 H1. elim H0; intros incF H2. elim H2; intros incH eqFH. inversion_clear H1. split; auto. intros; apply Diffble_I_wd with F; auto. apply included_Feq with I; auto. Qed. Variables F G : PartIR. Hypothesis diffF : Diffble I pI F. Hypothesis diffG : Diffble I pI G. (** %\begin{convention}% Assume [F] and [G] are differentiable in [I]. %\end{convention}% *) Lemma included_imp_Diffble : forall a b Hab, included (Compact (less_leEq _ a b Hab)) I -> Diffble_I Hab F. Proof. intros. elim diffF; auto. Qed. Lemma Included_imp_Diffble : forall J (pJ : proper J), included J I -> Diffble J pJ F. Proof. intros J pJ H. split. exact (included_trans _ _ _ _ H (Diffble_imp_inc _ diffF)). intros; apply included_imp_Diffble; Included. Qed. Lemma Diffble_const : forall c : IR, Diffble I pI [-C-]c. Proof. intro. split. Included. intros; apply Diffble_I_const. Qed. Lemma Diffble_id : Diffble I pI FId. Proof. split. Included. intros; apply Diffble_I_id. Qed. Lemma Diffble_plus : Diffble I pI (F{+}G). Proof. elim diffF; intros incF diffbleF. elim diffG; intros incG diffbleG. split. Included. intros; apply Diffble_I_plus; auto. Qed. Lemma Diffble_inv : Diffble I pI {--}F. Proof. elim diffF; intros incF diffbleF. split. Included. intros; apply Diffble_I_inv; auto. Qed. Lemma Diffble_minus : Diffble I pI (F{-}G). Proof. elim diffF; intros incF diffbleF. elim diffG; intros incG diffbleG. split. Included. intros; apply Diffble_I_minus; auto. Qed. Lemma Diffble_mult : Diffble I pI (F{*}G). Proof. elim diffF; intros incF diffbleF. elim diffG; intros incG diffbleG. split. Included. intros; apply Diffble_I_mult; auto. Qed. Lemma Diffble_nth : forall n : nat, Diffble I pI (F{^}n). Proof. elim diffF; intros incF diffbleF. split. Included. intros; apply Diffble_I_nth; auto. Qed. Lemma Diffble_scal : forall c : IR, Diffble I pI (c{**}F). Proof. elim diffF; intros incF diffbleF. split. Included. intros; apply Diffble_I_scal; auto. Qed. Lemma Diffble_poly : forall p, Diffble I pI (FPoly _ p). Proof. split. Included. intros; apply Diffble_I_poly; auto. Qed. Lemma Diffble_recip : bnd_away_zero_in_P G I -> Diffble I pI {1/}G. Proof. elim diffG; intros incG diffbleG Gbnd. cut (forall x : IR, I x -> forall Hx, Part G x Hx [#] [0]); intros. split. Included. intros; apply Diffble_I_recip; auto. Included. Qed. End Diffble_Basic_Properties. #[global] Hint Immediate Diffble_imp_inc: included. Section Diffble_Corollaries. Variable I : interval. Hypothesis pI : proper I. Variables F G : PartIR. Hypothesis diffF : Diffble I pI F. Hypothesis diffG : Diffble I pI G. Lemma Diffble_div : bnd_away_zero_in_P G I -> Diffble I pI (F{/}G). Proof. intro. apply Diffble_wd with (F{*}{1/}G). apply eq_imp_Feq. apply included_FMult. apply Diffble_imp_inc with pI; apply diffF. apply included_FRecip. apply Diffble_imp_inc with pI; apply diffG. Included. apply included_FDiv. apply Diffble_imp_inc with pI; apply diffF. apply Diffble_imp_inc with pI; apply diffG. Included. intros; simpl in |- *; rational. apply Diffble_mult; auto. apply Diffble_recip; auto. Qed. Lemma Diffble_Sum0 : forall f, (forall n, Diffble I pI (f n)) -> forall n, Diffble I pI (FSum0 n f). Proof. intros f hypF n. split. intros x H n0. elim (hypF n0); intros. exact (a x H). intros; apply Diffble_I_Sum0; auto. intro; elim (hypF n0); auto. Qed. Lemma Diffble_Sumx : forall n f, ext_fun_seq' f -> (forall i Hi, Diffble I pI (f i Hi)) -> Diffble I pI (FSumx n f). Proof. intros n f Hgood hypF. split. red in |- *; intros. apply FSumx_pred'; auto. intros. elim (hypF i Hi); auto. intros; apply Diffble_I_Sumx. intros i Hi; elim (hypF i Hi); auto. Qed. Lemma Diffble_Sum : forall f, (forall n, Diffble I pI (f n)) -> forall m n, Diffble I pI (FSum m n f). Proof. intros f hypF m n. eapply Diffble_wd. apply Feq_symmetric; apply FSum_FSum0'. intro; apply Diffble_imp_inc with pI; auto. apply Diffble_minus; apply Diffble_Sum0; auto. Qed. End Diffble_Corollaries. Section Nth_Derivative. (** ** Nth Derivative Higher order derivatives pose more interesting problems. It turns out that it really becomes necessary to generalize our [n_deriv] operator to any interval. *) Variable I : interval. Hypothesis pI : proper I. Section Definitions. (** %\begin{convention}% Let [n:nat], [F:PartIR] and assume that [F] is n-times differentiable in [I]. %\end{convention}% *) Variable n : nat. Variable F : PartIR. Hypothesis diffF : Diffble_n n I pI F. Definition N_Deriv_fun : forall x : IR, I x -> IR. Proof. intros x H. set (J := compact_in_interval I pI x H) in *. elim diffF; intros incF diffbleF. set (a := Lend (compact_compact_in_interval I pI x H)) in *. set (b := Rend (compact_compact_in_interval I pI x H)) in *. fold J in (value of a), (value of b). cut (a [<] b). intro H0. cut (Diffble_I_n H0 n F). intro H1. apply (Part (n_deriv_I _ _ _ _ _ H1) x). apply n_deriv_inc. unfold a, b, J in |- *; apply iprop_compact_in_interval_inc2. apply iprop_compact_in_interval. apply diffbleF. apply (included_trans _ (Compact (less_leEq IR a b H0)) J); unfold a, b, J in |- *; Included. unfold a, b, J in |- *; apply proper_compact_in_interval'. Defined. Lemma N_Deriv_char (* begin hide *) : forall x Hx H, N_Deriv_fun x Hx [=] Part (n_deriv_I _ _ (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval I pI x Hx)) n F H) x (n_deriv_inc _ _ _ _ _ _ _ (iprop_compact_in_interval_inc2 _ _ _ _ (compact_compact_in_interval _ _ _ _) (less_leEq _ _ _ (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval _ _ _ _))) _ (iprop_compact_in_interval _ _ _ _))). Proof. intros. unfold N_Deriv_fun in |- *. elim diffF; intros; simpl in |- *. apply n_deriv_I_wd'. algebra. apply iprop_compact_in_interval'. apply iprop_compact_in_interval'. apply b. apply included_trans with (Compact (less_leEq _ _ _ (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval I pI x Hx)))). 2: Included. intros x0 H0. inversion_clear H0. split. eapply leEq_wdl. apply H1. eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft; apply eq_imp_leEq. apply compact_in_interval_wd1; algebra. eapply leEq_wdr. apply H2. apply leEq_imp_Max_is_rht; apply eq_imp_leEq. apply compact_in_interval_wd2; algebra. Qed. (* end hide *) Lemma N_Deriv_strext : forall x y Hx Hy, N_Deriv_fun x Hx [#] N_Deriv_fun y Hy -> x [#] y. Proof. intros x y Hx Hy H. elim diffF; intros incF diffbleF. cut (Diffble_I_n (proper_compact_in_interval2' _ _ _ _ _ _ (compact_compact_in_interval2 I pI x y Hx Hy)) n F). intro H0. cut (Diffble_I_n (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval I pI x Hx)) n F). intro H1. cut (Diffble_I_n (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval I pI y Hy)) n F). intro H2. cut (Dom (n_deriv_I _ _ _ _ _ H0) x). intro H3. cut (Dom (n_deriv_I _ _ _ _ _ H0) y). intro H4. apply pfstrx with (Hx := H3) (Hy := H4). eapply ap_wdl_unfolded. eapply ap_wdr_unfolded. apply H. eapply eq_transitive_unfolded. apply (N_Deriv_char y Hy H2). apply n_deriv_I_wd'. algebra. apply iprop_compact_in_interval_inc2; apply iprop_compact_in_interval. apply iprop_compact_in_interval2_inc2; apply iprop_compact_in_interval2y. apply included_imp_diffble_n with (Hab' := proper_compact_in_interval2' _ _ _ _ _ _ (compact_compact_in_interval2 I pI x y Hx Hy)). 2: apply H0. red in |- *; intros z Hz. inversion_clear Hz; split. eapply leEq_wdl. apply H5. eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft. apply compact_in_interval_y_lft. eapply leEq_wdr. apply H6. apply leEq_imp_Max_is_rht. apply compact_in_interval_y_rht. eapply eq_transitive_unfolded. apply (N_Deriv_char x Hx H1). apply n_deriv_I_wd'. algebra. apply iprop_compact_in_interval_inc2; apply iprop_compact_in_interval. apply iprop_compact_in_interval2_inc2; apply iprop_compact_in_interval2x. apply included_imp_diffble_n with (Hab' := proper_compact_in_interval2' _ _ _ _ _ _ (compact_compact_in_interval2 I pI x y Hx Hy)). 2: apply H0. red in |- *; intros z Hz. inversion_clear Hz; split. eapply leEq_wdl. apply H5. eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft. apply compact_in_interval_x_lft. eapply leEq_wdr. apply H6. apply leEq_imp_Max_is_rht. apply compact_in_interval_x_rht. apply n_deriv_inc. apply iprop_compact_in_interval2_inc2; apply iprop_compact_in_interval2y. apply n_deriv_inc. apply iprop_compact_in_interval2_inc2; apply iprop_compact_in_interval2x. apply diffbleF. simpl in |- *; Included. apply diffbleF. simpl in |- *; Included. apply diffbleF. simpl in |- *; Included. Qed. Lemma N_Deriv_wd : forall x y Hx Hy, x [=] y -> N_Deriv_fun x Hx [=] N_Deriv_fun y Hy. Proof. intros. apply not_ap_imp_eq. intro H0. cut (x [#] y). apply eq_imp_not_ap; auto. exact (N_Deriv_strext _ _ _ _ H0). Qed. Definition N_Deriv : PartIR. Proof. apply Build_PartFunct with (pfpfun := N_Deriv_fun). apply iprop_wd. exact N_Deriv_strext. Defined. End Definitions. Section Basic_Results. (** All the usual results hold. *) Lemma Diffble_n_wd : forall n F G, Feq I F G -> Diffble_n n I pI F -> Diffble_n n I pI G. Proof. intros n F G H H0. elim H; intros incF H1. elim H1; intro incG. split. auto. intros; apply Diffble_I_n_wd with F. apply included_Feq with I; auto. elim H0; auto. Qed. Lemma Derivative_n_wdr : forall n F G H, Feq I G H -> Derivative_n n I pI F G -> Derivative_n n I pI F H. Proof. intros n F G H H0 H1. elim H0; intros incG H2. elim H2; intros incH Heq. elim H1; intros incF H0'. elim H0'; intros incG' derivF. clear H2 H0'. split; auto. split; auto. intros; apply Derivative_I_n_wdr with G. apply included_Feq with I; auto. auto. Qed. Lemma Derivative_n_wdl : forall n F G H, Feq I F G -> Derivative_n n I pI F H -> Derivative_n n I pI G H. Proof. intros n F G H H0 H1. elim H0; intros incG H2. elim H2; intros incH Heq. elim H1; intros incF H0'. elim H0'; intros incG' derivF. clear H2 H0'. split; auto. split; auto. intros; apply Derivative_I_n_wdl with F. apply included_Feq with I; auto. auto. Qed. Lemma Derivative_n_unique : forall n F G H, Derivative_n n I pI F G -> Derivative_n n I pI F H -> Feq I G H. Proof. intros n F G H H0 H1. elim H0; intros incF H2. elim H2; intros incG derivFG. elim H1; intros incF' H3. elim H3; intros incH derivFH. FEQ. rename X into H4. apply Feq_imp_eq with (Compact (less_leEq _ _ _ (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval I pI x H4)))). apply Derivative_I_n_unique with n F. apply derivFG. simpl in |- *; Included. apply derivFH. simpl in |- *; Included. apply interval_compact_inc. apply iprop_compact_in_interval. Qed. Lemma Diffble_n_imp_Diffble : forall n : nat, 0 < n -> forall F, Diffble_n n I pI F -> Diffble I pI F. Proof. intros n H F H0. elim H0; intros incF diffF. split; auto. intros; apply Diffble_I_n_imp_diffble with n; auto. Qed. Lemma Derivative_n_imp_Diffble : forall n, 0 < n -> forall F F', Derivative_n n I pI F F' -> Diffble I pI F. Proof. intros n H F F' H0. elim H0; intros incF H1. elim H1; intros incF' derivF. split; auto. intros; apply deriv_n_imp_diffble with n F'; auto. Qed. Lemma le_imp_Diffble_n : forall m n, m <= n -> forall F, Diffble_n n I pI F -> Diffble_n m I pI F. Proof. intros m n H F H0. elim H0; intros incF diffF. split; auto. intros; apply le_imp_Diffble_I with n; auto. Qed. Lemma Diffble_n_imp_le : forall n, 0 < n -> forall F F', Diffble_n n I pI F -> Derivative I pI F F' -> Diffble_n (pred n) I pI F'. Proof. intros n H F F' H0 H1. elim H0; intros incF diffF. elim H1; intros incFa H2. elim H2; intros incF' derivF. split; auto. intros; apply Diffble_I_imp_le with F; auto. Qed. Lemma Diffble_n_imp_inc : forall n F, Diffble_n n I pI F -> included I (Dom F). Proof. intros n F H. inversion_clear H; auto. Qed. Lemma Derivative_n_imp_Diffble_n : forall n F F', Derivative_n n I pI F F' -> Diffble_n n I pI F. Proof. intros n F F' H. elim H; intros incF H1. elim H1; intros incF' derivF. split; auto. intros; apply deriv_n_imp_Diffble_I_n with F'; auto. Qed. Lemma Derivative_n_imp_inc : forall n F F', Derivative_n n I pI F F' -> included I (Dom F). Proof. intros n F F' H. inversion_clear H; auto. Qed. Lemma Derivative_n_imp_inc' : forall n F F', Derivative_n n I pI F F' -> included I (Dom F'). Proof. intros. inversion_clear X; inversion_clear X1; auto. Qed. Lemma included_imp_Derivative_n : forall n F F' a b Hab, Derivative_n n I pI F F' -> included (Compact (less_leEq _ a b Hab)) I -> Derivative_I_n Hab n F F'. Proof. intros n F F' a b Hab H H0. elim H; intros incF H1. elim H1; auto. Qed. Lemma included_imp_Diffble_n : forall n F a b Hab, Diffble_n n I pI F -> included (Compact (less_leEq _ a b Hab)) I -> Diffble_I_n Hab n F. Proof. intros. elim X; auto. Qed. Lemma Included_imp_Derivative_n : forall n (J : interval) pJ F F', included J I -> Derivative_n n I pI F F' -> Derivative_n n J pJ F F'. Proof. intros n J pJ F F' H H0. elim H0; clear H0; intros H1 H2. elim H2; clear H2; intros H0 H3. split. Included. split. Included. intros; apply H3. Included. Qed. Lemma Included_imp_Diffble_n : forall n (J : interval) pJ F, included J I -> Diffble_n n I pI F -> Diffble_n n J pJ F. Proof. intros n J pJ F H H0. elim H0; clear H0; intros H1 H2. split. Included. intros; apply H2. Included. Qed. Lemma Derivative_n_plus : forall J pJ n m k F G H, Derivative_n m J pJ F G -> Derivative_n n J pJ G H -> k = m + n -> Derivative_n k J pJ F H. Proof. intros J pJ n m k F G H H0 H1 H2. elim H0; intros incF Hf. elim Hf; intros incG derFG. elim H1; intros incG' Hg. elim Hg; intros incH derGH. clear Hf Hg. split; auto. split; auto. intros; apply Derivative_I_n_plus with n m G; auto. Qed. End Basic_Results. Section More_Results. (** Some new results hold, too: *) Lemma N_Deriv_Feq : forall n F diffF a b Hab H (incN : included (Compact (less_leEq _ _ _ Hab)) (Dom (N_Deriv n F diffF))), Feq (Compact (less_leEq _ _ _ Hab)) (N_Deriv n F diffF) (n_deriv_I a b Hab n F H). Proof. intros. FEQ. apply n_deriv_inc. simpl in |- *. cut (Diffble_I_n (proper_compact_in_interval' _ _ _ _ (compact_compact_in_interval I pI x Hx)) n F). intro H1. eapply eq_transitive_unfolded. apply (N_Deriv_char n F diffF x Hx H1). apply n_deriv_I_wd'; auto. algebra. apply iprop_compact_in_interval_inc2; apply iprop_compact_in_interval. apply included_imp_Diffble_n; auto. apply included_interval'. apply (included_compact_in_interval I pI x Hx). apply (iprop_compact_in_interval_inc1 _ _ _ _ (compact_compact_in_interval I pI x Hx) (Lend_leEq_Rend _ (compact_compact_in_interval I pI x Hx))). apply compact_inc_lft. apply (included_compact_in_interval I pI x Hx). apply (iprop_compact_in_interval_inc1 _ _ _ _ (compact_compact_in_interval I pI x Hx) (Lend_leEq_Rend _ (compact_compact_in_interval I pI x Hx))). apply compact_inc_rht. apply incN; apply compact_inc_lft. apply incN; apply compact_inc_rht. elim diffF; intros incF diffbleF. apply diffbleF; auto. eapply included_trans. apply iprop_compact_in_interval_inc1. Included. Qed. Lemma N_Deriv_lemma : forall n F H, Derivative_n n I pI F (N_Deriv n F H). Proof. intros. elim H; intros incF diffF. split; auto. split; Included. intros a b Hab H0. cut (Diffble_I_n Hab n F). intro H1. 2: auto. eapply Derivative_I_n_wdr. apply Feq_symmetric; apply (N_Deriv_Feq n F (incF, diffF) _ _ Hab H1 H0). apply n_deriv_lemma. Qed. Lemma N_Deriv_S : forall n F H HS, Derivative I pI (N_Deriv n F H) (N_Deriv (S n) F HS). Proof. intros n F H H'. split; Included. split; Included. elim H; intros incF diffFn. elim H'; intros incF' diffFSn. intros a b Hab H0. cut (Diffble_I_n Hab n F). intro H1. 2: auto. cut (Diffble_I_n Hab (S n) F). intro H2. 2: auto. eapply Derivative_I_wdl. apply Feq_symmetric; apply (N_Deriv_Feq n F (incF, diffFn) _ _ Hab H1 H0). eapply Derivative_I_wdr. apply Feq_symmetric; apply (N_Deriv_Feq _ _ (incF', diffFSn) _ _ Hab H2 H0). apply n_Sn_deriv. Qed. Lemma N_Deriv_plus : forall m n F H H', Derivative_n m I pI (N_Deriv n F H) (N_Deriv (m + n) F H'). Proof. intros. split; Included. split; Included. intros a b Hab H0. cut (Diffble_I_n Hab n F). intro H1. cut (Diffble_I_n Hab (m + n) F). intro H2. eapply Derivative_I_n_wdl. apply Feq_symmetric; apply (N_Deriv_Feq n F H _ _ Hab H1 H0). eapply Derivative_I_n_wdr. apply Feq_symmetric; apply (N_Deriv_Feq _ _ H' _ _ Hab H2 H0). apply n_deriv_plus. elim H'; auto. elim H; auto. Qed. (** Some useful characterization results. *) Lemma Derivative_n_O : forall F, included I (Dom F) -> Derivative_n 0 I pI F F. Proof. intros. split; Included. split; Included. intros. red in |- *; apply Feq_reflexive; Included. Qed. Lemma Derivative_n_Sn : forall F n fn fSn, Derivative_n n I pI F fn -> Derivative_n (S n) I pI F fSn -> Derivative I pI fn fSn. Proof. intros F n fn fSn H H0. cut (Diffble_n n I pI F); [ intro H1 | eapply Derivative_n_imp_Diffble_n; apply H ]. cut (Diffble_n (S n) I pI F); [ intro H2 | eapply Derivative_n_imp_Diffble_n; apply H0 ]. apply Derivative_wdl with (N_Deriv _ _ H1). apply Derivative_n_unique with n F. apply N_Deriv_lemma. auto. apply Derivative_wdr with (N_Deriv _ _ H2). apply Derivative_n_unique with (S n) F. apply N_Deriv_lemma. auto. apply N_Deriv_S. Qed. End More_Results. Section Derivating_Diffble. (** As a special case we get a differentiation operator%\ldots%#...# *) Variable F : PartIR. (* begin show *) Hypothesis diffF : Diffble I pI F. (* end show *) Lemma Diffble_imp_Diffble_n : Diffble_n 1 I pI F. Proof. elim diffF; intros incF diffbleF. split; auto. intros a b Hab H; exists (diffbleF a b Hab H). simpl in |- *; Included. Qed. Definition Deriv := N_Deriv 1 F Diffble_imp_Diffble_n. End Derivating_Diffble. Section Corollaries. (** %\ldots%#...# for which the expected property also holds. *) Lemma Deriv_lemma : forall F diffF, Derivative I pI F (Deriv F diffF). Proof. intros; unfold Deriv in |- *. apply Derivative_wdl with (N_Deriv 0 F (le_imp_Diffble_n 0 1 (Nat.le_succ_diag_r 0) F (Diffble_imp_Diffble_n _ diffF))). apply Derivative_n_unique with 0 F. apply N_Deriv_lemma. apply Derivative_n_O; elim diffF; auto. apply N_Deriv_S. Qed. (** Some more interesting properties. *) Lemma Derivative_n_1 : forall F G, Derivative I pI F G -> Derivative_n 1 I pI F G. Proof. intros F G H. cut (Diffble I pI F). intro H0. apply Derivative_n_wdr with (Deriv _ H0). apply Derivative_unique with pI F. apply Deriv_lemma. auto. unfold Deriv in |- *; apply N_Deriv_lemma. apply Derivative_imp_Diffble with G; auto. Qed. Lemma Derivative_n_chain : forall F f, Feq I F (f 0) -> (forall n, Derivative I pI (f n) (f (S n))) -> forall n, Derivative_n n I pI F (f n). Proof. intros F f H H0 n. induction n as [| n Hrecn]. apply Derivative_n_wdr with F. auto. apply Derivative_n_O. elim H; auto. apply Derivative_n_plus with 1 n (f n); auto. apply Derivative_n_1; auto. rewrite Nat.add_comm; auto. Qed. Lemma Derivative_n_imp_Continuous : forall n F G, 0 < n -> Derivative_n n I pI F G -> Continuous I F. Proof. intros n F G H H0. cut (Diffble I pI F). intro H1. apply Derivative_imp_Continuous with pI (Deriv _ H1). apply Deriv_lemma. apply Diffble_n_imp_Diffble with n; auto. apply Derivative_n_imp_Diffble_n with G; auto. Qed. Lemma Derivative_n_imp_Continuous' : forall n F G, 0 < n -> Derivative_n n I pI F G -> Continuous I G. Proof. intros n F G H H0. cut (Diffble_n (pred n) I pI F). intro H1. apply Derivative_imp_Continuous' with pI (N_Deriv _ _ H1). apply Derivative_wdr with (N_Deriv _ _ (Derivative_n_imp_Diffble_n _ _ _ H0)). apply Derivative_n_unique with n F; auto; apply N_Deriv_lemma. cut (n = S (pred n)); [ intro | symmetry; apply Nat.lt_succ_pred with 0; auto ]. generalize H0 H1. rewrite H2. intros. apply N_Deriv_S. apply le_imp_Diffble_n with n. auto with arith. apply Derivative_n_imp_Diffble_n with G; auto. Qed. End Corollaries. End Nth_Derivative. #[global] Hint Resolve Derivative_const Derivative_id Derivative_plus Derivative_inv Derivative_minus Derivative_mult Derivative_scal Derivative_nth Derivative_recip Derivative_div Derivative_Sumx Derivative_Sum0 Derivative_Sum: derivate. #[global] Hint Immediate Derivative_n_imp_inc Derivative_n_imp_inc' Diffble_n_imp_inc: included. #[global] Hint Resolve Deriv_lemma N_Deriv_lemma: derivate. #[global] Hint Immediate Derivative_n_imp_Continuous Derivative_n_imp_Continuous': continuous. corn-8.20.0/ftc/MoreIntegrals.v000066400000000000000000000540031473720167500162760ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Integral. Require Export CoRN.ftc.MoreFunctions. Section Lemmas. (** printing Integral %\ensuremath{\int}% #∫# *) (** printing integral' %\ensuremath{\int}% #∫# *) (** * The generalized integral In this file we extend the definition of integral to allow for arbitrary integration domains (that is, not requiring that the lower endpoint of integration be less or equal than the upper endpoint) and we prove the fundamental properties of the new operator. %\begin{convention}% Let [a, b : IR] and assume that [F] and [G] are two partial functions continuous in [[Min(a,b),Max(a,b)]]. %\end{convention}% ** Definitions Before we define the new integral we need to some trivial interval inclusions. *) Variables a b : IR. Hypothesis Hab : Min a b [<=] Max a b. Lemma compact_inc_Min_lft : forall H, included (compact (Min a b) a H) (Compact Hab). Proof. intros. apply included_compact; split. apply leEq_reflexive. apply Min_leEq_Max. apply Min_leEq_lft. apply lft_leEq_Max. Qed. Lemma compact_inc_Min_rht : forall H, included (compact (Min a b) b H) (Compact Hab). Proof. intros. apply included_compact; split. apply leEq_reflexive. apply Min_leEq_Max. apply Min_leEq_rht. apply rht_leEq_Max. Qed. End Lemmas. Section Definitions. (** The integral is defined by the formula $\int_a^bf=\int_{\min(a,b)}^bf-\int_{\min(a,b)}^af$#∫abf=∫min(a,b)bf-∫min(a,b)af#, inspired by the domain union rule; obviously it coincides with the classical definition, and it collapses to the old one in the case [a [<=] b]. *) Variables a b : IR. Hypothesis Hab : Min a b [<=] Max a b. Variable F : PartIR. Hypothesis HF : Continuous_I Hab F. Lemma Integral_inc1 : Continuous_I (Min_leEq_lft a b) F. Proof. eapply included_imp_contin with (Hab := Hab). 2: apply HF. apply compact_inc_Min_lft. Qed. Lemma Integral_inc2 : Continuous_I (Min_leEq_rht a b) F. Proof. eapply included_imp_contin with (Hab := Hab). 2: apply HF. apply compact_inc_Min_rht. Qed. Definition Integral := integral _ _ (Min_leEq_rht a b) F Integral_inc2[-]integral _ _ (Min_leEq_lft a b) _ Integral_inc1. Lemma Integral_integral : forall Hab' HF', Integral [=] integral a b Hab' F HF'. Proof. intros. unfold Integral in |- *. astepr (integral a b Hab' F HF'[-][0]). apply cg_minus_wd. apply integral_wd'. apply leEq_imp_Min_is_lft; assumption. algebra. apply integral_empty. apply leEq_imp_Min_is_lft; assumption. Qed. End Definitions. Arguments Integral [a b Hab F]. Section Properties_of_Integral. (** ** Properties of the Integral All our old properties carry over to this new definition---and some new ones, too. We begin with (strong) extensionality. *) Variables a b : IR. Hypothesis Hab : Min a b [<=] Max a b. Variables F G : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis contG : Continuous_I Hab G. Lemma Integral_strext : Integral contF [#] Integral contG -> {x : IR | Compact Hab x | forall Hx Hx', Part F x Hx [#] Part G x Hx'}. Proof. intro H. unfold Integral in H. elim (cg_minus_strext _ _ _ _ _ H); intro. elim (integral_strext _ _ _ _ _ _ _ a0); intros. exists x. apply compact_inc_Min_rht with (H := Min_leEq_rht a b); assumption. assumption. elim (integral_strext _ _ _ _ _ _ _ b0); intros. exists x. apply compact_inc_Min_lft with (H := Min_leEq_lft a b); assumption. assumption. Qed. Lemma Integral_strext' : forall c d Hcd HF1 HF2, Integral (Hab:=Hab) (F:=F) HF1 [#] Integral (a:=c) (b:=d) (Hab:=Hcd) (F:=F) HF2 -> a [#] c or b [#] d. Proof. intros c d Hcd HF1 HF2 H. elim (cg_minus_strext _ _ _ _ _ H); clear H; intro H; elim (integral_strext' _ _ _ _ _ _ _ _ _ H); clear H; intro H. elim (Min_strext_unfolded _ _ _ _ H); auto. auto. elim (Min_strext_unfolded _ _ _ _ H); auto. auto. Qed. Lemma Integral_wd : Feq (Compact Hab) F G -> Integral contF [=] Integral contG. Proof. intros; unfold Integral in |- *. apply cg_minus_wd; apply integral_wd. apply included_Feq with (Compact Hab). apply compact_inc_Min_rht. assumption. apply included_Feq with (Compact Hab). apply compact_inc_Min_lft. assumption. Qed. Lemma Integral_wd' : forall a' b' Ha'b' contF', a [=] a' -> b [=] b' -> Integral contF [=] Integral (a:=a') (b:=b') (Hab:=Ha'b') (F:=F) contF'. Proof. intros. unfold Integral in |- *. apply cg_minus_wd; apply integral_wd'; try apply bin_op_wd_unfolded; algebra. Qed. (** The integral is a linear operator. *) Lemma Integral_const : forall c (H : Continuous_I Hab [-C-]c), Integral H [=] c[*] (b[-]a). Proof. intros. unfold Integral in |- *. rstepr (c[*] (b[-]Min a b) [-]c[*] (a[-]Min a b)). apply cg_minus_wd; apply integral_const. Qed. Lemma Integral_comm_scal : forall c (H : Continuous_I Hab (c{**}F)), Integral H [=] c[*]Integral contF. Proof. intros. unfold Integral in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply dist_2a. apply cg_minus_wd; apply integral_comm_scal. Qed. Lemma Integral_plus : forall H : Continuous_I Hab (F{+}G), Integral H [=] Integral contF[+]Integral contG. Proof. intro. unfold Integral in |- *. cut (forall x y z w : IR, x[-]y[+] (z[-]w) [=] x[+]z[-] (y[+]w)); intros. 2: rational. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply H0. apply cg_minus_wd; apply integral_plus. Qed. Lemma Integral_inv : forall H : Continuous_I Hab {--}F, Integral H [=] [--] (Integral contF). Proof. intro. unfold Integral in |- *. cut (forall x y : IR, [--] (x[-]y) [=] [--]x[-][--]y); intros. 2: rational. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply H0. apply cg_minus_wd; apply integral_inv. Qed. Lemma Integral_minus : forall H : Continuous_I Hab (F{-}G), Integral H [=] Integral contF[-]Integral contG. Proof. intro. unfold Integral in |- *. cut (forall x y z w : IR, x[-]y[-] (z[-]w) [=] x[-]z[-] (y[-]w)); intros. 2: rational. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply H0. apply cg_minus_wd; apply integral_minus. Qed. Lemma linear_Integral : forall alpha beta (H : Continuous_I Hab (alpha{**}F{+}beta{**}G)), Integral H [=] alpha[*]Integral contF[+]beta[*]Integral contG. Proof. intros; unfold Integral in |- *. cut (forall x y z r s t : IR, x[*] (y[-]z) [+]r[*] (s[-]t) [=] x[*]y[+]r[*]s[-] (x[*]z[+]r[*]t)). 2: intros; rational. intro; eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply H0. clear H0. apply cg_minus_wd; apply linear_integral. Qed. (** If the endpoints are equal then the integral vanishes. *) Lemma Integral_empty : a [=] b -> Integral contF [=] [0]. Proof. intros. unfold Integral in |- *. astepr (ZeroR[-][0]). apply cg_minus_wd; apply integral_empty. astepr a; apply leEq_imp_Min_is_lft; apply eq_imp_leEq; assumption. apply leEq_imp_Min_is_lft; apply eq_imp_leEq; assumption. Qed. (** And the norm provides an upper bound for the absolute value of the integral. *) Lemma Integral_leEq_norm : AbsIR (Integral contF) [<=] Norm_Funct contF[*]AbsIR (b[-]a). Proof. unfold Integral in |- *. eapply leEq_transitive. apply triangle_IR_minus. apply leEq_transitive with (Norm_Funct contF[*] (b[-]Min a b) [+]Norm_Funct contF[*] (a[-]Min a b)). apply plus_resp_leEq_both; (eapply leEq_transitive; [ apply integral_leEq_norm | apply mult_resp_leEq_rht ]). apply leEq_Norm_Funct; intros. apply norm_bnd_AbsIR; apply compact_inc_Min_rht with (H := Min_leEq_rht a b); assumption. apply shift_leEq_minus; astepl (Min a b); apply Min_leEq_rht. apply leEq_Norm_Funct; intros. apply norm_bnd_AbsIR; apply compact_inc_Min_lft with (H := Min_leEq_lft a b); assumption. apply shift_leEq_minus; astepl (Min a b); apply Min_leEq_lft. eapply leEq_wdl. 2: apply ring_dist_unfolded. apply mult_resp_leEq_lft. 2: apply positive_norm. rstepl (a[+]b[-]Two[*]Min a b). apply shift_minus_leEq; apply shift_leEq_plus'. apply shift_leEq_mult' with (two_ap_zero IR). apply pos_two. apply leEq_Min. apply shift_div_leEq. apply pos_two. apply shift_minus_leEq; apply shift_leEq_plus'. rstepl (b[-]a); apply leEq_AbsIR. apply shift_div_leEq. apply pos_two. apply shift_minus_leEq; apply shift_leEq_plus'. rstepl ( [--] (b[-]a)); apply inv_leEq_AbsIR. Qed. End Properties_of_Integral. Section More_Properties. (** Two other ways of stating the addition law for domains. *) Lemma integral_plus_Integral : forall a b Hab F c Hac Hcb Hab' Hac' Hcb', integral c b Hcb F Hcb' [=] integral a b Hab F Hab'[-]integral a c Hac F Hac'. Proof. intros. rstepl (integral a c Hac F Hac'[+]integral c b Hcb F Hcb'[-]integral a c Hac F Hac'). apply cg_minus_wd. apply integral_plus_integral. algebra. Qed. Lemma integral_plus_integral' : forall a b Hab F c Hac Hcb Hab' Hac' Hcb', integral a c Hac F Hac' [=] integral a b Hab F Hab'[-]integral c b Hcb F Hcb'. Proof. intros. rstepl (integral a c Hac F Hac'[+]integral c b Hcb F Hcb'[-]integral c b Hcb F Hcb'). apply cg_minus_wd. apply integral_plus_integral. algebra. Qed. (** And now we can prove the addition law for domains with our general operator. %\begin{convention}% Assume [c : IR]. %\end{convention}% *) Variables a b c : IR. (* begin show *) Hypothesis Hab' : Min a b [<=] Max a b. Hypothesis Hac' : Min a c [<=] Max a c. Hypothesis Hcb' : Min c b [<=] Max c b. Hypothesis Habc' : Min (Min a b) c [<=] Max (Max a b) c. (* end show *) Variable F : PartIR. (* begin show *) Hypothesis Hab : Continuous_I Hab' F. Hypothesis Hac : Continuous_I Hac' F. Hypothesis Hcb : Continuous_I Hcb' F. Hypothesis Habc : Continuous_I Habc' F. (* end show *) (* begin hide *) Let le_abc_ab : Min (Min a b) c [<=] Min a b. Proof. apply Min_leEq_lft. Qed. Let le_abc_ac : Min (Min a b) c [<=] Min a c. Proof. apply leEq_Min. eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_lft. apply Min_leEq_rht. Qed. Let le_abc_cb : Min (Min a b) c [<=] Min c b. Proof. apply leEq_Min. apply Min_leEq_rht. eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_rht. Qed. Let le_abc_a : Min (Min a b) c [<=] a. Proof. eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_lft. Qed. Let le_abc_b : Min (Min a b) c [<=] b. Proof. eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_rht. Qed. Let le_abc_c : Min (Min a b) c [<=] c. Proof. apply Min_leEq_rht. Qed. Let le_ab_a : Min a b [<=] a. Proof. apply Min_leEq_lft. Qed. Let le_cb_c : Min c b [<=] c. Proof. apply Min_leEq_lft. Qed. Let le_ac_a : Min a c [<=] a. Proof. apply Min_leEq_lft. Qed. Let le_ab_b : Min a b [<=] b. Proof. apply Min_leEq_rht. Qed. Let le_cb_b : Min c b [<=] b. Proof. apply Min_leEq_rht. Qed. Let le_ac_c : Min a c [<=] c. Proof. apply Min_leEq_rht. Qed. Let Habc_abc : Compact Habc' (Min (Min a b) c). Proof. apply compact_inc_lft. Qed. Let Habc_ab : Continuous_I le_abc_ab F. Proof. apply included_imp_contin with (Hab := Habc'). 2: apply Habc. apply included_compact; [ apply Habc_abc | split ]. apply Min_leEq_lft. eapply leEq_transitive. apply Min_leEq_Max. apply lft_leEq_Max. Qed. Let Habc_ac : Continuous_I le_abc_ac F. Proof. apply included_imp_contin with (Hab := Habc'). 2: apply Habc. apply included_compact; [ apply Habc_abc | split ]. apply le_abc_ac. eapply leEq_transitive. apply Min_leEq_Max. apply Max_leEq. eapply leEq_transitive. 2: apply lft_leEq_Max. apply lft_leEq_Max. apply rht_leEq_Max. Qed. Let Habc_cb : Continuous_I le_abc_cb F. Proof. apply included_imp_contin with (Hab := Habc'). 2: apply Habc. apply included_compact; [ apply Habc_abc | split ]. apply le_abc_cb. eapply leEq_transitive. 2: apply rht_leEq_Max. apply Min_leEq_lft. Qed. Let Habc_a : Continuous_I le_abc_a F. Proof. apply included_imp_contin with (Hab := Habc'). 2: apply Habc. apply included_compact; [ apply Habc_abc | split ]. apply le_abc_a. eapply leEq_transitive. 2: apply lft_leEq_Max. apply lft_leEq_Max. Qed. Let Habc_b : Continuous_I le_abc_b F. Proof. apply included_imp_contin with (Hab := Habc'). 2: apply Habc. apply included_compact; [ apply Habc_abc | split ]. apply le_abc_b. eapply leEq_transitive. 2: apply lft_leEq_Max. apply rht_leEq_Max. Qed. Let Habc_c : Continuous_I le_abc_c F. Proof. apply included_imp_contin with (Hab := Habc'). 2: apply Habc. apply included_compact; [ apply Habc_abc | split ]. apply le_abc_c. apply rht_leEq_Max. Qed. (* end hide *) Lemma Integral_plus_Integral : Integral Hab [=] Integral Hac[+]Integral Hcb. Proof. unfold Integral in |- *. apply eq_transitive_unfolded with (integral _ _ le_abc_b _ Habc_b[-]integral _ _ le_abc_ab _ Habc_ab[-] (integral _ _ le_abc_a _ Habc_a[-]integral _ _ le_abc_ab _ Habc_ab)). apply cg_minus_wd; apply integral_plus_Integral. rstepl (integral _ _ le_abc_b _ Habc_b[-]integral _ _ le_abc_a _ Habc_a). rstepl (integral _ _ le_abc_c _ Habc_c[-]integral _ _ le_abc_ac _ Habc_ac[-] (integral _ _ le_abc_a _ Habc_a[-]integral _ _ le_abc_ac _ Habc_ac) [+] (integral _ _ le_abc_b _ Habc_b[-]integral _ _ le_abc_cb _ Habc_cb[-] (integral _ _ le_abc_c _ Habc_c[-]integral _ _ le_abc_cb _ Habc_cb))). apply eq_symmetric_unfolded; apply bin_op_wd_unfolded; apply cg_minus_wd; apply integral_plus_Integral. Qed. (** Notice that, unlike in the classical case, an extra hypothesis (the continuity of [F] in the interval [[Min(a,b,c),Max(a,b,c)]]) must be assumed. *) End More_Properties. Section Corollaries. Variables a b : IR. Hypothesis Hab : Min a b [<=] Max a b. Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. (** As a corollary, we get the following rule: *) Lemma Integral_op : forall Hab' (contF' : Continuous_I (a:=Min b a) (b:=Max b a) Hab' F), Integral contF [=] [--] (Integral contF'). Proof. intros. apply cg_inv_unique'. cut (Continuous_I (Min_leEq_Max a a) F). intro H. apply eq_transitive_unfolded with (Integral H). cut (Min (Min a a) b [<=] Max (Max a a) b); intros. apply eq_symmetric_unfolded; apply Integral_plus_Integral with H0. cut (included (Compact H0) (Compact Hab)). intro H1. exact (included_imp_contin _ _ _ _ _ _ _ H1 contF). apply included_compact. split. apply leEq_Min. apply leEq_transitive with a. apply Min_leEq_lft. apply eq_imp_leEq; apply eq_symmetric_unfolded; apply Min_id. apply Min_leEq_rht. apply leEq_transitive with b. apply Min_leEq_rht. apply rht_leEq_Max. split. apply leEq_transitive with b. apply Min_leEq_rht. apply rht_leEq_Max. apply Max_leEq. apply leEq_wdl with a. apply lft_leEq_Max. apply eq_symmetric_unfolded; apply Max_id. apply rht_leEq_Max. apply leEq_transitive with b. apply Min_leEq_rht. apply rht_leEq_Max. apply Integral_empty; algebra. apply included_imp_contin with (Hab := Hab). 2: apply contF. intros x H. apply compact_wd with a. split. apply Min_leEq_lft. apply lft_leEq_Max. inversion_clear H. apply leEq_imp_eq. eapply leEq_wdl. apply H0. apply Min_id. eapply leEq_wdr. apply H1. apply Max_id. Qed. (** Finally, some miscellaneous results: *) Lemma Integral_less_norm : a [#] b -> forall x, Compact Hab x -> forall Hx, AbsIR (F x Hx) [<] Norm_Funct contF -> AbsIR (Integral contF) [<] Norm_Funct contF[*]AbsIR (b[-]a). Proof. intros H x H0 Hx H1. set (N := Norm_Funct contF) in *. elim (ap_imp_less _ _ _ H); intro. apply less_wdr with (N[*] (b[-]a)). eapply less_wdl. eapply less_leEq_trans. apply integral_less_norm with (contF := included_imp_contin _ _ _ _ _ _ _ (compact_map2 a b (less_leEq _ _ _ a0) Hab) contF) (Hx := Hx); auto. apply compact_map1 with (Hab' := Hab); auto. eapply less_leEq_trans. apply H1. unfold N in |- *; apply included_imp_norm_leEq. apply compact_map1. apply mult_resp_leEq_rht. unfold N in |- *; apply included_imp_norm_leEq. apply compact_map2. apply shift_leEq_minus; apply less_leEq. astepl a; auto. apply AbsIR_wd; apply eq_symmetric_unfolded. apply Integral_integral. apply mult_wdr. apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply shift_leEq_minus; apply less_leEq. astepl a; auto. apply less_wdr with (N[*] (a[-]b)). set (Hmin := Min_leEq_Max b a) in *. cut (included (Compact Hmin) (Compact Hab)). cut (included (Compact Hab) (Compact Hmin)). intros H2 H3. cut (Continuous_I Hmin F). intro H4. eapply less_wdl. eapply less_leEq_trans. apply integral_less_norm with (contF := included_imp_contin _ _ _ _ _ _ _ (compact_map2 _ _ (less_leEq _ _ _ b0) Hmin) H4) (Hx := Hx); auto. apply compact_map1 with (Hab' := Hmin); auto. eapply less_leEq_trans. apply H1. unfold N in |- *; apply included_imp_norm_leEq. eapply included_trans. 2: apply compact_map1 with (Hab' := Hmin). apply H2. apply mult_resp_leEq_rht. unfold N in |- *; apply included_imp_norm_leEq. eapply included_trans. apply compact_map2 with (Hab' := Hmin). apply H3. apply shift_leEq_minus; apply less_leEq. astepl b; auto. eapply eq_transitive_unfolded. apply AbsIR_inv. apply AbsIR_wd; apply eq_symmetric_unfolded. apply eq_transitive_unfolded with ( [--] (Integral (included_imp_contin _ _ _ _ _ _ _ H3 contF))). apply Integral_op. apply un_op_wd_unfolded. apply Integral_integral. apply included_imp_contin with (Hab := Hab); auto. red in |- *; intros. apply compact_wd' with (Hab := Hab). apply Min_comm. apply Max_comm. auto. red in |- *; intros. apply compact_wd' with (Hab := Hmin). apply Min_comm. apply Max_comm. auto. apply mult_wdr. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply shift_leEq_minus; apply less_leEq. astepl b; auto. apply AbsIR_minus. Qed. Lemma ub_Integral : a [#] b -> forall c, (forall x, Compact Hab x -> forall Hx, AbsIR (F x Hx) [<=] c) -> forall x, Compact Hab x -> forall Hx, AbsIR (F x Hx) [<] c -> AbsIR (Integral contF) [<] c[*]AbsIR (b[-]a). Proof. intros H c H0 x H1 Hx H2. set (N := Norm_Funct contF) in *. cut (N [<=] c); intros. elim (less_cotransitive_unfolded _ _ _ H2 N); intros. apply less_leEq_trans with (N[*]AbsIR (b[-]a)). unfold N in |- *; apply Integral_less_norm with x Hx; auto. apply mult_resp_leEq_rht; auto. apply AbsIR_nonneg. apply leEq_less_trans with (N[*]AbsIR (b[-]a)). unfold N in |- *; apply Integral_leEq_norm. apply mult_resp_less; auto. apply AbsIR_pos. apply minus_ap_zero. apply ap_symmetric_unfolded; auto. unfold N in |- *; apply leEq_Norm_Funct; auto. Qed. End Corollaries. Lemma Integral_ap_zero : forall a b Hab (F : PartIR) contF, a [#] b -> forall x, Compact Hab x -> forall Hx, [0] [<] F x Hx -> (forall x, Compact Hab x -> forall Hx, [0] [<=] F x Hx) -> [0] [<] AbsIR (Integral (a:=a) (b:=b) (Hab:=Hab) (F:=F) contF). Proof. intros a b Hab F contF H x H0 Hx H1 H2. elim (ap_imp_less _ _ _ H); intro. eapply less_leEq_trans. 2: apply leEq_AbsIR. eapply less_wdr. 2: apply eq_symmetric_unfolded. 2: apply Integral_integral with (HF' := included_imp_contin _ _ _ _ _ _ _ (compact_map2 a b (less_leEq _ _ _ a0) Hab) contF). eapply integral_gt_zero with x Hx; auto. exact (compact_map1 _ _ (less_leEq _ _ _ a0) Hab x H0). intros x0 H3 Hx0; apply H2. exact (compact_map2 _ _ (less_leEq _ _ _ a0) Hab _ H3). cut (included (Compact (Min_leEq_Max b a)) (Compact Hab)). 2: apply included_compact; split. 2: apply eq_imp_leEq; apply Min_comm. 2: apply leEq_transitive with a; [ apply Min_leEq_rht | apply lft_leEq_Max ]. 2: apply leEq_transitive with b; [ apply Min_leEq_rht | apply lft_leEq_Max ]. 2: apply eq_imp_leEq; apply Max_comm. cut (included (Compact Hab) (Compact (Min_leEq_Max b a))). 2: apply included_compact; split. 2: apply eq_imp_leEq; apply Min_comm. 2: apply leEq_transitive with b; [ apply Min_leEq_rht | apply lft_leEq_Max ]. 2: apply leEq_transitive with a; [ apply Min_leEq_rht | apply lft_leEq_Max ]. 2: apply eq_imp_leEq; apply Max_comm. intros H3 H4. eapply less_leEq_trans. 2: apply inv_leEq_AbsIR. eapply less_wdr. 2: apply Integral_op with (contF := included_imp_contin _ _ _ _ _ _ _ H4 contF). eapply less_wdr. 2: apply eq_symmetric_unfolded. 2: apply Integral_integral with (HF' := included_imp_contin _ _ _ _ _ _ _ (compact_map2 _ _ (less_leEq _ _ _ b0) (Min_leEq_Max b a)) (included_imp_contin _ _ _ _ _ _ _ H4 contF)). eapply integral_gt_zero with x Hx; auto. exact (compact_map1 _ _ (less_leEq _ _ _ b0) (Min_leEq_Max b a) x (H3 x H0)). intros x0 H5 Hx0; apply H2. exact (H4 _ (compact_map2 _ _ (less_leEq _ _ _ b0) (Min_leEq_Max _ _) _ H5)). Qed. Lemma Integral_eq_zero : forall a b Hab (F : PartIR) contF x, Compact Hab x -> (forall Hx, [0] [<] F x Hx) -> (forall x, Compact Hab x -> forall Hx, [0] [<=] F x Hx) -> Integral (a:=a) (b:=b) (Hab:=Hab) (F:=F) contF [=] [0] -> a [=] b. Proof. intros a b Hab F contF x H X H0 H1. apply not_ap_imp_eq; intro. apply less_irreflexive_unfolded with (x := ZeroR). apply less_wdr with (AbsIR (Integral contF)). 2: Step_final (AbsIR [0]). apply Integral_ap_zero with x (contin_imp_inc _ _ _ _ contF x H); auto. Qed. corn-8.20.0/ftc/MoreIntervals.v000066400000000000000000001276721473720167500163320ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.NthDerivative. Opaque Min Max. Section Intervals. (** printing realline %\ensuremath{\RR}% #(-∞,+∞)# *) (** printing openl %\ensuremath{(\cdot,+\infty)}% #(⋅,+∞)# *) (** printing openr %\ensuremath{(-\infty,\cdot)}% #(-∞,⋅)# *) (** printing closel %\ensuremath{[\cdot,+\infty)}% #[⋅,+∞)# *) (** printing closer %\ensuremath{(-\infty,\cdot]}% #(-∞,⋅]# *) (** printing olor %\ensuremath{(\cdot,\cdot)}% #(⋅,⋅)# *) (** printing clor %\ensuremath{[\cdot,\cdot)}% #[⋅,⋅)# *) (** printing olcr %\ensuremath{(\cdot,\cdot]}% #(⋅,⋅]# *) (** printing clcr %\ensuremath{[\cdot,\cdot]}% #[⋅,⋅]# *) (** * Generalized Intervals At this stage we have enough material to begin generalizing our concepts in preparation for the fundamental theorem of calculus and the definition of the main (non-polynomial) functions of analysis. In order to define functions via power series (or any other kind of series) we need to formalize a notion of convergence more general than the one we already have on compact intervals. This is necessary for practical reasons: we want to define a single exponential function with domain [IR], not several exponential functions defined on compact intervals which we prove to be the same wherever their domains overlap. In a similar way, we want to define indefinite integrals on infinite domains and not only on compact intervals. Unfortunately, proceeding in a way analogous to how we defined the concept of global continuity will lead us nowhere; the concept turns out to be to general, and the behaviour on too small domains (typically intervals [[a,a']] where [a [=] a'] is neither provably true nor provably false) will be unsatisfactory. There is a special family of sets, however, where this problems can be avoided: intervals. Intervals have some nice properties that allow us to prove good results, namely the facts that if [a] and [b] are elements of an interval [I] then so are [Min(a,b)] and [Max(a,b)] (which is in general not true) and also the compact interval [[a,b]] is included in [I]. Furthermore, all intervals are characterized by simple, well defined predicates, and the nonempty and proper concepts become very easy to define. ** Definitions and Basic Results We define an inductive type of intervals with nine constructors, corresponding to the nine basic types of intervals. The reason why so many constructors are needed is that we do not have a notion of real line, for many reasons which we will not discuss here. Also it seems simple to directly define finite intervals than to define then later as intersections of infinite intervals, as it would only mess things up. The compact interval which we will define here is obviously the same that we have been working with all the way through; why, then, the different formulation? The reason is simple: if we had worked with intervals from the beginning we would have had case definitions at every spot, and our lemmas and proofs would have been very awkward. Also, it seems more natural to characterize a compact interval by two real numbers (and a proof) than as a particular case of a more general concept which doesn't have an intuitive interpretation. Finally, the definitions we will make here will have the elegant consequence that from this point on we can work with any kind of intervals in exactly the same way. *) Inductive interval : Type := | realline : interval | openl : IR -> interval | openr : IR -> interval | closel : IR -> interval | closer : IR -> interval | olor : IR -> IR -> interval | olcr : IR -> IR -> interval | clor : IR -> IR -> interval | clcr : IR -> IR -> interval. (** To each interval a predicate (set) is assigned by the following map: *) Definition iprop (I : interval) (x : IR) : CProp := match I with | realline => True | openr b => x [<] b | openl a => a [<] x | closer b => x [<=] b | closel a => a [<=] x | olor a b => a [<] x and x [<] b | olcr a b => a [<] x and x [<=] b | clor a b => a [<=] x and x [<] b | clcr a b => a [<=] x and x [<=] b end. (* begin hide *) Coercion iprop : interval >-> Funclass. (* end hide *) (** This map is made into a coercion, so that intervals %\emph{%##are%}%## really subsets of reals. We now define what it means for an interval to be nonvoid, proper, finite and compact in the obvious way. *) Definition nonvoid (I : interval) : CProp := match I with | realline => True | openr b => True | openl a => True | closer b => True | closel a => True | olor a b => a [<] b | olcr a b => a [<] b | clor a b => a [<] b | clcr a b => a [<=] b end. Definition proper (I : interval) : CProp := match I with | realline => True | openr b => True | openl a => True | closer b => True | closel a => True | olor a b => a [<] b | olcr a b => a [<] b | clor a b => a [<] b | clcr a b => a [<] b end. Definition finite (I : interval) : CProp := match I with | realline => False | openr b => False | openl a => False | closer b => False | closel a => False | olor a b => True | olcr a b => True | clor a b => True | clcr a b => True end. Definition compact_ (I : interval) : CProp := match I with | realline => False | openr b => False | openl a => False | closer b => False | closel a => False | olor a b => False | olcr a b => False | clor a b => False | clcr a b => a [<=] b end. (** Finite intervals have a left end and a right end. *) Definition left_end (I : interval) : finite I -> IR. Proof. intro. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; rename X into H. inversion H. inversion H. inversion H. inversion H. inversion H. apply c. apply c. apply c. apply c. Defined. Definition right_end (I : interval) : finite I -> IR. Proof. intro. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; rename X into H. inversion H. inversion H. inversion H. inversion H. inversion H. apply c0. apply c0. apply c0. apply c0. Defined. (** Some trivia: compact intervals are finite; proper intervals are nonvoid; an interval is nonvoid iff it contains some point. *) Lemma compact_finite : forall I : interval, compact_ I -> finite I. intros; induction I as [| c| c| c| c| c c0| c c0| c c0| c c0]; simpl in |- *; auto. Qed. Lemma proper_nonvoid : forall I : interval, proper I -> nonvoid I. Proof. intro. elim I; simpl in |- *; intros; auto. apply less_leEq; auto. Qed. Lemma nonvoid_point : forall I : interval, nonvoid I -> {x : IR | I x}. Proof. intro. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; simpl in |- *; intros; try rename X into H. exists ZeroR; auto. exists (c[+][1]); apply less_plusOne. exists (c[-][1]); apply shift_minus_less; apply less_plusOne. exists c; apply leEq_reflexive. exists c; apply leEq_reflexive. exists (c[+] (c0[-]c) [/]TwoNZ); split. astepl (c[+][0]); apply plus_resp_less_lft. apply div_resp_pos. apply pos_two. apply shift_less_minus; astepl c; auto. rstepr (c[+] (c0[-]c)). apply plus_resp_less_lft. apply pos_div_two'. apply shift_less_minus; astepl c; auto. exists c0; split; auto; apply leEq_reflexive. exists c; split; auto; apply leEq_reflexive. exists c; split; [ apply leEq_reflexive | auto ]. Qed. Lemma nonvoid_char : forall (I : interval) (x : IR), I x -> nonvoid I. Proof. intro; induction I; simpl in |- *; intros x H; auto; inversion_clear H. apply less_transitive_unfolded with x; auto. apply less_leEq_trans with x; auto. apply leEq_less_trans with x; auto. apply leEq_transitive with x; auto. Qed. (** For practical reasons it helps to define left end and right end of compact intervals. *) Definition Lend I (H : compact_ I) := left_end I (compact_finite I H). Definition Rend I (H : compact_ I) := right_end I (compact_finite I H). (** In a compact interval, the left end is always less than or equal to the right end. *) Lemma Lend_leEq_Rend : forall I cI, Lend I cI [<=] Rend I cI. Proof. intro; elim I; simpl in |- *; intros; try inversion cI; auto. Qed. (** Some nice characterizations of inclusion: *) Lemma compact_included : forall a b Hab (I : interval), I a -> I b -> included (compact a b Hab) I. Proof. induction I; red in |- *; simpl in |- *; intros X X0 x X1; try inversion_clear X; try inversion_clear X0; try inversion_clear X1. auto. apply less_leEq_trans with a; auto. apply leEq_less_trans with b; auto. apply leEq_transitive with a; auto. apply leEq_transitive with b; auto. split; [ apply less_leEq_trans with a | apply leEq_less_trans with b ]; auto. split; [ apply less_leEq_trans with a | apply leEq_transitive with b ]; auto. split; [ apply leEq_transitive with a | apply leEq_less_trans with b ]; auto. split; [ apply leEq_transitive with a | apply leEq_transitive with b ]; auto. Qed. (** This lemma is almost same as [compact_included] above, except that it gets rid of the hypothesis [Hab : a [<=] b] *) Lemma interval_convex: forall (a b : IR) (I : interval), I a -> I b -> included (clcr a b) I. Proof. intros ? ? ? Ha Hb. unfold included. intros x Hab. simpl in Hab. destruct Hab as [Hab Habr]. destruct I; simpl in Ha, Hb; simpl; try (split; destruct Ha, Hb); eauto using leEq_less_trans, leEq_reflexive, less_leEq_trans, leEq_transitive. Qed. (** Classically, this is a trivial consequence of [interval_convex]. However, a constructive proof seems to require a little more work*) Lemma interval_Min: forall {a b : IR} {I : interval}, I a -> I b -> I (Min a b). Proof. intros ? ? ? Ha Hb. destruct I; simpl in Ha, Hb; simpl; try (split; destruct Ha, Hb); eauto using leEq_less_trans, leEq_reflexive, leEq_transitive, Min_leEq_lft, less_Min, leEq_Min. Qed. Lemma interval_Max: forall {a b : IR} {I : interval}, I a -> I b -> I (Max a b). Proof. intros ? ? ? Ha Hb. destruct I; simpl in Ha, Hb; simpl; try (split; destruct Ha, Hb); eauto using less_leEq_trans, leEq_reflexive, leEq_transitive, lft_leEq_Max, Max_less, Max_leEq. Qed. Lemma included_interval' : forall (I : interval) x y z w, I x -> I y -> I z -> I w -> forall H, included (compact (Min x z) (Max y w) H) I. Proof. intros I x y z w; induction I; simpl in |- *; intros X X0 X1 X2 H; red in |- *; intros t Ht; inversion_clear Ht; simpl in |- *; try inversion_clear X; try inversion_clear X0; try inversion_clear X1; try inversion_clear X2; try split. apply less_leEq_trans with (Min x z); try apply less_Min; auto. apply leEq_less_trans with (Max y w); try apply Max_less; auto. apply leEq_transitive with (Min x z); try apply leEq_Min; auto. apply leEq_transitive with (Max y w); try apply Max_leEq; auto. apply less_leEq_trans with (Min x z); try apply less_Min; auto. apply leEq_less_trans with (Max y w); try apply Max_less; auto. apply less_leEq_trans with (Min x z); try apply less_Min; auto. apply leEq_transitive with (Max y w); try apply Max_leEq; auto. apply leEq_transitive with (Min x z); try apply leEq_Min; auto. apply leEq_less_trans with (Max y w); try apply Max_less; auto. apply leEq_transitive with (Min x z); try apply leEq_Min; auto. apply leEq_transitive with (Max y w); try apply Max_leEq; auto. Qed. Lemma included_interval : forall (I : interval) x y, I x -> I y -> forall H, included (compact (Min x y) (Max x y) H) I. Proof. intros; apply included_interval'; auto. Qed. (** A weirder inclusion result. *) Lemma included3_interval : forall (I : interval) x y z Hxyz, I x -> I y -> I z -> included (compact (Min (Min x y) z) (Max (Max x y) z) Hxyz) I. Proof. intros I x y z Hxyz H H0 H1. apply included_interval'; auto. apply (included_interval I x y H H0 (Min_leEq_Max _ _)). apply compact_inc_lft. apply (included_interval I x y H H0 (Min_leEq_Max _ _)). apply compact_inc_rht. Qed. (** Finally, all intervals are characterized by well defined predicates. *) Lemma iprop_wd : forall I : interval, pred_wd _ I. Proof. induction I; unfold iprop in |- *; red in |- *; intros x y X X0; try inversion_clear X; try inversion X0. auto. astepr x; auto. astepl x; auto. astepr x; auto. astepl x; auto. split. astepr x; auto. astepl x; auto. split. astepr x; auto. astepl x; auto. split. astepr x; auto. astepl x; auto. split. astepr x; auto. astepl x; auto. Qed. End Intervals. Arguments Lend [I]. Arguments Rend [I]. Section Compact_Constructions. Section Single_Compact_Interval. (** ** Constructions with Compact Intervals Several important constructions are now discussed. We begin by defining the compact interval [[x,x]]. %\begin{convention}% Let [P:IR->CProp] be well defined, and [x:IR] such that [P(x)] holds. %\end{convention}% *) Variable P : IR -> CProp. Hypothesis wdP : pred_wd IR P. Variable x : IR. Hypothesis Hx : P x. Definition compact_single := Compact (leEq_reflexive _ x). (** This interval contains [x] and only (elements equal to) [x]; furthermore, for every (well-defined) [P], if $x\in P$#x∈P# then $[x,x]\subseteq P$#[x,x]⊆P#. *) Lemma compact_single_prop : compact_single x. Proof. split; apply leEq_reflexive. Qed. Lemma compact_single_pt : forall y : IR, compact_single y -> x [=] y. Proof. intros y H. inversion_clear H; apply leEq_imp_eq; auto. Qed. Lemma compact_single_inc : included compact_single P. Proof. red in |- *; intros. apply wdP with x. auto. apply compact_single_pt; auto. Qed. End Single_Compact_Interval. (** The special case of intervals is worth singling out, as one of the hypothesis becomes a theorem. *) Definition compact_single_iprop I := compact_single_inc _ (iprop_wd I). (** Now for more interesting and important results. Let [I] be a proper interval and [x] be a point of [I]. Then there is a proper compact interval [[a,b]] such that $x\in[a,b]\subseteq I$#x∈[a,b]⊆I#. *) Section Proper_Compact_with_One_or_Two_Points. (* begin hide *) Let cip1' : forall c x : IR, c [<=] x -> x[-] (x[-]c) [/]TwoNZ [<=] x. Proof. intros. astepr (x[-][0]). unfold cg_minus at 1 3 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq; apply shift_leEq_div. apply pos_two. apply shift_leEq_minus; rstepl c; auto. Qed. Let cip1'' : forall c x : IR, c [<] x -> x[-] (x[-]c) [/]TwoNZ [<] x. Proof. intros. astepr (x[-][0]). unfold cg_minus at 1 3 in |- *; apply plus_resp_less_lft. apply inv_resp_less; apply shift_less_div. apply pos_two. apply shift_less_minus; rstepl c; auto. Qed. Let cip1''' : forall c0 x : IR, x [<=] c0 -> x [<=] x[+] (c0[-]x) [/]TwoNZ. Proof. intros. astepl (x[+][0]). apply plus_resp_leEq_lft. apply shift_leEq_div. apply pos_two. apply shift_leEq_minus; rstepl x; auto. Qed. Let cip1'''' : forall c0 x : IR, x [<] c0 -> x [<] x[+] (c0[-]x) [/]TwoNZ. Proof. intros. astepl (x[+][0]). apply plus_resp_less_lft. apply shift_less_div. apply pos_two. apply shift_less_minus; rstepl x; auto. Qed. Let cip2 : forall c x x0 : IR, c [<=] x -> x[-] (x[-]c) [/]TwoNZ [<=] x0 -> c [<=] x0. Proof. intros. apply leEq_transitive with (c[+] (x[-]c) [/]TwoNZ). astepl (c[+][0]); apply plus_resp_leEq_lft. apply shift_leEq_div. apply pos_two. apply shift_leEq_minus; rstepl c; auto. eapply leEq_wdl. apply H0. rational. Qed. Let cip2' : forall c x x0 : IR, c [<] x -> x[-] (x[-]c) [/]TwoNZ [<=] x0 -> c [<] x0. Proof. intros c x x0 H H0. apply less_leEq_trans with (c[+] (x[-]c) [/]TwoNZ). astepl (c[+][0]); apply plus_resp_less_lft. apply shift_less_div. apply pos_two. apply shift_less_minus; rstepl c; auto. eapply leEq_wdl. apply H0. rational. Qed. Let cip2'' : forall c x x0 : IR, c [<=] x -> x[-] (x[-]c) [/]TwoNZ [<] x0 -> c [<] x0. Proof. intros c x x0 H H0. apply leEq_less_trans with (c[+] (x[-]c) [/]TwoNZ). astepl (c[+][0]); apply plus_resp_leEq_lft. apply shift_leEq_div. apply pos_two. apply shift_leEq_minus; rstepl c; auto. eapply less_wdl. apply H0. rational. Qed. Let cip2''' : forall c x x0 : IR, c [<] x -> x[-] (x[-]c) [/]TwoNZ [<] x0 -> c [<] x0. Proof. intros c x x0 H H0. apply cip2'' with x. apply less_leEq; auto. auto. Qed. Let cip3 : forall c0 x x0 : IR, x [<=] c0 -> x0 [<=] x[+] (c0[-]x) [/]TwoNZ -> x0 [<=] c0. Proof. intros c0 x x0 H H0. eapply leEq_transitive. apply H0. rstepl (c0[-] (c0[-]x) [/]TwoNZ). astepr (c0[-][0]); unfold cg_minus at 1 3 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. apply shift_leEq_div. apply pos_two. apply shift_leEq_minus; rstepl x; auto. Qed. Let cip3' : forall c0 x x0 : IR, x [<] c0 -> x0 [<=] x[+] (c0[-]x) [/]TwoNZ -> x0 [<] c0. Proof. intros c0 x x0 H H0. eapply leEq_less_trans. apply H0. rstepl (c0[-] (c0[-]x) [/]TwoNZ). astepr (c0[-][0]); unfold cg_minus at 1 3 in |- *; apply plus_resp_less_lft. apply inv_resp_less. apply shift_less_div. apply pos_two. apply shift_less_minus; rstepl x; auto. Qed. Let cip3'' : forall c0 x x0 : IR, x [<=] c0 -> x0 [<] x[+] (c0[-]x) [/]TwoNZ -> x0 [<] c0. Proof. intros c0 x x0 H H0. eapply less_leEq_trans. apply H0. rstepl (c0[-] (c0[-]x) [/]TwoNZ). astepr (c0[-][0]); unfold cg_minus at 1 3 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. apply shift_leEq_div. apply pos_two. apply shift_leEq_minus; rstepl x; auto. Qed. Let cip3''' : forall c0 x x0 : IR, x [<] c0 -> x0 [<] x[+] (c0[-]x) [/]TwoNZ -> x0 [<] c0. Proof. intros c0 x x0 H H0. apply cip3'' with x; try apply less_leEq; auto. Qed. (* end hide *) Definition compact_in_interval I (pI : proper I) x (Hx : I x) : interval. Proof. intros; destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros. apply (clcr x (x[+][1])). apply (clcr x (x[+][1])). apply (clcr (x[-][1]) x). apply (clcr x (x[+][1])). apply (clcr (x[-][1]) x). apply (clcr (x[-] (x[-]c) [/]TwoNZ) (x[+] (c0[-]x) [/]TwoNZ)). apply (clcr (x[-] (x[-]c) [/]TwoNZ) (x[+] (c0[-]x) [/]TwoNZ)). apply (clcr (x[-] (x[-]c) [/]TwoNZ) (x[+] (c0[-]x) [/]TwoNZ)). apply (clcr c c0). Defined. Lemma compact_compact_in_interval : forall I pI x Hx, compact_ (compact_in_interval I pI x Hx). Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx; try apply ts; apply less_leEq. apply less_plusOne. apply less_plusOne. apply shift_minus_less; apply less_plusOne. apply less_plusOne. apply shift_minus_less; apply less_plusOne. eapply less_transitive_unfolded; [ apply cip1'' | apply cip1'''' ]; auto. eapply less_leEq_trans; [ apply cip1'' | apply cip1''' ]; auto. eapply leEq_less_trans; [ apply cip1' | apply cip1'''' ]; auto. auto. Qed. Lemma proper_compact_in_interval : forall I pI x Hx, proper (compact_in_interval I pI x Hx). Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx. apply less_plusOne. apply less_plusOne. apply shift_minus_less; apply less_plusOne. apply less_plusOne. apply shift_minus_less; apply less_plusOne. eapply less_transitive_unfolded; [ apply cip1'' | apply cip1'''' ]; auto. eapply less_leEq_trans; [ apply cip1'' | apply cip1''' ]; auto. eapply leEq_less_trans; [ apply cip1' | apply cip1'''' ]; auto. auto. Qed. Lemma proper_compact_in_interval' : forall I pI x Hx (H : compact_ (compact_in_interval I pI x Hx)), Lend H [<] Rend H. Proof. do 4 intro. cut (proper (compact_in_interval I pI x Hx)). 2: apply proper_compact_in_interval. elim (compact_in_interval I pI x Hx); intros; try inversion H. simpl in |- *; simpl in H; auto. Qed. Lemma included_compact_in_interval : forall I pI x Hx, included (compact_in_interval I pI x Hx) I. Proof. induction I; simpl in |- *; intros X x X0; try inversion_clear Hx; red in |- *; simpl in |- *; intros x0 X1; try inversion_clear X; try inversion_clear X0; try inversion_clear X1; auto. apply less_leEq_trans with x; auto. apply leEq_less_trans with x; auto. apply leEq_transitive with x; auto. apply leEq_transitive with x; auto. split. apply cip2' with x; auto. apply cip3' with x; auto. split. apply cip2' with x; auto. apply cip3 with x; auto. split. apply cip2 with x; auto. apply cip3' with x; auto. Qed. Lemma iprop_compact_in_interval : forall I pI x Hx, compact_in_interval I pI x Hx x. Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx; split; auto; try apply leEq_reflexive. apply less_leEq; apply less_plusOne. apply less_leEq; apply less_plusOne. apply less_leEq; apply shift_minus_less; apply less_plusOne. apply less_leEq; apply less_plusOne. apply less_leEq; apply shift_minus_less; apply less_plusOne. apply less_leEq; apply cip1''; auto. apply less_leEq; apply cip1''''; auto. apply less_leEq; apply cip1''; auto. apply less_leEq; apply cip1''''; auto. Qed. Lemma iprop_compact_in_interval' : forall I pI x Hx (H : compact_ (compact_in_interval I pI x Hx)) H', compact (Lend H) (Rend H) H' x. Proof. do 4 intro. cut (compact_in_interval I pI x Hx x). 2: apply iprop_compact_in_interval. elim (compact_in_interval I pI x Hx); intros; try inversion H. simpl in |- *; auto. Qed. Lemma iprop_compact_in_interval_inc1 : forall I pI x Hx (H : compact_ (compact_in_interval I pI x Hx)) H', included (compact (Lend H) (Rend H) H') (compact_in_interval I pI x Hx). Proof. do 4 intro. elim (compact_in_interval I pI x Hx); intros; try inversion H. unfold compact in |- *; simpl in |- *; Included. Qed. Lemma iprop_compact_in_interval_inc2 : forall I pI x Hx (H : compact_ (compact_in_interval I pI x Hx)) H', included (compact_in_interval I pI x Hx) (compact (Lend H) (Rend H) H'). Proof. do 4 intro. elim (compact_in_interval I pI x Hx); intros; try inversion H. unfold compact in |- *; simpl in |- *; Included. Qed. (** If [x [=] y] then the construction yields the same interval whether we use [x] or [y] in its definition. This property is required at some stage, which is why we formalized this result as a functional definition rather than as an existential formula. *) Lemma compact_in_interval_wd1 : forall I pI x Hx y Hy (H : compact_ (compact_in_interval I pI x Hx)) (H' : compact_ (compact_in_interval I pI y Hy)), x [=] y -> Lend H [=] Lend H'. Proof. intro I; elim I; simpl in |- *; intros; algebra. Qed. Lemma compact_in_interval_wd2 : forall I pI x Hx y Hy (H : compact_ (compact_in_interval I pI x Hx)) (H' : compact_ (compact_in_interval I pI y Hy)), x [=] y -> Rend H [=] Rend H'. Proof. intro I; elim I; simpl in |- *; intros; algebra. Qed. (** We can make an analogous construction for two points. *) Definition compact_in_interval2 I (pI : proper I) x y : I x -> I y -> interval. Proof. intros. set (z1 := Min x y) in *. set (z2 := Max x y) in *. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros. apply (clcr z1 (z2[+][1])). apply (clcr z1 (z2[+][1])). apply (clcr (z1[-][1]) z2). apply (clcr z1 (z2[+][1])). apply (clcr (z1[-][1]) z2). apply (clcr (z1[-] (z1[-]c) [/]TwoNZ) (z2[+] (c0[-]z2) [/]TwoNZ)). apply (clcr (z1[-] (z1[-]c) [/]TwoNZ) (z2[+] (c0[-]z2) [/]TwoNZ)). apply (clcr (z1[-] (z1[-]c) [/]TwoNZ) (z2[+] (c0[-]z2) [/]TwoNZ)). apply (clcr c c0). Defined. Lemma compact_compact_in_interval2 : forall I pI x y Hx Hy, compact_ (compact_in_interval2 I pI x y Hx Hy). Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx; try inversion_clear Hy; try apply ts; apply less_leEq. apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply shift_minus_less; apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply shift_minus_less; apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. eapply less_transitive_unfolded; [ apply cip1'' | eapply leEq_less_trans; [ apply Min_leEq_Max | apply cip1'''' ] ]; try apply less_Min; try apply Max_less; auto. eapply less_leEq_trans; [ apply cip1'' | eapply leEq_transitive; [ apply Min_leEq_Max | apply cip1''' ] ]; try apply less_Min; try apply Max_leEq; auto. eapply leEq_less_trans; [ apply cip1' | eapply leEq_less_trans; [ apply Min_leEq_Max | apply cip1'''' ] ]; try apply leEq_Min; try apply Max_less; auto. auto. Qed. Lemma proper_compact_in_interval2 : forall I pI x y Hx Hy, proper (compact_in_interval2 I pI x y Hx Hy). Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx; try inversion_clear Hy. apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply shift_minus_less; apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. apply shift_minus_less; apply leEq_less_trans with (Max x y); [ apply Min_leEq_Max | apply less_plusOne ]. eapply less_transitive_unfolded; [ apply cip1'' | eapply leEq_less_trans; [ apply Min_leEq_Max | apply cip1'''' ] ]; try apply less_Min; try apply Max_less; auto. eapply less_leEq_trans; [ apply cip1'' | eapply leEq_transitive; [ apply Min_leEq_Max | apply cip1''' ] ]; try apply less_Min; try apply Max_leEq; auto. eapply leEq_less_trans; [ apply cip1' | eapply leEq_less_trans; [ apply Min_leEq_Max | apply cip1'''' ] ]; try apply leEq_Min; try apply Max_less; auto. auto. Qed. Lemma proper_compact_in_interval2' : forall I pI x y Hx Hy H, Lend (I:=compact_in_interval2 I pI x y Hx Hy) H [<] Rend (I:=compact_in_interval2 I pI x y Hx Hy) H. Proof. do 6 intro. cut (proper (compact_in_interval2 I pI x y Hx Hy)). 2: apply proper_compact_in_interval2. elim (compact_in_interval2 I pI x y Hx Hy); intros; try inversion H. simpl in |- *; simpl in H; auto. Qed. Lemma included_compact_in_interval2 : forall I pI x y Hx Hy, included (compact_in_interval2 I pI x y Hx Hy) I. Proof. induction I; simpl in |- *; intros; try inversion_clear Hx as (H,H0); try inversion_clear Hy as (H1,H2); red in |- *; simpl in |- *; intros x0 X; try inversion_clear X; auto. apply less_leEq_trans with (Min x y); try apply less_Min; auto. apply leEq_less_trans with (Max x y); try apply Max_less; auto. apply leEq_transitive with (Min x y); try apply leEq_Min; auto. apply leEq_transitive with (Max x y); try apply Max_leEq; auto. split. apply cip2' with (Min x y); try apply less_Min; auto. apply cip3' with (Max x y); try apply Max_less; auto. split. apply cip2' with (Min x y); try apply less_Min; auto. apply cip3 with (Max x y); try apply Max_leEq; auto. split. apply cip2 with (Min x y); try apply leEq_Min; auto. apply cip3' with (Max x y); try apply Max_less; auto. Qed. Lemma iprop_compact_in_interval2x : forall I pI x y Hx Hy, compact_in_interval2 I pI x y Hx Hy x. Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx; try inversion_clear Hy; split; auto; try apply Min_leEq_lft; try apply lft_leEq_Max. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply lft_leEq_Max | apply less_plusOne ]. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply lft_leEq_Max | apply less_plusOne ]. apply less_leEq; apply shift_minus_less; apply leEq_less_trans with x; [ apply Min_leEq_lft | apply less_plusOne ]. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply lft_leEq_Max | apply less_plusOne ]. apply less_leEq; apply shift_minus_less; apply leEq_less_trans with x; [ apply Min_leEq_lft | apply less_plusOne ]. apply less_leEq; eapply less_leEq_trans; [ apply cip1'' | apply Min_leEq_lft ]; try apply less_Min; auto. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply lft_leEq_Max | apply cip1'''' ]; try apply Max_less; auto. apply less_leEq; eapply less_leEq_trans; [ apply cip1'' | apply Min_leEq_lft ]; try apply less_Min; auto. apply leEq_transitive with (Max x y); [ apply lft_leEq_Max | apply cip1''' ]; try apply Max_leEq; auto. eapply leEq_transitive; [ apply cip1' | apply Min_leEq_lft ]; try apply leEq_Min; auto. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply lft_leEq_Max | apply cip1'''' ]; try apply Max_less; auto. Qed. Lemma iprop_compact_in_interval2y : forall I pI x y Hx Hy, compact_in_interval2 I pI x y Hx Hy y. Proof. intro. elim I; simpl in |- *; intros; try inversion_clear Hx; try inversion_clear Hy; split; auto; try apply Min_leEq_rht; try apply rht_leEq_Max. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply rht_leEq_Max | apply less_plusOne ]. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply rht_leEq_Max | apply less_plusOne ]. apply less_leEq; apply shift_minus_less; apply leEq_less_trans with y; [ apply Min_leEq_rht | apply less_plusOne ]. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply rht_leEq_Max | apply less_plusOne ]. apply less_leEq; apply shift_minus_less; apply leEq_less_trans with y; [ apply Min_leEq_rht | apply less_plusOne ]. apply less_leEq; eapply less_leEq_trans; [ apply cip1'' | apply Min_leEq_rht ]; try apply less_Min; auto. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply rht_leEq_Max | apply cip1'''' ]; try apply Max_less; auto. apply less_leEq; eapply less_leEq_trans; [ apply cip1'' | apply Min_leEq_rht ]; try apply less_Min; auto. apply leEq_transitive with (Max x y); [ apply rht_leEq_Max | apply cip1''' ]; try apply Max_leEq; auto. eapply leEq_transitive; [ apply cip1' | apply Min_leEq_rht ]; try apply leEq_Min; auto. apply less_leEq; apply leEq_less_trans with (Max x y); [ apply rht_leEq_Max | apply cip1'''' ]; try apply Max_less; auto. Qed. Lemma iprop_compact_in_interval2x' : forall I pI x y Hx Hy (H : compact_ (compact_in_interval2 I pI x y Hx Hy)) H', compact (Lend H) (Rend H) H' x. Proof. do 6 intro. cut (compact_in_interval2 I pI x y Hx Hy x). 2: apply iprop_compact_in_interval2x. elim (compact_in_interval2 I pI x y Hx Hy); intros; try inversion H. simpl in |- *; auto. Qed. Lemma iprop_compact_in_interval2y' : forall I pI x y Hx Hy (H : compact_ (compact_in_interval2 I pI x y Hx Hy)) H', compact (Lend H) (Rend H) H' y. Proof. do 6 intro. cut (compact_in_interval2 I pI x y Hx Hy y). 2: apply iprop_compact_in_interval2y. elim (compact_in_interval2 I pI x y Hx Hy); intros; try inversion H. simpl in |- *; auto. Qed. Lemma iprop_compact_in_interval2_inc1 : forall I pI x y Hx Hy (H : compact_ (compact_in_interval2 I pI x y Hx Hy)) H', included (compact (Lend H) (Rend H) H') (compact_in_interval2 I pI x y Hx Hy). Proof. do 6 intro. elim (compact_in_interval2 I pI x y Hx Hy); intros; try inversion H. unfold compact in |- *; unfold iprop in |- *; simpl in |- *; Included. Qed. Lemma iprop_compact_in_interval2_inc2 : forall I pI x y Hx Hy (H : compact_ (compact_in_interval2 I pI x y Hx Hy)) H', included (compact_in_interval2 I pI x y Hx Hy) (compact (Lend H) (Rend H) H'). Proof. do 6 intro. elim (compact_in_interval2 I pI x y Hx Hy); intros; try inversion H. unfold compact in |- *; unfold iprop in |- *; simpl in |- *; Included. Qed. Lemma compact_in_interval_x_lft : forall I pI x y Hx Hy H H', Lend (I:=compact_in_interval2 I pI x y Hx Hy) H [<=] Lend (I:=compact_in_interval I pI x Hx) H'. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; simpl in |- *; intros; try apply minus_resp_leEq; try apply Min_leEq_lft; try apply leEq_reflexive; (rstepl (c[+] (Min x y[-]c) [/]TwoNZ); rstepr (c[+] (x[-]c) [/]TwoNZ); apply plus_resp_leEq_lft; apply div_resp_leEq; [ apply pos_two | apply minus_resp_leEq; apply Min_leEq_lft ]). Qed. Lemma compact_in_interval_y_lft : forall I pI x y Hx Hy H H', Lend (I:=compact_in_interval2 I pI x y Hx Hy) H [<=] Lend (I:=compact_in_interval I pI y Hy) H'. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; simpl in |- *; intros; try apply minus_resp_leEq; try apply Min_leEq_rht; try apply leEq_reflexive; (rstepl (c[+] (Min x y[-]c) [/]TwoNZ); rstepr (c[+] (y[-]c) [/]TwoNZ); apply plus_resp_leEq_lft; apply div_resp_leEq; [ apply pos_two | apply minus_resp_leEq; apply Min_leEq_rht ]). Qed. Lemma compact_in_interval_x_rht : forall I pI x y Hx Hy H H', Rend (I:=compact_in_interval I pI x Hx) H [<=] Rend (I:=compact_in_interval2 I pI x y Hx Hy) H'. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; simpl in |- *; intros; try apply plus_resp_leEq; try apply lft_leEq_Max; try apply leEq_reflexive; (rstepl (c0[-] (c0[-]x) [/]TwoNZ); rstepr (c0[-] (c0[-]Max x y) [/]TwoNZ); unfold cg_minus in |- *; apply plus_resp_leEq_lft; apply inv_resp_leEq; apply div_resp_leEq; [ apply pos_two | apply plus_resp_leEq_lft; apply inv_resp_leEq; apply lft_leEq_Max ]). Qed. Lemma compact_in_interval_y_rht : forall I pI x y Hx Hy H H', Rend (I:=compact_in_interval I pI y Hy) H [<=] Rend (I:=compact_in_interval2 I pI x y Hx Hy) H'. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; simpl in |- *; intros; try apply plus_resp_leEq; try apply rht_leEq_Max; try apply leEq_reflexive; (rstepl (c0[-] (c0[-]y) [/]TwoNZ); rstepr (c0[-] (c0[-]Max x y) [/]TwoNZ); unfold cg_minus in |- *; apply plus_resp_leEq_lft; apply inv_resp_leEq; apply div_resp_leEq; [ apply pos_two | apply plus_resp_leEq_lft; apply inv_resp_leEq; apply rht_leEq_Max ]). Qed. End Proper_Compact_with_One_or_Two_Points. (** Compact intervals are exactly compact intervals(!). *) Lemma interval_compact_inc : forall I (cI : compact_ I) H, included I (compact (Lend cI) (Rend cI) H). Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0];intros; try inversion cI. generalize c c0 cI H; clear H cI c0 c. simpl in |- *; intros a b Hab Hab'. intros x H. simpl in H. inversion_clear H; split; auto. Qed. Lemma compact_interval_inc : forall I (cI : compact_ I) H, included (compact (Lend cI) (Rend cI) H) I. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI H; clear H cI c0 c. simpl in |- *; intros a b Hab. intros H x H0. inversion_clear H0; split; auto. Qed. (** A generalization of the previous results: if $[a,b]\subseteq J$#[a,b]⊆J# and [J] is proper, then we can find a proper interval [[a',b']] such that $[a,b]\subseteq[a',b']\subseteq J$#[a,b]⊆[a',b']⊆J#. *) Lemma compact_proper_in_interval : forall (J : interval) a b Hab, included (compact a b Hab) J -> proper J -> {a' : IR | {b' : IR | {Hab' : _ | included (compact a' b' (less_leEq _ _ _ Hab')) J | included (Compact Hab) (Compact (less_leEq _ _ _ Hab'))}}}. Proof. intros J a b Hab H H0. exists (Lend (compact_compact_in_interval2 J H0 a b (H _ (compact_inc_lft _ _ Hab)) (H _ (compact_inc_rht _ _ Hab)))). exists (Rend (compact_compact_in_interval2 J H0 a b (H _ (compact_inc_lft _ _ Hab)) (H _ (compact_inc_rht _ _ Hab)))). exists (proper_compact_in_interval2' _ _ _ _ _ _ (compact_compact_in_interval2 J H0 a b (H _ (compact_inc_lft _ _ Hab)) (H _ (compact_inc_rht _ _ Hab)))). eapply included_trans. apply compact_interval_inc. apply included_compact_in_interval2. apply included_compact. apply iprop_compact_in_interval2x'. apply iprop_compact_in_interval2y'. Qed. End Compact_Constructions. Section Functions. (** ** Properties of Functions in Intervals We now define notions of continuity, differentiability and so on on arbitrary intervals. As expected, a function [F] has property [P] in the (proper) interval [I] iff it has property [P] in every compact interval included in [I]. We can formalize this in a nice way using previously defined concepts. %\begin{convention}% Let [n:nat] and [I:interval]. %\end{convention}% *) Variable n : nat. Variable I : interval. Definition Continuous F := included I (Dom F) and (forall a b (Hab : a [<=] b), included (Compact Hab) I -> Continuous_I Hab F). Definition Derivative (pI : proper I) F G := included I (Dom F) and included I (Dom G) and (forall a b Hab, included (Compact (less_leEq _ a b Hab)) I -> Derivative_I Hab F G). Definition Diffble (pI : proper I) F := included I (Dom F) and (forall a b Hab, included (Compact (less_leEq _ a b Hab)) I -> Diffble_I Hab F). Definition Derivative_n (pI : proper I) F G := included I (Dom F) and included I (Dom G) and (forall a b Hab, included (Compact (less_leEq _ a b Hab)) I -> Derivative_I_n Hab n F G). Definition Diffble_n (pI : proper I) F := included I (Dom F) and (forall a b Hab, included (Compact (less_leEq _ a b Hab)) I -> Diffble_I_n Hab n F). End Functions. Section Reflexivity_Properties. (** In the case of compact intervals, this definitions collapse to the old ones. *) Lemma Continuous_Int : forall (I : interval) (cI : compact_ I) H (F : PartIR), Continuous_I (a:=Lend cI) (b:=Rend cI) H F -> Continuous I F. Proof. intros I cI H F H0. cut (included I (compact (Lend cI) (Rend cI) H)). 2: apply interval_compact_inc; auto. cut (included (compact (Lend cI) (Rend cI) H) I). 2: apply compact_interval_inc; auto. generalize cI H H0; clear H0 H cI. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI H H0 X X0; clear X0 X H0 H cI c0 c. simpl in |- *; intros a b Hab Hab' contF inc1 inc2. split. apply included_trans with (Compact Hab'); Included. intros. apply included_imp_contin with (Hab := Hab'); Included. Qed. Lemma Int_Continuous : forall (I : interval) (cI : compact_ I) H (F : PartIR), Continuous I F -> Continuous_I (a:=Lend cI) (b:=Rend cI) H F. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI H F X; clear X F H cI c0 c. simpl in |- *; intros a b Hab Hab' F contF. inversion_clear contF. Contin. Qed. Lemma Derivative_Int : forall (I : interval) (cI : compact_ I) (pI : proper I) H (F F' : PartIR), Derivative_I (a:=Lend cI) (b:=Rend cI) H F F' -> Derivative I pI F F'. Proof. do 4 intro. cut (included I (compact (Lend cI) (Rend cI) (less_leEq _ _ _ H))). 2: apply interval_compact_inc; auto. cut (included (compact (Lend cI) (Rend cI) (less_leEq _ _ _ H)) I). 2: apply compact_interval_inc; auto. generalize cI pI H; clear H cI pI. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI pI H X X0 F F' X1; clear X1 F' F X0 X H pI cI c0 c. simpl in |- *; intros a b Hab Hnonv Hab' inc1 inc2 F F' derF. split. apply included_trans with (Compact (less_leEq _ _ _ Hab')); Included. split. apply included_trans with (Compact (less_leEq _ _ _ Hab')); Included. intros c d Hcd' Hinc. apply included_imp_deriv with (Hab := Hab'); Included. Qed. Lemma Int_Derivative : forall (I : interval) (cI : compact_ I) (pI : proper I) H (F F' : PartIR), Derivative I pI F F' -> Derivative_I (a:=Lend cI) (b:=Rend cI) H F F'. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI pI H F F' X; clear X F' F H pI cI c0 c. simpl in |- *; intros a b Hab Hnonv Hab' F F' derF. elim derF; intros H H0. elim H0; intros H1 H2. Included. Qed. Lemma Diffble_Int : forall (I : interval) (cI : compact_ I) (pI : proper I) H (F : PartIR), Diffble_I (a:=Lend cI) (b:=Rend cI) H F -> Diffble I pI F. Proof. do 4 intro. cut (included I (compact (Lend cI) (Rend cI) (less_leEq _ _ _ H))). 2: apply interval_compact_inc; auto. cut (included (compact (Lend cI) (Rend cI) (less_leEq _ _ _ H)) I). 2: apply compact_interval_inc; auto. generalize cI pI H; clear H pI cI. destruct I as [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI pI H X X0 F X1; clear X1 F X0 X H pI cI c0 c. simpl in |- *; intros a b Hab Hnonv Hab' inc1 inc2 F diffF. red in |- *; simpl in |- *. split. apply included_trans with (Compact (less_leEq _ _ _ Hab')); Included. intros c d Hcd' Hinc. apply included_imp_diffble with (Hab := Hab'); auto. Qed. Lemma Int_Diffble : forall (I : interval) (cI : compact_ I) (pI : proper I) H (F : PartIR), Diffble I pI F -> Diffble_I (a:=Lend cI) (b:=Rend cI) H F. Proof. intros [| c| c| c| c| c c0| c c0| c c0| c c0]; intros; try inversion cI. generalize c c0 cI pI H F X; clear X F H pI cI c0 c. simpl in |- *; intros a b Hab Hnonv Hab' F diffF. inversion_clear diffF. Included. Qed. End Reflexivity_Properties. Section Lemmas. (** Interestingly, inclusion and equality in an interval are also characterizable in a similar way: *) Lemma included_imp_inc : forall (J : interval) P, (forall a b Hab, included (compact a b Hab) J -> included (compact a b Hab) P) -> included J P. Proof. intros J P H x H0. apply (H _ _ (leEq_reflexive _ _) (compact_single_iprop J x H0)). apply compact_inc_lft. Qed. Lemma included_Feq'' : forall I F G, proper I -> (forall a b Hab (Hab':=(less_leEq _ a b Hab)), included (Compact Hab') I -> Feq (Compact Hab') F G) -> Feq I F G. Proof. intros I F G H H0. apply eq_imp_Feq. intros x H1. elim (compact_proper_in_interval I x x (leEq_reflexive _ x)); Included. 2: exact (compact_single_iprop I x H1). intros a Ha. elim Ha; clear Ha. intros b Hb. elim Hb; clear Hb. intros Hab H2 H3. elim (H0 _ _ _ H2); intros. apply a0; apply H3; apply compact_single_prop. intros x H1. elim (compact_proper_in_interval I x x (leEq_reflexive _ x)); Included. 2: exact (compact_single_iprop I x H1). intros a Ha. elim Ha; clear Ha. intros b Hb. elim Hb; clear Hb. intros Hab H2 H3. elim (H0 _ _ _ H2); intros. inversion_clear b0. apply X; apply H3; apply compact_single_prop. intros x H1 Hx Hx'. elim (compact_proper_in_interval I x x (leEq_reflexive _ x)); Included. 2: exact (compact_single_iprop I x H1). intros a Ha. elim Ha; clear Ha. intros b Hb. elim Hb; clear Hb. intros Hab H2 H3. elim (H0 _ _ _ H2); intros. inversion_clear b0. apply H4; apply H3; apply compact_single_prop. Qed. Lemma included_Feq' : forall (I : interval) F G, (forall a b Hab, included (compact a b Hab) I -> Feq (Compact Hab) F G) -> Feq I F G. Proof. intros I F G H. apply eq_imp_Feq. intros x H0. elim (H x x (leEq_reflexive _ x) (compact_single_iprop I x H0)); intros. apply a; apply compact_single_prop. intros x H0. elim (H x x (leEq_reflexive _ x) (compact_single_iprop I x H0)); intros. inversion_clear b. apply X; apply compact_single_prop. intros x H0 Hx Hx'. elim (H x x (leEq_reflexive _ x) (compact_single_iprop I x H0)); intros. inversion_clear b. apply H1; apply compact_single_prop. Qed. End Lemmas. #[global] Hint Resolve included_interval included_interval' included3_interval compact_single_inc compact_single_iprop included_compact_in_interval iprop_compact_in_interval_inc1 iprop_compact_in_interval_inc2 included_compact_in_interval2 iprop_compact_in_interval2_inc1 iprop_compact_in_interval2_inc2 interval_compact_inc compact_interval_inc iprop_wd: included. corn-8.20.0/ftc/NthDerivative.v000066400000000000000000000533101473720167500162770ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Differentiability. Section Nth_Derivative. (** * Nth Derivative We now study higher order differentiability. %\begin{convention}% Throughout this section: - [a, b] will be real numbers with [a [<] b]; - [I] will denote the compact interval [[a,b]]; - [F, G, H] will denote partial functions. %\end{convention}% ** Definitions We first define what we mean by the derivative of order [n] of a function. *) Variables a b : IR. Hypothesis Hab' : a[<]b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Fixpoint Derivative_I_n (n : nat) (F Fn : PartIR) {struct n} : CProp := match n with | O => Feq I F Fn | S p => {f' : CSetoid_fun (subset (Compact Hab)) IR | Derivative_I Hab' F (PartInt f') | Derivative_I_n p (PartInt f') Fn} end. (** Unlike first order differentiability, for our definition to be workable it is better to define directly what it means for a function to be [n] times differentiable instead of quantifying over the [Derivative_I_n] relation. *) Fixpoint Diffble_I_n (n : nat) (F : PartIR) {struct n} : CProp := match n with | O => included I (Dom F) | S p => {H : Diffble_I Hab' F | Diffble_I_n p (PartInt (ProjT1 H))} end. End Nth_Derivative. Arguments Derivative_I_n [a b]. Arguments Diffble_I_n [a b]. Section Trivia. (** ** Trivia These are the expected extensionality and uniqueness results. *) Variables a b : IR. Hypothesis Hab' : a[<]b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Lemma Diffble_I_n_wd : forall n F G, Feq I F G -> Diffble_I_n Hab' n F -> Diffble_I_n Hab' n G. Proof. intro. induction n as [| n Hrecn]. simpl in |- *; unfold Feq in |- *; tauto. intros F G H H0. elim H0; intros H1 H2; clear H0. cut (Diffble_I Hab' G). 2: apply Diffble_I_wd with F; assumption. intro H0. exists H0. eapply Hrecn. 2: apply H2. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. apply Derivative_I_wdl with G. apply Feq_symmetric; assumption. apply projT2. Qed. Lemma Derivative_I_n_wdr : forall n F G H, Feq I G H -> Derivative_I_n Hab' n F G -> Derivative_I_n Hab' n F H. Proof. intro. induction n as [| n Hrecn]; intros F G H H0 H1. simpl in |- *; simpl in H1. apply Feq_transitive with G; assumption. elim H1; intros f' H2 H3. exists f'; auto. apply Hrecn with G; assumption. Qed. Lemma Derivative_I_n_wdl : forall n F G H, Feq I F G -> Derivative_I_n Hab' n F H -> Derivative_I_n Hab' n G H. Proof. intro. induction n as [| n Hrecn]; intros F G H H0 H1. simpl in |- *; simpl in H1. apply Feq_transitive with F. apply Feq_symmetric; assumption. auto. elim H1; intros f' H2 H3. exists f'; auto. apply Derivative_I_wdl with F; assumption. Qed. Lemma Derivative_I_n_unique : forall n F G H, Derivative_I_n Hab' n F G -> Derivative_I_n Hab' n F H -> Feq I G H. Proof. intro. induction n as [| n Hrecn]; intros F G H H0 H1. simpl in H0, H1. unfold I in |- *; apply Feq_transitive with F. apply Feq_symmetric; assumption. auto. elim H0; intros g' H2 H3. elim H1; intros h' H4 H5. apply Hrecn with (PartInt g'). assumption. apply Derivative_I_n_wdl with (PartInt h'). 2: assumption. unfold I, Hab in |- *; apply Derivative_I_unique with F; assumption. Qed. End Trivia. Section Basic_Results. (** ** Basic Results We now explore the concept of [n] times differentiability. Notice that, unlike the first order case, we do not pay so much attention to the relation of [n] times derivative, but focus rather on the definition of [Diffble_I_n]. *) Variables a b : IR. Hypothesis Hab' : a[<]b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) (** We begin by showing that having a higher order derivative implies being differentiable. *) Lemma Diffble_I_n_imp_diffble : forall n : nat, 0 < n -> forall F : PartIR, Diffble_I_n Hab' n F -> Diffble_I Hab' F. Proof. intros n H F. rewrite <- (Nat.lt_succ_pred 0 n);auto. simpl. intro H0. simpl in H0. inversion_clear H0; assumption. Qed. Lemma deriv_n_imp_diffble : forall n : nat, 0 < n -> forall F F' : PartIR, Derivative_I_n Hab' n F F' -> Diffble_I Hab' F. Proof. simple destruct n. intros; exfalso; inversion H. clear n; intros n H F F' H0. elim H0; clear H0; intros f'' H0 H1. exists f''; assumption. Qed. (** If a function is [n] times differentiable then it is also [m] times differentiable for every [m] less or equal than [n]. *) Lemma le_imp_Diffble_I : forall m n : nat, m <= n -> forall F, Diffble_I_n Hab' n F -> Diffble_I_n Hab' m F. Proof. intros m n H F H0. induction n as [| n Hrecn]. cut (m = 0); [ intro | auto with arith ]. rewrite H1; simpl in |- *; tauto. elim (le_lt_eq_dec _ _ H); intro H2. 2: rewrite H2; assumption. apply Hrecn. auto with arith. elim H0; intros Hf Hf'. clear Hf' Hf H2 Hrecn H. generalize H0. generalize F. clear H0 F; induction n as [| n Hrecn]; intros. simpl in |- *; apply diffble_imp_inc. exact (Diffble_I_n_imp_diffble _ (Nat.lt_succ_diag_r 0) F H0). simpl in |- *. elim H0; intros Hf Hf'. exists Hf. apply Hrecn. assumption. Qed. (** The next result consolidates our intuition that a function is [n] times differentiable if we can build from it a chain of [n] derivatives. *) Lemma Diffble_I_imp_le : forall n, 0 < n -> forall F F', Diffble_I_n Hab' n F -> Derivative_I Hab' F F' -> Diffble_I_n Hab' (pred n) F'. Proof. simple destruct n. intros; exfalso; inversion H. clear n; intros n H F F' H0 H1. elim H0; intros f'' Hf''. simpl in |- *. eapply Diffble_I_n_wd. 2: apply Hf''. apply Derivative_I_unique with F. apply projT2. assumption. Qed. (** As expected, an [n] times differentiable in [[a,b]] function must be defined in that interval. *) Lemma Diffble_I_n_imp_inc : forall n F, Diffble_I_n Hab' n F -> included (Compact Hab) (Dom F). Proof. intros n F H; induction n as [| n Hrecn]. simpl in H; Included. apply Hrecn. exact (le_imp_Diffble_I _ _ (Nat.le_succ_diag_r n) _ H). Qed. (** Also, the notions of derivative and differentiability are related as expected. *) Lemma Diffble_I_n_imp_deriv_n : forall n F, Diffble_I_n Hab' n F -> {f' : CSetoid_fun (subset (Compact Hab)) IR | Derivative_I_n Hab' n F (PartInt f')}. Proof. intro; induction n as [| n Hrecn]. intros F H. exists (IntPartIR (Diffble_I_n_imp_inc _ _ H)). simpl in |- *; simpl in H. FEQ. intros F H. elim H; intros H1 H2. elim (Hrecn _ H2); intros f' Hf'. exists f'. simpl in |- *. exists (ProjT1 H1). apply projT2. assumption. Qed. Lemma deriv_n_imp_Diffble_I_n : forall n F F', Derivative_I_n Hab' n F F' -> Diffble_I_n Hab' n F. Proof. intro; induction n as [| n Hrecn]; intros F F' H. simpl in |- *; simpl in H. elim H; intros. elim b0; auto. simpl in |- *. elim H; intros f' H0 H1. cut (Diffble_I Hab' F); [ intro H2 | exists f'; assumption ]. exists H2. apply Hrecn with F'. eapply Derivative_I_n_wdl. 2: apply H1. apply Derivative_I_unique with F. assumption. apply projT2. Qed. (** From this we can prove that if [F] has an nth order derivative in [[a,b]] then both [F] and its derivative are defined in that interval. *) Lemma Derivative_I_n_imp_inc : forall n F F', Derivative_I_n Hab' n F F' -> included I (Dom F). Proof. intros; apply Diffble_I_n_imp_inc with n. apply deriv_n_imp_Diffble_I_n with F'; assumption. Qed. Lemma Derivative_I_n_imp_inc' : forall n F F', Derivative_I_n Hab' n F F' -> included I (Dom F'). Proof. intro; induction n as [| n Hrecn]; intros F F' H. simpl in |- *; simpl in H. elim H; intros H0 H1; elim H1; auto. elim H; intros f' H0 H1. apply Hrecn with (PartInt f'). assumption. Qed. Section aux. (** First order differentiability is just a special case. *) (* begin show *) Variable F : PartIR. Hypothesis diffF : Diffble_I Hab' F. Hypothesis diffFn : Diffble_I_n Hab' 1 F. (* end show *) Lemma deriv_1_deriv : Feq I (PartInt (ProjT1 diffF)) (PartInt (ProjT1 (Diffble_I_n_imp_deriv_n _ _ diffFn))). Proof. intros. simpl in |- *. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. cut (Derivative_I_n Hab' 1 F (PartInt (ProjT1 (Diffble_I_n_imp_deriv_n 1 F diffFn)))). 2: apply projT2. intro H. elim H; intros f' H0 H1. apply Derivative_I_wdr with (PartInt f'); assumption. Qed. Lemma deriv_1_deriv' : forall (x : subset I), ProjT1 diffF x [=] ProjT1 (Diffble_I_n_imp_deriv_n _ _ diffFn) x. Proof. intros. elim deriv_1_deriv; intros H H1. elim H1; intros H0 H2. simpl in H2. clear H0 H1. generalize (H2 (scs_elem _ _ x) (scs_prf _ _ x) (scs_prf _ _ x) (scs_prf _ _ x)). intro H0. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply H0. apply csf_wd_unfolded. cut (scs_elem _ _ x [=] scs_elem _ _ x). case x; simpl in |- *; auto. algebra. apply csf_wd_unfolded. cut (scs_elem _ _ x [=] scs_elem _ _ x). case x; simpl in |- *; auto. algebra. Qed. End aux. (** As usual, nth order derivability is preserved by shrinking the interval. *) Lemma included_imp_deriv_n : forall n c d Hcd F F', included (Compact (less_leEq _ c d Hcd)) (Compact (less_leEq _ a b Hab')) -> Derivative_I_n Hab' n F F' -> Derivative_I_n Hcd n F F'. Proof. intro; induction n as [| n Hrecn]; simpl in |- *; intros c d Hcd F F' H H0. apply included_Feq with (Compact (less_leEq _ _ _ Hab')); auto. elim H0; intros f' H1 H2. exists (IntPartIR (F:=(Frestr (F:=PartInt f') (compact_wd _ _ _) H)) (included_refl _ _)). apply Derivative_I_wdr with (PartInt f'). FEQ. simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply included_imp_deriv with (Hab := Hab'); auto. apply Derivative_I_n_wdl with (PartInt f'). FEQ. simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. auto. Qed. Lemma included_imp_diffble_n : forall n c d Hcd F, included (Compact (less_leEq _ c d Hcd)) (Compact (less_leEq _ a b Hab')) -> Diffble_I_n Hab' n F -> Diffble_I_n Hcd n F. Proof. intro; induction n as [| n Hrecn]; simpl in |- *; intros c d Hcd F H H0. apply included_trans with (Compact (less_leEq _ _ _ Hab')); Included. elim H0; intros f' HF. exists (included_imp_diffble _ _ _ _ _ _ _ H f'). apply Diffble_I_n_wd with (PartInt (ProjT1 f')). apply Derivative_I_unique with F. apply included_imp_deriv with (Hab := Hab'). auto. apply projT2. apply projT2. auto. Qed. (** And finally we have an addition rule for the order of the derivative. *) Lemma Derivative_I_n_plus : forall n m k F G H, Derivative_I_n Hab' m F G -> Derivative_I_n Hab' n G H -> k = m + n -> Derivative_I_n Hab' k F H. Proof. do 2 intro. induction m as [| m Hrecm]; intros k F G H H0 H1 H2; rewrite H2. simpl in |- *. apply Derivative_I_n_wdl with G. elim H0; clear H0; intros H3 H4. elim H4; clear H4; intros H0 H5. apply Derivative_I_n_unique with 0 G. simpl in |- *; apply Feq_reflexive; auto. simpl in |- *; FEQ; algebra. auto. elim H0; intros F' H3 H4. exists F'; auto. apply Hrecm with G; auto. Qed. End Basic_Results. Section More_Results. Variables a b : IR. Hypothesis Hab' : a[<]b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) (** ** The Nth Derivative We now define an operator that returns an nth order derivative of an n-times differentiable function. This is analogous to the quantifier elimination which we would get if we had defined nth differentiability as an existential quantification of the nth derivative relation. *) Definition n_deriv_I n F (H : Diffble_I_n Hab' n F) : PartIR. Proof. revert F H; induction n as [| n Hrecn]. intros. simpl in H. apply (FRestr H). intros F H. cut (Diffble_I Hab' F). intro H0. set (f' := ProjT1 H0) in *. cut (Diffble_I_n Hab' n (PartInt f')). intro H1. apply (Hrecn _ H1). cut (n = pred (S n)); [ intro | simpl in |- *; reflexivity ]. rewrite H1. apply Diffble_I_imp_le with F. apply Nat.lt_0_succ. assumption. unfold f' in |- *; apply projT2. apply Diffble_I_n_imp_diffble with (S n). apply Nat.lt_0_succ. assumption. Defined. (** This operator is well defined and works as expected. *) Lemma n_deriv_I_wd : forall n F G Hf Hg, Feq I F G -> Feq I (n_deriv_I n F Hf) (n_deriv_I n G Hg). Proof. intro; induction n as [| n Hrecn]; intros F G Hf Hg H. elim H; clear H; intros H H0. elim H0; clear H0; intros H2 H1. unfold I in |- *; simpl in |- *; FEQ. simpl in |- *; apply H1; auto. simpl in |- *. apply Hrecn. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. apply Derivative_I_wdl with G. apply Feq_symmetric; assumption. apply projT2. Qed. Lemma n_deriv_lemma : forall n F H, Derivative_I_n Hab' n F (n_deriv_I n F H). Proof. intro; induction n as [| n Hrecn]; intros. simpl in |- *; simpl in H; FEQ. elim H; intros Hf Hf'. exists (ProjT1 Hf). apply projT2. simpl in |- *. cut (Diffble_I_n Hab' n (PartInt (ProjT1 Hf))). intro H0. apply Derivative_I_n_wdr with (n_deriv_I _ _ H0). 2: apply Hrecn. apply n_deriv_I_wd. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. apply projT2. elim H; intros. eapply Diffble_I_n_wd. 2: apply p. apply Derivative_I_unique with F; apply projT2. Qed. Lemma n_deriv_inc : forall n F H, included (Compact Hab) (Dom (n_deriv_I n F H)). Proof. intros; simpl in |- *. unfold I, Hab in |- *; apply Derivative_I_n_imp_inc' with n F. apply n_deriv_lemma. Qed. Lemma n_deriv_inc' : forall n Hab F H, included (Dom (n_deriv_I n F H)) (compact a b Hab). Proof. intro; induction n as [| n Hrecn]; intros; simpl in |- *; Included. Qed. (** Some basic properties of this operation. *) Lemma n_Sn_deriv : forall n F H HS, Derivative_I Hab' (n_deriv_I n F H) (n_deriv_I (S n) F HS). Proof. intro; induction n as [| n Hrecn]. intros. apply Derivative_I_wdl with F. FEQ. apply Derivative_I_wdr with (PartInt (ProjT1 (Diffble_I_n_imp_diffble _ _ _ _ (Nat.lt_0_succ 0) _ HS))). apply eq_imp_Feq. Included. Included. intros; simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply projT2. intro. cut {p : nat | p = S n}. intro H; elim H; intros p H0. pattern (S n) at 2 4 in |- *; rewrite <- H0. intros. elim H1; intros H0' H0''; clear H1. elim HS; intros H1' H1''; clear HS. cut (Diffble_I_n Hab' n (PartInt (ProjT1 H1'))). intro H1'''. apply Derivative_I_wdl with (n_deriv_I _ _ H1'''). 2: apply Derivative_I_wdr with (n_deriv_I _ _ H1''). simpl in |- *; apply n_deriv_I_wd. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. apply projT2. simpl in |- *; apply n_deriv_I_wd. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. apply projT2. generalize H1''. rewrite H0. intro. apply Hrecn. generalize H1''; clear H1''. rewrite H0; intro. apply le_imp_Diffble_I with (S n); [ auto with arith | assumption ]. exists (S n); auto. Qed. Lemma n_deriv_plus : forall m n F H H', Derivative_I_n Hab' m (n_deriv_I n F H) (n_deriv_I (m + n) F H'). Proof. intro; induction m as [| m Hrecm]. simpl in |- *. intros. apply n_deriv_I_wd. unfold I in |- *; apply Feq_reflexive. exact (Diffble_I_n_imp_inc _ _ _ _ _ H). intros. simpl in |- *. cut (Diffble_I_n Hab' (S n) F). intro H0. exists (IntPartIR (n_deriv_inc _ _ H0)). eapply Derivative_I_wdr. 2: apply n_Sn_deriv with (HS := H0). FEQ. apply n_deriv_inc. cut (Diffble_I_n Hab' (m + n) (PartInt (ProjT1 (Diffble_I_n_imp_diffble _ _ _ (S n) (Nat.lt_0_succ n) F H0)))). intro H1. eapply Derivative_I_n_wdr. 2: eapply Derivative_I_n_wdl. 3: apply Hrecm with (H' := H1). apply n_deriv_I_wd. unfold I, Hab in |- *; apply Derivative_I_unique with F. apply projT2. apply projT2. FEQ. apply n_deriv_inc. simpl in |- *; algebra. elim H'; intros. eapply Diffble_I_n_wd. 2: apply p. apply Derivative_I_unique with F. apply projT2. apply projT2. apply le_imp_Diffble_I with (S m + n). simpl in |- *; rewrite Nat.add_comm; auto with arith. assumption. Qed. End More_Results. Section More_on_n_deriv. (** Some not so basic properties of this operation (needed in rather specific situations). *) Lemma n_deriv_I_wd' : forall n a b Hab a' b' Hab' F H H' x y, x [=] y -> Compact (less_leEq _ _ _ Hab) x -> Compact (less_leEq _ _ _ Hab') y -> Diffble_I_n (Min_less_Max _ _ a' b' Hab) n F -> forall Hx Hy, n_deriv_I a b Hab n F H x Hx [=] n_deriv_I a' b' Hab' n F H' y Hy. Proof. intros n a b Hab a' b' Hab' F H H' x y H0 H1 H2 H3 Hx Hy. cut (included (Compact (less_leEq _ _ _ Hab)) (Dom (n_deriv_I _ _ _ _ _ H3))). intro H4. cut (included (Compact (less_leEq _ _ _ Hab')) (Dom (n_deriv_I _ _ _ _ _ H3))). intro H5. apply eq_transitive_unfolded with (Part (FRestr H5) y H2). apply eq_transitive_unfolded with (Part (FRestr H4) x H1). apply Feq_imp_eq with (Compact (less_leEq _ _ _ Hab)). apply Derivative_I_n_unique with n F. apply n_deriv_lemma. apply Derivative_I_n_wdr with (n_deriv_I _ _ _ _ _ H3). FEQ. apply included_imp_deriv_n with (Hab' := Min_less_Max a b a' b' Hab). intros x0 H6. elim H6; clear H6; intros H7 H8; split. apply leEq_transitive with a. apply Min_leEq_lft. auto. apply leEq_transitive with b. auto. apply lft_leEq_Max. apply n_deriv_lemma. auto. simpl in |- *; algebra. apply eq_symmetric_unfolded. apply Feq_imp_eq with (Compact (less_leEq _ _ _ Hab')). apply Derivative_I_n_unique with n F. apply n_deriv_lemma. apply Derivative_I_n_wdr with (n_deriv_I _ _ _ _ _ H3). FEQ. apply included_imp_deriv_n with (Hab' := Min_less_Max a b a' b' Hab). intros x0 H6. elim H6; clear H6; intros H7 H8; split. apply leEq_transitive with a'. apply Min_leEq_rht. auto. apply leEq_transitive with b'. auto. apply rht_leEq_Max. apply n_deriv_lemma. auto. intros x0 H5. apply n_deriv_inc. elim H5; clear H5; intros H6 H7; split. apply leEq_transitive with a'. apply Min_leEq_rht. auto. apply leEq_transitive with b'. auto. apply rht_leEq_Max. intros x0 H4. apply n_deriv_inc. elim H4; clear H4; intros H5 H6; split. apply leEq_transitive with a. apply Min_leEq_lft. auto. apply leEq_transitive with b. auto. apply lft_leEq_Max. Qed. Lemma n_deriv_I_wd'' : forall n a b Hab Hab' F H H' x y, x [=] y -> Compact (less_leEq _ _ _ Hab) x -> Compact (less_leEq _ _ _ Hab) y -> forall Hx Hy, n_deriv_I a b Hab n F H x Hx [=] n_deriv_I a b Hab' n F H' y Hy. Proof. intros n a b Hab Hab' F H H' x y H0 H1 H2 Hx Hy. apply n_deriv_I_wd'. algebra. auto. auto. apply included_imp_diffble_n with (Hab' := Hab). 2: auto. intros x0 H3. elim H3; clear H3; intros H4 H5; split. eapply leEq_wdl. apply H4. apply Min_id. eapply leEq_wdr. apply H5. apply Max_id. Qed. Lemma n_deriv_I_strext' : forall n a b Hab a' b' Hab' F H H' x y, Compact (less_leEq _ _ _ Hab) x -> Compact (less_leEq _ _ _ Hab') y -> Diffble_I_n (Min_less_Max _ _ a' b' Hab) n F -> (forall Hx Hy, n_deriv_I a b Hab n F H x Hx [#] n_deriv_I a' b' Hab' n F H' y Hy) -> x [#] y. Proof. intros n a b Hab a' b' Hab' F H H' x y H0 H1 H2 H3. cut (Compact (less_leEq _ _ _ (Min_less_Max a b a' b' Hab)) x). intro H4. cut (Compact (less_leEq _ _ _ (Min_less_Max a b a' b' Hab)) y). intro H5. apply pfstrx with (n_deriv_I _ _ _ _ _ H2) (n_deriv_inc _ _ _ _ _ H2 _ H4) (n_deriv_inc _ _ _ _ _ H2 _ H5). apply ap_wdr_unfolded with (Part (n_deriv_I _ _ _ _ _ H') y (n_deriv_inc _ _ _ _ _ H' y H1)). apply ap_wdl_unfolded with (Part (n_deriv_I _ _ _ _ _ H) x (n_deriv_inc _ _ _ _ _ H x H0)). auto. apply Feq_imp_eq with (Compact (less_leEq _ _ _ Hab)). apply Derivative_I_n_unique with n F. apply n_deriv_lemma. apply included_imp_deriv_n with (Hab' := Min_less_Max a b a' b' Hab). intros x0 H6. elim H6; clear H6; intros H7 H8; split. apply leEq_transitive with a. apply Min_leEq_lft. auto. apply leEq_transitive with b. auto. apply lft_leEq_Max. apply n_deriv_lemma. auto. apply Feq_imp_eq with (Compact (less_leEq _ _ _ Hab')). apply Derivative_I_n_unique with n F. apply n_deriv_lemma. apply included_imp_deriv_n with (Hab' := Min_less_Max a b a' b' Hab). intros x0 H6. elim H6; clear H6; intros H7 H8; split. apply leEq_transitive with a'. apply Min_leEq_rht. auto. apply leEq_transitive with b'. auto. apply rht_leEq_Max. apply n_deriv_lemma. auto. elim H1; clear H1; intros H7 H8; split. apply leEq_transitive with a'. apply Min_leEq_rht. auto. apply leEq_transitive with b'. auto. apply rht_leEq_Max. red in |- *; intros. inversion_clear H0; split. apply leEq_transitive with a. apply Min_leEq_lft. auto. apply leEq_transitive with b. auto. apply lft_leEq_Max. Qed. End More_on_n_deriv. corn-8.20.0/ftc/PartFunEquality.v000066400000000000000000000355421473720167500166270ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Feq %\ensuremath{\approx}% #≈# *) Require Export CoRN.reals.Intervals. Require Export CoRN.tactics.DiffTactics1. Section Definitions. (** * Equality of Partial Functions ** Definitions In some contexts (namely when quantifying over partial functions) we need to refer explicitly to the subsetoid of elements satisfying a given predicate rather than to the predicate itself. The following definition makes this possible. *) Definition subset (P : IR -> CProp) : CSetoid := Build_SubCSetoid IR P. (** The core of our work will revolve around the following fundamental notion: two functions are equal in a given domain (predicate) iff they coincide on every point of that domain#. #%\footnote{%Notice that, according to our definition of partial function, it is equivalent to prove the equality for every proof or for a specific proof. Typically it is easier to consider a generic case%.}%. This file is concerned with proving the main properties of this equality relation. *) Definition Feq P (F G : PartIR) := included P (Dom F) and included P (Dom G) and (forall x, P x -> forall Hx Hx', F x Hx [=] G x Hx'). (** Notice that, because the quantification over the proofs is universal, we must require explicitly that the predicate be included in the domain of each function; otherwise the basic properties of equality (like, for example, transitivity) would fail to hold#. #%\footnote{%To see this it is enough to realize that the empty function would be equal to every other function in every domain.%}.% The way to circumvent this would be to quantify existentially over the proofs; this, however, would have two major disadvantages: first, proofs of equality would become very cumbersome and clumsy; secondly (and most important), we often need to prove the inclusions from an equality hypothesis, and this definition allows us to do it in a very easy way. Also, the pointwise equality is much nicer to use from this definition than in an existentially quantified one. *) End Definitions. Section Equality_Results. (** ** Properties of Inclusion We will now prove the main properties of the equality relation. %\begin{convention}% Let [I,R:IR->CProp] and [F,G:PartIR], and denote by [P] and [Q], respectively, the domains of [F] and [G]. %\end{convention}% *) Variable I : IR -> CProp. Variables F G : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Variable R : IR -> CProp. (** We start with two lemmas which make it much easier to prove and use this definition: *) Lemma eq_imp_Feq : included I P -> included I Q -> (forall x, I x -> forall Hx Hx', F x Hx [=] G x Hx') -> Feq I F G. Proof. intros. split. assumption. split; assumption. Qed. Lemma Feq_imp_eq : Feq I F G -> forall x, I x -> forall Hx Hx', F x Hx [=] G x Hx'. Proof. intros H x Hx1 Hx Hx'. elim H; intros H0 H1. elim H1; auto. Qed. Lemma included_IR : included I (fun x : IR => True). Proof. split. Qed. End Equality_Results. #[global] Hint Resolve included_IR : included. Section Some_More. (** If two function coincide on a given subset then they coincide in any smaller subset. *) Lemma included_Feq : forall P Q F G, included P Q -> Feq Q F G -> Feq P F G. Proof. intros P Q F G H H0. elim H0; clear H0; intros H0 H1. elim H1; clear H1; intros H1 H2. apply eq_imp_Feq. eapply included_trans. apply H. assumption. eapply included_trans. apply H. assumption. intros; apply H2. apply H; assumption. Qed. End Some_More. Section Away_from_Zero. Section Definitions. (** ** Away from [0] Before we prove our main results about the equality we have to do some work on division. A function is said to be bounded away from zero in a set if there exists a positive lower bound for the set of absolute values of its image of that set. %\begin{convention}% Let [I : IR->CProp], [F : PartIR] and denote by [P] the domain of [F]. %\end{convention}% *) Variable I : IR -> CProp. Variable F : PartIR. (* begin hide *) Let P := Dom F. (* end hide *) Definition bnd_away_zero := included I P and {c : IR | [0] [<] c | forall y Hy, (I y) -> c [<=] AbsIR (F y Hy)}. (** If [F] is bounded away from zero in [I] then [F] is necessarily apart from zero in [I]; also this means that [I] is included in the domain of [{1/}F]. *) (* begin show *) Hypothesis Hf : bnd_away_zero. (* end show *) Lemma bnd_imp_ap_zero : forall x Hx, (I x) -> F x Hx [#] [0]. Proof. intros. apply AbsIR_cancel_ap_zero. apply Greater_imp_ap. elim Hf; intros. inversion_clear b. eapply less_leEq_trans; auto. auto. Qed. Lemma bnd_imp_inc_recip : included I (Dom {1/}F). Proof. intros x Hx. elim Hf; intros H H0. split. apply (H x Hx). intro. apply bnd_imp_ap_zero; auto. Qed. Lemma bnd_imp_inc_div : forall G, included I (Dom G) -> included I (Dom (G{/}F)). Proof. intros G HG x Hx. split; auto. elim Hf; intros H0 H1. split. apply (H0 x Hx). intro. apply bnd_imp_ap_zero; auto. Qed. End Definitions. (** Boundedness away from zero is preserved through restriction of the set. %\begin{convention}% Let [F] be a partial function and [P, Q] be predicates. %\end{convention}% *) Variable F : PartIR. Variables P Q : IR -> CProp. Lemma included_imp_bnd : included Q P -> bnd_away_zero P F -> bnd_away_zero Q F. Proof. intros H H0. elim H0; clear H0; intros H1 H2; split. apply included_trans with P; auto. elim H2; intros c Hc Hc'. exists c; auto. Qed. Lemma FRestr_bnd : forall (HP : pred_wd _ P) (H : included P (Dom F)), included Q P -> bnd_away_zero Q F -> bnd_away_zero Q (Frestr HP H). Proof. intros HP H H0 H1. elim H1; clear H1; intros H2 H3; split. auto. elim H3; intro c; intros. exists c; simpl in |- *; auto. Qed. (** A function is said to be bounded away from zero everywhere if it is bounded away from zero in every compact subinterval of its domain; a similar definition is made for arbitrary sets, which will be necessary for future work. *) Definition bnd_away_zero_everywhere G := forall a b Hab, included (compact a b Hab) (Dom G) -> bnd_away_zero (compact a b Hab) G. Definition bnd_away_zero_in_P := forall a b Hab, included (compact a b Hab) P -> bnd_away_zero (compact a b Hab) F. (** An immediate consequence: *) Lemma bnd_in_P_imp_ap_zero : pred_wd _ P -> bnd_away_zero_in_P -> forall x, P x -> forall Hx, F x Hx [#] [0]. Proof. intros H H0 x H1 Hx. apply bnd_imp_ap_zero with (Compact (leEq_reflexive _ x)). apply H0. red in |- *; intros x0 H2. cut (x [=] x0); intros. apply H with x; auto. inversion_clear H2; apply leEq_imp_eq; auto. split; apply leEq_reflexive. Qed. Lemma FRestr_bnd' : forall (HP : pred_wd _ P) (H : included P (Dom F)), bnd_away_zero_everywhere F -> bnd_away_zero_everywhere (Frestr HP H). Proof. intros HP H H0 a b Hab H1. elim (H0 a b Hab); intros. split. auto. elim b0; intro c; intros. exists c; simpl in |- *; auto. apply included_trans with P; simpl in H1; auto. Qed. End Away_from_Zero. #[global] Hint Resolve bnd_imp_inc_recip bnd_imp_inc_div: included. #[global] Hint Immediate bnd_in_P_imp_ap_zero: included. (** ** The [FEQ] tactic This tactic splits a goal of the form [Feq I F G] into the three subgoals [included I (Dom F)], [included I (Dom G)] and [forall x, F x [=] G x] and applies [Included] to the first two and [rational] to the third. *) (* begin hide *) Ltac FEQ := apply eq_imp_Feq; [ Included | Included | intros; try (simpl in |- *; rational) ]. (* end hide *) Section More_on_Equality. (** ** Properties of Equality We are now finally able to prove the main properties of the equality relation. We begin by showing it to be an equivalence relation. %\begin{convention}% Let [I] be a predicate and [F, F', G, G', H] be partial functions. %\end{convention}% *) Variable I : IR -> CProp. Section Feq_Equivalence. Variables F G H : PartIR. Lemma Feq_reflexive : included I (Dom F) -> Feq I F F. Proof. intro; FEQ. Qed. Lemma Feq_symmetric : Feq I F G -> Feq I G F. Proof. intro H0. elim H0; intros H' H1. elim H1; intros incF incG. FEQ; algebra. Qed. Lemma Feq_transitive : Feq I F G -> Feq I G H -> Feq I F H. Proof. intro H0. elim H0; intros incF H'. elim H'; intros incG H1. clear H0 H'. intro H0. elim H0; intros incG' H'. elim H'; intros incH H2. clear H0 H'. FEQ. Step_final (G x (incG x X)). Qed. End Feq_Equivalence. Section Operations. (** Also it is preserved through application of functional constructors and restriction. *) Variables F F' G G' : PartIR. Lemma Feq_plus : Feq I F F' -> Feq I G G' -> Feq I (F{+}G) (F'{+}G'). Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incG H2. elim H1; intros incF' H1'. elim H1'; clear H1 H1'; intros incG' H1. FEQ; simpl in |- *; algebra. Qed. Lemma Feq_inv : Feq I F F' -> Feq I {--}F {--}F'. Proof. intro H0. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incF' H1. FEQ; simpl in |- *; algebra. Qed. Lemma Feq_minus : Feq I F F' -> Feq I G G' -> Feq I (F{-}G) (F'{-}G'). Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incG H2. elim H1; intros incF' H1'. elim H1'; clear H1 H1'; intros incG' H0. FEQ; simpl in |- *; algebra. Qed. Lemma Feq_mult : Feq I F F' -> Feq I G G' -> Feq I (F{*}G) (F'{*}G'). Proof. intros H0 H1. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incG H2. elim H1; intros incF' H1'. elim H1'; clear H1 H1'; intros incG' H0. FEQ; simpl in |- *; algebra. Qed. Lemma Feq_nth : forall n : nat, Feq I F F' -> Feq I (F{^}n) (F'{^}n). Proof. intros n H0. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incF' H1. FEQ. astepl (F x Hx[^]n); Step_final (Part F' x Hx'[^]n). Qed. Lemma Feq_recip : bnd_away_zero I F -> Feq I F F' -> Feq I {1/}F {1/}F'. Proof. intros Hbnd H0. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incF' H1. FEQ. apply included_FRecip. auto. intros x H Hx; apply ap_wdl_unfolded with (F x (incF x H)). apply bnd_imp_ap_zero with I; assumption. auto. simpl in |- *; algebra. Qed. Lemma Feq_recip' : bnd_away_zero I F -> Feq I F' F -> Feq I {1/}F' {1/}F. Proof. intros. apply Feq_symmetric; apply Feq_recip. assumption. apply Feq_symmetric; assumption. Qed. Lemma Feq_div : bnd_away_zero I G -> Feq I F F' -> Feq I G G' -> Feq I (F{/}G) (F'{/}G'). Proof. intros Hbnd H0 H1. elim H0; intros incF H0'. elim H0'; clear H0 H0'; intros incF' H2. elim H1; intros incG H1'. elim H1'; clear H1 H1'; intros incG' H0. FEQ. apply included_FDiv; auto. intros x H Hx; apply ap_wdl_unfolded with (G x (incG x H)). apply bnd_imp_ap_zero with I; assumption. auto. simpl in |- *; algebra. Qed. Lemma Feq_div' : bnd_away_zero I G -> Feq I F' F -> Feq I G' G -> Feq I (F'{/}G') (F{/}G). Proof. intros. apply Feq_symmetric; apply Feq_div. assumption. apply Feq_symmetric; assumption. apply Feq_symmetric; assumption. Qed. Lemma Feq_comp : forall (J : IR -> CProp), (forall x Hx, I x -> J (F x Hx)) -> (forall x Hx, I x -> J (F' x Hx)) -> Feq I F F' -> Feq J G G' -> Feq I (G[o]F) (G'[o]F'). Proof. intros J Hmap Hmap' [HF0 [HF1 HF2]] [HG0 [HG1 HG2]]. repeat split; try (apply included_FComp; Included). intros x Habx [Hx0 Hx1] [Hx'0 Hx'1]. simpl. assert (F x Hx0[=]F' x Hx'0). apply HF2. Included. assert (X:Dom G' (F x Hx0)). eapply dom_wd. apply Hx'1. apply eq_symmetric; assumption. apply eq_transitive with (G' (F x Hx0) X). apply HG2. Included. apply pfwdef. assumption. Qed. (** Notice that in the case of division we only need to require boundedness away from zero for one of the functions (as they are equal); thus the two last lemmas are stated in two different ways, as according to the context one or the other condition may be easier to prove. The restriction of a function is well defined. *) Lemma FRestr_wd : forall Iwd Hinc, Feq I F (Frestr (F:=F) (P:=I) Iwd Hinc). Proof. intros. FEQ. Qed. (** The image of a set is extensional. *) Lemma fun_image_wd : Feq I F G -> forall x, fun_image F I x -> fun_image G I x. Proof. intros H x H0. elim H; clear H; intros H H1. elim H1; clear H1; intros H2 H3. elim H0; intros y Hy. exists y. elim Hy; intros H4 H1. elim H1; clear Hy H1; intros H5 H6. split; auto. split; auto. intro; Step_final (F y H5). Qed. End Operations. End More_on_Equality. Section Nth_Power. (** ** Nth Power We finish this group of lemmas with characterization results for the power function (similar to those already proved for arbitrary rings). The characterization is done at first pointwise and later using the equality relation. %\begin{convention}% Let [F] be a partial function with domain [P] and [Q] be a predicate on the real numbers assumed to be included in [P]. %\end{convention}% *) Variable F : PartIR. (* begin hide *) Let P := Dom F. (* end hide *) Variable Q : IR -> CProp. Hypothesis H : included Q (fun x : IR => True). Hypothesis Hf : included Q (Dom F). Lemma FNth_zero : forall x, Q x -> forall Hx Hx', [-C-][1] x Hx [=] (F{^}0) x Hx'. Proof. intros. algebra. Qed. Variable n : nat. Hypothesis H' : included Q (Dom (F{*}F{^}n)). Lemma FNth_mult : forall x, Q x -> forall Hx Hx', (F{*}F{^}n) x Hx [=] (F{^}S n) x Hx'. Proof. intros. simpl in |- *. eapply eq_transitive_unfolded. 2: apply mult_commutes. apply mult_wd. rational. change (F x (ProjIR2 Hx) [^]n [=] F x Hx'[^]n) in |- *. apply nexp_wd; rational. Qed. End Nth_Power. Section Strong_Nth_Power. (** %\begin{convention}% Let [a,b] be real numbers such that [I := [a,b]] is included in the domain of [F]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := compact a b Hab. (* end hide *) Variable F : PartIR. Hypothesis incF : included I (Dom F). Lemma FNth_zero' : Feq I [-C-][1] (F{^}0). Proof. FEQ. Qed. Lemma FNth_mult' : forall n, Feq I (F{*}F{^}n) (F{^}S n). Proof. intro; FEQ. simpl in |- *. eapply eq_transitive_unfolded. 2: apply mult_commutes. apply bin_op_wd_unfolded. rational. change (F x (ProjIR2 Hx) [^]n [=] F x Hx'[^]n) in |- *. apply nexp_wd; rational. Qed. End Strong_Nth_Power. corn-8.20.0/ftc/PartInterval.v000066400000000000000000000150371473720167500161420ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.IntervalFunct. Section Conversion. (** * Correspondence In this file we prove that there are mappings going in both ways between the set of partial functions whose domain contains [[a,b]] and the set of real-valued functions with domain on that interval. These mappings form an adjunction, and thus they have all the good properties for preservation results. ** Mappings We begin by defining the map from partial functions to setoid functions as simply being the restriction of the partial function to the interval [[a,b]]. %\begin{convention}% Let [F] be a partial function and [a,b:IR] such that [I [=] [a,b]] is included in the domain of [F]. %\end{convention}% *) Variable F : PartIR. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := compact a b Hab. (* end hide *) Hypothesis Hf : included I (Dom F). Lemma IntPartIR_strext : fun_strext (fun x : subset I => F (scs_elem _ _ x) (Hf _ (scs_prf _ _ x))). Proof. red in |- *; intros x y H. generalize (pfstrx _ _ _ _ _ _ H). case x; case y; auto. Qed. Definition IntPartIR : CSetoid_fun (subset I) IR. Proof. apply Build_CSetoid_fun with (fun x : subset I => Part F (scs_elem _ _ x) (Hf (scs_elem _ _ x) (scs_prf _ _ x))). exact IntPartIR_strext. Defined. End Conversion. Arguments IntPartIR [F a b Hab]. Section AntiConversion. (** To go the other way around, we simply take a setoid function [f] with domain [[a,b]] and build the corresponding partial function. *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := compact a b Hab. (* end hide *) Variable f : CSetoid_fun (subset I) IR. Lemma PartInt_strext : forall x y Hx Hy, f (Build_subcsetoid_crr IR _ x Hx) [#] f (Build_subcsetoid_crr IR _ y Hy) -> x [#] y. Proof. intros x y Hx Hy H. exact (csf_strext_unfolded _ _ _ _ _ H). Qed. Definition PartInt : PartIR. apply Build_PartFunct with (pfpfun := fun (x : IR) Hx => f (Build_subcsetoid_crr IR _ x Hx)). Proof. exact (compact_wd _ _ _). exact PartInt_strext. Defined. End AntiConversion. Arguments PartInt [a b Hab]. Section Inverses. (** In one direction these operators are inverses. *) Lemma int_part_int : forall a b Hab F (Hf : included (compact a b Hab) (Dom F)), Feq (compact a b Hab) F (PartInt (IntPartIR Hf)). Proof. intros; FEQ. Qed. End Inverses. Section Equivalences. (** ** Mappings Preserve Operations We now prove that all the operations we have defined on both sets are preserved by [PartInt]. %\begin{convention}% Let [F,G] be partial functions and [a,b:IR] and denote by [I] the interval [[a,b]]. Let [f,g] be setoid functions of type [I->IR] equal respectively to [F] and [G] in [I]. %\end{convention}% *) Variables F G : PartIR. Variables a b c : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := compact a b Hab. (* end hide *) Variables f g : CSetoid_fun (subset (compact a b Hab)) IR. Hypothesis Ff : Feq I F (PartInt f). Hypothesis Gg : Feq I G (PartInt g). Lemma part_int_const : Feq I [-C-]c (PartInt (IConst (Hab:=Hab) c)). Proof. apply eq_imp_Feq. red in |- *; simpl in |- *; intros; auto. unfold I in |- *; apply included_refl. intros; simpl in |- *; algebra. Qed. Lemma part_int_id : Feq I FId (PartInt (IId (Hab:=Hab))). Proof. apply eq_imp_Feq. red in |- *; simpl in |- *; intros; auto. unfold I in |- *; apply included_refl. intros; simpl in |- *; algebra. Qed. Lemma part_int_plus : Feq I (F{+}G) (PartInt (IPlus f g)). Proof. elim Ff; intros incF Hf. elim Hf; clear Ff Hf; intros incF' Hf. elim Gg; intros incG Hg. elim Hg; clear Gg Hg; intros incG' Hg. apply eq_imp_Feq. Included. Included. intros; simpl in |- *; simpl in Hf, Hg. simpl in |- *; algebra. Qed. Lemma part_int_inv : Feq I {--}F (PartInt (IInv f)). Proof. elim Ff; intros incF Hf. elim Hf; clear Ff Hf; intros incF' Hf. apply eq_imp_Feq. Included. Included. intros; simpl in |- *; simpl in Hf. simpl in |- *; algebra. Qed. Lemma part_int_minus : Feq I (F{-}G) (PartInt (IMinus f g)). Proof. elim Ff; intros incF Hf. elim Hf; clear Ff Hf; intros incF' Hf. elim Gg; intros incG Hg. elim Hg; clear Gg Hg; intros incG' Hg. apply eq_imp_Feq. Included. Included. intros; simpl in |- *; simpl in Hf, Hg. simpl in |- *; algebra. Qed. Lemma part_int_mult : Feq I (F{*}G) (PartInt (IMult f g)). Proof. elim Ff; intros incF Hf. elim Hf; clear Ff Hf; intros incF' Hf. elim Gg; intros incG Hg. elim Hg; clear Gg Hg; intros incG' Hg. apply eq_imp_Feq. Included. Included. intros; simpl in |- *; simpl in Hf, Hg. simpl in |- *; algebra. Qed. Lemma part_int_nth : forall n : nat, Feq I (F{^}n) (PartInt (INth f n)). Proof. intro. elim Ff; intros incF Hf. elim Hf; clear Ff Hf; intros incF' Hf. apply eq_imp_Feq. Included. Included. intros; simpl in |- *; simpl in Hf. astepl (Part F x Hx[^]n); astepr (f (Build_subcsetoid_crr IR _ x Hx')[^]n). apply nexp_wd; algebra. Qed. (* begin show *) Hypothesis HG : bnd_away_zero I G. Hypothesis Hg : forall x : subset I, g x [#] [0]. (* end show *) Lemma part_int_recip : Feq I {1/}G (PartInt (IRecip g Hg)). Proof. elim Gg; intros incG Hg'. elim Hg'; clear Gg Hg'; intros incG' Hg'. apply eq_imp_Feq. Included. Included. intros; simpl in Hg'; simpl in |- *; algebra. Qed. Lemma part_int_div : Feq I (F{/}G) (PartInt (IDiv f g Hg)). Proof. elim Ff; intros incF Hf. elim Hf; clear Ff Hf; intros incF' Hf. elim Gg; intros incG Hg'. elim Hg'; clear Gg Hg'; intros incG' Hg'. apply eq_imp_Feq. Included. Included. intros; simpl in Hf, Hg'; simpl in |- *. algebra. Qed. End Equivalences. corn-8.20.0/ftc/Partitions.v000066400000000000000000000623341473720167500156650ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Continuity. From Coq Require Import Lia. (** printing Partition_Sum %\ensuremath{\sum_P}% #∑P# *) Section Definitions. (** * Partitions We now begin to lay the way for the definition of Riemann integral. This will be done through the definition of a sequence of sums that is proved to be convergent; in order to do that, we first need to do a bit of work on partitions. ** Definitions A partition is defined as a record type. For each compact interval [[a,b]] and each natural number [n], a partition of [[a,b]] with [n+1] points is a choice of real numbers [a [=] a0 [<=] a1 [<=] an [=] b]; the following specification works as follows: - [Pts] is the function that chooses the points (it is declared as a coercion); - [prf1] states that [Pts] is a setoid function; - [prf2] states that the points are ordered; - [start] requires that [a0 [=] a] and - [finish] requires that [an [=] b]. *) Record Partition (a b : IR) (Hab : a [<=] b) (lng : nat) : Type := {Pts :> forall i, i <= lng -> IR; prf1 : forall i j, i = j -> forall Hi Hj, Pts i Hi [=] Pts j Hj; prf2 : forall i Hi HSi, Pts i Hi [<=] Pts (S i) HSi; start : forall H, Pts 0 H [=] a; finish : forall H, Pts lng H [=] b}. (** Two immediate consequences of this are that [ai [<=] aj] whenever [i < j] and that [ai] is in [[a,b]] for all [i]. *) Lemma Partition_mon : forall a b Hab lng (P : Partition a b Hab lng) i j Hi Hj, i <= j -> P i Hi [<=] P j Hj. Proof. intros; induction j as [| j Hrecj]. cut (i = 0); [ intro | auto with arith ]. apply eq_imp_leEq; apply prf1; auto. elim (le_lt_eq_dec _ _ H); intro H1. cut (j <= lng); [ intro | clear Hrecj; lia ]. apply leEq_transitive with (Pts _ _ _ _ P j H0). apply Hrecj; clear Hrecj; auto with arith. apply prf2. apply eq_imp_leEq; apply prf1; assumption. Qed. Lemma Partition_in_compact : forall a b Hab lng (P : Partition a b Hab lng) i Hi, compact a b Hab (P i Hi). Proof. intros. split. apply leEq_wdl with (P _ (Nat.le_0_l _)). apply Partition_mon; auto with arith. apply start. apply leEq_wdr with (P _ (le_n _)). apply Partition_mon; auto with arith. apply finish. Qed. (** Each partition of [[a,b]] implies a partition of the interval $[a,a_{n-1}]$#[a,an-1]#. This partition will play an important role in much of our future work, so we take some care to define it. *) Lemma part_pred_lemma : forall a b Hab lng (P : Partition a b Hab lng) i Hi, a [<=] P i Hi. Proof. intros. apply leEq_wdl with (P 0 (Nat.le_0_l _)). apply Partition_mon; auto with arith. apply start. Qed. Definition Partition_Dom a b Hab n P : Partition a _ (part_pred_lemma a b Hab (S n) P n (Nat.le_succ_diag_r n)) n. Proof. intros. apply Build_Partition with (fun (i : nat) (Hi : i <= n) => P i (le_S _ _ Hi)). intros; simpl in |- *; apply prf1; assumption. intros; simpl in |- *; apply prf2. intros; simpl in |- *; apply start. intros; simpl in |- *; apply prf1; auto. Defined. (** The mesh of a partition is the greatest distance between two consecutive points. For convenience's sake we also define the dual concept, which is very helpful in some situations. In order to do this, we begin by building a list with all the distances between consecutive points; next we only need to extract the maximum and the minimum of this list. Notice that this list is nonempty except in the case when [a [=] b] and [n = 0]; this means that the convention we took of defining the minimum and maximum of the empty list to be [0] actually helps us in this case. *) Definition Part_Mesh_List n a b Hab (P : Partition a b Hab n) : list IR. Proof. revert a b Hab P; induction n as [| n Hrecn]; intros. apply (@nil IR). apply cons. apply (P _ (le_n (S n)) [-]P _ (le_S _ _ (le_n n))). apply Hrecn with a (P _ (Nat.le_succ_diag_r n)) (part_pred_lemma _ _ _ _ P n (Nat.le_succ_diag_r n)). apply Partition_Dom. Defined. Definition Mesh a b Hab n P := maxlist (Part_Mesh_List n a b Hab P). Definition AntiMesh a b Hab n P := minlist (Part_Mesh_List n a b Hab P). (** Even partitions (partitions where all the points are evenly spaced) will also play a central role in our work; the first two lemmas are presented simply to make the definition of even partition lighter. *) Lemma even_part_1 : forall a b n Hn, a[+]nring 0[*] (b[-]a[/] _[//]nring_ap_zero' IR n Hn) [=] a. Proof. intros; rational. Qed. Lemma even_part_2 : forall a b n Hn, a[+]nring n[*] (b[-]a[/] _[//]nring_ap_zero' IR n Hn) [=] b. Proof. intros; rational. Qed. Definition Even_Partition a b Hab n (Hn : 0 <> n) : Partition a b Hab n. Proof. intros. apply Build_Partition with (fun (i : nat) (Hi : i <= n) => a[+]nring i[*] (b[-]a[/] _[//]nring_ap_zero' _ n Hn)). intros; simpl in |- *. rewrite H; algebra. intros; simpl in |- *. apply plus_resp_leEq_lft. apply mult_resp_leEq_rht. apply less_leEq; apply less_plusOne. apply shift_leEq_div. apply nring_pos; clear Hi; apply Nat.neq_0_lt_0; auto. apply shift_leEq_minus. astepl ([0][+]a). astepl a; assumption. intros; simpl in |- *; apply even_part_1; auto. intros; simpl in |- *; apply even_part_2; auto. Defined. Section Refinements. Variables a b : IR. Hypothesis Hab : a [<=] b. Variables m n : nat. Variable P : (Partition a b Hab n). Variable Q : (Partition a b Hab m). (** We now define what it means for a partition [Q] to be a refinement of [P] and prove the main property of refinements. *) Definition Refinement := {f : nat -> nat | f 0 = 0 /\ f n = m /\ (forall i j, i < j -> f i < f j) | forall i Hi, {H' : f i <= m | P i Hi [=] Q (f i) H'}}. Lemma Refinement_prop : Refinement -> forall i (Hi : i <= m) (HSi : (S i) <= m), {j : nat | {Hj : j <= n | {HSj : S j <= n | P _ Hj [<=] Q _ Hi | Q _ HSi [<=] P _ HSj}}}. Proof. intros H i Hi Hi'. elim H; clear H; intros f Hf. elim Hf; clear Hf; intros Hf0 Hf. elim Hf; clear Hf; intros Hfn Hfmon. intro Hf. cut {j : nat | f j <= i | S i <= f (S j)}. intro H. elim H; clear H; intros j Hj Hj'. exists j. cut (j < n). intro. cut (j <= n); [ intro Hj1 | auto with arith ]. exists Hj1. elim (Hf j Hj1); intros H' HPts. cut (S j <= n); [ intro Hj2 | apply H ]. elim (Hf (S j) Hj2); intros H'' HPts'. exists Hj2. eapply leEq_wdl. 2: eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply HPts. apply Partition_mon; assumption. apply prf1; auto. eapply leEq_wdr. 2: eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply HPts'. apply Partition_mon; assumption. apply prf1; auto. clear Hj' Hf Hf0. cut (i < f n). intro. cut (f j < f n); [ intro | apply Nat.le_lt_trans with i; auto ]. apply not_ge. intro; red in H1. apply (Nat.le_ngt (f j) (f n)); auto with arith. apply Hfmon. elim (le_lt_eq_dec _ _ H1); intro; auto. rewrite b0 in H0; elim (Nat.lt_irrefl (f j)); auto. rewrite <- Hfn in Hi'; auto. apply mon_fun_covers; auto. exists n; clear Hf Hfmon. rewrite Hfn; assumption. Qed. (** We will also need to consider arbitrary sums %of the form \[\sum_{i=0}^{n-1}f(x_i)(a_{i+1}-a_i)\]%#of f(xi)(ai+1-ai)# where $x_i\in[a_i,a_{i+1}]$#xi∈[ai,ai+1]#. For this, we again need a choice function [x] which has to satisfy some condition. We define the condition and the sum for a fixed [P]: *) Definition Points_in_Partition (g : forall i, i < n -> IR) : CProp := forall i Hi, Compact (prf2 _ _ _ _ P i (Nat.lt_le_incl _ _ Hi) Hi) (g i Hi). Lemma Pts_part_lemma : forall g, Points_in_Partition g -> forall i Hi, compact a b Hab (g i Hi). Proof. intros g H i H0. elim (H i H0); intros. split. eapply leEq_transitive. 2: apply a0. apply leEq_wdl with (P 0 (Nat.le_0_l _)). apply Partition_mon; auto with arith. apply start. eapply leEq_transitive. apply b0. apply leEq_wdr with (P n (le_n _)). apply Partition_mon; auto with arith. apply finish. Qed. Definition Partition_Sum g F (H : Points_in_Partition g) (incF : included (Compact Hab) (Dom F)) := Sumx (fun i Hi => F (g i Hi) (incF _ (Pts_part_lemma _ H i Hi)) [*] (P (S i) Hi[-]P i (Nat.lt_le_incl _ _ Hi))). End Refinements. Arguments Points_in_Partition [a b Hab n]. Arguments Partition_Sum [a b Hab n P g F]. (** ** Constructions We now formalize some trivial and helpful constructions. %\begin{convention}% We will assume a fixed compact interval [[a,b]], denoted by [I]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := compact a b Hab. (* end hide *) Section Getting_Points. (** From a partition we always have a canonical choice of points at which to evaluate a function: just take all but the last points of the partition. %\begin{convention}% Let [Q] be a partition of [I] with [m] points. %\end{convention}% *) Variable m : nat. Variable Q : Partition a b Hab m. Definition Partition_imp_points : forall i : nat, i < m -> IR. Proof. intros. apply (Q i (Nat.lt_le_incl _ _ H)). Defined. Lemma Partition_imp_points_1 : Points_in_Partition Q Partition_imp_points. Proof. red in |- *; intros. unfold Partition_imp_points in |- *; split. apply leEq_reflexive. apply prf2. Qed. Lemma Partition_imp_points_2 : nat_less_n_fun Partition_imp_points. Proof. red in |- *; intros. unfold Partition_imp_points in |- *; simpl in |- *. apply prf1; auto. Qed. End Getting_Points. (** As a corollary, given any continuous function [F] and a natural number we have an immediate choice of a sum of [F] in [[a,b]]. *) Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. Definition Even_Partition_Sum (n : nat) (Hn : 0 <> n) : IR. Proof. intros. apply Partition_Sum with a b Hab n (Even_Partition a b Hab n Hn) (Partition_imp_points _ (Even_Partition a b Hab n Hn)) F. apply Partition_imp_points_1. apply contin_imp_inc; assumption. Defined. End Definitions. Arguments Partition [a b]. Arguments Partition_Dom [a b Hab n]. Arguments Mesh [a b Hab n]. Arguments AntiMesh [a b Hab n]. Arguments Pts [a b Hab lng]. Arguments Part_Mesh_List [n a b Hab]. Arguments Points_in_Partition [a b Hab n]. Arguments Partition_Sum [a b Hab n P g F]. Arguments Even_Partition [a b]. Arguments Even_Partition_Sum [a b]. Arguments Refinement [a b Hab m n]. #[global] Hint Resolve start finish: algebra. Section Lemmas. (** ** Properties of the mesh If a partition has more than one point then its mesh list is nonempty. *) Lemma length_Part_Mesh_List : forall n (a b : IR) (Hab : a [<=] b) (P : Partition Hab n), 0 < n -> 0 < length (Part_Mesh_List P). Proof. intro; case n; intros. exfalso; inversion H. simpl in |- *; auto with arith. Qed. (** Any element of the auxiliary list defined to calculate the mesh of a partition has a very specific form. *) Lemma Part_Mesh_List_lemma : forall n (a b : IR) (Hab : a [<=] b) (P : Partition Hab n) x, member x (Part_Mesh_List P) -> {i : nat | {Hi : i <= n | {Hi' : S i <= n | x [=] P _ Hi'[-]P _ Hi}}}. Proof. intro; induction n as [| n Hrecn]. simpl in |- *; intros. easy. intros a b Hab P x H. simpl in H; elim H; clear H; intro H0. elim (Hrecn _ _ _ _ _ H0); clear Hrecn. intros i H; elim H; clear H. intros Hi H; elim H; clear H. intros Hi' H. simpl in H. exists i; exists (le_S _ _ Hi); exists (le_S _ _ Hi'). eapply eq_transitive_unfolded. apply H. apply cg_minus_wd; apply prf1; auto. exists n. exists (le_S _ _ (le_n n)). exists (le_n (S n)). eapply eq_transitive_unfolded. apply H0. apply cg_minus_wd; apply prf1; auto. Qed. (** Mesh and antimesh are always nonnegative. *) Lemma Mesh_nonneg : forall n (a b : IR) (Hab : a [<=] b) (P : Partition Hab n), [0] [<=] Mesh P. Proof. simple induction n. intros; unfold Mesh in |- *; simpl in |- *. apply leEq_reflexive. clear n; intros. unfold Mesh in |- *. apply leEq_transitive with (P _ (le_n (S n)) [-]P _ (le_S _ _ (le_n n))). apply shift_leEq_minus; astepl (P _ (le_S _ _ (le_n n))). apply prf2. apply maxlist_greater. right; algebra. Qed. Lemma AntiMesh_nonneg : forall n (a b : IR) (Hab : a [<=] b) (P : Partition Hab n), [0] [<=] AntiMesh P. Proof. intro; induction n as [| n Hrecn]. intros; unfold AntiMesh in |- *; simpl in |- *. apply leEq_reflexive. intros. unfold AntiMesh in |- *. apply leEq_minlist. simpl in |- *; auto with arith. intros y H. simpl in H; elim H; clear H; intro H0. unfold AntiMesh in Hrecn. apply leEq_transitive with (minlist (Part_Mesh_List (Partition_Dom P))). 2: apply minlist_smaller; assumption. apply Hrecn. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply H0. apply shift_leEq_minus; astepl (P _ (le_S _ _ (le_n n))). apply prf2. Qed. (** Most important, [AntiMesh] and [Mesh] provide lower and upper bounds for the distance between any two consecutive points in a partition. %\begin{convention}% Let [I] be [[a,b]] and [P] be a partition of [I] with [n] points. %\end{convention}% *) Variables a b : IR. (* begin hide *) Let I := compact a b. (* end hide *) Hypothesis Hab : a [<=] b. Variable n : nat. Variable P : Partition Hab n. Lemma Mesh_lemma : forall i H H', P (S i) H'[-]P i H [<=] Mesh P. Proof. clear I; generalize n a b Hab P; clear P n Hab a b. simple induction n. intros; exfalso; inversion H'. clear n; intro m; intros. induction m as [| m Hrecm]. cut (0 = i); [ intro | inversion H'; auto; inversion H2 ]. generalize H0 H'; clear H0 H'; rewrite <- H1. intros. unfold Mesh in |- *; simpl in |- *. apply eq_imp_leEq; apply cg_minus_wd; apply prf1; auto. elim (le_lt_eq_dec _ _ H'); intro H1. cut (i <= S m); [ intro | auto with arith ]. cut (S i <= S m); [ intro | auto with arith ]. set (P' := Partition_Dom P) in *. apply leEq_wdl with (P' _ H3[-]P' _ H2). 2: simpl in |- *; apply cg_minus_wd; apply prf1; auto. apply leEq_transitive with (Mesh P'). apply H. unfold Mesh in |- *; simpl in |- *; apply rht_leEq_Max. cut (i = S m); [ intro | auto with arith ]. generalize H' H0; clear H0 H'. rewrite H2; intros. unfold Mesh in |- *; apply maxlist_greater; right. apply cg_minus_wd; apply prf1; auto. Qed. Lemma AntiMesh_lemma : forall i H H', AntiMesh P [<=] P (S i) H'[-]P i H. Proof. clear I; generalize n a b Hab P; clear P n Hab a b. simple induction n. intros; exfalso; inversion H'. clear n; intro m; intros. induction m as [| m Hrecm]. cut (0 = i); [ intro | inversion H'; auto; inversion H2 ]. generalize H0 H'; clear H0 H'; rewrite <- H1. intros. unfold AntiMesh in |- *; simpl in |- *. apply eq_imp_leEq; apply cg_minus_wd; apply prf1; auto. elim (le_lt_eq_dec _ _ H'); intro H1. cut (i <= S m); [ intro | auto with arith ]. cut (S i <= S m); [ intro | auto with arith ]. set (P' := Partition_Dom P) in *. apply leEq_wdr with (P' _ H3[-]P' _ H2). 2: simpl in |- *; apply cg_minus_wd; apply prf1; auto. apply leEq_transitive with (AntiMesh P'). 2: apply H. unfold AntiMesh in |- *; simpl in |- *. unfold MIN. eapply leEq_wdr. 2: apply cg_inv_inv. apply inv_resp_leEq; apply rht_leEq_Max. cut (i = S m); [ intro | auto with arith ]. generalize H' H0; clear H0 H'. rewrite H2; intros. unfold AntiMesh in |- *; apply minlist_smaller; right. apply cg_minus_wd; apply prf1; auto. Qed. Lemma Mesh_leEq : forall m (Q : Partition Hab m), Refinement P Q -> Mesh Q [<=] Mesh P. Proof. intro; case m. intros Q H. unfold Mesh at 1 in |- *; simpl in |- *. apply Mesh_nonneg. clear m; intros m Q H. unfold Mesh at 1 in |- *. apply maxlist_leEq. simpl in |- *; auto with arith. intros x H0. elim (Part_Mesh_List_lemma _ _ _ _ _ _ H0). clear H0. intros i H0. elim H0; clear H0; intros Hi H0. elim H0; clear H0; intros Hi' H0. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply H0. elim H; intros f Hf. elim Hf; clear Hf; intros Hf' Hf. cut {j : nat | {Hj : j <= n | {Hj' : S j <= n | P _ Hj [<=] Q _ Hi | Q _ Hi' [<=] P _ Hj'}}}. intro H1. elim H1; intros j Hj. elim Hj; clear H1 Hj; intros Hj Hjaux. elim Hjaux; clear Hjaux; intros Hj' Hjaux. intros HPts HPts'. apply leEq_transitive with (P _ Hj'[-]P _ Hj). unfold cg_minus in |- *; apply plus_resp_leEq_both. assumption. apply inv_resp_leEq; assumption. apply Mesh_lemma. apply Refinement_prop; assumption. Qed. End Lemmas. Section Even_Partitions. (** More technical stuff. Two equal partitions have the same mesh. *) Lemma Mesh_wd : forall n a b b' (Hab : a [<=] b) (Hab' : a [<=] b') (P : Partition Hab n) (Q : Partition Hab' n), (forall i Hi, P i Hi [=] Q i Hi) -> Mesh P [=] Mesh Q. Proof. simple induction n. intros. unfold Mesh in |- *; simpl in |- *; algebra. clear n; intro. case n. intros. unfold Mesh in |- *; simpl in |- *. apply cg_minus_wd; apply H0. clear n; intros. unfold Mesh in |- *. apply eq_transitive_unfolded with (Max (P _ (le_n (S (S n))) [-]P _ (le_S _ _ (le_n (S n)))) (maxlist (Part_Mesh_List (Partition_Dom P)))). simpl in |- *; algebra. apply eq_transitive_unfolded with (Max (Q _ (le_n (S (S n))) [-]Q _ (le_S _ _ (le_n (S n)))) (maxlist (Part_Mesh_List (Partition_Dom Q)))). 2: simpl in |- *; algebra. apply Max_wd_unfolded. apply cg_minus_wd; apply H0. apply eq_transitive_unfolded with (Mesh (Partition_Dom P)). unfold Mesh in |- *; algebra. apply eq_transitive_unfolded with (Mesh (Partition_Dom Q)). apply H. intros. unfold Partition_Dom in |- *; simpl in |- *. apply H0. unfold Mesh in |- *; algebra. Qed. Lemma Mesh_wd' : forall n a b (Hab : a [<=] b) (P Q : Partition Hab n), (forall i Hi, P i Hi [=] Q i Hi) -> Mesh P [=] Mesh Q. Proof. intros. apply Mesh_wd. intros; apply H. Qed. (** The mesh of an even partition is easily calculated. *) Lemma even_partition_Mesh : forall m Hm a b (Hab : a [<=] b), Mesh (Even_Partition Hab m Hm) [=] (b[-]a[/] _[//]nring_ap_zero' _ _ Hm). Proof. simple induction m. intros; exfalso; apply Hm; auto. intros. unfold Mesh in |- *. elim (le_lt_dec n 0); intro. cut (0 = n); [ intro | auto with arith ]. generalize Hm; clear H a0 Hm. rewrite <- H0; intros. simpl in |- *. rational. apply eq_transitive_unfolded with (Max (a[+]nring (S n) [*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hm) [-] (a[+]nring n[*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hm))) (maxlist (Part_Mesh_List (Partition_Dom (Even_Partition Hab _ Hm))))). cut (n = S (pred n)); [ intro | symmetry; apply Nat.lt_succ_pred with 0; auto ]. generalize Hm; rewrite H0; clear Hm; intro. simpl in |- *; algebra. eapply eq_transitive_unfolded. apply Max_comm. simpl in |- *. eapply eq_transitive_unfolded. apply leEq_imp_Max_is_rht. 2: rational. apply eq_imp_leEq. rstepr (b[-]a[/] nring n[+][1][//]nring_ap_zero' _ _ Hm). apply eq_transitive_unfolded with (Mesh (Partition_Dom (Even_Partition Hab _ Hm))). simpl in |- *; algebra. cut (0 <> n); intro. eapply eq_transitive_unfolded. apply Mesh_wd' with (Q := Even_Partition (part_pred_lemma _ _ Hab (S n) (Even_Partition Hab _ Hm) n (Nat.le_succ_diag_r n)) _ H0). intros; simpl in |- *; rational. eapply eq_transitive_unfolded. apply H. simpl in |- *; rational. apply (Nat.neq_0_lt_0 n); auto. Qed. (** ** Miscellaneous %\begin{convention}% Throughout this section, let [a,b:IR] and [I] be [[a,b]]. %\end{convention}% *) Variables a b : IR. (* begin hide *) Let I := compact a b. (* end hide *) Hypothesis Hab : a [<=] b. (** An interesting property: in a partition, if [ai [<] aj] then [i < j]. *) Lemma Partition_Points_mon : forall n (P : Partition Hab n) i j Hi Hj, P i Hi [<] P j Hj -> i < j. Proof. intros. cut (~ j <= i); intro. apply not_ge; auto. exfalso. apply less_irreflexive_unfolded with (x := P i Hi). apply less_leEq_trans with (P j Hj). assumption. apply local_mon'_imp_mon'_le with (f := fun (i : nat) (Hi : i <= n) => P i Hi). intros; apply prf2. intro; intros; apply prf1; assumption. assumption. Qed. Lemma refinement_resp_mult : forall m n Hm Hn, {k : nat | m = n * k} -> Refinement (Even_Partition Hab n Hn) (Even_Partition Hab m Hm). Proof. intros m n Hm Hn H. elim H; intros k Hk. red in |- *. cut (0 <> k); intro. exists (fun i : nat => i * k); repeat split. symmetry in |- *; assumption. intros. apply Nat.mul_lt_mono_pos_r. apply Nat.neq_0_lt_0; auto. assumption. intros. cut (i * k <= m). intro. exists H1. simpl in |- *. apply bin_op_wd_unfolded. algebra. generalize Hm; rewrite Hk. clear Hm; intro. rstepl (nring i[*]nring k[*] (b[-]a[/] _[//] mult_resp_ap_zero _ _ _ (nring_ap_zero' _ _ Hn) (nring_ap_zero' _ _ H0))). apply mult_wd. apply eq_symmetric_unfolded; apply nring_comm_mult. apply div_wd. algebra. apply eq_symmetric_unfolded; apply nring_comm_mult. rewrite Hk. apply Nat.mul_le_mono_r; assumption. apply Hm. rewrite Hk. rewrite <- H0. auto. Qed. (** %\begin{convention}% Assume [m,n] are positive natural numbers and denote by [P] and [Q] the even partitions with, respectively, [m] and [n] points. %\end{convention}% Even partitions always have a common refinement. *) Variables m n : nat. Hypothesis Hm : 0 <> m. Hypothesis Hn : 0 <> n. (* begin hide *) Let P := Even_Partition Hab m Hm. Let Q := Even_Partition Hab n Hn. (* end hide *) Lemma even_partition_refinement : {N : nat | {HN : 0 <> N | Refinement P (Even_Partition Hab N HN) | Refinement Q (Even_Partition Hab N HN)}}. Proof. exists (m * n). cut (0 <> m * n); intro. exists H. unfold P in |- *; apply refinement_resp_mult. exists n; auto. unfold Q in |- *; apply refinement_resp_mult. exists m; auto with arith. clear P Q. cut (nring (R:=IR) (m * n) [#] [0]). rewrite <- H; simpl in |- *. apply ap_irreflexive_unfolded. astepl (nring m[*]nring (R:=IR) n). apply mult_resp_ap_zero; apply Greater_imp_ap; astepl (nring (R:=IR) 0); apply nring_less; apply Nat.neq_0_lt_0; auto. Qed. End Even_Partitions. Section More_Definitions. (** ** Separation Some auxiliary definitions. A partition is said to be separated if all its points are distinct. *) Variables a b : IR. Hypothesis Hab : a [<=] b. Definition _Separated n (P : Partition Hab n) := forall i Hi H', P i Hi [<] P (S i) H'. (** Two partitions are said to be (mutually) separated if they are both separated and all their points are distinct (except for the endpoints). %\begin{convention}% Let [P,Q] be partitions of [I] with, respectively, [n] and [m] points. %\end{convention}% *) Variables n m : nat. Variable P : Partition Hab n. Variable Q : Partition Hab m. Definition Separated := _Separated _ P and _Separated _ Q and (forall i j, 0 < i -> 0 < j -> i < n -> j < m -> forall Hi Hj, P i Hi [#] Q j Hj). End More_Definitions. Arguments _Separated [a b Hab n]. Arguments Separated [a b Hab n m]. Section Sep_Partitions. Variables a b : IR. (* begin hide *) Let I := compact a b. (* end hide *) Hypothesis Hab : a [<=] b. (** The antimesh of a separated partition is always positive. *) Lemma pos_AntiMesh : forall n (P : Partition Hab n), 0 < n -> _Separated P -> [0] [<] AntiMesh P. Proof. intro; case n; clear n. intros P H H0; exfalso; apply (Nat.lt_irrefl _ H). intros n P H H0. unfold AntiMesh in |- *. apply less_minlist. simpl in |- *; auto with arith. intros y H1. elim (Part_Mesh_List_lemma _ _ _ _ _ _ H1); intros i Hi. elim Hi; clear Hi; intros Hi Hi'. elim Hi'; clear Hi'; intros Hi' H'. eapply less_wdr. 2: apply eq_symmetric_unfolded; apply H'. apply shift_less_minus; astepl (P i Hi). apply H0. Qed. (** A partition can have only one point iff the endpoints of the interval are the same; moreover, if the partition is separated and the endpoints of the interval are the same then it must have one point. *) Lemma partition_length_zero : Partition Hab 0 -> a [=] b. Proof. intro H. Step_final (H 0 (Nat.le_0_l 0)). Qed. Lemma _Separated_imp_length_zero : forall n (P : Partition Hab n), _Separated P -> a [=] b -> 0 = n. Proof. intros n P H H0. cut (~ 0 <> n); [ auto with zarith | intro ]. cut (0 < n); [ intro | apply Nat.neq_0_lt_0; auto ]. cut (a [#] b). exact (eq_imp_not_ap _ _ _ H0). astepl (P _ (Nat.le_0_l _)). astepr (P _ (le_n _)). apply less_imp_ap. apply local_mon_imp_mon_le with (f := fun (i : nat) (H : i <= n) => P i H). exact H. assumption. Qed. Lemma partition_less_imp_gt_zero : forall n (P : Partition Hab n), a [<] b -> 0 < n. Proof. intros n P H. cut (0 <> n); intro. apply Nat.neq_0_lt_0; auto. exfalso. cut (a [=] b). intro; apply less_irreflexive_unfolded with (x := a). astepr b; assumption. apply partition_length_zero. rewrite H0; apply P. Qed. End Sep_Partitions. corn-8.20.0/ftc/RefLemma.v000066400000000000000000001110101473720167500152030ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.RefSeparating. Require Export CoRN.ftc.RefSeparated. Require Export CoRN.ftc.RefSepRef. Section Refinement_Lemma. (** * The Refinement Lemmas Here we resume the results proved in four different files. The aim is to prove the following result (last part of Theorem 2.9 of Bishop 1967): %\noindent\textbf{%##Theorem##%}% Let [f] be a continuous function on a compact interval [[a,b]] with modulus of continuity%\footnote{%# (#From our point of view, the modulus of continuity is simply the proof that [f] is continuous.#)#%}% [lia]. Let [P] be a partition of [[a,b]] and [eps [>] [0]] be such that [mesh(P) [<] lia(eps)]. Then %\[\left|S(f,P)-\int_a^bf(x)dx\right|\leq\varepsilon(b-a),\]%#|S(f,P)-∫f(x)dx|≤ε(b-a)# where [S(f,P)] denotes any sum of the function [f] respecting the partition [P] (as previously defined). The proof of this theorem relies on the fact that for any two partitions [P] and [R] of [[a,b]] it is possible to define a partition [Q] which is ``almost'' a common refinement of [P] and [R]---that is, given [eps [>] [0]] it is possible to define [Q] such that for every point [x] of either [P] or [R] there is a point [y] of [Q] such that [|x[-]y| [<] eps]. This requires three separate constructions (done in three separate files) which are then properly combined to give the final result. We recommend the reader to ignore this technical constructions. First we prove that if [P] and [R] are both separated (though not necessarily separated from each other) then we can define a partition [P'] arbitrarily close to [P] (that is, such that given [alpha [>] [0]] and [xi [>] [0]] [P'] satisfies both [mesh(P') [<] mesh(P) [+] xi] and for every choice of points [x_i] respecting [P] there is a choice of points [x'_i] respecting [P'] such that [|S(f,P)-S(f,P')| [<] alpha]) that is separated from [R]. Then we prove that given any partition [P] and assuming [a [#] b] we can define a partition [P'] arbitrarily close to [P] (in the same sense as above) which is separated. Finally we prove that every two separated partitions [P] and [R] have a common refinement---as every two points in [P] and [R] are apart, we can decide which one is smaller. We use here the technical results about ordering that we proved in the file [IntegralLemmas.v]. Using the results from these files, we prove our main lemma in several steps (and versions). %\begin{convention}% Throughout this section: - [a,b:IR] and [I] denotes [[a,b]]; - [F] is a partial function continuous in [I]. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis incF : included (Compact Hab) (Dom F). (* begin hide *) Let contF' := contin_prop _ _ _ _ contF. (* end hide *) Section First_Refinement_Lemma. (** This is the first part of the proof of Theorem 2.9. %\begin{convention}% - [P, Q] are partitions of [I] with, respectively, [n] and [m] points; - [Q] is a refinement of [P]; - [e] is a positive real number; - [d] is the modulus of continuity of [F] for [e]; - the mesh of [P] is less or equal to [d]; - [fP] and [fQ] are choices of points respecting the partitions [P] and [Q], respectively. %\end{convention}% *) Variable e : IR. Hypothesis He : [0] [<] e. (* begin hide *) Let d := proj1_sig2T _ _ _ (contF' e He). (* end hide *) Variables m n : nat. Variable P : Partition Hab n. Hypothesis HMesh : Mesh P [<=] d. Variable Q : Partition Hab m. Hypothesis Href : Refinement P Q. Variable fP : forall i : nat, i < n -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Variable fQ : forall i : nat, i < m -> IR. Hypothesis HfQ : Points_in_Partition Q fQ. Hypothesis HfQ' : nat_less_n_fun fQ. (* begin hide *) Let sub := proj1_sig2T _ _ _ Href. Lemma RL_sub_0 : sub 0 = 0. Proof. elim (proj2a_sig2T _ _ _ Href); auto. Qed. Lemma RL_sub_n : sub n = m. Proof. elim (proj2a_sig2T _ _ _ Href); intros. elim H0; auto. Qed. Lemma RL_sub_mon : forall i j : nat, i < j -> sub i < sub j. Proof. elim (proj2a_sig2T _ _ _ Href); intros. elim H0; intros. elim H1; auto. Qed. Lemma RL_sub_mon' : forall i j : nat, i <= j -> sub i <= sub j. Proof. intros. elim (le_lt_eq_dec _ _ H); intro. apply Nat.lt_le_incl; apply RL_sub_mon; assumption. rewrite b0; apply le_n. Qed. Lemma RL_sub_hyp : forall (i : nat) (H : i <= n), {H' : sub i <= m | P i H [=] Q (sub i) H'}. Proof. apply (proj2b_sig2T _ _ _ Href). Qed. Lemma RL_sub_S : forall i : nat, 0 < sub (S i). Proof. rewrite <- RL_sub_0. intro; apply RL_sub_mon; apply Nat.lt_0_succ. Qed. Let H : forall i j : nat, i < n -> j <= pred (sub (S i)) -> j < m. Proof. intros. cut (S i <= n); [ intro | apply H ]. elim (le_lt_eq_dec _ _ H1); clear H1; intro. cut (sub (S i) < sub n); [ intro | apply RL_sub_mon; assumption ]. rewrite <- RL_sub_n. apply Nat.le_lt_trans with (sub (S i)); auto; eapply Nat.le_trans; [ apply H0 | apply Nat.le_pred_l ]. cut (0 < sub (S i)); [ intro | apply RL_sub_S ]. rewrite <- RL_sub_n. rewrite <- b0. rewrite <- (Nat.lt_succ_pred _ _ H1); auto with arith. Qed. Let H' : forall i j : nat, i < n -> j <= pred (sub (S i)) -> S j <= m. Proof. intros; exact (H _ _ H0 H1). Qed. Let H0 : forall i : nat, sub i < sub (S i). Proof. intro; apply RL_sub_mon; apply Nat.lt_succ_diag_r. Qed. Lemma RL_sub_SS : forall i : nat, sub i <= S (pred (sub (S i))). Proof. intro; cut (sub i < sub (S i)); [ intro | apply H0 ]. rewrite (Nat.lt_succ_pred _ _ H1); apply Nat.lt_le_incl; apply H0. Qed. Definition RL_h : nat -> IR. Proof. intro i. elim (le_lt_dec i m); intro. apply (Q _ a0). apply ZeroR. Defined. Definition RL_g : nat -> IR. Proof. intro i. elim (le_lt_dec m i); intro. apply ZeroR. apply (Q _ b0[-]Q _ (Nat.lt_le_incl _ _ b0)). Defined. Notation g := RL_g. Notation h := RL_h. Lemma ref_calc1 : forall (i : nat) (Hi : i < n), Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))) [=] P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi). Proof. intros. unfold Sum2 in |- *. elim (RL_sub_hyp (S i) Hi); intros P1 HP1. elim (RL_sub_hyp i (Nat.lt_le_incl _ _ Hi)); intros P2 HP2. apply eq_transitive_unfolded with (Q _ P1[-]Q _ P2). 2: apply eq_symmetric_unfolded; apply cg_minus_wd; [ apply HP1 | apply HP2 ]. cut (sub (S i) = S (pred (sub (S i)))). 2: symmetry; apply Nat.lt_succ_pred with 0; apply RL_sub_S. intro. generalize P1 HP1; clear HP1 P1. pattern (sub (S i)) at 1 2 11 in |- *. rewrite H1; intros. eapply eq_transitive_unfolded. apply str_Mengolli_Sum_gen with (f := h). apply RL_sub_SS. intros j Hj Hj'. elim (le_lt_dec j (pred (sub (S i)))); intro; simpl in |- *. elim (le_lt_dec (sub i) j); intro; simpl in |- *. unfold h in |- *. apply cg_minus_wd. elim (le_lt_dec (S j) m); intro; simpl in |- *. apply prf1; auto. cut (S j <= m); [ intro | apply H' with i; assumption ]. exfalso; apply (proj1 (Nat.le_ngt _ _) H2 b0). elim (le_lt_dec j m); intro; simpl in |- *. apply prf1; auto. cut (j < m); [ intro | apply H with i; assumption ]. exfalso; apply Nat.le_ngt with m j; auto with arith. exfalso; apply Nat.le_ngt with (sub i) j; auto with arith. exfalso; apply (proj1 (Nat.le_ngt _ _) Hj' b0). unfold h in |- *. apply cg_minus_wd. elim (le_lt_dec (S (pred (sub (S i)))) m); intro; simpl in |- *. apply prf1; auto. exfalso. apply (proj1 (Nat.le_ngt _ _) P1 b0). elim (le_lt_dec (sub i) m); intro; simpl in |- *. apply prf1; auto. exfalso. apply (proj1 (Nat.le_ngt _ _) P2 b0). Qed. Notation just1 := (incF _ (Pts_part_lemma _ _ _ _ _ _ HfP _ _)). Notation just2 := (incF _ (Pts_part_lemma _ _ _ _ _ _ HfQ _ _)). Lemma ref_calc2 : AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfQ incF) [=] AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Part F (fP i Hi) just1[*] Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))) [-] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fQ j (H _ _ Hi Hj')) just2[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))). Proof. apply AbsIR_wd; unfold Partition_Sum in |- *. apply cg_minus_wd. apply Sumx_wd; intros. apply mult_wdr. apply eq_symmetric_unfolded; apply ref_calc1. apply eq_symmetric_unfolded; unfold Sum2 in |- *. apply eq_transitive_unfolded with (Sumx (fun (j : nat) (Hj : j < m) => part_tot_nat_fun _ _ (fun (i : nat) (H : i < m) => Part F (fQ i H) just2[*] (Q _ H[-]Q _ (Nat.lt_le_incl _ _ H))) j)). apply str_Sumx_Sum_Sum with (g := fun (i : nat) (Hi : i < n) (i0 : nat) => sumbool_rect (fun _ : {sub i <= i0} + {i0 < sub i} => IR) (fun _ : sub i <= i0 => sumbool_rect (fun _ : {i0 <= pred (sub (S i))} + {pred (sub (S i)) < i0} => IR) (fun a1 : i0 <= pred (sub (S i)) => Part F (fQ i0 (H i i0 Hi a1)) just2[*] (Q (S i0) (H' i i0 Hi a1) [-] Q i0 (Nat.lt_le_incl i0 m (H i i0 Hi a1)))) (fun _ : pred (sub (S i)) < i0 => [0]) (le_lt_dec i0 (pred (sub (S i))))) (fun _ : i0 < sub i => [0]) (le_lt_dec (sub i) i0)) (h := part_tot_nat_fun _ _ (fun (i : nat) (H : i < m) => Part F (fQ i H) just2[*] (Q _ H[-]Q _ (Nat.lt_le_incl _ _ H)))). exact RL_sub_0. exact RL_sub_mon. intros. elim (le_lt_dec (sub i) j); intro; simpl in |- *. elim (le_lt_dec j (pred (sub (S i)))); intro; simpl in |- *. unfold part_tot_nat_fun in |- *. elim (le_lt_dec m j); intro; simpl in |- *. exfalso. cut (0 < sub (S i)); [ intro | apply RL_sub_S ]. cut (sub (S i) <= m); intros. apply (proj1 (Nat.le_ngt _ _) H4); apply Nat.le_lt_trans with j; auto. rewrite <- RL_sub_n. apply RL_sub_mon'; apply Hi. apply mult_wd. apply pfwdef. apply HfQ'; auto. apply cg_minus_wd; apply prf1; auto. exfalso; apply (proj1 (Nat.le_ngt _ _) b0). rewrite (Nat.lt_succ_pred _ _ (RL_sub_S i)); auto. exfalso; apply (proj1 (Nat.le_ngt _ _) H1 b0). symmetry in |- *; apply RL_sub_n. apply Sumx_wd; intros. unfold part_tot_nat_fun in |- *. elim (le_lt_dec m i); intro; simpl in |- *. exfalso; apply Nat.le_ngt with m i; auto. apply mult_wd. apply pfwdef; apply HfQ'; auto. apply cg_minus_wd; apply prf1; auto. Qed. Lemma ref_calc3 : AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Part F (fP i Hi) just1[*] Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))) [-] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fQ j (H _ _ Hi Hj')) just2[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))) [=] AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fP i Hi) just1[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))))) [-] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fQ j (H _ _ Hi Hj')) just2[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))). Proof. apply AbsIR_wd. apply cg_minus_wd; apply Sumx_wd; intros. apply eq_symmetric_unfolded; apply Sum2_comm_scal' with (f := fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Q (S j) (H' _ _ H1 Hj') [-]Q j (Nat.lt_le_incl _ _ (H _ _ H1 Hj'))). apply RL_sub_SS. algebra. Qed. Lemma ref_calc4 : AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fP i Hi) just1[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))))) [-] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fQ j (H _ _ Hi Hj')) just2[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))) [=] AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fP i Hi) just1[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))) [-] Part F (fQ j (H _ _ Hi Hj')) just2[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))). Proof. apply AbsIR_wd. eapply eq_transitive_unfolded. apply Sumx_minus_Sumx. apply Sumx_wd; intros. eapply eq_transitive_unfolded. apply Sum2_minus_Sum2. apply RL_sub_SS. algebra. Qed. Lemma ref_calc5 : AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Part F (fP i Hi) just1[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))) [-] Part F (fQ j (H _ _ Hi Hj')) just2[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))) [=] AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => (Part F (fP i Hi) just1[-]Part F (fQ j (H _ _ Hi Hj')) just2) [*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))). Proof. apply AbsIR_wd; apply Sumx_wd; intros. apply Sum2_wd; intros. apply RL_sub_SS. algebra. Qed. Lemma ref_calc6 : AbsIR (Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => (Part F (fP i Hi) just1[-]Part F (fQ j (H _ _ Hi Hj')) just2) [*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))) [<=] Sumx (fun (i : nat) (Hi : i < n) => AbsIR (Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => (Part F (fP i Hi) just1[-]Part F (fQ j (H _ _ Hi Hj')) just2) [*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))). Proof. eapply leEq_wdr. apply triangle_SumxIR. apply Sumx_wd. intros. apply AbsIR_wd. apply Sum2_wd. apply RL_sub_SS. intros j Hj Hj'. algebra. Qed. Lemma ref_calc7 : Sumx (fun (i : nat) (Hi : i < n) => AbsIR (Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => (Part F (fP i Hi) just1[-]Part F (fQ j (H _ _ Hi Hj')) just2) [*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))) [<=] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => AbsIR ((Part F (fP i Hi) just1[-]Part F (fQ j (H _ _ Hi Hj')) just2) [*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))). Proof. apply Sumx_resp_leEq; intros. eapply leEq_wdr. apply triangle_Sum2IR. apply RL_sub_SS. algebra. Qed. Lemma ref_calc8 : Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => AbsIR ((Part F (fP i Hi) just1[-]Part F (fQ j (H _ _ Hi Hj')) just2) [*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj')))))) [<=] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => e[*] (Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))))). Proof. apply Sumx_resp_leEq; intros. apply Sum2_resp_leEq. apply RL_sub_SS. intros j Hj Hj'. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both. apply AbsIR_nonneg. apply AbsIR_nonneg. generalize (proj2b_sig2T _ _ _ (contF' e He)); fold d in |- *; intros. apply H2. unfold I in |- *; apply Pts_part_lemma with n P; assumption. unfold I in |- *; apply Pts_part_lemma with m Q; assumption. apply leEq_transitive with (Mesh P). 2: assumption. apply leEq_transitive with (AbsIR (P (S i) H1[-]P i (Nat.lt_le_incl _ _ H1))). 2: eapply leEq_wdl. 3: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply Mesh_lemma. 2: apply shift_leEq_minus; astepl (P i (Nat.lt_le_incl _ _ H1)); apply prf2. apply compact_elements with (prf2 _ _ _ _ P i (Nat.lt_le_incl _ _ H1) H1). apply HfP. elim (HfQ j (H _ _ H1 Hj')); intros. split. elim (RL_sub_hyp i (Nat.lt_le_incl _ _ H1)); intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply p. apply leEq_transitive with (Q j (Nat.lt_le_incl _ _ (H i j H1 Hj'))). apply Partition_mon; assumption. assumption. elim (RL_sub_hyp (S i) H1); intros. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply p. apply leEq_transitive with (Q _ (H i j H1 Hj')). assumption. apply Partition_mon. rewrite <- (Nat.lt_succ_pred _ _ (RL_sub_S i)); auto with arith. apply eq_imp_leEq; apply AbsIR_eq_x. apply shift_leEq_minus; astepl (Q j (Nat.lt_le_incl _ _ (H _ _ H1 Hj'))); apply prf2. Qed. (* end hide *) Lemma first_refinement_lemma : AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfQ incF) [<=] e[*] (b[-]a). Proof. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply ref_calc2. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply ref_calc3. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply ref_calc4. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply ref_calc5. eapply leEq_transitive. apply ref_calc6. eapply leEq_transitive. apply ref_calc7. eapply leEq_transitive. apply ref_calc8. apply leEq_wdl with (e[*] Sumx (fun (i : nat) (Hi : i < n) => Sum2 (fun (j : nat) (Hj : sub i <= j) (Hj' : j <= pred (sub (S i))) => Q _ (H' _ _ Hi Hj') [-]Q _ (Nat.lt_le_incl _ _ (H _ _ Hi Hj'))))). apply mult_resp_leEq_lft. 2: apply less_leEq; assumption. apply leEq_wdl with (Sumx (fun (i : nat) (Hi : i < n) => P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))). 2: apply Sumx_wd; intros. 2: apply eq_symmetric_unfolded; apply ref_calc1. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= n) => P i Hi). eapply leEq_transitive. apply leEq_AbsIR. eapply leEq_wdr. 2: apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl a; assumption. apply compact_elements with Hab; apply Partition_in_compact. red in |- *; intros; apply prf1; auto. intros; apply cg_minus_wd; apply prf1; auto. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply Sumx_comm_scal'. apply Sumx_wd; intros. eapply eq_transitive_unfolded. 2: apply Sum2_comm_scal'. algebra. apply RL_sub_SS. Qed. End First_Refinement_Lemma. Section Second_Refinement_Lemma. (** This is inequality (2.6.7). %\begin{convention}% - [P, Q, R] are partitions of [I] with, respectively, [j, n] and [k] points; - [Q] is a common refinement of [P] and [R]; - [e, e'] are positive real numbers; - [d, d'] are the moduli of continuity of [F] for [e, e']; - the Mesh of [P] is less or equal to [d]; - the Mesh of [R] is less or equal to [d']; - [fP, fQ] and [fR] are choices of points respecting the partitions [P, Q] and [R], respectively. %\end{convention}% *) Variables n j k : nat. Variable P : Partition Hab j. Variable Q : Partition Hab n. Variable R : Partition Hab k. Hypothesis HrefP : Refinement P Q. Hypothesis HrefR : Refinement R Q. Variables e e' : IR. Hypothesis He : [0] [<] e. Hypothesis He' : [0] [<] e'. (* begin hide *) Let d := proj1_sig2T _ _ _ (contF' e He). Let d' := proj1_sig2T _ _ _ (contF' e' He'). (* end hide *) Hypothesis HMeshP : Mesh P [<=] d. Hypothesis HMeshR : Mesh R [<=] d'. Variable fP : forall i : nat, i < j -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Variable fR : forall i : nat, i < k -> IR. Hypothesis HfR : Points_in_Partition R fR. Hypothesis HfR' : nat_less_n_fun fR. Lemma second_refinement_lemma : AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfR incF) [<=] e[*] (b[-]a) [+]e'[*] (b[-]a). Proof. set (HfQ := Partition_imp_points_1 _ _ _ _ Q) in *. set (H' := Partition_imp_points_2 _ _ _ _ Q) in *. apply leEq_wdl with (AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfQ incF[+] (Partition_Sum HfQ incF[-]Partition_Sum HfR incF))). 2: apply AbsIR_wd; rational. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. apply first_refinement_lemma with He; assumption. eapply leEq_wdl. 2: apply AbsIR_minus. apply first_refinement_lemma with He'; assumption. Qed. End Second_Refinement_Lemma. Section Third_Refinement_Lemma. (** This is an approximation of inequality (2.6.7), but without assuming the existence of a common refinement of [P] and [R]. %\begin{convention}% - [P, R] are partitions of [I] with, respectively, [n] and [m] points; - [e, e'] are positive real numbers; - [d, d'] are the moduli of continuity of [F] for [e, e']; - the Mesh of [P] is less than [d]; - the Mesh of [R] is less than [d']; - [fP] and [fR] are choices of points respecting the partitions [P] and [R], respectively; - [beta] is a positive real number. %\end{convention}% *) Variables n m : nat. Variable P : Partition Hab n. Variable R : Partition Hab m. Variables e e' : IR. Hypothesis He : [0] [<] e. Hypothesis He' : [0] [<] e'. (* begin hide *) Let d := proj1_sig2T _ _ _ (contF' e He). Let d' := proj1_sig2T _ _ _ (contF' e' He'). (* end hide *) Hypothesis HMeshP : Mesh P [<] d. Hypothesis HMeshR : Mesh R [<] d'. Variable fP : forall i : nat, i < n -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Variable fR : forall i : nat, i < m -> IR. Hypothesis HfR : Points_in_Partition R fR. Hypothesis HfR' : nat_less_n_fun fR. Hypothesis Hab' : a [<] b. Variable beta : IR. Hypothesis Hbeta : [0] [<] beta. (* begin hide *) Let alpha := beta [/]ThreeNZ. Lemma RL_alpha : [0] [<] alpha. Proof. unfold alpha in |- *; apply pos_div_three; assumption. Qed. Let csi1 := Min (b[-]a) ((d[-]Mesh P) [/]TwoNZ). Lemma RL_csi1 : [0] [<] csi1. Proof. unfold csi1 in |- *; apply less_Min. apply shift_less_minus; astepl a; assumption. apply pos_div_two. apply shift_less_minus. astepl (Mesh P); assumption. Qed. Let delta1 := Min csi1 (alpha[/] _[//] mult_resp_ap_zero IR _ _ (nring_ap_zero _ n (SPap_n _ _ _ Hab' _ P)) (max_one_ap_zero (Norm_Funct contF))). Lemma RL_delta1 : delta1 [/]TwoNZ [<] b[-]a. Proof. apply shift_div_less'. apply pos_two. apply leEq_less_trans with (b[-]a). unfold delta1 in |- *; clear delta1. apply leEq_transitive with csi1. apply Min_leEq_lft. unfold csi1 in |- *. apply Min_leEq_lft. astepl ([0][+] (b[-]a)); rstepr (b[-]a[+] (b[-]a)). apply plus_resp_less_rht. apply shift_less_minus; astepl a; assumption. Qed. Let P' := sep__part _ _ _ F contF Hab' _ P _ RL_alpha _ RL_csi1 RL_delta1. Lemma RL_P'_sep : _Separated P'. Proof. red in |- *; intros. unfold P' in |- *; apply sep__part_mon. Qed. Lemma RL_P'_Mesh : Mesh P' [<] d. Proof. unfold P' in |- *. eapply leEq_less_trans. apply sep__part_mon_Mesh. unfold csi1 in |- *. apply shift_plus_less'; eapply leEq_less_trans. apply Min_leEq_rht. apply pos_div_two'. apply shift_less_minus. astepl (Mesh P); assumption. Qed. Let fP' := sep__part_pts _ _ _ F contF Hab' _ P _ RL_alpha _ RL_csi1 fP. Lemma RL_fP'_in_P' : Points_in_Partition P' fP'. Proof. unfold fP', P' in |- *; apply sep__part_pts_in_Partition. assumption. Qed. Lemma RL_P'_P_sum : AbsIR (Partition_Sum HfP incF[-]Partition_Sum RL_fP'_in_P' incF) [<=] alpha. Proof. apply leEq_wdl with (AbsIR (Partition_Sum HfP incF[-] Partition_Sum (sep__part_pts_in_Partition _ _ _ F contF Hab' _ P _ RL_alpha _ RL_csi1 RL_delta1 _ HfP) incF)). apply sep__part_Sum. assumption. apply AbsIR_wd; apply cg_minus_wd. algebra. unfold Partition_Sum in |- *; apply Sumx_wd; intros. algebra. Qed. Let csi2 := Min (b[-]a) ((d'[-]Mesh R) [/]TwoNZ). Lemma RL_csi2 : [0] [<] csi2. Proof. unfold csi2 in |- *; apply less_Min. apply shift_less_minus; astepl a; assumption. apply pos_div_two. apply shift_less_minus. astepl (Mesh R); assumption. Qed. Let delta2 := Min csi2 (alpha[/] _[//] mult_resp_ap_zero IR _ _ (nring_ap_zero _ m (SPap_n _ _ _ Hab' _ R)) (max_one_ap_zero (Norm_Funct contF))). Lemma RL_delta2 : delta2 [/]TwoNZ [<] b[-]a. Proof. apply shift_div_less'. apply pos_two. apply leEq_less_trans with (b[-]a). unfold delta2 in |- *; clear delta2. apply leEq_transitive with csi2. apply Min_leEq_lft. unfold csi2 in |- *. apply Min_leEq_lft. astepl ([0][+] (b[-]a)); rstepr (b[-]a[+] (b[-]a)). apply plus_resp_less_rht. apply shift_less_minus; astepl a; assumption. Qed. Let R' := sep__part _ _ _ F contF Hab' _ R _ RL_alpha _ RL_csi2 RL_delta2. Lemma RL_R'_sep : _Separated R'. Proof. red in |- *; intros. unfold R' in |- *; apply sep__part_mon. Qed. Lemma RL_R'_Mesh : Mesh R' [<] d'. Proof. unfold R' in |- *. eapply leEq_less_trans. apply sep__part_mon_Mesh. unfold csi2 in |- *. apply shift_plus_less'; eapply leEq_less_trans. apply Min_leEq_rht. apply pos_div_two'. apply shift_less_minus. astepl (Mesh R); assumption. Qed. Let fR' := sep__part_pts _ _ _ F contF Hab' _ R _ RL_alpha _ RL_csi2 fR. Lemma RL_fR'_in_R' : Points_in_Partition R' fR'. Proof. unfold fR', R' in |- *; apply sep__part_pts_in_Partition. assumption. Qed. Lemma RL_R'_R_sum : AbsIR (Partition_Sum HfR incF[-]Partition_Sum RL_fR'_in_R' incF) [<=] alpha. Proof. apply leEq_wdl with (AbsIR (Partition_Sum HfR incF[-] Partition_Sum (sep__part_pts_in_Partition _ _ _ F contF Hab' _ R _ RL_alpha _ RL_csi2 RL_delta2 _ HfR) incF)). apply sep__part_Sum. assumption. apply AbsIR_wd; apply cg_minus_wd. algebra. unfold Partition_Sum in |- *; apply Sumx_wd; intros. algebra. Qed. Let csi3 := d[-]Mesh P'. Lemma RL_csi3 : [0] [<] csi3. Proof. unfold csi3 in |- *. apply shift_less_minus; astepl (Mesh P'). apply RL_P'_Mesh. Qed. Let Q := sep__sep_part _ _ _ F contF Hab' _ _ _ _ RL_P'_sep RL_R'_sep _ RL_alpha _ RL_csi3. Lemma RL_Q_Mesh : Mesh Q [<=] d. Proof. unfold Q in |- *; eapply leEq_wdr. apply sep__sep_Mesh. unfold csi3 in |- *; rational. Qed. Lemma RL_Q_sep : Separated Q R'. Proof. unfold Q in |- *; apply sep__sep_lemma. Qed. Let fQ := sep__sep_points _ _ _ F contF Hab' _ _ _ _ RL_P'_sep RL_R'_sep _ RL_alpha _ RL_csi3 fP'. Lemma RL_fQ_in_Q : Points_in_Partition Q fQ. Proof. unfold Q, fQ in |- *; apply sep__sep_points_lemma. apply RL_fP'_in_P'. Qed. Lemma RL_Q_P'_sum : AbsIR (Partition_Sum RL_fP'_in_P' incF[-]Partition_Sum RL_fQ_in_Q incF) [<=] alpha. Proof. apply leEq_wdl with (AbsIR (Partition_Sum RL_fP'_in_P' incF[-] Partition_Sum (sep__sep_points_lemma _ _ _ F contF Hab' _ _ _ _ RL_P'_sep RL_R'_sep _ RL_alpha _ RL_csi3 _ RL_fP'_in_P') incF)). unfold Q, fQ in |- *; apply sep__sep_Sum. apply AbsIR_wd. unfold Partition_Sum in |- *; apply cg_minus_wd. algebra. apply Sumx_wd; intros. algebra. Qed. (* end hide *) Lemma third_refinement_lemma : AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfR incF) [<=] e[*] (b[-]a) [+]e'[*] (b[-]a) [+]beta. Proof. apply leEq_wdl with (AbsIR (Partition_Sum HfP incF[-]Partition_Sum RL_fP'_in_P' incF[+] (Partition_Sum RL_fP'_in_P' incF[-]Partition_Sum RL_fQ_in_Q incF) [+] (Partition_Sum RL_fQ_in_Q incF[-]Partition_Sum RL_fR'_in_R' incF) [+] (Partition_Sum RL_fR'_in_R' incF[-]Partition_Sum HfR incF))). apply leEq_wdr with (alpha[+]alpha[+] (e[*] (b[-]a) [+]e'[*] (b[-]a)) [+]alpha). 2: unfold alpha in |- *; rational. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq_both. apply RL_P'_P_sum. apply RL_Q_P'_sum. 2: eapply leEq_wdl. 3: apply AbsIR_minus. 2: apply RL_R'_R_sum. 2: apply AbsIR_wd; rational. eapply second_refinement_lemma with (Q := Separated_Refinement _ _ _ _ _ _ _ RL_Q_sep) (He := He) (He' := He'). apply Separated_Refinement_lft. apply Separated_Refinement_rht. apply RL_Q_Mesh. apply less_leEq; apply RL_R'_Mesh. Qed. End Third_Refinement_Lemma. Section Fourth_Refinement_Lemma. (* begin hide *) Let Fa := Part F a (incF _ (compact_inc_lft a b Hab)). Notation just := (fun z => incF _ (Pts_part_lemma _ _ _ _ _ _ z _ _)). Lemma RL_sum_lemma_aux : forall (n : nat) (P : Partition Hab n) fP (HfP : Points_in_Partition P fP), Partition_Sum HfP incF [=] Fa[*] (b[-]a) [-] Sumx (fun (i : nat) (Hi : i < n) => (Fa[-]Part F (fP i Hi) (just HfP)) [*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))). Proof. intros; apply eq_transitive_unfolded with (Sumx (fun (i : nat) (Hi : i < n) => Fa[*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))) [-] Sumx (fun (i : nat) (Hi : i < n) => (Fa[-]Part F (fP i Hi) (just HfP)) [*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi)))). eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Sumx_minus_Sumx. unfold Partition_Sum in |- *; apply Sumx_wd; intros. eapply eq_transitive_unfolded. 2: apply ring_distl_minus. apply mult_wdl. rstepr (Part F (fP i H) (just HfP)); algebra. apply cg_minus_wd. 2: algebra. astepr (Fa[*]b[-]Fa[*]a). eapply eq_transitive_unfolded. apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= n) => Fa[*]P i Hi). red in |- *; intros. apply mult_wdr. apply prf1; auto. intros; algebra. apply cg_minus_wd; apply mult_wdr. apply finish. apply start. Qed. (* end hide *) (** Finally, this is inequality (2.6.7) exactly as stated (same conventions as above) *) Variables n m : nat. Variable P : Partition Hab n. Variable R : Partition Hab m. Variables e e' : IR. Hypothesis He : [0] [<] e. Hypothesis He' : [0] [<] e'. (* begin hide *) Let d := proj1_sig2T _ _ _ (contF' e He). Let d' := proj1_sig2T _ _ _ (contF' e' He'). (* end hide *) Hypothesis HMeshP : Mesh P [<] d. Hypothesis HMeshR : Mesh R [<] d'. Variable fP : forall i : nat, i < n -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Variable fR : forall i : nat, i < m -> IR. Hypothesis HfR : Points_in_Partition R fR. Hypothesis HfR' : nat_less_n_fun fR. (* begin show *) Hypothesis Hab' : b[-]a [<] Min d d'. (* end show *) Lemma fourth_refinement_lemma : AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfR incF) [<=] e[*] (b[-]a) [+]e'[*] (b[-]a). Proof. generalize (proj2b_sig2T _ _ _ (contF' e He)); generalize (proj2a_sig2T _ _ _ (contF' e He)); fold d in |- *; intros Hd Hdd. generalize (proj2b_sig2T _ _ _ (contF' e' He')); generalize (proj2a_sig2T _ _ _ (contF' e' He')); fold d' in |- *; intros Hd' Hdd'. apply leEq_wdl with (AbsIR (Fa[*] (b[-]a) [-] Sumx (fun (i : nat) (Hi : i < n) => (Fa[-]Part F (fP i Hi) (just HfP)) [*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))) [-] (Fa[*] (b[-]a) [-] Sumx (fun (j : nat) (Hj : j < m) => (Fa[-]Part F (fR j Hj) (just HfR)) [*] (R _ Hj[-]R _ (Nat.lt_le_incl _ _ Hj)))))). 2: apply AbsIR_wd; apply eq_symmetric_unfolded. 2: apply cg_minus_wd; apply RL_sum_lemma_aux. apply leEq_wdl with (AbsIR (Sumx (fun (j : nat) (Hj : j < m) => (Fa[-]Part F (fR j Hj) (just HfR)) [*] (R _ Hj[-]R _ (Nat.lt_le_incl _ _ Hj))) [-] Sumx (fun (i : nat) (Hi : i < n) => (Fa[-]Part F (fP i Hi) (just HfP)) [*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))))). 2: apply AbsIR_wd; rational. rstepr (e'[*] (b[-]a) [+]e[*] (b[-]a)). eapply leEq_transitive. apply triangle_IR_minus. apply plus_resp_leEq_both. eapply leEq_transitive. apply triangle_SumxIR. apply leEq_wdr with (Sumx (fun (i : nat) (Hi : i < m) => e'[*] (R _ Hi[-]R _ (Nat.lt_le_incl _ _ Hi)))). apply Sumx_resp_leEq; intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. unfold Fa in |- *; apply Hdd'; unfold I in |- *. apply compact_inc_lft. apply Pts_part_lemma with m R; assumption. apply leEq_transitive with (AbsIR (b[-]a)). apply compact_elements with Hab. apply compact_inc_lft. apply Pts_part_lemma with m R; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl a; assumption. eapply leEq_transitive. apply less_leEq; apply Hab'. apply Min_leEq_rht. apply eq_imp_leEq; apply AbsIR_eq_x. apply shift_leEq_minus; astepl (R i (Nat.lt_le_incl _ _ H)); apply prf2. eapply eq_transitive_unfolded. apply Sumx_comm_scal' with (f := fun (i : nat) (Hi : i < m) => R _ Hi[-]R _ (Nat.lt_le_incl _ _ Hi)). apply mult_wdr. eapply eq_transitive_unfolded. apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= m) => R i Hi). red in |- *; intros. apply prf1; auto. intros; algebra. apply cg_minus_wd; [ apply finish | apply start ]. eapply leEq_transitive. apply triangle_SumxIR. apply leEq_wdr with (Sumx (fun (i : nat) (Hi : i < n) => e[*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi)))). apply Sumx_resp_leEq; intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. unfold Fa in |- *; apply Hdd; unfold I in |- *. apply compact_inc_lft. apply Pts_part_lemma with n P; assumption. apply leEq_transitive with (AbsIR (b[-]a)). apply compact_elements with Hab. apply compact_inc_lft. apply Pts_part_lemma with n P; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl a; assumption. eapply leEq_transitive. apply less_leEq; apply Hab'. apply Min_leEq_lft. apply eq_imp_leEq; apply AbsIR_eq_x. apply shift_leEq_minus; astepl (P i (Nat.lt_le_incl _ _ H)); apply prf2. eapply eq_transitive_unfolded. apply Sumx_comm_scal' with (f := fun (i : nat) (Hi : i < n) => P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi)). apply mult_wdr. eapply eq_transitive_unfolded. apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= n) => P i Hi). red in |- *; intros. apply prf1; auto. intros; algebra. apply cg_minus_wd; [ apply finish | apply start ]. Qed. End Fourth_Refinement_Lemma. Section Main_Refinement_Lemma. (** We finish by presenting Theorem 9. *) Variables n m : nat. Variable P : Partition Hab n. Variable R : Partition Hab m. Variables e e' : IR. Hypothesis He : [0] [<] e. Hypothesis He' : [0] [<] e'. (* begin hide *) Let d := proj1_sig2T _ _ _ (contF' e He). Let d' := proj1_sig2T _ _ _ (contF' e' He'). (* end hide *) Hypothesis HMeshP : Mesh P [<] d. Hypothesis HMeshR : Mesh R [<] d'. Variable fP : forall i : nat, i < n -> IR. Hypothesis HfP : Points_in_Partition P fP. Hypothesis HfP' : nat_less_n_fun fP. Variable fR : forall i : nat, i < m -> IR. Hypothesis HfR : Points_in_Partition R fR. Hypothesis HfR' : nat_less_n_fun fR. Lemma refinement_lemma : AbsIR (Partition_Sum HfP incF[-]Partition_Sum HfR incF) [<=] e[*] (b[-]a) [+]e'[*] (b[-]a). Proof. cut ([0] [<] Min d d'). intro H; elim (less_cotransitive_unfolded _ _ _ H (b[-]a)); intro. astepr (e[*] (b[-]a) [+]e'[*] (b[-]a) [+][0]). apply shift_leEq_plus'. apply approach_zero_weak. intros beta Hbeta. apply shift_minus_leEq. astepr (e[*] (b[-]a) [+]e'[*] (b[-]a) [+]beta). apply third_refinement_lemma with (He := He) (He' := He'); try assumption. astepl ([0][+]a); apply shift_plus_less; assumption. apply fourth_refinement_lemma with He He'. assumption. apply less_Min. unfold d in |- *; apply proj2a_sig2T. unfold d' in |- *; apply proj2a_sig2T. Qed. End Main_Refinement_Lemma. End Refinement_Lemma. corn-8.20.0/ftc/RefSepRef.v000066400000000000000000000562771473720167500153630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.ftc.COrdLemmas. Require Export CoRN.ftc.Partitions. From Coq Require Import Lia. Section Refining_Separated. Variables a b : IR. Hypothesis Hab : a[<=]b. Let I := compact a b Hab. Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis incF : included (compact a b Hab) (Dom F). Variables m n : nat. Variable P : Partition Hab n. Variable R : Partition Hab m. Hypothesis HPR : Separated P R. Lemma RSR_HP : _Separated P. Proof. elim HPR; intros; assumption. Qed. Lemma RSR_HP' : a[=]b -> 0 = n. Proof. intro. apply _Separated_imp_length_zero with (P := P). exact RSR_HP. assumption. Qed. Lemma RSR_HR : _Separated R. Proof. elim HPR; intros. elim b0; intros; assumption. Qed. Lemma RSR_HR' : a[=]b -> 0 = m. Proof. intro. apply _Separated_imp_length_zero with (P := R). exact RSR_HR. assumption. Qed. Lemma RSR_mn0 : 0 = m -> 0 = n. Proof. intro; apply RSR_HP'; apply partition_length_zero with Hab. rewrite H; apply R. Qed. Lemma RSR_nm0 : 0 = n -> 0 = m. Proof. intro; apply RSR_HR'; apply partition_length_zero with Hab. rewrite H; apply P. Qed. Lemma RSR_H' : forall i j : nat, 0 < i -> 0 < j -> i < n -> j < m -> forall (Hi : i <= n) (Hj : j <= m), P i Hi[#]R j Hj. Proof. elim HPR; do 2 intro. elim b0; do 2 intro; assumption. Qed. Let f' (i : nat) (H : i < pred n) := P _ (lt_8 _ _ H). Let g' (j : nat) (H : j < pred m) := R _ (lt_8 _ _ H). Lemma RSR_f'_nlnf : nat_less_n_fun f'. Proof. red in |- *; intros; unfold f' in |- *; apply prf1; auto. Qed. Lemma RSR_g'_nlnf : nat_less_n_fun g'. Proof. red in |- *; intros; unfold g' in |- *; apply prf1; auto. Qed. Lemma RSR_f'_mon : forall (i i' : nat) Hi Hi', i < i' -> f' i Hi[<]f' i' Hi'. Proof. intros. apply local_mon_imp_mon_lt with (n := pred n). intros; unfold f' in |- *; apply RSR_HP. assumption. Qed. Lemma RSR_g'_mon : forall (j j' : nat) Hj Hj', j < j' -> g' j Hj[<]g' j' Hj'. Proof. intros. apply local_mon_imp_mon_lt with (n := pred m). intros; unfold g' in |- *; apply RSR_HR. assumption. Qed. Lemma RSR_f'_ap_g' : forall (i j : nat) Hi Hj, f' i Hi[#]g' j Hj. Proof. intros. unfold f', g' in |- *; apply RSR_H'. apply Nat.lt_0_succ. apply Nat.lt_0_succ. apply pred_lt; assumption. apply pred_lt; assumption. Qed. Let h := om_fun _ _ _ _ _ RSR_f'_ap_g'. Lemma RSR_h_nlnf : nat_less_n_fun h. Proof. unfold h in |- *; apply om_fun_1. exact RSR_f'_nlnf. exact RSR_g'_nlnf. Qed. Lemma RSR_h_mon : forall (i i' : nat) Hi Hi', i < i' -> h i Hi[<]h i' Hi'. Proof. unfold h in |- *; apply om_fun_2; auto. exact RSR_f'_nlnf. exact RSR_g'_nlnf. exact RSR_f'_mon. exact RSR_g'_mon. Qed. Lemma RSR_h_mon' : forall (i i' : nat) Hi Hi', i <= i' -> h i Hi[<=]h i' Hi'. Proof. intros; apply mon_imp_mon'_lt with (n := pred m + pred n). apply RSR_h_nlnf. apply RSR_h_mon. assumption. Qed. Lemma RSR_h_f' : forall (i : nat) Hi, {j : nat | {Hj : _ < _ | f' i Hi[=]h j Hj}}. Proof. unfold h in |- *; apply om_fun_3a; auto. exact RSR_f'_nlnf. exact RSR_g'_nlnf. Qed. Lemma RSR_h_g' : forall (j : nat) Hj, {i : nat | {Hi : _ < _ | g' j Hj[=]h i Hi}}. Proof. unfold h in |- *; apply om_fun_3b; auto. exact RSR_f'_nlnf. exact RSR_g'_nlnf. Qed. Lemma RSR_h_PropAll : forall P : IR -> Prop, pred_wd' IR P -> (forall (i : nat) Hi, P (f' i Hi)) -> (forall (j : nat) Hj, P (g' j Hj)) -> forall (k : nat) Hk, P (h k Hk). Proof. unfold h in |- *; apply om_fun_4b. Qed. Lemma RSR_h_PropEx : forall P : IR -> Prop, pred_wd' IR P -> {i : nat | {Hi : _ < _ | P (f' i Hi)}} or {j : nat | {Hj : _ < _ | P (g' j Hj)}} -> {k : nat | {Hk : _ < _ | P (h k Hk)}}. Proof. unfold h in |- *; intros; apply om_fun_4d; auto. exact RSR_f'_nlnf. exact RSR_g'_nlnf. Qed. Definition Separated_Refinement_fun : forall i : nat, i <= pred (m + n) -> IR. Proof. intros. elim (le_lt_eq_dec _ _ H); intro. elim (le_lt_dec i 0); intro. apply a. apply (h (pred i) (lt_10 _ _ _ b0 a0)). apply b. Defined. Lemma Separated_Refinement_lemma1 : forall i j : nat, i = j -> forall (Hi : i <= pred (m + n)) (Hj : j <= pred (m + n)), Separated_Refinement_fun i Hi[=]Separated_Refinement_fun j Hj. Proof. do 3 intro. rewrite <- H; intros; unfold Separated_Refinement_fun in |- *; simpl in |- *. elim (le_lt_eq_dec _ _ Hi); elim (le_lt_eq_dec _ _ Hj); elim (le_lt_dec i 0); intros; simpl in |- *. algebra. apply RSR_h_nlnf; reflexivity. exfalso; rewrite <- b0 in a1; apply (Nat.lt_irrefl _ a1). exfalso; rewrite <- b1 in a0; apply (Nat.lt_irrefl _ a0). exfalso; rewrite <- b0 in a1; apply (Nat.lt_irrefl _ a1). exfalso; rewrite <- b1 in a0; apply (Nat.lt_irrefl _ a0). algebra. algebra. Qed. Lemma Separated_Refinement_lemma3 : forall H : 0 <= pred (m + n), Separated_Refinement_fun 0 H[=]a. Proof. intros; unfold Separated_Refinement_fun in |- *; simpl in |- *. elim (le_lt_eq_dec _ _ H); elim (le_lt_dec 0 0); intros; simpl in |- *. algebra. exfalso; inversion b0. apply eq_symmetric_unfolded; apply partition_length_zero with Hab. cut (m + n <= 1); [ intro | lia ]. elim (plus_eq_one_imp_eq_zero _ _ H0); intro. rewrite <- a1; apply R. rewrite <- b1; apply P. exfalso; inversion b0. Qed. Lemma Separated_Refinement_lemma4 : forall H : pred (m + n) <= pred (m + n), Separated_Refinement_fun (pred (m + n)) H[=]b. Proof. intros; unfold Separated_Refinement_fun in |- *; simpl in |- *. elim (le_lt_eq_dec _ _ H); elim (le_lt_dec 0 0); intros; simpl in |- *. algebra. exfalso; apply (Nat.lt_irrefl _ a1). exfalso; apply (Nat.lt_irrefl _ a0). algebra. algebra. Qed. Lemma Separated_Refinement_lemma2 : forall (i : nat) (H : i <= pred (m + n)) (H' : S i <= pred (m + n)), Separated_Refinement_fun i H[<=]Separated_Refinement_fun (S i) H'. Proof. intros; unfold Separated_Refinement_fun in |- *; simpl in |- *. elim (le_lt_eq_dec _ _ H); elim (le_lt_eq_dec _ _ H'); intros; simpl in |- *. elim (le_lt_dec i 0); elim (le_lt_dec (S i) 0); intros; simpl in |- *. exfalso; inversion a2. apply RSR_h_PropAll with (P := fun x : IR => a[<=]x). red in |- *; intros. apply leEq_wdr with x; assumption. intros; unfold f' in |- *. astepl (P 0 (Nat.le_0_l _)). apply Partition_mon; apply Nat.le_0_l. intros; unfold g' in |- *. astepl (R 0 (Nat.le_0_l _)). apply Partition_mon; apply Nat.le_0_l. exfalso; inversion a2. apply less_leEq; apply RSR_h_mon; auto with arith. elim (le_lt_dec i 0); elim (le_lt_dec (S i) 0); intros; simpl in |- *. exfalso; inversion a1. assumption. exfalso; inversion a1. apply RSR_h_PropAll with (P := fun x : IR => x[<=]b). red in |- *; intros. apply leEq_wdl with x; assumption. intros; unfold f' in |- *. apply leEq_wdr with (P _ (le_n _)). apply Partition_mon; apply Nat.le_trans with (pred n); auto with arith. apply finish. intros; unfold g' in |- *. apply leEq_wdr with (R _ (le_n _)). apply Partition_mon; apply Nat.le_trans with (pred m); auto with arith. apply finish. exfalso; rewrite <- b0 in H'; apply (Nat.nle_succ_diag_l _ H'). apply leEq_reflexive. Qed. Definition Separated_Refinement : Partition Hab (pred (m + n)). Proof. apply Build_Partition with Separated_Refinement_fun. exact Separated_Refinement_lemma1. exact Separated_Refinement_lemma2. exact Separated_Refinement_lemma3. exact Separated_Refinement_lemma4. Defined. Definition RSR_auxP : nat -> nat. Proof. intro i. elim (le_lt_dec i 0); intro. apply 0. elim (le_lt_dec n i); intro. apply (pred (m + n) + (i - n)). apply (S (ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b1)))). Defined. Definition RSR_auxR : nat -> nat. Proof. intro i. elim (le_lt_dec i 0); intro. apply 0. elim (le_lt_dec m i); intro. apply (pred (m + n) + (i - m)). apply (S (ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b1)))). Defined. Lemma RSR_auxP_lemma0 : RSR_auxP 0 = 0. Proof. unfold RSR_auxP in |- *. elim (le_lt_dec 0 0); intro; simpl in |- *. reflexivity. exfalso; inversion b0. Qed. Lemma RSR_h_inj : forall (i j : nat) Hi Hj, h i Hi[=]h j Hj -> i = j. Proof. intros. eapply mon_imp_inj_lt with (f := h). exact RSR_h_mon. apply H. Qed. Lemma RSR_auxP_lemmai : forall (i : nat) (Hi : 0 < i) (Hi' : i < n), RSR_auxP i = S (ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ Hi Hi'))). Proof. intros. unfold RSR_auxP in |- *. elim (le_lt_dec n i); intro; simpl in |- *. exfalso; apply Nat.le_ngt with n i; auto. elim (le_lt_dec i 0); intro; simpl in |- *. exfalso; apply Nat.lt_irrefl with 0; apply Nat.lt_le_trans with i; auto. set (x := ProjT1 (RSR_h_f' _ (lt_pred' _ _ b1 b0))) in *. set (y := ProjT1 (RSR_h_f' _ (lt_pred' _ _ Hi Hi'))) in *. cut (x = y). intro; auto with arith. assert (H := ProjT2 (RSR_h_f' _ (lt_pred' _ _ b1 b0))). assert (H0 := ProjT2 (RSR_h_f' _ (lt_pred' _ _ Hi Hi'))). elim H; clear H; intros Hx Hx'. elim H0; clear H0; intros Hy Hy'. apply RSR_h_inj with Hx Hy. eapply eq_transitive_unfolded. 2: apply Hy'. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply Hx'. apply RSR_f'_nlnf; reflexivity. Qed. Lemma RSR_auxP_lemman : RSR_auxP n = pred (m + n). Proof. unfold RSR_auxP in |- *. elim (le_lt_dec n 0); intro; simpl in |- *. cut (n = 0); [ intro | auto with arith ]. transitivity (pred m). 2: rewrite H; auto. cut (0 = m); [ intro; rewrite <- H0; auto | apply RSR_HR' ]. apply partition_length_zero with Hab; rewrite <- H; apply P. elim (le_lt_dec n n); intro; simpl in |- *. rewrite Nat.sub_diag; auto. exfalso; apply Nat.lt_irrefl with n; auto. Qed. Lemma RSR_auxP_lemma1 : forall i j : nat, i < j -> RSR_auxP i < RSR_auxP j. Proof. intros; unfold RSR_auxP in |- *. assert (X:=not_not_lt); assert (X':=plus_pred_pred_plus). assert (X'':=RSR_mn0); assert (X''':=RSR_nm0). elim (le_lt_dec i 0); intro. elim (le_lt_dec j 0); intros; simpl in |- *. apply Nat.lt_le_trans with j; try apply Nat.le_lt_trans with i; auto with arith. elim (le_lt_dec n j); intros; simpl in |- *. lia. apply Nat.lt_0_succ. elim (le_lt_dec n i); elim (le_lt_dec j 0); intros; simpl in |- *. elim (Nat.lt_irrefl 0); apply Nat.lt_le_trans with j; try apply Nat.le_lt_trans with i; auto with arith. elim (le_lt_dec n j); intro; simpl in |- *. apply Nat.add_lt_mono_l. apply Nat.add_lt_mono_l with n. repeat (rewrite Nat.add_comm; rewrite Nat.sub_add); auto. lia; auto; apply Nat.lt_trans with j; auto. elim (Nat.lt_irrefl 0); apply Nat.lt_trans with i; auto; apply Nat.lt_le_trans with j; auto. elim (le_lt_dec n j); intro; simpl in |- *. apply Nat.lt_le_trans with (S (pred m + pred n)). apply -> Nat.succ_lt_mono. apply (ProjT1 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2)))). rewrite plus_n_Sm. rewrite Nat.lt_succ_pred with 0 n. 2: apply Nat.lt_trans with i; auto. replace (pred m + n) with (pred (m + n)). auto with arith. cut (S (pred (m + n)) = S (pred m + n)); auto. rewrite <- plus_Sn_m. rewrite <- (Nat.lt_succ_pred 0 m); auto with arith. apply Nat.neq_0_lt_0. intro. apply Nat.lt_irrefl with 0. apply Nat.lt_trans with i; auto. rewrite RSR_mn0; auto. apply -> Nat.succ_lt_mono. cut (~ ~ ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2)) < ProjT1 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3))); intro. apply not_not_lt; assumption. cut (ProjT1 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3)) <= ProjT1 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2))); intros. 2: apply not_lt; assumption. cut (h _ (ProjT1 (ProjT2 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3))))[<=] h _ (ProjT1 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2))))). intro. 2: apply RSR_h_mon'; assumption. cut (f' (pred j) (lt_pred' _ _ b1 b3)[<=]f' (pred i) (lt_pred' _ _ b0 b2)). 2: apply leEq_wdl with (h _ (ProjT1 (ProjT2 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3))))). 2: apply leEq_wdr with (h _ (ProjT1 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2))))). 2: assumption. 3: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_f' (pred j) (lt_pred' _ _ b1 b3)))). 2: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_f' (pred i) (lt_pred' _ _ b0 b2)))). clear H2 H1; intro. cut (f' _ (lt_pred' _ _ b0 b2)[<]f' _ (lt_pred' _ _ b1 b3)). 2: apply RSR_f'_mon. 2: apply lt_pred'; assumption. intro. exfalso. apply less_irreflexive_unfolded with (x := f' _ (lt_pred' _ _ b1 b3)). eapply leEq_less_trans; [ apply H1 | apply X0 ]. Qed. Lemma RSR_auxP_lemma2 : forall (i : nat) (H : i <= n), {H' : RSR_auxP i <= _ | P i H[=]Separated_Refinement _ H'}. Proof. intros. unfold Separated_Refinement in |- *; simpl in |- *. unfold Separated_Refinement_fun in |- *; simpl in |- *. elim (le_lt_dec i 0); intro; simpl in |- *. cut (i = 0); [ intro | auto with arith ]. generalize H; clear a0 H; rewrite H0. rewrite RSR_auxP_lemma0. clear H0; intros. exists (Nat.le_0_l (pred (m + n))). elim le_lt_eq_dec; intro; simpl in |- *. elim (le_lt_dec 0 0); intro; simpl in |- *. apply start. exfalso; inversion b0. apply eq_transitive_unfolded with a. apply start. apply partition_length_zero with Hab. cut (m + n <= 1). intro. elim (plus_eq_one_imp_eq_zero _ _ H0); intro. rewrite <- a0; apply R. rewrite <- b1; apply P. generalize b0; clear b0. case (m + n). auto. intros. simpl in b0; rewrite <- b0; auto. elim (le_lt_eq_dec _ _ H); intro. cut (pred i < pred n); [ intro | apply Nat.lt_succ_lt_pred; rewrite Nat.lt_succ_pred with 0 i; auto ]. cut (RSR_auxP i <= pred (m + n)). intro; exists H1. elim le_lt_eq_dec; intro; simpl in |- *. elim (le_lt_dec (RSR_auxP i) 0); intro; simpl in |- *. cut (RSR_auxP i = 0); [ intro | auto with arith ]. rewrite <- RSR_auxP_lemma0 in H2. cut (RSR_auxP 0 < RSR_auxP i); [ intro | apply RSR_auxP_lemma1; assumption ]. exfalso; rewrite H2 in H3; apply (Nat.lt_irrefl _ H3). generalize b1 a1; clear b1 a1. rewrite (RSR_auxP_lemmai i b0 a0); intros. simpl in |- *. elim (ProjT2 (RSR_h_f' _ (lt_pred' i n b0 a0))); intros. eapply eq_transitive_unfolded. 2: eapply eq_transitive_unfolded. 2: apply p. unfold f' in |- *. apply prf1; symmetry; apply Nat.lt_succ_pred with 0; auto. apply RSR_h_nlnf; reflexivity. rewrite <- RSR_auxP_lemman in b1. cut (i = n). intro; exfalso; rewrite H2 in a0; apply (Nat.lt_irrefl _ a0). apply nat_mon_imp_inj with (h := RSR_auxP). apply RSR_auxP_lemma1. assumption. unfold RSR_auxP in |- *. elim (le_lt_dec i 0); intro; simpl in |- *. apply Nat.le_0_l. elim (le_lt_dec n i); intro; simpl in |- *. elim (Nat.lt_irrefl n); apply Nat.le_lt_trans with i; auto. apply plus_pred_pred_plus. elim (ProjT2 (RSR_h_f' _ (lt_pred' i n b1 b2))); intros. assumption. generalize H; clear H; rewrite b1; intro. rewrite RSR_auxP_lemman. exists (le_n (pred (m + n))). elim le_lt_eq_dec; intro; simpl in |- *. exfalso; apply (Nat.lt_irrefl _ a0). apply finish. Qed. Lemma Separated_Refinement_lft : Refinement P Separated_Refinement. Proof. exists RSR_auxP; repeat split. exact RSR_auxP_lemman. intros; apply RSR_auxP_lemma1; assumption. exact RSR_auxP_lemma2. Qed. Lemma RSR_auxR_lemma0 : RSR_auxR 0 = 0. Proof. unfold RSR_auxR in |- *. elim (le_lt_dec 0 0); intro; simpl in |- *. reflexivity. exfalso; inversion b0. Qed. Lemma RSR_auxR_lemmai : forall (i : nat) (Hi : 0 < i) (Hi' : i < m), RSR_auxR i = S (ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ Hi Hi'))). Proof. intros. unfold RSR_auxR in |- *. elim (le_lt_dec m i); intro; simpl in |- *. exfalso; apply Nat.le_ngt with m i; auto. elim (le_lt_dec i 0); intro; simpl in |- *. exfalso; apply Nat.lt_irrefl with 0; apply Nat.lt_le_trans with i; auto. set (x := ProjT1 (RSR_h_g' _ (lt_pred' _ _ b1 b0))) in *. set (y := ProjT1 (RSR_h_g' _ (lt_pred' _ _ Hi Hi'))) in *. cut (x = y). intro; auto with arith. assert (H := ProjT2 (RSR_h_g' _ (lt_pred' _ _ b1 b0))). assert (H0 := ProjT2 (RSR_h_g' _ (lt_pred' _ _ Hi Hi'))). elim H; clear H; intros Hx Hx'. elim H0; clear H0; intros Hy Hy'. apply RSR_h_inj with Hx Hy. eapply eq_transitive_unfolded. 2: apply Hy'. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply Hx'. apply RSR_g'_nlnf; reflexivity. Qed. Lemma RSR_auxR_lemmam : RSR_auxR m = pred (m + n). Proof. unfold RSR_auxR in |- *. elim (le_lt_dec m 0); intro; simpl in |- *. cut (m = 0); [ intro | auto with arith ]. transitivity (pred m). rewrite H; auto. cut (0 = n); [ intro; rewrite <- H0; auto | apply RSR_HP' ]. apply partition_length_zero with Hab; rewrite <- H; apply R. elim (le_lt_dec m m); intro; simpl in |- *. rewrite Nat.sub_diag; auto. elim (Nat.lt_irrefl _ b1). Qed. Lemma RSR_auxR_lemma1 : forall i j : nat, i < j -> RSR_auxR i < RSR_auxR j. Proof. intros; unfold RSR_auxR in |- *. assert (X:=not_not_lt); assert (X':=plus_pred_pred_plus). assert (X'':=RSR_mn0); assert (X''':=RSR_nm0). elim (le_lt_dec i 0); intro. elim (le_lt_dec j 0); intros; simpl in |- *. apply Nat.le_lt_trans with i; try apply Nat.lt_le_trans with j; auto with arith. elim (le_lt_dec m j); intros; simpl in |- *. lia. apply Nat.lt_0_succ. elim (le_lt_dec m i); elim (le_lt_dec j 0); intros; simpl in |- *. elim (Nat.lt_irrefl 0); apply Nat.le_lt_trans with i; try apply Nat.lt_le_trans with j; auto with arith. elim (le_lt_dec m j); intro; simpl in |- *. apply Nat.add_lt_mono_l. apply Nat.add_lt_mono_l with m. repeat (rewrite Nat.add_comm; rewrite Nat.sub_add); auto. lia; auto; apply Nat.lt_trans with j; auto. elim (Nat.lt_irrefl 0); apply Nat.lt_trans with i; auto; apply Nat.lt_le_trans with j; auto. elim (le_lt_dec m j); intro; simpl in |- *. set (H0 := RSR_nm0) in *; set (H1 := RSR_mn0) in *; apply Nat.lt_le_trans with (S (pred m + pred n)). apply -> Nat.succ_lt_mono. apply (ProjT1 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2)))). rewrite <- plus_Sn_m. rewrite Nat.lt_succ_pred with 0 m. 2: apply Nat.lt_trans with i; auto. replace (m + pred n) with (pred (m + n)). auto with arith. cut (S (pred (m + n)) = S (m + pred n)); auto. rewrite plus_n_Sm. rewrite Nat.lt_succ_pred with 0 n; auto with arith. apply Nat.lt_succ_pred with 0. apply Nat.lt_le_trans with m; auto with arith. apply Nat.lt_trans with i; auto. apply Nat.neq_0_lt_0. intro. apply Nat.lt_irrefl with 0. apply Nat.lt_trans with i; auto. rewrite RSR_nm0; auto. apply -> Nat.succ_lt_mono. cut (~ ~ ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2)) < ProjT1 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3))); intro. apply not_not_lt; assumption. cut (ProjT1 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3)) <= ProjT1 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2))); intros. 2: apply not_lt; assumption. cut (h _ (ProjT1 (ProjT2 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3))))[<=] h _ (ProjT1 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2))))). intro. 2: apply RSR_h_mon'; assumption. cut (g' (pred j) (lt_pred' _ _ b1 b3)[<=]g' (pred i) (lt_pred' _ _ b0 b2)). 2: apply leEq_wdl with (h _ (ProjT1 (ProjT2 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3))))). 2: apply leEq_wdr with (h _ (ProjT1 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2))))). 2: assumption. 3: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_g' (pred j) (lt_pred' _ _ b1 b3)))). 2: apply eq_symmetric_unfolded; exact (ProjT2 (ProjT2 (RSR_h_g' (pred i) (lt_pred' _ _ b0 b2)))). clear H2 H1; intro. cut (g' _ (lt_pred' _ _ b0 b2)[<]g' _ (lt_pred' _ _ b1 b3)). 2: apply RSR_g'_mon. 2: apply lt_pred'; assumption. intro. exfalso. apply less_irreflexive_unfolded with (x := g' _ (lt_pred' _ _ b1 b3)). eapply leEq_less_trans; [ apply H1 | apply X0 ]. Qed. Lemma RSR_auxR_lemma2 : forall (j : nat) (H : j <= m), {H' : RSR_auxR j <= _ | R j H[=]Separated_Refinement _ H'}. Proof. intros. unfold Separated_Refinement in |- *; simpl in |- *. unfold Separated_Refinement_fun in |- *; simpl in |- *. elim (le_lt_dec j 0); intro; simpl in |- *. cut (j = 0); [ intro | auto with arith ]. generalize H; clear a0 H; rewrite H0. rewrite RSR_auxR_lemma0. clear H0; intros. exists (Nat.le_0_l (pred (m + n))). elim le_lt_eq_dec; intro; simpl in |- *. elim (le_lt_dec 0 0); intro; simpl in |- *. apply start. exfalso; inversion b0. apply eq_transitive_unfolded with a. apply start. apply partition_length_zero with Hab. cut (m + n <= 1). intros. elim (plus_eq_one_imp_eq_zero _ _ H0); intro. rewrite <- a0; apply R. rewrite <- b1; apply P. generalize b0; clear b0. case (m + n). auto. intros. simpl in b0; rewrite <- b0; auto. elim (le_lt_eq_dec _ _ H); intro. cut (pred j < pred m); [ intro | red in |- *; rewrite Nat.lt_succ_pred with 0 j; auto; apply le_2; auto ]. cut (RSR_auxR j <= pred (m + n)). intro; exists H1. elim le_lt_eq_dec; intro; simpl in |- *. elim (le_lt_dec (RSR_auxR j) 0); intro; simpl in |- *. cut (RSR_auxR j = 0); [ intro | auto with arith ]. rewrite <- RSR_auxR_lemma0 in H2. cut (RSR_auxR 0 < RSR_auxR j); [ intro | apply RSR_auxR_lemma1; assumption ]. exfalso; rewrite H2 in H3; apply (Nat.lt_irrefl _ H3). generalize b1 a1; clear b1 a1. rewrite (RSR_auxR_lemmai j b0 a0); intros. simpl in |- *. elim (ProjT2 (RSR_h_g' _ (lt_pred' _ _ b0 a0))); intros. eapply eq_transitive_unfolded. 2: eapply eq_transitive_unfolded. 2: apply p. unfold g' in |- *. apply prf1; symmetry; apply Nat.lt_succ_pred with 0; auto. apply RSR_h_nlnf; reflexivity. rewrite <- RSR_auxR_lemmam in b1. cut (j = m). intro; exfalso; rewrite H2 in a0; apply (Nat.lt_irrefl _ a0). apply nat_mon_imp_inj with (h := RSR_auxR). apply RSR_auxR_lemma1. assumption. unfold RSR_auxR in |- *. elim (le_lt_dec j 0); intro; simpl in |- *. apply Nat.le_0_l. elim (le_lt_dec m j); intro; simpl in |- *. rewrite (proj2 (Nat.sub_0_le j m)). rewrite <- plus_n_O; auto with arith. assumption. apply plus_pred_pred_plus. elim (ProjT2 (RSR_h_g' _ (lt_pred' _ _ b1 b2))); intros. assumption. generalize H; clear H; rewrite b1; intro. rewrite RSR_auxR_lemmam. exists (le_n (pred (m + n))). elim le_lt_eq_dec; intro; simpl in |- *. exfalso; apply (Nat.lt_irrefl _ a0). apply finish. Qed. Lemma Separated_Refinement_rht : Refinement R Separated_Refinement. Proof. exists RSR_auxR; repeat split. exact RSR_auxR_lemmam. intros; apply RSR_auxR_lemma1; assumption. exact RSR_auxR_lemma2. Qed. End Refining_Separated. (* end hide *) corn-8.20.0/ftc/RefSeparated.v000066400000000000000000000670501473720167500160760ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.ftc.COrdLemmas. Require Export CoRN.ftc.Partitions. Section Separating__Separated. Variables a b : IR. Hypothesis Hab : a[<=]b. Let I := compact a b Hab. Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis incF : included (Compact Hab) (Dom F). Hypothesis Hab' : a[<]b. Variables m n : nat. Variable P : Partition Hab n. Variable R : Partition Hab m. Hypothesis HP : _Separated P. Hypothesis HR : _Separated R. Lemma RS_pos_n : 0 < n. Proof. apply partition_less_imp_gt_zero with a b Hab; assumption. Qed. Lemma RS_pos_m : 0 < m. Proof. apply partition_less_imp_gt_zero with a b Hab; assumption. Qed. Variable alpha : IR. Hypothesis Halpha : [0][<]alpha. Let e := alpha [/]TwoNZ[/] _[//]max_one_ap_zero (b[-]a). Lemma RS_He : [0][<]e. Proof. unfold e in |- *; apply div_resp_pos. apply pos_max_one. apply pos_div_two; assumption. Qed. Let contF' := contin_prop _ _ _ _ contF. Let d : IR. Proof. elim (contF' e RS_He). intros; apply x. Defined. Lemma RS_Hd : [0][<]d. Proof. unfold d in |- *; elim (contF' e RS_He); auto. Qed. Lemma RS_Hd' : forall x y : IR, I x -> I y -> forall Hx Hy, AbsIR (x[-]y)[<=]d -> AbsIR (F x Hx[-]F y Hy)[<=]e. Proof. unfold d in |- *; elim (contF' e RS_He); auto. Qed. Variable csi : IR. Hypothesis Hcsi : [0][<]csi. Let M := Norm_Funct contF. Let deltaP := AntiMesh P. Let deltaR := AntiMesh R. Let delta := Min (Min deltaP deltaR) (Min (alpha [/]TwoNZ[/] _[//]max_one_ap_zero (nring n[*]M)) (Min csi d)). Lemma RS_delta_deltaP : delta[<=]deltaP. Proof. unfold delta in |- *; eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_lft. Qed. Lemma RS_delta_deltaR : delta[<=]deltaR. Proof. unfold delta in |- *; eapply leEq_transitive. apply Min_leEq_lft. apply Min_leEq_rht. Qed. Lemma RS_delta_csi : delta[<=]csi. Proof. unfold delta in |- *; eapply leEq_transitive. apply Min_leEq_rht. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_lft. Qed. Lemma RS_delta_d : delta[<=]d. Proof. unfold delta in |- *; eapply leEq_transitive. apply Min_leEq_rht. eapply leEq_transitive; apply Min_leEq_rht. Qed. Lemma RS_delta_pos : [0][<]delta. Proof. unfold delta in |- *; apply less_Min; apply less_Min. unfold deltaP in |- *; apply pos_AntiMesh; [ apply RS_pos_n | assumption ]. unfold deltaR in |- *; apply pos_AntiMesh; [ apply RS_pos_m | assumption ]. apply div_resp_pos. apply pos_max_one. apply pos_div_two; assumption. apply less_Min. assumption. apply RS_Hd. Qed. Section Defining_ai'. Variable i : nat. Hypothesis Hi : i <= n. Lemma separation_conseq : forall (j : nat) (Hj : j <= m), AbsIR (P i Hi[-]R j Hj)[<]delta [/]TwoNZ -> forall j' : nat, j <> j' -> forall Hj' : j' <= m, delta [/]TwoNZ[<]AbsIR (P i Hi[-]R j' Hj'). Proof. intros j Hj H; intros. elim (Cnat_total_order _ _ H0); clear H0; intro H0. elim (le_lt_dec j' m); intro. cut (S j <= m); [ intro | clear H; apply Nat.le_trans with j'; auto ]. eapply less_wdr. 2: apply AbsIR_minus. cut (R (S j) H1[<=]R j' Hj'); intros. eapply less_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. rstepr (R _ Hj'[-]R _ H1[+](R _ H1[-]R _ Hj)[+](R _ Hj[-]P i Hi)). rstepl ([0][+]delta[+][--](delta [/]TwoNZ)). apply plus_resp_leEq_less. apply plus_resp_leEq_both. apply shift_leEq_minus; astepl (R _ H1). assumption. apply leEq_transitive with deltaR. apply RS_delta_deltaR. unfold deltaR in |- *; apply AntiMesh_lemma. rstepl ([--](delta [/]TwoNZ)). rstepr ([--](P i Hi[-]R j Hj)). apply inv_resp_less. eapply leEq_less_trans. apply leEq_AbsIR. assumption. apply shift_leEq_minus; astepl (P i Hi). eapply leEq_transitive. 2: apply H2. apply less_leEq; apply less_transitive_unfolded with (R j Hj[+]delta [/]TwoNZ). apply shift_less_plus'. eapply leEq_less_trans; [ apply leEq_AbsIR | apply H ]. apply shift_plus_less'. apply less_leEq_trans with delta. apply pos_div_two'; exact RS_delta_pos. apply leEq_transitive with deltaR. apply RS_delta_deltaR. unfold deltaR in |- *; apply AntiMesh_lemma. apply local_mon_imp_mon'_le with (f := fun (i : nat) (Hi : i <= m) => R i Hi). intros; apply HR. red in |- *; intros; apply prf1; auto. assumption. exfalso; apply (Nat.le_ngt j' m); auto. elim (le_lt_dec j 0); intro. exfalso; apply Nat.nlt_0_r with j'; red in |- *; apply Nat.le_trans with j; auto. generalize Hj H H0; clear H0 H Hj. set (jj := pred j) in *. cut (j = S jj); [ intro | unfold jj in |- *; symmetry; apply Nat.lt_succ_pred with 0; auto ]. rewrite H; intros. cut (jj <= m); [ intro | auto with arith ]. cut (R j' Hj'[<=]R jj H2); intros. eapply less_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. rstepr (P i Hi[-]R _ Hj[+](R _ Hj[-]R jj H2)[+](R jj H2[-]R j' Hj')). rstepl ([--](delta [/]TwoNZ)[+]delta[+][0]). apply plus_resp_less_leEq. apply plus_resp_less_leEq. eapply less_wdr. 2: apply cg_inv_inv. apply inv_resp_less; eapply leEq_less_trans. 2: apply H0. apply inv_leEq_AbsIR. eapply leEq_transitive. apply RS_delta_deltaR. unfold deltaR in |- *; apply AntiMesh_lemma. apply shift_leEq_minus; eapply leEq_wdl. apply H3. algebra. apply shift_leEq_minus; astepl (R j' Hj'). eapply leEq_transitive. apply H3. apply less_leEq; apply less_transitive_unfolded with (R _ Hj[-]delta [/]TwoNZ). apply shift_less_minus; apply shift_plus_less'. apply less_leEq_trans with delta. apply pos_div_two'; exact RS_delta_pos. eapply leEq_transitive. apply RS_delta_deltaR. unfold deltaR in |- *; apply AntiMesh_lemma. apply shift_minus_less; apply shift_less_plus'. eapply leEq_less_trans. 2: apply H0. eapply leEq_wdr. 2: apply AbsIR_minus. apply leEq_AbsIR. apply local_mon_imp_mon'_le with (f := fun (i : nat) (Hi : i <= m) => R i Hi). intros; apply HR. red in |- *; intros; apply prf1; auto. auto with arith. Qed. Let pred1 (j : nat) (Hj : j <= m) := forall Hi' : i <= n, AbsIR (P i Hi'[-]R j Hj)[<]delta [/]TwoNZ. Let pred2 (j : nat) (Hj : j <= m) := forall Hi' : i <= n, delta [/]FourNZ[<]AbsIR (P i Hi'[-]R j Hj). Lemma sep__sep_aux_lemma : {j : nat | {Hj : j <= m | pred1 j Hj}} or (forall (j : nat) (Hj : j <= m), pred2 j Hj). Proof. apply finite_or_elim. red in |- *; unfold pred1 in |- *; do 3 intro. rewrite H; intros H0 H' H1 Hi'. eapply less_wdl. apply H1 with (Hi' := Hi'). apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto. red in |- *; unfold pred2 in |- *; intros. rename X into H1. eapply less_wdr. apply H1 with (Hi' := Hi'). apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto. intros j Hj. cut (pred2 j Hj or pred1 j Hj). intro H; inversion_clear H; [ right | left ]; assumption. unfold pred1, pred2 in |- *. cut (forall Hi' : i <= n, delta [/]FourNZ[<]AbsIR (P i Hi'[-]R j Hj) or AbsIR (P i Hi'[-]R j Hj)[<]delta [/]TwoNZ). intro H. elim (le_lt_dec i n); intro. elim (H a0); intro. left; intro. eapply less_wdr. apply a1. apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto. right; intro. eapply less_wdl. apply b0. apply AbsIR_wd; apply cg_minus_wd; apply prf1; auto. left; intro. exfalso; apply Nat.le_ngt with i n; auto. intros. apply less_cotransitive_unfolded. rstepl ((delta [/]TwoNZ) [/]TwoNZ). apply pos_div_two'; apply pos_div_two; apply RS_delta_pos. Qed. Hypothesis Hi0 : 0 < i. Hypothesis Hin : i < n. Definition sep__sep_fun_i : IR. Proof. elim sep__sep_aux_lemma; intros. 2: apply (P i Hi). apply (P i Hi[+]delta [/]TwoNZ). Defined. Lemma sep__sep_leEq : forall Hi' : i <= n, P i Hi'[<=]sep__sep_fun_i. Proof. unfold sep__sep_fun_i in |- *. elim sep__sep_aux_lemma; intros; simpl in |- *. 2: apply eq_imp_leEq; apply prf1; auto. apply leEq_wdl with (P i Hi). 2: apply prf1; auto. apply shift_leEq_plus'; astepl ZeroR. astepr (delta [/]TwoNZ). apply less_leEq; apply pos_div_two; exact RS_delta_pos. Qed. Lemma sep__sep_less : forall Hi' : S i <= n, sep__sep_fun_i[<]P (S i) Hi'. Proof. unfold sep__sep_fun_i in |- *. elim sep__sep_aux_lemma; intros; simpl in |- *. 2: apply HP. apply shift_plus_less'. apply less_leEq_trans with delta. astepl (delta [/]TwoNZ). apply pos_div_two'; exact RS_delta_pos. apply leEq_transitive with deltaP. apply RS_delta_deltaP. unfold deltaP in |- *; apply AntiMesh_lemma. Qed. Lemma sep__sep_ap : forall (j : nat) (Hj : j <= m), sep__sep_fun_i[#]R j Hj. Proof. intros. unfold sep__sep_fun_i in |- *; elim sep__sep_aux_lemma; intro; simpl in |- *. 2: apply zero_minus_apart; apply AbsIR_cancel_ap_zero; apply Greater_imp_ap. elim a0; intros j' H. elim H; clear a0 H; intros Hj' H. unfold pred1 in H. rstepr (P i Hi[+](R j Hj[-]P i Hi)). apply op_lft_resp_ap. apply un_op_strext_unfolded with AbsIR. apply ap_wdl_unfolded with (delta [/]TwoNZ). 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply less_leEq; apply pos_div_two; exact RS_delta_pos. eapply ap_wdr_unfolded. 2: apply AbsIR_minus. elim (le_lt_dec j j'); intro. elim (le_lt_eq_dec _ _ a0); clear a0; intro. apply less_imp_ap; apply separation_conseq with j' Hj'. apply H. intro; rewrite H0 in a0; apply (Nat.lt_irrefl _ a0). apply Greater_imp_ap. eapply less_wdl. apply H with (Hi' := Hi). apply AbsIR_wd. apply cg_minus_wd. algebra. apply prf1; auto. apply less_imp_ap; apply separation_conseq with j' Hj'. apply H. intro; rewrite H0 in b0; apply (Nat.lt_irrefl _ b0). unfold pred2 in b0. eapply less_transitive_unfolded. 2: apply b0. apply pos_div_four; exact RS_delta_pos. Qed. End Defining_ai'. Definition sep__sep_fun : forall i : nat, i <= n -> IR. Proof. intros. elim (le_lt_dec i 0); intro. apply a. elim (le_lt_eq_dec _ _ H); intro. apply (sep__sep_fun_i i H). apply b. Defined. Lemma sep__sep_fun_i_delta : forall (i : nat) (Hi Hi' : i <= n) (Hi0 : i < n), AbsIR (sep__sep_fun_i i Hi[-]P i Hi')[<=]delta [/]TwoNZ. Proof. intros. unfold sep__sep_fun_i in |- *. elim (sep__sep_aux_lemma i); intro; simpl in |- *. apply eq_imp_leEq. eapply eq_transitive_unfolded. 2: apply AbsIR_eq_x. apply AbsIR_wd. rstepr (P i Hi'[+]delta [/]TwoNZ[-]P i Hi'). apply cg_minus_wd. apply bin_op_wd_unfolded. apply prf1; auto. algebra. algebra. astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos. apply leEq_wdl with ZeroR. astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIRz_isz. apply AbsIR_wd. astepl (P i Hi[-]P i Hi). apply cg_minus_wd; apply prf1; auto. Qed. Lemma sep__sep_fun_delta : forall (i : nat) (Hi Hi' : i <= n), AbsIR (sep__sep_fun i Hi[-]P i Hi')[<=]delta [/]TwoNZ. Proof. intros. unfold sep__sep_fun in |- *. elim (le_lt_dec i 0); intro; simpl in |- *. cut (i = 0); [ intro | auto with arith ]. generalize Hi'; rewrite H; intros. apply leEq_wdl with ZeroR. astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIRz_isz. apply AbsIR_wd. astepl (a[-]a). apply cg_minus_wd; [ algebra | apply eq_symmetric_unfolded; apply start ]. elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *. apply sep__sep_fun_i_delta; assumption. generalize Hi'; rewrite b1; intros. apply leEq_wdl with ZeroR. astepr (delta [/]TwoNZ); apply less_leEq; apply pos_div_two; exact RS_delta_pos. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIRz_isz. apply AbsIR_wd. astepl (b[-]b). apply cg_minus_wd; [ algebra | apply eq_symmetric_unfolded; apply finish ]. Qed. Lemma sep__sep_mon_i : forall (i : nat) (Hi : i <= n) (Hi' : S i <= n) (Hi0 : i < n), sep__sep_fun_i i Hi[<]sep__sep_fun_i (S i) Hi'. Proof. intros. apply less_leEq_trans with (P (S i) Hi0). apply sep__sep_less. apply sep__sep_leEq. Qed. Lemma sep__sep_mon : forall (i : nat) (Hi : i <= n) (Hi' : S i <= n), sep__sep_fun i Hi[<]sep__sep_fun (S i) Hi'. Proof. intros. unfold sep__sep_fun in |- *. elim (le_lt_dec (S i) 0); intro; simpl in |- *. exfalso; apply (Nat.nle_succ_0 _ a0). elim (le_lt_dec i 0); intro; simpl in |- *. elim (le_lt_eq_dec _ _ Hi'); intro; simpl in |- *. apply less_leEq_trans with (P (S i) Hi'). apply leEq_less_trans with (P i Hi). elim (Partition_in_compact _ _ _ _ P i Hi); intros; auto. apply HP. apply sep__sep_leEq. assumption. elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *. elim (le_lt_eq_dec _ _ Hi'); intro; simpl in |- *. apply sep__sep_mon_i; assumption. eapply less_wdr. 2: apply finish with (p := P) (H := le_n n). eapply less_wdr. apply sep__sep_less with (Hi' := Hi'). generalize Hi'; rewrite b2. intro; apply prf1; auto. exfalso; rewrite b2 in Hi'; apply (Nat.nle_succ_diag_l _ Hi'). Qed. Lemma sep__sep_fun_i_wd : forall i j : nat, i = j -> forall (Hi : i <= n) (Hj : j <= n), sep__sep_fun_i i Hi[=]sep__sep_fun_i j Hj. Proof. do 3 intro. rewrite <- H. intros. unfold sep__sep_fun_i in |- *. elim (sep__sep_aux_lemma i); intros; simpl in |- *. apply bin_op_wd_unfolded; [ apply prf1; auto | algebra ]. apply prf1; auto. Qed. Lemma sep__sep_fun_wd : forall i j : nat, i = j -> forall (Hi : i <= n) (Hj : j <= n), sep__sep_fun i Hi[=]sep__sep_fun j Hj. Proof. intros. unfold sep__sep_fun in |- *. elim (le_lt_dec i 0); elim (le_lt_dec j 0); intros; simpl in |- *. algebra. exfalso; apply (Nat.lt_irrefl 0); apply Nat.lt_le_trans with j; auto; rewrite <- H; auto. exfalso; apply (Nat.lt_irrefl 0); apply Nat.lt_le_trans with j; auto; rewrite <- H; auto. elim (le_lt_eq_dec _ _ Hi); elim (le_lt_eq_dec _ _ Hj); intros; simpl in |- *. apply sep__sep_fun_i_wd; auto. exfalso; rewrite H in a0; rewrite b2 in a0; apply (Nat.lt_irrefl _ a0). exfalso; rewrite <- H in a0; rewrite b2 in a0; apply (Nat.lt_irrefl _ a0). algebra. Qed. Definition sep__sep_part : Partition Hab n. Proof. apply Build_Partition with sep__sep_fun. exact sep__sep_fun_wd. intros; apply less_leEq; apply sep__sep_mon. intros; unfold sep__sep_fun in |- *. elim (le_lt_dec 0 0); intro; simpl in |- *. algebra. exfalso; inversion b0. intros; unfold sep__sep_fun in |- *. elim (le_lt_dec n 0); intro; simpl in |- *. apply partition_length_zero with Hab. cut (n = 0); [ intro | auto with arith ]. rewrite <- H0; apply P. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. exfalso; apply (Nat.lt_irrefl _ a0). algebra. Defined. Lemma sep__sep_lemma : Separated sep__sep_part R. Proof. repeat split; unfold _Separated in |- *; intros. apply sep__sep_mon. apply HR. unfold sep__sep_part in |- *; simpl in |- *. unfold sep__sep_fun in |- *; simpl in |- *. elim (le_lt_dec i 0); intro; simpl in |- *. exfalso; apply Nat.lt_irrefl with 0; apply Nat.lt_le_trans with i; auto. elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *. apply sep__sep_ap. exfalso; rewrite b1 in H1; apply (Nat.lt_irrefl _ H1). Qed. Variable g : forall i : nat, i < n -> IR. Hypothesis gP : Points_in_Partition P g. Definition sep__sep_points (i : nat) (Hi : i < n) : IR. Proof. intros. apply (Max (sep__sep_fun_i i (Nat.lt_le_incl _ _ Hi)) (g i Hi)). Defined. Lemma sep__sep_points_lemma : Points_in_Partition sep__sep_part sep__sep_points. Proof. red in |- *; intros. split. unfold sep__sep_part in |- *; simpl in |- *. unfold sep__sep_fun, sep__sep_points in |- *. elim (le_lt_dec i 0); intro; simpl in |- *. apply leEq_transitive with (g i Hi). elim (Pts_part_lemma _ _ _ _ _ _ gP i Hi); intros; assumption. apply rht_leEq_Max. elim (le_lt_eq_dec _ _ (Nat.lt_le_incl _ _ Hi)); intro; simpl in |- *. eapply leEq_wdl. apply lft_leEq_Max. apply sep__sep_fun_i_wd; auto. exfalso; rewrite b1 in Hi; apply (Nat.lt_irrefl _ Hi). unfold sep__sep_part in |- *; simpl in |- *. unfold sep__sep_fun, sep__sep_points in |- *. elim (le_lt_dec (S i) 0); intro; simpl in |- *. exfalso; inversion a0. elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *. apply Max_leEq. apply less_leEq; apply sep__sep_mon_i; assumption. apply leEq_transitive with (P (S i) Hi). elim (gP i Hi); intros; auto. apply sep__sep_leEq. apply Max_leEq. unfold sep__sep_fun_i in |- *. elim (sep__sep_aux_lemma i); intro; simpl in |- *. apply leEq_transitive with (P (S i) Hi). apply shift_plus_leEq'. apply leEq_transitive with delta. astepl (delta [/]TwoNZ); apply less_leEq; apply pos_div_two'; exact RS_delta_pos. apply leEq_transitive with deltaP. apply RS_delta_deltaP. unfold deltaP in |- *; apply AntiMesh_lemma. elim (Partition_in_compact _ _ _ _ P (S i) Hi); intros; assumption. elim (Partition_in_compact _ _ _ _ P i (Nat.lt_le_incl _ _ Hi)); intros; assumption. elim (Pts_part_lemma _ _ _ _ _ _ gP i Hi); intros; assumption. Qed. Lemma sep__sep_aux : forall (i : nat) (H : i < n) Hg Hs, AbsIR (F (g i H) Hg[-]F (sep__sep_points i H) Hs)[<=]e. Proof. intros. apply RS_Hd'. unfold I in |- *; apply Pts_part_lemma with n P; assumption. unfold I in |- *; apply Pts_part_lemma with n sep__sep_part; apply sep__sep_points_lemma. unfold sep__sep_points in |- *; simpl in |- *. eapply leEq_wdl. 2: apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply shift_minus_leEq; apply Max_leEq. unfold sep__sep_fun_i in |- *. elim sep__sep_aux_lemma; intro; simpl in |- *. apply leEq_transitive with (P i (Nat.lt_le_incl _ _ H)[+]delta). apply plus_resp_leEq_lft. apply less_leEq; astepl (delta [/]TwoNZ); apply pos_div_two'; exact RS_delta_pos. eapply leEq_wdr. 2: apply cag_commutes_unfolded. apply plus_resp_leEq_both. elim (gP i H); intros; assumption. apply RS_delta_d. astepl ([0][+]P i (Nat.lt_le_incl _ _ H)). apply plus_resp_leEq_both. apply less_leEq; exact RS_Hd. elim (gP i H); intros; auto. apply shift_leEq_plus; astepl ZeroR; apply less_leEq; exact RS_Hd. apply shift_leEq_minus. eapply leEq_wdl. apply rht_leEq_Max. algebra. Qed. Notation just1 := (incF _ (Pts_part_lemma _ _ _ _ _ _ gP _ _)). Notation just2 := (incF _ (Pts_part_lemma _ _ _ _ _ _ sep__sep_points_lemma _ _)). Lemma sep__sep_Sum : AbsIR (Partition_Sum gP incF[-]Partition_Sum sep__sep_points_lemma incF)[<=] alpha. Proof. unfold Partition_Sum in |- *; simpl in |- *. rstepr (alpha [/]TwoNZ[+]alpha [/]TwoNZ). apply leEq_transitive with (e[*](b[-]a)[+]nring n[*]M[*]delta). apply leEq_wdr with (e[*] Sumx (fun (i : nat) (Hi : i < n) => P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))[+] Sumx (fun (i : nat) (Hi : i < n) => M[*]delta)). apply leEq_transitive with (Sumx (fun (i : nat) (Hi : i < n) => AbsIR (F (g i Hi) just1[-]F (sep__sep_points i Hi) just2)[*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi)))[+] Sumx (fun (i : nat) (Hi : i < n) => AbsIR (F (sep__sep_points i Hi) just2)[*] (AbsIR (sep__sep_fun _ Hi[-]P _ Hi)[+] AbsIR (P _ (Nat.lt_le_incl _ _ Hi)[-]sep__sep_fun _ (Nat.lt_le_incl _ _ Hi))))). apply leEq_transitive with (AbsIR (Sumx (fun (i : nat) (Hi : i < n) => F (g i Hi) just1[*](P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))[-] F (sep__sep_points i Hi) just2[*] (P _ Hi[-]P _ (Nat.lt_le_incl _ _ Hi))))[+] AbsIR (Sumx (fun (i : nat) (Hi : i < n) => F (sep__sep_points i Hi) just2[*] (sep__sep_fun _ Hi[-]P _ Hi[+] (P _ (Nat.lt_le_incl _ _ Hi)[-]sep__sep_fun _ (Nat.lt_le_incl _ _ Hi)))))). eapply leEq_wdl. apply triangle_IR_minus. apply eq_symmetric_unfolded. apply AbsIR_wd. eapply eq_transitive_unfolded. apply Sumx_minus_Sumx. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply Sumx_minus_Sumx. apply Sumx_wd; intros. astepl (F (g i H) just1[*](P _ H[-]P _ (Nat.lt_le_incl _ _ H))[-] F (sep__sep_points i H) just2[*] (sep__sep_fun _ H[-]sep__sep_fun _ (Nat.lt_le_incl _ _ H))). rational. apply plus_resp_leEq_both. eapply leEq_wdr. apply triangle_SumxIR. apply Sumx_wd; intros. apply eq_transitive_unfolded with (AbsIR (F (g i H) just1[-]F (sep__sep_points i H) just2)[*] AbsIR (P _ H[-]P _ (Nat.lt_le_incl _ _ H))). eapply eq_transitive_unfolded. 2: apply AbsIR_resp_mult. apply AbsIR_wd; algebra. apply mult_wdr. apply AbsIR_eq_x. apply shift_leEq_minus; astepl (P i (Nat.lt_le_incl _ _ H)); apply prf2. eapply leEq_transitive. apply triangle_SumxIR. apply Sumx_resp_leEq; intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_lft. apply triangle_IR. apply AbsIR_nonneg. apply plus_resp_leEq_both. eapply leEq_wdr. 2: apply Sumx_comm_scal'. apply Sumx_resp_leEq; intros. apply mult_resp_leEq_rht. apply sep__sep_aux. apply shift_leEq_minus; astepl (P i (Nat.lt_le_incl _ _ H)); apply prf2. apply Sumx_resp_leEq; intros. apply mult_resp_leEq_both. apply AbsIR_nonneg. astepl (ZeroR[+][0]); apply plus_resp_leEq_both; apply AbsIR_nonneg. unfold I, M in |- *; apply norm_bnd_AbsIR. apply Pts_part_lemma with n sep__sep_part; apply sep__sep_points_lemma. rstepr (delta [/]TwoNZ[+]delta [/]TwoNZ). apply plus_resp_leEq_both. apply sep__sep_fun_delta. eapply leEq_wdl. 2: apply AbsIR_minus. apply sep__sep_fun_delta. apply bin_op_wd_unfolded. apply mult_wdr. eapply eq_transitive_unfolded. apply Mengolli_Sum with (f := fun (i : nat) (Hi : i <= n) => P i Hi). red in |- *; intros; apply prf1; auto. intros; algebra. apply cg_minus_wd. apply finish. apply start. astepr (nring n[*](M[*]delta)); apply sumx_const. apply plus_resp_leEq_both. unfold e in |- *. apply leEq_wdl with (alpha [/]TwoNZ[*](b[-]a[/] _[//]max_one_ap_zero (b[-]a))). rstepr (alpha [/]TwoNZ[*][1]). apply mult_resp_leEq_lft. apply shift_div_leEq. apply pos_max_one. astepr (Max (b[-]a) [1]); apply lft_leEq_Max. apply less_leEq; apply pos_div_two; assumption. simpl in |- *; rational. apply leEq_transitive with (Max (nring n[*]M) [1][*]delta). apply mult_resp_leEq_rht. apply lft_leEq_Max. apply less_leEq; apply RS_delta_pos. apply shift_mult_leEq' with (max_one_ap_zero (nring n[*]M)). apply pos_max_one. unfold delta in |- *. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_lft. Qed. Lemma sep__sep_Mesh : Mesh sep__sep_part[<=]Mesh P[+]csi. Proof. unfold Mesh in |- *. apply maxlist_leEq. apply length_Part_Mesh_List. exact RS_pos_n. intros x H. elim (Part_Mesh_List_lemma _ _ _ _ _ _ H); intros i Hi. elim Hi; clear Hi; intros Hi Hi'. elim Hi'; clear Hi'; intros Hi' Hx. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Hx. unfold sep__sep_part in |- *; simpl in |- *. unfold sep__sep_fun in |- *; simpl in |- *. elim (le_lt_dec (S i) 0); intro; simpl in |- *. exfalso; inversion a0. elim (le_lt_eq_dec _ _ Hi'); intro; simpl in |- *. elim (le_lt_dec i 0); intro; simpl in |- *. cut (i = 0); [ intro | auto with arith ]. unfold sep__sep_fun_i in |- *; simpl in |- *. elim (sep__sep_aux_lemma (S i)); intro; simpl in |- *. generalize Hi'; rewrite H0; clear Hx Hi'; intro. apply leEq_wdl with (P 1 Hi'[+]delta [/]TwoNZ[-]P 0 (Nat.le_0_l _)). rstepl (P 1 Hi'[-]P 0 (Nat.le_0_l _)[+]delta [/]TwoNZ). apply plus_resp_leEq_both. fold (Mesh P) in |- *; apply Mesh_lemma. apply leEq_transitive with delta. apply less_leEq; apply pos_div_two'; exact RS_delta_pos. apply RS_delta_csi. apply cg_minus_wd; [ algebra | apply start ]. generalize Hi'; rewrite H0; clear Hx Hi'; intro. apply leEq_wdl with (P 1 Hi'[-]P 0 (Nat.le_0_l _)). fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]). astepr (Mesh P); apply Mesh_lemma. apply plus_resp_leEq_lft. apply less_leEq; assumption. apply cg_minus_wd; [ algebra | apply start ]. elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *. unfold sep__sep_fun_i in |- *. elim (sep__sep_aux_lemma (S i)); elim (sep__sep_aux_lemma i); intros; simpl in |- *. rstepl (P (S i) Hi'[-]P i Hi). fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]). astepr (Mesh P); apply Mesh_lemma. apply plus_resp_leEq_lft. apply less_leEq; assumption. rstepl (P _ Hi'[-]P _ Hi[+]delta [/]TwoNZ). apply plus_resp_leEq_both. fold (Mesh P) in |- *; apply Mesh_lemma. apply leEq_transitive with delta. apply less_leEq; apply pos_div_two'; exact RS_delta_pos. apply RS_delta_csi. rstepl (P _ Hi'[-]P _ Hi[-]delta [/]TwoNZ). unfold cg_minus at 1 in |- *; apply plus_resp_leEq_both. fold (Mesh P) in |- *; apply Mesh_lemma. apply leEq_transitive with ZeroR. astepr ([--]ZeroR); apply inv_resp_leEq. apply less_leEq; apply pos_div_two; exact RS_delta_pos. apply leEq_transitive with delta. apply less_leEq; exact RS_delta_pos. apply RS_delta_csi. fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]). astepr (Mesh P); apply Mesh_lemma. apply plus_resp_leEq_lft. apply less_leEq; assumption. exfalso; rewrite b2 in a0; apply Nat.lt_irrefl with (S n); apply Nat.lt_trans with (S n); auto with arith. elim (le_lt_dec i 0); intro; simpl in |- *. cut (i = 0); [ intro | auto with arith ]. rewrite H0 in b1. clear Hx; rewrite H0 in Hi'. apply leEq_wdl with (P 1 Hi'[-]P 0 (Nat.le_0_l n)). fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]). astepr (Mesh P); apply Mesh_lemma. apply plus_resp_leEq_lft. apply less_leEq; assumption. apply cg_minus_wd. generalize Hi'; rewrite b1; intro; apply finish. apply start. elim (le_lt_eq_dec _ _ Hi); intro; simpl in |- *. unfold sep__sep_fun_i in |- *. elim (sep__sep_aux_lemma i); intro; simpl in |- *. apply leEq_wdl with (P (S i) Hi'[-](P i Hi[+]delta [/]TwoNZ)). rstepl (P (S i) Hi'[-]P i Hi[-]delta [/]TwoNZ). unfold cg_minus at 1 in |- *; apply plus_resp_leEq_both. fold (Mesh P) in |- *; apply Mesh_lemma. apply leEq_transitive with ZeroR. astepr ([--]ZeroR); apply inv_resp_leEq. apply less_leEq; apply pos_div_two; exact RS_delta_pos. apply leEq_transitive with delta. apply less_leEq; exact RS_delta_pos. apply RS_delta_csi. apply cg_minus_wd. generalize Hi'; rewrite b1; intro; apply finish. algebra. apply leEq_wdl with (P (S i) Hi'[-]P i Hi). fold (Mesh P) in |- *; apply leEq_transitive with (Mesh P[+][0]). astepr (Mesh P); apply Mesh_lemma. apply plus_resp_leEq_lft. apply less_leEq; assumption. apply cg_minus_wd. generalize Hi'; rewrite b1; intro; apply finish. algebra. exfalso; rewrite b3 in b1; apply n_Sn with n; auto. Qed. End Separating__Separated. (* end hide *) corn-8.20.0/ftc/RefSeparating.v000066400000000000000000001300321473720167500162520ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.ftc.COrdLemmas. Require Export CoRN.ftc.Partitions. From Coq Require Import Lia. Section Separating_Partition. Variables a b : IR. Hypothesis Hab : a[<=]b. Let I := compact a b Hab. Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. Hypothesis incF : included (compact a b Hab) (Dom F). Hypothesis Hab' : a[<]b. Variable n : nat. Variable P : Partition Hab n. Variable alpha : IR. Hypothesis Halpha : [0][<]alpha. Variable csi : IR. Hypothesis Hcsi : [0][<]csi. Let M := Norm_Funct contF. Lemma RS'_pos_n : 0 < n. Proof. apply partition_less_imp_gt_zero with a b Hab; assumption. Qed. Lemma SPap_n : n <> 0. Proof. intro. apply (Nat.neq_0_lt_0 n). exact RS'_pos_n. auto. Qed. Let delta := Min csi (alpha[/] _[//] mult_resp_ap_zero _ _ _ (nring_ap_zero _ _ SPap_n) (max_one_ap_zero M)). Lemma RS'_delta_pos : [0][<]delta. Proof. unfold delta in |- *; apply less_Min. assumption. apply div_resp_pos. apply mult_resp_pos. astepl (nring (R:=IR) 0); apply nring_less; apply RS'_pos_n. apply pos_max_one. assumption. Qed. Lemma RS'_delta_csi : delta[<=]csi. Proof. unfold delta in |- *; apply Min_leEq_lft. Qed. Hypothesis Hab'' : delta [/]TwoNZ[<]b[-]a. Lemma sep__part_lemma : forall (i : nat) (Hi : i <= n), {j : nat | {Hj : j <= n | delta [/]FourNZ[<]P j Hj[-]P i Hi and (forall (j' : nat) (Hj' : j' <= n), j' < j -> P j' Hj'[-]P i Hi[<]delta [/]TwoNZ)}} or P n (le_n n)[-]P i Hi[<]delta [/]TwoNZ. Proof. intros. elim (str_finite_or_elim _ (fun (j : nat) (Hj : j <= n) => delta [/]FourNZ[<]P j Hj[-]P i Hi) (fun (j : nat) (Hj : j <= n) => P j Hj[-]P i Hi[<]delta [/]TwoNZ)); intros. left. elim a0; intros j a'. elim a'; intros Hj Hj'. elim Hj'; clear a0 a' Hj'; intros Hj' H0. exists j; exists Hj. split; assumption. right; auto. red in |- *; intros. rename X into H1. eapply less_wdr. apply H1. apply cg_minus_wd; apply prf1; auto. red in |- *; intros. rename X into H1. eapply less_wdl. apply H1. apply cg_minus_wd; apply prf1; auto. apply less_cotransitive_unfolded. apply shift_div_less. apply pos_four. rstepr (delta[+]delta). astepl ([0][+]delta). apply plus_resp_less_leEq. apply RS'_delta_pos. apply leEq_reflexive. Qed. Definition sep__part_h : nat -> nat. Proof. intro i; induction i as [| i Hreci]. apply 0. elim (le_lt_dec Hreci n); intro. elim (sep__part_lemma Hreci a0); intro. apply (ProjT1 a1). apply n. apply n. Defined. Lemma sep__part_h_bnd : forall i : nat, sep__part_h i <= n. Proof. intro. induction i as [| i Hreci]. apply Nat.le_0_l. simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a0); intro; simpl in |- *. set (j := ProjT1 a1) in *; fold j in |- *. elim (ProjT2 a1); intros Hj Hj'; fold j in Hj, Hj'. assumption. apply le_n. apply le_n. Qed. Lemma sep__part_h_mon_1 : forall i : nat, sep__part_h i <= sep__part_h (S i). Proof. intros; simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a0); intro; simpl in |- *. set (j := ProjT1 a1) in *; fold j in |- *. elim (ProjT2 a1); intros Hj Hj'; fold j in Hj, Hj'. elim Hj'; clear Hj'; intros Hj0 Hj1. cut (sep__part_h i < j); intros. apply Nat.lt_le_incl; assumption. apply (Partition_Points_mon _ _ _ _ P) with a0 Hj. apply less_transitive_unfolded with (P (sep__part_h i) a0[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR. apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; assumption. assumption. apply sep__part_h_bnd. Qed. Lemma sep__part_h_mon_2 : forall i : nat, sep__part_h i < n -> sep__part_h i < sep__part_h (S i). Proof. intros; simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a0); intro; simpl in |- *. set (j := ProjT1 a1) in *; fold j in |- *. elim (ProjT2 a1); intros Hj Hj'; fold j in Hj, Hj'. elim Hj'; clear Hj'; intros Hj0 Hj1. apply (Partition_Points_mon _ _ _ _ P) with a0 Hj. apply less_transitive_unfolded with (P (sep__part_h i) a0[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR. apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; assumption. assumption. assumption. Qed. Lemma sep__part_h_mon_3 : forall i j : nat, sep__part_h i < n -> i < j -> sep__part_h i < sep__part_h j. Proof. intros; induction j as [| j Hrecj]. exfalso; inversion H0. cut (sep__part_h j <= sep__part_h (S j)); intros. 2: apply sep__part_h_mon_1. elim (le_lt_eq_dec _ _ H0); intro. apply Nat.lt_le_trans with (sep__part_h j); auto. apply Hrecj; auto with arith. rewrite <- b0; apply sep__part_h_mon_2; auto. Qed. Lemma sep__part_app_n : {m : nat | sep__part_h (S m) = n /\ (forall i : nat, i <= m -> sep__part_h i < n)}. Proof. elim (weird_mon_covers _ _ sep__part_h_mon_2); intros m Hm Hm'. set (m' := pred m) in *. exists m'. cut (m <> 0); intro. split. cut (S m' = m); [ intro | unfold m' in |- *; apply Nat.lt_succ_pred with 0; apply Nat.neq_0_lt_0; auto ]. rewrite H0; clear H0 m'. cut (n <= sep__part_h m). cut (sep__part_h m <= n); intros. auto with arith. apply sep__part_h_bnd. assumption. intros; apply Hm'. unfold m' in H0; rewrite <- (Nat.lt_succ_pred 0 m); auto with arith. apply Nat.neq_0_lt_0; auto. apply SPap_n. rewrite H in Hm. simpl in Hm. apply Nat.le_antisymm; auto with arith. Qed. Lemma sep__part_h_lemma : forall i : nat, sep__part_h (S i) < n -> forall Hi Hi', P (sep__part_h i) Hi[<]P (sep__part_h (S i)) Hi'. Proof. do 3 intro; simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a0); intro; simpl in |- *. set (m' := ProjT1 a1) in *. change (forall Hi' : m' <= n, P (sep__part_h i) Hi[<]P m' Hi') in |- *; intros. elim (ProjT2 a1); fold m' in |- *; intros Hm' Hm''. elim Hm''; clear Hm''; intros H0 H1. apply less_transitive_unfolded with (P (sep__part_h i) Hi[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR; apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; eapply less_wdr. apply H0. apply cg_minus_wd; apply prf1; auto. generalize H. simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a1); intro; simpl in |- *. 2: intro; exfalso; apply (Nat.lt_irrefl n); auto. 2: intro; exfalso; apply (Nat.lt_irrefl n); auto. set (m' := ProjT1 a2) in *. change (m' < n -> forall Hi' : n <= n, P (sep__part_h i) Hi[<]P n Hi') in |- *; intros. elim (ProjT2 a2); fold m' in |- *; intros Hm' Hm''. elim Hm''; clear Hm''; intros H1 H2. apply less_leEq_trans with (P _ Hm'). apply less_transitive_unfolded with (P (sep__part_h i) Hi[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR; apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; eapply less_wdr. apply H1. apply cg_minus_wd; apply prf1; auto. apply local_mon'_imp_mon'2_le with (f := fun (i : nat) Hi => P i Hi). intros; apply prf2. assumption. exfalso; lia. Qed. Lemma sep__part_h_lemma2 : forall (i : nat) Hi Hi', P (pred (sep__part_h (S i))) Hi'[-]P (sep__part_h i) Hi[<=]delta [/]TwoNZ. Proof. do 2 intro; simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a0); intro; simpl in |- *. set (j := ProjT1 a1) in *. elim (ProjT2 a1); fold j in |- *; intros Hj Hj'; elim Hj'; clear Hj'; intros H H0. change (forall Hi', P (pred j) Hi'[-]P _ Hi[<=]delta [/]TwoNZ) in |- *. intros; apply less_leEq. apply less_wdl with (P (pred j) Hi'[-]P _ a0); intros. 2: apply cg_minus_wd; apply prf1; auto. apply H0. apply Nat.lt_pred_l. apply Nat.neq_0_lt_0. apply Nat.le_lt_trans with (sep__part_h i). apply Nat.le_0_l. apply Partition_Points_mon with (P := P) (Hi := a0) (Hj := Hj). apply less_transitive_unfolded with (P (sep__part_h i) a0[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR; apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; assumption. intros; eapply leEq_transitive. 2: apply less_leEq; apply b0. unfold cg_minus in |- *; apply plus_resp_leEq_both. apply Partition_mon; assumption. apply inv_resp_leEq; apply eq_imp_leEq; apply prf1; auto. exfalso; lia. Qed. Lemma sep__part_h_lemma3 : forall (i k : nat) Hk Hk', sep__part_h i <= k -> k < pred (sep__part_h (S i)) -> P (S k) Hk'[-]P k Hk[<=]delta [/]TwoNZ. Proof. intros. cut (sep__part_h i <= n). cut (pred (sep__part_h (S i)) <= n); intros. eapply leEq_transitive. 2: apply sep__part_h_lemma2 with (Hi := H2) (Hi' := H1). unfold cg_minus in |- *; apply plus_resp_leEq_both. apply Partition_mon; assumption. apply inv_resp_leEq; apply Partition_mon; assumption. apply Nat.le_trans with (sep__part_h (S i)). auto with arith. apply sep__part_h_bnd. apply sep__part_h_bnd. Qed. Lemma RS'_delta2_delta4 : forall m : nat, delta [/]FourNZ[<]P _ (sep__part_h_bnd (S m))[-]P _ (sep__part_h_bnd m) or P _ (sep__part_h_bnd (S m))[-]P _ (sep__part_h_bnd m)[<]delta [/]TwoNZ. Proof. intro; apply less_cotransitive_unfolded. rstepl ((delta [/]TwoNZ) [/]TwoNZ). apply pos_div_two'; apply pos_div_two; exact RS'_delta_pos. Qed. Definition RS'_m1 := ProjT1 sep__part_app_n. Definition RS'_m : nat. Proof. elim (RS'_delta2_delta4 RS'_m1); intro. apply (S RS'_m1). apply RS'_m1. Defined. Notation m := RS'_m. Definition sep__part_length := m. Lemma RS'_m_m1 : {m = RS'_m1} + {m = S RS'_m1}. Proof. unfold m in |- *. elim (RS'_delta2_delta4 RS'_m1); intro; simpl in |- *. right; auto. left; auto. Qed. Lemma RS'_pos_m : 0 < m. Proof. unfold m in |- *. elim (RS'_delta2_delta4 RS'_m1); intro; simpl in |- *. auto with arith. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. cut (0 <> RS'_m1); intro. auto with arith. exfalso. apply less_irreflexive_unfolded with (x := delta [/]TwoNZ). apply less_transitive_unfolded with (b[-]a). assumption. eapply less_wdl. apply b0. apply cg_minus_wd. eapply eq_transitive_unfolded. 2: apply finish with (p := P) (H := le_n n). apply prf1. auto. eapply eq_transitive_unfolded. 2: apply start with (p := P) (H := Nat.le_0_l n). apply prf1. rewrite <- H1. simpl in |- *; auto. Qed. Definition sep__part_fun : forall i : nat, i <= m -> nat. Proof. intros i Hi. elim (le_lt_eq_dec _ _ Hi); intro. apply (sep__part_h i). apply n. Defined. Lemma sep__part_fun_bnd : forall (i : nat) (H : i <= m), sep__part_fun i H <= n. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. apply sep__part_h_bnd. apply le_n. Qed. Lemma sep__part_fun_0 : forall H : 0 <= m, sep__part_fun 0 H = 0. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. reflexivity. exfalso. generalize b0. apply Nat.neq_sym. apply Nat.neq_0_lt_0; apply RS'_pos_m. Qed. Lemma sep__part_fun_i : forall (i : nat) (H : i <= m), i < m -> sep__part_fun i H = sep__part_h i. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. reflexivity. rewrite b0 in H0; elim (Nat.lt_irrefl _ H0). Qed. Lemma sep__part_fun_m : forall H : m <= m, sep__part_fun m H = n. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. elim (Nat.lt_irrefl _ a0). reflexivity. Qed. Lemma sep__part_fun_i' : forall (i : nat) (H : i <= m), sep__part_h i <= sep__part_fun i H. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. apply le_n. apply sep__part_h_bnd. Qed. Lemma sep__part_fun_bnd' : forall (i : nat) (H : i <= m), i < m -> sep__part_fun i H < n. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ H); intro; simpl in |- *. elim (ProjT2 sep__part_app_n). intros. apply H2. generalize a0; clear a0. unfold m in |- *; elim (RS'_delta2_delta4 RS'_m1); intro; simpl in |- *. auto with arith. auto with arith. rewrite b0 in H0; elim (Nat.lt_irrefl _ H0). Qed. Lemma sep__part_fun_wd : forall (i j : nat) Hi Hj, i = j -> sep__part_fun i Hi = sep__part_fun j Hj. Proof. intros. unfold sep__part_fun in |- *. elim (le_lt_eq_dec _ _ Hi); elim (le_lt_eq_dec _ _ Hj); intros; simpl in |- *. rewrite H; auto. rewrite H in a0; rewrite b0 in a0; elim (Nat.lt_irrefl _ a0). rewrite <- H in a0; rewrite b0 in a0; elim (Nat.lt_irrefl _ a0). auto. Qed. Lemma sep__part_fun_mon : forall (i j : nat) Hi Hj, i < j -> sep__part_fun i Hi < sep__part_fun j Hj. Proof. intros. apply less_nring with (IR:COrdField). apply local_mon_imp_mon_le with (f := fun (i : nat) (Hi : i <= m) => nring (R:=IR) (sep__part_fun i Hi)). clear H Hj Hi j i; intros; apply nring_less. 2: assumption. elim (le_lt_eq_dec _ _ H'); intro. rewrite (sep__part_fun_i (S i)). 2: assumption. simpl in |- *; elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a1); intro; simpl in |- *. elim (ProjT2 a2); set (j := ProjT1 a2) in *. intros Hj Hj'. elim Hj'; clear Hj'; intros H0 H1. rewrite sep__part_fun_i. 2: auto with arith. apply (Partition_Points_mon _ _ _ _ P) with a1 Hj. apply less_transitive_unfolded with (P _ a1[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR; apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; apply H0. apply sep__part_fun_bnd'; auto with arith. apply sep__part_fun_bnd'; auto with arith. generalize H'; rewrite b0. intro; rewrite sep__part_fun_m. apply sep__part_fun_bnd'. auto with arith. Qed. Definition sep__part : Partition Hab sep__part_length. apply Build_Partition with (fun (i : nat) (Hi : i <= m) => P _ (sep__part_fun_bnd i Hi)). Proof. intros; apply prf1. apply sep__part_fun_wd; auto. intros. apply local_mon'_imp_mon'2_le with (f := fun (i : nat) (Hi : i <= n) => P i Hi). intros; apply prf2. apply sep__part_fun_mon; auto. intro. apply eq_transitive_unfolded with (P 0 (Nat.le_0_l _)). apply prf1. apply sep__part_fun_0. apply start. intro; eapply eq_transitive_unfolded. 2: apply finish with (p := P) (H := le_n n). apply prf1. apply sep__part_fun_m. Defined. Lemma sep__part_fun_mon_pts : forall (i : nat) Hi Hi' Hi0 Hi'0, P (sep__part_fun i Hi) Hi0[<]P (sep__part_fun (S i) Hi') Hi'0. Proof. do 3 intro. rewrite sep__part_fun_i. 2: auto with arith. elim (le_lt_eq_dec _ _ Hi'); intro. rewrite (sep__part_fun_i (S i)). 2: assumption. intros. apply sep__part_h_lemma. rewrite <- sep__part_fun_i with (H := Hi'). apply sep__part_fun_bnd'; assumption. assumption. generalize Hi'; clear Hi'; rewrite b0. intro; rewrite sep__part_fun_m. intros. cut (m = m). 2: auto. unfold m at 2 in |- *; elim (RS'_delta2_delta4 RS'_m1); intro; simpl in |- *; intro. cut (i = RS'_m1); [ clear b0; intro | rewrite <- b0 in H; auto with arith ]. generalize Hi0; clear Hi0; rewrite H0. intro. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. apply less_transitive_unfolded with (P (sep__part_h RS'_m1) Hi0[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR; apply pos_div_four; apply RS'_delta_pos. apply shift_plus_less'; eapply less_wdr. apply a0. apply cg_minus_wd; apply prf1. auto. auto. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. generalize Hi'0; clear Hi'0. cut (S i = RS'_m1); [ intro | transitivity m; auto ]. pattern n at 1 5 in |- *; rewrite <- H0. rewrite <- H2. intro. apply less_leEq_trans with (P _ (sep__part_h_bnd (S i))). 2: apply local_mon'_imp_mon'_le with (f := fun (i : nat) (Hi : i <= n) => P i Hi). 2: intros; apply prf2. 2: red in |- *; intros; apply prf1; assumption. 2: apply sep__part_h_mon_1. apply sep__part_h_lemma. apply H1. rewrite H2; apply le_n. Qed. Lemma sep__part_mon : forall (i : nat) Hi Hi', sep__part i Hi[<]sep__part (S i) Hi'. Proof. intros. unfold sep__part in |- *; simpl in |- *. apply sep__part_fun_mon_pts. Qed. Lemma sep__part_mon_Mesh : Mesh sep__part[<=]Mesh P[+]csi. Proof. unfold Mesh at 1 in |- *. apply maxlist_leEq. apply length_Part_Mesh_List. apply RS'_pos_m. intros x H. elim (Part_Mesh_List_lemma _ _ _ _ _ _ H). intros i Hi. elim Hi; clear Hi; intros Hi Hi'. elim Hi'; clear Hi'; intros Hi' Hx. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Hx. clear Hx H x. simpl in |- *. cut (forall Ha Hb, P (sep__part_fun (S i) Hi') Ha[-]P (sep__part_fun i Hi) Hb[<=]Mesh P[+]csi). intro. apply H. rename Hi' into H. rewrite (sep__part_fun_i i). 2: assumption. elim (le_lt_eq_dec _ _ H); intro. rewrite sep__part_fun_i. 2: assumption. intros. cut (pred (sep__part_h (S i)) <= n); [ intro | eapply Nat.le_trans; [ apply Nat.le_pred_l | auto ] ]. rstepl (P _ Ha[-]P _ H0[+](P _ H0[-]P _ Hb)). apply plus_resp_leEq_both. generalize Ha; pattern (sep__part_h (S i)) at 1 2 in |- *; replace (sep__part_h (S i)) with (S (pred (sep__part_h (S i)))); intros. apply Mesh_lemma. apply Nat.lt_succ_pred with (sep__part_h i); apply sep__part_h_mon_2. rewrite <- sep__part_fun_i with (H := Nat.lt_le_incl _ _ H). apply sep__part_fun_bnd'; assumption. assumption. eapply leEq_transitive. apply sep__part_h_lemma2. apply less_leEq; apply less_leEq_trans with delta. apply pos_div_two'; exact RS'_delta_pos. apply RS'_delta_csi. generalize H; clear H; rewrite b0; intro H. rewrite sep__part_fun_m. cut (m = m); [ unfold m at 2 in |- * | auto ]. elim RS'_delta2_delta4; intro; simpl in |- *; intro. intros. cut (sep__part_h (S RS'_m1) = n). intro; generalize Ha Hb; pattern n at 1 5 in |- *. rewrite <- H1. cut (i = RS'_m1); [ intro | unfold sep__part_length in b0; rewrite <- b0 in H0; auto with arith ]. rewrite H2. intros. cut (pred (sep__part_h (S RS'_m1)) <= n); [ intro | eapply Nat.le_trans; [ apply Nat.le_pred_l | auto ] ]. rstepl (P _ Ha0[-]P _ H3[+](P _ H3[-]P _ Hb0)). apply plus_resp_leEq_both. generalize Ha0; pattern (sep__part_h (S RS'_m1)) at 1 2 in |- *; replace (sep__part_h (S RS'_m1)) with (S (pred (sep__part_h (S RS'_m1)))); intros. apply Mesh_lemma. apply Nat.lt_succ_pred with (sep__part_h RS'_m1); apply sep__part_h_mon_2. cut (RS'_m1 <= m). 2: rewrite H0; apply Nat.le_succ_diag_r. intro. rewrite <- sep__part_fun_i with (H := H4). apply sep__part_fun_bnd'. rewrite H0; apply Nat.lt_succ_diag_r. rewrite H0; apply Nat.lt_succ_diag_r. eapply leEq_transitive. apply sep__part_h_lemma2. apply less_leEq; apply less_leEq_trans with delta. apply pos_div_two'; exact RS'_delta_pos. apply RS'_delta_csi. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. auto. cut (sep__part_h (S RS'_m1) = n). intro; pattern n at 1 5 in |- *. rewrite <- H1. intros. cut (sep__part_h RS'_m1 <= n); [ intro | apply sep__part_h_bnd ]. rstepl (P _ Ha[-]P _ H2[+](P _ H2[-]P _ Hb)). apply leEq_transitive with (delta [/]TwoNZ[+](Mesh P[+]delta [/]TwoNZ)). apply plus_resp_leEq_both. apply less_leEq; eapply less_wdl. apply b1. apply cg_minus_wd; apply prf1; auto. generalize H2; clear H2; rewrite <- H0; unfold sep__part_length in b0; rewrite <- b0. simpl in |- *. elim (le_lt_dec (sep__part_h i) n); intro; simpl in |- *. elim (sep__part_lemma (sep__part_h i) a0); intro; simpl in |- *. set (j := ProjT1 a1) in *. change (forall H0, P j H0[-]P (sep__part_h i) Hb[<=]Mesh P[+]delta [/]TwoNZ) in |- *. elim (ProjT2 a1); fold j in |- *; intros Hj Hj'. elim Hj'; clear Hj'; intros H2 H3. intros. cut (pred j <= n); [ intro | apply Nat.le_trans with j; auto with arith ]. rstepl (P j H4[-]P (pred j) H5[+](P (pred j) H5[-]P (sep__part_h i) Hb)). cut (0 < j); intros. apply plus_resp_leEq_both. cut (j = S (pred j)); [ intro | symmetry; apply Nat.lt_succ_pred with 0; auto ]. generalize H4 H5 H6; rewrite H7; intros. apply Mesh_lemma. apply less_leEq. apply less_wdl with (P (pred j) H5[-]P _ a0). 2: apply cg_minus_wd; apply prf1; auto. apply H3. auto with arith. apply Nat.le_lt_trans with (sep__part_h i); auto with arith. apply Partition_Points_mon with (P := P) (Hi := a0) (Hj := Hj). apply less_transitive_unfolded with (P (sep__part_h i) a0[+]delta [/]FourNZ). apply shift_less_plus'; astepl ZeroR; apply pos_div_four; exact RS'_delta_pos. apply shift_plus_less'; assumption. intros. apply less_leEq; apply less_leEq_trans with (delta [/]TwoNZ). eapply less_wdl. apply b2. apply cg_minus_wd; apply prf1; auto. astepl ([0][+]delta [/]TwoNZ); apply plus_resp_leEq; apply Mesh_nonneg. exfalso. lia. rstepl (Mesh P[+]delta). apply plus_resp_leEq_lft; apply RS'_delta_csi. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. auto. Qed. Variable g : forall i : nat, i < n -> IR. Hypothesis gP : Points_in_Partition P g. Hypothesis gP' : nat_less_n_fun g. Definition sep__part_pts (i : nat) (Hi : i < sep__part_length) : IR. Proof. intros. cut (pred (sep__part_h (S i)) < n); intros. apply (g _ H). cut (sep__part_h i < sep__part_h (S i)). 2: apply sep__part_h_mon_3. intro. red in |- *. replace (S (pred (sep__part_h (S i)))) with (sep__part_h (S i)); intros. apply sep__part_h_bnd. symmetry; apply Nat.lt_succ_pred with (sep__part_h i); assumption. rewrite <- sep__part_fun_i with (H := Nat.lt_le_incl _ _ Hi). apply sep__part_fun_bnd'; assumption. assumption. apply Nat.lt_succ_diag_r. Defined. Lemma sep__part_pts_lemma : forall (i : nat) Hi Hi', sep__part_pts i Hi[=]g (pred (sep__part_h (S i))) Hi'. Proof. intros; unfold sep__part_pts in |- *. apply gP'; auto. Qed. Lemma sep__part_pts_in_Partition : Points_in_Partition sep__part sep__part_pts. Proof. red in |- *; intros i Hi. set (H := sep__part_h_mon_3 _ _ (eq_ind (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) ( fun n0 : nat => n0 < n) (sep__part_fun_bnd' i (Nat.lt_le_incl _ _ Hi) Hi) (sep__part_h i) (sep__part_fun_i i (Nat.lt_le_incl _ _ Hi) Hi)) (Nat.lt_succ_diag_r i)) in *. set (H0 := eq_sym (Nat.lt_succ_pred (sep__part_h i) (sep__part_h (S i)) H)) in *. set (H' := eq_ind (sep__part_h (S i)) (fun j : nat => j <= n) ( sep__part_h_bnd (S i)) (S (pred (sep__part_h (S i)))) H0) in *. elim (gP _ H'); intros. simpl in |- *; unfold sep__part_pts in |- *. split. eapply leEq_transitive. 2: apply a0. apply Partition_mon; apply le_2. rewrite sep__part_fun_i; assumption. eapply leEq_transitive. apply b0. apply Partition_mon. rewrite <- H0. apply sep__part_fun_i'. Qed. Lemma RS'_Hsep_S : forall (i j : nat) (Hi : S i <= m), j <= pred (sep__part_fun (S i) Hi) -> S j <= n. Proof. intros. apply Nat.le_trans with (sep__part_fun (S i) Hi). 2: apply sep__part_fun_bnd. rewrite <- (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) (sep__part_fun (S i) Hi) ) . auto with arith. apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. Qed. Lemma RS'_Hsep : forall (i j : nat) (Hi : S i <= m), j <= pred (sep__part_fun (S i) Hi) -> j <= n. Proof. intros. apply Nat.le_trans with (sep__part_fun (S i) Hi). 2: apply sep__part_fun_bnd. rewrite <- (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) (sep__part_fun (S i) Hi) ) . apply le_S; assumption. apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. Qed. Definition RS'_h : nat -> IR. Proof. intro i. elim (le_lt_dec i n); intro. apply (P i a0). apply ZeroR. Defined. Notation h := RS'_h. Notation just1 := (incF _ (Pts_part_lemma _ _ _ _ _ _ gP _ _)). Notation just2 := (incF _ (Pts_part_lemma _ _ _ _ _ _ sep__part_pts_in_Partition _ _)). Lemma sep__part_suRS'_m1 : forall (i : nat) (Hi : i < m), Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj'))[=] sep__part _ Hi[-]sep__part _ (Nat.lt_le_incl _ _ Hi). Proof. intros; simpl in |- *. unfold Sum2 in |- *. cut (sep__part_fun (S i) Hi = S (pred (sep__part_fun (S i) Hi))). 2: symmetry; apply Nat.lt_succ_pred with (sep__part_fun i (Nat.lt_le_incl _ _ Hi)); apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. intro. cut (S (pred (sep__part_fun (S i) Hi)) <= n). 2: rewrite <- H; apply sep__part_fun_bnd. intro. apply eq_transitive_unfolded with (P _ H0[-]P _ (sep__part_fun_bnd i (Nat.lt_le_incl _ _ Hi))). 2: apply cg_minus_wd; apply prf1; auto. eapply eq_transitive_unfolded. apply str_Mengolli_Sum_gen with (f := h). rewrite <- H; apply Nat.lt_le_incl; apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. intro j; intros. do 2 elim le_lt_dec; intros; simpl in |- *. unfold h in |- *. do 2 elim le_lt_dec; intros; simpl in |- *. apply cg_minus_wd; apply prf1; auto. exfalso; apply Nat.le_ngt with j n. apply Nat.le_trans with (S j); auto with arith. assumption. exfalso; apply Nat.le_ngt with (S j) n. exact (RS'_Hsep_S _ _ Hi a1). assumption. exfalso; apply Nat.le_ngt with (S j) n. exact (RS'_Hsep_S _ _ Hi a1). assumption. exfalso; lia. exfalso; lia. exfalso; lia. unfold h in |- *. apply cg_minus_wd. elim le_lt_dec; simpl in |- *; intros. apply prf1; auto. exfalso; lia. elim le_lt_dec; intro; simpl in |- *. apply prf1; auto. exfalso; rewrite <- H in H0; apply Nat.le_ngt with (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) n. apply sep__part_fun_bnd. assumption. Qed. Lemma sep__part_Sum2 : Partition_Sum gP incF[=] Sumx (fun (i : nat) (Hi : i < m) => Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => F (g j (RS'_Hsep_S _ _ _ Hj')) just1[*] (P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj')))). Proof. unfold Partition_Sum in |- *. apply eq_symmetric_unfolded. unfold Sum2 in |- *. apply eq_transitive_unfolded with (Sumx (fun (j : nat) (Hj : j < n) => part_tot_nat_fun _ _ (fun (i : nat) (H : i < n) => F (g i H) just1[*](P _ H[-]P _ (Nat.lt_le_incl _ _ H))) j)). apply str_Sumx_Sum_Sum' with (g := fun (i : nat) (Hi : i < m) (i0 : nat) => sumbool_rect (fun _ : {sep__part_fun i (Nat.lt_le_incl i m Hi) <= i0} + {i0 < sep__part_fun i (Nat.lt_le_incl i m Hi)} => IR) (fun _ : sep__part_fun i (Nat.lt_le_incl i m Hi) <= i0 => sumbool_rect (fun _ : {i0 <= pred (sep__part_fun (S i) Hi)} + {pred (sep__part_fun (S i) Hi) < i0} => IR) (fun H0 : i0 <= pred (sep__part_fun (S i) Hi) => F (g i0 (RS'_Hsep_S i i0 Hi H0)) (incF (g i0 (RS'_Hsep_S i i0 Hi H0)) (Pts_part_lemma a b Hab n P g gP i0 (RS'_Hsep_S i i0 Hi H0)))[*] (P (S i0) (RS'_Hsep_S i i0 Hi H0)[-]P i0 (RS'_Hsep i i0 Hi H0))) (fun _ : pred (sep__part_fun (S i) Hi) < i0 => [0]) (le_lt_dec i0 (pred (sep__part_fun (S i) Hi)))) (fun _ : i0 < sep__part_fun i (Nat.lt_le_incl i m Hi) => [0]) (le_lt_dec (sep__part_fun i (Nat.lt_le_incl i m Hi)) i0)) (h := part_tot_nat_fun _ _ (fun (i : nat) (H : i < n) => F (g i H) just1[*](P _ H[-]P _ (Nat.lt_le_incl _ _ H)))). apply sep__part_fun_0. intros; apply sep__part_fun_wd; auto. intros; apply sep__part_fun_mon; auto. intros. elim le_lt_dec; intro; simpl in |- *. elim le_lt_dec; intro; simpl in |- *. unfold part_tot_nat_fun in |- *. elim (le_lt_dec n j); intro; simpl in |- *. exfalso. apply Nat.le_ngt with n j. assumption. apply Nat.lt_le_trans with (sep__part_fun (S i) Hi''). assumption. apply sep__part_fun_bnd. apply mult_wd; algebra. apply cg_minus_wd; apply prf1; auto. exfalso. apply Nat.le_ngt with (sep__part_fun i Hi') j. assumption. cut (sep__part_fun i Hi' = sep__part_fun i (Nat.lt_le_incl _ _ Hi)); [ intro | apply sep__part_fun_wd; auto ]. rewrite H1; assumption. exfalso. apply Nat.le_ngt with (S j) (sep__part_fun (S i) Hi). cut (sep__part_fun (S i) Hi = sep__part_fun (S i) Hi''); [ intro | apply sep__part_fun_wd; auto ]. rewrite H1; apply H0. rewrite <- (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) (sep__part_fun (S i) Hi)) . auto with arith. apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. intros; symmetry in |- *; apply sep__part_fun_m. apply Sumx_wd; intros. unfold part_tot_nat_fun in |- *. elim (le_lt_dec n i); intro; simpl in |- *. exfalso; apply Nat.le_ngt with n i; auto. apply mult_wd; algebra. apply cg_minus_wd; apply prf1; auto. Qed. Lemma sep__part_Sum3 : AbsIR (Partition_Sum gP incF[-]Partition_Sum sep__part_pts_in_Partition incF)[=] AbsIR (Sumx (fun (i : nat) (Hi : i < m) => Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => (F (g j (RS'_Hsep_S _ _ _ Hj')) just1[-]F (sep__part_pts i Hi) just2)[*] (P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj'))))). Proof. apply AbsIR_wd. apply eq_transitive_unfolded with (Sumx (fun (i : nat) (Hi : i < m) => Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => F (g j (RS'_Hsep_S _ _ _ Hj')) just1[*] (P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj')))[-] F (sep__part_pts i Hi) just2[*] Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj')))). eapply eq_transitive_unfolded. 2: apply Sumx_minus_Sumx with (f := fun (i : nat) (Hi : i < m) => Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => F (g j (RS'_Hsep_S _ _ _ Hj')) just1[*] (P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj')))) (g := fun (i : nat) (Hi : i < m) => F (sep__part_pts i Hi) just2[*] Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj'))). apply cg_minus_wd. apply sep__part_Sum2. unfold Partition_Sum in |- *; apply Sumx_wd; intros. apply mult_wdr. apply eq_symmetric_unfolded; apply sep__part_suRS'_m1. apply Sumx_wd; intros i Hi. apply eq_transitive_unfolded with (Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => F (g j (RS'_Hsep_S _ _ _ Hj')) just1[*] (P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj')))[-] Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => F (sep__part_pts i Hi) just2[*] (P _ (RS'_Hsep_S _ _ _ Hj')[-]P _ (RS'_Hsep _ _ _ Hj')))). apply cg_minus_wd. algebra. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply Sum2_comm_scal'. algebra. rewrite (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) (sep__part_fun (S i) Hi) (sep__part_fun_mon _ _ _ _ (Nat.lt_succ_diag_r i))). apply Nat.lt_le_incl; apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. eapply eq_transitive_unfolded. apply Sum2_minus_Sum2. rewrite (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) (sep__part_fun (S i) Hi) (sep__part_fun_mon _ _ _ _ (Nat.lt_succ_diag_r i))). apply Nat.lt_le_incl; apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. apply Sum2_wd; intros. rewrite (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) (sep__part_fun (S i) Hi) (sep__part_fun_mon _ _ _ _ (Nat.lt_succ_diag_r i))). apply Nat.lt_le_incl; apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. algebra. Qed. Lemma sep__part_Sum4 : Sumx (fun (i : nat) (Hi : i < m) => Sum2 (fun (j : nat) (Hj : sep__part_fun i (Nat.lt_le_incl _ _ Hi) <= j) (Hj' : j <= pred (sep__part_fun (S i) Hi)) => (M[+]M)[*]delta [/]TwoNZ))[<=]alpha. Proof. unfold Sum2 in |- *. apply leEq_wdl with (Sumx (fun (j : nat) (_ : j < n) => part_tot_nat_fun _ _ (fun (i : nat) (_ : i < n) => (M[+]M)[*]delta [/]TwoNZ) j)). 2: apply eq_symmetric_unfolded; apply str_Sumx_Sum_Sum' with (g := fun (i : nat) (Hi : i < m) (i0 : nat) => sumbool_rect (fun _ : {sep__part_fun i (Nat.lt_le_incl i m Hi) <= i0} + {i0 < sep__part_fun i (Nat.lt_le_incl i m Hi)} => IR) (fun _ : sep__part_fun i (Nat.lt_le_incl i m Hi) <= i0 => sumbool_rect (fun _ : {i0 <= pred (sep__part_fun (S i) Hi)} + {pred (sep__part_fun (S i) Hi) < i0} => IR) (fun _ : i0 <= pred (sep__part_fun (S i) Hi) => (M[+]M)[*]delta [/]TwoNZ) (fun _ : pred (sep__part_fun (S i) Hi) < i0 => [0]) (le_lt_dec i0 (pred (sep__part_fun (S i) Hi)))) (fun _ : i0 < sep__part_fun i (Nat.lt_le_incl i m Hi) => [0]) (le_lt_dec (sep__part_fun i (Nat.lt_le_incl i m Hi)) i0)) (h := part_tot_nat_fun _ _ (fun (i : nat) (_ : i < n) => (M[+]M)[*]delta [/]TwoNZ)). apply leEq_wdr with (Sumx (fun (i : nat) (_ : i < n) => alpha[/] _[//]nring_ap_zero _ _ SPap_n)). 2: rstepr (nring n[*](alpha[/] _[//]nring_ap_zero _ _ SPap_n)); apply sumx_const. apply Sumx_resp_leEq; intros. unfold part_tot_nat_fun in |- *. elim (le_lt_dec n i); intro; simpl in |- *. exfalso; lia. unfold delta in |- *. apply leEq_transitive with ((M[+]M)[*] (alpha[/] _[//] mult_resp_ap_zero _ _ _ (nring_ap_zero _ _ SPap_n) (max_one_ap_zero M)) [/]TwoNZ). apply mult_resp_leEq_lft. apply div_resp_leEq. apply pos_two. apply Min_leEq_rht. astepl (ZeroR[+][0]); apply plus_resp_leEq_both; unfold M in |- *; apply positive_norm. rstepl (alpha[*](M[/] _[//]max_one_ap_zero M)[*] ([1][/] _[//]nring_ap_zero _ _ SPap_n)). rstepr (alpha[*][1][*]([1][/] _[//]nring_ap_zero _ _ SPap_n)). apply mult_resp_leEq_rht. apply mult_resp_leEq_lft. apply shift_div_leEq. apply pos_max_one. astepr (Max M [1]); apply lft_leEq_Max. apply less_leEq; assumption. apply less_leEq; apply recip_resp_pos. astepl (nring (R:=IR) 0); apply nring_less; apply RS'_pos_n. apply sep__part_fun_0. exact sep__part_fun_wd. exact sep__part_fun_mon. unfold part_tot_nat_fun in |- *. intros; elim (le_lt_dec (sep__part_fun i (Nat.lt_le_incl _ _ Hi)) j); intro; simpl in |- *. elim (le_lt_dec j (pred (sep__part_fun (S i) Hi))); intro; simpl in |- *. elim (le_lt_dec n j); intro; simpl in |- *. exfalso; apply (Nat.le_ngt n j). assumption. eapply Nat.lt_le_trans. apply H0. apply sep__part_fun_bnd. algebra. exfalso; apply (proj1 (Nat.le_ngt _ _) H0). rewrite <- (Nat.lt_succ_pred (sep__part_fun i Hi') (sep__part_fun (S i) Hi'')). cut (sep__part_fun (S i) Hi'' = sep__part_fun (S i) Hi); [ intro | apply sep__part_fun_wd; auto ]. rewrite H1; auto with arith. apply sep__part_fun_mon. apply Nat.lt_succ_diag_r. exfalso; apply (proj1 (Nat.le_ngt _ _) H). rewrite sep__part_fun_i. 2: assumption. rewrite sep__part_fun_i in b0; assumption. intros; symmetry in |- *; apply sep__part_fun_m. Qed. Lemma sep__part_aux : forall i : nat, pred (sep__part_h (S i)) < n. Proof. intros. red in |- *. rewrite Nat.lt_succ_pred with (sep__part_h 0) (sep__part_h (S i)). apply sep__part_h_bnd. apply sep__part_h_mon_3. rewrite <- sep__part_fun_i with (H := Nat.le_0_l m). 2: apply RS'_pos_m. 2: apply Nat.lt_0_succ. rewrite <- sep__part_fun_m with (H := le_n m). apply sep__part_fun_mon. apply RS'_pos_m. Qed. Lemma sep__part_Sum : AbsIR (Partition_Sum gP incF[-]Partition_Sum sep__part_pts_in_Partition incF)[<=] alpha. Proof. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply sep__part_Sum3. eapply leEq_transitive. 2: apply sep__part_Sum4. eapply leEq_transitive. apply triangle_SumxIR. apply Sumx_resp_leEq; intros. eapply leEq_transitive. apply triangle_Sum2IR. rewrite (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ H)) (sep__part_fun (S i) H) (sep__part_fun_mon _ _ _ _ (Nat.lt_succ_diag_r i))). apply Nat.lt_le_incl; apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. apply Sum2_resp_leEq. rewrite (Nat.lt_succ_pred (sep__part_fun i (Nat.lt_le_incl _ _ H)) (sep__part_fun (S i) H) (sep__part_fun_mon _ _ _ _ (Nat.lt_succ_diag_r i))). apply Nat.lt_le_incl; apply sep__part_fun_mon; apply Nat.lt_succ_diag_r. intros k Hk Hk'. elim (le_lt_dec m (S i)); intro. cut (S i = m); [ intro | clear Hk Hk'; lia ]. generalize H0. unfold m at 1 in |- *; elim RS'_delta2_delta4; intro; simpl in |- *; intro. cut (i < m); [ intro | assumption ]. apply leEq_wdl with (AbsIR ((F (g k (RS'_Hsep_S _ _ H Hk')) just1[-]F (g _ (sep__part_aux RS'_m1)) just1)[*] (P (S k) (RS'_Hsep_S _ _ H Hk')[-]P k (RS'_Hsep _ _ H Hk')))). 2: apply AbsIR_wd; apply mult_wdl. 2: apply cg_minus_wd; [ algebra | idtac ]. 2: cut (i = RS'_m1); [ intro | auto ]. 2: generalize H; rewrite H3; intro. 2: unfold sep__part_pts in |- *; simpl in |- *; algebra. elim (le_lt_dec (pred (sep__part_h (S RS'_m1))) k); intro. cut (pred (sep__part_h (S RS'_m1)) = k); intros. apply leEq_wdl with ZeroR. astepl (([0][+][0])[*]ZeroR). apply mult_resp_leEq_both. apply eq_imp_leEq; algebra. apply leEq_reflexive. apply plus_resp_leEq_both; unfold M in |- *; apply positive_norm. apply less_leEq; astepr (delta [/]TwoNZ); apply pos_div_two; exact RS'_delta_pos. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply AbsIRz_isz. apply AbsIR_wd. rstepr ((F (g _ (sep__part_aux RS'_m1)) just1[-]F (g _ (sep__part_aux RS'_m1)) just1)[*] (P (S k) (RS'_Hsep_S _ _ H Hk')[-]P k (RS'_Hsep _ _ H Hk'))). algebra. cut (forall H, sep__part_fun (S i) H = n). intro. cut (sep__part_h (S RS'_m1) = n); intros. rewrite H4 in a2. rewrite H3 in Hk'. rewrite H4. apply Nat.le_antisymm; auto. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. auto. rewrite H0; exact sep__part_fun_m. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_transitive. apply triangle_IR_minus. apply plus_resp_leEq_both; unfold M, I in |- *; apply norm_bnd_AbsIR; apply Pts_part_lemma with n P; apply gP. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (P k (RS'_Hsep i k H Hk')); apply prf2. apply sep__part_h_lemma3 with i. rewrite sep__part_fun_i in Hk; assumption. rewrite H1; assumption. apply leEq_wdl with (AbsIR ((F (g k (RS'_Hsep_S _ _ H Hk')) just1[-]F (g _ (sep__part_aux i)) just1)[*] (P (S k) (RS'_Hsep_S _ _ H Hk')[-]P k (RS'_Hsep _ _ H Hk')))). 2: apply AbsIR_wd; apply mult_wd. 2: apply cg_minus_wd; apply pfwdef; [ algebra | unfold sep__part_pts in |- *; apply gP' ]; auto. 2: apply cg_minus_wd; apply prf1; auto. elim (le_lt_dec (pred (sep__part_h RS'_m1)) k); intro. elim (le_lt_eq_dec _ _ a1); intro. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_transitive. apply triangle_IR_minus. apply plus_resp_leEq_both; unfold M, I in |- *; apply norm_bnd_AbsIR; apply Pts_part_lemma with n P; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (P k (RS'_Hsep i k H Hk')); apply prf2. apply less_leEq; eapply leEq_less_trans. 2: apply b0. unfold cg_minus in |- *; apply plus_resp_leEq_both. apply Partition_mon. rewrite <- (Nat.lt_succ_pred (sep__part_h RS'_m1) (sep__part_h (S RS'_m1))). apply le_n_S. cut (forall H, sep__part_h (S RS'_m1) = sep__part_fun (S i) H); intros. rewrite (H2 H); assumption. generalize H2; rewrite H0. intro; rewrite sep__part_fun_m. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; auto. apply sep__part_h_mon_3. elim (ProjT2 sep__part_app_n); fold RS'_m1 in |- *; intros. apply H3; apply le_n. apply Nat.lt_succ_diag_r. apply inv_resp_leEq; apply Partition_mon. eapply Nat.le_trans. 2: apply a2. clear Hk Hk'; lia. apply leEq_wdl with ZeroR. astepl (([0][+][0])[*]ZeroR). apply mult_resp_leEq_both. apply eq_imp_leEq; algebra. apply leEq_reflexive. apply plus_resp_leEq_both; unfold M in |- *; apply positive_norm. apply less_leEq; astepr (delta [/]TwoNZ); apply pos_div_two; exact RS'_delta_pos. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply AbsIRz_isz. apply AbsIR_wd. rstepr ((F (g _ (sep__part_aux i)) just1[-]F (g _ (sep__part_aux i)) just1)[*] (P (S k) (RS'_Hsep_S _ _ H Hk')[-]P k (RS'_Hsep _ _ H Hk'))). apply mult_wdl. apply cg_minus_wd; apply pfwdef; apply gP'; auto. rewrite H1; auto. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_transitive. apply triangle_IR_minus. apply plus_resp_leEq_both; unfold M, I in |- *; apply norm_bnd_AbsIR; apply Pts_part_lemma with n P; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (P k (RS'_Hsep i k H Hk')); apply prf2. apply sep__part_h_lemma3 with i. rewrite sep__part_fun_i in Hk; assumption. rewrite H1; assumption. elim (le_lt_eq_dec _ _ Hk'); intro. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_transitive. apply triangle_IR_minus. apply plus_resp_leEq_both; unfold M, I in |- *; apply norm_bnd_AbsIR. apply Pts_part_lemma with n P; assumption. apply Pts_part_lemma with sep__part_length sep__part; apply sep__part_pts_in_Partition. cut (pred (sep__part_fun (S i) H) <= n); intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (P k (RS'_Hsep i k H Hk')); apply prf2. apply sep__part_h_lemma3 with i. rewrite sep__part_fun_i in Hk; assumption. rewrite sep__part_fun_i in a0; assumption. apply Nat.le_trans with (sep__part_fun (S i) H). auto with arith. apply sep__part_fun_bnd. apply leEq_wdl with ZeroR. astepl (([0][+][0])[*]ZeroR). apply mult_resp_leEq_both. apply eq_imp_leEq; algebra. apply leEq_reflexive. apply plus_resp_leEq_both; unfold M in |- *; apply positive_norm. apply less_leEq; astepr (delta [/]TwoNZ); apply pos_div_two; exact RS'_delta_pos. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply AbsIRz_isz. apply AbsIR_wd. rstepr ((F (g _ (sep__part_aux i)) just1[-]F (g _ (sep__part_aux i)) just1)[*] (P (S k) (RS'_Hsep_S _ _ H Hk')[-]P k (RS'_Hsep _ _ H Hk'))). apply mult_wdl. apply cg_minus_wd; apply pfwdef; unfold sep__part_pts in |- *; apply gP'; auto. rewrite sep__part_fun_i in b1; assumption. Qed. End Separating_Partition. (* end hide *) corn-8.20.0/ftc/Rolle.v000066400000000000000000000556521473720167500146130ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.tactics.DiffTactics2. Require Export CoRN.ftc.MoreFunctions. Section Rolle. (** * Rolle's Theorem We now begin to work with partial functions. We begin by stating and proving Rolle's theorem in various forms and some of its corollaries. %\begin{convention}% Assume that: - [a,b:IR] with [a [<] b] and denote by [I] the interval [[a,b]]; - [F,F'] are partial functions such that [F'] is the derivative of [F] in [I]; - [e] is a positive real number. %\end{convention}% *) (* begin hide *) Variables a b : IR. Hypothesis Hab' : a [<] b. Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. Variables F F' : PartIR. Hypothesis derF : Derivative_I Hab' F F'. Hypothesis Ha : Dom F a. Hypothesis Hb : Dom F b. (* end hide *) (* begin show *) Hypothesis Fab : F a Ha [=] F b Hb. (* end show *) (* begin hide *) Variable e : IR. Hypothesis He : [0] [<] e. Let contF' : Continuous_I Hab F'. Proof. apply deriv_imp_contin'_I with Hab' F. assumption. Qed. Let derivF : forall e : IR, [0] [<] e -> {d : IR | [0] [<] d | forall x y : IR, I x -> I y -> forall Hx Hy Hx', AbsIR (x[-]y) [<=] d -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e[*]AbsIR (y[-]x)}. Proof. elim derF. intros a0 b0. elim b0; intros H b1. unfold I in |- *; assumption. Qed. Let Rolle_lemma2 : {d : IR | [0] [<] d | forall x y : IR, I x -> I y -> forall Hx Hy Hx', AbsIR (x[-]y) [<=] d -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e [/]TwoNZ[*]AbsIR (y[-]x)}. Proof. exact (derivF _ (pos_div_two _ _ He)). Qed. Let df := proj1_sig2T _ _ _ Rolle_lemma2. Let Hdf : [0] [<] df := proj2a_sig2T _ _ _ Rolle_lemma2. Let Hf : forall x y : IR, I x -> I y -> forall Hx Hy Hx', AbsIR (x[-]y) [<=] df -> AbsIR (F y Hy[-]F x Hx[-]F' x Hx'[*] (y[-]x)) [<=] e [/]TwoNZ[*]AbsIR (y[-]x) := proj2b_sig2T _ _ _ Rolle_lemma2. Let Rolle_lemma3 : {d : IR | [0] [<] d | forall x y : IR, I x -> I y -> forall Hx Hy, AbsIR (x[-]y) [<=] d -> AbsIR (F' x Hx[-]F' y Hy) [<=] e [/]TwoNZ}. Proof. elim contF'; intros. exact (b0 _ (pos_div_two _ _ He)). Qed. Let df' := proj1_sig2T _ _ _ Rolle_lemma3. Let Hdf' : [0] [<] df' := proj2a_sig2T _ _ _ Rolle_lemma3. Let Hf' : forall x y : IR, I x -> I y -> forall Hx Hy, AbsIR (x[-]y) [<=] df' -> AbsIR (F' x Hx[-]F' y Hy) [<=] e [/]TwoNZ := proj2b_sig2T _ _ _ Rolle_lemma3. Let d := Min df df'. Let Hd : [0] [<] d. Proof. unfold d in |- *; apply less_Min; auto. Qed. Let incF : included (Compact Hab) (Dom F). Proof. elim derF; intros; assumption. Qed. Let n := compact_nat a b d Hd. Let fcp (i : nat) (Hi : i <= n) := F (compact_part a b Hab' d Hd i Hi) (incF _ (compact_part_hyp a b Hab Hab' d Hd i Hi)). Let Rolle_lemma1 : Sumx (fun (i : nat) (H : i < n) => fcp (S i) H[-]fcp i (Nat.lt_le_incl i n H)) [=] [0]. Proof. apply eq_transitive_unfolded with (fcp _ (le_n n) [-]fcp 0 (Nat.le_0_l n)). apply Mengolli_Sum with (f := fun (i : nat) (H : i <= n) => fcp _ H). red in |- *; do 3 intro. rewrite H; intros. unfold fcp in |- *; simpl in |- *; algebra. intros; algebra. apply eq_transitive_unfolded with (F b Hb[-]F a Ha). unfold fcp, compact_part, n in |- *; simpl in |- *. apply cg_minus_wd; apply pfwdef; rational. astepr (F a Ha[-]F a Ha); apply cg_minus_wd. apply eq_symmetric_unfolded; apply Fab. algebra. Qed. Let incF' : included (Compact Hab) (Dom F'). Proof. elim derF; intros. elim b0; intros. assumption. Qed. Let fcp' (i : nat) (Hi : i <= n) := F' (compact_part a b Hab' d Hd i Hi) (incF' _ (compact_part_hyp a b Hab Hab' d Hd i Hi)). Notation cp := (compact_part a b Hab' d Hd). Let Rolle_lemma4 : {i : nat | {H : i < n | [0] [<] (fcp' _ (Nat.lt_le_incl _ _ H) [+]e) [*] (cp (S i) H[-]cp i (Nat.lt_le_incl _ _ H))}}. Proof. apply positive_Sumx with (f := fun (i : nat) (H : i < n) => (fcp' _ (Nat.lt_le_incl _ _ H) [+]e) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H))). red in |- *; do 3 intro. rewrite H; intros. unfold fcp' in |- *; algebra. apply less_wdl with (Sumx (fun (i : nat) (H : i < n) => fcp _ H[-]fcp _ (Nat.lt_le_incl _ _ H))). 2: apply Rolle_lemma1. apply Sumx_resp_less. apply less_nring with (IR:COrdField); simpl in |- *; unfold n in |- *; apply pos_compact_nat; auto. intros. apply leEq_less_trans with ((fcp' i (Nat.lt_le_incl _ _ H) [+]e [/]TwoNZ) [*] (cp (S i) H[-]cp i (Nat.lt_le_incl _ _ H))). 2: apply mult_resp_less. 3: apply compact_less. 2: apply plus_resp_less_lft. 2: apply pos_div_two'; assumption. rstepl (fcp' i (Nat.lt_le_incl _ _ H) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H)) [+] (fcp _ H[-]fcp _ (Nat.lt_le_incl _ _ H) [-] fcp' i (Nat.lt_le_incl _ _ H) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H)))). eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply ring_distl_unfolded. apply plus_resp_leEq_lft. apply leEq_wdr with (e [/]TwoNZ[*]AbsIR (cp (S i) H[-]cp i (Nat.lt_le_incl _ _ H))). 2: apply mult_wd. 2: algebra. 2: apply AbsIR_eq_x. 2: apply less_leEq; apply compact_less. eapply leEq_transitive. apply leEq_AbsIR. unfold fcp, fcp' in |- *; apply Hf. unfold I in |- *; apply compact_part_hyp. unfold I in |- *; apply compact_part_hyp. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_minus. apply leEq_transitive with d. 2: unfold d in |- *; apply Min_leEq_lft. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply compact_leEq. apply less_leEq; apply compact_less. Qed. Let Rolle_lemma5 : {i : nat | {H : i <= n | [--]e [<] fcp' _ H}}. Proof. elim Rolle_lemma4; intros i Hi; elim Hi; clear Hi; intros Hi Hi'. exists i; exists (Nat.lt_le_incl _ _ Hi). astepl ([0][-]e); apply shift_minus_less. eapply mult_cancel_less. 2: eapply less_wdl. 2: apply Hi'. 2: algebra. apply compact_less. Qed. Let Rolle_lemma6 : {i : nat | {H : i < n | (fcp' _ (Nat.lt_le_incl _ _ H) [-]e) [*] (cp (S i) H[-]cp i (Nat.lt_le_incl _ _ H)) [<] [0]}}. Proof. apply negative_Sumx with (f := fun (i : nat) (H : i < n) => (fcp' _ (Nat.lt_le_incl _ _ H) [-]e) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H))). red in |- *; do 3 intro. rewrite H; intros. unfold fcp' in |- *; algebra. apply less_wdr with (Sumx (fun (i : nat) (H : i < n) => fcp _ H[-]fcp _ (Nat.lt_le_incl _ _ H))). 2: apply Rolle_lemma1. apply Sumx_resp_less. apply less_nring with (IR:COrdField); simpl in |- *; unfold n in |- *; apply pos_compact_nat; auto. intros. apply less_leEq_trans with ((fcp' _ (Nat.lt_le_incl _ _ H) [-]e [/]TwoNZ) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H))). apply mult_resp_less. 2: apply compact_less. unfold cg_minus in |- *; apply plus_resp_less_lft. apply inv_resp_less; apply pos_div_two'; assumption. rstepr (fcp' _ (Nat.lt_le_incl _ _ H) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H)) [+] [--] [--] (fcp _ H[-]fcp _ (Nat.lt_le_incl _ _ H) [-] fcp' _ (Nat.lt_le_incl _ _ H) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H)))). rstepl (fcp' _ (Nat.lt_le_incl _ _ H) [*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H)) [-] e [/]TwoNZ[*] (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H))). unfold cg_minus at 1 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq; apply leEq_wdr with (e [/]TwoNZ[*]AbsIR (cp _ H[-]cp _ (Nat.lt_le_incl _ _ H))). 2: apply mult_wd. 2: algebra. 2: apply AbsIR_eq_x. 2: apply less_leEq; apply compact_less. eapply leEq_transitive. apply inv_leEq_AbsIR. unfold fcp, fcp' in |- *; apply Hf. unfold I in |- *; apply compact_part_hyp. unfold I in |- *; apply compact_part_hyp. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_minus. apply leEq_transitive with d. 2: unfold d in |- *; apply Min_leEq_lft. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply compact_leEq. apply less_leEq; apply compact_less. Qed. Let Rolle_lemma7 : {i : nat | {H : i <= n | fcp' _ H [<] e}}. Proof. elim Rolle_lemma6; intros i Hi; elim Hi; clear Hi; intros Hi Hi'. exists i; exists (Nat.lt_le_incl _ _ Hi). astepr (e[+][0]); apply shift_less_plus'. eapply mult_cancel_less. 2: eapply less_wdr. 2: apply Hi'. 2: algebra. apply shift_less_minus. astepl (cp _ (Nat.lt_le_incl _ _ Hi)). unfold compact_part in |- *. apply plus_resp_less_lft. apply mult_resp_less. simpl in |- *; apply less_plusOne. apply div_resp_pos. 2: apply shift_less_minus; astepl a; auto. apply pos_compact_nat; auto. Qed. Let j := ProjT1 Rolle_lemma5. Let Hj := ProjT1 (ProjT2 Rolle_lemma5). Let Hj' : [--]e [<] fcp' _ Hj. Proof. exact (ProjT2 (ProjT2 Rolle_lemma5)). Qed. Let k := ProjT1 Rolle_lemma7. Let Hk := ProjT1 (ProjT2 Rolle_lemma7). Let Hk' : fcp' _ Hk [<] e. Proof. exact (ProjT2 (ProjT2 Rolle_lemma7)). Qed. Let Rolle_lemma8 : forall (i : nat) (H : i <= n), AbsIR (fcp' _ H) [<] e or e [/]TwoNZ [<] AbsIR (fcp' _ H). Proof. intros. cut (e [/]TwoNZ [<] AbsIR (fcp' _ H) or AbsIR (fcp' _ H) [<] e). intro H0; inversion_clear H0; [ right | left ]; assumption. apply less_cotransitive_unfolded. apply pos_div_two'; assumption. Qed. Let Rolle_lemma9 : {m : nat | {Hm : m <= n | AbsIR (fcp' _ Hm) [<] e}} or (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)). Proof. set (P := fun (i : nat) (H : i <= n) => AbsIR (fcp' _ H) [<] e) in *. set (Q := fun (i : nat) (H : i <= n) => e [/]TwoNZ [<] AbsIR (fcp' _ H)) in *. apply finite_or_elim with (P := P) (Q := Q). red in |- *. intros i i' Hii'; rewrite Hii'; intros Hi Hi' HP. red in |- *; red in HP. eapply less_wdl. apply HP. apply AbsIR_wd; unfold fcp' in |- *; algebra. red in |- *. intros i i' Hii'; rewrite Hii'; intros Hi Hi' HQ. red in |- *; red in HQ. eapply less_wdr. apply HQ. apply AbsIR_wd; unfold fcp' in |- *; algebra. apply Rolle_lemma8. Qed. Let Rolle_lemma10 : {m : nat | {Hm : m <= n | AbsIR (fcp' _ Hm) [<] e}} -> {x : IR | I x | forall Hx, AbsIR (F' x Hx) [<=] e}. Proof. intro H. elim H; intros m Hm; elim Hm; clear H Hm; intros Hm Hm'. exists (cp _ Hm). red in |- *; apply compact_part_hyp. intro; apply less_leEq; eapply less_wdl. apply Hm'. apply AbsIR_wd; unfold fcp' in |- *; algebra. Qed. Let Rolle_lemma11 : (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)) -> (forall H : 0 <= n, fcp' _ H [<] [--] (e [/]TwoNZ)) -> forall (i : nat) (H : i <= n), fcp' _ H [<] [0]. Proof. intros H H0. cut (forall H : 0 <= n, fcp' _ H [<] [0]). intro. simple induction i. assumption. intros i' Hrec HSi'. astepr (e [/]TwoNZ[-]e [/]TwoNZ). apply shift_less_minus. cut (i' <= n). 2: auto with arith. intro Hi'. apply less_leEq_trans with (fcp' _ HSi'[-]fcp' _ Hi'). unfold cg_minus in |- *; apply plus_resp_less_lft. cut (e [/]TwoNZ [<] fcp' _ Hi' or fcp' _ Hi' [<] [--] (e [/]TwoNZ)). intro H2. elim H2; clear H2; intro H3. exfalso. cut (e [/]TwoNZ [<] [0]). apply less_antisymmetric_unfolded. apply pos_div_two; assumption. eapply less_transitive_unfolded; [ apply H3 | apply Hrec ]. astepl ( [--][--] (e [/]TwoNZ)); apply inv_resp_less; assumption. cut (e [/]TwoNZ [<] AbsIR (fcp' _ Hi')). 2: exact (H i' Hi'). intro H2. apply less_AbsIR. apply pos_div_two; assumption. assumption. eapply leEq_transitive. apply leEq_AbsIR. unfold fcp' in |- *; apply Hf'. red in |- *; apply compact_part_hyp. red in |- *; apply compact_part_hyp. apply leEq_transitive with d. 2: unfold d in |- *; apply Min_leEq_rht. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply compact_leEq. apply less_leEq; apply compact_less. intro. eapply less_transitive_unfolded. apply (H0 H1). astepr ( [--]ZeroR); apply inv_resp_less; apply pos_div_two; assumption. Qed. Let Rolle_lemma12 : (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)) -> (forall H : 0 <= n, e [/]TwoNZ [<] fcp' _ H) -> forall (i : nat) (H : i <= n), [0] [<] fcp' _ H. Proof. intros H H0. cut (forall H : 0 <= n, [0] [<] fcp' _ H). intro. simple induction i. assumption. intros i' Hrec HSi'. astepl ( [--]ZeroR); astepr ( [--][--] (fcp' _ HSi')); apply inv_resp_less. astepr (e [/]TwoNZ[-]e [/]TwoNZ). apply shift_less_minus'. astepl (e [/]TwoNZ[-]fcp' _ HSi'). cut (i' <= n). 2: auto with arith. intro Hi'. apply less_leEq_trans with (fcp' _ Hi'[-]fcp' _ HSi'). unfold cg_minus in |- *; apply plus_resp_less_rht. cut (e [/]TwoNZ [<] fcp' _ Hi' or fcp' _ Hi' [<] [--] (e [/]TwoNZ)). intro H2; elim H2; clear H2; intro H3. assumption. exfalso. cut ([0] [<] [--] (e [/]TwoNZ)). apply less_antisymmetric_unfolded. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_div_two; assumption. eapply less_transitive_unfolded; [ apply (Hrec Hi') | apply H3 ]. cut (e [/]TwoNZ [<] AbsIR (fcp' _ Hi')). 2: exact (H i' Hi'). intro. apply less_AbsIR. apply pos_div_two; assumption. assumption. eapply leEq_transitive. apply leEq_AbsIR. unfold fcp' in |- *; apply Hf'. red in |- *; apply compact_part_hyp. red in |- *; apply compact_part_hyp. apply leEq_transitive with d. 2: unfold d in |- *; apply Min_leEq_rht. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply compact_leEq. apply less_leEq; apply compact_less. intro. eapply less_transitive_unfolded. 2: apply (H0 H1). apply pos_div_two; assumption. Qed. Let Rolle_lemma13 : (forall (i : nat) (H : i <= n), fcp' _ H [<] [0]) or (forall (i : nat) (H : i <= n), [0] [<] fcp' _ H) -> {x : IR | I x | forall Hx, AbsIR (F' x Hx) [<=] e}. Proof. intro H; elim H; clear H; intro H0. exists (cp _ Hj). red in |- *; apply compact_part_hyp. intro; simpl in |- *; unfold ABSIR in |- *; apply Max_leEq. apply less_leEq; apply less_transitive_unfolded with ZeroR. eapply less_wdl. apply (H0 _ Hj). unfold fcp' in |- *; algebra. assumption. astepr ( [--][--]e); apply inv_resp_leEq. apply less_leEq; eapply less_wdr. apply Hj'. unfold fcp' in |- *; algebra. exists (cp _ Hk). red in |- *; apply compact_part_hyp. intros. simpl in |- *; unfold ABSIR in |- *; apply Max_leEq. apply less_leEq; eapply less_wdl. apply Hk'. unfold fcp' in |- *; algebra. apply less_leEq; apply less_transitive_unfolded with ZeroR. astepr ( [--]ZeroR); apply inv_resp_less; eapply less_wdr. apply (H0 _ Hk). unfold fcp' in |- *; rational. assumption. Qed. Let Rolle_lemma15 : (forall (i : nat) (H : i <= n), e [/]TwoNZ [<] AbsIR (fcp' _ H)) -> fcp' _ (Nat.le_0_l n) [<] [--] (e [/]TwoNZ) or e [/]TwoNZ [<] fcp' _ (Nat.le_0_l n). Proof. intro H. cut (e [/]TwoNZ [<] fcp' _ (Nat.le_0_l n) or fcp' _ (Nat.le_0_l n) [<] [--] (e [/]TwoNZ)). intro H0; inversion_clear H0; [ right | left ]; assumption. apply less_AbsIR. apply pos_div_two; assumption. apply H. Qed. (* end hide *) Theorem Rolle : {x : IR | I x | forall Hx, AbsIR (F' x Hx) [<=] e}. Proof. elim Rolle_lemma9. exact Rolle_lemma10. intro. apply Rolle_lemma13. elim (Rolle_lemma15 b0). left; apply Rolle_lemma11. assumption. intro. eapply less_wdl. apply a0. unfold fcp' in |- *; algebra. right; apply Rolle_lemma12. assumption. intro. eapply less_wdr. apply b1. unfold fcp' in |- *; algebra. Qed. End Rolle. Section Law_of_the_Mean. (** The following is a simple corollary: *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Variables F F' : PartIR. Hypothesis HF : Derivative_I Hab' F F'. (* begin show *) Hypothesis HA : Dom F a. Hypothesis HB : Dom F b. (* end show *) Lemma Law_of_the_Mean_I : forall e, [0] [<] e -> {x : IR | I x | forall Hx, AbsIR (F b HB[-]F a HA[-]F' x Hx[*] (b[-]a)) [<=] e}. Proof. intros e H. set (h := (FId{-} [-C-]a) {*} [-C-] (F b HB[-]F a HA) {-}F{*} [-C-] (b[-]a)) in *. set (h' := [-C-] (F b HB[-]F a HA) {-}F'{*} [-C-] (b[-]a)) in *. cut (Derivative_I Hab' h h'). intro H0. cut {x : IR | I x | forall Hx, AbsIR (h' x Hx) [<=] e}. intro H1. elim H1; intros x Ix Hx. exists x. assumption. intro. eapply leEq_wdl. apply (Hx (derivative_imp_inc' _ _ _ _ _ H0 x Ix)). apply AbsIR_wd; simpl in |- *; rational. unfold I, Hab in |- *; eapply Rolle with h (derivative_imp_inc _ _ _ _ _ H0 _ (compact_inc_lft _ _ _)) (derivative_imp_inc _ _ _ _ _ H0 _ (compact_inc_rht _ _ _)). assumption. simpl in |- *; rational. assumption. unfold h, h' in |- *; clear h h'. New_Deriv. apply Feq_reflexive. apply included_FMinus; Included. apply eq_imp_Feq. apply included_FMinus. apply included_FPlus; Included. Included. Included. intros. simpl in |- *; rational. Qed. End Law_of_the_Mean. Section Corollaries. (** We can also state these theorems without expliciting the derivative of [F]. *) Variables a b : IR. Hypothesis Hab' : a [<] b. (* begin hide *) Let Hab := less_leEq _ _ _ Hab'. (* end hide *) Variable F : PartIR. (* begin show *) Hypothesis HF : Diffble_I Hab' F. (* end show *) Theorem Rolle' : (forall Ha Hb, F a Ha [=] F b Hb) -> forall e, [0] [<] e -> {x : IR | Compact Hab x | forall Hx, AbsIR (PartInt (ProjT1 HF) x Hx) [<=] e}. Proof. intros. unfold Hab in |- *. apply Rolle with F (diffble_imp_inc _ _ _ _ HF _ (compact_inc_lft a b Hab)) (diffble_imp_inc _ _ _ _ HF _ (compact_inc_rht a b Hab)). apply projT2. apply H. assumption. Qed. Lemma Law_of_the_Mean'_I : forall HA HB e, [0] [<] e -> {x : IR | Compact Hab x | forall Hx, AbsIR (F b HB[-]F a HA[-]PartInt (ProjT1 HF) x Hx[*] (b[-]a)) [<=] e}. Proof. intros. unfold Hab in |- *. apply Law_of_the_Mean_I. apply projT2. assumption. Qed. End Corollaries. Section Generalizations. (** The mean law is more useful if we abstract [a] and [b] from the context---allowing them in particular to be equal. In the case where [F(a) [=] F(b)] we get Rolle's theorem again, so there is no need to state it also in this form. %\begin{convention}% Assume [I] is a proper interval, [F,F':PartIR]. %\end{convention}% *) Variable I : interval. Hypothesis pI : proper I. Variables F F' : PartIR. (* begin show *) Hypothesis derF : Derivative I pI F F'. (* end show *) (* begin hide *) Let incF := Derivative_imp_inc _ _ _ _ derF. Let incF' := Derivative_imp_inc' _ _ _ _ derF. (* end hide *) Theorem Law_of_the_Mean : forall a b, I a -> I b -> forall e, [0] [<] e -> {x : IR | Compact (Min_leEq_Max a b) x | forall Ha Hb Hx, AbsIR (F b Hb[-]F a Ha[-]F' x Hx[*] (b[-]a)) [<=] e}. Proof. intros a b Ha Hb e He. cut (included (Compact (Min_leEq_Max a b)) I). intro H. 2: apply included_interval'; auto. elim (less_cotransitive_unfolded _ _ _ He (AbsIR (F b (incF _ Hb) [-]F a (incF _ Ha) [-]F' a (incF' _ Ha) [*] (b[-]a)))); intros. cut (Min a b [<] Max a b). intro H0. cut (included (Compact (less_leEq _ _ _ H0)) I). intro H1. 2: apply included_interval'; auto. elim (ap_imp_less _ _ _ (Min_less_Max_imp_ap _ _ H0)); intro. cut (included (Compact (less_leEq _ _ _ a1)) I). intro H2. 2: apply included_trans with (Compact (less_leEq _ _ _ H0)); [ apply compact_map2 | apply H1 ]. elim (Law_of_the_Mean_I _ _ a1 _ _ (included_imp_Derivative _ _ _ _ derF _ _ a1 H2) ( incF _ Ha) (incF _ Hb) e He). intros x H3 H4. exists x; auto. apply compact_map2 with (Hab := less_leEq _ _ _ a1); auto. intros. eapply leEq_wdl. apply (H4 Hx). apply AbsIR_wd; algebra. cut (included (Compact (Min_leEq_Max b a)) (Compact (Min_leEq_Max a b))). intro H2. cut (included (Compact (less_leEq _ _ _ b0)) I). intro H3. 2: apply included_trans with (Compact (Min_leEq_Max b a)); [ apply compact_map2 | apply included_trans with (Compact (less_leEq _ _ _ H0)); [ apply H2 | apply H1 ] ]. elim (Law_of_the_Mean_I _ _ b0 _ _ (included_imp_Derivative _ _ _ _ derF _ _ b0 H3) ( incF _ Hb) (incF _ Ha) e He). intros x H4 H5. exists x; auto. apply H2; apply compact_map2 with (Hab := less_leEq _ _ _ b0); auto. intros. eapply leEq_wdl. apply (H5 Hx). eapply eq_transitive_unfolded. apply AbsIR_minus. apply AbsIR_wd; rational. intros x H2. elim H2; clear H2; intros H3 H4; split. eapply leEq_wdl; [ apply H3 | apply Min_comm ]. eapply leEq_wdr; [ apply H4 | apply Max_comm ]. apply ap_imp_Min_less_Max. cut (Part _ _ (incF b Hb) [-]Part _ _ (incF a Ha) [#] [0] or Part _ _ (incF' a Ha) [*] (b[-]a) [#] [0]). intro H0. elim H0; clear H0; intro H1. apply pfstrx with F (incF a Ha) (incF b Hb). apply ap_symmetric_unfolded; apply zero_minus_apart; auto. apply ap_symmetric_unfolded; apply zero_minus_apart. eapply cring_mult_ap_zero_op; apply H1. apply cg_minus_strext. astepr ZeroR. apply AbsIR_cancel_ap_zero. apply Greater_imp_ap; auto. exists a. apply compact_Min_lft. intros; apply less_leEq. eapply less_wdl. apply b0. apply AbsIR_wd; algebra. Qed. (** We further generalize the mean law by writing as an explicit bound. *) Theorem Law_of_the_Mean_Abs_ineq : forall a b, I a -> I b -> forall c, (forall x, Compact (Min_leEq_Max a b) x -> forall Hx, AbsIR (F' x Hx) [<=] c) -> forall Ha Hb, AbsIR (F b Hb[-]F a Ha) [<=] c[*]AbsIR (b[-]a). Proof. intros a b Ia Ib c Hc Ha Hb. astepr (c[*]AbsIR (b[-]a) [+][0]). apply shift_leEq_plus'. apply approach_zero_weak. intros e H. elim Law_of_the_Mean with a b e; auto. intros x H0 H1. cut (Dom F' x). intro H2. eapply leEq_transitive. 2: apply (H1 Ha Hb H2). eapply leEq_transitive. 2: apply triangle_IR_minus'. unfold cg_minus at 1 4 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. stepl (AbsIR (F' x H2)[*]AbsIR(b[-]a)). 2:apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. auto. apply AbsIR_nonneg. apply (Derivative_imp_inc' _ _ _ _ derF). exact (included_interval I a b Ia Ib (Min_leEq_Max a b) x H0). Qed. Theorem Law_of_the_Mean_ineq : forall a b, I a -> I b -> forall c, (forall x, Compact (Min_leEq_Max a b) x -> forall Hx, AbsIR (F' x Hx) [<=] c) -> forall Ha Hb, F b Hb[-]F a Ha [<=] c[*]AbsIR (b[-]a). Proof. intros. eapply leEq_transitive. apply leEq_AbsIR. apply Law_of_the_Mean_Abs_ineq; assumption. Qed. End Generalizations. corn-8.20.0/ftc/StrongIVT.v000066400000000000000000000502131473720167500153610ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.WeakIVT. Require Export CoRN.ftc.CalculusTheorems. Section IVT'. (** ** Strong IVT for partial functions The IVT can be generalized to arbitrary partial functions; in the first part, we will simply do that, repeating the previous construction. The same notations and conventions apply as before. *) Variables a b : IR. Hypothesis Hab' : a [<] b. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. Let I' := olor a b. (* end hide *) Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. (* begin hide *) Let incF := contin_imp_inc _ _ _ _ contF. (* end hide *) (* begin show *) Hypothesis incrF : forall x y, I x -> I y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy. (* end show *) (* begin hide *) Let Ha := compact_inc_lft _ _ Hab. Let Hb := compact_inc_rht _ _ Hab. Let HFab' := incrF _ _ Ha Hb Hab' (incF _ Ha) (incF _ Hb). (* end hide *) (* begin show *) Variable z : IR. Hypothesis Haz : F a (incF _ Ha) [<] z. Hypothesis Hzb : z [<] F b (incF _ Hb). (* end show *) Lemma IVT'_seq_lemma : forall (xy : IR ** IR) (x:=fstT xy) (y:=sndT xy) (Hxy : (I x) ** (I y)) (Hx:=fstT Hxy) (Hy:=sndT Hxy), x [<] y -> F x (incF _ Hx) [<] z and z [<] F y (incF _ Hy) -> {xy0 : IR ** IR | let x0 := fstT xy0 in let y0 := sndT xy0 in {Hxy0 : (I x0) ** (I y0) | let Hx0 := fstT Hxy0 in let Hy0 := sndT Hxy0 in x0 [<] y0 and F x0 (incF _ Hx0) [<] z and z [<] F y0 (incF _ Hy0) | y0[-]x0 [=] Two [/]ThreeNZ[*] (y[-]x) /\ x [<=] x0 /\ y0 [<=] y}}. Proof. (* begin hide *) do 6 intro. intros H H0. set (x1 := (Two[*]x[+]y) [/]ThreeNZ) in *. set (y1 := (x[+]Two[*]y) [/]ThreeNZ) in *. cut (x1 [<] y1). intro H1. 2: unfold x1, y1 in |- *; apply lft_rht; auto. cut (I x1). intro H2. cut (I y1). intro H3. cut (F x1 (incF _ H2) [<] F y1 (incF _ H3)); [ intro H4 | auto ]. elim (less_cotransitive_unfolded _ _ _ H4 z); intros. exists (pairT x1 y); exists (pairT H2 Hy); simpl in |- *; repeat split; auto. apply less_transitive_unfolded with y1; unfold x1, y1 in |- *; [ apply lft_rht | apply rht_b ]; auto. auto. elim H0; auto. unfold x1 in |- *; apply smaller_rht. unfold x1 in |- *; apply less_leEq; apply a_lft; auto. apply leEq_reflexive. exists (pairT x y1); exists (pairT Hx H3); simpl in |- *; repeat split; auto. apply less_transitive_unfolded with x1; unfold x1, y1 in |- *; [ apply a_lft | apply lft_rht ]; auto. elim H0; auto. unfold y1 in |- *; apply smaller_lft; auto. apply leEq_reflexive. apply less_leEq; unfold y1 in |- *; apply rht_b; auto. unfold y1 in |- *; inversion_clear Hx; inversion_clear Hy; split. apply leEq_transitive with x; auto. apply less_leEq; apply less_transitive_unfolded with x1; unfold x1 in |- *; [ apply a_lft | apply lft_rht ]; auto. apply leEq_transitive with y; auto. apply less_leEq; apply rht_b; auto. unfold x1 in |- *; inversion_clear Hx; inversion_clear Hy; split. apply leEq_transitive with x; auto. apply less_leEq; apply a_lft; auto. apply leEq_transitive with y; auto. apply less_leEq; apply less_transitive_unfolded with y1; unfold y1 in |- *; [ apply lft_rht | apply rht_b ]; auto. Qed. (* end hide *) Record IVT'_aux_seq_type : Type := {IVT'seq1 : IR; IVT'seq2 : IR; IVT'H1 : I IVT'seq1; IVT'H2 : I IVT'seq2; IVT'prf : IVT'seq1 [<] IVT'seq2; IVT'z1 : F IVT'seq1 (incF _ IVT'H1) [<] z; IVT'z2 : z [<] F IVT'seq2 (incF _ IVT'H2)}. Definition IVT'_iter : IVT'_aux_seq_type -> IVT'_aux_seq_type. Proof. intro Haux; elim Haux; intros. elim (IVT'_seq_lemma (pairT IVT'seq3 IVT'seq4) (pairT IVT'H3 IVT'H4) IVT'prf0 (IVT'z3, IVT'z4)). intro x; elim x; simpl in |- *; clear x; intros. elim p. intro x; elim x; simpl in |- *; clear x; intros. inversion_clear p0. inversion_clear X0. inversion_clear q. inversion_clear H0. apply Build_IVT'_aux_seq_type with a0 b0 a1 b1; auto. Defined. Definition IVT'_seq : nat -> IVT'_aux_seq_type. Proof. intro n; induction n as [| n Hrecn]. apply Build_IVT'_aux_seq_type with a b Ha Hb; auto. apply (IVT'_iter Hrecn). Defined. Definition a'_seq n := IVT'seq1 (IVT'_seq n). Definition b'_seq n := IVT'seq2 (IVT'_seq n). Definition a'_seq_I n : I (a'_seq n) := IVT'H1 (IVT'_seq n). Definition b'_seq_I n : I (b'_seq n) := IVT'H2 (IVT'_seq n). Lemma a'_seq_less_b'_seq : forall n, a'_seq n [<] b'_seq n. Proof. exact (fun n => IVT'prf (IVT'_seq n)). Qed. Lemma a'_seq_less_z : forall n, F _ (incF _ (a'_seq_I n)) [<] z. Proof. exact (fun n => IVT'z1 (IVT'_seq n)). Qed. Lemma z_less_b'_seq : forall n, z [<] F _ (incF _ (b'_seq_I n)). Proof. exact (fun n => IVT'z2 (IVT'_seq n)). Qed. Lemma a'_seq_mon : forall i : nat, a'_seq i [<=] a'_seq (S i). Proof. intro. unfold a'_seq in |- *. simpl in |- *. elim (IVT'_seq i); simpl in |- *; intros. elim IVT'_seq_lemma; simpl in |- *; intro. elim x; simpl in |- *; clear x; intros. elim p; clear p; intro. elim x; simpl in |- *; clear x; intros. case q; clear q; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. elim p; clear p; simpl in |- *; intros. elim b2; clear b2; simpl in |- *; auto. Qed. Lemma b'_seq_mon : forall i : nat, b'_seq (S i) [<=] b'_seq i. Proof. intro. unfold b'_seq in |- *. simpl in |- *. elim (IVT'_seq i); simpl in |- *; intros. elim IVT'_seq_lemma; simpl in |- *; intro. elim x; simpl in |- *; clear x; intros. elim p; clear p; intro. elim x; simpl in |- *; clear x; intros. case q; clear q; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. elim p; clear p; simpl in |- *; intros. elim b2; clear b2; simpl in |- *; auto. Qed. Lemma a'_seq_b'_seq_dist_n : forall n, b'_seq (S n) [-]a'_seq (S n) [=] Two [/]ThreeNZ[*] (b'_seq n[-]a'_seq n). Proof. intro. unfold a'_seq, b'_seq in |- *. simpl in |- *. elim (IVT'_seq n); simpl in |- *; intros. elim IVT'_seq_lemma; simpl in |- *; intro. elim x; simpl in |- *; clear x; intros. elim p; clear p; intro. elim x; simpl in |- *; clear x; intros. case q; clear q; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. elim p; clear p; simpl in |- *; intros. elim b2; clear b2; simpl in |- *; auto. Qed. Lemma a'_seq_b'_seq_dist : forall n, b'_seq n[-]a'_seq n [=] (Two [/]ThreeNZ) [^]n[*] (b[-]a). Proof. simple induction n. simpl in |- *; algebra. clear n; intros. astepr (Two [/]ThreeNZ[*] (Two [/]ThreeNZ) [^]n[*] (b[-]a)). astepr (Two [/]ThreeNZ[*] ((Two [/]ThreeNZ) [^]n[*] (b[-]a))). astepr (Two [/]ThreeNZ[*] (b'_seq n[-]a'_seq n)). apply a'_seq_b'_seq_dist_n. Qed. Lemma a'_seq_Cauchy : Cauchy_prop a'_seq. Proof. intros e H. elim (intervals_small' a b e H); intros i Hi. exists i; intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. 2: apply Hi. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (a'_seq i). 2: apply local_mon'_imp_mon'; auto; exact a'_seq_mon. eapply leEq_wdr. 2: apply a'_seq_b'_seq_dist. apply minus_resp_leEq. apply less_leEq; apply a_b'. exact a'_seq_mon. exact b'_seq_mon. exact a'_seq_less_b'_seq. Qed. Lemma b'_seq_Cauchy : Cauchy_prop b'_seq. Proof. intros e H. elim (intervals_small' a b e H); intros i Hi. exists i; intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. 2: apply Hi. eapply leEq_wdl. 2: apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (b'_seq m). 2: astepl ( [--][--] (b'_seq m)); astepr ( [--][--] (b'_seq i)). 2: apply inv_resp_leEq; apply local_mon'_imp_mon' with (f := fun n => [--] (b'_seq n)); auto. 2: intro; apply inv_resp_leEq; apply b'_seq_mon. eapply leEq_wdr. 2: apply a'_seq_b'_seq_dist. unfold cg_minus in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. apply less_leEq; apply a_b'. exact a'_seq_mon. exact b'_seq_mon. exact a'_seq_less_b'_seq. Qed. Let xa := Lim (Build_CauchySeq _ _ a'_seq_Cauchy). Let xb := Lim (Build_CauchySeq _ _ b'_seq_Cauchy). Lemma a'_seq_b'_seq_lim : xa [=] xb. Proof. unfold xa, xb in |- *; clear xa xb. apply cg_inv_unique_2. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply Lim_minus. simpl in |- *. apply Limits_unique. simpl in |- *. intros eps H. elim (intervals_small' a b eps H); intros i Hi. exists i; intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. 2: apply Hi. eapply leEq_wdl. 2: apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (a'_seq m[-]b'_seq m). 2: apply shift_minus_leEq; astepr (b'_seq m). 2: apply less_leEq; apply a'_seq_less_b'_seq. eapply leEq_wdr. 2: apply a'_seq_b'_seq_dist. rstepl (b'_seq m[-]a'_seq m). unfold cg_minus in |- *; apply plus_resp_leEq_both. astepl ( [--][--] (b'_seq m)); astepr ( [--][--] (b'_seq i)). apply inv_resp_leEq; apply local_mon'_imp_mon' with (f := fun n => [--] (b'_seq n)); auto. intro; apply inv_resp_leEq; apply b'_seq_mon. apply inv_resp_leEq; apply local_mon'_imp_mon'; auto; exact a'_seq_mon. Qed. Lemma xa'_in_interval : I xa. Proof. split. unfold xa in |- *. apply leEq_seq_so_leEq_Lim. simpl in |- *. intro; elim (a'_seq_I i); auto. unfold xa in |- *. apply seq_leEq_so_Lim_leEq. simpl in |- *. intro; elim (a'_seq_I i); auto. Qed. Lemma IVT'_I : {x : IR | I' x | forall Hx, F x Hx [=] z}. Proof. elim (IVT_I a b Hab' Hab F contF) with z; try apply less_leEq; auto. intros x H H0. exists x; auto. elim H; intros; split; apply leEq_not_eq; auto. apply pfstrx with F (incF _ Ha) (incF _ H). apply less_imp_ap; astepr z; auto. apply pfstrx with F (incF _ H) (incF _ Hb). apply less_imp_ap; astepl z; auto. Qed. End IVT'. (** ** Other formulations We now generalize the various statements of the intermediate value theorem to more widely applicable forms. *) Lemma Weak_IVT : forall I F, Continuous I F -> forall a b Ha Hb (HFab : F a Ha [<] F b Hb), I a -> I b -> forall e, [0] [<] e -> forall y, Compact (less_leEq _ _ _ HFab) y -> {x : IR | Compact (Min_leEq_Max a b) x | forall Hx, AbsIR (F x Hx[-]y) [<=] e}. Proof. intros I F H a b Ha Hb HFab H0 H1 e H2 y H3. set (H5 := less_imp_ap _ _ _ HFab) in *. set (H6 := pfstrx _ _ _ _ _ _ H5) in *. elim (ap_imp_less _ _ _ H6); clear H6 H5; intro. cut (Continuous_I (Min_leEq_Max a b) F). intro H4. 2: apply included_imp_Continuous with I; auto; apply included_interval; auto. set (incF := contin_imp_inc _ _ _ _ H4) in *. cut (Min a b [=] a). cut (Max a b [=] b); intros. 2: apply leEq_imp_Max_is_rht; apply less_leEq; auto. 2: apply leEq_imp_Min_is_lft; apply less_leEq; auto. set (Ha' := incF _ (compact_inc_lft _ _ (Min_leEq_Max a b))) in *. set (Hb' := incF _ (compact_inc_rht _ _ (Min_leEq_Max a b))) in *. cut (F _ Ha' [<] F _ Hb'). intro H7. apply Weak_IVT_ap_lft with (HFab := H7); auto. apply compact_wd' with (Hab := less_leEq _ _ _ HFab); algebra. astepl (F a Ha); astepr (F b Hb); auto. cut (Continuous_I (Min_leEq_Max b a) F). intro H4. 2: apply included_imp_Continuous with I; auto; apply included_interval; auto. set (incF := contin_imp_inc _ _ _ _ H4) in *. cut (Min a b [=] b). cut (Max a b [=] a); intros. 2: eapply eq_transitive_unfolded; [ apply Max_comm | apply leEq_imp_Max_is_rht; apply less_leEq; auto ]. 2: eapply eq_transitive_unfolded; [ apply Min_comm | apply leEq_imp_Min_is_lft; apply less_leEq; auto ]. set (Ha' := incF _ (compact_inc_lft _ _ (Min_leEq_Max b a))) in *. set (Hb' := incF _ (compact_inc_rht _ _ (Min_leEq_Max b a))) in *. cut (F _ Hb' [<] F _ Ha'). intro H7. elim (Weak_IVT_ap_rht _ _ _ _ H4 _ _ H7 _ H2 y); auto. intro x; intros. exists x; auto. apply compact_wd' with (Hab := Min_leEq_Max b a); [ apply Min_comm | apply Max_comm | auto ]. apply compact_wd' with (Hab := less_leEq _ _ _ HFab); algebra. apply pfwdef; astepl (Max a b); apply Max_comm. apply pfwdef; astepl (Min a b); apply Min_comm. apply less_wdl with (F a Ha). apply less_wdr with (F b Hb). auto. apply pfwdef; astepl (Min a b); apply Min_comm. apply pfwdef; astepl (Max a b); apply Max_comm. Qed. Lemma IVT_inc : forall I F, Continuous I F -> forall a b Ha Hb, F a Ha [#] F b Hb -> I a -> I b -> (forall x y, I x -> I y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) -> forall y, Compact (Min_leEq_Max (F a Ha) (F b Hb)) y -> {x : IR | Compact (Min_leEq_Max a b) x | forall Hx, F x Hx [=] y}. Proof. intros I F H a b Ha Hb H0 H1 H2 H3 y H4. set (H5 := pfstrx _ _ _ _ _ _ H0) in *. elim (ap_imp_less _ _ _ H5); clear H5; intro. cut (Continuous_I (Min_leEq_Max a b) F). intro H5. 2: apply included_imp_Continuous with I; auto; apply included_interval; auto. cut (Min a b [=] a); [ intro | apply leEq_imp_Min_is_lft; apply less_leEq; auto ]. cut (Max a b [=] b); [ intro | apply leEq_imp_Max_is_rht; apply less_leEq; auto ]. cut (forall H H', F (Min a b) H [<] F (Max a b) H'); intros. 2: apply H3; auto. 2: apply iprop_wd with a; algebra. 2: apply iprop_wd with b; algebra. 2: astepl a; astepr b; auto. elim H4; intros. apply IVT_I with H5. apply ap_imp_Min_less_Max; apply less_imp_ap; auto. intros. apply H3; auto. apply (included_interval _ _ _ H1 H2 (Min_leEq_Max a b)); auto. apply (included_interval _ _ _ H1 H2 (Min_leEq_Max a b)); auto. eapply leEq_wdl. apply a1. astepr (F a Ha); apply leEq_imp_Min_is_lft; apply less_leEq; auto. eapply leEq_wdr. apply b0. astepr (F b Hb); apply leEq_imp_Max_is_rht; apply less_leEq; auto. cut (Continuous_I (Min_leEq_Max b a) F). intro H5. 2: apply included_imp_Continuous with I; auto; apply included_interval; auto. cut (Min b a [=] b); [ intro | apply leEq_imp_Min_is_lft; apply less_leEq; auto ]. cut (Max b a [=] a); [ intro | apply leEq_imp_Max_is_rht; apply less_leEq; auto ]. cut (forall H H', F (Min b a) H [<] F (Max b a) H'). intro H8. 2: apply H3; auto. 2: apply iprop_wd with b; algebra. 2: apply iprop_wd with a; algebra. 2: astepl b; astepr a; auto. elim H4; intros. elim IVT_I with (contF := H5) (z := y); intros; auto. exists x; auto. apply compact_wd' with (Hab := Min_leEq_Max b a); auto. apply Min_comm. apply Max_comm. astepl b; astepr a; auto. apply H3; auto. apply (included_interval _ _ _ H2 H1 (Min_leEq_Max b a)); auto. apply (included_interval _ _ _ H2 H1 (Min_leEq_Max b a)); auto. eapply leEq_wdl. apply a0. astepr (F b Hb); eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft; apply less_leEq; auto. eapply leEq_wdr. apply b1. astepr (F a Ha); eapply eq_transitive_unfolded. apply Max_comm. apply leEq_imp_Max_is_rht; apply less_leEq; auto. Qed. Transparent Min. Lemma IVT_dec : forall I F, Continuous I F -> forall a b Ha Hb, F a Ha [#] F b Hb -> I a -> I b -> (forall x y, I x -> I y -> x [<] y -> forall Hx Hy, F y Hy [<] F x Hx) -> forall y, Compact (Min_leEq_Max (F a Ha) (F b Hb)) y -> {x : IR | Compact (Min_leEq_Max a b) x | forall Hx, F x Hx [=] y}. Proof. intros. try rename X4 into H. elim IVT_inc with (I := I) (F := {--}F) (a := a) (b := b) (y := [--]y) (Ha := Ha) (Hb := Hb); auto. intros x H5 H6. exists x; auto. intro. astepl ( [--][--] (F x Hx)); astepr ( [--][--]y). apply un_op_wd_unfolded; simpl in H6; apply H6. Contin. simpl in |- *; apply un_op_strext_unfolded with (cg_inv (c:=IR)). astepl (F a Ha); astepr (F b Hb); auto. intros; simpl in |- *; apply inv_resp_less; auto. inversion_clear H as (H0,H1); split; simpl in |- *; unfold MIN. apply inv_resp_leEq. eapply leEq_wdr. apply H1. apply Max_wd_unfolded; algebra. astepr ( [--][--] (Max [--] (F a Ha) [--] (F b Hb))). apply inv_resp_leEq; auto. Qed. Lemma IVT'_inc : forall I F, Continuous I F -> forall a b Ha Hb, F a Ha [#] F b Hb -> I a -> I b -> (forall x y, I x -> I y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy) -> forall y, olor (Min (F a Ha) (F b Hb)) (Max (F a Ha) (F b Hb)) y -> {x : IR | olor (Min a b) (Max a b) x | forall Hx, F x Hx [=] y}. Proof. intros I F H a b Ha Hb H0 H1 H2 H3 y H4. set (H5 := pfstrx _ _ _ _ _ _ H0) in *. elim (ap_imp_less _ _ _ H5); clear H5; intro. cut (Continuous_I (Min_leEq_Max a b) F). intro H5. 2: apply included_imp_Continuous with I; auto; apply included_interval; auto. cut (Min a b [=] a); [ intro | apply leEq_imp_Min_is_lft; apply less_leEq; auto ]. cut (Max a b [=] b); [ intro | apply leEq_imp_Max_is_rht; apply less_leEq; auto ]. cut (forall H H', F (Min a b) H [<] F (Max a b) H'). intro H8. 2: apply H3; auto. 2: apply iprop_wd with a; algebra. 2: apply iprop_wd with b; algebra. 2: astepl a; astepr b; auto. elim H4; intros. apply IVT'_I with (Min_leEq_Max a b) H5. apply ap_imp_Min_less_Max; apply less_imp_ap; auto. intros. apply H3; auto. apply (included_interval _ _ _ H1 H2 (Min_leEq_Max a b)); auto. apply (included_interval _ _ _ H1 H2 (Min_leEq_Max a b)); auto. eapply less_wdl. apply a1. astepr (F a Ha); apply leEq_imp_Min_is_lft; apply less_leEq; auto. eapply less_wdr. apply b0. astepr (F b Hb); apply leEq_imp_Max_is_rht; apply less_leEq; auto. cut (Continuous_I (Min_leEq_Max b a) F). intro H5. 2: apply included_imp_Continuous with I; auto; apply included_interval; auto. cut (Min b a [=] b); [ intro | apply leEq_imp_Min_is_lft; apply less_leEq; auto ]. cut (Max b a [=] a); [ intro | apply leEq_imp_Max_is_rht; apply less_leEq; auto ]. cut (forall H H', F (Min b a) H [<] F (Max b a) H'). intro H8. 2: apply H3; auto. 2: apply iprop_wd with b; algebra. 2: apply iprop_wd with a; algebra. 2: astepl b; astepr a; auto. elim H4; intros. elim IVT'_I with (contF := H5) (z := y); auto. intros x H9 H10; exists x; auto. elim H9; clear H9; intros H11 H12; split. eapply less_wdl; [ apply H11 | apply Min_comm ]. eapply less_wdr; [ apply H12 | apply Max_comm ]. apply ap_imp_Min_less_Max; apply less_imp_ap; auto. intros; apply H3; auto. apply (included_interval _ _ _ H2 H1 (Min_leEq_Max b a)); auto. apply (included_interval _ _ _ H2 H1 (Min_leEq_Max b a)); auto. eapply less_wdl. apply a0. astepr (F b Hb); eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft; apply less_leEq; auto. eapply less_wdr. apply b1. astepr (F a Ha); eapply eq_transitive_unfolded. apply Max_comm. apply leEq_imp_Max_is_rht; apply less_leEq; auto. Qed. Transparent Min. Lemma IVT'_dec : forall I F, Continuous I F -> forall a b Ha Hb, F a Ha [#] F b Hb -> I a -> I b -> (forall x y, I x -> I y -> x [<] y -> forall Hx Hy, F y Hy [<] F x Hx) -> forall y, olor (Min (F a Ha) (F b Hb)) (Max (F a Ha) (F b Hb)) y -> {x : IR | olor (Min a b) (Max a b) x | forall Hx, F x Hx [=] y}. Proof. intros. elim IVT'_inc with (I := I) (F := {--}F) (a := a) (b := b) (y := [--]y) (Ha := Ha) (Hb := Hb); auto. intros x H5 H6. exists x; auto. intro. astepl ( [--][--] (F x Hx)); astepr ( [--][--]y). apply un_op_wd_unfolded; simpl in H6; apply H6. Contin. simpl in |- *; apply un_op_strext_unfolded with (cg_inv (c:=IR)). astepl (F a Ha); astepr (F b Hb); auto. intros; simpl in |- *; apply inv_resp_less; auto. inversion_clear X4; split; simpl in |- *; unfold MIN. apply inv_resp_less. eapply less_wdr. apply X6. apply Max_wd_unfolded; algebra. astepr ( [--][--] (Max [--] (F a Ha) [--] (F b Hb))). apply inv_resp_less; auto. Qed. corn-8.20.0/ftc/Taylor.v000066400000000000000000000346711473720167500150060ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.TaylorLemma. Opaque Min Max N_Deriv. Section More_Taylor_Defs. (** ** General case The generalization to arbitrary intervals just needs a few more definitions. %\begin{convention}% Let [I] be a proper interval, [F:PartIR] and [a,b:IR] be points of [I]. %\end{convention}% *) Variable I : interval. Hypothesis pI : proper I. Variable F : PartIR. (* begin show *) Let deriv_Sn b n Hf := N_Deriv _ pI (S n) F Hf{*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]b{-}FId) {^}n. (* end show *) Variables a b : IR. Hypothesis Ha : I a. Hypothesis Hb : I b. (* begin show *) Let fi n Hf i Hi := N_Deriv _ pI _ _ (le_imp_Diffble_n _ _ _ _ (proj1 (Nat.lt_succ_r i n) Hi) F Hf). Let funct_i n Hf i Hi := [-C-] (fi n Hf i Hi a Ha[/] _[//]nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i. (* end show *) Definition Taylor_Seq' n Hf := FSumx _ (funct_i n Hf). (* begin hide *) Lemma TaylorB : forall n Hf, Dom (Taylor_Seq' n Hf) b. Proof. repeat split. apply FSumx_pred'; repeat split. Qed. (* end hide *) Definition Taylor_Rem n Hf := F b (Diffble_n_imp_inc _ _ _ _ Hf b Hb) [-] Taylor_Seq' n Hf b (TaylorB n Hf). (* begin hide *) Lemma Taylor_Sumx_lemma : forall n x z y y', (forall H, y 0 H [=] z) -> (forall i H H', y' i H' [=] y (S i) H) -> x[-]Sumx (G:=IR) (n:=S n) y [=] x[-]z[-]Sumx (G:=IR) (n:=n) y'. Proof. intro; induction n as [| n Hrecn]. intros; simpl in |- *. astepl (x[-] ([0][+]z)). rational. intros. astepl (x[-] (Sumx (fun i (l : i < S n) => y i (Nat.lt_lt_succ_r _ _ l)) [+] y (S n) (Nat.lt_succ_diag_r (S n)))). rstepl (x[-]Sumx (fun i (l : i < S n) => y i (Nat.lt_lt_succ_r _ _ l)) [-] y (S n) (Nat.lt_succ_diag_r (S n))). astepr (x[-]z[-] (Sumx (fun i (l : i < n) => y' i (Nat.lt_lt_succ_r _ _ l)) [+]y' n (Nat.lt_succ_diag_r n))). rstepr (x[-]z[-]Sumx (fun i (l : i < n) => y' i (Nat.lt_lt_succ_r _ _ l)) [-] y' n (Nat.lt_succ_diag_r n)). algebra. Qed. Lemma Taylor_lemma_ap : forall n Hf Hf' Ha', Taylor_Rem n Hf'[-]deriv_Sn b n Hf a Ha'[*] (b[-]a) [#] [0] -> a [#] b. Proof. intros. rename X into H. set (Hpred := Diffble_n_imp_inc _ _ _ _ Hf') in *. cut (Taylor_Rem n Hf'[-]Part _ _ Ha'[*] (b[-]a) [#] [0][-][0]). 2: astepr ZeroR; auto. clear H; intros. rename X into H. elim (cg_minus_strext _ _ _ _ _ H); clear H; intro H. unfold Taylor_Rem, Taylor_Seq', funct_i in H. cut (Dom (FSumx n (fun i (Hi : i < n) => [-C-] (fi n Hf' (S i) (proj1 (Nat.succ_lt_mono _ _) Hi) a Ha[/] _[//] nring_fac_ap_zero IR (S i)) {*} (FId{-} [-C-]a) {^}S i)) b). 2: apply FSumx_pred'; repeat split. intro H0. cut (F b (Hpred b Hb) [-]F a (Hpred a Ha) [#] [0] or Part _ _ H0 [#] [0]). intro H1. elim H1; clear H H1; intro H. apply pfstrx with (Hx := Hpred a Ha) (Hy := Hpred b Hb). apply ap_symmetric_unfolded; apply zero_minus_apart; auto. cut (ext_fun_seq' (fun i (Hi : i < n) => [-C-] (fi n Hf' (S i) (proj1 (Nat.succ_lt_mono _ _) Hi) a Ha[/] _[//]nring_fac_ap_zero IR (S i)) {*} (FId{-} [-C-]a) {^}S i)). 2: red in |- *; repeat split. intro H1. cut (Sumx (fun i (Hi : i < n) => Part _ _ (FSumx_pred n _ H1 _ H0 i Hi)) [#] Sumx (fun i (Hi : i < n) => [0])). intro H2. 2: eapply ap_wdl_unfolded. 2: eapply ap_wdr_unfolded. 2: apply H. 2: apply eq_symmetric_unfolded; eapply eq_transitive_unfolded; [ apply sumx_const | algebra ]. 2: exact (FSumx_char _ _ _ _ H1). simpl in H2. cut (nat_less_n_fun (fun i (Hi : i < n) => (fi n Hf' (S i) (proj1 (Nat.succ_lt_mono _ _) Hi) a Ha[/] _[//]nring_fac_ap_zero IR (S i)) [*] (nexp IR i (b[+][--]a) [*] (b[+][--]a)))); intros. cut (nat_less_n_fun (fun i (Hi : i < n) => ([0]:IR))); intros. elim (Sumx_strext _ _ _ _ H3 H4 H2); clear H H0 H1 H2 H3 H4; intros N HN. elim HN; clear HN; intros HN H. cut (b[+][--]a [#] [0]). intro H3. 2: eapply cring_mult_ap_zero_op; eapply cring_mult_ap_zero_op; apply H. apply ap_symmetric_unfolded; apply zero_minus_apart; auto. red in |- *; algebra. red in |- *; do 3 intro. rewrite H3; intros; unfold fi in |- *. apply mult_wdl. apply div_wd. 2: algebra. apply Feq_imp_eq with I. apply Derivative_n_unique with pI (S j) F; apply N_Deriv_lemma. auto. apply cg_minus_strext. astepr ZeroR. apply ap_wdl_unfolded with (Part _ _ (Hpred b Hb) [-]Part _ _ (TaylorB n Hf')); auto. unfold Taylor_Seq', funct_i in |- *. cut (ext_fun_seq' (fun i Hi => [-C-] (fi n Hf' i Hi a Ha[/] _[//]nring_fac_ap_zero IR i) {*} (FId{-} [-C-]a) {^}i)). intro H1. apply eq_transitive_unfolded with (Part _ _ (Hpred b Hb) [-] Sumx (fun i Hi => Part _ _ (FSumx_pred _ _ H1 b (TaylorB n Hf') i Hi))). apply cg_minus_wd. algebra. exact (FSumx_char _ _ _ _ H1). cut (ext_fun_seq' (fun i (Hi : i < n) => [-C-] (fi n Hf' (S i) (proj1 (Nat.succ_lt_mono _ _) Hi) a Ha[/] _[//]nring_fac_ap_zero IR (S i)) {*} (FId{-} [-C-]a) {^}S i)). intro H2. apply eq_transitive_unfolded with (Part _ _ (Hpred b Hb) [-]Part _ _ (Hpred a Ha) [-] Sumx (fun i (Hi : i < n) => Part _ _ (FSumx_pred _ _ H2 b H0 i Hi))). 2: apply cg_minus_wd. 2: algebra. 2: apply eq_symmetric_unfolded; exact (FSumx_char _ _ _ _ H2). apply Taylor_Sumx_lemma. intros; simpl in |- *. unfold fi in |- *. rstepr ((Part _ _ (Hpred a Ha) [/] [0][+][1][//]nring_fac_ap_zero IR 0) [*][1]). apply mult_wdl; apply div_wd. 2: algebra. apply Feq_imp_eq with I. apply Derivative_n_unique with pI 0 F. apply N_Deriv_lemma. split; auto. split; auto. intros; simpl in |- *. apply Feq_reflexive; Included. auto. intros; simpl in |- *. apply mult_wdl; apply div_wd. 2: algebra. unfold fi in |- *. apply Feq_imp_eq with I. apply Derivative_n_unique with pI (S i) F; apply N_Deriv_lemma; auto. auto. repeat split. repeat split. apply ap_symmetric_unfolded; apply zero_minus_apart. eapply cring_mult_ap_zero_op; apply H. Qed. (* end hide *) Theorem Taylor' : forall n Hf Hf' e, [0] [<] e -> {c : IR | Compact (Min_leEq_Max a b) c | forall Hc, AbsIR (Taylor_Rem n Hf'[-]deriv_Sn b n Hf c Hc[*] (b[-]a)) [<=] e}. Proof. intros. rename X into H. cut (Dom (deriv_Sn b n Hf) a). intro H0. 2: repeat split. 2: simpl in |- *; auto. elim (less_cotransitive_unfolded _ _ _ H (AbsIR (Taylor_Rem n Hf'[-]Part _ _ H0[*] (b[-]a)))). intros. cut (a [#] b). intro H1. clear a0 H0. cut (Diffble_I_n (ap_imp_Min_less_Max _ _ H1) (S n) F). intro H0. 2: apply included_imp_Diffble_n with I pI; auto. cut (Diffble_I_n (ap_imp_Min_less_Max _ _ H1) n F). intro H2. 2: apply le_imp_Diffble_I with (S n); auto. elim (Taylor_lemma a b H1 F (Diffble_n_imp_inc _ _ _ _ Hf b Hb) e H n H2 H0). intros c H3 H4. exists c; auto. intro. cut (Dom (n_deriv_I _ _ _ _ _ H0{*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]b{-}FId) {^}n) c). intro H5. 2: repeat split. 2: apply n_deriv_inc; auto. eapply leEq_wdl. apply (H4 H5). unfold Taylor_rem, Taylor_Rem in |- *. apply AbsIR_wd; repeat apply cg_minus_wd. algebra. simpl in |- *. repeat first [ apply bin_op_wd_unfolded | apply mult_wd | apply div_wd | apply eq_reflexive_unfolded ]. apply FSumx_wd; intros; simpl in |- *. apply mult_wdl. apply div_wd. 2: algebra. apply eq_transitive_unfolded with (PartInt (ProjT1 (Diffble_I_n_imp_deriv_n _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (proj1 (Nat.lt_succ_r _ _) (Nat.lt_lt_succ_r _ _ Hi)) _ H2))) a (compact_Min_lft _ _ (less_leEq _ _ _ (ap_imp_Min_less_Max _ _ H1)))). simpl in |- *; algebra. apply Feq_imp_eq with (Compact (less_leEq _ _ _ (ap_imp_Min_less_Max _ _ H1))). apply Derivative_I_n_unique with i F. apply projT2. unfold fi in |- *. elim (N_Deriv_lemma _ _ _ _ (le_imp_Diffble_n I pI i n (proj1 (Nat.lt_succ_r _ _) (Nat.lt_lt_succ_r _ _ Hi)) _ Hf')); intros incF0 H'. elim H'; intros Hinc derivF; clear H'. apply derivF. simpl in |- *; Included. apply compact_Min_lft. apply eq_transitive_unfolded with (PartInt (ProjT1 (Diffble_I_n_imp_deriv_n _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (proj1 (Nat.lt_succ_r _ _) (Nat.lt_succ_diag_r n)) _ H2))) a (compact_Min_lft _ _ (less_leEq _ _ _ (ap_imp_Min_less_Max _ _ H1)))). simpl in |- *; algebra. apply Feq_imp_eq with (Compact (less_leEq _ _ _ (ap_imp_Min_less_Max _ _ H1))). apply Derivative_I_n_unique with n F. apply projT2. unfold fi in |- *. elim (N_Deriv_lemma _ _ _ _ (le_imp_Diffble_n I pI n n (proj1 (Nat.lt_succ_r _ _) (Nat.lt_succ_diag_r n)) _ Hf')); intros incF0 H'. elim H'; intros Hinc derivF; clear H'. apply derivF. simpl in |- *; Included. apply compact_Min_lft. simpl in |- *. repeat apply mult_wdl. apply Feq_imp_eq with (Compact (less_leEq _ _ _ (ap_imp_Min_less_Max _ _ H1))). apply Derivative_I_n_unique with (S n) F. apply Derivative_I_n_wdr with (n_deriv_I _ _ _ _ _ H0). apply Derivative_I_n_unique with n (n_deriv_I _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (le_n_S _ _ (Nat.le_0_l n)) _ H0)). cut (forall HS HSn, Derivative_I_n (ap_imp_Min_less_Max _ _ H1) n (n_deriv_I _ _ (ap_imp_Min_less_Max _ _ H1) 1 F HS) (n_deriv_I _ _ (ap_imp_Min_less_Max _ _ H1) (S n) F HSn)); auto. cut (S n = n + 1); [ intro | rewrite Nat.add_comm; auto ]. rewrite H6. intros; apply n_deriv_plus. eapply Derivative_I_n_wdl. 2: apply n_deriv_lemma. apply Derivative_I_unique with F. apply projT2. apply Derivative_I_wdl with (n_deriv_I _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (Nat.le_0_l _) F H0)). simpl in |- *. FEQ. apply (included_trans _ (Compact (less_leEq IR (Min a b) (Max a b) (ap_imp_Min_less_Max a b H1))) I); Included. apply n_Sn_deriv. apply n_deriv_lemma. elim (N_Deriv_lemma _ _ _ _ Hf); intros incF0 H'. elim H'; intros Hinc derivF; clear H'. apply derivF. simpl in |- *; Included. elim H5; clear H5; intros H6 H7. elim H6; clear H6; intros H5 H8. exact (n_deriv_inc' _ _ _ _ _ _ _ _ H5). Included. cut (Taylor_Rem n Hf'[-]Part _ _ H0[*] (b[-]a) [#] [0]). intro H1; exact (Taylor_lemma_ap _ _ _ _ H1). astepr ZeroR; apply AbsIR_cancel_ap_zero; apply Greater_imp_ap; auto. intro. exists a. apply compact_Min_lft. intro; eapply leEq_wdl. apply less_leEq; apply b0. apply AbsIR_wd; rational. Qed. End More_Taylor_Defs. Section Taylor_Theorem. (** And finally the ``nice'' version, when we know the expression of the derivatives of [F]. %\begin{convention}% Let [f] be the sequence of derivatives of [F] of order up to [n] and [F'] be the nth-derivative of [F]. %\end{convention}% *) Variable I : interval. Hypothesis pI : proper I. Variable F : PartIR. Variable n : nat. Variable f : forall i : nat, i < S n -> PartIR. Hypothesis goodF : ext_fun_seq f. Hypothesis goodF' : ext_fun_seq' f. Hypothesis derF : forall i Hi, Derivative_n i I pI F (f i Hi). Variable F' : PartIR. Hypothesis derF' : Derivative_n (S n) I pI F F'. Variables a b : IR. Hypothesis Ha : I a. Hypothesis Hb : I b. (* begin show *) Let funct_i i Hi := let HX := (Derivative_n_imp_inc' _ _ _ _ _ (derF i Hi) a Ha) in [-C-] (f i Hi a HX [/] _[//] nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i. Definition Taylor_Seq := FSumx _ funct_i. Let deriv_Sn := F'{*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]b{-}FId) {^}n. (* end show *) Lemma Taylor_aux : Dom Taylor_Seq b. Proof. repeat split. apply FSumx_pred'; repeat split. Qed. Theorem Taylor : forall e, [0] [<] e -> forall Hb', {c : IR | Compact (Min_leEq_Max a b) c | forall Hc, AbsIR (F b Hb'[-]Part _ _ Taylor_aux[-]deriv_Sn c Hc[*] (b[-]a)) [<=] e}. Proof. intros e H Hb'. cut (Diffble_n (S n) I pI F). intro Hf. cut (Diffble_n n I pI F). intro Hf'. elim (Taylor' I pI F _ _ Ha Hb n Hf Hf' e H); intros c Hc' Hc. exists c. auto. intros. cut (Dom (N_Deriv _ _ _ _ Hf{*} [-C-] ([1][/] _[//]nring_fac_ap_zero IR n) {*} ( [-C-]b{-}FId) {^}n) c). intro H0. eapply leEq_wdl. apply (Hc H0). apply AbsIR_wd; simpl in |- *; repeat simple apply cg_minus_wd. 2: repeat simple apply mult_wdl. unfold Taylor_Rem in |- *; simpl in |- *. apply cg_minus_wd. algebra. apply bin_op_wd_unfolded. apply Feq_imp_eq with (Compact (Min_leEq_Max a b)). apply FSumx_wd'. unfold funct_i in |- *; intros; simpl in |- *. apply Feq_mult. FEQ. simpl in |- *. apply div_wd. apply Feq_imp_eq with I. apply Derivative_n_unique with pI i F. apply N_Deriv_lemma. apply derF. auto. algebra. apply Feq_reflexive; repeat split. apply compact_Min_rht. apply mult_wdl. apply div_wd. 2: algebra. apply Feq_imp_eq with I. apply Derivative_n_unique with pI n F. apply N_Deriv_lemma. apply derF. auto. apply Feq_imp_eq with I. apply Derivative_n_unique with pI (S n) F. apply N_Deriv_lemma. assumption. cut (included (Compact (Min_leEq_Max a b)) I); Included. repeat split. Transparent N_Deriv. simpl in |- *. cut (included (Compact (Min_leEq_Max a b)) I); Included. apply Derivative_n_imp_Diffble_n with (f n (Nat.lt_succ_diag_r n)). apply derF. apply Derivative_n_imp_Diffble_n with F'. assumption. Qed. End Taylor_Theorem. corn-8.20.0/ftc/TaylorLemma.v000066400000000000000000000661631473720167500157630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.ftc.Rolle. From Coq Require Import Lia. Opaque Min. Section Taylor_Defs. (** * Taylor's Theorem We now prove Taylor's theorem for the remainder of the Taylor series. This proof is done in two steps: first, we prove the lemma for a proper compact interval; next we generalize the result to two arbitrary (eventually equal) points in a proper interval. ** First case We assume two different points [a] and [b] in the domain of [F] and define the nth order derivative of [F] in the interval [[Min(a,b),Max(a,b)]]. *) Variables a b : IR. Hypothesis Hap : a [#] b. (* begin hide *) Let Hab' := ap_imp_Min_less_Max _ _ Hap. Let Hab := less_leEq _ _ _ Hab'. Let I := Compact Hab. (* end hide *) Variable F : PartIR. Hypothesis Ha : Dom F a. Hypothesis Hb : Dom F b. (* begin show *) Let fi n (Hf : Diffble_I_n Hab' n F) i Hi := ProjT1 (Diffble_I_n_imp_deriv_n _ _ _ i F (le_imp_Diffble_I _ _ _ _ _ (proj1 (Nat.lt_succ_r i n) Hi) _ Hf)). (* end show *) (** This last local definition is simply: $f_i=f^{(i)}$#fi=f(i)#. *) (* begin hide *) Lemma Taylor_lemma1 : forall n Hf i Hi, Derivative_I_n Hab' i F (PartInt (fi n Hf i Hi)). Proof. intros. unfold fi in |- *. apply projT2. Qed. (* end hide *) (** Now we can define the Taylor sequence around [a]. The auxiliary definition gives, for any [i], the function expressed by the rule %\[g(x)=\frac{f^{(i)} (a)}{i!}*(x-a)^i.\]%#g(x)=f(i)(a)/i!*(x-a)i.# We denote by [A] and [B] the elements of [[Min(a,b),Max(a,b)]] corresponding to [a] and [b]. *) (* begin hide *) Let TL_compact_a := compact_Min_lft _ _ Hab. Let TL_compact_b := compact_Min_rht _ _ Hab. Notation A := (Build_subcsetoid_crr IR _ _ TL_compact_a). Notation B := (Build_subcsetoid_crr IR _ _ TL_compact_b). (* end hide *) (* begin show *) Let funct_i n Hf i Hi := [-C-] (fi n Hf i Hi A [/] _[//] nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i. (* end show *) (* begin hide *) Let funct_i' n Hf i Hi := PartInt (fi n Hf i Hi) {*} [-C-] ([1][/] _[//]nring_fac_ap_zero IR i) {*} ( [-C-]b{-}FId) {^}i. Lemma TL_a_i : forall n Hf i Hi, Dom (funct_i n Hf i Hi) a. Proof. split; split; simpl in |- *; auto. Qed. Lemma TL_b_i : forall n Hf i Hi, Dom (funct_i n Hf i Hi) b. Proof. split; split; simpl in |- *; auto. Qed. Lemma TL_x_i : forall x, I x -> forall n Hf i Hi, Dom (funct_i n Hf i Hi) x. Proof. split; split; simpl in |- *; auto. Qed. Lemma TL_a_i' : forall n Hf i Hi, Dom (funct_i' n Hf i Hi) a. Proof. split; split; simpl in |- *; auto. Qed. Lemma TL_b_i' : forall n Hf i Hi, Dom (funct_i' n Hf i Hi) b. Proof. split; split; simpl in |- *; auto. Qed. Lemma TL_x_i' : forall x, I x -> forall n Hf i Hi, Dom (funct_i' n Hf i Hi) x. Proof. split; split; simpl in |- *; auto. Qed. Lemma Taylor_lemma2 : forall n Hf, ext_fun_seq (funct_i n Hf). Proof. red in |- *; intros n Hf i j H H0 H' x y H1 Hx Hy. simpl in |- *. apply mult_wd. apply div_wd. 2: rewrite H; algebra. generalize H' Hx Hy; clear Hy Hx H'. rewrite <- H; intros. cut (forall Ha1 Ha2, PartInt (fi n Hf i H0) a Ha1 [=] PartInt (fi n Hf i H') a Ha2); intros. simpl in H2. apply H2. apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1. apply TL_compact_a. rewrite H. astepl ((x[+][--]a) [^]j); Step_final ((y[+][--]a) [^]j). Qed. Lemma Taylor_lemma2' : forall n Hf, ext_fun_seq' (funct_i n Hf). Proof. repeat intro. repeat split. Qed. Lemma Taylor_lemma3 : forall n Hf, ext_fun_seq (funct_i' n Hf). Proof. red in |- *; intros n Hf i j H H0 H' x y H1 Hx Hy. simpl in |- *. apply mult_wd. apply mult_wd. 2: rewrite H; algebra. generalize H' Hx Hy; clear Hy Hx H'. rewrite <- H; intros. cut (forall Hx' Hy', PartInt (fi n Hf i H0) x Hx' [=] PartInt (fi n Hf i H') y Hy'); intros. simpl in H2. apply H2. cut (Dom (PartInt (fi n Hf i H')) x); [ intro H2 | apply dom_wd with y; algebra ]. apply eq_transitive_unfolded with (Part _ _ H2). apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1. simpl in Hx. elim Hx; intros. inversion_clear a0; auto. algebra. rewrite H. astepl ((b[+][--]x) [^]j); Step_final ((b[+][--]y) [^]j). Qed. Lemma Taylor_lemma3' : forall n Hf, ext_fun_seq' (funct_i' n Hf). Proof. intros n Hf i j H H0 H' x y H1 H2. elim H2; intros. simpl in a0, b0. clear b0; inversion_clear a0 as (X,X0). inversion_clear X; repeat split. astepr x; auto. astepl x; auto. Qed. (* end hide *) (** Adding the previous expressions up to a given bound [n] gives us the Taylor sum of order [n]. *) Definition Taylor_seq' n Hf := FSumx _ (funct_i n Hf). (* begin hide *) Let Taylor_seq'_aux n Hf := FSumx _ (funct_i' n Hf). Lemma TL_lemma_a : forall n Hf, Dom (Taylor_seq' n Hf) a. Proof. intros. repeat split. apply FSumx_pred'. repeat split. repeat split. Qed. (* end hide *) (** It is easy to show that [b] is in the domain of this series, which allows us to write down the Taylor remainder around [b]. *) Lemma TL_lemma_b : forall n Hf, Dom (Taylor_seq' n Hf) b. Proof. intros. repeat split. apply FSumx_pred'. repeat split. repeat split. Qed. (* begin hide *) Lemma TL_lemma_a' : forall n Hf, Dom (Taylor_seq'_aux n Hf) a. Proof. intros. split. apply FSumx_pred'. red in |- *; intros. simpl in X. inversion_clear X. inversion_clear X0. simpl in |- *. split; split; auto. apply compact_wd with x; auto. intros. apply TL_a_i'. apply TL_a_i'. Qed. Lemma TL_lemma_b' : forall n Hf, Dom (Taylor_seq'_aux n Hf) b. Proof. intros. split. apply FSumx_pred'. red in |- *; intros. simpl in X. inversion_clear X. inversion_clear X0. simpl in |- *. split; split; auto. apply compact_wd with x; auto. intros. apply TL_b_i'. apply TL_b_i'. Qed. (* end hide *) Definition Taylor_rem n Hf := F b Hb[-]Taylor_seq' n Hf b (TL_lemma_b n Hf). (* begin hide *) Let g n Hf Hab := [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf{-} [-C-] (Taylor_rem n Hf) {*} (( [-C-]b{-}FId) {*} [-C-] ([1][/] (b[-]a) [//]Hab)). Lemma Taylor_lemma4 : forall n Hf Hab Ha', g n Hf Hab a Ha' [=] [0]. Proof. unfold g in |- *; clear g; intros. cut (Dom ( [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf{-} [-C-] (Taylor_rem n Hf)) a). intro H. apply eq_transitive_unfolded with (Part _ _ H). Opaque Taylor_seq'_aux Taylor_rem. simpl in |- *; rational. Transparent Taylor_rem. unfold Taylor_rem in |- *. apply eq_transitive_unfolded with (Part _ _ (TL_lemma_b n Hf) [-]Part _ _ (TL_lemma_a' n Hf)). Opaque Taylor_seq'. simpl in |- *; rational. Transparent Taylor_seq' Taylor_seq'_aux. unfold Taylor_seq', Taylor_seq'_aux in |- *. cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i n Hf))) b). intro H0. cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i' n Hf))) a). intro H1. apply eq_transitive_unfolded with (Part _ _ H0[-]Part _ _ H1). apply eq_symmetric_unfolded; apply cg_minus_wd; apply FSum_FSumx_to_FSum. apply Taylor_lemma2. apply Taylor_lemma2'. apply Taylor_lemma3. apply Taylor_lemma3'. eapply eq_transitive_unfolded. simpl in |- *. apply eq_symmetric_unfolded; apply Sum_minus_Sum. apply Sum_zero. auto with arith. intros. cut (forall Hb' Ha', FSumx_to_FSum (S n) (funct_i n Hf) i b Hb'[-] FSumx_to_FSum (S n) (funct_i' n Hf) i a Ha' [=] [0]); auto. unfold FSumx_to_FSum in |- *. elim le_lt_dec; intro; simpl in |- *. algebra. intros. set (w := fi n Hf i b0 (Build_subcsetoid_crr _ _ _ TL_compact_a) [*] ([1][/] _[//]nring_fac_ap_zero IR i) [*] (b[+][--]a) [^]i) in *. astepr (w[-]w); unfold w in |- *; simpl in |- *. repeat first [ apply cg_minus_wd | simple apply mult_wd ]; try apply csf_wd_unfolded; algebra. rational. simpl in |- *; algebra. simpl in |- *; intro i. Opaque funct_i'. unfold FSumx_to_FSum in |- *. elim le_lt_dec; intro; simpl in |- *. auto. apply TL_a_i'. Opaque funct_i. simpl in |- *; intro i. unfold FSumx_to_FSum in |- *. elim le_lt_dec; intro; simpl in |- *. auto. apply TL_b_i. split; split; split. apply FSumx_pred'. red in |- *; intros. inversion_clear X. inversion_clear X0. simpl in X. split; split; auto. simpl in |- *; apply compact_wd with x; auto. intros; apply TL_a_i'. apply TL_a_i'. Qed. Transparent funct_i funct_i'. Lemma Taylor_lemma5 : forall n Hf Hab Hb', g n Hf Hab b Hb' [=] [0]. Proof. unfold g in |- *; intros. cut (Dom ( [-C-] (F b Hb) {-}Taylor_seq'_aux n Hf) b). intro H. apply eq_transitive_unfolded with (Part _ _ H). Opaque Taylor_seq'_aux. simpl in |- *; rational. Transparent Taylor_seq'_aux. unfold Taylor_seq'_aux in |- *. cut (Dom (FSum 0 n (FSumx_to_FSum _ (funct_i' n Hf))) b). intro H0. apply eq_transitive_unfolded with (F b Hb[-]Part _ _ H0). Opaque FSumx. apply eq_transitive_unfolded with (F b Hb[-]FSumx (S n) (funct_i' n Hf) b (ProjIR2 H)). simpl in |- *; rational. apply cg_minus_wd. algebra. apply eq_symmetric_unfolded; apply FSum_FSumx_to_FSum. apply Taylor_lemma3. apply Taylor_lemma3'. simpl in |- *. astepr (Part _ _ Hb[-]Part _ _ Hb); apply cg_minus_wd. algebra. eapply eq_transitive_unfolded. apply Sum_first. astepr (Part _ _ Hb[+][0]); apply bin_op_wd_unfolded. cut (forall H', FSumx_to_FSum (S n) (funct_i' n Hf) 0 b H' [=] Part _ _ Hb); auto. unfold FSumx_to_FSum in |- *. elim le_lt_dec; intro; simpl in |- *. exfalso; inversion a0. intros; simpl in |- *. rstepr (Part _ _ Hb[*][1][*][1]). apply mult_wdl. apply mult_wd. 2: rational. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (PartInt (fi n Hf 0 b0) b TL_compact_b). 2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply Feq_imp_eq with (Compact Hab). apply (ProjT2 (Diffble_I_n_imp_deriv_n _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (proj1 (Nat.lt_succ_r 0 n) b0) _ Hf))). apply TL_compact_b. apply Sum_zero. auto with arith. intros. cut (forall H', FSumx_to_FSum (S n) (funct_i' n Hf) i b H' [=] [0]); auto. unfold FSumx_to_FSum in |- *. elim le_lt_dec; intro; simpl in |- *. algebra. intro. astepr (fi n Hf i b0 (Build_subcsetoid_crr IR _ b (ProjIR1 (ProjIR1 H'))) [*] ([1][/] _[//]nring_fac_ap_zero _ i) [*][0]). apply mult_wdr. astepl ((b[-]b) [^]i). Step_final (ZeroR[^]i). intro i. Opaque funct_i'. unfold FSumx_to_FSum in |- *. elim le_lt_dec; intro; simpl in |- *. auto. apply TL_b_i'. split. simpl in |- *; auto. simpl in |- *. apply TL_lemma_b'. Qed. Transparent funct_i' FSumx. Let funct_aux n Hf i Hi := PartInt (fi (S n) Hf (S i) (proj1 (Nat.succ_lt_mono _ _) Hi)) {*} [-C-] ([1][/] _[//]nring_fac_ap_zero IR i) {*} ( [-C-]b{-}FId) {^}i. Lemma Taylor_lemma6 : forall n Hf Hf' i Hi, Derivative_I Hab' (PartInt (fi n Hf i Hi)) (PartInt (fi (S n) Hf' (S i) (proj1 (Nat.succ_lt_mono _ _) Hi))). Proof. intros. cut (Derivative_I_n Hab' 1 (PartInt (fi n Hf i Hi)) (PartInt (fi (S n) Hf' (S i) (proj1 (Nat.succ_lt_mono i (S n)) Hi)))). intro H. simpl in H. elim H; intros f' H1 H2. apply Derivative_I_wdr with (PartInt f'); assumption. cut (S i = 1 + i); [ intro | lia ]. cut (1 + i < S (S n)); [ intro | lia ]. apply Derivative_I_n_wdr with (PartInt (fi (S n) Hf' _ H0)). apply Derivative_I_n_unique with (S i) F. generalize H0; clear H0. rewrite <- H; intro. apply Taylor_lemma1. apply Taylor_lemma1. apply Derivative_I_n_wdl with (n_deriv_I _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (proj1 (Nat.lt_succ_r i n) Hi) _ Hf)). 2: apply Derivative_I_n_wdr with (n_deriv_I _ _ _ _ _ (le_imp_Diffble_I _ _ _ _ _ (proj1 (Nat.lt_succ_r _ _) H0) _ Hf')). 3: apply n_deriv_plus. apply Derivative_I_n_unique with i F. apply n_deriv_lemma. apply Taylor_lemma1. apply Derivative_I_n_unique with (1 + i) F. apply n_deriv_lemma. apply Taylor_lemma1. Qed. Ltac Lazy_Included := repeat first [ simple apply included_IR | simple apply included_FPlus | simple apply included_FInv | simple apply included_FMinus | simple apply included_FMult | simple apply included_FNth | simple apply included_refl ]. Ltac Lazy_Eq := repeat first [ simple apply bin_op_wd_unfolded | simple apply un_op_wd_unfolded | simple apply cg_minus_wd | simple apply div_wd | simple apply csf_wd_unfolded ]; algebra. Lemma Taylor_lemma7 : forall n Hf Hf' i (Hi : 0 < i) Hi', Derivative_I Hab' (funct_i' n Hf i Hi') (funct_aux n Hf' i Hi'{-}funct_aux n Hf' (pred i) (lt_5 i (S n) Hi')). Proof. do 5 intro. rewrite <- (Nat.lt_succ_pred _ _ Hi). set (p := pred i) in *; clearbody p; clear Hi i. intros. cut (Derivative_I Hab' (PartInt (fi n Hf _ Hi')) (PartInt (fi (S n) Hf' (S (S p)) (proj1 (Nat.succ_lt_mono _ _) Hi')))); [ intro | apply Taylor_lemma6 ]. unfold funct_aux, funct_i' in |- *. New_Deriv. apply Feq_reflexive. Lazy_Included. apply eq_imp_Feq. Lazy_Included. Lazy_Included. intros x X0 Hx Hx'. simpl in Hx, Hx'; simpl in |- *. set (fiSp1 := fi n Hf (S p) Hi') in *. set (fiSp2 := fi (S n) Hf' (S p) (proj1 (Nat.succ_lt_mono p (S n)) (lt_5 (S p) (S n) Hi'))) in *. cut (forall x y : subset I, scs_elem _ _ x [=] scs_elem _ _ y -> fiSp1 x [=] fiSp2 y); intros. set (x1 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 Hx)))) in *. simpl in (value of x1); fold x1 in |- *. set (x2 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR2 Hx')))) in *. simpl in (value of x2); fold x2 in |- *. set (x3 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 (ProjIR2 Hx))))) in *. simpl in (value of x3); fold x3 in |- *. set (x4 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR1 (ProjIR1 Hx')))) in *. simpl in (value of x4); fold x4 in |- *. set (x5 := Build_subcsetoid_crr IR _ _ (ProjIR1 (ProjIR2 (ProjIR1 (ProjIR2 Hx))))) in *. simpl in (value of x5); fold x5 in |- *. set (fiSSp := fi (S n) Hf' (S (S p)) (proj1 (Nat.succ_lt_mono (S p) (S n)) Hi')) in *. set (pp := [1][/] nring (fact p + p * fact p) [//]nring_fac_ap_zero IR (S p)) in *. set (bxp := nexp _ p (b[-]x)) in *. set (a1 := fiSp1 x1) in *; set (a5 := fiSSp x5) in *; simpl in (value of a1), (value of a5); fold a1 a5 in |- *. rstepl (a5[*]pp[*] (bxp[*] (b[-]x)) [-]a1[*] ((nring p[+][1]) [*]pp) [*]bxp). unfold a1, a5 in |- *; clear a1 a5. Lazy_Eq. unfold x4, x5 in |- *; algebra. simpl in |- *; algebra. unfold pp in |- *. rstepr (nring (S p) [*] ([1][/] _[//] mult_resp_ap_zero _ _ _ (nring_fac_ap_zero _ p) (pos_ap_zero _ _ (pos_nring_S IR p)))); simpl in |- *. apply mult_wdr; apply div_wd. algebra. clear X H bxp pp x5 x4 x3 x2 x1 fiSSp fiSp1 fiSp2 Hx. cut (fact p + p * fact p = fact p * S p). intro; rewrite H. eapply eq_transitive_unfolded. apply nring_comm_mult. algebra. transitivity (S p * fact p); auto with arith. unfold fiSp1, fiSp2 in |- *. apply eq_transitive_unfolded with (PartInt (fi n Hf (S p) Hi') (scs_elem _ _ x0) (scs_prf _ _ x0)). 2: apply eq_transitive_unfolded with (PartInt (fi (S n) Hf' (S p) (proj1 (Nat.succ_lt_mono _ _) (lt_5 _ _ Hi'))) (scs_elem _ _ x0) (scs_prf _ _ x0)). simpl in |- *; apply csf_wd_unfolded. case x0; simpl in |- *; algebra. apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with (S p) F; apply Taylor_lemma1. apply scs_prf. simpl in |- *; apply csf_wd_unfolded. generalize H; case x0; case y; auto. Qed. Lemma Taylor_lemma8 : forall n Hf Hf' Hi, Derivative_I Hab' (funct_i' n Hf 0 Hi) (funct_aux n Hf' 0 Hi). Proof. intros. cut (Derivative_I Hab' (PartInt (fi n Hf _ Hi)) (PartInt (fi (S n) Hf' 1 (proj1 (Nat.succ_lt_mono _ _) Hi)))); [ intro | apply Taylor_lemma6 ]. unfold funct_aux, funct_i' in |- *; New_Deriv. apply Feq_reflexive; Lazy_Included. apply eq_imp_Feq. Lazy_Included. Lazy_Included. intros; simpl in |- *. apply eq_transitive_unfolded with (fi (S n) Hf' 1 (proj1 (Nat.succ_lt_mono _ _) Hi) (Build_subcsetoid_crr _ _ _ (ProjIR1 (ProjIR2 (ProjIR1 (ProjIR2 Hx))))) [*] ([1][/] _[//]nring_fac_ap_zero IR 0) [*][1]). simpl in |- *; rational. Lazy_Eq; simpl in |- *; algebra. Qed. Lemma Taylor_lemma9 : forall n Hf Hf', Derivative_I Hab' (Taylor_seq'_aux n Hf) (funct_aux n Hf' n (Nat.lt_succ_diag_r n)). Proof. intro; induction n as [| n Hrecn]. intros. unfold Taylor_seq'_aux in |- *; simpl in |- *. apply Derivative_I_wdl with (funct_i' 0 Hf 0 (Nat.lt_succ_diag_r 0)). apply eq_imp_Feq. split; split; simpl in |- *; auto. split; split; split; simpl in |- *; auto. intros; simpl in |- *. apply eq_transitive_unfolded with ([0][+] fi 0 Hf 0 (Nat.lt_succ_diag_r 0) (Build_subcsetoid_crr _ _ _ (ProjIR1 (ProjIR1 Hx))) [*] ([1][/] [0][+][1][//]nring_fac_ap_zero IR 0) [*][1]). simpl in |- *; rational. Lazy_Eq; simpl in |- *; algebra. apply Taylor_lemma8; assumption. cut {p : nat | S n = p}; [ intro H | exists (S n); auto ]. elim H; intros p H0. rewrite H0. intros. unfold Taylor_seq'_aux in |- *; simpl in |- *. generalize Hf Hf'; clear Hf Hf'. rewrite <- H0; intros. cut (Diffble_I_n Hab' n F); [ intro H1 | apply le_imp_Diffble_I with (S n); [ lia | assumption ] ]. apply Derivative_I_wdl with (Taylor_seq'_aux n H1{+}funct_i' _ Hf _ (Nat.lt_succ_diag_r (S n))). unfold Taylor_seq'_aux in |- *. apply eq_imp_Feq. repeat (split; auto). try rename X into H2. apply FSumx_pred'. red in |- *; intros. try rename X into H6. exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6). intros; simpl in |- *; repeat (split; auto). repeat (split; auto). try rename X into H2. apply FSumx_pred'. red in |- *; intros. try rename X into H6. exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6). intros; simpl in |- *; repeat (split; auto). intros x H2 Hx Hx'; simpl in |- *. repeat first [ simple apply mult_wd | simple apply bin_op_wd_unfolded | simple apply csf_wd_unfolded | simple apply eq_reflexive_unfolded ]; simpl in |- *. 3: algebra. apply Feq_imp_eq with (Compact Hab). 2: assumption. apply FSumx_wd'. intros; apply eq_imp_Feq. repeat (split; auto). repeat (split; auto). intros x0 H4; intros; simpl in |- *. repeat apply mult_wdl. apply eq_transitive_unfolded with (PartInt (fi n H1 i (Nat.lt_lt_succ_r _ _ H3)) x0 H4). simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply eq_transitive_unfolded with (PartInt (fi (S n) Hf i (Nat.lt_lt_succ_r _ _ (Nat.lt_lt_succ_r _ _ H'))) x0 H4). 2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with i F; apply Taylor_lemma1. auto. apply eq_transitive_unfolded with (PartInt (fi n H1 n (Nat.lt_succ_diag_r _)) x H2). 2: apply eq_transitive_unfolded with (PartInt (fi (S n) Hf n (Nat.lt_lt_succ_r _ _ (Nat.lt_succ_diag_r _))) x H2). simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. 2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with n F; apply Taylor_lemma1. auto. apply Derivative_I_wdr with (funct_aux (S n) Hf' (pred (S n)) (lt_5 _ _ (Nat.lt_succ_diag_r (S n))) {+} (funct_aux _ Hf' _ (Nat.lt_succ_diag_r (S n)) {-} funct_aux (S n) Hf' (pred (S n)) (lt_5 _ _ (Nat.lt_succ_diag_r (S n))))). Opaque funct_aux. FEQ. Transparent funct_aux. repeat (split; auto). repeat (split; auto). apply Derivative_I_plus. apply Derivative_I_wdr with (funct_aux n Hf n (Nat.lt_succ_diag_r n)). apply eq_imp_Feq. repeat (split; auto). repeat (split; auto). intros x H2 Hx Hx'; simpl in |- *. repeat apply mult_wdl. apply eq_transitive_unfolded with (PartInt (fi (S n) Hf (S n) (proj1 (Nat.succ_lt_mono _ _) (Nat.lt_succ_diag_r _))) x H2). 2: apply eq_transitive_unfolded with (PartInt (fi (S (S n)) Hf' (S n) (proj1 (Nat.succ_lt_mono _ _) (lt_5 _ _ (Nat.lt_succ_diag_r (S n))))) x H2). simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. 2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with (S n) F; apply Taylor_lemma1. auto. apply Hrecn. apply Taylor_lemma7. lia. Qed. Let g' n Hf Hf' Hab := [-C-] (Taylor_rem n Hf[/] (b[-]a) [//]Hab) {-}funct_aux n Hf' n (Nat.lt_succ_diag_r n). Lemma Taylor_lemma10 : forall n Hf Hf' Hab (H : a [#] b), Derivative_I Hab' (g n Hf Hab) (g' n Hf Hf' Hab). Proof. unfold g, g' in |- *. intros. cut (Derivative_I Hab' (Taylor_seq'_aux n Hf) (funct_aux n Hf' n (Nat.lt_succ_diag_r n))); [ intro | apply Taylor_lemma9; assumption ]. Opaque Taylor_rem funct_aux. New_Deriv. apply Feq_reflexive; Lazy_Included. Included. apply eq_imp_Feq. Lazy_Included. Included. Lazy_Included. Included. intros; simpl in |- *; rational. Qed. Transparent Taylor_rem funct_aux. (* end hide *) (** Now Taylor's theorem. %\begin{convention}% Let [e] be a positive real number. %\end{convention}% *) Variable e : IR. Hypothesis He : [0] [<] e. (* begin hide *) Lemma Taylor_lemma11 : forall n Hf Hf' H, {c : IR | I c | forall Hc, AbsIR (g' n Hf Hf' H c Hc) [<=] e[*]AbsIR ([1][/] (b[-]a) [//]H)}. Proof. intros. cut (Dom (g n Hf H) (Min a b)). intro H0. cut (Dom (g n Hf H) (Max a b)). intro H1. cut (Dom (g n Hf H) a). intro H2. cut (Dom (g n Hf H) b). intro H3. unfold I, Hab in |- *; apply Rolle with (g n Hf H) H0 H1. apply Taylor_lemma10; auto. elim (ap_imp_less _ _ _ Hap); intro. apply eq_transitive_unfolded with ZeroR. eapply eq_transitive_unfolded. 2: apply Taylor_lemma4 with (Ha' := H2). apply pfwdef; apply leEq_imp_Min_is_lft; apply less_leEq; auto. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply Taylor_lemma5 with (Hb' := H3). apply pfwdef; apply leEq_imp_Max_is_rht; apply less_leEq; auto. apply eq_transitive_unfolded with ZeroR. eapply eq_transitive_unfolded. 2: apply Taylor_lemma5 with (Hb' := H3). apply pfwdef; eapply eq_transitive_unfolded. apply Min_comm. apply leEq_imp_Min_is_lft; apply less_leEq; auto. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply Taylor_lemma4 with (Ha' := H2). apply pfwdef; eapply eq_transitive_unfolded. apply Max_comm. apply leEq_imp_Max_is_rht; apply less_leEq; auto. astepl ([0][*]AbsIR ([1][/] _[//]H)). apply mult_resp_less. assumption. apply AbsIR_pos. apply div_resp_ap_zero_rev. apply one_ap_zero. split; split; split; simpl in |- *; auto. 3: split; split. 2: split; split; auto; apply TL_compact_b. apply FSumx_pred'; intros. 2: apply TL_b_i'. red in |- *; intros. try rename X into H6. exact (Taylor_lemma3' _ _ _ _ H3 _ _ _ _ H4 H6). split; split; split; simpl in |- *; auto. 3: split; split. 2: split; split; auto; apply TL_compact_a. apply FSumx_pred'; intros. 2: apply TL_a_i'. red in |- *; intros. try rename X into H5. exact (Taylor_lemma3' _ _ _ _ H2 _ _ _ _ H3 H5). split; split; split; simpl in |- *; auto. 3: split; split. 2: split; split; auto; apply compact_inc_rht. apply FSumx_pred'; intros. 2: apply TL_x_i'. red in |- *; intros. try rename X into H4. exact (Taylor_lemma3' _ _ _ _ H1 _ _ _ _ H2 H4). unfold I in |- *; apply compact_inc_rht. split; split; split; simpl in |- *; auto. 3: split; split. 2: split; split; auto; apply compact_inc_lft. apply FSumx_pred'; intros. 2: apply TL_x_i'. red in |- *; intros. try rename X into H3. exact (Taylor_lemma3' _ _ _ _ H0 _ _ _ _ H1 H3). unfold I in |- *; apply compact_inc_lft. Qed. (* end hide *) (* begin show *) Let deriv_Sn' n Hf' := n_deriv_I _ _ Hab' (S n) F Hf'{*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]b{-}FId) {^}n. (* end show *) (* begin hide *) Lemma TLH : b[-]a [#] [0]. Proof. rstepl ( [--] (a[-]b)). apply inv_resp_ap_zero. apply minus_ap_zero; auto. Qed. (* end hide *) Lemma Taylor_lemma : forall n Hf Hf', {c : IR | I c | forall Hc, AbsIR (Taylor_rem n Hf[-]deriv_Sn' n Hf' c Hc[*] (b[-]a)) [<=] e}. Proof. intros. assert (H := TLH). cut {c : IR | I c | forall Hc, AbsIR (g' n Hf Hf' H c Hc) [<=] e[*]AbsIR ([1][/] _[//]H)}; [ intro H0 | apply Taylor_lemma11; assumption ]. elim H0; intros c Hc' Hc; clear H0; exists c. auto. intro. cut (Dom (funct_aux n Hf' n (Nat.lt_succ_diag_r n)) c). intro H0. apply leEq_wdl with (AbsIR (((Taylor_rem n Hf[/] _[//]H) [-]Part _ _ H0) [*] (b[-]a))). eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply shift_mult_leEq with (AbsIR_resp_ap_zero _ H). apply AbsIR_pos; apply H. rstepr (e[*] ([1][/] _[//]AbsIR_resp_ap_zero _ H)). apply leEq_wdr with (e[*]AbsIR ([1][/] _[//]H)). Opaque funct_aux. cut (Dom (g' n Hf Hf' H) c). intro H1. eapply leEq_wdl. apply (Hc H1). apply AbsIR_wd; unfold g' in |- *. Opaque Taylor_rem. simpl in |- *; rational. repeat (split; auto). apply mult_wdr. apply AbsIR_recip. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (AbsIR ((Taylor_rem n Hf[/] _[//]H) [-]Part _ _ H0) [*]AbsIR (b[-]a)). eapply eq_transitive_unfolded. 2: apply AbsIR_resp_mult. apply AbsIR_wd. rstepr (Taylor_rem n Hf[-]Part _ _ H0[*] (b[-]a)). apply cg_minus_wd. algebra. apply mult_wdl. Transparent Taylor_rem funct_aux. unfold deriv_Sn', funct_aux in |- *. cut (Dom (n_deriv_I _ _ Hab' (S n) F Hf') c). intro H1. simpl in |- *; apply eq_transitive_unfolded with (n_deriv_I _ _ Hab' (S n) F Hf' c H1[*] ([1][/] _[//]nring_fac_ap_zero _ n) [*] (b[-]c) [^]n). repeat apply mult_wdl; apply pfwdef; algebra. repeat apply mult_wdl. apply eq_transitive_unfolded with (PartInt (fi (S n) Hf' (S n) (proj1 (Nat.succ_lt_mono _ _) (Nat.lt_succ_diag_r _))) c Hc'). 2: simpl in |- *; apply csf_wd_unfolded; simpl in |- *; algebra. apply Feq_imp_eq with (Compact Hab). unfold Hab in |- *; apply Derivative_I_n_unique with (S n) F. apply n_deriv_lemma. apply Taylor_lemma1. auto. apply n_deriv_inc; auto. apply eq_symmetric_unfolded; apply AbsIR_resp_mult. repeat (split; auto). Qed. End Taylor_Defs. corn-8.20.0/ftc/WeakIVT.v000066400000000000000000000456341473720167500150070ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing ** %\ensuremath\times% #×# *) (* begin hide *) Infix "**" := prodT (at level 20). (* end hide *) Require Export CoRN.ftc.Continuity. (** * IVT for Partial Functions In general, we cannot prove the classically valid Intermediate Value Theorem for arbitrary partial functions, which states that in any interval [[a,b]], for any value [z] between [f(a)] and [f(b)] there exists $x\in[a,b]$#x∈[a,b]# such that [f(x) [=] z]. However, as is usually the case, there are some good aproximation results. We will prove them here. *) Section Lemma1. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. (** ** First Lemmas %\begin{convention}% Let [a, b : IR] and [Hab : a [<=] b] and denote by [I] the interval [[a,b]]. Let [F] be a continuous function on [I]. %\end{convention}% We begin by proving that, if [f(a) [<] f(b)], then for every [y] in [[f(a),f(b)]] there is an $x\in[a,b]$#x∈[a,b]# such that [f(x)] is close enough to [z]. *) Lemma Weak_IVT_ap_lft : forall Ha Hb (HFab : F a Ha [<] F b Hb) e, [0] [<] e -> forall z, Compact (less_leEq _ _ _ HFab) z -> {x : IR | Compact Hab x | forall Hx, AbsIR (F x Hx[-]z) [<=] e}. Proof. intros Ha Hb HFab e H z H0. cut (a [<] b). intro Hab'. set (G := FAbs (F{-}[-C-]z)) in *. assert (H1 : Continuous_I Hab G). unfold G in |- *; Contin. set (m := glb_funct _ _ _ _ H1) in *. elim (glb_is_glb _ _ _ _ H1). fold m in |- *; intros. cut (forall x : IR, Compact Hab x -> forall Hx, m [<=] AbsIR (F x Hx[-]z)); [ clear a0; intro a0 | intros ]. elim (less_cotransitive_unfolded _ _ _ H m); intros. elim H0; clear H0; intros H0 H0'. cut (F a Ha[-]z [<=] [--]m); intros. cut (m [<=] F b Hb[-]z); intros. exfalso. elim (contin_prop _ _ _ _ contF m a1); intros d H4 H5. set (incF := contin_imp_inc _ _ _ _ contF) in *. set (f := fun i Hi => F (compact_part _ _ Hab' d H4 i Hi) (incF _ (compact_part_hyp _ _ Hab Hab' d H4 i Hi)) [-]z) in *. set (n := compact_nat a b d H4) in *. cut (forall i Hi, f i Hi [<=] [0]). intros. apply (less_irreflexive_unfolded _ (F b Hb[-]z)). eapply less_leEq_trans. 2: apply H3. apply leEq_less_trans with ZeroR. 2: auto. apply leEq_wdl with (f _ (le_n n)); auto. unfold f, compact_part, n in |- *; simpl in |- *. apply cg_minus_wd; [ apply pfwdef; rational | algebra ]. simple induction i. intros; unfold f, compact_part in |- *. apply leEq_wdl with (F a Ha[-]z). apply leEq_transitive with ( [--]m); auto. astepr ( [--]ZeroR); apply less_leEq; apply inv_resp_less; auto. apply cg_minus_wd; [apply pfwdef | idtac]; rational. intros i' Hrec HSi'. astepr (m[-]m). apply shift_leEq_minus'. cut (i' <= n); [ intro Hi' | auto with arith ]. apply leEq_transitive with ( [--] (f _ Hi') [+]f _ HSi'). apply plus_resp_leEq. cut ({m [<=] f _ Hi'} + {f _ Hi' [<=] [--]m}). intro; inversion_clear H6. exfalso. apply (less_irreflexive_unfolded _ m). apply leEq_less_trans with ZeroR. eapply leEq_transitive; [ apply H7 | apply (Hrec Hi') ]. auto. astepl ( [--][--]m); apply inv_resp_leEq; auto. apply leEq_distr_AbsIR. assumption. unfold f in |- *; apply a0; apply compact_part_hyp. rstepl (f _ HSi'[-]f _ Hi'). eapply leEq_transitive. apply leEq_AbsIR. unfold f in |- *; simpl in |- *. apply leEq_wdl with (AbsIR (F _ (incF _ (compact_part_hyp _ _ Hab Hab' d H4 _ HSi')) [-] F _ (incF _ (compact_part_hyp _ _ Hab Hab' d H4 _ Hi')))). apply H5; try apply compact_part_hyp. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply compact_leEq. apply less_leEq; apply compact_less. apply AbsIR_wd; rational. eapply leEq_wdr. 2: apply AbsIR_eq_x. apply a0; apply compact_inc_rht. apply shift_leEq_minus; astepl z; auto. astepl ( [--][--] (F a Ha[-]z)); apply inv_resp_leEq. eapply leEq_wdr. 2: apply AbsIR_eq_inv_x. apply a0; apply compact_inc_lft. apply shift_minus_leEq; astepr z; auto. elim (b0 (e[-]m)); intros. elim p; clear p b0; intros y Hy. elim Hy; intros. elim b0; clear b0; intros H2 H3. exists y; auto. intro. apply leEq_wdl with (G y H2). apply less_leEq. apply plus_cancel_less with ( [--]m). eapply less_wdl. apply q. unfold cg_minus in |- *; algebra. unfold G in |- *. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 H2))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; algebra. apply shift_less_minus; astepl m; auto. apply a0. exists x. split. auto. repeat split; auto. intro; unfold G in |- *. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 Hy))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; algebra. set (H1 := less_imp_ap _ _ _ HFab) in *. set (H2 := pfstrx _ _ _ _ _ _ H1) in *. elim (ap_imp_less _ _ _ H2); intro. auto. exfalso. apply (less_irreflexive_unfolded _ a). apply leEq_less_trans with b; auto. Qed. End Lemma1. Section Lemma2. Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. (** If [f(b) [<] f(a)], a similar result holds: *) Lemma Weak_IVT_ap_rht : forall Ha Hb (HFab : F b Hb [<] F a Ha) e, [0] [<] e -> forall z, Compact (less_leEq _ _ _ HFab) z -> {x : IR | Compact Hab x | forall Hx, AbsIR (F x Hx[-]z) [<=] e}. Proof. intros Ha Hb HFab e H z H0. set (G := {--}F) in *. assert (contG : Continuous_I Hab G). unfold G in |- *; Contin. assert (HGab : G a Ha [<] G b Hb). unfold G in |- *; simpl in |- *; apply inv_resp_less; auto. assert (H1 : Compact (less_leEq _ _ _ HGab) [--]z). inversion_clear H0; split; unfold G in |- *; simpl in |- *; apply inv_resp_leEq; auto. elim (Weak_IVT_ap_lft _ _ _ _ contG _ _ HGab _ H _ H1); intros x Hx. exists x; auto. intro; eapply leEq_wdl. apply (q Hx0). eapply eq_transitive_unfolded. apply AbsIR_minus. apply AbsIR_wd; unfold G in |- *; simpl in |- *; rational. Qed. End Lemma2. Section IVT. (** ** The IVT We will now assume that [a [<] b] and that [F] is not only continuous, but also strictly increasing in [I]. Under these assumptions, we can build two sequences of values which converge to [x0] such that [f(x0) [=] z]. *) Variables a b : IR. Hypothesis Hab' : a [<] b. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := Compact Hab. (* end hide *) Variable F : PartIR. Hypothesis contF : Continuous_I Hab F. (* begin hide *) Let incF := contin_imp_inc _ _ _ _ contF. (* end hide *) (* begin show *) Hypothesis incrF : forall x y, I x -> I y -> x [<] y -> forall Hx Hy, F x Hx [<] F y Hy. (* end show *) (* begin hide *) Let Ha := compact_inc_lft _ _ Hab. Let Hb := compact_inc_rht _ _ Hab. Let HFab' := incrF _ _ Ha Hb Hab' (incF _ Ha) (incF _ Hb). (* end hide *) (* begin show *) Variable z : IR. Hypothesis Haz : F a (incF _ Ha) [<=] z. Hypothesis Hzb : z [<=] F b (incF _ Hb). (* end show *) (** Given any two points [x [<] y] in [[a,b]] such that [x [<=] z [<=] y], we can find [x' [<] y'] such that $|x'-y'|=\frac23|x-y|$#|x'-y'|=2/3|x-y|# and [x' [<=] z [<=] y']. *) Lemma IVT_seq_lemma : forall (xy : IR ** IR) (x:=fstT xy) (y:=sndT xy) (Hxy : (I x) ** (I y)) (Hx := fstT Hxy) (Hy := sndT Hxy), x [<] y -> F x (incF _ Hx) [<=] z /\ z [<=] F y (incF _ Hy) -> {xy0 : IR ** IR | let x0 := fstT xy0 in let y0 := sndT xy0 in {Hxy0 : (I x0) ** (I y0) | x0 [<] y0 | let Hx0 := fstT Hxy0 in let Hy0 := sndT Hxy0 in F x0 (incF _ Hx0) [<=] z /\ z [<=] F y0 (incF _ Hy0) /\ y0[-]x0 [=] Two [/]ThreeNZ[*] (y[-]x) /\ x [<=] x0 /\ y0 [<=] y}}. Proof. (* begin hide *) intros xy x y Hxy Hx Hy H H0. set (x1 := (Two[*]x[+]y) [/]ThreeNZ) in *. set (y1 := (x[+]Two[*]y) [/]ThreeNZ) in *. assert (H1 : x1 [<] y1). unfold x1, y1 in |- *; apply lft_rht; auto. cut (I x1). intro H2. cut (I y1). intro H3. cut (F x1 (incF _ H2) [<] F y1 (incF _ H3)); [ intro H4 | auto ]. elim (less_cotransitive_unfolded _ _ _ H4 z); intros. exists (pairT x1 y); exists (pairT H2 Hy); simpl in |- *; repeat split; auto. apply less_leEq_trans with y1. auto. apply less_leEq; unfold x1, y1 in |- *; apply rht_b; auto. apply less_leEq; auto. elim H0; auto. unfold x1 in |- *; apply smaller_rht. unfold x1 in |- *; apply less_leEq; apply a_lft; auto. apply leEq_reflexive. exists (pairT x y1); exists (pairT Hx H3); simpl in |- *; repeat split; auto. apply leEq_less_trans with x1. apply less_leEq; unfold x1, y1 in |- *; apply a_lft; auto. auto. elim H0; auto. apply less_leEq; auto. unfold y1 in |- *; apply smaller_lft; auto. apply leEq_reflexive. apply less_leEq; unfold y1 in |- *; apply rht_b; auto. unfold y1 in |- *; inversion_clear Hx; inversion_clear Hy; split. apply leEq_transitive with x; auto. apply less_leEq; apply less_transitive_unfolded with x1; unfold x1 in |- *; [ apply a_lft | apply lft_rht ]; auto. apply leEq_transitive with y; auto. apply less_leEq; apply rht_b; auto. unfold x1 in |- *; inversion_clear Hx; inversion_clear Hy; split. apply leEq_transitive with x; auto. apply less_leEq; apply a_lft; auto. apply leEq_transitive with y; auto. apply less_leEq; apply less_transitive_unfolded with y1; unfold y1 in |- *; [ apply lft_rht | apply rht_b ]; auto. Qed. (* end hide *) (** We now iterate this construction. *) Record IVT_aux_seq_type : Type := {IVTseq1 : IR; IVTseq2 : IR; IVTH1 : I IVTseq1; IVTH2 : I IVTseq2; IVTprf : IVTseq1 [<] IVTseq2; IVTz1 : F IVTseq1 (incF _ IVTH1) [<=] z; IVTz2 : z [<=] F IVTseq2 (incF _ IVTH2)}. Definition IVT_iter : IVT_aux_seq_type -> IVT_aux_seq_type. Proof. intro Haux; elim Haux; intros. elim (IVT_seq_lemma (pairT IVTseq3 IVTseq4) (pairT IVTH3 IVTH4) IVTprf0 (conj IVTz3 IVTz4)). intro x; elim x; simpl in |- *; clear x; intros. elim p. intro x; elim x; simpl in |- *; clear x; intros. inversion_clear q. inversion_clear H0. inversion_clear H2. inversion_clear H3. apply Build_IVT_aux_seq_type with a0 b0 a1 b1; auto. Defined. Definition IVT_seq : nat -> IVT_aux_seq_type. Proof. intro n; induction n as [| n Hrecn]. apply Build_IVT_aux_seq_type with a b Ha Hb; auto. apply (IVT_iter Hrecn). Defined. (** We now define the sequences built from this iteration, starting with [a] and [b]. *) Definition a_seq (n : nat) := IVTseq1 (IVT_seq n). Definition b_seq (n : nat) := IVTseq2 (IVT_seq n). Definition a_seq_I (n : nat) : I (a_seq n) := IVTH1 (IVT_seq n). Definition b_seq_I (n : nat) : I (b_seq n) := IVTH2 (IVT_seq n). Lemma a_seq_less_b_seq : forall n : nat, a_seq n [<] b_seq n. Proof. exact (fun n : nat => IVTprf (IVT_seq n)). Qed. Lemma a_seq_leEq_z : forall n : nat, F _ (incF _ (a_seq_I n)) [<=] z. Proof. exact (fun n : nat => IVTz1 (IVT_seq n)). Qed. Lemma z_leEq_b_seq : forall n : nat, z [<=] F _ (incF _ (b_seq_I n)). Proof. exact (fun n : nat => IVTz2 (IVT_seq n)). Qed. Lemma a_seq_mon : forall i : nat, a_seq i [<=] a_seq (S i). Proof. intro. unfold a_seq in |- *. simpl in |- *. elim IVT_seq; simpl in |- *; intros. elim IVT_seq_lemma; simpl in |- *; intro. elim x; simpl in |- *; clear x; intros. elim p; clear p; intro. elim x; simpl in |- *; clear x; intros. case q; clear q; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. case a2; auto. Qed. Lemma b_seq_mon : forall i : nat, b_seq (S i) [<=] b_seq i. Proof. intro. unfold b_seq in |- *. simpl in |- *. elim IVT_seq; simpl in |- *; intros. elim IVT_seq_lemma; simpl in |- *; intro. elim x; simpl in |- *; clear x; intros. elim p; clear p; intro. elim x; simpl in |- *; clear x; intros. case q; clear q; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. case a2; auto. Qed. Lemma a_seq_b_seq_dist_n : forall n, b_seq (S n) [-]a_seq (S n) [=] Two [/]ThreeNZ[*] (b_seq n[-]a_seq n). Proof. intro. unfold a_seq, b_seq in |- *. simpl in |- *. elim IVT_seq; simpl in |- *; intros. elim IVT_seq_lemma; simpl in |- *; intro. elim x; simpl in |- *; clear x; intros. elim p; clear p; intro. elim x; simpl in |- *; clear x; intros. case q; clear q; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. case a2; clear a2; simpl in |- *; intros. case a2; auto. Qed. Lemma a_seq_b_seq_dist : forall n, b_seq n[-]a_seq n [=] (Two [/]ThreeNZ) [^]n[*] (b[-]a). Proof. simple induction n. simpl in |- *; algebra. clear n; intros. astepr (Two [/]ThreeNZ[*] (Two [/]ThreeNZ) [^]n[*] (b[-]a)). astepr (Two [/]ThreeNZ[*] ((Two [/]ThreeNZ) [^]n[*] (b[-]a))). astepr (Two [/]ThreeNZ[*] (b_seq n[-]a_seq n)). apply a_seq_b_seq_dist_n. Qed. Lemma a_seq_Cauchy : Cauchy_prop a_seq. Proof. intros e H. elim (intervals_small' a b e H); intros i Hi. exists i; intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. 2: apply Hi. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (a_seq i). 2: apply local_mon'_imp_mon'; auto; exact a_seq_mon. eapply leEq_wdr. 2: apply a_seq_b_seq_dist. apply minus_resp_leEq. apply less_leEq; apply a_b'. exact a_seq_mon. exact b_seq_mon. exact a_seq_less_b_seq. Qed. Lemma b_seq_Cauchy : Cauchy_prop b_seq. Proof. intros e H. elim (intervals_small' a b e H); intros i Hi. exists i; intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. 2: apply Hi. eapply leEq_wdl. 2: apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (b_seq m). 2: astepl ( [--][--] (b_seq m)); astepr ( [--][--] (b_seq i)). 2: apply inv_resp_leEq; apply local_mon'_imp_mon' with (f := fun n : nat => [--] (b_seq n)); auto. 2: intro; apply inv_resp_leEq; apply b_seq_mon. eapply leEq_wdr. 2: apply a_seq_b_seq_dist. unfold cg_minus in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. apply less_leEq; apply a_b'. exact a_seq_mon. exact b_seq_mon. exact a_seq_less_b_seq. Qed. Let xa := Lim (Build_CauchySeq _ _ a_seq_Cauchy). Let xb := Lim (Build_CauchySeq _ _ b_seq_Cauchy). Lemma a_seq_b_seq_lim : xa [=] xb. Proof. unfold xa, xb in |- *; clear xa xb. apply cg_inv_unique_2. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply Lim_minus. simpl in |- *. apply Limits_unique. simpl in |- *. intros eps H. elim (intervals_small' a b eps H); intros i Hi. exists i; intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. 2: apply Hi. eapply leEq_wdl. 2: apply AbsIR_minus. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (a_seq m[-]b_seq m). 2: apply shift_minus_leEq; astepr (b_seq m). 2: apply less_leEq; apply a_seq_less_b_seq. eapply leEq_wdr. 2: apply a_seq_b_seq_dist. rstepl (b_seq m[-]a_seq m). unfold cg_minus in |- *; apply plus_resp_leEq_both. astepl ( [--][--] (b_seq m)); astepr ( [--][--] (b_seq i)). apply inv_resp_leEq; apply local_mon'_imp_mon' with (f := fun n : nat => [--] (b_seq n)); auto. intro; apply inv_resp_leEq; apply b_seq_mon. apply inv_resp_leEq; apply local_mon'_imp_mon'; auto; exact a_seq_mon. Qed. Lemma xa_in_interval : I xa. Proof. split. unfold xa in |- *. apply leEq_seq_so_leEq_Lim. simpl in |- *. intro; elim (a_seq_I i); auto. unfold xa in |- *. apply seq_leEq_so_Lim_leEq. simpl in |- *. intro; elim (a_seq_I i); auto. Qed. Lemma IVT_I : {x : IR | I x | forall Hx, F x Hx [=] z}. Proof. exists xa. apply xa_in_interval. intro. apply cg_inv_unique_2; apply leEq_imp_eq. apply approach_zero. intros e H. apply leEq_less_trans with (e [/]TwoNZ). 2: apply pos_div_two'; auto. elim (contin_prop _ _ _ _ contF _ (pos_div_two _ _ H)); intros d H0 H1. elim (Cauchy_complete (Build_CauchySeq _ _ a_seq_Cauchy) _ H0); fold xa in |- *; simpl in |- *; intros N HN. apply leEq_transitive with (F xa Hx[-]F (a_seq N) (incF _ (a_seq_I N))). unfold cg_minus in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq; apply a_seq_leEq_z. eapply leEq_wdl. 2: apply AbsIR_eq_x. apply H1; auto. apply xa_in_interval. apply a_seq_I. apply AbsSmall_imp_AbsIR. apply AbsSmall_minus. auto. apply shift_leEq_minus; astepl (F _ (incF _ (a_seq_I N))). apply part_mon_imp_mon' with I; auto. apply a_seq_I. apply xa_in_interval. unfold xa in |- *. apply str_leEq_seq_so_leEq_Lim. exists N; intros; simpl in |- *. apply local_mon'_imp_mon'; auto; exact a_seq_mon. astepl ( [--]ZeroR); rstepr ( [--] (z[-]F xa Hx)). apply inv_resp_leEq. apply approach_zero. intros e H. apply leEq_less_trans with (e [/]TwoNZ). 2: apply pos_div_two'; auto. elim (contin_prop _ _ _ _ contF _ (pos_div_two _ _ H)); intros d H0 H1. elim (Cauchy_complete (Build_CauchySeq _ _ b_seq_Cauchy) _ H0); fold xb in |- *; simpl in |- *; intros N HN. apply leEq_transitive with (F (b_seq N) (incF _ (b_seq_I N)) [-]F xa Hx). apply minus_resp_leEq; apply z_leEq_b_seq. eapply leEq_wdl. 2: apply AbsIR_eq_x. apply H1; auto. apply b_seq_I. apply xa_in_interval. apply leEq_wdl with (AbsIR (b_seq N[-]xb)). 2: apply AbsIR_wd; apply cg_minus_wd; [ algebra | apply eq_symmetric_unfolded; apply a_seq_b_seq_lim ]. apply AbsSmall_imp_AbsIR. auto. apply shift_leEq_minus; astepl (F xa Hx). apply part_mon_imp_mon' with I; auto. apply xa_in_interval. apply b_seq_I. apply leEq_wdl with xb. 2: apply eq_symmetric_unfolded; apply a_seq_b_seq_lim. unfold xb in |- *. apply str_seq_leEq_so_Lim_leEq. exists N; intros; simpl in |- *. astepl ( [--][--] (b_seq i)); astepr ( [--][--] (b_seq N)). apply inv_resp_leEq. apply local_mon'_imp_mon' with (f := fun n : nat => [--] (b_seq n)); auto. intro; apply inv_resp_leEq; apply b_seq_mon. Qed. End IVT. corn-8.20.0/ftc/WeakIVTQ.v000066400000000000000000000123421473720167500151160ustar00rootroot00000000000000(** Author : Abhishek Anand ( http://www.cs.cornell.edu/~aa755/ ) *) Require Export CoRN.ftc.FTC. Definition Q2R (q: Q) : IR := (inj_Q IR q). Coercion Q2R : Q >-> st_car. From Coq Require Import Ring. Require Import CoRN.tactics.CornTac. Require Import CoRN.algebra.CRing_as_Ring. Add Ring IRisaRing: (CRing_Ring IR). Require Export CoRN.ftc.Derivative. Require Export CoRN.ftc.Integral. Lemma ltAddRhs : forall (a b : IR), [0][<]b -> a[<]a[+]b. intros ? ? Hlt. pose proof (leEq_reflexive _ a) as Hr. apply (plus_resp_less_leEq _ _ _ _ _ Hlt) in Hr. eapply less_wdl in Hr;[|apply cm_lft_unit_unfolded]. eapply less_wdr;[| apply cag_commutes_unfolded]. trivial. Qed. Lemma closeRationalR : forall (a b t d : IR) (Hab : a [<=] b), Compact Hab t -> t[<]b -> [0][<]d -> {q : Q | Compact Hab q /\ AbsIR (t[-]q)[<=]d}. Proof. intros ? ? ? ? ? p Hcc Hdp. pose proof (less_Min _ _ _ (ltAddRhs t d Hdp) Hcc) as Hmlt. pose proof (Q_dense_in_CReals' _ _ _ Hmlt) as Hqr. destruct Hqr as [q Hqr Hql]. exists q. simpl in p. unfold Q2R in p. destruct p as [pl pr]. assert ( a[<=]inj_Q IR q) as Haq by (eauto using less_leEq, leEq_less_trans). assert (inj_Q IR q[<=] b) as Hqb by (eauto using less_leEq, less_leEq_trans, Min_leEq_rht). split;[exact (Haq,Hqb)|]. rewrite AbsIR_minus. unfold Q2R. rewrite AbsIR_eq_x;[|eauto 4 using shift_zero_leEq_minus, less_leEq]. apply shift_minus_leEq. rewrite cag_commutes_unfolded. eauto using less_leEq,leEq_less_trans,leEq_reflexive, less_leEq_trans,Min_leEq_lft. Defined. Lemma ltMinusRhs: forall (x y: IR), [0] [<]y -> x[-]y[<]x. Proof. intros. apply shift_minus_less. apply ltAddRhs; auto. Qed. Lemma closeRationalL : forall (a b t d : IR) (Hab : a [<=] b), Compact Hab t -> a[<]t -> [0][<]d -> {q : Q | Compact Hab q /\ AbsIR (t[-]q)[<=]d}. Proof. intros ? ? ? ? ? p Hcc Hdp. pose proof (Max_less _ _ _ (ltMinusRhs _ d Hdp) Hcc) as Hmlt. pose proof (Q_dense_in_CReals' _ _ _ Hmlt) as Hqr. destruct Hqr as [q Hqr Hql]. exists q. simpl in p. unfold Q2R in p. destruct p as [pl pr]. assert (inj_Q IR q[<=] b) as Hqb by (eauto using less_leEq, less_leEq_trans). assert (a[<=] inj_Q IR q) as Haq by (eauto using less_leEq, less_leEq_trans, leEq_less_trans, rht_leEq_Max). split;[exact (Haq,Hqb)|]. rewrite AbsIR_eq_x;[|eauto 4 using shift_zero_leEq_minus, less_leEq]. apply shift_minus_leEq. apply shift_leEq_plus'. unfold Q2R. pose proof (lft_leEq_Max (t[-]d) a). apply less_leEq. eapply leEq_less_trans; eauto. Qed. Require Export CoRN.ftc.StrongIVT. Lemma closeRationalLR : forall (a b x d : IR) (Hab : a [<] b), (Compact (less_leEq _ _ _ Hab)) x -> [0][<]d -> {q : Q | (Compact (less_leEq _ _ _ Hab)) q /\ AbsIR (x[-]q)[<=]d}. Proof. intros ? ? ? ? ? Hcc Hdp. pose proof Hab as Hap. apply less_cotransitive_unfolded with (z:=x)in Hap. destruct Hap as [Hlt | Hgt]. - apply closeRationalL; auto. - apply closeRationalR; auto. Qed. (** this lemma is stronger than Weak_IVT. the only change is that the type of [x] (in the concluion) is Q, instead of IR *) Lemma Weak_IVTQ : forall (I : interval) (F : PartFunct IR), Continuous I F -> forall (a b : IR) (Ha : Dom F a) (Hb : Dom F b) (HFab : F a Ha[<]F b Hb), I a -> I b -> forall e : IR, [0][<]e -> forall y : IR, Compact (less_leEq IR (F a Ha) (F b Hb) HFab) y -> {x : Q | Compact (Min_leEq_Max a b) x /\ forall Hx : Dom F x, AbsIR (F x Hx[-]y)[<=]e}. Proof. intros ? ? Hc ? ? ? ? ? Hia Hib ? He ? Hcp. apply pos_div_two in He. pose proof He as Hivt. eapply Weak_IVT with (y:=y) (F:=F) (HFab := HFab) in Hivt; eauto. unfold compact in He. unfold Continuous in Hc. destruct Hc as [Hcl Hcr]. specialize (Hcr _ _ (Min_leEq_Max a b)). unfold Continuous_I in Hcr. match type of Hcr with ?A -> _ => assert A as H99 by (apply included_interval; auto); pose proof (included_trans _ _ _ _ H99 Hcl) as Hdom; specialize (Hcr H99); clear H99 end. apply snd in Hcr. specialize (Hcr _ He). destruct Hcr as [d Hdp Hcc]. destruct Hivt as [x Hmm Hfx]. pose proof HFab as Hap. specialize (fun xp => Hcc x xp Hmm). (* y already names a point in the co-domain *) apply less_imp_ap in Hap. apply pfstrx in Hap. apply ap_imp_Min_less_Max in Hap. pose proof (closeRationalLR _ _ _ _ Hap Hmm Hdp) as Hqq. destruct Hqq as [q H99]. exists q. destruct H99 as [Hcomp Hab]. split;[exact Hcomp|]. specialize (Hcc q Hcomp (Hdom _ Hmm) (Hdom _ Hcomp) Hab). specialize (Hfx (Hdom _ Hmm)). rewrite AbsIR_minus in Hcc. apply AbsIR_imp_AbsSmall in Hcc. apply AbsIR_imp_AbsSmall in Hfx. pose proof (AbsSmall_eps_div_two _ _ _ _ Hcc Hfx) as Hsum. clear Hfx Hcc. unfold cg_minus in Hsum. ring_simplify in Hsum. intros Hx. apply AbsSmall_imp_AbsIR. rewrite pfwdef with (Hy := Hx) in Hsum; trivial. apply eq_reflexive. Qed. corn-8.20.0/liouville/000077500000000000000000000000001473720167500145625ustar00rootroot00000000000000corn-8.20.0/liouville/CPoly_Euclid.v000066400000000000000000000204031473720167500172630ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CPoly_Degree Lia. Import CRing_Homomorphisms.coercions. Set Implicit Arguments. Unset Strict Implicit. Section poly_eucl. Variable CR : CRing. Add Ring CR: (CRing_Ring CR). Add Ring cpolycring_th : (CRing_Ring (cpoly_cring CR)). Lemma degree_poly_div : forall (m n : nat) (f g : cpoly CR), let f1 := (_C_ (nth_coeff n g) [*] f [-] _C_ (nth_coeff (S m) f) [*] ((_X_ [^] ((S m) - n)) [*] g)) in S m >= n -> degree_le (S m) f -> degree_le n g -> degree_le m f1. Proof. intros m n f g f1 ge_m_n df dg p Hp; unfold f1; clear f1. rewrite -> nth_coeff_minus, nth_coeff_c_mult_p, nth_coeff_c_mult_p, nth_coeff_mult. rewrite -> (Sum_term _ _ _ (S m - n)); [ | lia | lia | intros ]. rewrite -> nth_coeff_nexp_eq. destruct Hp. replace (S m - (S m - n)) with n by lia. unfold cg_minus. ring. rewrite -> (dg (S m0 - (S m - n))); [ | lia]. rewrite -> df; [ unfold cg_minus; ring | lia]. rewrite nth_coeff_nexp_neq. ring. assumption. Qed. Theorem cpoly_div1 : forall (m n : nat) (f g : cpoly_cring CR), degree_le m f -> degree_le (S n) g -> n <= m -> {qr: (cpoly_cring CR)*(cpoly_cring CR) & let (q,r):=qr in f [*] _C_ ((nth_coeff (S n) g) [^] (m - n)) [=] q [*] g [+] r & let (q,r):=qr in degree_le n r}. Proof. intros m n; generalize (refl_equal (m - n)). generalize (m - n) at 1 as p; intro p; revert m n; induction p; intros. exists (([0] : cpoly_cring CR),f). rewrite <- H. simpl (nth_coeff (S n) g[^]0). rewrite <- c_one. ring. replace n with m by lia; assumption. set (f1 := (_C_ (nth_coeff (S n) g) [*] f [-] _C_ (nth_coeff m f) [*] ((_X_ [^] (m - (S n))) [*] g))). destruct (IHp (m - 1) n) with (f := f1) (g := g); [ lia | | assumption | lia | ]. unfold f1; clear f1. assert (HypTmp : m = S (m - 1)); [ lia | rewrite HypTmp; rewrite <- HypTmp at 1 ]. apply degree_poly_div; [ lia | rewrite <- HypTmp; assumption | assumption ]. destruct x as [q1 r1]. exists (q1 [+] _C_ ((nth_coeff (S n) g)[^](m - S n) [*] (nth_coeff m f)) [*] _X_ [^] (m - S n), r1); [ | assumption]. unfold f1 in y. rewrite -> ring_distl_unfolded. rewrite <- plus_assoc_unfolded. rewrite -> (cag_commutes _ _ r1). rewrite -> plus_assoc_unfolded. rewrite <- y. replace (m - n) with (S (m - S n)) by lia. replace (m - 1 - n) with (m - S n) by lia. rewrite <- nexp_Sn. generalize (nth_coeff (S n) g) (nth_coeff m f) (m - S n). intros. rewrite c_mult, c_mult. unfold cg_minus. ring. Qed. Definition degree_lt_pair (p q : cpoly_cring CR) := (forall n : nat, degree_le (S n) q -> degree_le n p) and (degree_le O q -> p [=] [0]). Lemma cpoly_div2 : forall (n m : nat) (a b c : cpoly_cring CR), degree_le n a -> monic m b -> degree_lt_pair c b -> a [*] b [=] c -> a [=] [0]. Proof. induction n. intros m a b c H X H1 H2; destruct (degree_le_zero _ _ H) as [x s]. revert H1. rewrite -> s; destruct X as [H0 H1]; rewrite -> c_zero. rewrite -> s in H2. intro. apply cpoly_const_eq. destruct m. generalize (nth_coeff_wd _ 0 _ _ H2); destruct H3 as [d s0]. rewrite -> nth_coeff_c_mult_p, H0, mult_one, (nth_coeff_wd _ _ _ _ (s0 H1)). intro tmp; apply tmp. generalize (nth_coeff_wd _ (S m) _ _ H2); destruct H3 as [d s0]. rewrite -> nth_coeff_c_mult_p, H0, mult_one, (d m H1 (S m)). intro; assumption. apply le_n. intros. induction a as [ | a s ] using cpoly_induc; [ reflexivity | ]. apply _linear_eq_zero. revert H2. rewrite -> cpoly_lin, ring_distl_unfolded. intro H2. cut (a [=] [0]); [ intro aeqz; split; [ | apply aeqz ] | ]. assert (s [=] nth_coeff m (_C_ s[*]b[+]_X_[*]a[*]b)). destruct H0; rewrite -> nth_coeff_plus, nth_coeff_c_mult_p, H0. rewrite -> (nth_coeff_wd _ _ _ [0]); [ simpl; ring | ]. rewrite -> aeqz; ring. rewrite -> H3. rewrite -> (nth_coeff_wd _ _ _ _ H2). destruct H1 as [d s0]. destruct H0 as [H0 H1]. destruct m; [ rewrite -> (nth_coeff_wd _ _ _ _ (s0 H1)); reflexivity | apply (d m H1); apply le_n ]. apply (IHn (S m) _ ([0] [+X*] b) (c [-] _C_ s [*] b)); [ | | | rewrite <- H2, cpoly_lin, <- c_zero; unfold cg_minus; ring ]. unfold degree_le; intros; rewrite <- (coeff_Sm_lin _ _ s). apply H; apply -> Nat.succ_lt_mono; apply H3. split; [ rewrite -> coeff_Sm_lin; destruct H0; apply H0 | unfold degree_le; intros ]. destruct m0; [ inversion H3 | simpl; destruct H0 ]. apply H4; apply Nat.succ_lt_mono; apply H3. unfold degree_lt_pair. split; intros. unfold degree_le; intros. rewrite -> nth_coeff_minus, nth_coeff_c_mult_p, (degree_le_cpoly_linear _ _ _ _ H3); [ | apply H4 ]. rewrite -> cring_mult_zero, cg_inv_zero; destruct H1 as [d s0]. destruct m; [ destruct H0; apply (nth_coeff_wd _ _ _ _ (s0 H1)) | ]. apply (d n0); [ | apply H4 ]. apply (degree_le_mon _ _ n0); [ apply le_S; apply le_n | apply (degree_le_cpoly_linear _ _ _ _ H3) ]. destruct (degree_le_zero _ _ H3) as [x s0]. revert s0. rewrite -> cpoly_C_. intro s0. destruct (linear_eq_linear_ _ _ _ _ _ s0) as [H4 H5]. rewrite <- H2, -> H5. unfold cg_minus. ring. Qed. Lemma cpoly_div : forall (f g : cpoly_cring CR) (n : nat), monic n g -> ex_unq (fun (qr : ProdCSetoid (cpoly_cring CR) (cpoly_cring CR)) => f[=](fst qr)[*]g[+](snd qr) and degree_lt_pair (snd qr) g). Proof. intros f g n H; destruct n. destruct H; destruct (degree_le_zero _ _ H0). rewrite -> (nth_coeff_wd _ _ _ _ s) in H. simpl in H; rewrite -> H in s. exists (f,[0]). intros; destruct y; simpl (snd (s0, s1)) in *; simpl (fst (s0, s1)) in *. rename H1 into X. destruct X; destruct d; split; [ | symmetry; apply (s3 H0) ]. rewrite -> s2, (s3 H0), s, <- c_one; ring. simpl (fst (f, [0] : cpoly_cring CR)); simpl (snd (f, [0] : cpoly_cring CR)). replace (cpoly_zero CR) with ([0] : cpoly_cring CR) by (simpl;reflexivity). split; [ rewrite -> s, <- c_one; ring | ]. split; [ | reflexivity ]. unfold degree_le; intros; apply nth_coeff_zero. destruct (@cpoly_div1 (Nat.max (lth_of_poly f) n) n f g); [ | destruct H; assumption | apply Nat.le_max_r | ]. apply (@degree_le_mon _ _ (lth_of_poly f)); [ apply Nat.le_max_l | apply poly_degree_lth ]. destruct H; destruct x as [q r]. rewrite -> H, one_nexp, mult_one in y. assert (f[=]q[*]g[+]r and degree_lt_pair r g). split; [ assumption | ]. split. intros; unfold degree_le; intros; apply y0; apply Nat.le_lt_trans with n0; [ | assumption ]. unfold degree_le in H1; apply not_gt; intro; unfold gt in H3. set (tmp := (H1 (S n) (proj1 (Nat.succ_lt_mono _ _) H3))); rewrite -> H in tmp. apply (eq_imp_not_ap _ _ _ tmp); apply ring_non_triv. intro; unfold degree_le in H1; rewrite -> H1 in H; [ | apply Nat.lt_0_succ ]. destruct (eq_imp_not_ap _ _ _ H); apply ap_symmetric; apply ring_non_triv. exists (q,r); [ | assumption ]. intros y1 X0; destruct y1 as [q1 r1]; simpl (fst (q1, r1)); simpl (snd (q1, r1)) in X0. rename H1 into X. destruct X; destruct X0; rewrite -> s in s0; assert (q [=] q1). apply cg_inv_unique_2. apply (@cpoly_div2 (lth_of_poly (q [-] q1)) (S n) (q [-] q1) g (r1 [-] r)); [ apply poly_degree_lth | split; assumption | | ]. destruct d; destruct d0; split. intros; apply degree_le_minus; [ apply d0 | apply d ]; assumption. intro; rewrite -> (s1 H1) ,(s2 H1); unfold cg_minus; ring. assert (r1[=]q1[*]g[+]r1[-]q1[*]g); [ unfold cg_minus; ring | ]. rewrite -> H1, <- s0; unfold cg_minus; ring. split; [ assumption | ]. rewrite -> H1 in s0; apply (cg_cancel_lft _ _ _ _ s0). Qed. End poly_eucl. corn-8.20.0/liouville/CRingClass.v000066400000000000000000000047301473720167500167450ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot and Bas Spitters Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CRings RingClass. Section cring_is_ring. Global Instance CRing_is_Ring (CR : CRing) : Ring (@cm_unit CR) (@cr_one CR) (@csg_op CR) (@cr_mult CR) (fun x y => x [-] y) (@cg_inv CR). Proof with auto. split;split;algebra. Qed. End cring_is_ring. Section SubCRings. Variable CR : CRing. Variable P : CR -> Type. Variable Punit : P [0]. Variable op_pres_P : bin_op_pres_pred _ P csg_op. Variable inv_pres_P : un_op_pres_pred _ P cg_inv. Variable Pone : P [1]. Variable mul_pres_P : bin_op_pres_pred _ P cr_mult. Let subcrr : CAbGroup := Build_SubCAbGroup _ _ Punit op_pres_P inv_pres_P. Let submult : CSetoid_bin_op subcrr := Build_SubCSetoid_bin_op _ _ _ mul_pres_P. Lemma isring_scrr : is_CRing subcrr (Build_subcsetoid_crr _ _ _ Pone) submult. Proof. assert (associative submult). intros x y z; destruct x as [x xpf]; destruct y as [y ypf]; destruct z as [z zpf]; simpl; apply mult_assoc. apply (Build_is_CRing _ _ _ H). split; intro x; destruct x as [x xpf]; simpl; algebra. intros x y; destruct x as [x xpf]; destruct y as [y ypf]; simpl; apply mult_commutes. intros x y z; destruct x as [x xpf]; destruct y as [y ypf]; destruct z as [z zpf]; simpl; apply dist. simpl; apply ring_non_triv. Qed. Definition Build_SubCRing : CRing := Build_CRing _ _ _ isring_scrr. Global Instance SubCRing_is_SubRing : SubRing P. Proof. constructor; auto. intros x y Px Py; apply op_pres_P; [ | apply inv_pres_P ]; assumption. Qed. End SubCRings. corn-8.20.0/liouville/Liouville.v000066400000000000000000000364131473720167500167240ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CRing_Homomorphisms. Require Import CPoly_NthCoeff. Require Import MoreFunctions. Require Import Rolle. Require Import Zlcm Q_can RX_deg QX_ZX QX_root_loc QX_extract_roots. Section CPoly_bounded. Variable I : interval. Hypothesis I_fin : finite I. Fixpoint AbsPoly (P : cpoly_cring IR) : cpoly_cring IR := match P with | cpoly_zero _ => cpoly_zero IR | cpoly_linear _ c P => cpoly_linear IR (AbsIR c) (AbsPoly P) end. Lemma AbsPoly_zero : AbsPoly [0] = [0]. Proof. reflexivity. Qed. Lemma AbsPoly_linear : forall c P, AbsPoly (c[+X*]P) = AbsIR c[+X*]AbsPoly P. Proof. reflexivity. Qed. Lemma Abs_poly_nth_coeff : forall P i, nth_coeff i (AbsPoly P) [=] AbsIR (nth_coeff i P). Proof. intro P. pattern P; apply Ccpoly_induc; clear P. intro; rewrite -> AbsPoly_zero, nth_coeff_zero. symmetry; apply AbsIRz_isz. intros P c Hrec n. rewrite AbsPoly_linear. destruct n. rewrite -> coeff_O_lin; reflexivity. rewrite -> coeff_Sm_lin. rewrite -> Hrec. apply AbsIR_wd. symmetry; apply coeff_Sm_lin. Qed. Definition CPoly_bound (P : cpoly_cring IR) : IR := (AbsPoly P) ! (Max (AbsIR (left_end I I_fin)) (AbsIR (right_end I I_fin))). Lemma AbsIR_leEq : forall a b, a [<=] b -> [--]a [<=] b -> AbsIR a [<=] b. Proof. intros a b Hp Hm. unfold AbsIR, ABSIR; simpl. apply Max_leEq; assumption. Qed. Lemma abs_max : forall a b x, a [<=] x -> x [<=] b -> AbsIR x [<=] Max (AbsIR a) (AbsIR b). Proof. intros a b x Ha Hb. apply AbsIR_leEq. apply (leEq_transitive _ _ (AbsIR b)); [|apply rht_leEq_Max]. apply (leEq_transitive _ _ b); [assumption|apply leEq_AbsIR]. apply (leEq_transitive _ _ (AbsIR a)); [|apply lft_leEq_Max]. apply (leEq_transitive _ _ ([--]a)). apply inv_resp_leEq; assumption. rewrite -> AbsIR_inv; apply leEq_AbsIR. Qed. Lemma Abs_min_max : forall x, I x -> AbsIR x [<=] Max (AbsIR (left_end I I_fin)) (AbsIR (right_end I I_fin)). Proof. intros x HI; unfold left_end, right_end. destruct I; try inversion I_fin; destruct HI; apply abs_max; (apply less_leEq; assumption)|| assumption. Qed. Lemma CPoly_bound_spec : forall x P, I x -> AbsIR (P ! x) [<=] CPoly_bound P. Proof. intros x P HI. destruct (Cpoly_ex_degree _ P) as [n Hdeg]. destruct (Cpoly_ex_degree _ (AbsPoly P)) as [m HdegA]. unfold CPoly_bound. generalize (degree_le_mon _ _ _ _ (Nat.le_max_l n m) Hdeg). generalize (degree_le_mon _ _ _ _ (Nat.le_max_r n m) HdegA). revert HI. generalize (Nat.max n m). clear. intros n HI HdegP HdegA. rewrite -> (poly_as_sum _ _ _ HdegP). rewrite -> (poly_as_sum _ _ _ HdegA). apply (leEq_transitive _ _ (Sum 0 n (fun i => AbsIR (nth_coeff i P[*]x[^]i)))). apply triangle_SumIR. apply Nat.le_0_l. apply Sum_resp_leEq. apply Nat.le_0_l. intros i H1 H2. rewrite -> AbsIR_resp_mult. rewrite -> Abs_poly_nth_coeff. apply mult_resp_leEq_lft; [|apply AbsIR_nonneg]. rewrite -> AbsIR_nexp_op. apply nexp_resp_leEq; [apply AbsIR_nonneg|]. apply Abs_min_max; assumption. Qed. End CPoly_bounded. Section poly_law_of_mean. Variable I : interval. Hypothesis I_fin : finite I. Hypothesis I_proper : proper I. Variable P : cpoly_cring IR. Let C := CPoly_bound I I_fin (_D_ P). Let Hderiv := Derivative_poly I I_proper P. Lemma poly_law_of_mean : forall a b, I a -> I b -> AbsIR (P ! b [-] P ! a) [<=] C [*] (AbsIR (b [-] a)). Proof. intros a b Ha Hb. set (Law_of_the_Mean_Abs_ineq I I_proper (FPoly IR P) (FPoly IR (_D_ P)) Hderiv a b Ha Hb (CPoly_bound I I_fin (_D_ P))). simpl in c. apply c; [|auto|auto]. clear c; intros x Hcomp Htrue; clear Htrue. apply CPoly_bound_spec. destruct Hcomp. destruct I; simpl in *; try auto; try split; try (destruct Ha; destruct Hb); (apply (less_leEq_trans _ _ (MIN a b)); [apply less_Min|]; assumption)|| (apply (leEq_less_trans _ _ (MAX a b)); [|apply Max_less]; assumption)|| (apply (leEq_transitive _ _ (MIN a b)); [apply leEq_Min|]; assumption)|| (apply (leEq_transitive _ _ (MAX a b)); [|apply Max_leEq]; assumption). Qed. End poly_law_of_mean. Section liouville_lemmas. Variable a : IR. Definition Ia : interval := clcr (a[-]Two) (a[+]Two). Lemma Ia_fin : finite Ia. Proof. simpl; auto. Qed. Lemma Ia_proper : proper Ia. Proof. simpl. apply shift_minus_less. apply (less_wdl _ (a[+](([0][+][0][+][0])[+]([0][+][0][+][0])))); [|rational]. apply (less_wdr _ _ (a[+](Two[+]Two))); [|rational]. apply plus_resp_less_lft. apply plus_resp_less_both. apply plus_resp_less_both; [|apply pos_one]. apply plus_resp_less_lft; apply pos_one. apply plus_resp_less_both; [|apply pos_one]. apply plus_resp_less_lft; apply pos_one. Qed. Lemma a_in_Ia : Ia a. Proof. split. apply less_leEq. apply (less_wdr _ _ (a[-]([0][+][0][+][0]))); [|rational]. apply minus_resp_less_rht. apply plus_resp_less_both; [|apply pos_one]. apply plus_resp_less_lft; apply pos_one. apply less_leEq. apply (less_wdl _ (a[+]([0][+][0][+][0]))); [|rational]. apply plus_resp_less_lft. apply plus_resp_less_both; [|apply pos_one]. apply plus_resp_less_lft; apply pos_one. Qed. Lemma Liouville_lemma1 : forall x : IR, AbsIR (x[-]a) [<=] Two -> Ia x. Proof. intros x Hle. split. apply (leEq_wdr _ _ (x[+]Two[-]Two)); [|rational]. apply minus_resp_leEq. apply (leEq_wdl _ (x[+](a[-]x))); [|rational]. apply plus_resp_leEq_lft. rewrite -> AbsIR_minus in Hle. apply (leEq_transitive _ _ (AbsIR (a[-]x))); [|assumption]. apply leEq_AbsIR. apply (leEq_wdl _ (x[-]Two[+]Two)); [|rational]. apply plus_resp_leEq. apply (leEq_wdr _ _ (x[-](x[-]a))); [|rational]. apply minus_resp_leEq_rht. apply (leEq_transitive _ _ (AbsIR (x[-]a))); [|assumption]. apply leEq_AbsIR. Qed. Variable P : cpoly_cring IR. Let C := CPoly_bound Ia Ia_fin (_D_ P). Lemma Liouville_lemma2 : forall x : IR, AbsIR (x[-]a) [<=] Two -> AbsIR (P ! x [-] P ! a) [<=] C [*] AbsIR (x [-] a). Proof. intros x Hle. apply (poly_law_of_mean Ia Ia_fin Ia_proper P a x a_in_Ia (Liouville_lemma1 x Hle)). Qed. Lemma Liouville_lemma3 : forall x : IR, [1] [<] x or x [<] Two. Proof. intro x. apply less_cotransitive_unfolded. apply (less_wdl _ ([0][+][0][+][1])); [|rational]. apply plus_resp_less_rht. apply plus_resp_less_lft. apply pos_one. Qed. End liouville_lemmas. Section liouville_lemmas2. Let ZX_deg := RX_deg Z_as_CRing Z_dec. Variable P : cpoly_cring Z_as_CRing. Lemma Liouville_lemma4 : forall p : Z_as_CRing, p [#] [0] -> [1] [<=] AbsIR (inj_Q_rh p). Proof. intros p Hap. change ([1][<=]AbsIR(inj_Q IR p)). rewrite -> AbsIR_Qabs. unfold Qabs.Qabs. unfold inject_Z. rewrite <- inj_Q_One. apply inj_Q_leEq. unfold Z.abs. destruct p. destruct Hap; reflexivity. simpl; unfold Qle; simpl; intuition. simpl; unfold Qle; simpl; intuition. Qed. Lemma Liouville_lemma5 : forall (p : Z_as_CRing) (q : positive), (zx2qx P) ! (p#q)%Q [#] [0] -> [1] [<=] (inj_Q_rh q)[^](ZX_deg P) [*] AbsIR (inj_Q_rh ((zx2qx P) ! (p#q)%Q)). Proof. intros p q Hap. set (n := ZX_deg P). assert (Zpos q=Z.abs q); [reflexivity|]. rewrite H; clear H. rewrite <- nexp_ring_hom. assert (((Z.abs q):Q_as_CRing)[^]n [=] Z.abs ((q:Z_as_CRing)[^]n)). generalize n; clear; induction n; [reflexivity|]. rewrite <- nexp_Sn. rewrite <- nexp_Sn. rewrite Zabs_Zmult. rewrite -> IHn. reflexivity. rewrite -> H; clear H. rewrite <- (AbsIR_Qabs ((q:Z_as_CRing)[^]n)). rewrite <- AbsIR_resp_mult. change (inj_Q IR ((q:Z_as_CRing)[^]n)) with (inj_Q_rh ((q:Z_as_CRing)[^]n)). rewrite <- rh_pres_mult. assert (inject_Z ((q:Z_as_CRing)[^]n) [=] (inject_Z (q:Z_as_CRing))[^]n). generalize n; clear; induction n; [reflexivity|]. rewrite <- nexp_Sn. rewrite <- nexp_Sn. rewrite <- IHn. reflexivity. rewrite -> H; clear H. set (H:=Q_Z_poly_apply P p q). cbv zeta in H. fold ZX_deg in H. fold n in H. rewrite -> H. apply Liouville_lemma4. intro. destruct (ap_imp_neq _ _ _ Hap); clear Hap. assert ((inject_Z (Zpos q))[^]n [#] [0]). generalize n; clear; induction n; [discriminate|]. intro; destruct IHn. rewrite <- nexp_Sn in H. destruct (Qmult_integral _ _ H); [discriminate|assumption]. rewrite -> H0 in H. apply (mult_eq_zero _ _ _ X); assumption. Qed. End liouville_lemmas2. Section liouville_lemmas3. Let ZX_deg := RX_deg Z_as_CRing Z_dec. Let QX_deg := RX_deg Q_as_CRing Q_dec. Variable P : cpoly_cring Q_as_CRing. Lemma Liouville_lemma6 : forall (p : Z_as_CRing) (q : positive), P ! (p#q)%Q [#] [0] -> [1] [<=] (inj_Q_rh q)[^](QX_deg P) [*] AbsIR (inj_Q_rh ((Zlcm_den_poly P:Q_as_CRing)[*]P ! (p#q)%Q)). Proof. intros p q Hap. assert ((zx2qx (qx2zx P)) ! (p#q)%Q[#][0]). case (Q_dec ((zx2qx (qx2zx P)) ! (p#q)%Q) [0]); [|tauto]. intro Heq; destruct (ap_imp_neq _ _ _ Hap); revert Heq. rewrite -> qx2zx_spec. rewrite -> mult_apply, c_apply. intro Heq. apply (mult_eq_zero _ (Zlcm_den_poly P:Q_as_CField)). replace (cm_unit Q_as_CField) with (inject_Z (cm_unit Z_as_CRing)) by reflexivity. intro Heq2; rewrite Q.Qeq_Zeq in Heq2. apply (eq_imp_not_ap _ (Zlcm_den_poly P) [0]). assumption. apply Zlcm_den_poly_nz. assumption. rewrite -> qx2zx_deg; fold ZX_deg. apply (leEq_wdr _ _ _ _ (Liouville_lemma5 _ _ _ X)); fold ZX_deg. apply mult_wdr. apply AbsIR_wd. apply csf_wd. rewrite -> qx2zx_spec. rewrite -> mult_apply, c_apply; reflexivity. Qed. Lemma Liouville_lemma7 : forall (p : Z_as_CRing) (q : positive), P ! (p#q)%Q [#] [0] -> [1] [<=] (inj_Q_rh q)[^](QX_deg P) [*] AbsIR (inj_Q_rh (Zlcm_den_poly P:Q_as_CRing)) [*] AbsIR (inj_Q_rh (P ! (p#q)%Q)). Proof. intros p q Hap. apply (leEq_wdr _ _ _ _ (Liouville_lemma6 _ _ Hap)). rewrite <- CRings.mult_assoc. apply mult_wdr. rewrite -> rh_pres_mult. apply AbsIR_resp_mult. Qed. Variable a : IR. Let C := AbsIR (inj_Q_rh (Zlcm_den_poly P:Q_as_CRing)) [*] CPoly_bound (Ia a) (Ia_fin a) (_D_ (inj_QX_rh P)). Hypothesis Ha : (inj_QX_rh P) ! a [=] [0]. Lemma Liouville_lemma8 : forall (n : nat) (q : positive), [1] [<=] (inj_Q_rh q)[^]n. Proof. intros n q; induction n. apply leEq_reflexive. rewrite <- nexp_Sn. apply (leEq_wdl _ ([1][*][1])); [|rational]. apply mult_resp_leEq_both; [apply less_leEq; apply pos_one|apply less_leEq; apply pos_one| |apply IHn]. rewrite <- (rh_pres_unit _ _ inj_Q_rh). apply inj_Q_leEq. simpl; unfold Qle; simpl; rewrite Pmult_1_r. unfold Z.le; simpl. case q; intros; discriminate. Qed. Lemma Liouville_lemma9 : forall (p : Z_as_CRing) (q : positive), P ! (p#q)%Q [#] [0] -> AbsIR ((inj_Q_rh (p#q)%Q) [-] a) [<=] Two -> [1] [<=] (inj_Q_rh q)[^](QX_deg P) [*] C [*] AbsIR ((inj_Q_rh (p#q)%Q) [-] a). Proof. intros p q Hap Hle. apply (leEq_transitive _ _ _ _ (Liouville_lemma7 _ _ Hap)). rewrite <- CRings.mult_assoc, <- CRings.mult_assoc. apply mult_resp_leEq_lft. unfold C. rewrite <- CRings.mult_assoc. apply mult_resp_leEq_lft; [|apply AbsIR_nonneg]. apply (leEq_wdl _ _ _ _ (Liouville_lemma2 _ _ _ Hle)). apply AbsIR_wd. rewrite -> Ha. rewrite -> cg_inv_zero. unfold inj_QX_rh. rewrite -> cpoly_map_apply; reflexivity. set (Liouville_lemma8 (QX_deg P) q). apply (leEq_transitive _ _ [1]); [apply less_leEq; apply pos_one|]. apply Liouville_lemma8. Qed. Let C' := Max [1] C. Lemma Liouville_lemma10 : forall (p : Z_as_CRing) (q : positive), P ! (p#q)%Q [#] [0] -> [1] [<=] (inj_Q_rh q)[^](QX_deg P) [*] C' [*] AbsIR ((inj_Q_rh (p#q)%Q) [-] a). Proof. intros p q Hap. destruct (Liouville_lemma3 (AbsIR (inj_Q_rh (p # q)%Q[-]a))). apply (leEq_transitive _ _ _ _ (less_leEq _ _ _ c)). apply (leEq_wdl _ ([1] [*] AbsIR (inj_Q_rh (p#q)%Q [-] a))); [|rational]. apply mult_resp_leEq_rht; [|apply AbsIR_nonneg]. apply (leEq_wdl _ ([1] [*] [1])); [|rational]. apply mult_resp_leEq_both; [apply less_leEq; apply pos_one|apply less_leEq; apply pos_one| |apply lft_leEq_Max]. apply Liouville_lemma8. apply (leEq_transitive _ _ _ _ (Liouville_lemma9 _ _ Hap (less_leEq _ _ _ c))). apply mult_resp_leEq_rht; [|apply AbsIR_nonneg]. apply mult_resp_leEq_lft; [|]. unfold C'; apply rht_leEq_Max. apply (leEq_transitive _ _ [1]); [apply less_leEq; apply pos_one|]. apply Liouville_lemma8. Qed. End liouville_lemmas3. Section liouville_theorem. Variable a : IR. Hypothesis a_irrat : forall x : Q, a [~=] inj_Q _ x. Variable P : cpoly_cring Q_as_CRing. Hypothesis P_nz : P [#] [0]. Hypothesis a_alg : (inj_QX_rh P) ! a [=] [0]. Let C : IR := Max [1] (AbsIR (inj_Q_rh (Zlcm_den_poly (QX_extract_roots P):Q_as_CRing)) [*] CPoly_bound (Ia a) (Ia_fin a) (_D_ (inj_QX_rh (QX_extract_roots P)))). Lemma constant_pos : [0] [<] C. Proof. unfold C. apply (less_leEq_trans _ _ [1]). apply pos_one. apply lft_leEq_Max. Qed. Lemma constant_nz : C [#] [0]. Proof. apply pos_ap_zero; apply constant_pos. Qed. Definition Liouville_constant : IR := [1] [/] C [//] constant_nz. Definition Liouville_degree := RX_deg _ Q_dec (QX_extract_roots P). Theorem Liouville_theorem : forall (x : Q), (Liouville_constant[*]inj_Q IR (1#Qden x)%Q[^]Liouville_degree) [<=] AbsIR (inj_Q _ x [-] a). Proof. intro x. destruct x as [p q]; unfold Qden. apply (mult_cancel_leEq _ _ _ (inj_Q_rh q[^]Liouville_degree)). apply (less_leEq_trans _ _ [1]); [apply pos_one|]. apply Liouville_lemma8. assert (H : inj_Q IR (1#q)%Q = inj_Q_rh (1#q)%Q). reflexivity. rewrite H; clear H. rewrite <- nexp_ring_hom. rewrite <- CRings.mult_assoc. rewrite <- nexp_ring_hom. rewrite <- rh_pres_mult. assert (H : (1 # q)%Q[^]Liouville_degree[*](inject_Z q)[^]Liouville_degree [=] [1]). rewrite <- mult_nexp. rewrite <- (one_nexp _ Liouville_degree). apply nexp_wd; reflexivity. rewrite -> H; clear H. rewrite -> rh_pres_unit. rewrite -> mult_one. unfold Liouville_constant. apply shift_div_leEq'. apply constant_pos. assert (H : (inj_QX_rh (QX_extract_roots P)) ! a[=][0]). apply QX_extract_roots_spec_nrat; assumption. assert (H1 : (QX_extract_roots P) ! ((p # q)%Q)[#][0]). apply QX_extract_roots_spec_rat; assumption. apply (leEq_wdr _ _ _ _ (Liouville_lemma10 _ _ H _ _ H1)). fold C. rewrite -> (mult_commutes _ _ C). rewrite <- CRings.mult_assoc. apply mult_wdr. rewrite -> mult_commutes. apply mult_wdr. unfold Liouville_degree. symmetry; apply nexp_ring_hom. Qed. Theorem Liouville_theorem2 : {n : nat | {C : IR | [0] [<] C | forall (x : Q), (C[*]inj_Q IR (1#Qden x)%Q[^]n) [<=] AbsIR (inj_Q _ x [-] a)}}. Proof. exists Liouville_degree. exists Liouville_constant. unfold Liouville_constant. apply recip_resp_pos. apply constant_pos. intro x. apply Liouville_theorem. Qed. End liouville_theorem. corn-8.20.0/liouville/QX_ZX.v000066400000000000000000000275651473720167500157410ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CPoly_Degree. Require Import CoRN.model.rings.Qring. Require Import Zring. Require Import Qordfield. Require Import CRing_Homomorphisms. Require Import RingClass CRingClass. Require Import Zlcm Q_can RX_deg. Section Z_Q. Let QX := cpoly_cring Q_as_CRing. Add Ring q_r : (r_rt (Ring:=CRing_is_Ring Q_as_CRing)). Add Ring qx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring Q_as_CRing))). Let ZX := cpoly_cring Z_as_CRing. Add Ring zx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring Z_as_CRing))). Let ZX_deg := RX_deg Z_as_CRing Z_dec. Let ZX_dec := RX_dec Z_as_CRing Z_dec. Let QX_dec := RX_dec Q_as_CRing Q_dec. Let QX_deg := RX_deg Q_as_CRing Q_dec. Definition in_ZX (P : QX) := forall n, in_Z (nth_coeff n P). Definition QX_normalize (p : QX) : Q_as_CRing := match (Qeq_dec (nth_coeff (QX_deg p) p) [0]) with | left _ => [0] | right H => [1] [/] (nth_coeff (QX_deg p) p) [//] H end. Lemma QX_normalize_spec : forall p : QX, p [#] [0] -> monic (QX_deg p) ((_C_ (QX_normalize p)) [*] p). Proof. intros p H. destruct (RX_deg_spec _ Q_dec _ H) as [Hcoeff Hdeg]. split. rewrite -> nth_coeff_c_mult_p. unfold QX_normalize. case (Qeq_dec (nth_coeff (QX_deg p) p) [0]). intro; destruct Hcoeff; assumption. intro Hap. apply (div_1 Q_as_CField). intros m Hlt; rewrite -> nth_coeff_c_mult_p. rewrite -> (Hdeg m Hlt). ring. Qed. Definition QX_to_monic (p : QX) : QX := (_C_ (QX_normalize p)) [*] p. Lemma QX_to_monic_spec : forall p : QX, p [#] [0] -> monic (QX_deg p) (QX_to_monic p). Proof. intros p H. apply QX_normalize_spec. assumption. Qed. Lemma QX_to_monic_apply : forall (p : QX) (a : Q), p ! a [=] [0] -> (QX_to_monic p) ! a [=] [0]. Proof. intros p a Heq. unfold QX_to_monic; rewrite -> mult_apply; rewrite -> Heq; ring. Qed. Fixpoint den_list (P : QX) : list Z_as_CRing := match P with | cpoly_zero _ => [1]::nil | cpoly_linear _ c P => Q_can_den c::den_list P end. Lemma den_list_zero : den_list [0] = [1]::nil. Proof. reflexivity. Qed. Lemma den_list_linear : forall c P, den_list (c[+X*]P) = Q_can_den c::den_list P. Proof. reflexivity. Qed. Lemma den_list_spec : forall P n, n <= QX_deg P -> In (Q_can_den (nth_coeff n P)) (den_list P). Proof. intro P; pattern P; apply Ccpoly_induc; clear P. simpl; left. rewrite Q_can_den_pos_val_spec. unfold Q_can_den_pos_val; reflexivity. intros P c Hrec n. unfold QX_deg; rewrite RX_deg_linear; fold QX_deg; fold QX_dec. case (QX_dec P [0]). simpl. case n. left; reflexivity. intros A B C; inversion C. intros Hap Hle. simpl. destruct n. left; reflexivity. right; apply Hrec. apply le_S_n; assumption. Qed. Definition Zlcm_den_poly (P : QX) := Zlcm_gen (den_list P). Lemma Zlcm_den_poly_nz : forall P, Zlcm_den_poly P [#] [0]. Proof. intro P; apply Zlcm_gen_nz. intro a; pattern P; apply Ccpoly_induc; clear P. simpl; intro H; destruct H; [|contradiction]. rewrite <- H; discriminate. intros P c. rewrite den_list_linear. rewrite Q_can_den_pos_val_spec. induction (den_list P). simpl; intros. destruct H0; [rewrite <- H0; discriminate|contradiction]. simpl; intros. destruct H0; [rewrite <- H0; discriminate|]. apply H; assumption. Qed. Lemma den_1_div_iff : forall q : Q_as_CRing, Q_can_den q = 1 <-> Zdivides (Qden q) (Qnum q). Proof. intro q. split; intro H. unfold Q_can_den in H. destruct q; simpl in *. cut (Zpos Qden = Zgcd Qnum Qden). intro H0; rewrite H0. apply Zgcd_is_divisor_lft. rewrite (Zgcd_div_mult_rht Qnum Qden) at 1. rewrite H. apply Zmult_1_l. intro. destruct (Zgcd_zero _ _ H0). rewrite H1 in H. rewrite H2 in H. rewrite Zgcd_zero_rht in H. rewrite Zdiv_0_r in H. discriminate. unfold Q_can_den. destruct q; simpl in *. case (Z_dec Qnum 0). intro H0; rewrite H0. rewrite Zgcd_zero_lft. apply Z_div_same_full. discriminate. intro Hap. cut (Zpos Qden = Zgcd Qnum Qden). intro H0; rewrite H0 at 1. apply Z_div_same_full. intro H1; destruct (Zgcd_zero _ _ H1). discriminate. symmetry. apply Zgcd_divisor; assumption. Qed. Fixpoint Q_can_num_poly (P : QX) : ZX := match P with | cpoly_zero _ => cpoly_zero Z_as_CRing | cpoly_linear _ c Q => cpoly_linear Z_as_CRing (Q_can_num c) (Q_can_num_poly Q) end. Lemma Q_can_num_poly_zero : Q_can_num_poly [0] = [0]. Proof. reflexivity. Qed. Lemma Q_can_num_poly_linear : forall c P, Q_can_num_poly (c[+X*]P) = Q_can_num c[+X*]Q_can_num_poly P. Proof. reflexivity. Qed. Lemma Q_can_num_poly_spec : forall P Q, P [=] Q -> Q_can_num_poly P [=] Q_can_num_poly Q. Proof. intros P Q; pattern P, Q; apply Ccpoly_double_sym_ind; clear P Q. intros P Q Hsym Heq. symmetry; apply Hsym; symmetry; assumption. intro P. pattern P; apply Ccpoly_induc; clear P. reflexivity. intros P c Hrec Heq. destruct (zero_eq_linear_ _ _ _ Heq). split. rewrite (Q_can_num_spec _ [0]). reflexivity. assumption. change ([0] [=] Q_can_num_poly P). symmetry; apply Hrec; symmetry; assumption. intros P Q c d Hrec Heq. destruct (linear_eq_linear_ _ _ _ _ _ Heq). rewrite Q_can_num_poly_linear, Q_can_num_poly_linear. apply _linear_eq_linear. split. apply Q_can_num_spec; assumption. apply Hrec; assumption. Qed. Lemma Q_can_num_poly_deg_eq : forall P, QX_deg P = ZX_deg (Q_can_num_poly P). Proof. intro P. pattern P; apply Ccpoly_induc; clear P. reflexivity. intros P c Heq. rewrite Q_can_num_poly_linear. unfold QX_deg, ZX_deg. rewrite RX_deg_linear; fold QX_dec. rewrite RX_deg_linear; fold ZX_dec. fold QX_deg; fold ZX_deg. rewrite <- Heq. case (QX_dec P [0]). case (ZX_dec (Q_can_num_poly P) [0]). reflexivity. intros Hap Heq2; destruct (ap_imp_neq _ _ _ Hap); revert Heq2; clear. pattern P; apply Ccpoly_induc; clear P. reflexivity. intros P c Hrec Heq; destruct (linear_eq_zero_ _ _ _ Heq). rewrite Q_can_num_poly_linear. apply _linear_eq_zero; split. rewrite (Q_can_num_spec _ _ H); reflexivity. apply Hrec; assumption. intro Hap; case (ZX_dec (Q_can_num_poly P) [0]). intro Heq2; destruct (ap_imp_neq _ _ _ Hap); revert Heq2; clear. pattern P; apply Ccpoly_induc; clear P. reflexivity. intros P c Hrec Heq. rewrite Q_can_num_poly_linear in Heq. destruct (linear_eq_zero_ _ _ _ Heq). apply _linear_eq_zero; split; [|apply Hrec; assumption]. revert H; clear; destruct c as [qn qd]. unfold Q_can_num; simpl; unfold Qeq; simpl. rewrite Zmult_1_r. intro H; rewrite (Zgcd_div_mult_lft qn qd). rewrite H. apply Zmult_0_l. intro H0; destruct (Zgcd_zero _ _ H0); discriminate. reflexivity. Qed. Lemma nth_coeff_Q_can_num_poly_spec : forall P n, nth_coeff n (Q_can_num_poly P) = Q_can_num (nth_coeff n P). Proof. intro P; pattern P; apply Ccpoly_induc; clear P. simpl; unfold Q_can_num. rewrite Zdiv_0_l; reflexivity. destruct n. reflexivity. rewrite Q_can_num_poly_linear. rewrite -> coeff_Sm_lin. rewrite H. apply Q_can_num_spec. symmetry; apply coeff_Sm_lin. Qed. Lemma injZ_strext : fun_strext (inject_Z : Z_as_CRing -> Q_as_CRing). Proof. intros x y. unfold inject_Z; simpl; unfold Qap, Qeq, ap_Z; simpl. rewrite Zmult_1_r, Zmult_1_r; tauto. Qed. Lemma injZ_spec : forall q : Q_as_CRing, in_Z q -> q [=] (Q_can_num q). Proof. unfold in_Z. intros q Hin. destruct q as [qn qd]. unfold inject_Z. simpl; unfold Qeq; simpl. rewrite Zmult_1_r. unfold Q_can_num; simpl. unfold Q_can_den in Hin. simpl in Hin. cut (Zpos qd = Zgcd qn qd). intro H; rewrite H at 2. rewrite Zmult_comm. symmetry; apply Zdivides_spec. apply Zgcd_is_divisor_lft. rewrite (Zgcd_div_mult_rht qn qd) at 1. rewrite Hin; rewrite Zmult_1_l; reflexivity. intro H; destruct (Zgcd_zero _ _ H); discriminate. Qed. Lemma injZ_spec2 : forall p : Z_as_CRing, p = Q_can_num p. Proof. intro p. unfold Q_can_num, inject_Z; simpl. rewrite Zgcd_one_rht, Zdiv_1_r; reflexivity. Qed. Definition injZ_fun := Build_CSetoid_fun _ _ _ injZ_strext. Lemma injZ_pres_plus : fun_pres_plus _ _ injZ_fun. Proof. intros x y. simpl; unfold inject_Z, Qeq; simpl. ring. Qed. Lemma injZ_pres_unit : fun_pres_unit _ _ injZ_fun. Proof. unfold fun_pres_unit; simpl; unfold inject_Z, Qeq. simpl; reflexivity. Qed. Lemma injZ_pres_mult : fun_pres_mult _ _ injZ_fun. Proof. intros x y. reflexivity. Qed. Definition injZ_rh := Build_RingHom _ _ _ injZ_pres_plus injZ_pres_mult injZ_pres_unit. Definition zx2qx := cpoly_map injZ_rh. Lemma zx2qx_zero : zx2qx [0] = [0]. Proof. reflexivity. Qed. Lemma zx2qx_linear : forall c P, zx2qx (c[+X*]P) = (c:Q_as_CRing)[+X*]zx2qx P. Proof. reflexivity. Qed. Lemma nth_coeff_zx2qx : forall P n, nth_coeff n (zx2qx P) [=] nth_coeff n P. Proof. intro P; pattern P; apply Ccpoly_induc; clear P. reflexivity. intros P c Hrec n. rewrite zx2qx_linear. induction n. reflexivity. rewrite -> coeff_Sm_lin, coeff_Sm_lin. apply Hrec. Qed. Lemma zx2qx_spec : forall P : QX, in_ZX P -> P [=] zx2qx (Q_can_num_poly P). Proof. intros P Hin. apply all_nth_coeff_eq_imp. intro n. set (Hin n). rewrite -> nth_coeff_zx2qx. rewrite -> (injZ_spec _ i). unfold inject_Z; simpl; unfold Qeq; simpl. rewrite Zmult_1_r, Zmult_1_r. symmetry; apply nth_coeff_Q_can_num_poly_spec. Qed. Lemma Zlcm_den_poly_spec0 : forall P n, nth_coeff n (_C_ (Zlcm_den_poly P:Q_as_CRing) [*] P) [=] Qmake (Zlcm_den_poly P * Qnum (nth_coeff n P)) (Qden (nth_coeff n P)). Proof. intros P n. rewrite -> nth_coeff_c_mult_p. simpl. generalize (Zlcm_den_poly P), (nth_coeff n P); clear; intros z q. destruct q as [qn qd]; simpl. unfold Qmult; simpl. reflexivity. Qed. Lemma Zlcm_den_poly_spec : forall P, in_ZX (_C_ (Zlcm_den_poly P:Q_as_CRing) [*] P). Proof. intros P n. unfold in_Z. case (le_lt_dec n (QX_deg P)). transitivity (Q_can_den ((Qmake (Zlcm_den_poly P) xH) [*] nth_coeff n P)). apply Q_can_den_spec. apply nth_coeff_c_mult_p. simpl; unfold Qmult; simpl. rewrite -> den_1_div_iff. unfold Qmult; simpl. unfold Zlcm_den_poly. rewrite (Zgcd_div_mult_rht (Qnum (nth_coeff n P)) (Qden (nth_coeff n P))); try (intro H0; destruct (Zgcd_zero _ _ H0); discriminate). fold (Q_can_den (nth_coeff n P)). apply Zdivides_mult_elim; try apply Zgcd_is_divisor_lft. apply Zlcm_gen_spec. apply den_list_spec; assumption. intros Hgt. cut (nth_coeff n (_C_ (Zlcm_den_poly P:Q_as_CRing)[*]P) [=] [0]). intro Heq. transitivity (Q_can_den [0]). apply Q_can_den_spec; assumption. rewrite Q_can_den_pos_val_spec; reflexivity. case (RX_dec _ Q_dec P [0]). intro H. transitivity (nth_coeff n ([0]:QX)). apply nth_coeff_wd. rewrite -> H at 2. apply I. reflexivity. intro Hap. rewrite -> nth_coeff_c_mult_p. cut (nth_coeff n P [=] [0]). intro H; rewrite -> H; ring. cut (degree_le (QX_deg P) P). intro H; apply H; assumption. destruct (RX_deg_spec _ Q_dec P); assumption. Qed. Definition qx2zx (P : QX) : ZX := Q_can_num_poly (_C_ (Zlcm_den_poly P:Q_as_CRing) [*] P). Lemma qx2zx_spec : forall P, zx2qx (qx2zx P) [=] _C_ (Zlcm_den_poly P:Q_as_CRing) [*] P. Proof. intro P. unfold qx2zx. symmetry; apply zx2qx_spec. apply Zlcm_den_poly_spec. Qed. End Z_Q. corn-8.20.0/liouville/QX_extract_roots.v000066400000000000000000000223221473720167500202620ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CPoly_Degree. Require Import CRing_Homomorphisms. Require Import CoRN.model.ordfields.Qordfield. Require Import CauchySeq. Require Import Q_in_CReals. Require Import CPoly_Euclid RingClass CRingClass. Require Import Q_can nat_Q_lists RX_deg RX_div QX_root_loc. Section Z_Q. Let QX := cpoly_cring Q_as_CRing. Add Ring q_r : (r_rt (Ring:=CRing_is_Ring Q_as_CRing)). Add Ring qx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring Q_as_CRing))). Let QX_dec := RX_dec Q_as_CRing Q_dec. Let QX_deg := RX_deg Q_as_CRing Q_dec. Fixpoint QX_test_list (P : QX) (l : list Q_as_CRing) : option Q_as_CRing := match l with | nil => None | cons q l => match Q_dec (P ! q) [0] with inl _ => Some q | inr _ => QX_test_list P l end end. Lemma QX_test_list_spec_none : forall P l, QX_test_list P l = None -> forall q : Q_as_CRing, In q l -> P ! q [#] [0]. Proof. induction l. intros; contradiction. unfold QX_test_list. case (Q_dec P ! a [0]). intros; discriminate. fold (QX_test_list P l). intros Hap Hnone q. simpl (In q (a::l)). case (Q_dec a q). intros Haq Hin Hval. destruct Hap. rewrite -> Haq; assumption. intros. apply IHl. assumption. destruct H. destruct c; rewrite H; reflexivity. assumption. Qed. Lemma QX_test_list_spec_some : forall P l x, QX_test_list P l = Some x -> P ! x [=] [0]. Proof. induction l. intros; discriminate. unfold QX_test_list. fold (QX_test_list P l). case (Q_dec P ! a [0]); [|intro; assumption]. intros. injection H; intro. rewrite <- H0; assumption. Qed. Let P0 (P : QX) := nth_coeff 0 (QX_ZX.qx2zx P). Let Pn (P : QX) := nth_coeff (QX_deg P) (QX_ZX.qx2zx P). Definition QX_find_root (P : QX) : option Q_as_CRing := match Q_dec (P ! [0]) [0] with inl _ => Some [0] | inr _ => QX_test_list P (list_Q (P0 P) (Pn P)) end. Lemma QX_find_root_spec_none : forall P, QX_find_root P = None -> forall q : Q_as_CRing, P ! q [#] [0]. Proof. intro P; unfold QX_find_root. case (Q_dec P ! [0] [0]). intros; discriminate. intros Hap Hnone q. assert (forall x y : Q_as_CRing, {x = y} + {x <> y}). clear; intros x y. destruct x; destruct y; simpl. case (Z.eq_dec Qnum Qnum0); case (Z.eq_dec Qden Qden0); intros H1 H2. left; f_equal; [assumption|injection H1; tauto]. right; intro H3; injection H3; intros; destruct H1; f_equal; assumption. right; intro H3; injection H3; intros; destruct H2; assumption. right; intro H3; injection H3; intros; destruct H2; assumption. destruct (In_dec X (Q_can q) (list_Q (P0 P) (Pn P))). intro H; rewrite -> (Q_can_spec q) in H; revert H. apply (QX_test_list_spec_none _ _ Hnone _ i). intro Hval; apply n. apply QX_root_loc; assumption. Qed. Lemma QX_find_root_spec_some : forall P x, QX_find_root P = Some x -> P ! x [=] [0]. Proof. intros P x; unfold QX_find_root. case (Q_dec P ! [0] [0]). intros H1 H2; injection H2; intro H3; rewrite <- H3; assumption. intro Hap; apply QX_test_list_spec_some. Qed. Lemma QX_integral : forall p q : QX, p [#] [0] -> q [#] [0] -> p[*]q [#] [0]. Proof. intros p q Hp Hq. apply (nth_coeff_strext _ (QX_deg p + QX_deg q)). simpl (nth_coeff (QX_deg p + QX_deg q) ([0]:QX)). cut (degree (QX_deg p + QX_deg q) (p[*]q)). intro H; apply H. apply (degree_mult Q_as_CField). apply RX_deg_spec; assumption. apply RX_deg_spec; assumption. Qed. Lemma QX_deg_mult : forall p q, p [#] [0] -> q [#] [0] -> QX_deg (p[*]q) = QX_deg p + QX_deg q. Proof. intros p q Hp Hq. set (RX_deg_spec _ Q_dec _ Hp). set (RX_deg_spec _ Q_dec _ Hq). set (degree_mult Q_as_CField _ _ _ _ d d0). fold QX_deg in d1. apply (degree_inj _ (p[*]q)); [|assumption]. apply RX_deg_spec. apply QX_integral; assumption. Qed. Lemma QX_div_deg0 : forall (p : QX) (a : Q_as_CRing), QX_deg p <> 0 -> RX_div _ p a [#] [0]. Proof. intros p a Hdeg. case (QX_dec (RX_div _ p a) [0]); [|tauto]. intro Heq; destruct Hdeg; revert Heq. unfold RX_div. destruct (cpoly_div p (_X_monic _ a)) as [[q r] _ [s [d s0]]]. unfold fst, snd in *. intro Hq. rewrite -> Hq in s. assert (H : p [=] r); [rewrite -> s; unfold cg_minus; unfold QX; ring|]. unfold QX_deg; rewrite (RX_deg_wd _ Q_dec _ _ H); fold QX_deg. destruct (_X_monic _ a). destruct (degree_le_zero _ _ (d _ H1)). unfold QX_deg; rewrite (RX_deg_wd _ Q_dec _ _ s1). rewrite RX_deg_c_; reflexivity. Qed. Lemma QX_div_deg : forall (p : QX) (a : Q_as_CRing), QX_deg p <> 0 -> QX_deg p = S (QX_deg (RX_div _ p a)). Proof. intros p a Hdeg. case_eq (QX_deg p). intro; destruct Hdeg; assumption. intros n Heq. f_equal. revert Heq. unfold QX_deg; rewrite (RX_deg_wd _ Q_dec _ _ (RX_div_spec _ p a)). rewrite RX_deg_sum. rewrite Nat.max_comm. rewrite -> QX_deg_mult. unfold QX_deg; rewrite RX_deg_minus. rewrite RX_deg_c_, RX_deg_x_, RX_deg_c_; fold QX_deg. simpl; rewrite Nat.add_comm; simpl. intro H; injection H; symmetry; assumption. rewrite RX_deg_x_, RX_deg_c_; discriminate. apply QX_div_deg0; assumption. right; left; discriminate. rewrite RX_deg_c_. rewrite -> QX_deg_mult. unfold QX_deg; rewrite RX_deg_minus. rewrite RX_deg_x_, RX_deg_c_. rewrite Nat.add_comm; discriminate. rewrite RX_deg_x_, RX_deg_c_; discriminate. apply QX_div_deg0; assumption. right; left; discriminate. Qed. Fixpoint QX_extract_roots_rec (n : nat) (P : QX) := match n with | O => P | S n => match QX_find_root P with | None => P | Some x => QX_extract_roots_rec n (RX_div _ P x) end end. Definition QX_extract_roots (P : QX) := QX_extract_roots_rec (QX_deg P) P. Lemma QX_extract_roots_spec_rat : forall P a, P [#] [0] -> (QX_extract_roots P) ! a [#] [0]. Proof. unfold QX_extract_roots. intros P a; remember (QX_deg P) as n; revert P Heqn. induction n. intros P Hdeg Hap; unfold QX_extract_roots_rec. destruct (RX_deg_spec _ Q_dec _ Hap). fold QX_deg in d; rewrite <- Hdeg in d. destruct (degree_le_zero _ _ d). case (Q_dec P ! a [0]); [|tauto]. intro Heq; destruct (ap_imp_neq _ _ _ Hap); clear Hap; revert Heq. rewrite -> s, c_apply; intro H; rewrite -> H; split; [reflexivity|apply I]. unfold QX_extract_roots_rec. intros P Hdeg Hap. case_eq (QX_find_root P). intros x Hsome; fold (QX_extract_roots_rec n (RX_div _ P x)). apply IHn. apply eq_add_S. rewrite <- QX_div_deg; [assumption|]. rewrite <- Hdeg; discriminate. case (QX_dec (RX_div _ P x) [0]); [|tauto]. intro Heq; apply QX_div_deg0. rewrite <- Hdeg; discriminate. intro; apply QX_find_root_spec_none; assumption. Qed. Definition inj_Q_fun := Build_CSetoid_fun _ _ _ (inj_Q_strext IR). Lemma inj_Q_pres_plus : fun_pres_plus _ _ inj_Q_fun. Proof. intros x y; apply inj_Q_plus. Qed. Lemma inj_Q_pres_unit : fun_pres_unit _ _ inj_Q_fun. Proof. apply inj_Q_One. Qed. Lemma inj_Q_pres_mult : fun_pres_mult _ _ inj_Q_fun. Proof. intros x y; apply inj_Q_mult. Qed. Definition inj_Q_rh := Build_RingHom _ _ inj_Q_fun inj_Q_pres_plus inj_Q_pres_mult inj_Q_pres_unit. Definition inj_QX_rh := cpoly_map inj_Q_rh. Lemma QX_extract_roots_spec_nrat : forall (P : QX) (x : IR), (forall y : Q_as_CRing, x [~=] (inj_Q_rh y)) -> (inj_QX_rh P) ! x [=] [0] -> (inj_QX_rh (QX_extract_roots P)) ! x [=] [0]. Proof. intros P x Hx; unfold QX_extract_roots. remember (QX_deg P) as n; revert P Heqn; induction n. intros; unfold QX_extract_roots_rec; assumption. intros P Hdeg Hval; unfold QX_extract_roots_rec; fold (QX_extract_roots_rec). case_eq (QX_find_root P); [|intro; assumption]. intros y Hsome. apply IHn. apply eq_add_S. rewrite Hdeg; apply QX_div_deg. rewrite <- Hdeg; discriminate. clear IHn; revert Hval. rewrite -> (RX_div_spec _ P y) at 1. rewrite -> rh_pres_plus. rewrite -> rh_pres_mult. rewrite -> rh_pres_minus. rewrite -> (cpoly_map_X _ _ inj_Q_rh). rewrite -> (cpoly_map_C _ _ inj_Q_rh). rewrite -> (cpoly_map_C _ _ inj_Q_rh). rewrite -> plus_apply. rewrite -> mult_apply. rewrite -> minus_apply. rewrite -> x_apply. rewrite -> c_apply. rewrite -> c_apply. rewrite -> (QX_find_root_spec_some _ _ Hsome). rewrite -> rh_pres_zero. rewrite -> cm_rht_unit. rewrite -> mult_commutes. set (H := Hx y); revert H; generalize (RX_div Q_as_CRing P y). clear; intros P Hap Heq. apply (mult_eq_zero IR (x[-]inj_Q_rh y)); [|assumption]. intro; apply Hap. apply cg_inv_unique_2; assumption. Qed. End Z_Q. corn-8.20.0/liouville/QX_root_loc.v000066400000000000000000000316401473720167500172050ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CPoly_Degree. Require Import CRing_Homomorphisms. Require Import Qring. Require Import Zring. Require Import Qordfield. Require Import RingClass CRingClass. Require Import Zlcm Q_can nat_Q_lists RX_deg QX_ZX. Section QX_root. Let QX := cpoly_cring Q_as_CRing. Add Ring q_r : (r_rt (Ring:=CRing_is_Ring Q_as_CRing)). Add Ring qx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring Q_as_CRing))). Let ZX := cpoly_cring Z_as_CRing. Add Ring z_r : (r_rt (Ring:=CRing_is_Ring Z_as_CRing)). Add Ring zx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring Z_as_CRing))). Let ZX_deg := RX_deg Z_as_CRing Z_dec. Let ZX_dec := RX_dec Z_as_CRing Z_dec. Let QX_dec := RX_dec Q_as_CRing Q_dec. Let QX_deg := RX_deg Q_as_CRing Q_dec. Lemma Sum0_ring_hom : forall R S (phi : RingHom R S) f n, phi (Sum0 n f) [=] Sum0 n (fun i => phi (f i)). Proof. intros. induction n; [apply rh_pres_zero|]. simpl; rewrite -> rh_pres_plus, IHn; reflexivity. Qed. Lemma Sum_ring_hom : forall R S (phi : RingHom R S) f i j, phi (Sum i j f) [=] Sum i j (fun i => phi (f i)). Proof. intros; unfold Sum, Sum1; simpl. rewrite -> rh_pres_minus, rh_pres_plus. rewrite -> Sum0_ring_hom, Sum0_ring_hom; reflexivity. Qed. Lemma nexp_ring_hom : forall R S (phi : RingHom R S) a n, phi (a[^]n) [=] phi a[^]n. Proof. intros; induction n; [apply rh_pres_unit|]. rewrite <- nexp_Sn, <- nexp_Sn; rewrite -> rh_pres_mult, IHn; reflexivity. Qed. Lemma Q_Z_nexp : forall (p : Z_as_CRing) (q : positive) i, ((p#q)[^]i[*](q:Q_as_CRing)[^]i [=] p[^]i)%Q. Proof. intros p q. induction i. reflexivity. rewrite <- nexp_Sn, <- nexp_Sn, <- nexp_Sn. rewrite -> (mult_commutes _ (p#q)%Q). rewrite <- CRings.mult_assoc. rewrite -> (mult_commutes _ (p#q)%Q). rewrite -> (mult_commutes _ (q:Q_as_CRing)). rewrite -> CRings.mult_assoc. rewrite -> CRings.mult_assoc. rewrite -> IHi. rewrite (mult_commutes _ p). rewrite <- CRings.mult_assoc. apply (mult_wdr _ (inject_Z ((p:Z_as_CRing)[^]i)) ((q:Q_as_CRing)[*](p # q)%Q) p). simpl; unfold Qeq; simpl. case p. rewrite Zmult_0_l, Zmult_0_l; reflexivity. intro r; rewrite Zmult_1_r; rewrite Zmult_comm; reflexivity. intro r; rewrite Zmult_1_r; rewrite Zmult_comm; reflexivity. Qed. Lemma Q_Z_poly_apply : forall (P : ZX) (p : Z_as_CRing) (q : positive), let n := ZX_deg P in (q:Q_as_CRing)[^]n [*] (zx2qx P) ! (p # q)%Q [=] Sum 0 n (fun i => (nth_coeff i P) [*] p [^] i [*] (q : Z_as_CRing)[^](n - i)). Proof. intros P p q n. assert (degree_le n (zx2qx P)). case (ZX_dec P [0]). intro H; apply (degree_le_wd _ (_C_ [0])). rewrite -> H; split; [reflexivity|apply I]. apply (degree_le_mon _ _ 0). apply Nat.le_0_l. apply degree_le_c_. intro Hap. destruct (RX_deg_spec _ Z_dec _ Hap). clear c; fold (ZX_deg P) in d; fold n in d. intros m Hlt. rewrite -> nth_coeff_zx2qx. rewrite d; [reflexivity|assumption]. rewrite -> (poly_as_sum _ _ _ H). rewrite <- mult_distr_sum_lft. rewrite -> (Sum_ring_hom _ _ injZ_rh). apply Sum_wd'. apply Nat.le_0_l. intros i H0 Hn. rewrite -> nth_coeff_zx2qx. rewrite -> rh_pres_mult. rewrite -> rh_pres_mult. rewrite -> mult_commutes. rewrite -> nexp_ring_hom, nexp_ring_hom. rewrite <- CRings.mult_assoc, <- CRings.mult_assoc. apply mult_wdr. rewrite <- (Nat.sub_add _ _ Hn) at 1. rewrite Nat.add_comm. clear H0 Hn. rewrite <- nexp_plus. rewrite -> CRings.mult_assoc. apply mult_wdl. simpl (injZ_rh p). rewrite -> (Q_Z_nexp p q i). apply (nexp_ring_hom _ _ injZ_rh). Qed. Lemma RX_deg_cmult_p : forall P a, a [#] [0] -> QX_deg (_C_ a [*] P) = QX_deg P. Proof. intros P a Hap. case (QX_dec P [0]). intro; apply RX_deg_wd. rewrite -> s; ring. intro HapP. apply (degree_inj _ (_C_ a [*] P)). case (QX_dec (_C_ a[*]P) [0]). intro Heq; destruct (ap_imp_neq _ _ _ HapP); clear HapP. apply all_nth_coeff_eq_imp. intro i; generalize (nth_coeff_wd _ i _ _ Heq). rewrite -> nth_coeff_c_mult_p. fold QX; simpl (nth_coeff i ([0]:QX)). intro Heq2; apply (mult_eq_zero _ a); [apply Hap|assumption]. apply RX_deg_spec. destruct (RX_deg_spec _ Q_dec _ HapP). split. intro. destruct c. rewrite -> nth_coeff_c_mult_p in H. apply (mult_eq_zero _ _ _ Hap H). intros m Hlt. rewrite -> nth_coeff_c_mult_p. rewrite -> (d m Hlt); ring. Qed. Lemma den_div_Pn0 : forall (Q : ZX) (n : nat) (p q : Z_as_CRing), Sum 0 n (fun i : nat => nth_coeff i Q[*]p[^]i[*]q[^](n - i))[=][0] -> Zdivides q (nth_coeff n Q[*]p[^]n). Proof. clear QX QX_dec QX_deg. intros P n p q. destruct n. rewrite -> Sum_one. simpl. rewrite Zmult_1_r; intro H; rewrite H. apply Zdivides_zero_rht. rewrite -> Sum_last. rewrite Nat.sub_diag. simpl (q[^]0). rewrite -> mult_one. generalize (nth_coeff (S n) P[*]p[^]S n); intro r. exists ([--](Sum 0 n (fun i : nat => nth_coeff i P[*]p[^]i[*]q[^](n - i)))). rewrite Zopp_mult_distr_l_reverse. symmetry; apply (cg_inv_unique Z_as_CRing). rewrite <- H. apply cs_bin_op_wd; [|reflexivity]. rewrite <- (mult_distr_sum_rht Z_as_CRing). apply Sum_wd'. apply Nat.le_0_l. intros i H0 Hn. rewrite <- CRings.mult_assoc. apply mult_wd. reflexivity. rewrite Nat.sub_succ_l; [|assumption]. reflexivity. Qed. Lemma qx2zx_deg : forall P, QX_deg P = ZX_deg (qx2zx P). Proof. intro P; unfold qx2zx. rewrite <- Q_can_num_poly_deg_eq. symmetry; apply RX_deg_cmult_p. intro; apply (Zlcm_den_poly_nz P). rewrite (injZ_spec2 (Zlcm_den_poly P)). revert H; generalize (inject_Z (Zlcm_den_poly P)); clear. intro q; destruct q as [qn qd]. unfold Qeq, Q_can_num; simpl. rewrite Zmult_1_r; intro H; rewrite H. compute; reflexivity. Qed. Let Pn (P : QX) := nth_coeff (QX_deg P) (qx2zx P). Lemma den_div_Pn1 : forall (P : QX) (a : Q_as_CRing), P ! a [=] [0] -> Zdivides (Qden a) (Pn P[*](Qnum a:Z_as_CRing)[^]QX_deg P). Proof. intros P a Hval. set (P0 := _C_ (Zlcm_den_poly P:Q_as_CRing)[*]P). assert (H : P0 ! a [=] [0]). unfold P0; rewrite -> mult_apply, c_apply, Hval; ring. clear Hval; revert H. rewrite -> (zx2qx_spec P0); [|apply Zlcm_den_poly_spec]. unfold P0; clear P0. destruct a as [p q]; unfold Qnum, Qden. set (Q := qx2zx P). intro Hval. assert ((q:Q_as_CRing)[^](ZX_deg Q) [*] (zx2qx Q) ! (p # q)%Q [=] [0]). unfold Q. rewrite -> Hval; ring. assert (Q_can_num ((q:Q_as_CRing)[^](ZX_deg Q) [*] (zx2qx Q) ! (p # q)%Q) [=] [0]). rewrite (Q_can_num_spec _ _ H). unfold Q_can_num; simpl. rewrite Zgcd_one_rht, Zdiv_0_l; reflexivity. clear Hval H; revert H0. rewrite (Q_can_num_spec _ _ (Q_Z_poly_apply _ _ _)). rewrite <- injZ_spec2. assert (ZX_deg Q = QX_deg P). symmetry; apply qx2zx_deg. assert (nth_coeff (QX_deg P) (qx2zx P) = nth_coeff (QX_deg P) Q). reflexivity. unfold Q. unfold Pn; rewrite H0. rewrite <- H; clear H H0. apply den_div_Pn0. Qed. Lemma Zrelprime_nexp : forall (p q : Z_as_CRing) n, Zrelprime p q -> Zrelprime p (q[^]n). Proof. intros p q n; intro H. induction n. apply Zgcd_one_rht. rewrite <- nexp_Sn. apply Zrelprime_symm. apply Zrelprime_mult_elim_lft. apply Zrelprime_symm; assumption. apply Zrelprime_symm; assumption. Qed. Lemma den_div_Pn : forall (P : QX) (a : Q_as_CRing), P ! a [=] [0] -> Zdivides (Q_can_den a) (Pn P). Proof. intros P a Hval. rewrite Q_can_den_pos_val_spec. apply (Zrelprime_div_mult_intro _ ((Q_can_num a:Z_as_CRing)[^]QX_deg P)). apply Zrelprime_nexp. apply Zrelprime_symm. apply (Q_can_spec2 a). rewrite Zmult_comm. apply (den_div_Pn1 _ (Q_can a)). rewrite <- Hval. apply cpoly_apply_wd; [reflexivity|]. symmetry; apply Q_can_spec. Qed. Lemma Sum_shift_simpl : forall (G : CAbGroup) (f : nat -> G) m n, Sum (S m) (S n) f [=] Sum m n (fun i => f (S i)). Proof. intros G f m n. symmetry; apply Sum_shift. intro; reflexivity. Qed. Lemma den_div_P00 : forall (Q : ZX) (n : nat) (p q : Z_as_CRing), Sum 0 n (fun i : nat => nth_coeff i Q[*]p[^]i[*]q[^](n - i))[=][0] -> Zdivides p (nth_coeff 0 Q[*]q[^]n). Proof. clear Pn QX QX_dec QX_deg. intros P n p q. destruct n. rewrite -> Sum_one. simpl. rewrite Zmult_1_r; intro H; rewrite H. apply Zdivides_zero_rht. rewrite -> Sum_first. rewrite -> Sum_shift_simpl. simpl (p[^]0). rewrite -> mult_one. simpl (S n - 0). generalize (nth_coeff 0 P[*]q[^]S n); intro r. exists ([--](Sum 0 n (fun i : nat => nth_coeff (S i) P[*]p[^]i[*]q[^](n - i)))). rewrite Zopp_mult_distr_l_reverse. symmetry; apply (cg_inv_unique Z_as_CRing). rewrite <- H. rewrite -> cag_commutes. apply cs_bin_op_wd; [reflexivity|]. rewrite <- (mult_distr_sum_rht Z_as_CRing). apply Sum_wd'. apply Nat.le_0_l. intros i H0 Hn. rewrite <- nexp_Sn. simpl (S n - S i). ring. Qed. Let P0 (P : QX) := nth_coeff 0 (qx2zx P). Lemma den_div_P01 : forall (P : QX) (a : Q_as_CRing), P ! a [=] [0] -> Zdivides (Qnum a) (P0 P[*](Qden a:Z_as_CRing)[^]QX_deg P). Proof. intros P a Hval. set (Q := _C_ (Zlcm_den_poly P:Q_as_CRing)[*]P). assert (H : Q ! a [=] [0]). unfold Q; rewrite -> mult_apply, c_apply, Hval; ring. clear Hval; revert H. rewrite -> (zx2qx_spec Q); [|apply Zlcm_den_poly_spec]. unfold Q; clear Q. destruct a as [p q]; unfold Qnum, Qden. set (Q := qx2zx P). intro Hval. assert ((q:Q_as_CRing)[^](ZX_deg Q) [*] (zx2qx Q) ! (p # q)%Q [=] [0]). unfold Q. rewrite -> Hval; ring. assert (Q_can_num ((q:Q_as_CRing)[^](ZX_deg Q) [*] (zx2qx Q) ! (p # q)%Q) [=] [0]). rewrite (Q_can_num_spec _ _ H). unfold Q_can_num; simpl. rewrite Zgcd_one_rht, Zdiv_0_l; reflexivity. clear Hval H; revert H0. rewrite (Q_can_num_spec _ _ (Q_Z_poly_apply _ _ _)). rewrite <- injZ_spec2. assert (ZX_deg Q = QX_deg P). symmetry; apply qx2zx_deg. assert (nth_coeff 0 (qx2zx P) = nth_coeff 0 Q). reflexivity. unfold Q. unfold P0; rewrite H0. rewrite <- H; clear H H0. apply den_div_P00. Qed. Lemma den_div_P0 : forall (P : QX) (a : Q_as_CRing), P ! a [=] [0] -> Zdivides (Q_can_num a) (P0 P). Proof. intros P a Hval. apply (Zrelprime_div_mult_intro _ ((Q_can_den a:Z_as_CRing)[^]QX_deg P)). apply Zrelprime_nexp. rewrite Q_can_den_pos_val_spec. apply (Q_can_spec2 a). rewrite Zmult_comm. rewrite Q_can_den_pos_val_spec. apply (den_div_P01 _ (Q_can a)). rewrite <- Hval. apply cpoly_apply_wd; [reflexivity|]. symmetry; apply Q_can_spec. Qed. Lemma QX_root_loc : forall (P : QX) (a : Q_as_CRing), P ! [0] [#] [0] -> P ! a [=] [0] -> In (Q_can a) (list_Q (P0 P) (Pn P)). Proof. intros P a Hap Hval. apply list_Q_spec. intro; apply Hap; clear Hap. unfold P0 in H. cut ((_C_ (Zlcm_den_poly P:Q_as_CRing) [*] P) ! [0] [=] [0]). rewrite -> mult_apply, c_apply. intro H0; apply (Qmult_integral_l (Zlcm_den_poly P)); [|assumption]. intro H1; destruct (Zlcm_den_poly_nz P). unfold Qeq in H1; simpl in H1. rewrite Zmult_1_r in H1; assumption. cut ((zx2qx (qx2zx P)) ! [0] [=] [0]). rewrite -> qx2zx_spec; tauto. unfold zx2qx. rewrite <- (rh_pres_zero _ _ injZ_rh) at 1. rewrite <- cpoly_map_apply. cut ((qx2zx P) ! [0] [=] [0]). intro H0; rewrite H0; reflexivity. rewrite -> poly_at_zero; assumption. case (QX_dec P [0]). intro H; destruct Hap; rewrite -> H; reflexivity. intros Hap2 Heq; apply (ap_imp_neq _ _ _ Hap2); clear Hap Hval; revert Heq. unfold Pn. destruct (RX_deg_spec _ Z_dec (qx2zx P)); [|]. case (ZX_dec (qx2zx P) [0]); [|tauto]. intro Heq; destruct (ap_imp_neq _ _ _ Hap2); clear Hap2. cut (_C_(Zlcm_den_poly P:Q_as_CRing) [*] P [=] [0]). intro Heq2; apply all_nth_coeff_eq_imp; intro i. apply (Qmult_integral_l (Zlcm_den_poly P)). intro H1; destruct (Zlcm_den_poly_nz P). unfold Qeq in H1; simpl in H1. rewrite Zmult_1_r in H1; assumption. generalize (nth_coeff_wd _ i _ _ Heq2). rewrite -> nth_coeff_c_mult_p. simpl; tauto. rewrite <- qx2zx_spec. rewrite -> Heq. apply (rh_pres_zero _ _ zx2qx). intro H; destruct c; fold (ZX_deg (qx2zx P)). rewrite <- qx2zx_deg; assumption. apply den_div_P0; assumption. rewrite inj_Zabs_nat. rewrite <- Q_can_den_pos_val_spec. apply Zdivides_abs_elim_lft. apply den_div_Pn; assumption. Qed. End QX_root. corn-8.20.0/liouville/Q_can.v000066400000000000000000000120471473720167500157760ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CRings Qring Zring. Require Import Zlcm. Section Q_can. Lemma Q_dec : forall x y : Q_as_CRing, (x [=] y) or (x [#] y). Proof. intros x y; case (Qeq_dec x y); [left|right]; assumption. Qed. Definition Q_can_num (q : Q_as_CRing) : Z_as_CRing := Z.div (Qnum q) (Zgcd (Qnum q) (Qden q)). Lemma Q_can_num_spec : forall q q', q [=] q' -> Q_can_num q = Q_can_num q'. Proof. intros q q'. unfold Q_can_num. destruct q as [qn qd]; destruct q' as [q'n q'd]. simpl; unfold Qeq; simpl. intro Heq. apply (Zmult_reg_l _ _ (Zgcd qn qd * Zgcd q'n q'd)). intro; destruct (Zmult_integral _ _ H); destruct (Zgcd_zero _ _ H0); discriminate. rewrite -> (Zmult_comm (Zgcd qn qd)) at 1. rewrite <- Zmult_assoc, <- Zmult_assoc. rewrite -> (Zmult_comm (Zgcd qn qd)) at 1. rewrite -> (Zmult_comm (Zgcd q'n q'd) (q'n / Zgcd q'n q'd)). rewrite <- Zgcd_div_mult_lft, <- Zgcd_div_mult_lft; try (intro H; destruct (Zgcd_zero _ _ H); discriminate). rewrite Zmult_comm, (Zmult_comm _ q'n). rewrite <- (Zabs_Zsgn qn) at 1; rewrite <- (Zabs_Zsgn q'n) at 2. rewrite (Zmult_comm (Z.abs qn)), (Zmult_comm (Z.abs q'n)). rewrite <- Zmult_assoc, <- Zmult_assoc. rewrite Zgcd_lin, Zgcd_lin. rewrite Heq. rewrite (Zmult_comm qn q'n). cut (Z.sgn qn = Z.sgn q'n). intro H; rewrite H; reflexivity. destruct qn; destruct q'n; reflexivity||discriminate. Qed. Definition Q_can_den (q : Q_as_CRing) : Z_as_CRing := Z.div (Qden q) (Zgcd (Qnum q) (Qden q)). Lemma Q_can_den_spec : forall q q', q [=] q' -> Q_can_den q = Q_can_den q'. Proof. intros q q'. unfold Q_can_den. destruct q as [qn qd]; destruct q' as [q'n q'd]. simpl; unfold Qeq; simpl. intro Heq. apply (Zmult_reg_l _ _ (Zgcd qn qd * Zgcd q'n q'd)). intro; destruct (Zmult_integral _ _ H); destruct (Zgcd_zero _ _ H0); discriminate. rewrite -> (Zmult_comm (Zgcd qn qd)) at 1. rewrite <- Zmult_assoc, <- Zmult_assoc. rewrite -> (Zmult_comm (Zgcd qn qd)) at 1. rewrite (Zmult_comm (Zgcd q'n q'd) (q'd / Zgcd q'n q'd)). rewrite <- Zgcd_div_mult_rht, <- Zgcd_div_mult_rht; try (intro H; destruct (Zgcd_zero _ _ H); discriminate). rewrite Zmult_comm, (Zmult_comm _ q'd). rewrite <- (Zabs_Zsgn qd) at 1; rewrite <- (Zabs_Zsgn q'd) at 2. rewrite (Zmult_comm (Z.abs qd)), (Zmult_comm (Z.abs q'd)). rewrite <- Zmult_assoc, <- Zmult_assoc. rewrite Zgcd_lin, Zgcd_lin. rewrite (Zmult_comm qd q'n), (Zmult_comm q'd qn). rewrite Heq. rewrite (Zmult_comm qd q'd). reflexivity. Qed. Lemma Q_can_den_pos : forall q : Q_as_CRing, (0 < Q_can_den q)%Z. Proof. intro q; destruct q as [qn qd]; unfold Q_can_den. simpl. set (Zdiv_le_lower_bound qd (Zgcd qn qd) 1). assert (0 <= qd)%Z by discriminate. assert (0 < Zgcd qn qd)%Z. apply Zgcd_pos; right; discriminate. assert (Zgcd qn qd <= qd)%Z. apply Zgcd_le_rht; apply Zgt_pos_0. apply Z.div_str_pos. split; assumption. Qed. Definition Q_can_den_pos_val (q : Q_as_CRing) : positive := match (Q_can_den q) with | Zpos p => p | _ => xH end. Lemma Q_can_den_pos_val_spec : forall q : Q_as_CRing, Q_can_den q = Q_can_den_pos_val q. Proof. intro q; set (Q_can_den_pos q) as z. unfold Q_can_den_pos_val. clearbody z. revert z. case (Q_can_den q). intro; discriminate. reflexivity. intros; discriminate. Qed. Definition Q_can (q : Q_as_CRing) := Qmake (Q_can_num q) (Q_can_den_pos_val q). Lemma Q_can_spec : forall q : Q_as_CRing, q [=] Q_can q. Proof. intro q; destruct q as [qn qd]; unfold Q_can; simpl; unfold Qeq; simpl. rewrite <- Q_can_den_pos_val_spec. unfold Q_can_den, Q_can_num; simpl. assert (Zgcd qn qd <> 0). intro. destruct (Zgcd_zero _ _ H). discriminate. rewrite -> (Zgcd_div_mult_lft qn qd) at 1. rewrite -> (Zgcd_div_mult_rht qn qd) at 6. ring. assumption. assumption. Qed. Lemma Q_can_spec2 : forall q : Q_as_CRing, Zrelprime (Qnum (Q_can q)) (Qden (Q_can q)). Proof. intro q; destruct q as [qn qd]. unfold Q_can; simpl. rewrite <- Q_can_den_pos_val_spec. unfold Q_can_den, Q_can_num; simpl. apply Zgcd_div_gcd_1. intro. destruct (Zgcd_zero _ _ H). discriminate. Qed. Definition in_Z (q : Q_as_CRing) := Q_can_den q = 1. End Q_can. corn-8.20.0/liouville/RX_deg.v000066400000000000000000000161211473720167500161220ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CPoly_Degree RingClass CRingClass. Import CRing_Homomorphisms.coercions. Section RX_deg. Variable R : CRing. Let RX := cpoly_cring R. Add Ring r_r : (r_rt (Ring:=CRing_is_Ring R)). Add Ring rx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring R))). Hypothesis R_dec : forall x y : R, sum (x [=] y) (x [#] y). Lemma RX_dec : forall p q : RX, sum (p [=] q) (p [#] q). Proof. unfold RX; intros p q; pattern p, q; apply Ccpoly_double_sym_ind; clear p q. intros p q H. case H. left; symmetry; assumption. right; apply ap_symmetric; assumption. intro p; pattern p; apply Ccpoly_induc; clear p. left; reflexivity. intros p c; case (R_dec c [0]). intros H1 H2; destruct H2. left; apply _linear_eq_zero; split; assumption. right; rewrite linear_ap_zero; right; assumption. right; rewrite linear_ap_zero; left; assumption. intros p q c d H; case (R_dec c d). case H. left; apply _linear_eq_linear; split; assumption. right; rewrite linear_ap_linear; right; assumption. right; rewrite linear_ap_linear; left; assumption. Qed. Fixpoint RX_deg (p : RX) : nat := match p with | cpoly_zero _ => 0 | cpoly_linear _ c p => match RX_dec p [0] with inl _ => 0 | inr _ => S (RX_deg p) end end. Lemma RX_deg_zero : RX_deg [0] = 0. Proof. reflexivity. Qed. Lemma RX_deg_linear : forall c p, RX_deg (c[+X*]p) = match RX_dec p [0] with inl _ => 0 | inr _ => S (RX_deg p) end. Proof. reflexivity. Qed. Lemma RX_deg_spec : forall p : RX, p [#] [0] -> degree (RX_deg p) p. Proof. intro p; pattern p; apply Ccpoly_induc; clear p. intro H; destruct (ap_irreflexive _ _ H). unfold RX; intros p c Hrec. rewrite linear_ap_zero; intro H. rewrite RX_deg_linear. case (RX_dec p [0]). case H. split. assumption. intro m; case m. intro H1; inversion H1. intros; rewrite -> coeff_Sm_lin. rewrite <- (nth_coeff_zero _ n). apply nth_coeff_wd; assumption. intros Hap Heq; destruct (eq_imp_not_ap _ _ _ Heq Hap). intro H0; destruct (Hrec H0) as [Hcoeff Hdeg]. split. case (R_dec (nth_coeff (S (RX_deg p)) (c[+X*]p)) [0]). intro H1; destruct (ap_imp_neq _ _ _ Hcoeff). rewrite -> coeff_Sm_lin in H1; assumption. tauto. intro m; case m. intro H1; inversion H1. clear m; intros m Hlt; rewrite -> coeff_Sm_lin. apply Hdeg; apply le_S_n; assumption. Qed. Lemma RX_deg_wd : forall P Q, P [=] Q -> RX_deg P = RX_deg Q. Proof. intros P Q; pattern P, Q; apply Ccpoly_double_sym_ind; clear P Q. intros P Q Hsym Heq. symmetry; apply Hsym; symmetry; assumption. intro p; pattern p; apply Ccpoly_induc; clear p. reflexivity. intros. rewrite RX_deg_linear. case (RX_dec p [0]). reflexivity. intro Hap; destruct (ap_imp_neq _ _ _ Hap). apply (linear_eq_zero_ _ _ _ H0). intros P Q c d Hrec Heq. destruct (linear_eq_linear_ _ _ _ _ _ Heq). rewrite RX_deg_linear. rewrite RX_deg_linear. case (RX_dec P [0]). case (RX_dec Q [0]). reflexivity. intros H1 H2; destruct (ap_imp_neq _ _ _ H1). rewrite <- H0; assumption. case (RX_dec Q [0]). intros H1 H2; destruct (ap_imp_neq _ _ _ H2). rewrite -> H0; assumption. intros HQ HP. f_equal; apply Hrec; assumption. Qed. Lemma degree_inj : forall (P : RX) m n, degree m P -> degree n P -> m = n. Proof. intros P m n Hm Hn. destruct Hm as [Hm1 Hm2]. destruct Hn as [Hn1 Hn2]. case (lt_eq_lt_dec m n). intro H; destruct H. destruct (ap_imp_neq _ _ _ Hn1). apply Hm2; assumption. assumption. intro Hlt; destruct (ap_imp_neq _ _ _ Hm1). apply Hn2; assumption. Qed. Lemma RX_deg_c_ : forall a : R, RX_deg (_C_ a) = 0. Proof. simpl; case (RX_dec (cpoly_zero R) (cpoly_zero R)); [reflexivity|]. intro H; destruct (ap_irreflexive _ _ H). Qed. Lemma RX_deg_x_ : RX_deg _X_ = 1. Proof. simpl. case (RX_dec (cpoly_one R) (cpoly_zero R)). intro H; destruct (eq_imp_not_ap _ _ _ H (ring_non_triv _)). intro; case (RX_dec (cpoly_zero R) (cpoly_zero R)); [reflexivity|]. intro H; destruct (ap_irreflexive _ _ H). Qed. Lemma RX_deg_inv : forall p, RX_deg p = RX_deg ([--]p). Proof. intro p. case (RX_dec p [0]). intro H; rewrite (RX_deg_wd _ _ H), RX_deg_zero. rewrite <- RX_deg_zero; apply RX_deg_wd; rewrite -> H; unfold RX; ring. intro Hp. apply (degree_inj p). apply RX_deg_spec; assumption. apply (degree_wd _ ([--][--]p)); [apply cg_inv_inv|]. apply degree_inv. apply RX_deg_spec. apply inv_resp_ap_zero; assumption. Qed. Lemma RX_deg_sum : forall p q, RX_deg p <> RX_deg q -> RX_deg (p[+]q)=Nat.max (RX_deg p) (RX_deg q). Proof. intros p q Hneq. case (RX_dec p [0]). intro H; rewrite (RX_deg_wd _ _ H). transitivity (RX_deg q); [apply RX_deg_wd; rewrite -> H; unfold RX; ring|]. rewrite RX_deg_zero; reflexivity. case (RX_dec q [0]). intro H; rewrite (RX_deg_wd _ _ H). transitivity (RX_deg p); [apply RX_deg_wd; rewrite -> H; unfold RX; ring|]. rewrite RX_deg_zero; rewrite Nat.max_comm; reflexivity. intros Hq Hp. set (RX_deg_spec _ Hp). set (RX_deg_spec _ Hq). case (le_lt_dec (RX_deg p) (RX_deg q)); intro. rewrite Nat.max_r; [|assumption]. inversion l. destruct (Hneq H0). apply (degree_inj (p[+]q)). apply RX_deg_spec. case (RX_dec (p[+]q) [0]); [|tauto]. intro; destruct Hneq. rewrite (RX_deg_wd p ([--]q)). symmetry; apply RX_deg_inv. apply cg_inv_unique'; assumption. apply (degree_plus_rht _ _ _ m); [| |apply le_n]. apply (degree_le_mon _ _ (RX_deg p)); [assumption|apply d]. rewrite H; apply RX_deg_spec; assumption. rewrite Nat.max_l; [|apply Nat.lt_le_incl; assumption]. apply (degree_inj (p[+]q)). apply RX_deg_spec. case (RX_dec (p[+]q) [0]); [|tauto]. intro; destruct Hneq. rewrite (RX_deg_wd p ([--]q)). symmetry; apply RX_deg_inv. apply cg_inv_unique'; assumption. apply (degree_wd _ _ _ _ (cag_commutes _ _ _)). apply (degree_plus_rht _ _ _ (RX_deg q)); [| |assumption]. apply degree_imp_degree_le. apply RX_deg_spec; assumption. apply RX_deg_spec; assumption. Qed. Lemma RX_deg_minus : forall p q, RX_deg p <> RX_deg q -> RX_deg (p[-]q)=Nat.max (RX_deg p) (RX_deg q). Proof. unfold cg_minus; intros p q Hneq. rewrite (RX_deg_inv q) in Hneq. rewrite (RX_deg_sum _ _ Hneq). f_equal. symmetry; apply RX_deg_inv. Qed. End RX_deg. corn-8.20.0/liouville/RX_div.v000066400000000000000000000041521473720167500161460ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CPoly_Degree CPoly_Euclid RingClass CRingClass. Import CRing_Homomorphisms.coercions. Section RX_div. Variable R : CRing. Let RX := cpoly_cring R. Add Ring r_r : (r_rt (Ring:=CRing_is_Ring R)). Add Ring rx_r : (r_rt (Ring:=CRing_is_Ring (cpoly_cring R))). Lemma _X_monic : forall a : R, monic 1 (_X_ [-] _C_ a). Proof. split. reflexivity. intro m; destruct m. intro H; inversion H. destruct m. intro H; destruct (Nat.lt_irrefl _ H). reflexivity. Qed. Definition RX_div (p : RX) (a : R) : RX. Proof. destruct (cpoly_div p (_X_monic a)) as [qr Hunq Heq]; exact (fst qr). Defined. Lemma RX_div_spec : forall (p : RX) (a : R), p [=] (RX_div p a) [*] (_X_ [-] _C_ a) [+] _C_ (p ! a). Proof. intros p a. unfold RX_div. destruct (cpoly_div p (_X_monic a)) as [[q r] s [s0 d]]. unfold fst, snd in *. rewrite -> s0. apply cs_bin_op_wd; [reflexivity|]. destruct d. destruct (_X_monic a). destruct (degree_le_zero _ _ (d _ H0)). rewrite -> s2. apply csf_wd. rewrite -> plus_apply, mult_apply, minus_apply. rewrite -> x_apply, c_apply, c_apply; unfold cg_minus; ring. Qed. End RX_div. corn-8.20.0/liouville/RingClass.v000066400000000000000000000127221473720167500166420ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) (** Rings as a type class *) Require Import Setoid Ring Morphisms. Open Scope signature_scope. Require Import OperationClasses. Set Implicit Arguments. Unset Strict Implicit. Section Definitions. Context {R: Type} {req: relation R}. Class Ring {r_st : Equivalence req} (rO rI : R) (radd rmul rsub : binop R) (ropp : unop R) := { r_rt : ring_theory rO rI radd rmul rsub ropp req; r_ree : ring_eq_ext radd rmul ropp req }. Class SubRing {r_st : Equivalence req} `{r_ring : Ring} (P : R -> Type) := {zero_stab : P rO; one_stab : P rI; radd_int : binop_intern P radd; rmul_int : binop_intern P rmul; rsub_int : binop_intern P rsub; ropp_int : unop_intern P ropp}. End Definitions. Section Properties. Context `{r_ring : Ring}. Global Instance radd_morph : Proper (req==>req==>req) radd. Proof. reduce; apply (Radd_ext r_ree); auto. Qed. Global Instance rmul_morph : Proper (req==>req==>req) rmul. Proof. reduce; apply (Rmul_ext r_ree); auto. Qed. Global Instance rsub_morph : Proper (req==>req==>req) rsub. Proof. reduce; rewrite -> (Rsub_def r_rt), -> (Rsub_def r_rt y y0). apply (Radd_ext r_ree); auto; apply (Ropp_ext r_ree); auto. Qed. Global Instance ropp_morph : Proper (req==>req) ropp. Proof. reduce; apply (Ropp_ext r_ree); auto. Qed. Global Instance radd_assoc : associative radd. Proof. reduce; apply (Radd_assoc r_rt). Qed. Global Instance radd_comm : commutative radd. Proof. reduce; apply (Radd_comm r_rt). Qed. Global Instance radd_left_comm : left_commutative radd := mulAC_comm_l. Global Instance radd_right_comm : right_commutative radd := mulAC_comm_r. Global Instance radd_left_unit : left_unit radd rO. Proof. reduce; apply (Radd_0_l r_rt). Qed. Global Instance radd_right_unit : right_unit radd rO := mulC_id_l. Global Instance ropp_left_inverse : left_inverse radd rO ropp. Proof. reduce; apply (Ropp_def r_rt). Qed. Global Instance ropp_right_inverse : right_inverse radd rO ropp := mulC_inv_l. Global Instance rmul_assoc : associative rmul. Proof. reduce; apply (Rmul_assoc r_rt). Qed. Global Instance rmul_comm : commutative rmul. Proof. reduce; apply (Rmul_comm r_rt). Qed. Global Instance rmul_left_comm : left_commutative rmul := mulAC_comm_l. Global Instance rmul_right_comm : right_commutative rmul := mulAC_comm_r. Global Instance rmul_left_unit : left_unit rmul rI. Proof. reduce; apply (Rmul_1_l r_rt). Qed. Global Instance rmul_right_unit : right_unit rmul rI := mulC_id_l. Global Instance radd_rmul_left_distr : left_distributive radd rmul. Proof. reduce; apply (Rdistr_l r_rt). Qed. Global Instance radd_rmul_right_distr : right_distributive radd rmul := mulC_distr_l. Global Instance rmul_left_zero : left_absorbing rmul rO := @opA_zero_l R req r_st radd rmul ropp rO radd_morph rmul_morph radd_assoc radd_comm ropp_left_inverse radd_left_unit radd_rmul_left_distr. Global Instance rmul_right_zero : right_absorbing rmul rO := @mulC_zero_l R req r_st rmul rmul_comm rO rmul_left_zero. End Properties. Section SubRing_is_Ring. Context `{SubRing}. Add Ring r_r : r_rt (setoid r_st r_ree). Let R' := sigT P. Let proj1' := fun x : R' => projT1 x. Coercion proj1' : R'>->R. Let req' : relation R' := fun x y => req (projT1 x) (projT1 y). Instance r_st' : Equivalence req'. Proof. constructor; intro x; destruct x as [x Px]; try (intro y; destruct y as [y Py]); try (intro z; destruct z as [z Pz]); unfold req'; [ reflexivity | intro; symmetry; assumption | intros eqxy eqyz; rewrite eqxy; assumption ]. Qed. Let rO' := existT P rO zero_stab. Let rI' := existT P rI one_stab. Let radd' : binop R' := fun x y => existT P (radd x y) (radd_int (projT2 x) (projT2 y)). Let rmul' : binop R' := fun x y => existT P (rmul x y) (rmul_int (projT2 x) (projT2 y)). Let rsub' : binop R' := fun x y => existT P (rsub x y) (rsub_int (projT2 x) (projT2 y)). Let ropp' : unop R' := fun x => existT P (ropp x) (ropp_int (projT2 x)). Global Instance sr_ring : @Ring R' req' r_st' rO' rI' radd' rmul' rsub' ropp'. Proof. constructor. constructor; unfold R', req', radd', rmul', rsub', ropp', proj1'; intro x; destruct x as [ x Px ]; try (intro y; destruct y as [ y Py ]); try (intro z; destruct z as [ z Pz ]); simpl; ring. constructor; unfold R', req', radd', rmul', rsub', ropp', proj1'; simpl; intros x x'; destruct x as [ x Px ]; destruct x' as [ x' Px' ]; simpl; intro eqx; try (intros y y'; destruct y as [ y Py ]; destruct y' as [ y' Py' ]; simpl; intro eqy; simpl); [ apply radd_morph | apply rmul_morph | apply ropp_morph ]; assumption. Qed. End SubRing_is_Ring. corn-8.20.0/liouville/Zlcm.v000066400000000000000000000167451473720167500156730ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CRings Zring. Section Zgcd_lin. Lemma Z_dec : forall x y : Z_as_CRing, x [=] y or x [#] y. Proof. intros x y; case (Z.eq_dec x y). left; assumption. right; assumption. Qed. Lemma Zgcd_lin : forall a b c, (Z.abs c * Zgcd a b = Zgcd (c * a) (c * b))%Z. Proof. intros a b c. case (Z.eq_dec a 0). intro H; rewrite H; rewrite Zmult_0_r, Zgcd_zero_lft, Zgcd_zero_lft; apply Zabs_mult_compat. intro Ha; case (Z.eq_dec b 0). intro H; rewrite H; rewrite Zmult_0_r, Zgcd_zero_rht, Zgcd_zero_rht; apply Zabs_mult_compat. intro Hb; case (Z.eq_dec c 0). intro H; rewrite H; rewrite Zmult_0_l, Zmult_0_l, Zmult_0_l, Zgcd_zero_lft; reflexivity. intro Hc; apply Zdivides_antisymm. rewrite <- (Zmult_0_r (Z.abs c)). apply Zmult_pos_mon_lt_lft. apply Z.lt_gt. apply Zgcd_pos. left; assumption. destruct c; [destruct Hc| |]; reflexivity. apply Z.lt_gt. apply Zgcd_pos. left. intro H0; destruct (Zmult_zero_div _ _ H0). destruct Hc; assumption. destruct Ha; assumption. apply Zdiv_gcd_elim. apply Zdivides_mult_elim. apply Zdivides_abs_elim_lft. apply Zdivides_ref. apply Zgcd_is_divisor_lft. apply Zdivides_mult_elim. apply Zdivides_abs_elim_lft. apply Zdivides_ref. apply Zgcd_is_divisor_rht. cut (forall c : positive, Zdivides (Zgcd (c * a) (c * b)) (Z.abs c * Zgcd a b)). intro H; case c. simpl; rewrite Zgcd_zero_lft; apply Zdivides_ref. apply H. intro p; rewrite Zgcd_abs. rewrite <- Zabs_mult_compat, <- Zabs_mult_compat. simpl (Z.abs (Zneg p)). assert ((p:Z) = Z.abs p). reflexivity. rewrite H0; clear H0. rewrite Zabs_mult_compat, Zabs_mult_compat. rewrite <- Zgcd_abs. apply H. clear c Hc; intro c. rewrite (Zgcd_lin_comb a b). rewrite Zmult_plus_distr_r. simpl (Z.abs c). rewrite Zmult_assoc, Zmult_assoc. rewrite (Zmult_comm c (Zgcd_coeff_a a b)). rewrite (Zmult_comm c (Zgcd_coeff_b a b)). rewrite <- Zmult_assoc, <- Zmult_assoc. apply Zdivides_plus_elim. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_lft. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_rht. Qed. End Zgcd_lin. Definition Zlcm (a b : Z_as_CRing) : Z_as_CRing := Z.div (a [*] b) (Zgcd a b). Lemma Zlcm_specl : forall a b : Z_as_CRing, Zdivides a (Zlcm a b). Proof. intros a b. unfold Zlcm. case (Z.eq_dec (Zgcd a b) ([0]:Z_as_CRing)). intro H; rewrite H; simpl. rewrite Zdiv_0_r. apply Zdivides_zero_rht. intro H; rewrite -> (Zgcd_div_mult_rht a b) at 1; [|assumption]. simpl. rewrite Zmult_assoc. rewrite Z_div_mult_full; [|assumption]. apply Zdivides_mult_rht. Qed. Lemma Zlcm_specr : forall a b : Z_as_CRing, Zdivides b (Zlcm a b). Proof. intros a b. unfold Zlcm. case (Z.eq_dec (Zgcd a b) ([0]:Z_as_CRing)). intro H; rewrite H; simpl. rewrite Zdiv_0_r. apply Zdivides_zero_rht. intro H; rewrite -> (Zgcd_div_mult_lft a b) at 1; [|assumption]. simpl. rewrite Zmult_comm. rewrite Zmult_assoc. rewrite Z_div_mult_full; [|assumption]. apply Zdivides_mult_rht. Qed. Lemma Zlcm_spec : forall a b c : Z_as_CRing, Zdivides a c -> Zdivides b c -> Zdivides (Zlcm a b) c. Proof. intros a b c Hac Hbc; unfold Zlcm; simpl. case (Z.eq_dec (Zgcd a b) ([0]:Z_as_CRing)). intro H; rewrite H; simpl. destruct (Zgcd_zero _ _ H). rewrite H0 in Hac; clear H H0 H1. rewrite Zdiv_0_r; assumption. case (Z.eq_dec c ([0]:Z_as_CRing)). intro Hc; rewrite Hc. intro Hap; apply Zdivides_zero_rht. intros Hc Hap. apply Zdivides_abs_intro_rht. rewrite <- (Zmult_1_r (Z.abs c)). rewrite <- (Zgcd_div_gcd_1 a b); [|assumption]. rewrite Zgcd_lin. apply Zdiv_gcd_elim. cut (a * b / Zgcd a b = b * (a / Zgcd a b))%Z. intro H; rewrite H; clear H. apply Zdivides_mult_cancel_rht. assumption. rewrite Zmult_comm. apply (Zmult_reg_r _ _ (Zgcd a b) Hap). rewrite <- Zmult_assoc. rewrite <- (Zgcd_div_mult_lft _ _ Hap). rewrite Zmult_comm. rewrite <- (Z_div_exact_full_2 _ _ Hap). reflexivity. apply Zmod0_Zdivides. apply Hap. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_lft. cut (a * b / Zgcd a b = a * (b / Zgcd a b))%Z. intro H; rewrite H; clear H. apply Zdivides_mult_cancel_rht. assumption. apply (Zmult_reg_r _ _ (Zgcd a b) Hap). rewrite <- Zmult_assoc. rewrite <- (Zgcd_div_mult_rht _ _ Hap). rewrite Zmult_comm. rewrite <- (Z_div_exact_full_2 _ _ Hap). reflexivity. apply Zmod0_Zdivides. apply Hap. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_rht. Qed. Lemma Zlcm_zero : forall p q, Zlcm p q [=] [0] -> p [=] [0] or q [=] [0]. Proof. intros p q; unfold Zlcm; intro Heq. case (Z.eq_dec p ([0]:Z_as_CRing)). left; assumption. intro Happ; right. simpl in *. unfold ap_Z in Happ. apply (Zmult_integral_l _ _ Happ). rewrite Zmult_comm. revert Heq. assert (Zgcd p q <> 0%Z). intro H; destruct Happ; apply (Zgcd_zero _ _ H). rewrite -> (Zgcd_div_mult_lft p q) at 1; [|assumption]. rewrite (Zmult_comm (p / Zgcd p q)). rewrite <- Zmult_assoc. rewrite Zdiv_mult_cancel_lft; [|assumption]. intro Heq. rewrite (Zgcd_div_mult_lft p q); [|assumption]. rewrite <- Zmult_assoc, (Zmult_comm _ q), Zmult_assoc. rewrite Heq, Zmult_0_l; reflexivity. Qed. Fixpoint Zlcm_gen (l : list Z_as_CRing) : Z_as_CRing := match l with | nil => [1] | h::q => Zlcm h (Zlcm_gen q) end. Lemma Zlcm_gen_spec : forall l x, In x l -> Zdivides x (Zlcm_gen l). Proof. induction l. intros x Hin; destruct Hin. intros x Hin; destruct Hin. rewrite <- H; clear H. apply Zlcm_specl. fold (In x l) in H. simpl. apply (Zdivides_trans _ _ _ (IHl _ H)). apply Zlcm_specr. Qed. Lemma Zlcm_gen_spec2 : forall l x, (forall y, In y l -> Zdivides y x) -> Zdivides (Zlcm_gen l) x. Proof. induction l. intros; apply Zdivides_one. intros x H; apply Zlcm_spec. apply H; left; reflexivity. fold (Zlcm_gen l). apply IHl. intros y Hin; apply H. right; assumption. Qed. Lemma Zdivides_spec : forall (a b : Z), Zdivides a b -> (a * (b / a) = b)%Z. Proof. intros a b Hdiv. case (Z.eq_dec a 0). intro H; rewrite H; simpl. symmetry; apply Zdivides_zero_lft; rewrite <- H; assumption. intro Hap. rewrite <- Z_div_exact_full_2. reflexivity. assumption. case (Z.eq_dec a 0). now intro H; rewrite H in Hap. intro H; clear H. apply Zmod0_Zdivides; assumption. Qed. Lemma Zlcm_gen_nz : forall l, (forall x, In x l -> x [#] [0]) -> Zlcm_gen l [#] [0]. Proof. induction l. intro; intro; discriminate. simpl. intros H1 H2; simpl. destruct (Zlcm_zero a (Zlcm_gen l) H2). apply (H1 a); [left; reflexivity|assumption]. destruct IHl; [|assumption]. intros; apply H1; right; assumption. Qed. corn-8.20.0/liouville/nat_Q_lists.v000066400000000000000000000141001473720167500172250ustar00rootroot00000000000000(* Copyright © 2009 Valentin Blot Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import Zring Qring Q_can. Import CRings.coercions. Section nat_Q_lists. Fixpoint list_nat (p : nat) : list nat := match p with | O => O::nil | S p => S p::list_nat p end. Lemma list_nat_spec : forall p a, a <= p -> In a (list_nat p). Proof. intro p; induction p. intros a Hle; inversion Hle; left; reflexivity. intros a Hle; simpl. case (eq_nat_dec (S p) a). left; assumption. right; apply IHp. inversion Hle. destruct n; symmetry; assumption. assumption. Qed. Definition list_nat_prod (p q : nat) : list (nat * nat) := list_prod (list_nat p) (list_nat q). Lemma list_nat_prod_spec : forall p q a b, a <= p -> b <= q -> In (a, b) (list_nat_prod p q). Proof. intros; apply in_prod; apply list_nat_spec; assumption. Qed. Definition nat_prod_to_Q (pq : nat * nat) : list Q_as_CRing := let (p, q) := pq in match p with | O => Qmake Z0 (P_of_succ_nat q)::nil | S p => match q with | O => nil | S q => Qmake (Zpos (P_of_succ_nat p)) (P_of_succ_nat q):: Qmake (Zneg (P_of_succ_nat p)) (P_of_succ_nat q)::nil end end. Definition list_Q (a b : Z_as_CRing) : list Q_as_CRing := flat_map nat_prod_to_Q (list_nat_prod (Z.abs_nat a) (Z.abs_nat b)). Lemma list_Q_spec_pos : forall a b c d, Z.abs_nat c <= Z.abs_nat a -> Z.abs_nat (Zpos d) <= Z.abs_nat b -> In (Qmake c d) (list_Q a b). Proof. intros a b c d Hca Hdb. case (Qeq_dec (c#d)%Q [0]). unfold Qeq; simpl; rewrite Zmult_1_r. intro Heq; rewrite Heq. clear c Hca Heq. unfold list_Q. rewrite -> in_flat_map. exists (0, pred (nat_of_P d)). split. apply list_nat_prod_spec. apply Nat.le_0_l. apply (Nat.le_trans _ _ _ (Nat.le_pred_l _) Hdb). left. f_equal. destruct (ZL4 d). rewrite H. simpl. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H. apply nat_of_P_inj; symmetry; assumption. unfold list_Q. intro H. rewrite -> in_flat_map. exists (Z.abs_nat c, Z.abs_nat d). split. apply list_nat_prod_spec; assumption. simpl. case (ZL4 d). intros d' Hd'. unfold Z.abs_nat at 1 in Hdb. rewrite Hd'. rewrite Hd' in Hdb. case_eq (Z.abs_nat c). intro Heq. destruct H. destruct c. reflexivity. simpl in Heq; destruct (ZL4 p); rewrite Heq in H; discriminate. simpl in Heq; destruct (ZL4 p); rewrite Heq in H; discriminate. intros. destruct c as [|c|c]. discriminate. constructor 1. unfold Qeq; simpl. assert (c = P_of_succ_nat n). rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H0. simpl in H. apply nat_of_P_inj; assumption. rewrite H1. cut (P_of_succ_nat d' = d). intro H2; rewrite H2; reflexivity. apply nat_of_P_inj. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. symmetry; assumption. constructor 2. constructor 1. unfold Qeq; simpl. assert (c = P_of_succ_nat n). rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H0. simpl in H. apply nat_of_P_inj; assumption. rewrite H1. cut (P_of_succ_nat d' = d). intro H2; rewrite H2; reflexivity. apply nat_of_P_inj. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. symmetry; assumption. Qed. Lemma list_Q_spec_neg : forall a b c d, Z.abs_nat c <= Z.abs_nat a -> Z.abs_nat (Zneg d) <= Z.abs_nat b -> In (Qmake c d) (list_Q a b). Proof. intros a b c d. apply list_Q_spec_pos. Qed. Lemma list_Q_spec_zero : forall a b d, nat_of_P d <= Z.abs_nat b -> In (Qmake Z0 d) (list_Q a b). Proof. intros a b d Hle. unfold list_Q. rewrite -> in_flat_map. exists (0, pred (nat_of_P d)). split. apply list_nat_prod_spec. apply Nat.le_0_l. apply (Nat.le_trans _ _ _ (Nat.le_pred_l _) Hle). left. f_equal. destruct (ZL4 d). rewrite H. simpl. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ in H. apply nat_of_P_inj; symmetry; assumption. Qed. Lemma div_imp_leq : forall a b : Z_as_CRing, b [#] [0] -> Zdivides a b -> Z.abs_nat a <= Z.abs_nat b. Proof. intros a b Hap Hdiv. destruct Hdiv. rewrite <- H. rewrite Zabs_nat_mult. rewrite <- H in Hap. destruct x. destruct Hap. reflexivity. simpl. destruct (ZL4 p). rewrite H0. simpl. rewrite <- (Nat.add_0_r (Z.abs_nat a)) at 1. apply Nat.add_le_mono_l. apply Nat.le_0_l. simpl. destruct (ZL4 p). rewrite H0. simpl. rewrite <- (Nat.add_0_r (Z.abs_nat a)) at 1. apply Nat.add_le_mono_l. apply Nat.le_0_l. Qed. Lemma list_Q_spec : forall (a b : Z_as_CRing) q, a [#] [0] -> b [#] [0] -> Zdivides (Q_can_num q) a -> Zdivides (Z.abs_nat (Q_can_den_pos_val q)) b -> In (Q_can q) (list_Q a b). Proof. intros a b q Hapa Hapb Ha Hb. destruct q as [qn qd]. destruct qn. apply list_Q_spec_zero. revert Hb; generalize (Q_can_den_pos_val (0#qd)%Q). intros p Hdiv. assert (nat_of_P p = Z.abs_nat p). reflexivity. rewrite H; apply div_imp_leq. assumption. rewrite inj_Zabs_nat in Hdiv. apply Zdivides_abs_intro_lft; assumption. apply list_Q_spec_pos. apply div_imp_leq; assumption. apply div_imp_leq. assumption. apply Zdivides_abs_intro_lft. rewrite <- inj_Zabs_nat. assumption. apply list_Q_spec_neg. apply div_imp_leq; assumption. apply div_imp_leq. assumption. apply Zdivides_abs_intro_lft. rewrite <- inj_Zabs_nat. assumption. Qed. End nat_Q_lists. corn-8.20.0/logic/000077500000000000000000000000001473720167500136535ustar00rootroot00000000000000corn-8.20.0/logic/CLogic.v000066400000000000000000001177361473720167500152210ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Not %\ensuremath\neg% #~# *) (** printing CNot %\ensuremath\neg% #~# *) (** printing Iff %\ensuremath\Leftrightarrow% #⇔# *) (** printing CFalse %\ensuremath\bot% #⊥# *) (** printing False %\ensuremath\bot% #⊥# *) (** printing CTrue %\ensuremath\top% *) (** printing True %\ensuremath\top% *) (** printing or %\ensuremath{\mathrel\vee}% *) (** printing and %\ensuremath{\mathrel\wedge}% *) From Coq Require Export Compare_dec. Require Export CoRN.logic.CornBasics. From Coq Require Export ZArith. From Coq Require Export ZArithRing. From Coq Require Export Wf_nat. From Coq Require Import Lia. (** * Extending the Coq Logic Because notions of apartness and order have computational meaning, we will have to define logical connectives in [Type]. In order to keep a syntactic distinction between types of terms, we define [CProp] as an alias for [Type], to be used as type of (computationally meaningful) propositions. Falsehood and negation will typically not be needed in [CProp], as they are used to refer to negative statements, which carry no computational meaning. Therefore, we will simply define a negation operator from [Type] to [Prop] . Conjunction, disjunction and existential quantification will have to come in multiple varieties. For conjunction, we will need four operators of type [s1->s2->s3], where [s3] is [Prop] if both [s1] and [s2] are [Prop] and [CProp] otherwise. We here take advantage of the inclusion of [Prop] in [Type]. Disjunction is slightly different, as it will always return a value in [CProp] even if both arguments are propositions. This is because in general it may be computationally important to know which of the two branches of the disjunction actually holds. Existential quantification will similarly always return a value in [CProp]. - [CProp]-valued conjuction will be denoted as [and]; - [Crop]-valued conjuction will be denoted as [or]; - Existential quantification will be written as [{x:A & B}] or [{x:A | B}], according to whether [B] is respectively of type [CProp] or [Prop]. In a few specific situations we do need truth, false and negation in [CProp], so we will also introduce them; this should be a temporary option. Finally, for other formulae that might occur in our [CProp]-valued propositions, such as [(le m n)], we have to introduce a [CProp]-valued version. *) Notation "'CProp'":= Type. Section Basics. (** ** Basics Here we treat conversion from [Prop] to [CProp] and vice versa, and some basic connectives in [CProp]. *) Definition True_constr := I. (* The name I is occasionally used for other things, hiding True's constructor. *) Definition Not (P : CProp) := P -> False. Definition Iff (A B : CProp) : CProp := prod (A -> B) (B -> A). Definition proj1_sigT (A : Type) (P : A -> CProp) (e : sigT P) := match e with | existT _ a b => a end. Definition proj2_sigT (A : Type) (P : A -> CProp) (e : sigT P) := match e return (P (proj1_sigT A P e)) with | existT _ a b => b end. Inductive sig2T (A : Type) (P Q : A -> CProp) : CProp := exist2T : forall x : A, P x -> Q x -> sig2T A P Q. Definition proj1_sig2T (A : Type) (P Q : A -> CProp) (e : sig2T A P Q) := match e with | exist2T _ _ _ a b c => a end. Definition proj2a_sig2T (A : Type) (P Q : A -> CProp) (e : sig2T A P Q) := match e return (P (proj1_sig2T A P Q e)) with | exist2T _ _ _ a b c => b end. Definition proj2b_sig2T (A : Type) (P Q : A -> CProp) (e : sig2T A P Q) := match e return (Q (proj1_sig2T A P Q e)) with | exist2T _ _ _ a b c => c end. End Basics. (* begin hide *) Infix "or" := sum (at level 85, right associativity). Infix "and" := prod (at level 80, right associativity). Notation "A 'IFF' B" := (Iff A B) (at level 95, no associativity). Notation ProjT1 := (proj1_sigT _ _). Notation ProjT2 := (proj2_sigT _ _). (* end hide *) (** Some lemmas to make it possible to use [Step] when reasoning with bi-implications. *) Lemma Iff_left : forall (A B C : CProp), (A IFF B) -> (A IFF C) -> (C IFF B). Proof. unfold Iff. intuition. Qed. Lemma Iff_right: forall (A B C : CProp), (A IFF B) -> (A IFF C) -> (B IFF C). Proof. unfold Iff. intuition. Qed. Lemma Iff_refl : forall (A : CProp), (A IFF A). Proof. unfold Iff. intuition. Qed. Lemma Iff_sym : forall (A B : CProp),(A IFF B) -> (B IFF A). Proof. unfold Iff. intuition. Qed. Lemma Iff_trans : forall (A B C : CProp), (prod (A IFF B) (B IFF C)) -> (A IFF C). Proof. unfold Iff. intuition. Qed. Lemma Iff_imp_imp : forall (A B : CProp), (A IFF B) -> (prod (A->B) (B->A)). Proof. unfold Iff. intuition. Qed. Declare Right Step Iff_right. Declare Left Step Iff_left. #[global] Hint Resolve Iff_trans Iff_sym Iff_refl Iff_right Iff_left Iff_imp_imp : algebra. Lemma not_r_cor_rect : forall (A B : CProp) (S : Type) (l r : S), Not B -> forall H : A or B, @sum_rect A B (fun _ : A or B => S) (fun x : A => l) (fun x : B => r) H = l. Proof. intros. elim H0. intros. reflexivity. intro. elim H. assumption. Qed. Lemma not_l_cor_rect : forall (A B : CProp) (S : Type) (l r : S), Not A -> forall H : A or B, @sum_rect A B (fun _ : A or B => S) (fun x : A => l) (fun x : B => r) H = r. Proof. intros. elim H0. intro. elim H. assumption. intros. reflexivity. Qed. (* begin hide *) (** This notation is incompatible with [Program]. It should be avoided *) Notation "{ x : A | P }" := (sigT (fun x : A => P):CProp) (at level 0, x at level 99) : type_scope. Notation "{ x : A | P | Q }" := (sig2T A (fun x : A => P) (fun x : A => Q)) (at level 0, x at level 99) : type_scope. (* end hide *) #[global] Hint Resolve pair inl inr existT exist2T : core. Section Choice. (* **Choice Let [P] be a predicate on $\NN^2$#N times N#. *) Variable P : nat -> nat -> Prop. Lemma choice : (forall n : nat, {m : nat | P n m}) -> {d : nat -> nat | forall n : nat, P n (d n)}. Proof. intro H. exists (fun i : nat => proj1_sigT _ _ (H i)). apply (fun i : nat => proj2_sigT _ _ (H i)). Qed. End Choice. Section Logical_Remarks. (** We prove a few logical results which are helpful to have as lemmas when [A], [B] and [C] are non trivial. *) Lemma CNot_Not_or : forall A B C : CProp, (A -> Not C) -> (B -> Not C) -> ~ Not (A or B) -> Not C. Proof. intros A B C H H0 H1. intro H2. apply H1. intro H3. elim H3. intro; apply H; auto. intro; apply H0; auto. Qed. Lemma CdeMorgan_ex_all : forall (A : Type) (P : A -> CProp) (X : Type), (sigT P -> X) -> forall a : A, P a -> X. Proof. intros A P X H a H0. eauto. Qed. End Logical_Remarks. Section CRelation_Definition. (** ** [CProp]-valued Relations Similar to Relations.v in Coq's standard library. %\begin{convention}% Let [A:Type] and [R:Crelation]. %\end{convention}% *) Variable A : Type. Definition Crelation := A -> A -> CProp. Variable R : Crelation. Definition Creflexive : CProp := forall x : A, R x x. Definition Ctransitive : CProp := forall x y z : A, R x y -> R y z -> R x z. Definition Csymmetric : CProp := forall x y : A, R x y -> R y x. Record Cequivalence : CProp := {Cequiv_refl : Creflexive; Cequiv_symm : Csymmetric; Cequiv_trans : Ctransitive}. Definition Cdecidable (P:CProp):= P or Not P. End CRelation_Definition. Fixpoint member (A : Type) (n : A) (l : list A) {struct l} : CProp := match l with | nil => False | cons y m => member A n m or y = n end. Arguments member [A]. Section TRelation_Definition. (** ** [Prop]-valued Relations Analogous. %\begin{convention}% Let [A:Type] and [R:Trelation]. %\end{convention}% *) Variable A : Type. Definition Trelation := A -> A -> Prop. Variable R : Trelation. Definition Treflexive : CProp := forall x : A, R x x. Definition Ttransitive : CProp := forall x y z : A, R x y -> R y z -> R x z. Definition Tsymmetric : CProp := forall x y : A, R x y -> R y x. Definition Tequiv : CProp := Treflexive and Ttransitive and Tsymmetric. End TRelation_Definition. Section le_odd. (** ** The relation [le], [lt], [odd] and [even] in [CProp] *) Inductive Cle (n : nat) : nat -> CProp := | Cle_n : Cle n n | Cle_S : forall m : nat, Cle n m -> Cle n (S m). Theorem Cnat_double_ind : forall R : nat -> nat -> CProp, (forall n : nat, R 0 n) -> (forall n : nat, R (S n) 0) -> (forall n m : nat, R n m -> R (S n) (S m)) -> forall n m : nat, R n m. Proof. simple induction n; auto. simple induction m; auto. Qed. Theorem my_Cle_ind : forall (n : nat) (P : nat -> CProp), P n -> (forall m : nat, Cle n m -> P m -> P (S m)) -> forall n0 : nat, Cle n n0 -> P n0. Proof. intros n P. generalize (Cle_rect n (fun (n0 : nat) (H : Cle n n0) => P n0)); intro. assumption. Qed. Theorem Cle_n_S : forall n m : nat, Cle n m -> Cle (S n) (S m). Proof. intros n m H. pattern m in |- *. apply (my_Cle_ind n). apply Cle_n. intros. apply Cle_S. assumption. assumption. Qed. Lemma toCle : forall m n : nat, m <= n -> Cle m n. Proof. intros m. induction m as [| m Hrecm]. simple induction n. intro H. apply Cle_n. intros n0 H H0. apply Cle_S. apply H. apply Nat.le_0_l. simple induction n. intro. exfalso. inversion H. intros n0 H H0. generalize (le_S_n _ _ H0); intro H1. generalize (Hrecm _ H1); intro H2. apply Cle_n_S. assumption. Qed. Hint Resolve toCle. Lemma Cle_to : forall m n : nat, Cle m n -> m <= n. Proof. intros m n H. elim H. apply le_n. intros m0 s H0. apply le_S. assumption. Qed. Definition Clt (m n : nat) : CProp := Cle (S m) n. Lemma toCProp_lt : forall m n : nat, m < n -> Clt m n. Proof. unfold lt in |- *. unfold Clt in |- *. intros m n H. apply toCle. assumption. Qed. Lemma Clt_to : forall m n : nat, Clt m n -> m < n. Proof. unfold lt in |- *. unfold Clt in |- *. intros m n H. apply Cle_to. assumption. Qed. Lemma Cle_le_S_eq : forall p q : nat, p <= q -> {S p <= q} + {p = q}. Proof. intros p q H. elim (gt_eq_gt_dec p q); intro H0. elim H0; auto. exfalso. apply Nat.lt_nge with q p; auto. Qed. Lemma Cnat_total_order : forall m n : nat, m <> n -> {m < n} + {n < m}. Proof. intros m n H. elim (gt_eq_gt_dec m n). intro H0. elim H0; intros. left; auto. exfalso. auto. auto. Qed. (** For compatibility with Coq.8.14 and Coq.8.15: this can be removed and changed with Nat.Even_Odd_dec when the minimal version is bumped to 8.16 *) Lemma Even_Odd_dec (n : nat) : {Nat.Even n} + {Nat.Odd n}. Proof. destruct (Nat.even n) eqn:E. - left; apply Nat.even_spec; exact E. - right; apply Bool.negb_true_iff in E; rewrite Nat.negb_even in E. apply Nat.odd_spec; exact E. Qed. Inductive Codd : nat -> CProp := Codd_S : forall n : nat, Ceven n -> Codd (S n) with Ceven : nat -> CProp := | Ceven_O : Ceven 0 | Ceven_S : forall n : nat, Codd n -> Ceven (S n). Lemma Codd_even_to : forall n : nat, (Codd n -> Nat.Odd n) /\ (Ceven n -> Nat.Even n). Proof. simple induction n. split. intro H. inversion H. intro. now exists 0. intros n0 H. elim H; intros H0 H1. split. intro H2. inversion H2. apply Nat.Odd_succ. apply H1. assumption. intro H2. inversion H2. apply Nat.Even_succ. apply H0. assumption. Qed. Lemma Codd_to : forall n : nat, Codd n -> Nat.Odd n. Proof. intros n H. elim (Codd_even_to n); auto. Qed. Lemma Ceven_to : forall n : nat, Ceven n -> Nat.Even n. Proof. intros n H. elim (Codd_even_to n); auto. Qed. Lemma to_Codd_even : forall n : nat, (Nat.Odd n -> Codd n) and (Nat.Even n -> Ceven n). Proof. induction n as [| n IH]; split. - intros H%Nat.odd_spec; discriminate H. - intros _; exact Ceven_O. - now intros H%Nat.Odd_succ; apply IH in H; apply Codd_S. - now intros H%Nat.Even_succ; apply IH in H; apply Ceven_S. Qed. Lemma to_Codd : forall n : nat, Nat.Odd n -> Codd n. Proof. intros. elim (to_Codd_even n); auto. Qed. Lemma to_Ceven : forall n : nat, Nat.Even n -> Ceven n. Proof. intros. elim (to_Codd_even n); auto. Qed. End le_odd. Section Misc. (** ** Miscellaneous *) Lemma CZ_exh : forall z : Z, {n : nat | z = n} or {n : nat | z = (- n)%Z}. Proof. intro z. elim z. left. exists 0. auto. intro p. left. exists (nat_of_P p). rewrite convert_is_POS. reflexivity. intro p. right. exists (nat_of_P p). rewrite min_convert_is_NEG. reflexivity. Qed. Lemma Cnats_Z_ind : forall P : Z -> CProp, (forall n : nat, P n) -> (forall n : nat, P (- n)%Z) -> forall z : Z, P z. Proof. intros P H H0 z. elim (CZ_exh z); intros H1. elim H1; intros n H2. rewrite H2. apply H. elim H1; intros n H2. rewrite H2. apply H0. Qed. Lemma Cdiff_Z_ind : forall P : Z -> CProp, (forall m n : nat, P (m - n)%Z) -> forall z : Z, P z. Proof. intros P H z. apply Cnats_Z_ind. intro n. replace (Z_of_nat n) with (n - 0%nat)%Z. apply H. simpl in |- *. auto with zarith. intro n. replace (- n)%Z with (0%nat - n)%Z. apply H. simpl in |- *. reflexivity. Qed. Lemma Cpred_succ_Z_ind : forall P : Z -> CProp, P 0%Z -> (forall n : Z, P n -> P (n + 1)%Z) -> (forall n : Z, P n -> P (n - 1)%Z) -> forall z : Z, P z. Proof. intros P H H0 H1 z. apply Cnats_Z_ind. intro n. elim n. exact H. intros n0 H2. replace (S n0:Z) with (n0 + 1)%Z. apply H0. assumption. rewrite Znat.inj_S. reflexivity. intro n. elim n. exact H. intros n0 H2. replace (- S n0)%Z with (- n0 - 1)%Z. apply H1. assumption. rewrite Znat.inj_S. unfold Z.succ in |- *. rewrite Zopp_plus_distr. reflexivity. Qed. Lemma not_r_sum_rec : forall (A B S : Set) (l r : S), Not B -> forall H : A + B, sum_rec (fun _ : A + B => S) (fun x : A => l) (fun x : B => r) H = l. Proof. intros A B S l r H H0. elim H0. intro a. reflexivity. intro b. elim H. assumption. Qed. Lemma not_l_sum_rec : forall (A B S : Set) (l r : S), Not A -> forall H : A + B, sum_rec (fun _ : A + B => S) (fun x : A => l) (fun x : B => r) H = r. Proof. intros A B S l r H H0. elim H0. intro a. elim H. assumption. intros. reflexivity. Qed. (** %\begin{convention}% Let [M:Type]. %\end{convention}% *) Variable M : Type. Lemma member_app : forall (x : M) (l k : (list M)), (Iff (member x (app k l)) ((member x k) or (member x l))). Proof. induction k; firstorder. Qed. End Misc. (** ** Results about the natural numbers We now define a class of predicates on a finite subset of natural numbers that will be important throughout all our work. Essentially, these are simply setoid predicates, but for clarity we will never write them in that form but we will single out the preservation of the setoid equality. *) Definition nat_less_n_pred (n : nat) (P : forall i : nat, i < n -> CProp) := forall i j : nat, i = j -> forall (H : i < n) (H' : j < n), P i H -> P j H'. Definition nat_less_n_pred' (n : nat) (P : forall i : nat, i <= n -> CProp) := forall i j : nat, i = j -> forall (H : i <= n) (H' : j <= n), P i H -> P j H'. Arguments nat_less_n_pred [n]. Arguments nat_less_n_pred' [n]. Section Odd_and_Even. (** For our work we will many times need to distinguish cases between even or odd numbers. We begin by proving that this case distinction is decidable. Next, we prove the usual results about sums of even and odd numbers: *) Lemma even_plus_n_n : forall n : nat, Nat.Even (n + n). Proof. intros n; replace (n + n) with (Nat.double n) by reflexivity. now rewrite Nat.double_twice; exists n. Qed. Lemma even_or_odd_plus : forall k : nat, {j : nat & {k = j + j} + {k = S (j + j)}}. Proof. induction k as [| k IH]. - exists 0; left; reflexivity. - destruct IH as [j [H | H]]. + now exists j; right; rewrite H. + now exists (S j); left; rewrite H, Nat.add_succ_r. Qed. (** Finally, we prove that an arbitrary natural number can be written in some canonical way. *) Lemma even_or_odd_plus_gt : forall i j : nat, i <= j -> {k : nat & {j = i + (k + k)} + {j = i + S (k + k)}}. Proof. intros i j H. destruct (even_or_odd_plus (j - i)) as [k [Hk | Hk]]; exists k. destruct (Nat.eq_dec k 0) as [-> | I]. - left; rewrite Nat.add_0_r; rewrite Nat.add_0_r in Hk. now apply Nat.sub_0_le in Hk; apply Nat.le_antisymm. - left; apply Nat.add_sub_eq_nz in Hk; [| now intros [C _]%Nat.eq_add_0]. exact (eq_sym Hk). - right; apply Nat.add_sub_eq_nz in Hk; [| now intros C]. exact (eq_sym Hk). Qed. End Odd_and_Even. #[global] Hint Resolve even_plus_n_n: arith. #[global] Hint Resolve toCle: core. Section Natural_Numbers. (** ** Algebraic Properties We now present a series of trivial things proved with [Lia] that are stated as lemmas to make proofs shorter and to aid in auxiliary definitions. Giving a name to these results allows us to use them in definitions keeping conciseness. *) Lemma Clt_le_weak : forall i j : nat, Clt i j -> Cle i j. Proof. intros. apply toCle; apply Nat.lt_le_incl; apply Clt_to; assumption. Qed. Lemma lt_5 : forall i n : nat, i < n -> pred i < n. Proof. intros; apply Nat.le_lt_trans with (pred n). apply Nat.pred_le_mono; auto with arith. apply Nat.lt_pred_l; apply Nat.neq_0_lt_0. apply Nat.le_lt_trans with i; auto with arith. Qed. Lemma lt_8 : forall m n : nat, m < pred n -> m < n. Proof. intros; apply Nat.lt_le_trans with (pred n); auto with arith. Qed. Lemma pred_lt : forall m n : nat, m < pred n -> S m < n. Proof. intros; apply Nat.le_lt_trans with (pred n); auto with arith. apply Nat.lt_pred_l; apply Nat.neq_0_lt_0. apply Nat.le_lt_trans with m. auto with arith. apply Nat.lt_le_trans with (pred n); auto with arith. Qed. Lemma lt_10 : forall i m n : nat, 0 < i -> i < pred (m + n) -> pred i < pred m + pred n. Proof. intros; lia. Qed. Lemma lt_pred' : forall m n : nat, 0 < m -> m < n -> pred m < pred n. Proof. intros m n H H0; red in |- *. destruct n. inversion H0. rewrite (Nat.lt_succ_pred 0 m); auto. simpl in |- *. auto with arith. Qed. Lemma le_1 : forall m n : nat, Cle m n -> pred m <= n. Proof. intros. cut (m <= n); [ intro | apply Cle_to; assumption ]. apply Nat.le_trans with (pred n); auto with arith. apply Nat.pred_le_mono; auto. Qed. Lemma le_2 : forall i j : nat, i < j -> i <= pred j. Proof. intros; lia. Qed. Lemma plus_eq_one_imp_eq_zero : forall m n : nat, m + n <= 1 -> {m = 0} + {n = 0}. Proof. intros m n H. elim (le_lt_dec m 0); intro. left; auto with arith. right; lia. Qed. Lemma not_not_lt : forall i j : nat, ~ ~ i < j -> i < j. Proof. intros; lia. Qed. Lemma plus_pred_pred_plus : forall i j k, k <= pred i + pred j -> k <= pred (i + j). Proof. intros; lia. Qed. (** We now prove some properties of functions on the natural numbers. %\begin{convention}% Let [H:nat->nat]. %\end{convention}% *) Variable h : nat -> nat. (** First we characterize monotonicity by a local condition: if [h(n) < h(n+1)] for every natural number [n] then [h] is monotonous. An analogous result holds for weak monotonicity. *) Lemma nat_local_mon_imp_mon : (forall i : nat, h i < h (S i)) -> forall i j : nat, i < j -> h i < h j. Proof. intros H i j H0. induction j as [| j Hrecj]. exfalso; lia. cut (i <= j); [ intro H1 | auto with arith ]. elim (le_lt_eq_dec _ _ H1); intro H2. cut (h i < h j); [ intro | apply Hrecj; assumption ]. cut (h j < h (S j)); [ intro | apply H ]. apply Nat.lt_trans with (h j); auto. rewrite H2; apply H. Qed. Lemma nat_local_mon_imp_mon_le : (forall i : nat, h i <= h (S i)) -> forall i j : nat, i <= j -> h i <= h j. Proof. intros H i j H0. induction j as [| j Hrecj]. cut (i = 0); [ intro H1 | auto with arith ]. rewrite H1; apply le_n. elim (le_lt_eq_dec _ _ H0); intro H1. cut (h i <= h j); [ intro | apply Hrecj; auto with arith ]. cut (h j <= h (S j)); [ intro | apply H ]. apply Nat.le_trans with (h j); auto. rewrite H1; apply le_n. Qed. (** A strictly increasing function is injective: *) Lemma nat_mon_imp_inj : (forall i j : nat, i < j -> h i < h j) -> forall i j : nat, h i = h j -> i = j. Proof. intros H i j H0. cut (~ i <> j); [ lia | intro H1 ]. cut (i < j \/ j < i); [ intro H2 | lia ]. inversion_clear H2. cut (h i < h j); [ rewrite H0; apply Nat.lt_irrefl | apply H; assumption ]. cut (h j < h i); [ rewrite H0; apply Nat.lt_irrefl | apply H; assumption ]. Qed. (** And (not completely trivial) a function that preserves [lt] also preserves [le]. *) Lemma nat_mon_imp_mon' : (forall i j : nat, i < j -> h i < h j) -> forall i j : nat, i <= j -> h i <= h j. Proof. intros H i j H0. elim (le_lt_eq_dec _ _ H0); intro H1. apply Nat.lt_le_incl; apply H; assumption. rewrite H1; apply le_n. Qed. (** The last lemmas in this section state that a monotonous function in the natural numbers completely covers the natural numbers, that is, for every natural number [n] there is an [i] such that [h(i) <= n<(n+1) <= h(i+1)]. These are useful for integration. *) Lemma mon_fun_covers : (forall i j, i < j -> h i < h j) -> h 0 = 0 -> forall n, {k : nat | S n <= h k} -> {i : nat | h i <= n | S n <= h (S i)}. Proof. intros H H0 n H1. elim H1; intros k Hk. induction k as [| k Hreck]. exists 0. rewrite H0; auto with arith. cut (h 0 < h 1); [ intro; apply Nat.le_trans with (h 0); auto with arith | apply H; apply Nat.lt_succ_diag_r ]. cut (h k < h (S k)); [ intro H2 | apply H; apply Nat.lt_succ_diag_r ]. elim (le_lt_dec (S n) (h k)); intro H3. elim (Hreck H3); intros i Hi. exists i; assumption. exists k; auto with arith. Qed. Lemma weird_mon_covers : forall n (f : nat -> nat), (forall i, f i < n -> f i < f (S i)) -> {m : nat | n <= f m | forall i, i < m -> f i < n}. Proof. intros; induction n as [| n Hrecn]. exists 0. auto with arith. intros; inversion H0. elim Hrecn. 2: auto. intros m Hm Hm'. elim (le_lt_eq_dec _ _ Hm); intro. exists m. assumption. auto with arith. exists (S m). apply Nat.le_lt_trans with (f m). rewrite b; auto with arith. apply H. rewrite b; apply Nat.lt_succ_diag_r. intros. elim (le_lt_eq_dec _ _ H0); intro. auto with arith. cut (i = m); [ intro | auto ]. rewrite b; rewrite <- H1. apply Nat.lt_succ_diag_r. Qed. End Natural_Numbers. (** Useful for the Fundamental Theorem of Algebra. *) Lemma kseq_prop : forall (k : nat -> nat) (n : nat), (forall i : nat, 1 <= k i /\ k i <= n) -> (forall i : nat, k (S i) <= k i) -> {j : nat | S j < 2 * n /\ k j = k (S j) /\ k (S j) = k (S (S j))}. Proof. intros k n. generalize k; clear k. induction n as [| n Hrecn]; intros k H H0. elim (H 0); intros H1 H2. generalize (Nat.le_trans _ _ _ H1 H2); intro H3. exfalso. inversion H3. elim (eq_nat_dec (k 0) (k 2)). intro H1. exists 0. cut (k 0 = k 1). intro H2. repeat split. lia. assumption. rewrite <- H1. auto. apply Nat.le_antisymm. rewrite H1. apply H0. apply H0. intro H1. elim (Hrecn (fun m : nat => k (S (S m)))). 3: intro; apply H0. intros m Hm. exists (S (S m)); lia. intro i. split. elim (H (S (S i))); auto. elim (lt_eq_lt_dec (k 0) (k 2)); intro H2. elim H2; intro H3. generalize (H0 0); intro H4. generalize (H0 1); intro H5. lia. tauto. generalize (H 0); intro H3. elim H3; intros H4 H5. generalize (Nat.lt_le_trans _ _ _ H2 H5); intro H6. cut (k 2 <= n). 2: lia. intro H7. induction i as [| i Hreci]. assumption. apply Nat.le_trans with (k (S (S i))); auto. Qed. Section Predicates_to_CProp. (** ** Logical Properties This section contains lemmas that aid in logical reasoning with natural numbers. First, we present some principles of induction, both for [CProp]- and [Prop]-valued predicates. We begin by presenting the results for [CProp]-valued predicates: *) Lemma even_induction : forall P : nat -> CProp, P 0 -> (forall n, Nat.Even n -> P n -> P (S (S n))) -> forall n, Nat.Even n -> P n. Proof. intros P H0 H n; induction n as [n IH] using Wf_nat.lt_wf_rect. destruct n as [| n]. - intros _; exact H0. - destruct n as [| n]. + intros C%Nat.even_spec; discriminate C. + intros Hn; apply ->Nat.Even_succ_succ in Hn. apply H; [exact Hn |]. apply IH; [| exact Hn]. apply Nat.lt_trans with (1 := Nat.lt_succ_diag_r n). exact (Nat.lt_succ_diag_r _). Qed. Lemma odd_induction : forall P : nat -> CProp, P 1 -> (forall n, Nat.Odd n -> P n -> P (S (S n))) -> forall n, Nat.Odd n -> P n. Proof. intros P H1 H [| n] Hn. - apply Nat.odd_spec in Hn; discriminate Hn. - apply (even_induction (fun n => P (S n))). + exact H1. + now intros k Hk; apply H, Nat.Odd_succ. + now apply Nat.Odd_succ. Qed. Lemma four_induction : forall P : nat -> CProp, P 0 -> P 1 -> P 2 -> P 3 -> (forall n, P n -> P (S (S (S (S n))))) -> forall n, P n. Proof. intros. apply lt_wf_rect. intro m. case m; auto. clear m; intro m. case m; auto. clear m; intro m. case m; auto. clear m; intro m. case m; auto with arith. Qed. Lemma nat_complete_double_induction : forall P : nat -> nat -> CProp, (forall m n, (forall m' n', m' < m -> n' < n -> P m' n') -> P m n) -> forall m n, P m n. Proof. intros P H m. pattern m in |- *; apply lt_wf_rect; auto with arith. Qed. Lemma odd_double_ind : forall P : nat -> CProp, (forall n, Nat.Odd n -> P n) -> (forall n, 0 < n -> P n -> P (Nat.double n)) -> forall n, 0 < n -> P n. Proof. assert (forall n : nat, 0 < Nat.double n -> 0 < n) as H. { unfold Nat.double; intros [| n]; simpl; [intros []%Nat.lt_irrefl |]. intros _; exact (Nat.lt_0_succ _). } intro. intro H0. intro H1. intro n. pattern n in |- *. apply lt_wf_rect. intros n0 H2 H3. pose proof (even_or_odd_plus n0) as [k [Hk | Hk]]. - assert (0 < k) as I. { apply H; unfold Nat.double; rewrite <-Hk; exact H3. } rewrite Hk; apply H1; [exact I |]. apply H2. lia. exact I. - apply H0. exists k. lia. Qed. (** For subsetoid predicates in the natural numbers we can eliminate disjunction (and existential quantification) as follows. *) Lemma finite_or_elim : forall (n : nat) (P Q : forall i, i <= n -> CProp), nat_less_n_pred' P -> nat_less_n_pred' Q -> (forall i H, P i H or Q i H) -> {m : nat | {Hm : m <= n | P m Hm}} or (forall i H, Q i H). Proof. intro n; induction n as [| n Hrecn]. intros P Q HP HQ H. elim (H _ (le_n 0)); intro H0. left; exists 0; exists (le_n 0); assumption. right; intros i H1. apply HQ with (H := le_n 0); auto with arith. intros P Q H H0 H1. elim (H1 _ (le_n (S n))); intro H2. left; exists (S n); exists (le_n (S n)); assumption. set (P' := fun (i : nat) (H : i <= n) => P i (le_S _ _ H)) in *. set (Q' := fun (i : nat) (H : i <= n) => Q i (le_S _ _ H)) in *. cut ({m : nat | {Hm : m <= n | P' m Hm}} or (forall (i : nat) (H : i <= n), Q' i H)). intro H3; elim H3; intro H4. left. elim H4; intros m Hm; elim Hm; clear H4 Hm; intros Hm Hm'. exists m. unfold P' in Hm'. exists (le_S _ _ Hm). eapply H with (i := m); [ lia | apply Hm' ]. right. intros i H5. unfold Q' in H4. elim (le_lt_eq_dec _ _ H5); intro H6. cut (i <= n); [ intro | auto with arith ]. eapply H0 with (i := i); [ auto with arith | apply (H4 i H7) ]. eapply H0 with (i := S n); [ auto with arith | apply H2 ]. apply Hrecn. intro i; intros j H3 H4 H5 H6. unfold P' in |- *. exact (H _ _ H3 _ _ H6). intro i; intros j H3 H4 H5 H6. unfold Q' in |- *. exact (H0 _ _ H3 _ _ H6). intros i H3. unfold P', Q' in |- *; apply H1. Qed. Lemma str_finite_or_elim : forall (n : nat) (P Q : forall i, i <= n -> CProp), nat_less_n_pred' P -> nat_less_n_pred' Q -> (forall i H, P i H or Q i H) -> {j : nat | {Hj : j <= n | P j Hj and (forall j' Hj', j' < j -> Q j' Hj')}} or (forall i H, Q i H). Proof. intro n; induction n as [| n Hrecn]. intros P Q H H0 H1. elim (H1 0 (le_n 0)); intro HPQ. left. exists 0; exists (le_n 0). split. apply H with (H := le_n 0); auto. intros; exfalso; inversion H2. right; intros. apply H0 with (H := le_n 0); auto with arith. intros P Q H H0 H1. set (P' := fun (i : nat) (H : i <= n) => P i (le_S _ _ H)) in *. set (Q' := fun (i : nat) (H : i <= n) => Q i (le_S _ _ H)) in *. elim (Hrecn P' Q'). intro H2. left. elim H2; intros m Hm; elim Hm; clear H2 Hm; intros Hm Hm'. exists m. unfold P' in Hm'. exists (le_S _ _ Hm). elim Hm'; clear Hm'; intros Hm' Hj. split. eapply H with (i := m); [ auto with arith | apply Hm' ]. unfold Q' in Hj; intros j' Hj' H2. cut (j' <= n); [ intro H4 | apply Nat.le_trans with m; auto with arith ]. apply H0 with (H := le_S _ _ H4); [ auto | apply Hj; assumption ]. elim (H1 (S n) (le_n (S n))); intro H1'. intro H2. left; exists (S n); exists (le_n (S n)); split. assumption. intros j' Hj' H3; unfold Q' in H1'. cut (j' <= n); [ intro H4 | auto with arith ]. unfold Q' in H2. apply H0 with (H := le_S _ _ H4); auto. intro H2. right; intros i H3. unfold Q' in H1'. elim (le_lt_eq_dec _ _ H3); intro H4. cut (i <= n); [ intro H5 | auto with arith ]. unfold Q' in H2. apply H0 with (H := le_S _ _ H5); auto. apply H0 with (H := le_n (S n)); auto. intro i; intros j H2 H3 H4 H5. unfold P' in |- *. exact (H _ _ H2 _ _ H5). intro i; intros j H2 H3 H4 H5. unfold Q' in |- *. exact (H0 _ _ H2 _ _ H5). intros i H2. unfold P', Q' in |- *. apply H1. Qed. End Predicates_to_CProp. Section Predicates_to_Prop. (** Finally, analogous results for [Prop]-valued predicates are presented for completeness's sake. *) Lemma even_ind : forall P : nat -> Prop, P 0 -> (forall n, Nat.Even n -> P n -> P (S (S n))) -> forall n, Nat.Even n -> P n. Proof. now intros P; apply even_induction. Qed. (* NOTE: this statement is not consistent with odd_induction, is it intended? *) Lemma odd_ind : forall P : nat -> Prop, P 1 -> (forall n, P n -> P (S (S n))) -> forall n, Nat.Odd n -> P n. Proof. intros P H1 H n Hn; apply odd_induction; [exact H1 | |]. - now intros k _; apply H. - exact Hn. Qed. Lemma nat_complete_double_ind : forall P : nat -> nat -> Prop, (forall m n, (forall m' n', m' < m -> n' < n -> P m' n') -> P m n) -> forall m n, P m n. Proof. intros P H m. pattern m in |- *; apply lt_wf_ind; auto. Qed. Lemma four_ind : forall P : nat -> Prop, P 0 -> P 1 -> P 2 -> P 3 -> (forall n, P n -> P (S (S (S (S n))))) -> forall n, P n. Proof. intros. apply lt_wf_ind. intro m. case m; auto. clear m; intro m. case m; auto. clear m; intro m. case m; auto. clear m; intro m. case m; auto with arith. Qed. End Predicates_to_Prop. (** ** Integers Similar results for integers. *) (* begin hide *) Tactic Notation "ElimCompare" constr(c) constr(d) := elim_compare c d. (* end hide *) Definition Zlts (x y : Z) := eq (A:=Datatypes.comparison) (x ?= y)%Z Datatypes.Lt. Lemma toCProp_Zlt : forall x y : Z, (x < y)%Z -> Zlts x y. Proof. intros x y H. unfold Zlts in |- *. unfold Z.lt in H. auto. Qed. Lemma CZlt_to : forall x y : Z, Zlts x y -> (x < y)%Z. Proof. intros x y H. unfold Z.lt in |- *. inversion H. auto. Qed. Lemma Zsgn_1 : forall x : Z, {Z.sgn x = 0%Z} + {Z.sgn x = 1%Z} + {Z.sgn x = (-1)%Z}. Proof. intro x. case x. left. left. unfold Z.sgn in |- *. reflexivity. intro p. simpl in |- *. left. right. reflexivity. intro p. right. simpl in |- *. reflexivity. Qed. Lemma Zsgn_2 : forall x : Z, Z.sgn x = 0%Z -> x = 0%Z. Proof. intro x. case x. intro H. reflexivity. intros p H. inversion H. intros p H. inversion H. Qed. Lemma Zsgn_3 : forall x : Z, x <> 0%Z -> Z.sgn x <> 0%Z. Proof. intro x. case x. intro H. elim H. reflexivity. intros p H. simpl in |- *. discriminate. intros p H. simpl in |- *. discriminate. Qed. (** The following have unusual names, in line with the series of lemmata in fast_integers.v. *) Lemma ZL4' : forall y : positive, {h : nat | nat_of_P y = S h}. Proof. simple induction y; [ intros p H; elim H; intros x H1; exists (S x + S x); unfold nat_of_P in |- *; simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H1; rewrite H1; auto with arith | intros p H1; elim H1; intros x H2; exists (x + S x); unfold nat_of_P in |- *; simpl in |- *; rewrite ZL0; rewrite Pmult_nat_r_plus_morphism; unfold nat_of_P in H2; rewrite H2; auto with arith | exists 0; auto with arith ]. Qed. Lemma ZL9 : forall p : positive, Z_of_nat (nat_of_P p) = Zpos p. Proof. intro p. elim (ZL4 p). intros x H0. rewrite H0. unfold Z_of_nat in |- *. apply f_equal with (A := positive) (B := Z) (f := Zpos). cut (P_of_succ_nat (nat_of_P p) = P_of_succ_nat (S x)). intro H1. rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H1. cut (Pos.pred (Pos.succ p) = Pos.pred (P_of_succ_nat (S x))). intro H2. rewrite Pos.pred_succ in H2. simpl in H2. rewrite Pos.pred_succ in H2. auto. apply f_equal with (A := positive) (B := positive) (f := Pos.pred). assumption. apply f_equal with (f := P_of_succ_nat). assumption. Qed. Theorem Zsgn_4 : forall a : Z, a = (Z.sgn a * Z.abs_nat a)%Z. Proof. intro a. case a. simpl in |- *. reflexivity. intro p. unfold Z.sgn in |- *. unfold Z.abs_nat in |- *. rewrite Zmult_1_l. symmetry in |- *. apply ZL9. intro p. unfold Z.sgn in |- *. unfold Z.abs_nat in |- *. rewrite ZL9. constructor. Qed. Theorem Zsgn_5 : forall a b x y : Z, x <> 0%Z -> y <> 0%Z -> (Z.sgn a * x)%Z = (Z.sgn b * y)%Z -> (Z.sgn a * y)%Z = (Z.sgn b * x)%Z. Proof. intros a b x y H H0. case a. case b. simpl in |- *. trivial. intro p. unfold Z.sgn in |- *. intro H1. rewrite Zmult_1_l in H1. simpl in H1. elim H0. auto. intro p. unfold Z.sgn in |- *. intro H1. elim H0. apply Z.opp_inj. simpl in |- *. transitivity (-1 * y)%Z; auto. intro p. unfold Z.sgn at 1 in |- *. unfold Z.sgn at 2 in |- *. intro H1. transitivity y. rewrite Zmult_1_l. reflexivity. transitivity (Z.sgn b * (Z.sgn b * y))%Z. case (Zsgn_1 b). intro H2. case H2. intro H3. elim H. rewrite H3 in H1. change ((1 * x)%Z = 0%Z) in H1. rewrite Zmult_1_l in H1. assumption. intro H3. rewrite H3. rewrite Zmult_1_l. rewrite Zmult_1_l. reflexivity. intro H2. rewrite H2. ring. rewrite Zmult_1_l in H1. rewrite H1. reflexivity. intro p. unfold Z.sgn at 1 in |- *. unfold Z.sgn at 2 in |- *. intro H1. transitivity (Z.sgn b * (-1 * (Z.sgn b * y)))%Z. case (Zsgn_1 b). intro H2. case H2. intro H3. elim H. apply Z.opp_inj. transitivity (-1 * x)%Z. ring. unfold Z.opp in |- *. rewrite H3 in H1. transitivity (0 * y)%Z; auto. intro H3. rewrite H3. ring. intro H2. rewrite H2. ring. rewrite <- H1. ring. Qed. Lemma nat_nat_pos : forall m n : nat, ((m + 1) * (n + 1) > 0)%Z. Proof. intros m n. apply Z.lt_gt. cut (Z_of_nat m + 1 > 0)%Z. intro H. cut (0 < Z_of_nat n + 1)%Z. intro H0. cut ((Z_of_nat m + 1) * 0 < (Z_of_nat m + 1) * (Z_of_nat n + 1))%Z. rewrite Zmult_0_r. auto. apply Zlt_reg_mult_l; auto. change (0 < Z.succ (Z_of_nat n))%Z in |- *. apply Zle_lt_succ. change (Z_of_nat 0 <= Z_of_nat n)%Z in |- *. apply Znat.inj_le. apply Nat.le_0_l. apply Z.lt_gt. change (0 < Z.succ (Z_of_nat m))%Z in |- *. apply Zle_lt_succ. change (Z_of_nat 0 <= Z_of_nat m)%Z in |- *. apply Znat.inj_le. apply Nat.le_0_l. Qed. Theorem S_predn : forall m : nat, m <> 0 -> S (pred m) = m. Proof. intros m H. symmetry in |- *. symmetry; apply Nat.lt_succ_pred with 0. lia. Qed. Lemma absolu_1 : forall x : Z, Z.abs_nat x = 0 -> x = 0%Z. Proof. intros x H. case (dec_eq x 0). auto. intro H0. apply False_ind. ElimCompare x 0%Z. intro H2. apply H0. elim (Zcompare_Eq_iff_eq x 0%nat). intros H3 H4. auto. intro H2. cut (exists h : nat, Z.abs_nat x = S h). intro H3. case H3. rewrite H. exact O_S. change (x < 0)%Z in H2. set (H3 := Z.lt_gt _ _ H2) in *. elim (Zcompare_Gt_spec _ _ H3). intros x0 H5. cut (exists q : positive, x = Zneg q). intro H6. case H6. intros x1 H7. rewrite H7. unfold Z.abs_nat in |- *. generalize x1. exact ZL4. cut (x = (- Zpos x0)%Z). simpl in |- *. intro H6. exists x0. assumption. rewrite <- (Z.opp_involutive x). exact (f_equal Z.opp H5). intro H2. cut (exists h : nat, Z.abs_nat x = S h). intro H3. case H3. rewrite H. exact O_S. elim (Zcompare_Gt_spec _ _ H2). simpl in |- *. rewrite Zplus_0_r. intros x0 H4. rewrite H4. unfold Z.abs_nat in |- *. generalize x0. exact ZL4. Qed. Lemma absolu_2 : forall x : Z, x <> 0%Z -> Z.abs_nat x <> 0. Proof. intros x H. intro H0. apply H. apply absolu_1. assumption. Qed. Lemma Zgt_mult_conv_absorb_l : forall a x y : Z, (a < 0)%Z -> (a * x > a * y)%Z -> (x < y)%Z. Proof. intros a x y H H0. case (dec_eq x y). intro H1. apply False_ind. rewrite H1 in H0. cut ((a * y)%Z = (a * y)%Z). change ((a * y)%Z <> (a * y)%Z) in |- *. apply Zgt_not_eq. assumption. trivial. intro H1. case (not_Zeq x y H1). trivial. intro H2. apply False_ind. cut (a * y > a * x)%Z. apply Zgt_asym with (m := (a * y)%Z) (n := (a * x)%Z). assumption. apply Zlt_conv_mult_l. assumption. assumption. Qed. Lemma Zgt_mult_reg_absorb_l : forall a x y : Z, (a > 0)%Z -> (a * x > a * y)%Z -> (x > y)%Z. Proof. intros a x y H H0. cut (- a < - (0))%Z. rewrite <- (Z.opp_involutive a) in H. rewrite <- (Z.opp_involutive 0) in H. simpl in |- *. intro H1. rewrite <- (Z.opp_involutive x). rewrite <- (Z.opp_involutive y). apply Zlt_opp. apply Zgt_mult_conv_absorb_l with (a := (- a)%Z) (x := (- x)%Z). assumption. rewrite Zopp_mult_distr_l_reverse. rewrite Zopp_mult_distr_l_reverse. apply Zlt_opp. rewrite <- Zopp_mult_distr_r. rewrite <- Zopp_mult_distr_r. apply Z.gt_lt. apply Zlt_opp. apply Z.gt_lt. assumption. lia. Qed. Lemma Zmult_Sm_Sn : forall m n : Z, ((m + 1) * (n + 1))%Z = (m * n + (m + n) + 1)%Z. Proof. intros. ring. Qed. Definition CForall {A: Type} (P: A -> Type): list A -> Type := fold_right (fun x => prod (P x)) True. Definition CForall_prop {A: Type} (P: A -> Prop) (l: list A): (forall x, In x l -> P x) IFF CForall P l. Proof with firstorder. induction l... subst... Qed. Lemma CForall_indexed {A} (P: A -> Type) (l: list A): CForall P l -> forall i (d: A), (i < length l)%nat -> P (nth i l d). Proof. intros X i. revert l X. induction i; destruct l; simpl in *; intuition; exfalso; inversion H. Qed. Lemma CForall_map {A B} (P: B -> Type) (f: A -> B) (l: list A): CForall P (map f l) IFF CForall (fun x => P (f x)) l. Proof. induction l; firstorder. Qed. Lemma CForall_weak {A} (P Q: A -> Type): (forall x, P x -> Q x) -> (forall l, CForall P l -> CForall Q l). Proof. induction l; firstorder. Qed. Fixpoint CNoDup {T: Type} (R: T -> T -> Type) (l: list T): Type := match l with | nil => True | h :: t => prod (CNoDup R t) (CForall (R h) t) end. Lemma CNoDup_weak {A: Type} (Ra Rb: A -> A -> Type) (l: list A): (forall x y, Ra x y -> Rb x y) -> CNoDup Ra l -> CNoDup Rb l. Proof with auto. induction l... firstorder. apply CForall_weak with (Ra a)... Qed. Lemma CNoDup_indexed {T} (R: T -> T -> Type) (Rsym: Csymmetric _ R) (l: list T) (d: T): CNoDup R l -> forall i j, (i < length l)%nat -> (j < length l)%nat -> i <> j -> R (nth i l d) (nth j l d). Proof with intuition. induction l; simpl... exfalso... destruct i. destruct j... apply (CForall_indexed (R a) l)... destruct j... apply Rsym. apply (CForall_indexed (R a) l)... Qed. Lemma CNoDup_map {A B: Type} (R: B -> B -> Type) (f: A -> B): forall l, CNoDup (fun x y => R (f x) (f y)) l IFF CNoDup R (map f l). Proof with auto; intuition. induction l; simpl... split; intro; split. apply IHl, X. apply CForall_map... apply IHl, X. apply CForall_map... Qed. corn-8.20.0/logic/Classic.v000066400000000000000000000104161473720167500154250ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.stdlib_omissions.List. (** * Classical Logic This section introduces the classical logic connectives, "classical or" and "classical exists" through their double negation translation. Induction principles are given that allow you to destruct these formulas as you would their constructive counter parts, so long as the conclusion is double negataion stable. No classical axioms are assumed. *) (** ** Classical or *) Section ClassicOr. Definition orC (P Q:Prop) := ~((~P)/\(~Q)). Lemma orWeaken : forall P Q, ({P}+{Q}) -> orC P Q. Proof. unfold orC. tauto. Qed. Lemma orC_ind : forall (P Q G:Prop), (~~G -> G) -> (P -> G) -> (Q -> G) -> (orC P Q) -> G. Proof. unfold orC. tauto. Qed. Lemma orC_stable : forall P Q, ~~(orC P Q) -> orC P Q. Proof. unfold orC. auto. Qed. End ClassicOr. (** ** Classical Existential *) Section ClassicExists. Variable A : Type. Variable P : A->Prop. Definition existsC : Prop := ~forall x:A, ~P x. Lemma existsWeaken : (exists x:A, P x) -> existsC. Proof. intros [x Hx] H. apply (H x). assumption. Qed. Lemma existsC_ind : forall (Q:Prop), (~~Q -> Q) -> (forall x:A, P x -> Q) -> existsC -> Q. Proof. intros Q HQ H ex. apply HQ. intros Z. apply ex. intros x Hx. apply Z. apply H with x. assumption. Qed. Lemma existsC_stable : ~~existsC -> existsC. Proof. unfold existsC. auto. Qed. End ClassicExists. (** ** Pidgeon Hole Principle Here we show the classical result of the pigenon hole principle using the classical quantifiers. Given a finite list of elements and a relation P(n,x) saying when items from the list are selected, there classically exists an item that is selected a classically infinite number of times. *) Lemma infinitePidgeonHolePrinicple : forall (X:Type) (l:list X) (P:nat -> X -> Prop), (forall n, existsC X (fun x => ~~In x l /\ P n x)) -> existsC X (fun x => In x l /\ forall n, existsC nat (fun m => (n <= m)%nat /\ (P m x))). Proof. intros X l. induction l; intros P HP G. apply (HP O). intros x [Hx _]. auto with *. apply (G a). split; auto with *. intros n Hn. set (P':= fun m => P (m+n)%nat). assert (HP' : forall m : nat, existsC X (fun x => ~~In x l /\ P' m x)). intros m. unfold P'. destruct (HP (m + n)%nat) as [HG | y [Hy0 Hy1]] using existsC_ind. apply existsC_stable; auto. apply existsWeaken. exists y. split; auto. revert Hy0. cut (In y (a :: l) -> In y l);[tauto|]. intros Hy0. destruct Hy0; auto. elim (Hn (m + n)%nat). rewrite H. auto with *. destruct (IHl P' HP') as [HG | x [Hx0 Hx1]] using existsC_ind. tauto. apply (G x). split; auto with *. unfold P' in Hx1. intros n0. destruct (Hx1 n0) as [HG | m [Hm0 Hm1]] using existsC_ind. apply existsC_stable; auto. apply existsWeaken. exists (m + n)%nat. split; auto. auto with *. Qed. (** This weaker version of the pidgen hole principle uses a function to select elements from a list instead of a releation. It may be more convienent to use at times. *) Lemma infinitePidgeonHolePrinicpleB : forall (X:Type) (l:list X) (f:nat -> X), (forall n, In (f n) l) -> existsC X (fun x => In x l /\ forall n, existsC nat (fun m => (n <= m)%nat /\ (f m)=x)). Proof. intros X l f H. apply infinitePidgeonHolePrinicple. intros n. apply existsWeaken. exists (f n). auto with *. Qed. corn-8.20.0/logic/CornBasics.v000066400000000000000000000541221473720167500160740ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing alpha %\ensuremath{\alpha}% #α# *) (** printing beta %\ensuremath{\beta}% #β# *) (** printing delta %\ensuremath{\delta}% #δ# *) (** printing eps %\ensuremath{\varepsilon}% #ε# *) (** printing phi %\ensuremath{\phi}% #φ# *) (** printing eta %\ensuremath{\eta}% #η# *) (** printing omega %\ensuremath{\omega}% #ω# *) (** printing nat %\ensuremath{\mathbb N}% #N# *) (** printing Z %\ensuremath{\mathbb Z}% #Z# *) From Coq Require Export ZArith. From Coq Require Import Lia. Require Export CoRN.stdlib_omissions.List. From Coq Require Import Eqdep_dec. From Coq Require Import Setoid. Tactic Notation "apply" ":" constr(x) := pose proof x as HHH; first [ refine HHH | refine (HHH _) | refine (HHH _ _) | refine (HHH _ _ _) | refine (HHH _ _ _ _) | refine (HHH _ _ _ _ _) | refine (HHH _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _ _ _ _ _ _) | refine (HHH _ _ _ _ _ _ _ _ _ _ _ _ _ _)]; clear HHH. #[global] Instance: @DefaultRelation nat eq | 2 := {}. (** * Basics This is random stuff that should be in the Coq basic library. *) Lemma lt_le_dec : forall n m : nat, {n < m} + {m <= n}. Proof. intros. case (le_lt_dec m n); auto. Qed. Lemma lt_z_two : 0 < 2. Proof. auto. Qed. Lemma le_pred : forall n m : nat, n <= m -> pred n <= pred m. Proof. simple induction n. simpl in |- *. auto with arith. intros n0 Hn0. simple induction m. simpl in |- *. intro H. inversion H. intros n1 H H0. simpl in |- *. auto with arith. Qed. Lemma lt_mult_right : forall x y z : nat, x < y -> 0 < z -> x * z < y * z. Proof. intros x y z H H0. induction z as [| z Hrecz]. elim (Nat.lt_irrefl _ H0). rewrite Nat.mul_comm. replace (y * S z) with (S z * y); auto with arith. Qed. Lemma le_mult_right : forall x y z : nat, x <= y -> x * z <= y * z. Proof. intros x y z H. rewrite Nat.mul_comm. rewrite (Nat.mul_comm y). auto with arith. Qed. Lemma le_irrelevent : forall n m (H1 H2:le n m), H1=H2. Proof. assert (forall n (H1: le n n), H1 = le_n n). intros n H1. change H1 with (eq_rec n (fun a => a <= n) H1 _ (refl_equal n)). generalize (refl_equal n). revert H1. generalize n at 1 3 7. dependent inversion H1. apply K_dec_set. decide equality. reflexivity. intros; exfalso; lia. induction m. dependent inversion H1. symmetry. apply H. dependent inversion H1. symmetry. apply H. intros H3. change H3 with (eq_rec (S m) (le n) (eq_rec n (fun n => n <= S m) H3 _ (refl_equal n)) _ (refl_equal (S m))). generalize (refl_equal n) (refl_equal (S m)). revert H3. generalize n at 1 2 7. generalize (S m) at 1 2 5 6. dependent inversion H3. intros; exfalso; lia. intros e e0. assert (e':=e). assert (e0':=e0). revert e e0 l0. rewrite e', (eq_add_S _ _ e0'). intros e. elim e using K_dec_set. decide equality. intros e0. elim e0 using K_dec_set. decide equality. simpl. intros l0. rewrite (IHm l l0). reflexivity. Qed. Lemma minus3:forall (a b c:nat),(c<=b<=a)-> a+(b-c)=b+(a-c). Proof. intros a b d H. cut ((Z_of_nat a) + ((Z_of_nat b) - (Z_of_nat d)) = (Z_of_nat b) + ((Z_of_nat a) - (Z_of_nat d)))%Z. 2:intuition. intro H1. elim H. intros H2 H3. set (H4:=(inj_minus1 b d H2)). rewrite<- H4 in H1. cut (d <=a). intro H5. 2:intuition. set (H6:=(inj_minus1 a d H5)). rewrite<- H6 in H1. intuition. Qed. Lemma minus4:forall (a b c d:nat), (d<=c<=b)-> (a+b)+(c-d)=(a+c)+(b-d). Proof. intros a b c0 d H. cut (((Z_of_nat a)+(Z_of_nat b))+((Z_of_nat c0)-(Z_of_nat d))= ((Z_of_nat a)+(Z_of_nat c0))+((Z_of_nat b)-(Z_of_nat d)))%Z. intro H0. 2:intuition. elim H. intros H1 H2. set (H3:=(inj_minus1 c0 d H1)). rewrite<- H3 in H0. cut (d<=b). 2:intuition. intro H4. set (H5:=(inj_minus1 b d H4)). rewrite<- H5 in H0. intuition. Qed. (** The power function does not exist in the standard library *) Fixpoint power (m : nat) : nat -> nat := match m with | O => fun _ : nat => 1 | S n => fun x : nat => power n x * x end. (* needed for computational behavior of "Inversion" tactic *) Transparent sym_eq. Transparent f_equal. Notation Pair := (pair (B:=_)) (only parsing). Notation Proj1 := (proj1 (B:=_)) (only parsing). Notation Proj2 := (proj2 (B:=_)) (only parsing ). (* Following only needed in finite, but tha's now obsolete Lemma deMorgan_or_and: (A,B,X:Prop)((A\/B)->X)->(A->X)/\(B->X). Tauto. Qed. Lemma deMorgan_and_or: (A,B,X:Prop)(A->X)/\(B->X)->(A\/B->X). Tauto. Qed. Lemma deMorgan_ex_all: (A:Set)(P:A->Prop)(X:Prop)((Ex P)->X)->(a:A)(P a)->X. Intros. Apply H; Exists a; Assumption. Qed. Lemma deMorgan_all_ex: (A:Set)(P:A->Prop)(X:Prop)((a:A)(P a)->X)->(Ex P)->X. Intros. Elim H0; Assumption. Qed. Implicit Arguments Off. Three lemmas for proving properties about definitions made with case distinction to a sumbool, i.e. [{A} + {B}]. Lemma sumbool_rec_or : (A,B:Prop)(S:Set)(l,r:S)(s:{A}+{B}) (sumbool_rec A B [_:{A}+{B}]S [x:A]l [x:B]r s) = l \/ (sumbool_rec A B [_:{A}+{B}]S [x:A]l [x:B]r s) = r. Intros. Elim s. Intros. Left. Reflexivity. Intros. Right. Reflexivity. Qed. *) Lemma not_r_sumbool_rec : forall (A B : Prop) (S : Set) (l r : S), ~ B -> forall H : {A} + {B}, sumbool_rec (fun _ : {A} + {B} => S) (fun x : A => l) (fun x : B => r) H = l. Proof. intros. elim H0. intros. reflexivity. intro. elim H. assumption. Qed. Lemma not_l_sumbool_rec : forall (A B : Prop) (S : Set) (l r : S), ~ A -> forall H : {A} + {B}, sumbool_rec (fun _ : {A} + {B} => S) (fun x : A => l) (fun x : B => r) H = r. Proof. intros. elim H0. intro. elim H. assumption. intros. reflexivity. Qed. (* begin hide *) Set Implicit Arguments. Unset Strict Implicit. (* end hide *) (** ** Some results about [Z] We consider the injection [inject_nat] from [nat] to [Z] as a coercion. *) (* begin hide *) Coercion Zpos : positive >-> Z. Coercion Z_of_nat : nat >-> Z. (* end hide *) Lemma POS_anti_convert : forall n : nat, S n = Zpos (P_of_succ_nat n) :>Z. Proof. simple induction n. simpl in |- *. reflexivity. intros n0 H. simpl in |- *. reflexivity. Qed. Lemma NEG_anti_convert : forall n : nat, (- S n)%Z = Zneg (P_of_succ_nat n). Proof. simple induction n. simpl in |- *. reflexivity. intros n0 H. simpl in |- *. reflexivity. Qed. Lemma lt_O_positive_to_nat : forall (p : positive) (m : nat), 0 < m -> 0 < Pmult_nat p m. Proof. intro p. elim p. intros p0 H m H0. simpl in |- *. auto with arith. intros p0 H m H0. simpl in |- *. apply H. auto with arith. intros m H. simpl in |- *. assumption. Qed. Lemma anti_convert_pred_convert : forall p : positive, p = P_of_succ_nat (pred (nat_of_P p)). Proof. intro p. pattern p at 1 in |- *. rewrite <- pred_o_P_of_succ_nat_o_nat_of_P_eq_id. cut (exists n : nat, nat_of_P p = S n). intro H. elim H; intros x H0. rewrite H0. elim x. simpl in |- *. reflexivity. intros n H1. simpl in |- *. rewrite Pos.pred_succ. reflexivity. exists (pred (nat_of_P p)). symmetry; apply Nat.lt_succ_pred with 0. unfold nat_of_P in |- *. apply lt_O_positive_to_nat. auto with arith. Qed. Lemma p_is_some_anti_convert : forall p : positive, exists n : nat, p = P_of_succ_nat n. Proof. intro p. exists (pred (nat_of_P p)). apply anti_convert_pred_convert. Qed. Lemma convert_is_POS : forall p : positive, nat_of_P p = Zpos p :>Z. Proof. intro p. elim (p_is_some_anti_convert p). intros x H. rewrite H. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. apply POS_anti_convert. Qed. Lemma min_convert_is_NEG : forall p : positive, (- nat_of_P p)%Z = Zneg p. Proof. intro p. elim (p_is_some_anti_convert p). intros x H. rewrite H. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. apply NEG_anti_convert. Qed. Lemma surj_eq:forall (n m:nat), ((Z_of_nat n)=(Z_of_nat m))%Z -> n=m. Proof. intros n m. intuition. Qed. Lemma surj_le:forall (n m:nat), ((Z_of_nat n)<=(Z_of_nat m))%Z -> n<=m. Proof. intros n m. intuition. Qed. Lemma surj_lt:forall (n m:nat), ((Z_of_nat n)<(Z_of_nat m))%Z -> n(Z_of_nat m))%Z -> n<>m. Proof. intros n m. intuition. Qed. Lemma lt_lt_minus:forall(q p l:nat), q p p+(l-q)nat. Proof. intros z. case z. intro H. exact 0. intros p H. exact (nat_of_P p). intros p H. cut False. intuition. intuition. Defined. Lemma Z_to_nat_correct:forall (z:Z)(H:(0<=z)%Z), z=(Z_of_nat (Z_to_nat H)). Proof. intro z. case z. intro H. unfold Z_to_nat. reflexivity. intros p H. unfold Z_to_nat. cut ( Z_of_nat (nat_of_P p)= Zpos p). intuition. apply inject_nat_convert. intros p H. cut False. intuition. intuition. Qed. Lemma Z_exh : forall z : Z, (exists n : nat, z = n) \/ (exists n : nat, z = (- n)%Z). Proof. intro z. elim z. left. exists 0. auto. intro p. left. exists (nat_of_P p). rewrite convert_is_POS. reflexivity. intro p. right. exists (nat_of_P p). rewrite min_convert_is_NEG. reflexivity. Qed. Lemma nats_Z_ind : forall P : Z -> Prop, (forall n : nat, P n) -> (forall n : nat, P (- n)%Z) -> forall z : Z, P z. Proof. intros P H H0 z. elim (Z_exh z); intro H1. elim H1; intros x H2. rewrite H2. apply H. elim H1; intros x H2. rewrite H2. apply H0. Qed. Lemma pred_succ_Z_ind : forall P : Z -> Prop, P 0%Z -> (forall n : Z, P n -> P (n + 1)%Z) -> (forall n : Z, P n -> P (n - 1)%Z) -> forall z : Z, P z. Proof. intros P H H0 H1 z. apply nats_Z_ind. intro n. elim n. exact H. intros n0 H2. replace (S n0:Z) with (n0 + 1)%Z. apply H0. assumption. rewrite Znat.inj_S. reflexivity. intro n. elim n. exact H. intros n0 H2. replace (- S n0)%Z with (- n0 - 1)%Z. apply H1. assumption. rewrite Znat.inj_S. unfold Z.succ in |- *. rewrite Zopp_plus_distr. reflexivity. Qed. Lemma Zmult_minus_distr_r : forall n m p : Z, (p * (n - m))%Z = (p * n - p * m)%Z. Proof. intros n m p. rewrite Zmult_comm. rewrite Zmult_minus_distr_r. rewrite Zmult_comm. rewrite (Zmult_comm m p). reflexivity. Qed. Lemma Zodd_Zeven_min1 : forall x : Z, Zeven.Zodd x -> Zeven.Zeven (x - 1). Proof. intro x. elim x. simpl in |- *. auto. simple induction p. simpl in |- *. auto. intros p0 H H0. simpl in H0. tauto. simpl in |- *; auto. simple induction p. simpl in |- *; auto. simpl in |- *; auto. auto. Qed. (* begin hide *) Set Implicit Arguments. Unset Strict Implicit. (* end hide *) Definition caseZ_diff (A : Type) (z : Z) (f : nat -> nat -> A) := match z with | Z0 => f 0 0 | Zpos m => f (nat_of_P m) 0 | Zneg m => f 0 (nat_of_P m) end. (* begin hide *) Set Strict Implicit. Unset Implicit Arguments. (* end hide *) Lemma caseZ_diff_O : forall (A : Type) (f : nat -> nat -> A), caseZ_diff 0 f = f 0 0. Proof. auto. Qed. Lemma caseZ_diff_Pos : forall (A : Type) (f : nat -> nat -> A) (n : nat), caseZ_diff n f = f n 0. Proof. intros A f n. elim n. reflexivity. intros n0 H. simpl in |- *. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. reflexivity. Qed. Lemma caseZ_diff_Neg : forall (A : Type) (f : nat -> nat -> A) (n : nat), caseZ_diff (- n) f = f 0 n. Proof. intros A f n. elim n. reflexivity. intros n0 H. simpl in |- *. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. reflexivity. Qed. Lemma proper_caseZ_diff : forall (A : Type) (f : nat -> nat -> A), (forall m n p q : nat, m + q = n + p -> f m n = f p q) -> forall m n : nat, caseZ_diff (m - n) f = f m n. Proof. intros A F H m n. pattern m, n in |- *. apply nat_double_ind. intro n0. replace (0%nat - n0)%Z with (- n0)%Z. rewrite caseZ_diff_Neg. reflexivity. simpl in |- *. reflexivity. intro n0. replace (S n0 - 0%nat)%Z with (Z_of_nat (S n0)). rewrite caseZ_diff_Pos. reflexivity. simpl in |- *. reflexivity. intros n0 m0 H0. rewrite (H (S n0) (S m0) n0 m0). rewrite <- H0. replace (S n0 - S m0)%Z with (n0 - m0)%Z. reflexivity. repeat rewrite Znat.inj_S. auto with zarith. auto with zarith. Qed. Lemma diff_Z_ind : forall P : Z -> Prop, (forall m n : nat, P (m - n)%Z) -> forall z : Z, P z. Proof. intros P H z. apply nats_Z_ind. intro n. replace (Z_of_nat n) with (n - 0%nat)%Z. apply H. simpl in |- *. auto with zarith. intro n. replace (- n)%Z with (0%nat - n)%Z. apply H. simpl in |- *. reflexivity. Qed. Lemma Zlt_reg_mult_l : forall x y z : Z, (x > 0)%Z -> (y < z)%Z -> (x * y < x * z)%Z. Proof. intros x y z H H0. case (Zcompare_Gt_spec x 0). unfold Z.gt in H. assumption. intros x0 H1. cut (x = Zpos x0). intro H2. rewrite H2. unfold Z.lt in H0. unfold Z.lt in |- *. cut ((Zpos x0 * y ?= Zpos x0 * z)%Z = (y ?= z)%Z). intro H3. exact (trans_eq H3 H0). apply Zcompare_mult_compat. cut (x = (x + - (0))%Z). intro H2. exact (trans_eq H2 H1). simpl in |- *. apply (sym_eq (A:=Z)). exact (Zplus_0_r x). Qed. Lemma Zlt_opp : forall x y : Z, (x < y)%Z -> (- x > - y)%Z. Proof. intros x y H. red in |- *. apply sym_eq. cut (Datatypes.Gt = (y ?= x)%Z). intro H0. cut ((y ?= x)%Z = (- x ?= - y)%Z). intro H1. exact (trans_eq H0 H1). exact (Zcompare_opp y x). apply sym_eq. exact (Z.lt_gt x y H). Qed. Lemma Zlt_conv_mult_l : forall x y z : Z, (x < 0)%Z -> (y < z)%Z -> (x * y > x * z)%Z. Proof. intros x y z H H0. cut (- x > 0)%Z. intro H1. cut (- x * y < - x * z)%Z. intro H2. cut (- (- x * y) > - (- x * z))%Z. intro H3. cut (- - (x * y) > - - (x * z))%Z. intro H4. cut ((- - (x * y))%Z = (x * y)%Z). intro H5. rewrite H5 in H4. cut ((- - (x * z))%Z = (x * z)%Z). intro H6. rewrite H6 in H4. assumption. exact (Z.opp_involutive (x * z)). exact (Z.opp_involutive (x * y)). cut ((- (- x * y))%Z = (- - (x * y))%Z). intro H4. rewrite H4 in H3. cut ((- (- x * z))%Z = (- - (x * z))%Z). intro H5. rewrite H5 in H3. assumption. cut ((- x * z)%Z = (- (x * z))%Z). intro H5. exact (f_equal Z.opp H5). exact (Zopp_mult_distr_l_reverse x z). cut ((- x * y)%Z = (- (x * y))%Z). intro H4. exact (f_equal Z.opp H4). exact (Zopp_mult_distr_l_reverse x y). exact (Zlt_opp (- x * y) (- x * z) H2). exact (Zlt_reg_mult_l (- x) y z H1 H0). exact (Zlt_opp x 0 H). Qed. Lemma Zgt_not_eq : forall x y : Z, (x > y)%Z -> x <> y. Proof. intros x y H. cut (y < x)%Z. intro H0. cut (y <> x). intro H1. red in |- *. intro H2. cut (y = x). intro H3. apply H1. assumption. exact (sym_eq H2). exact (Zorder.Zlt_not_eq y x H0). exact (Z.gt_lt x y H). Qed. Lemma Zmult_absorb : forall x y z : Z, x <> 0%Z -> (x * y)%Z = (x * z)%Z -> y = z. Proof. intros x y z H H0. case (dec_eq y z). intro H1. assumption. intro H1. case (not_Zeq y z). assumption. intro H2. case (not_Zeq x 0). assumption. intro H3. exfalso. cut (x * y > x * z)%Z. intro H4. cut ((x * y)%Z <> (x * z)%Z). intro H5. apply H5. assumption. exact (Zgt_not_eq (x * y) (x * z) H4). exact (Zlt_conv_mult_l x y z H3 H2). intro H3. exfalso. cut (x * y < x * z)%Z. intro H4. cut ((x * y)%Z <> (x * z)%Z). intro H5. apply H5. assumption. exact (Zorder.Zlt_not_eq (x * y) (x * z) H4). apply Zlt_reg_mult_l. exact (Z.lt_gt 0 x H3). assumption. intro H2. apply False_ind. cut (x * z < x * y)%Z. intro H3. cut ((x * z)%Z <> (x * y)%Z). intro H4. apply H4. apply (sym_eq (A:=Z)). assumption. exact (Zorder.Zlt_not_eq (x * z) (x * y) H3). apply False_ind. case (not_Zeq x 0). assumption. intro H3. cut (x * z > x * y)%Z. intro H4. cut ((x * z)%Z <> (x * y)%Z). intro H5. apply H5. apply (sym_eq (A:=Z)). assumption. exact (Zgt_not_eq (x * z) (x * y) H4). exact (Zlt_conv_mult_l x z y H3 H2). intro H3. cut (x * z < x * y)%Z. intro H4. cut ((x * z)%Z <> (x * y)%Z). intro H5. apply H5. apply (sym_eq (A:=Z)). assumption. exact (Zorder.Zlt_not_eq (x * z) (x * y) H4). apply Zlt_reg_mult_l. exact (Z.lt_gt 0 x H3). auto. Qed. Section Well_foundedT. Variable A : Type. Variable R : A -> A -> Prop. (** The accessibility predicate is defined to be non-informative *) Inductive Acc : A -> Prop := Acc_intro : forall x : A, (forall y : A, R y x -> Acc y) -> Acc x. End Well_foundedT. Section AccT. Variable A : Type. Definition well_founded (P : A -> A -> Prop) := forall a : A, Acc _ P a. End AccT. Arguments Acc [A]. Section IndT. Variable A : Type. Variable R : A -> A -> Prop. Section AccIter. Variable P : A -> Type. Variable F : forall x : A, (forall y : A, R y x -> P y) -> P x. Lemma Acc_inv : forall x : A, Acc R x -> forall y : A, R y x -> Acc R y. Proof. destruct 1; trivial. Defined. Fixpoint Acc_iter (x : A) (a : Acc R x) {struct a} : P x := F x (fun (y : A) (h : R y x) => Acc_iter y (Acc_inv x a y h)). End AccIter. Hypothesis Rwf : well_founded A R. Theorem well_founded_induction_type : forall P : A -> Type, (forall x : A, (forall y : A, R y x -> P y) -> P x) -> forall a : A, P a. Proof. Proof. intros; apply (Acc_iter P); auto. Defined. End IndT. Section InductionT. Variable A : Type. Variable f : A -> nat. Definition ltof (a b : A) := f a < f b. Theorem well_founded_ltof : well_founded A ltof. Proof. red in |- *. cut (forall (n : nat) (a : A), f a < n -> Acc ltof a). intros H a; apply (H (S (f a))); auto with arith. induction n. intros; absurd (f a < 0); auto with arith. intros a ltSma. apply Acc_intro. unfold ltof in |- *; intros b ltfafb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. Qed. Theorem induction_ltof2T : forall P : A -> Type, (forall x : A, (forall y : A, ltof y x -> P y) -> P x) -> forall a : A, P a. Proof. exact (well_founded_induction_type A ltof well_founded_ltof). Defined. End InductionT. Section InductionTT. Lemma lt_wf_rect : forall (p : nat) (P : nat -> Type), (forall n : nat, (forall m : nat, m < n -> P m) -> P n) -> P p. Proof. exact (fun (p : nat) (P : nat -> Type) (F : forall n : nat, (forall m : nat, m < n -> P m) -> P n) => induction_ltof2T nat (fun m : nat => m) P F p). Defined. End InductionTT. (** This new version of postive recursion gives access to both n and n+1 for the 2n+1 case, while still maintaining efficency. *) Fixpoint positive_rect2_helper (P : positive -> Type) (c1 : forall p : positive, P (Pos.succ p) -> P p -> P (xI p)) (c2 : forall p : positive, P p -> P (xO p)) (c3 : P 1%positive) (b : bool) (p : positive) {struct p} : P (if b then Pos.succ p else p) := match p with | xH => match b with true => c2 _ c3 | false => c3 end | xO p' => match b with | true => c1 _ (positive_rect2_helper P c1 c2 c3 true _) (positive_rect2_helper P c1 c2 c3 false _) | false => c2 _ (positive_rect2_helper P c1 c2 c3 false _) end | xI p' => match b with | true => c2 _ (positive_rect2_helper P c1 c2 c3 true _) | false =>c1 _ (positive_rect2_helper P c1 c2 c3 true _) (positive_rect2_helper P c1 c2 c3 false _) end end. Definition positive_rect2 (P : positive -> Type) (c1 : forall p : positive, P (Pos.succ p) -> P p -> P (xI p)) (c2 : forall p : positive, P p -> P (xO p)) (c3 : P 1%positive) (p : positive) : P p := positive_rect2_helper P c1 c2 c3 false p. Lemma positive_rect2_helper_bool : forall P c1 c2 c3 p, positive_rect2_helper P c1 c2 c3 true p = positive_rect2_helper P c1 c2 c3 false (Pos.succ p). Proof. intros P c1 c2 c3. induction p; try reflexivity. simpl. rewrite IHp. reflexivity. Qed. Lemma positive_rect2_red1 : forall P c1 c2 c3 p, positive_rect2 P c1 c2 c3 (xI p) = c1 p (positive_rect2 P c1 c2 c3 (Pos.succ p)) (positive_rect2 P c1 c2 c3 p). Proof. intros P c1 c2 c3 p. unfold positive_rect2. simpl. rewrite positive_rect2_helper_bool. reflexivity. Qed. Lemma positive_rect2_red2 : forall P c1 c2 c3 p, positive_rect2 P c1 c2 c3 (xO p) = c2 p (positive_rect2 P c1 c2 c3 p). Proof. reflexivity. Qed. Lemma positive_rect2_red3 : forall P c1 c2 c3, positive_rect2 P c1 c2 c3 (xH) = c3. Proof. reflexivity. Qed. (** Iteration for natural numbers. *) Fixpoint iterateN A (f:A -> A) (z:A) (n:nat) : list A := match n with O => nil |S m => z :: (iterateN A f (f z) m) end. (* begin hide *) Arguments iterateN [A]. (* end hide *) Lemma iterateN_f : forall A f (z:A) n, iterateN f (f z) n = map f (iterateN f z n). Proof. intros A f z n. revert f z. induction n. reflexivity. simpl. intros f z. rewrite <- IHn. reflexivity. Qed. (* Some purely logical reasoning aids: *) Lemma iff_under_forall {X} (P Q: X -> Prop): (forall x, P x <-> Q x) -> ((forall x, P x) <-> (forall x, Q x)). Proof. firstorder. Qed. Lemma conjunction_under_forall {X} (P Q: X -> Prop): ((forall x, P x) /\ (forall x, Q x)) <-> (forall x, P x /\ Q x). Proof. firstorder. Qed. corn-8.20.0/logic/PropDecid.v000066400000000000000000000017631473720167500157220ustar00rootroot00000000000000(* Copyright 2008-2008 * Cezary Kaliszyk * Russell O'Connor * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** ** Decidability of connectives Here we show the decidability of logical connectives. *) Lemma imp_dec : (forall A B, ({A} + {~A}) -> ({B} + {~B}) -> ({A -> B} + {~(A -> B)})). Proof. tauto. Qed. (* TODO: other connectives *) corn-8.20.0/logic/Stability.v000066400000000000000000000077521473720167500160210ustar00rootroot00000000000000 Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Import Coq.Classes.Morphisms. (* Doubly-negated types as a monad: *) Definition DN (T: Type): Prop := (T -> False) -> False. #[global] Hint Unfold DN. #[global] Instance DN_Proper: Proper (iff ==> iff) DN. Proof. firstorder. Qed. Definition DN_return {T: Type}: T -> DN T := fun x f => f x. #[global] Hint Resolve @DN_return. Definition DN_bind {A: Type}: DN A -> forall B, (A -> DN B) -> DN B := fun X Y Z P => X (fun a => Z a P). Definition ext_eq: Prop := forall (A B: Type) (f g: A -> B), (forall x, f x = g x) -> f = g. Lemma DN_runit: ext_eq -> forall A (x: DN A), DN_bind x _ DN_return = x. Proof. intros. cut (forall y y', y = y' -> x y = x y'). firstorder. congruence. Qed. Lemma DN_lunit: ext_eq -> forall A B (a: A) (f: A -> DN B), DN_bind (DN_return a) _ f = f a. Proof. firstorder. Qed. Lemma DN_assoc A B C (a: DN A) (f: A -> DN B) (g: B -> DN C): DN_bind (DN_bind a _ f) _ g = DN_bind a _ (fun x => DN_bind (f x) _ g). Proof. reflexivity. Qed. Lemma DN_fmap {A: Type}: DN A -> forall B, (A -> B) -> DN B. Proof. firstorder. Qed. Lemma DN_liftM2 {A B C: Type} (f: A -> B -> C): DN A -> DN B -> DN C. Proof. firstorder. Qed. (* todo: this is a specialization for DN. make a normal monadic version *) Lemma DN_exists {T: Type} {P: T -> Prop} {x: T}: DN (P x) -> DN (ex P). Proof. firstorder. Qed. Class Stable P := from_DN: (DN P -> P). (* Using an Inductive gets us universe polymorphism, which the following simpler alternative does not provide: *) (* Definition Stable P := DN P -> P. *) Lemma DN_apply {T: Type}: DN T -> forall P, Stable P -> (T -> P) -> P. Proof. firstorder. Qed. Lemma DN_free P: Stable P -> DN P -> P. Proof. firstorder. Qed. Lemma Stable_neg (P: Prop): Stable (~P). Proof. firstorder. Qed. #[global] Instance Stable_False: Stable False. Proof. firstorder. Qed. #[global] Instance Stable_True: Stable True. Proof. firstorder. Qed. #[global] Hint Immediate Stable_False Stable_True. #[global] Instance stable_conjunction (A B: Prop): Stable A -> Stable B -> Stable (A /\ B). Proof. firstorder. Qed. #[global] Hint Resolve stable_conjunction. #[global] Instance forall_stable (T: Type) (P: T -> Type): (forall x, Stable (P x)) -> Stable (forall x, P x). Proof. firstorder. Qed. #[global] Instance stable_iff (P Q: Prop): Stable P -> Stable Q -> Stable (P <-> Q). Proof. firstorder. Qed. #[global] Hint Resolve forall_stable. (*Require Import util.*) Class decision (P: Prop): Set := decide: { P } + { ~ P }. Lemma decision_stable P: decision P -> Stable P. Proof. firstorder. Qed. Require Import CoRN.reals.fast.CRGroupOps CoRN.logic.Classic. Lemma Qle_dec x y: decision (Qle x y). intros. destruct (Qlt_le_dec y x); [right | left]; [apply Qlt_not_le |]; assumption. Defined. (* Todo: Don't I have this elsewhere? *) (* Everything is decidable in DN: *) Lemma DN_decision (P: Prop): DN (decision P). Proof. firstorder. Qed. Lemma DN_decisionT (P: Type): DN (P + (P->False)). Proof. firstorder. Qed. #[global] Instance CRnonNeg_stable x: Stable (CRnonNeg x). Proof with auto. unfold CRnonNeg. intros. intro. intros. destruct (Qle_dec (-proj1_sig e) (approximate x (Qpos2QposInf e))). exact q. exfalso... Qed. #[global] Hint Resolve CRnonNeg_stable. #[global] Instance CReq_stable (x y: msp_car CR): Stable (x == y)%CR. Proof. simpl. unfold regFunEq, ball. simpl. apply forall_stable. intros. apply forall_stable. intros. unfold Qmetric.Qball, Qmetric.QAbsSmall. simpl. apply stable_conjunction. apply decision_stable. apply Qle_dec. apply decision_stable. apply Qle_dec. Qed. Local Open Scope CR_scope. Lemma DN_or P Q: (((P -> False) /\ (Q -> False)) -> False) -> DN (P + Q). Proof. firstorder. Qed. Definition not_forall_exists_not_DN (T: Type) (P: T -> Prop) (Pd: forall x, P x \/ ~ P x): (~ forall x, P x) -> DN (exists x, ~ P x). Proof. firstorder. Qed. corn-8.20.0/meta.yml000066400000000000000000000107461473720167500142370ustar00rootroot00000000000000--- fullname: C-CoRN shortname: corn organization: coq-community community: true action: true synopsis: The Coq Constructive Repository at Nijmegen. description: | CoRN includes the following parts: - Algebraic Hierarchy An axiomatic formalization of the most common algebraic structures, including setoids, monoids, groups, rings, fields, ordered fields, rings of polynomials, real and complex numbers - Model of the Real Numbers Construction of a concrete real number structure satisfying the previously defined axioms - Fundamental Theorem of Algebra A proof that every non-constant polynomial on the complex plane has at least one root - Real Calculus A collection of elementary results on real analysis, including continuity, differentiability, integration, Taylor's theorem and the Fundamental Theorem of Calculus - Exact Real Computation Fast verified computation inside Coq. This includes: real numbers, functions, integrals, graphs of functions, differential equations. authors: - name: Evgeny Makarov - name: Robbert Krebbers - name: Eelis van der Weegen - name: Bas Spitters - name: Jelle Herold - name: Russell O'Connor - name: Cezary Kaliszyk - name: Dan Synek - name: Luís Cruz-Filipe - name: Milad Niqui - name: Iris Loeb - name: Herman Geuvers - name: Randy Pollack - name: Freek Wiedijk - name: Jan Zwanenburg - name: Dimitri Hendriks - name: Henk Barendregt - name: Mariusz Giero - name: Rik van Ginneken - name: Dimitri Hendriks - name: Sébastien Hinderer - name: Bart Kirkels - name: Pierre Letouzey - name: Lionel Mamane - name: Nickolay Shmyrev - name: Vincent Semeria maintainers: - name: Bas Spitters nickname: spitters - name: Vincent Semeria nickname: vincentse - name: Xia Li-yao nickname: Lysxia opam-file-maintainer: b.a.w.spitters@gmail.com license: fullname: GNU General Public License v2 identifier: GPL-2.0 supported_coq_versions: text: Coq 8.18 or greater opam: '{(>= "8.18" & < "8.20~") | (= "dev")}' tested_coq_opam_versions: - version: dev - version: "8.19" - version: "8.18" dependencies: - opam: name: coq-math-classes version: '{(>= "8.8.1") | (= "dev")}' nix: math-classes description: | [Math-Classes](https://github.com/coq-community/math-classes) 8.8.1 or greater, which is a library of abstract interfaces for mathematical structures that is heavily based on Coq's type classes. - opam: name: coq-bignums nix: bignums description: "[Bignums](https://github/com/coq/bignums)" namespace: CoRN keywords: - name: constructive mathematics - name: algebra - name: real calculus - name: real numbers - name: Fundamental Theorem of Algebra categories: - name: Mathematics/Algebra - name: Mathematics/Real Calculus and Topology - name: Mathematics/Exact Real computation publications: - pub_title: See this page for the list of publications pub_url: http://corn.cs.ru.nl/pub.html build: | ## Building and installation instructions The easiest way to install the latest released version of C-CoRN is via [OPAM](https://opam.ocaml.org/doc/Install.html): ```shell opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-corn ``` To instead build and install manually, you have to start with the `bignums` dependency: ``` shell git clone https://github.com/coq/bignums cd bignums make # or make -j make install ``` The last `make install` is necessary, it copies `bignums` to a common folder, which is usually `coq/user-contrib`. Afterwards the similar commands for `math-classes` will find `bignums` there. Finally build `corn` itself: ``` shell git clone https://github.com/coq-community/corn cd corn ./configure.sh make # or make -j make install ``` ### Building C-CoRN with SCons C-CoRN supports building with [SCons](http://www.scons.org/). SCons is a modern Python-based Make-replacement. To build C-CoRN with SCons run `scons` to build the whole library, or `scons some/module.vo` to just build `some/module.vo` (and its dependencies). In addition to common Make options like `-j N` and `-k`, SCons supports some useful options of its own, such as `--debug=time`, which displays the time spent executing individual build commands. `scons -c` replaces Make clean For more information, see the [SCons documentation](http://www.scons.org/). ### Building documentation To build CoqDoc documentation, say `scons coqdoc`. --- corn-8.20.0/metric2/000077500000000000000000000000001473720167500141235ustar00rootroot00000000000000corn-8.20.0/metric2/Classification.v000066400000000000000000000037631473720167500172560ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.Metric. Local Open Scope Q_scope. (** ** Classification of metric spaces A metric space is located if you can choose between ball d x y and ~ball e x y for e < d. Every located metric is a stable metric. This translates the located property of the real numbers e < d -> (e < d(x,y) \/ d(x,y) < d). *) Definition locatedMetric (ms:MetricSpace) := forall (e d:Q) (x y:ms), e < d -> {ball d x y}+{~ball e x y}. (** At the top level a metric space is decidable if its ball relation is decidable. Every decidable metric is a located metric. *) Definition decidableMetric (ms:MetricSpace) := forall e (x y:ms), {ball e x y}+{~ball e x y}. Lemma decidable_located : forall ms, decidableMetric ms -> locatedMetric ms. Proof. intros ms H e d x y Hed. destruct (H e x y). left. abstract ( apply ball_weak_le with e; try assumption; apply Qlt_le_weak; assumption). right; assumption. Defined. corn-8.20.0/metric2/Classified.v000066400000000000000000001171571473720167500163740ustar00rootroot00000000000000 (** MathClasses-style operational & structural classes for a Russell-style metric space (i.e. MetricSpace). We don't put this in MathClasses because for reasons of interoperability with the existing MetricSpace it is still bound to stdlib Q rather than an abstract Rationals implementation. *) Require Import CoRN.algebra.RSetoid. Require Import Arith List CoRN.model.totalorder.QposMinMax CSetoids Qmetric Qring Qinf QnnInf QnonNeg ProductMetric QposInf Qposclasses (* defines Equiv on Qpos *) UniformContinuity MathClasses.implementations.stdlib_rationals stdlib_omissions.Pair stdlib_omissions.Q PointFree MathClasses.interfaces.abstract_algebra MathClasses.theory.setoids MathClasses.theory.products. Import Qinf.notations QnonNeg.coercions. Require Vector. Section MetricSpaceClass. Variable X: Type. Class MetricSpaceBall: Type := mspc_ball: Qinf → relation X. Hint Unfold relation : type_classes. (** We used to have mspc_ball take a Qpos instead of a Qinf. Because it is sometimes convenient to speak in terms of a generalized notion of balls that can have infinite or negative radius, we used a separate derived definition for that (which return False for negative radii, True for an infinite radius, and reduced to setoid equality for a radius equal to 0). This kinda worked, but had a big downside. The derived generalized ball relation (let's call it "gball") was defined using case distinctions on the finiteness and sign of the radius. These case distinctions routinely got in the way, because it meant that e.g. gball for the product metric space did not reduce to the composition of gballs derived for the constituent metrics spaces. Consequently, both the basic ball and the generalized ball relation were used side-by-side, and converting between the two was a constant annoyance. Because of this, we now use the generalized type for the "basic" ball. Now the product metric space's (generalized) ball relation is defined directly in terms of the constituent metric spaces' balls, and so reduces nicely. It also means that there is now a _single_ ball relation that is used everywhere. Of course, when defining the ball relation for a concrete metric space, the generalization to a Qinf parameter implies "more work". Fortunately, the additional work can be factored out into a smart constructor (defined later in this module) that takes the version with a Qpos parameter and extends it to Qinf in the way described above. All the ball's properties can be lifted along with this extension. *) Context `{!MetricSpaceBall}. Class MetricSpaceClass: Prop := { mspc_ball_proper:: forall (e1 e2 : Qinf) (x y : X), equiv e1 e2 -> (mspc_ball e1 x y <-> mspc_ball e2 x y) ; mspc_ball_inf: ∀ x y, mspc_ball Qinf.infinite x y ; mspc_ball_negative: ∀ (e: Q), (e < 0)%Q → ∀ x y, ~ mspc_ball e x y ; mspc_refl:: ∀ e, (0 <= e)%Qinf → Reflexive (mspc_ball e) ; mspc_sym:: ∀ e, Symmetric (mspc_ball e) ; mspc_triangle: ∀ (e1 e2: Qinf) (a b c: X), mspc_ball e1 a b → mspc_ball e2 b c → mspc_ball (e1 + e2) a c ; mspc_closed: ∀ (e: Qinf) (a b: X), (∀ d: Qpos, mspc_ball (e + d) a b) → mspc_ball e a b ; mspc_stable: ∀ (e: Q) (a b: X), (~~mspc_ball e a b) → mspc_ball e a b }. Context `{MetricSpaceClass}. Local Instance mspc_equiv : Equiv X := fun x y => mspc_ball 0 x y. (** Two simple derived properties: *) Lemma mspc_eq a b: (∀ e: Qpos, mspc_ball e a b) → a = b. Proof with auto. intros. apply mspc_closed. intros. rewrite (mspc_ball_proper (0+d)%Qinf d). apply H1. change (0 + d == d). ring. Qed. Lemma mspc_ball_weak_le (q q': Qinf): (q <= q')%Qinf → ∀ x y: X, mspc_ball q x y → mspc_ball q' x y. Proof with auto. destruct q, q'; simpl; intros... assert (q0 == q + (q0 - q))%Q as E by ring. rewrite (mspc_ball_proper q0 (q+(q0-q)) x y E). change (mspc_ball (Qinf.finite q + Qinf.finite (q0 - q)%Q) x y). apply mspc_triangle with y... apply mspc_refl. simpl. apply QArith_base.Qplus_le_r with q. ring_simplify... apply mspc_ball_inf. intuition. Qed. Lemma mspc_ball_e_wd : ∀ (e d : Q) (x y : X), e == d → mspc_ball e x y ↔ mspc_ball d x y. Proof. intros. apply mspc_ball_proper, H1. Qed. Lemma mspc_ball_wd : forall (e d : Qinf) x1 x2 y1 y2, e = d -> x1 = x2 -> y1 = y2 -> (mspc_ball e x1 y1 <-> mspc_ball d x2 y2). Proof. unfold equiv, mspc_equiv. split. - intros. destruct d as [d|]. 2: apply mspc_ball_inf. destruct e as [e|]. 2: inversion H1. simpl in H1. assert (0+(e+0) == d). { rewrite Qplus_0_r, Qplus_0_l. exact H1. } apply (mspc_ball_e_wd _ _ x2 y2 H5). clear H5 H1 d. pose proof (mspc_triangle 0 (e+0) x2 x1 y2). apply H1. clear H1. apply mspc_sym, H2. pose proof (mspc_triangle e 0 x1 y1 y2). apply H5. exact H4. exact H3. - intros. destruct e as [e|]. 2: apply mspc_ball_inf. destruct d as [d|]. 2: inversion H1. simpl in H1. assert (0+(d+0) == e). { rewrite Qplus_0_r, Qplus_0_l. rewrite H1. reflexivity. } apply (mspc_ball_e_wd _ _ x1 y1 H5). clear H5 H1 e. pose proof (mspc_triangle 0 (d+0) x1 x2 y1). apply H1. exact H2. clear H1. pose proof (mspc_triangle d 0 x2 y2 y1). apply H1. exact H4. apply mspc_sym, H3. Qed. (** Instances can be bundled to yield MetricSpaces: *) Program Definition bundle_MetricSpace: MetricSpace := Build_MetricSpace mspc_ball_e_wd _. Next Obligation. Proof with auto. constructor. - intros e epos. apply mspc_refl, epos. - intros. apply mspc_sym. - intros. apply (mspc_triangle e1 e2 a b c)... - intros. apply mspc_closed... intros. apply H1. apply Qpos_ispos. - intros. apply Qnot_lt_le. intro abs. destruct H0. exact (mspc_ball_negative0 e abs a b H1). - intros. apply mspc_stable, H1. Qed. (** .. which obviously have the same carrier: *) Goal X ≡ bundle_MetricSpace. Proof. reflexivity. Qed. End MetricSpaceClass. #[global] Instance: Params (@mspc_ball) 2 := {}. #[global] Hint Resolve Qlt_le_weak Qplus_lt_le_0_compat. (* Todo: Move. *) (** We now define the smart constructor that builds a MetricSpace from a ball relation with positive radius. *) Section genball. Context `{Setoid X} (R: Qpos → relation X) `{!Proper (QposEq ==> (=)) R} `{∀ e, Reflexive (R e)} `{∀ e, Symmetric (R e)} (Rtriangle: ∀ (e1 e2: Qpos) (a b c: X), R e1 a b → R e2 b c → R (e1 + e2)%Qpos a c) (Req: ∀ (a b: X), (∀ d: Qpos, R d a b) → a = b) (Rclosed: ∀ (e: Qpos) (a b: X), (∀ d: Qpos, R (e + d)%Qpos a b) → R e a b) (Rstable: ∀ (e: Qpos) (a b: X), (~~R e a b) → R e a b). Definition genball: MetricSpaceBall X := λ (oe: Qinf), match oe with | Qinf.infinite => λ _ _, True | Qinf.finite e => match Qdec_sign e with | inl (inl _) => λ _ _ , False | inl (inr p) => R (exist (Qlt 0) e p) | inr _ => equiv end end. Definition ball_genball (q: Qpos) (a b: X): genball q a b ↔ R q a b. Proof. unfold genball; simpl. destruct Qdec_sign as [[|]|U]. exfalso. destruct q. apply (Qlt_is_antisymmetric_unfolded 0 x); assumption. apply Proper0; reflexivity. exfalso. destruct q. simpl in U. revert q. rewrite U. apply Qlt_irrefl. Qed. Lemma genball_alt (q: Q) (x y: X): genball q x y <-> match Qdec_sign q with | inl (inl _) => False | inl (inr p) => genball q x y | inr _ => x=y end. Proof. unfold genball. simpl. split; destruct Qdec_sign as [[|]|]; auto. Qed. Instance genball_Proper: Proper ((=) ==> (=) ==> (=) ==> iff) genball. Proof with auto; intuition. unfold genball. intros u e' E. destruct u, e'. change (q = q0) in E. destruct Qdec_sign as [[|]|]; destruct Qdec_sign as [[|]|]. repeat intro... exfalso. revert q1. apply Qlt_is_antisymmetric_unfolded. rewrite E... exfalso. revert q1. rewrite E. rewrite q2. apply Qlt_irrefl. exfalso. revert q1. rewrite E. apply Qlt_is_antisymmetric_unfolded... apply Proper0... exfalso. revert q1. rewrite E, q2. apply Qlt_irrefl. exfalso. revert q2. rewrite <- E, q1. apply Qlt_irrefl. exfalso. revert q2. rewrite <- E, q1. apply Qlt_irrefl. intros ?? A ?? B. rewrite A, B... repeat intro... intuition. repeat intro. reflexivity. Qed. Instance: ∀ e, Proper ((=) ==> (=) ==> iff) (genball e). Proof. intros; now apply genball_Proper. Qed. Lemma genball_negative (q: Q): (q < 0)%Q → ∀ x y: X, ~ genball q x y. Proof with auto. unfold genball. intros E ??. destruct Qdec_sign as [[|]|U]; intro... apply (Qlt_is_antisymmetric_unfolded 0 q)... revert E. rewrite U. apply Qlt_irrefl. Qed. Lemma genball_Reflexive (q: Qinf): (0 <= q)%Qinf → Reflexive (genball q). Proof with auto. repeat intro. unfold genball. destruct q... destruct Qdec_sign as [[|]|]; intuition... apply (Qlt_not_le q 0)... Qed. Global Instance genball_Symmetric: ∀ e, Symmetric (genball e). Proof with auto. intros [q|]... simpl. destruct Qdec_sign as [[|]|]; try apply _... Qed. Lemma genball_triangle (e1 e2: Qinf) (a b c: X): genball e1 a b → genball e2 b c → genball (e1 + e2) a c. Proof with auto. intros U V. destruct e1 as [e1|]... destruct e2 as [e2|]... apply genball_alt. apply genball_alt in U. apply genball_alt in V. destruct (Qdec_sign (e1 + e2)) as [[G | I] | J]; destruct (Qdec_sign e1) as [[A | B] | C]; destruct (Qdec_sign e2) as [[D | E] | F]; intuition. revert G. apply (Qlt_is_antisymmetric_unfolded _ _)... revert G. rewrite F, Qplus_0_r. apply (Qlt_is_antisymmetric_unfolded _ _ B)... revert G. rewrite C, Qplus_0_l. apply (Qlt_is_antisymmetric_unfolded _ _ E)... revert G. rewrite C, F. apply Qlt_irrefl. change (genball (exist _ e1 B + exist _ e2 E )%Qpos a c). apply ball_genball. apply Rtriangle with b; apply ball_genball... rewrite <- V. assert (e1 + e2 == e1) by (rewrite F, Qplus_0_r; reflexivity). apply (genball_Proper (e1+e2) e1 H2 a a (reflexivity _) b b (reflexivity _)), U. rewrite U. assert (e1 + e2 == e2) by (rewrite C, Qplus_0_l; reflexivity). apply (genball_Proper (e1+e2) e2 H2 b b (reflexivity _) c c (reflexivity _)), V. rewrite U, V. apply genball_Reflexive. apply Qlt_le_weak, I. exfalso. apply Qlt_le_weak in E. apply (Qplus_lt_le_compat _ _ _ _ B) in E. rewrite J in E. apply (Qlt_irrefl 0 E). exfalso. rewrite F, Qplus_0_r in J. rewrite J in B. exact (Qlt_irrefl 0 B). exfalso. rewrite C, Qplus_0_l in J. rewrite J in E. exact (Qlt_irrefl 0 E). Qed. Lemma genball_closed : (∀ (e: Qinf) (a b: X), (∀ d: Qpos, genball (e + d) a b) → genball e a b). Proof with auto with *. intros. unfold genball. destruct e... destruct Qdec_sign as [[|]|]. assert (0 < (1#2) * -q)%Q. apply Qmult_lt_0_compat... apply Qopp_Qlt_0_l... pose proof (H2 (exist _ _ H3)). refine (genball_negative _ _ _ _ H4). simpl. ring_simplify. apply Qopp_Qlt_0_l... setoid_replace (- ((1 # 2) * q))%Q with (-q * (1#2))%Q by (simpl; ring). apply Qmult_lt_0_compat... apply Qopp_Qlt_0_l... apply Rclosed. intros. apply ball_genball. apply (H2 d). apply Req. intros. apply ball_genball. assert (d == q + d) by (rewrite q0, Qplus_0_l; reflexivity). apply (genball_Proper d (q+d) H3 a a (reflexivity _) b b (reflexivity _)), H2. Qed. Lemma genball_stable : (∀ (e: Q) (a b: X), (~~genball e a b) → genball e a b). Proof. intros. unfold genball. unfold genball in H2. destruct (Qdec_sign e). destruct s. - contradict H2. intro H2. contradiction. - apply Rstable, H2. - apply Req. unfold equiv in H2. intro d. apply Rstable. intro abs. contradict H2; intro H2. contradict abs. rewrite H2. apply H0. Qed. Instance genball_MetricSpace: @MetricSpaceClass X genball. Proof. constructor; try apply _. - unfold mspc_ball. intros. rewrite H2. reflexivity. - reflexivity. - apply genball_negative. - apply genball_Reflexive. - apply genball_triangle. - apply genball_closed. - apply genball_stable. Qed. End genball. (** Bundled MetricSpaces immediately yield instances of the classes: *) #[global] Instance: ∀ X: MetricSpace, MetricSpaceBall X := λ X, @genball X _ (@ball X). #[global] Instance class_from_MetricSpace (X: MetricSpace): MetricSpaceClass X. Proof. apply genball_MetricSpace. - intros q r H x y H0 z t H1. apply ball_wd; assumption. - intros e. apply msp_refl. exact (msp X). apply Qpos_nonneg. - intro e. apply msp_sym, (msp X). - intros e1 e2. apply msp_triangle, X. - intros x y H. apply ball_closed. intros. rewrite Qplus_0_l. apply (H (exist _ _ H0)). - intros e x y H. apply msp_closed. exact (msp X). intros. apply (H (exist _ _ H0)). - intros. apply (msp_stable (msp X)), H. Qed. Section products. Context `{MetricSpaceClass X} `{MetricSpaceClass Y}. Global Instance: MetricSpaceBall (X * Y) := λ e a b, mspc_ball X e (fst a) (fst b) ∧ mspc_ball Y e (snd a) (snd b). (* We do not reuse ProductMS here because to do so we'd need to go through genball, resulting in the problems described earlier. *) Global Instance: MetricSpaceClass (X * Y). Proof with auto. constructor. - intros. split. intros. destruct H4. split. rewrite <- (mspc_ball_proper X e1 e2 (fst x) (fst y) H3). exact H4. rewrite <- (mspc_ball_proper Y e1 e2 (snd x) (snd y) H3). exact H5. intros. destruct H4. split. rewrite (mspc_ball_proper X e1 e2 (fst x) (fst y) H3). exact H4. rewrite (mspc_ball_proper Y e1 e2 (snd x) (snd y) H3). exact H5. - split. apply (mspc_ball_inf X). apply (mspc_ball_inf Y). - repeat intro. destruct H4. apply (mspc_ball_negative X _ H3 _ _ H4). - intros e H3 x. split; apply mspc_refl. exact H0. exact H3. exact H2. exact H3. - split; apply (@symmetry _ _ ); try apply _; apply H3. (* just using [symmetry] here causes evar anomalies.. *) - split. apply (mspc_triangle X) with (fst b). apply H3. apply H4. apply (mspc_triangle Y) with (snd b). apply H3. apply H4. - split. apply (mspc_closed X). apply H3. apply (mspc_closed Y). apply H3. - split. apply (mspc_stable X). intro abs. contradict H3; intro H3. destruct H3. contradiction. apply (mspc_stable Y). intro abs. contradict H3; intro H3. destruct H3. contradiction. Qed. End products. (* Workaround Vector.Forall2, which is hard to destruct. *) Fixpoint Vector_Forall2 {X : Type} {n : nat} (P : X -> X -> Prop) (x y : Vector.t X n) { struct x } : Prop. Proof. destruct x as [|xh n xt]. - exact True. - exact (P xh (Vector.hd y) /\ Vector_Forall2 X n P xt (Vector.tl y)). Defined. Section vector_setoid. Context `{Setoid X} (n: nat). Global Instance: Equiv (Vector.t X n) := Vector_Forall2 equiv. Global Instance vector_setoid: Setoid (Vector.t X n). Proof. constructor. - intro x. unfold equiv, Equiv_instance_0. induction x; simpl; constructor. reflexivity. exact IHx. - intros x y H0. unfold equiv, Equiv_instance_0, equiv. unfold equiv, Equiv_instance_0, equiv in H0. induction x. + apply (Vector.case0 (fun y => Vector_Forall2 Ae y (Vector.nil X))). simpl. trivial. + simpl in H0. revert H0. apply (Vector.caseS' y). clear y. intros. destruct H0. split. simpl. symmetry. exact H0. apply IHx, H1. - intros x y z H1 H2. unfold Transitive, equiv, Equiv_instance_0, equiv. unfold Transitive, equiv, Equiv_instance_0, equiv in H1. unfold Transitive, equiv, Equiv_instance_0, equiv in H2. induction x. + simpl. trivial. + revert H2. apply (Vector.caseS' z). clear z. intros zh zt. revert H1. apply (Vector.caseS' y). clear y. intros yh yt H0 H1. simpl in H0. simpl in H1. destruct H0, H1. split. simpl. transitivity yh; assumption. simpl. apply (IHx yt); assumption. Qed. End vector_setoid. (* Todo: Move. *) Section vectors. Context `{MetricSpaceClass X} (n: nat). Global Instance: MetricSpaceBall (Vector.t X n) := λ e, Vector_Forall2 (mspc_ball X e). End vectors. (** I decided to experiment with a class used strictly to declare a metric space's components in a section using [Context] without also declaring the metric space structure itself, and risking accidental parameterization of the section context on the proof of that metric space structure if such parametrization is unneeded (for instance because there is already a UniformContinuous constraint which incorporates the metric space proof. *) Class MetricSpaceComponents X `{MetricSpaceBall X}: Prop. (** Next, we introduce classes for uniform continuity (which is what we're really after, since we will use these to automatically derive uniform continuity for various forms of function composition). *) Arguments mspc_ball {X MetricSpaceBall}. Class Canonical (T: Type): Type := canonical: T. (* Todo: Move. *) #[global] Instance: ∀ {T: Type}, Canonical (T → T) := @Datatypes.id. #[global] Instance: Canonical (Qpos → Qinf) := Qinf.finite ∘ QposAsQ. #[global] Instance composed_Proper `{Equiv A} `{Equiv B} `{Equiv C} (f: B → C) (g: A → B): Proper (=) f → Proper (=) g → Proper (=) (f ∘ g). Proof with auto. repeat intro. unfold Basics.compose. apply H2. apply H3. assumption. Qed. #[global] Instance: Proper (QposEq ==> (=)) QposAsQ. Proof. repeat intro. assumption. Qed. Require Import util.Container. Definition Ball X R := prod X R. #[global] Hint Extern 0 (Equiv (Ball _ _)) => eapply @prod_equiv : typeclass_instances. Section Ball. Context X `{MetricSpaceBall X} (R: Type) `{Canonical (R → Qinf)}. Global Instance ball_contains: Container X (Ball X R) := fun b => mspc_ball (canonical (snd b)) (fst b). Context `{Equiv R} `{!MetricSpaceClass X} `{!Proper (=) (canonical: R → Qinf)}. Local Instance : Equiv X := fun x y => mspc_ball 0 x y. Global Instance ball_contains_Proper: Proper (=) (In: Ball X R → X → Prop). Proof with auto. repeat intro. unfold In, ball_contains. unfold canonical. unfold canonical in Proper0. apply mspc_ball_wd... apply Proper0. apply H2. apply H2. Qed. (* Todo: Clean up. *) End Ball. (*Instance: Params (@contains) 4. Implicit Arguments contains [[X] [H] [H0] [R]].*) Section sig_metricspace. Context `{MetricSpaceClass X} (P: X → Prop). Global Instance sig_mspc_ball: MetricSpaceBall (sig P) := λ e x y, mspc_ball e (` x) (` y). Global Instance sig_mspc: MetricSpaceClass (sig P). Proof with auto. constructor. - intros. destruct x, y. unfold mspc_ball, sig_mspc_ball. simpl. apply mspc_ball_wd. exact H0. exact H1. apply mspc_refl. exact H0. apply Qle_refl. apply mspc_refl. exact H0. apply Qle_refl. - intros. change (mspc_ball Qinf.infinite (` x) (` y)). apply (mspc_ball_inf X). - intros. destruct x, y. unfold mspc_ball, sig_mspc_ball. simpl. apply mspc_ball_negative. exact H0. exact H1. - intros d H1 x. destruct x. unfold mspc_ball, sig_mspc_ball. simpl. apply mspc_refl. exact H0. exact H1. - repeat intro. change (mspc_ball e (` y) (` x)). symmetry... - repeat intro. apply (mspc_triangle X e1 e2 (` a) (` b))... - intros. apply (mspc_closed X e (` a) (` b))... - intros. apply (mspc_stable X e (` a) (` b))... Qed. End sig_metricspace. #[global] Instance Qpos_mspc_ball: MetricSpaceBall Qpos := @sig_mspc_ball Q_as_MetricSpace _ (Qlt 0). #[global] Instance Qpos_mspc: MetricSpaceClass Qpos := @sig_mspc Q_as_MetricSpace _ _ (Qlt 0). #[global] Instance: Cast QnnInf.T Qinf := λ x, match x with | QnnInf.Infinite => Qinf.infinite | QnnInf.Finite q => Qinf.finite (proj1_sig q) end. Section uniform_continuity. Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}. Class UniformlyContinuous_mu (f: X → Y): Type := { uc_mu: Qpos → QposInf }. (* Note: If we omit the {} around the uc_mu field and let the class become a definitional class, instance resolution will often find the wrong instance because the type of uc_mu is the same for different instantiations of X and Y. This solution is not ideal. *) Context (f: X → Y) `{!UniformlyContinuous_mu f}. Class UniformlyContinuous: Prop := { uc_from: MetricSpaceClass X ; uc_to: MetricSpaceClass Y ; uniformlyContinuous: ∀ (e: Qpos) (a b: X), mspc_ball (uc_mu e) a b → mspc_ball e (f a) (f b) }. (** If we have a function with this constraint, then we can bundle it into a UniformlyContinuousFunction: *) Context `{uc: UniformlyContinuous}. Let hint := uc_from. Let hint' := uc_to. (* Program Definition wrap_uc_fun : UniformlyContinuousFunction (bundle_MetricSpace X) (bundle_MetricSpace Y) := @Build_UniformlyContinuousFunction (bundle_MetricSpace X) (bundle_MetricSpace Y) f uc_mu _. Next Obligation. Proof with auto. repeat intro. unfold ball. simpl. apply uniformlyContinuous. destruct uc_mu... apply (mspc_ball_inf X). Qed.*) (** Note that wrap_uc_fun _also_ bundles the source and target metric spaces, because UniformlyContinuousFunction is expressed in terms of the bundled data type for metric spaces. *) End uniform_continuity. Arguments uc_mu {X Y} f {UniformlyContinuous_mu}. (** Local uniform continuity just means that the function restricted to any finite balls is uniformly continuous: *) Section local_uniform_continuity. Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}. Definition restrict (b: Ball X Qpos) (f: X → Y): sig ((∈ b)) → Y := f ∘ @proj1_sig _ _. Class LocallyUniformlyContinuous_mu (f: X → Y): Type := luc_mu (b: Ball X Qpos):: UniformlyContinuous_mu (restrict b f). Context (f: X → Y) {mu: LocallyUniformlyContinuous_mu f}. Class LocallyUniformlyContinuous: Prop := { luc_from: MetricSpaceClass X ; luc_to: MetricSpaceClass Y ; luc_uc (b: Ball X Qpos): UniformlyContinuous (restrict b f) }. Context `{LocallyUniformlyContinuous}. Local Instance : Equiv (X -> Y) := fun x y => forall a : X, mspc_ball 0 (x a) (y a). Instance luc_Proper: Proper (=) f. Proof with simpl; intuition. repeat intro. pose proof luc_to. apply (mspc_eq Y). intros. apply mspc_refl. exact H4. apply Qpos_nonneg. Qed. End local_uniform_continuity. Section local_from_global_continuity. Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y}. Context (f: X → Y) {mu: UniformlyContinuous_mu f} {uc: UniformlyContinuous f}. Instance local_from_global_uc_mu: LocallyUniformlyContinuous_mu f := λ _, Build_UniformlyContinuous_mu _ (uc_mu f). Instance local_from_global_uc: LocallyUniformlyContinuous f. Proof with auto. constructor. apply uc. apply uc. intro. pose proof (uc_from f). pose proof (uc_to f). constructor; try apply _. intros. apply (uniformlyContinuous f). assumption. Qed. End local_from_global_continuity. (** Normally, we would like to use the type class constraints whenever we need uniform continuity of functions, including in the types for higher order functions. For instance, we would like to assign an integration function for uniformly continuous functions a type along the lines of: ∀ (f: sig (∈ r) → CR) `{!UniformlyContinuous f}, CR However, dependent types like these get in the way when we subsequently want to express continuity of this higher order function itself. Hence, a modicum of bundling is hard to avoid. However, we only need to bundle the components of the uniformly continuous function itself---there is no need to also start bundling source and target metric spaces the way UniformlyContinuousFunction and wrap_uc_fun do. Hence, we now introduce a record for uniformly continuous functions that does not needlessly bundle the source and target metric spaces. *) Section shallowly_wrapped_ucfuns. Context `{@MetricSpaceComponents X Xb} `{@MetricSpaceComponents Y Yb}. (* We must name Xe/Xb/Ye/Yb here so that we can repeat them in the implicit argument specification later on. This could have been avoided if Coq offered more flexible commands for implicit argument specification that would let one reset implicit-ness for individual parameters without restating the whole list. *) Record UCFunction: Type := ucFunction { ucFun_itself:> X → Y ; ucFun_mu: UniformlyContinuous_mu ucFun_itself ; ucFun_uc: UniformlyContinuous ucFun_itself }. Local Instance : Equiv (X -> Y) := fun x y => forall a : X, mspc_ball 0 (x a) (y a). Global Instance: ∀ (f: UCFunction), Proper (=) (f: X → Y). Proof. intros. destruct f. simpl. set (local_from_global_uc_mu ucFun_itself0). apply (@luc_Proper X _ Y _ ucFun_itself0 l). apply (local_from_global_uc _). Qed. End shallowly_wrapped_ucfuns. #[global] Existing Instance ucFun_mu. #[global] Existing Instance ucFun_uc. Arguments UCFunction X {Xb} Y {Yb}. Arguments ucFunction {X Xb Y Yb} _ {ucFun_mu ucFun_uc}. Section proper_functions. (* Todo: This is bad. Make instances for (@sig (A → B) (Proper equiv)) instead and delegate to it for UCFunction. *) Context `{Setoid A} `{MetricSpaceClass B}. Local Instance : Equiv (A -> B) := fun x y => forall a : A, mspc_ball 0 (x a) (y a). Let T := (@sig (A → B) (Proper equiv)). (* The equivalence on functions is ext_equiv, ie equivalence of images for each equivalent arguments. *) Global Instance: Equiv T := λ x y, proj1_sig x = proj1_sig y. Global Instance: Setoid T. Proof. constructor. - intros [f fproper] x. simpl. apply mspc_refl. exact H1. apply Qle_refl. - intros [f fproper] [g gproper] fgeq x. simpl. apply mspc_sym. exact H1. apply fgeq. - intros [f fproper] [g gproper] [h hproper] fgeq gheq x. simpl. rewrite (mspc_ball_e_wd B 0 (0+0) (f x) (h x) eq_refl). pose proof (@mspc_triangle B H0 H1 0 0 (f x) (g x) (h x)). apply H2. apply fgeq. apply gheq. Qed. Global Instance: MetricSpaceBall T := λ e f g, Qinf.le 0 e ∧ ∀ a, mspc_ball e (` f a) (` g a). (* The 0<=e condition is needed because otherwise if A is empty, we cannot deduce False from a premise of two functions being inside a negative ball of eachother. If this turns out to be annoying, we can make a separate higher-priority metric space instance for functions from a known-nonempty type (registered with a NonEmpty type class). *) End proper_functions. Section uc_functions. (* Todo: Just delegate to proper_functions. *) Context `{MetricSpaceClass A} `{MetricSpaceClass B}. Local Instance : Equiv (A -> B) := fun x y => forall a : A, mspc_ball 0 (x a) (y a). Global Instance: Equiv (UCFunction A B) := equiv: relation (A→B). Global Instance: Setoid (UCFunction A B). Proof. constructor. - intros f x. apply mspc_refl. exact H2. apply Qle_refl. - intros f g H3 x. apply mspc_sym. exact H2. apply H3. - intros f g h fgeq gheq x. rewrite (mspc_ball_e_wd B 0 (0+0) (f x) (h x) eq_refl). pose proof (@mspc_triangle B H1 H2 0 0 (f x) (g x) (h x)). apply H3. apply fgeq. apply gheq. Qed. Global Instance: MetricSpaceBall (UCFunction A B) := λ e f g, Qinf.le 0 e ∧ ∀ a, mspc_ball e (f a) (g a). (* The 0<=e condition is needed because otherwise if A is empty, we cannot deduce False from a premise of two functions being inside a negative ball of eachother. If this turns out to be annoying, we can make a separate higher-priority metric space instance for functions from a known-nonempty type (registered with a NonEmpty type class). *) Lemma Proper_uc_ball : Proper equiv mspc_ball. Proof. intros d e deeq f g fgeq h k hkeq. split. - intros [dpos H3]. split. rewrite <- deeq. exact dpos. intro x. specialize (H3 x). specialize (fgeq x). specialize (hkeq x). rewrite <- (@mspc_ball_wd B _ H2 d e (f x) (g x) (h x) (k x) deeq fgeq hkeq). exact H3. - intros [dpos H3]. split. rewrite deeq. exact dpos. intro x. specialize (H3 x). specialize (fgeq x). specialize (hkeq x). symmetry in deeq. apply mspc_sym in fgeq. apply mspc_sym in hkeq. rewrite <- (@mspc_ball_wd B _ H2 e d (g x) (f x) (k x) (h x) deeq fgeq hkeq). exact H3. exact H2. exact H2. Qed. Global Instance UCFunction_MetricSpace: MetricSpaceClass (UCFunction A B). Proof. constructor. - split. + intros. destruct H4. split. rewrite <- H3. exact H4. intro a. destruct e2 as [e2|]. 2: apply mspc_ball_inf, H2. destruct e1 as [e1|]. rewrite (@mspc_ball_e_wd B _ H2 e2 e1). apply H5. symmetry. exact H3. inversion H3. + intros. destruct H4. split. rewrite H3. exact H4. intro a. destruct e1 as [e1|]. 2: apply mspc_ball_inf, H2. destruct e2 as [e2|]. rewrite (@mspc_ball_e_wd B _ H2 e1 e2). apply H5. exact H3. inversion H3. - intros f g. split. simpl. trivial. intro x. apply (mspc_ball_inf B). - intros. intros [H4 _]. exact (Qlt_not_le _ _ H3 H4). - intros e epos f. split. exact epos. intros x. apply (mspc_refl B _ epos). - intros e f g [epos H3]. split. exact epos. intro x. apply (mspc_sym B), (H3 x). - intros. destruct H3, H4. split. apply Qinf.le_0_plus_compat; assumption. intros x. specialize (H5 x). specialize (H6 x). apply (mspc_triangle B) with (b x); assumption. - intros. split. + destruct e as [e|]. 2: simpl; auto. simpl. destruct (Qlt_le_dec e 0). 2: exact q. exfalso. assert (0 < (1#2) * -e)%Q. apply Qmult_lt_0_compat. reflexivity. apply Qopp_Qlt_0_l, q. destruct (H3 (exist _ _ H4)) as [H5 _]. simpl in H5. clear q. apply (Qlt_not_le _ _ H4). clear H4. apply (Qplus_le_l ((1#2)*e)). ring_simplify. ring_simplify in H5. setoid_replace (0#4) with 0%Q by reflexivity. exact H5. + intros x. apply (mspc_closed B). intros. apply H3. - intros e f g H3. split. + apply Qnot_lt_le. intro H4. contradict H3; intro H3. destruct H3 as [H3 _]. exact (Qlt_not_le _ _ H4 H3). + intro x. apply (mspc_stable B). intro abs. contradict H3; intro H3. destruct H3 as [epos H3]. exact (abs (H3 x)). Qed. End uc_functions. (** If source and target are /already/ bundled, then we don't need to rebundle them when bundling a uniformly continuous function: *) Program Definition wrap_uc_fun' {X Y: MetricSpace} (f: X → Y) `{!UniformlyContinuous_mu f} `{@UniformlyContinuous X _ Y _ f _}: UniformlyContinuousFunction X Y := @Build_UniformlyContinuousFunction X Y f (uc_mu f) _. Next Obligation. Proof with auto. intros ????. assert (mspc_ball (uc_mu f e) a b). revert H0. set (uc_mu f e). intros. destruct q... apply <- (ball_genball (@ball X) q)... pose proof (uniformlyContinuous f e a b H1). apply (@ball_genball Y (@msp_eq Y) _ (fun q => ball (proj1_sig q))). 2: auto. intros x y H4 z t H5 u v H6. unfold QposEq in H4. rewrite H4. rewrite H5, H6. reflexivity. Qed. (** Conversely, if we have a UniformlyContinuousFunction (between bundled metric spaces) and project the real function out of it, instances of the classes can easily be derived. *) Open Scope uc_scope. Section unwrap_uc. Context {X Y: MetricSpace} (f: X --> Y). Global Instance unwrap_mu: UniformlyContinuous_mu f := { uc_mu := mu f }. Global Instance unwrap_uc_fun: UniformlyContinuous f. Proof with auto. constructor; try apply _. unfold uc_mu, unwrap_mu. destruct f. simpl. intros. unfold mspc_ball. unfold MetricSpaceBall_instance_0. apply ball_genball. apply _. apply uc_prf. set (mu e) in *. destruct q... simpl. apply (@ball_genball X (@msp_eq X) _ (fun q => ball (proj1_sig q))). 2: auto. intros x y H4 z t H5 u v H6. unfold QposEq in H4. rewrite H4. rewrite H5, H6. reflexivity. Qed. End unwrap_uc. (** Extentionally equal functions are obviously equally uniformly continuous (with extensionally equal mu's): *) Lemma UniformlyContinuous_proper `{MetricSpaceClass X} `{MetricSpaceClass Y} (f g: X → Y) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous_mu g}: (∀ x, mspc_equiv Y (f x) (g x)) → (∀ e, uc_mu f e ≡ uc_mu g e) → UniformlyContinuous f → UniformlyContinuous g. (* Todo: Stronger versions of this statement can be proved with a little effort. *) Proof. constructor; try apply _. intros ????. pose proof (mspc_ball_proper Y) as H7. rewrite <- (mspc_ball_wd Y e e (f a) (g a) (f b) (g b)). apply (uniformlyContinuous f). rewrite H4. auto. reflexivity. apply H3. apply H3. Qed. (** We now show that a couple of basic functions are continuous: *) (** The identity function is uniformly continuous: *) Section id_uc. Context `{MetricSpaceClass X}. Global Instance: UniformlyContinuous_mu (@Datatypes.id X) := { uc_mu := Qpos2QposInf }. Global Instance: UniformlyContinuous (@Datatypes.id X). Proof. constructor; try apply _. intros. assumption. Qed. End id_uc. (* Note: We don't need a separate instance for the [id] constant. If such an instance is needed, we can use [Hint Unfold id: typeclass_instances.] *) (** Constant functions are uniformly continuous: *) Section const_uc. Context `{MetricSpaceClass X} `{MetricSpaceClass Y} (y: Y). Global Instance: UniformlyContinuous_mu (@Basics.const Y X y) := { uc_mu := λ _, QposInfinity }. Global Instance: UniformlyContinuous (@Basics.const Y X y). Proof. repeat intro. constructor; try apply _. intros. apply (mspc_refl Y e). simpl. auto. Qed. End const_uc. (** Mapping both of a pair's components by uniformly continuous functions is uniformly continuous: *) Section exist_uc. Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y} (P: Y → Prop) (f: X → Y) (g: ∀ x, P (f x)) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f}. Global Instance exist_mu: UniformlyContinuous_mu (λ x: X, exist P (f x) (g x)) := { uc_mu := uc_mu f }. Global Instance exist_uc: UniformlyContinuous (λ x: X, exist P (f x) (g x)). Proof with auto. constructor. apply (uc_from f). pose proof (uc_to f). apply _. intros. apply (uniformlyContinuous f). assumption. Qed. End exist_uc. Section map_pair_uc. Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y} `{MetricSpaceComponents A} `{MetricSpaceComponents B} (f: X → Y) `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f} (g: A → B) `{!UniformlyContinuous_mu g} `{!UniformlyContinuous g}. Global Instance: UniformlyContinuous_mu (map_pair f g) := { uc_mu := λ x, QposInf_min (uc_mu f x) (uc_mu g x) }. Let hint := uc_from g. Let hint' := uc_to g. Let hint'' := uc_from f. Let hint''' := uc_to f. End map_pair_uc. (** The diagonal function is uniformly continuous: *) Section diagonal_uc. Context `{MetricSpaceClass X}. Global Instance: UniformlyContinuous_mu (@diagonal X) := { uc_mu := Qpos2QposInf }. Global Instance: UniformlyContinuous (@diagonal X). Proof. constructor; try apply _. intros ??? E. split; auto. Qed. End diagonal_uc. (** fst/snd/pair are uniformly continuous: *) Section pairops_uc. Context `{MetricSpaceClass A} `{MetricSpaceClass B}. Global Instance: UniformlyContinuous_mu (@fst A B) := { uc_mu := Qpos2QposInf }. Global Instance: UniformlyContinuous_mu (@snd A B) := { uc_mu := Qpos2QposInf }. Global Instance: UniformlyContinuous_mu (uncurry (@pair A B)) := { uc_mu := Qpos2QposInf }. Global Instance: ∀ a, UniformlyContinuous_mu (@pair A B a) := { uc_mu := Qpos2QposInf }. Global Instance: UniformlyContinuous (@fst A B). Proof. constructor; try apply _. intros ??? P. apply P. Qed. Global Instance: UniformlyContinuous (@snd A B). Proof. constructor; try apply _. intros ??? P. apply P. Qed. Global Instance: UniformlyContinuous (uncurry (@pair A B)). Proof. constructor; try apply _. intros ??? P. apply P. Qed. Global Instance: ∀ a, UniformlyContinuous (@pair A B a). Proof. constructor; try apply _. intros ??? P. split. apply (mspc_refl A). simpl. auto. apply P. Qed. End pairops_uc. Section compose_uc. Context `{MetricSpaceComponents X} `{MetricSpaceComponents Y} `{MetricSpaceComponents Z'} (f: Y → Z') `{!UniformlyContinuous_mu f} `{!UniformlyContinuous f} (g: X → Y) `{!UniformlyContinuous_mu g} `{!UniformlyContinuous g}. Global Instance compose_mu: UniformlyContinuous_mu (f ∘ g)%prg := { uc_mu := λ e, QposInf_bind (uc_mu g) (uc_mu f e) }. Let hint := uc_from g. Let hint' := uc_to g. Let hint'' := uc_to f. End compose_uc. Section curried_uc. Context `{MetricSpaceClass X} `{MetricSpaceClass Y} `{MetricSpaceClass Z'} (f: X → Y → Z') `{fmu1: ∀ x: X, UniformlyContinuous_mu (f x)} `{fuc1: ∀ x: X, UniformlyContinuous (f x)} `{fmu: !UniformlyContinuous_mu (λ p, f (fst p) (snd p))} `{fuc: !UniformlyContinuous (λ p, f (fst p) (snd p))}. Local Notation F := (λ x: X, {| ucFun_itself := λ y: Y, f x y; ucFun_mu := fmu1 x; ucFun_uc := fuc1 x |}). Global Instance curried_mu: UniformlyContinuous_mu F := { uc_mu := uc_mu (λ p, f (fst p) (snd p)) }. Global Instance curried_uc: UniformlyContinuous F. Proof with simpl; auto. constructor; try apply _. split... simpl in *. destruct fuc. intros. apply (@uniformlyContinuous0 e (a, a0) (b, a0)). simpl. set (q := uc_mu (λ p, f (fst p) (snd p)) e) in *. destruct q... split... apply (mspc_refl Y)... apply (mspc_ball_inf _). Qed. End curried_uc. Class HasLambda `{X: Type} (x: X): Prop. #[global] Instance lambda_has_lambda `(f: A → B): HasLambda (λ x, f x) := {}. #[global] Instance application_has_lambda_left: ∀ `(f: A → B) (x: A), HasLambda f → HasLambda (f x) := {}. #[global] Instance application_has_lambda_right: ∀ `(f: A → B) (x: A), HasLambda x → HasLambda (f x) := {}. Section lambda_uc. Context `{MetricSpaceComponents A} `{MetricSpaceComponents B} (f: A → B). Global Instance lambda_mu `{!HasLambda f} {free_f: A → B} `{!PointFree f free_f} `{!UniformlyContinuous_mu free_f}: UniformlyContinuous_mu f. (* Note: The HasLambda and PointFree constraints cannot be added to the Context declaration above because the definition of this mu needs to depend on them /despite/ not using them. Without the dependency, lambda_mu would be allowed to find a random free_f of the right signature for which it happens to have a mu already, and use that one. We do not factor out the mu constraint either, because for (dubious) efficiency reasons it is critical that it appear /after/ the PointFree constraint.*) Proof. constructor. apply UniformlyContinuous_mu0. Defined. Context `{!HasLambda f} {free_f: A → B} `{!PointFree f free_f} `{!UniformlyContinuous_mu free_f} `{!UniformlyContinuous free_f}. Global Instance lambda_uc: UniformlyContinuous f. Proof. destruct UniformlyContinuous0. constructor. apply _. apply _. destruct uc_from0. destruct uc_to0. intros. unfold PointFree in PointFree0. rewrite PointFree0. apply uniformlyContinuous0. unfold uc_mu in H3. simpl in H3. assumption. Qed. (* Todo: Clean up. *) End lambda_uc. (* Module test. Section test. Context `{MetricSpaceClass A} (f: A → A → A) `{!UniformlyContinuous_mu (uncurry f)} `{!UniformlyContinuous (uncurry f)} `{!Proper (=) f}. Definition t0: UniformlyContinuous_mu (λ (x: A), f (f x x) (f x (f x x))) := _. End test. End test. *) corn-8.20.0/metric2/Compact.v000066400000000000000000001754021473720167500157110ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.metric2.Limit. Require Export CoRN.metric2.FinEnum. From Coq Require Import Zpow_facts. Require Export CoRN.metric2.Complete. Require Import CoRN.logic.Classic. From Coq Require Import Qpower. From Coq Require Import Qround. Set Implicit Arguments. Local Open Scope uc_scope. (** * Compact sets This module formalizes compact sets as the completion of a finitely enumerables sets. *) Section BishopCompact. (** ** Bishop Compactness This section formalizes Bishops definition of compactness to serve as a reference specification for our definition of compactness. *) Variable X : MetricSpace. Variable P : X -> Prop. Definition CompleteSubset := forall (f:Complete X), (forall e, P (approximate f e)) -> {y:X | P y & msp_eq (Cunit y) f}. Definition ExtSubset := forall x y, (msp_eq x y) -> (P x <-> P y). Definition TotallyBoundedSubset := forall (e:Qpos), {l : list X | forall y, In y l -> P y & forall x, P x -> exists y, In y l /\ ball (proj1_sig e) x y }. (** A Bishop compact set is an (extensional) predicate that is complete and totally bounded. *) Record CompactSubset := {completeSubset : CompleteSubset ;totallyBoundedSubset : TotallyBoundedSubset ;extSubset : ExtSubset }. End BishopCompact. (* end hide *) (** ** Definition of Compact A compact set is defined as the completion of finite enumerations as a metric space *) Definition Compact X := Complete (FinEnum X). (** This predicate says that the distance between x and s is zero (less than arbitrary e1+e2). As a compact s is closed, so it implies that x is in s. inCompact also converts the abstract s:Compact X into a usual subset Complete X -> Prop. *) Definition inCompact {X : MetricSpace} (x:Complete X) (s:Compact X) : Prop := forall (e1 e2:Qpos), FinSubset_ball (proj1_sig e1 + proj1_sig e2) (approximate x e1) (approximate s e2). (* begin hide *) Add Parametric Morphism {X : MetricSpace} : (@inCompact X) with signature (@msp_eq _) ==> (@msp_eq _) ==> iff as inCompact_wd. Proof. cut (forall x1 x2 : Complete X, msp_eq x1 x2 -> forall x3 x4 : Complete (FinEnum X), msp_eq x3 x4 -> (inCompact x1 x3 -> inCompact x2 x4)). intros Z x1 x2 Hx y1 y2 Hy. split. apply Z; assumption. apply Z; symmetry; assumption. intros x1 x2 Hx y1 y2 Hy H e1 e2. apply FinSubset_ball_closed. intros d dpos. set (d':=((1#4) * exist _ _ dpos)%Qpos). assert (Qeq (proj1_sig e1 + proj1_sig e2 + d)%Q (proj1_sig ((e1 + d') + (d' + d') + (d' + e2))%Qpos)) by (unfold d'; unfold QposEq; simpl; ring). apply (@FinSubset_ball_wd_full _ (proj1_sig e1 + proj1_sig e2 + d) (proj1_sig ((e1 + d') + (d' + d') + (d' + e2))%Qpos) H0 _ _ (reflexivity _) _ _ (reflexivity _)). apply regFunEq_equiv in Hy. apply FinSubset_ball_triangle_r with (approximate y1 d');[|apply Hy]. symmetry in Hx. apply regFunEq_equiv in Hx. apply FinSubset_ball_triangle_l with (approximate x1 d');[apply Hx|]. apply H. Qed. (* end hide *) Section Compact. Variable X : MetricSpace. Let inCompact := @inCompact X. Lemma inCompact_stable : forall x s, ~~inCompact x s -> inCompact x s. Proof. intros x s H e1 e2. intros H0. contradict H. intros H1. revert H0. apply H1. Qed. (** ** Compact is Bishop Compact. Here we show that our definiton of compactness satifies Bishop's compactness. First we show that our compact sets are complete. *) Lemma CompactCompleteSubset : forall x, CompleteSubset _ (fun z => inCompact z x). Proof. intros x a H. pose (exist (Qlt 0) (1#2) eq_refl) as half. exists (Cjoin a). abstract ( intros e1 e2; unfold inCompact in H; eapply FinSubset_ball_weak_le; [|apply (H (half*e1) (half*e1) e2)%Qpos]; simpl; rewrite -> Qle_minus_iff; ring_simplify; auto with *; apply Qmult_le_0_compat; auto with * ). apply CunitCjoin. Defined. Section CompactTotallyBounded. (** In order to show that compact sets are totally bounded we need to assume that the underlying metric space is located. According to Bishop's definition, every metric space is located. Therefore this is a fair assumption to make. *) Hypothesis locatedX : locatedMetric X. (** Finite subsets are located (and even compact), so their distance to a point is realized constructively by a point in the subset. *) Lemma AlmostInExists : forall (e d:Q) x (s:FinEnum X), e < d -> FinSubset_ball e x s -> { n:nat | match nth_error s n with | None => False | Some y => ball d x y end }. Proof. intros e d x s Hed. induction s. intro abs; exfalso; exact (FinSubset_ball_nil abs). intros H. destruct (@locatedX _ _ x a Hed) as [close|far]. exists O. exact close. destruct IHs as [n Hy]. abstract (intros H0; apply FinSubset_ball_orC in H; apply H; split; auto). exists (S n). exact Hy. Defined. Lemma AlmostInExists_weak : forall (e d:Q) x (s:FinEnum X), e < d -> FinSubset_ball e x s -> { y:X | In y s /\ ball d x y }. Proof. intros. destruct (AlmostInExists H H0) as [n H1]. pose proof (nth_error_In s n). destruct (nth_error s n) as [y|]. 2: contradiction. exists y. split. exact (H2 y eq_refl). exact H1. Defined. (* If we want to improve this with d = e, we have to double negate, because it would require finding the minimum of the distance function, which reduces to proving CRmin a b=a \/ CRmin a b=b. *) Lemma InCompact_approx : forall (Y : Compact X) (x : Complete X) (d:Qpos) (e:Q), inCompact x Y -> proj1_sig d < e -> {y:X | In y (approximate Y d) /\ ball e x (Cunit y)}. Proof. intros. unfold inCompact in H. assert (0 < (1#4) * (e - proj1_sig d)). { apply Qlt_minus_iff in H0. apply (Qpos_ispos ((1#4)*exist _ _ H0)). } specialize (H (exist _ _ H1) d). simpl in H. assert ((1#4) * (e - proj1_sig d) + proj1_sig d < (1#2) * (proj1_sig d + e)). { apply (Qplus_lt_l _ _ (-(1#4)*e - (1#2)*proj1_sig d)). ring_simplify. apply Qmult_lt_l. reflexivity. exact H0. } pose proof (AlmostInExists_weak H2 H) as [y [H3 H4]]. exists y. split. exact H3. intros d1 d2. simpl. apply (@ball_weak_le _ (proj1_sig d1 + ((1 # 4) * (e - proj1_sig d)) + (1 # 2) * (proj1_sig d + e))). rewrite <- Qplus_assoc, <- Qplus_assoc. apply Qplus_le_r. apply (Qle_trans _ (e + 0)). rewrite Qplus_0_r. apply (Qplus_le_r _ _ (-(3#4)*e)). ring_simplify. setoid_replace (2#8) with (1#4) by reflexivity. apply Qmult_le_l. reflexivity. apply Qlt_le_weak, H0. apply Qplus_le_r, Qpos_nonneg. apply ball_triangle with (b:=(approximate x (Qpos2QposInf (exist _ _ H1)))). - apply (regFun_prf x d1 (exist _ _ H1)). - exact H4. Qed. Lemma InCompact_approxC : forall (Y : Compact X) (x : Complete X) (d:Qpos), inCompact x Y -> ~~exists y:X, In y (approximate Y d) /\ ball (proj1_sig d) x (Cunit y). Proof. intros. intro abs. apply (infinitePidgeonHolePrinicple _ (approximate Y d) (fun n y => ball (proj1_sig d+(1#Pos.of_nat n)) x (Cunit y))). - intros n. apply existsWeaken. destruct (@InCompact_approx Y x d (proj1_sig d + (1 # Pos.of_nat n)) H) as [t [H0 H1]]. apply (Qle_lt_trans _ (proj1_sig d+0)). rewrite Qplus_0_r. apply Qle_refl. apply Qplus_lt_r. reflexivity. exists t. split. intro H3; contradiction. exact H1. - intros t [H0 H1]. contradict abs. exists t. split. exact H0. apply ball_closed. intros e epos. destruct e as [a n]. specialize (H1 (Pos.to_nat n)). apply (msp_stable (msp (Complete X))). intro abs. unfold existsC in H1. contradict H1; intros k [H1 H3]. contradict abs. apply (ball_weak_le) with (e:=proj1_sig d + (1 # Pos.of_nat k)). apply Qplus_le_r. apply (Qle_trans _ (1#n)). unfold Qle; simpl. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H1. apply (Nat.lt_le_trans _ _ _ (Pos2Nat.is_pos n)) in H1. destruct k. inversion H1. discriminate. unfold Qle; simpl. apply (Z.mul_le_mono_nonneg_r 1 a (Z.pos n)). discriminate. unfold Qlt in epos. simpl in epos. rewrite Z.mul_1_r in epos. apply (Zlt_le_succ 0 a), epos. exact H3. Qed. (** The limit of this sequence constructs a point inside the compact set close to any point pt inside an approximation of the compact. The next point pt' is in approximate s (k*d), which converges to s when k < 1. By regularity of the compact s, the distance between the approximations at d and k*d is (1+k)*d. To constructively pick pt' we must bump the distance a bit by e and we get ball ((1+k)*d+e) pt pt'. Continuing we get ball ((1+k)*k*d+k*e) pt' pt''. By summing we see that the stream of points stays within distance (1+k)*d+e of pt, which we can take arbitrarily close to d, the initial distance between pt and the compact s. *) Fixpoint CompactImproveApproximation (s:Compact X) (k d e:Qpos) (pt:X) (Hpt : InFinEnumC pt (approximate s d)) (n : nat) { struct n } : X := match n with | O => pt | S p => let (f,_) := HausdorffBallHausdorffBallStrong locatedX (regFun_prf s d (k*d)%Qpos) in let (pt',HptX) := f pt Hpt e in let (Hpt',_) := HptX in @CompactImproveApproximation s k (k*d) (k*e) pt' Hpt' p end. (** This stream is Cauchy *) Lemma CompactTotallyBoundedStreamCauchyLemma : forall n (k d:Qpos), proj1_sig k < 1 -> 0 < (proj1_sig d*(1-proj1_sig k^Z.of_nat (S n))/(1-proj1_sig k)). Proof. intros n k d Hk. unfold Qdiv. rewrite <- Qmult_assoc. apply (Qle_lt_trans _ (proj1_sig d * 0)). rewrite Qmult_0_r. apply Qle_refl. apply Qmult_lt_l. apply Qpos_ispos. apply (Qle_lt_trans _ ((1 - proj1_sig k ^ Z.of_nat (S n)) * 0)). rewrite Qmult_0_r. apply Qle_refl. apply Qmult_lt_l. unfold Qminus. rewrite <- Qlt_minus_iff. induction n. assumption. simpl. rewrite Pplus_one_succ_l. rewrite -> Qpower_plus_positive. apply Qlt_trans with (proj1_sig k*1). apply Qmult_lt_l. apply Qpos_ispos. exact IHn. rewrite Qmult_1_r. exact Hk. apply Qlt_shift_inv_l. unfold Qminus. rewrite <- Qlt_minus_iff. assumption. ring_simplify. constructor. Qed. (* In a friendlier notation, the distance is ((1+k)*d1+d2) * (1-k^(S n)) / (1-k) *) Lemma CompactImproveApproxCauchy1 : forall n s (k d1 d2:Qpos) pt Hpt, proj1_sig k < 1 -> ball ((((1#1)+proj1_sig k)*proj1_sig d1+ proj1_sig d2) * (1-proj1_sig k^Z.of_nat(S n))/(1-proj1_sig k)) pt (@CompactImproveApproximation s k d1 d2 pt Hpt n). Proof. induction n; intros s k d1 d2 pt Hpt Hk. apply ball_refl. apply Qlt_le_weak. apply (CompactTotallyBoundedStreamCauchyLemma O k (((1#1) + k) * d1 + d2)%Qpos), Hk. simpl (CompactImproveApproximation s k d1 d2 Hpt (S n)). set (e:=(((1#1) + proj1_sig k) * proj1_sig d1 + proj1_sig d2) * (1 - proj1_sig k ^ Z.of_nat (S (S n))) / (1 - proj1_sig k)) in *. set (e0:=((d1 + k * d1 + d2) + exist _ _ (CompactTotallyBoundedStreamCauchyLemma n _ (((1#1) + k)*(k*d1) + (k*d2)) Hk))%Qpos). setoid_replace e with (proj1_sig e0). - simpl. destruct (@HausdorffBallHausdorffBallStrong X locatedX (@proj1_sig Q (Qlt 0) d1 + @proj1_sig Q (Qlt 0) k * @proj1_sig Q (Qlt 0) d1) (@approximate _ (FinEnum_ball X) s (Qpos2QposInf d1)) (@approximate _ (FinEnum_ball X) s (Qpos2QposInf (k * d1))) (@regFun_prf _ (FinEnum_ball X) s d1 (k * d1)%Qpos)) as [f _]. destruct (f pt Hpt d2) as [pt' [Hpt' Hpt'']]. unfold e0. apply ball_triangle with pt'. assumption. apply (IHn s k (k * d1)%Qpos (k * d2)%Qpos pt' Hpt' Hk). - unfold e0, e. simpl. assert (~proj1_sig k==0). { destruct k. simpl. intro abs. apply (Qlt_not_le _ _ q). rewrite abs. apply Qle_refl. } rewrite <- Pos.add_1_l. rewrite Qpower_plus_positive. simpl. field. intros H0. apply (Qlt_not_le _ _ Hk). rewrite -> Qle_minus_iff. setoid_replace (proj1_sig k + - (1)) with (-(1-proj1_sig k)) by (simpl; ring). rewrite -> H0. discriminate. Qed. Lemma CompactImproveApproxCauchy2 : forall (m n:nat) s (k d1 d2:Qpos) pt Hpt, proj1_sig k < 1 -> ball (proj1_sig k ^ (Z.of_nat m) * ((((1#1)+proj1_sig k)*proj1_sig d1+proj1_sig d2) *(1-proj1_sig k^Z.of_nat (S n))/(1-proj1_sig k))) (@CompactImproveApproximation s k d1 d2 pt Hpt m) (@CompactImproveApproximation s k d1 d2 pt Hpt (m + n)). Proof. induction m; intros n s k d1 d2 pt Hpt Hk. simpl (proj1_sig k ^ Z.of_nat 0). rewrite Qmult_1_l. apply CompactImproveApproxCauchy1; assumption. pose (e':=(CompactTotallyBoundedStreamCauchyLemma n _ (((1#1)+k)*(k*d1) + (k*d2)) Hk)%Qpos). assert (~proj1_sig k==0) as knz. { destruct k. simpl. intro abs. apply (Qlt_not_le _ _ q). rewrite abs. apply Qle_refl. } assert (Qeq (proj1_sig k ^ (Z.of_nat (S m)) * ((((1#1)+proj1_sig k)*proj1_sig d1+proj1_sig d2) *(1-proj1_sig k^Z.of_nat (S n))/(1-proj1_sig k))) (proj1_sig (Qpos_power k (Z.of_nat m)*exist _ _ e')%Qpos)). { rewrite Nat2Z.inj_succ. simpl. setoid_replace (proj1_sig k ^ (Z.succ (Z.of_nat m))) with (proj1_sig k ^ (1+Z.of_nat m)). rewrite Qpower_plus. simpl. field. intros H0. apply (Qlt_not_le _ _ Hk). rewrite -> Qle_minus_iff. setoid_replace (proj1_sig k + - (1)) with (-(1-proj1_sig k)) by (simpl; ring). rewrite -> H0. discriminate. exact knz. rewrite <- Z.add_1_l. reflexivity. } rewrite H. clear H. change (S m + n)%nat with (S (m + n))%nat. unfold Str_nth. simpl. destruct (@HausdorffBallHausdorffBallStrong X locatedX (@proj1_sig Q (Qlt 0) d1 + @proj1_sig Q (Qlt 0) k * @proj1_sig Q (Qlt 0) d1) (@approximate _ (FinEnum_ball X) s d1) (@approximate _ (FinEnum_ball X) s (k * d1)%Qpos) (@regFun_prf _ (FinEnum_ball X) s d1 (k * d1)%Qpos)) as [f _]. destruct (f pt Hpt d2) as [pt' [Hpt' _]]. simpl. apply (IHm n s k (k*d1)%Qpos (k*d2)%Qpos pt' Hpt'); assumption. Qed. (* All points in the stream are in the approximations of s, at precisions k^n * d1. *) Lemma StreamInCompactApprox : forall n s k d1 d2 pt Hpt, {q:Qpos | InFinEnumC (@CompactImproveApproximation s k d1 d2 pt Hpt n) (approximate s q) & QposEq q (Qpos_power k (Z.of_nat n)*d1) }. Proof. induction n. intros. exists d1. assumption. unfold QposEq; simpl; ring. intros. unfold Str_nth. simpl. destruct (@HausdorffBallHausdorffBallStrong X locatedX (@proj1_sig Q (Qlt 0) d1 + @proj1_sig Q (Qlt 0) k * @proj1_sig Q (Qlt 0) d1) (@approximate _ (FinEnum_ball X) s d1) (@approximate _ (FinEnum_ball X) s (k * d1)%Qpos) (@regFun_prf _ (FinEnum_ball X) s d1 (k * d1)%Qpos)) as [f _]. destruct (f pt Hpt d2) as [pt' [Hpt' _]]. destruct (IHn s k (k*d1) (k*d2) pt' Hpt')%Qpos as [q Hq Hq0]. exists q. apply Hq. rewrite Zpos_P_of_succ_nat. unfold Z.succ. unfold QposEq, Qpos_power, proj1_sig. simpl. rewrite Z.add_comm. rewrite -> Qpower_plus. simpl. unfold QposEq, proj1_sig in Hq0. simpl in Hq0. rewrite Hq0. unfold proj1_sig. ring. destruct k. simpl. intro abs. apply (Qlt_not_le _ _ q0). rewrite abs. apply Qle_refl. Qed. (* This is the index at which the stream has converged within e. *) Definition CompactTotallyBoundedIndex (e d1 d2:Qpos) : Z := Z.log2_up (Qceiling (((3#1)*proj1_sig d1+(2#1)*proj1_sig d2) / proj1_sig e)). Hint Resolve Qinv_lt_0_compat. (* todo: move, and put in appropriate hint db *) Lemma Qpower_inc : forall (n : nat) (a b : Q), 0 < a -> a <= b -> a ^ Z.of_nat n <= b ^ Z.of_nat n. Proof. induction n. - intros. discriminate. - intros. rewrite Nat2Z.inj_succ. rewrite <- Z.add_1_l. rewrite Qpower_plus, Qpower_plus. apply (Qle_trans _ (a * b ^ Z.of_nat n)). apply Qmult_le_l. exact H. apply IHn. exact H. exact H0. apply Qmult_le_compat_r. exact H0. apply Qpower_pos. refine (Qle_trans _ _ _ _ H0). apply Qlt_le_weak, H. intro abs. rewrite abs in H0. apply (Qlt_irrefl 0). exact (Qlt_le_trans _ _ _ H H0). intro abs. rewrite abs in H. apply (Qlt_irrefl 0 H). Qed. Lemma CompactTotallyBoundedIndexLemma : forall (e k d1 d2:Qpos), proj1_sig k <= 1#2 -> ((1+proj1_sig k)*proj1_sig d1 + proj1_sig d2) *proj1_sig k^(CompactTotallyBoundedIndex e d1 d2)/(1-proj1_sig k) <= proj1_sig e. Proof. intros e k d1 d2 khalf. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply (Qle_trans _ (((3#1)*proj1_sig d1+(2#1)*proj1_sig d2) * proj1_sig k ^(CompactTotallyBoundedIndex e d1 d2))). - apply Qmult_le_compat_r. 2: apply Qpower_pos, Qpos_nonneg. apply (Qle_trans _ ((2#1) * ((1 + proj1_sig k) * proj1_sig d1 + proj1_sig d2))). apply Qmult_le_compat_r. 2: apply (Qpos_nonneg (((1#1)+k)*d1+d2)%Qpos). apply Qle_shift_inv_r. unfold Qminus. rewrite <- Qlt_minus_iff. apply (Qle_lt_trans _ _ _ khalf). reflexivity. setoid_replace 1%Q with ((2#1)*(1#2)) at 1 by reflexivity. apply Qmult_le_l. reflexivity. apply (Qplus_le_l _ _ (proj1_sig k - (1#2))). ring_simplify. exact khalf. rewrite Qmult_plus_distr_r. apply Qplus_le_l. rewrite Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. apply (Qplus_le_r _ _ (-(2#1))). ring_simplify. setoid_replace 1%Q with ((2#1)*(1#2)) by reflexivity. apply Qmult_le_l. reflexivity. exact khalf. - apply (Qle_trans _ (((3#1) * proj1_sig d1 + (2#1) * proj1_sig d2) * (1#2) ^ (CompactTotallyBoundedIndex e d1 d2))). apply Qmult_le_l. apply (Qpos_ispos ((3#1) * d1 + (2#1) * d2)%Qpos). rewrite <- (Z2Nat.id (CompactTotallyBoundedIndex e d1 d2)). apply Qpower_inc. apply Qpos_ispos. exact khalf. apply Z.log2_up_nonneg. rewrite <- (Qmult_1_r (proj1_sig e)). rewrite <- (Qpower_1 (CompactTotallyBoundedIndex e d1 d2)). setoid_replace (1#1)%Q with ((2#1)*(1#2))%Q by reflexivity. rewrite Qmult_power, Qmult_assoc. apply Qmult_le_compat_r. 2: apply Qpower_pos; discriminate. rewrite <- (Zpower_Qpower 2 (CompactTotallyBoundedIndex e d1 d2)). 2: apply Z.log2_up_nonneg. rewrite (Qmult_comm (proj1_sig e)). apply (Qmult_le_r _ _ (/proj1_sig e)). apply Qinv_lt_0_compat, Qpos_ispos. rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. unfold CompactTotallyBoundedIndex. unfold Qdiv. assert (0 < ((3#1) * proj1_sig d1 + (2#1) * proj1_sig d2) * / proj1_sig e). { apply (Qle_lt_trans _ (((3#1) * proj1_sig d1 + (2#1) * proj1_sig d2)*0)). rewrite Qmult_0_r. discriminate. apply Qmult_lt_l. apply (Qpos_ispos ((3#1)*d1 + (2#1)*d2)). apply Qinv_lt_0_compat, Qpos_ispos. } revert H. generalize (((3#1) * proj1_sig d1 + (2#1) * proj1_sig d2) * / proj1_sig e). intros q qpos. apply (Qle_trans _ _ _ (Qle_ceiling q)). rewrite <- Q.Zle_Qle. apply Z.log2_up_le_pow2. rewrite Q.Zlt_Qlt. exact (Qlt_le_trans _ _ _ qpos (Qle_ceiling q)). apply Z.le_refl. apply Qpos_nonzero. Qed. Definition CompactTotallyBounded_raw (s:Compact X) (k d1 d2:Qpos) (pt:X) Hpt (e:QposInf) : X := match e with | QposInfinity => pt | Qpos2QposInf e' => @CompactImproveApproximation s k d1 d2 pt Hpt (Z.to_nat (CompactTotallyBoundedIndex e' d1 d2)) end. (** This stream forms a regular function *) Lemma CompactTotallyBounded_prf : forall (s:Compact X) (k d1 d2:Qpos) (pt:X) Hpt, proj1_sig k <= 1#2 -> is_RegularFunction (@ball X) (@CompactTotallyBounded_raw s k d1 d2 pt Hpt). Proof. unfold CompactTotallyBounded_raw, is_RegularFunction. cut (forall (s : Compact X) (k d1 d2 : Qpos) (pt : X) (Hpt : InFinEnumC pt (approximate s d1)) (e1 e2 : Qpos), proj1_sig k <= 1#2 -> (Z.to_nat (CompactTotallyBoundedIndex e1 d1 d2) <= Z.to_nat (CompactTotallyBoundedIndex e2 d1 d2))%nat -> ball (proj1_sig e1 + proj1_sig e2) (@CompactImproveApproximation s k d1 d2 pt Hpt (Z.to_nat (CompactTotallyBoundedIndex e1 d1 d2))) (@CompactImproveApproximation s k d1 d2 pt Hpt (Z.to_nat (CompactTotallyBoundedIndex e2 d1 d2)))). - intros Z s k d1 d2 pt Hpt khalf e1 e2. destruct (le_lt_dec (Z.to_nat (CompactTotallyBoundedIndex e1 d1 d2)) (Z.to_nat (CompactTotallyBoundedIndex e2 d1 d2))). apply Z; auto. rewrite Qplus_comm. apply ball_sym. apply Z; auto with *. - intros s k d1 d2 pt Hpt e1 e2 khalf H. set (A:=Z.to_nat (CompactTotallyBoundedIndex e1 d1 d2)) in *. set (B:=Z.to_nat (CompactTotallyBoundedIndex e2 d1 d2)) in *. rewrite <- (Nat.sub_add _ _ H). rewrite Nat.add_comm. assert (proj1_sig k < 1) as Y. { apply (Qle_lt_trans _ _ _ khalf). reflexivity. } assert (Y0:= (CompactTotallyBoundedStreamCauchyLemma (B-A) k (((1#1)+k)*d1 + d2) Y)%Qpos). apply ball_weak_le with (proj1_sig (Qpos_power k (Z.of_nat A)*(exist _ _ Y0))%Qpos). 2: apply CompactImproveApproxCauchy2; exact Y. simpl. unfold Qdiv. set (C:=(((1 + proj1_sig k) * proj1_sig d1 + proj1_sig d2) * proj1_sig k ^ Z.of_nat A * / (1 - proj1_sig k))). setoid_replace ( proj1_sig k ^ Z.of_nat A * (((1 + proj1_sig k) * proj1_sig d1 + proj1_sig d2) * (1 - Qpower_positive (proj1_sig k) (Pos.of_succ_nat (B - A))) * / (1 - proj1_sig k))) with ((1 - proj1_sig k ^ Z.of_nat (S (B - A))) * C) by (unfold C; simpl; ring). apply Qle_trans with (1*C). apply Qmult_le_r. unfold C. apply (Qle_lt_trans _ (0 *(/(1-proj1_sig k)))). rewrite Qmult_0_l. discriminate. apply Qmult_lt_r. apply Qinv_lt_0_compat. unfold Qminus. rewrite <- Qlt_minus_iff. exact Y. apply (Qpos_ispos ((((1#1) + k) * d1 + d2) * Qpos_power k (Z.of_nat A))). rewrite -> Qle_minus_iff. ring_simplify. apply Qpower_pos_positive. apply Qpos_nonneg. rewrite Qmult_1_l. apply Qle_trans with (proj1_sig e1). unfold A in C. unfold C. rewrite Z2Nat.id. apply CompactTotallyBoundedIndexLemma. exact khalf. apply Z.log2_up_nonneg. rewrite <- Qplus_0_r at 1. apply Qplus_le_r, Qpos_nonneg. Qed. Definition CompactTotallyBounded_fun (s:Compact X) (k d1 d2:Qpos) (khalf : proj1_sig k <= 1#2) (pt:X) (Hpt : InFinEnumC pt (approximate s d1)) : Complete X := Build_RegularFunction (@CompactTotallyBounded_prf s k d1 d2 pt Hpt khalf). (** The limit is inside the compact set *) Lemma CompactTotallyBoundedInCompact : forall (s:Compact X) (k d1 d2:Qpos) (khalf : proj1_sig k <= 1#2) (pt:X) Hpt, inCompact (@CompactTotallyBounded_fun s k d1 d2 khalf pt Hpt) s. Proof. intros s k d1 d2 khalf pt Hpt e1 e2. simpl. destruct (@StreamInCompactApprox (Z.to_nat (CompactTotallyBoundedIndex e1 d1 d2)) s k d1 d2 pt Hpt) as [q Hq Hq0]. apply FinSubset_ball_closed. intros d dpos. apply FinSubset_ball_weak_le with (d + (proj1_sig q + proj1_sig e2)). simpl. rewrite -> Qle_minus_iff. setoid_replace (proj1_sig e1 + proj1_sig e2 + d + - (d + (proj1_sig q + proj1_sig e2))) with (proj1_sig e1 + - proj1_sig q) by (simpl; ring). rewrite <- Qle_minus_iff. unfold QposEq in Hq0. rewrite -> Hq0. eapply Qle_trans;[|apply (CompactTotallyBoundedIndexLemma e1 k d1 d2)]. simpl. rewrite Z2Nat.id. cut (0 <= proj1_sig k ^ (CompactTotallyBoundedIndex e1 d1 d2)). { generalize ( proj1_sig k ^ (CompactTotallyBoundedIndex e1 d1 d2)). intros z Hz. clear - Hz khalf. apply Qle_shift_div_l. unfold Qminus. rewrite <- Qlt_minus_iff. apply (Qle_lt_trans _ _ _ khalf). reflexivity. rewrite <- Qmult_assoc, Qmult_comm. apply Qmult_le_compat_r. 2: exact Hz. apply (Qle_trans _ ((1 + proj1_sig k) * proj1_sig d1 + 0)). rewrite Qplus_0_r, Qmult_comm. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply Qplus_le_r. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qplus_le_r, Qpos_nonneg. } apply Qpower_pos. apply Qpos_nonneg. apply Z.log2_up_nonneg. exact khalf. eapply FinSubset_ball_triangle_r;[|apply regFun_prf]. replace d with (proj1_sig (exist _ _ dpos)) by reflexivity. apply FinSubset_ball_weak_le with (e1:=0). apply Qpos_nonneg. assumption. Qed. (** The limit is close to the initial starting point *) Lemma CompactTotallyBoundedNotFar : forall (s:Compact X) (k d1 d2:Qpos) (khalf : proj1_sig k <= 1#2) (pt:X) (Hpt : InFinEnumC pt (approximate s d1)), ball (((1 + proj1_sig k)*proj1_sig d1 + proj1_sig d2) / (1 - proj1_sig k)) (Cunit pt) (@CompactTotallyBounded_fun s k d1 d2 khalf pt Hpt). Proof. intros s k d1 d2 khalf pt Hpt e1 e2. simpl. assert (proj1_sig k < 1) as Z. { apply (Qle_lt_trans _ _ _ khalf). reflexivity. } pose proof (CompactTotallyBoundedStreamCauchyLemma (Z.to_nat (CompactTotallyBoundedIndex e2 d1 d2)) _ (((1#1)+k)*d1 + d2)%Qpos Z) as Z0. apply ball_weak_le with (proj1_sig (exist _ _ Z0)). 2: apply CompactImproveApproxCauchy1; exact Z. simpl. apply Qle_trans with (((1 + proj1_sig k) * proj1_sig d1 + proj1_sig d2) / (1 - proj1_sig k)). apply Qmult_le_compat_r. - rewrite <- (Qmult_1_r ( (1 + proj1_sig k) * proj1_sig d1 + proj1_sig d2)) at 2. apply Qmult_le_l. apply (Qpos_ispos (((1#1)+k)*d1 + d2)). rewrite -> Qle_minus_iff. ring_simplify. apply Qpower_pos_positive. apply Qpos_nonneg. - apply Qlt_le_weak, Qinv_lt_0_compat. unfold Qminus. rewrite <- Qlt_minus_iff. exact Z. - apply (Qle_trans _ (0 + (((1 + proj1_sig k) * proj1_sig d1 + proj1_sig d2) / (1 - proj1_sig k)) + 0)). rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl. apply Qplus_le_compat. 2: apply Qpos_nonneg. apply Qplus_le_compat. apply Qpos_nonneg. apply Qle_refl. Qed. Fixpoint MapInFinEnumC {Y : Type} (l : list X) (f : forall pt : X, InFinEnumC pt l -> Y) { struct l } : list Y. Proof. destruct l as [|m l]. - exact nil. - apply cons. apply (f m). apply InFinEnumC_weaken; left; reflexivity. exact (MapInFinEnumC Y l (fun pt H => (f pt (FinSubset_ball_cons H)))). Defined. Lemma QuarterLeHalf : 1#4 <= 1#2. Proof. discriminate. Qed. (** Using CompactTotallyBounded_fun we can map the approximation of a compact set to a new enumeration that contains only points inside the compact sets, without moving the points too much *) Definition CompactTotalBound (s:Compact X) (e:Qpos) : list (Complete X) := MapInFinEnumC (CompactTotallyBounded_fun s (1#4)%Qpos ((1#5)*e) ((1#5)*e) QuarterLeHalf). Lemma CompactTotalBoundNotFar : forall (s:Compact X) (e:Qpos), @ball (FinEnum (Complete X)) ((3#5)*proj1_sig e) (map Cunit (approximate s ((1#5)*e)%Qpos)) (CompactTotalBound s e). Proof. intros s e. unfold CompactTotalBound. generalize (CompactTotallyBoundedNotFar s (1#4)%Qpos ((1#5)*e) ((1#5)*e) QuarterLeHalf). generalize (CompactTotallyBounded_fun s (1 # 4) ((1 # 5) * e) ((1 # 5) * e) QuarterLeHalf). induction (approximate s ((1 # 5) * e)%Qpos) as [|a s0]; intros H L. - apply ball_refl. apply (Qpos_nonneg ((3#5)*e)). - unfold Qdiv in L. split. apply (Qpos_nonneg ((3#5)*e)). split; intros x Hx. + apply FinSubset_ball_orC in Hx. destruct Hx as [G | Hx | Hx] using orC_ind. auto using existsC_stable. apply existsWeaken. exists (H a (InFinEnumC_weaken X a (a :: s0) (or_introl eq_refl))). split. intro abs; contradict abs. exists (H a (InFinEnumC_weaken X a (a :: s0) (or_introl eq_refl))). split. left. reflexivity. reflexivity. rewrite -> Hx. setoid_replace ((3 # 5) * proj1_sig e) with (((5 # 4) * proj1_sig ((1 # 5) * e)%Qpos + proj1_sig ((1 # 5) * e)%Qpos) * (4 # 3)) by (simpl; ring). apply L. set (H':=(fun pt (Hpt : InFinEnumC pt s0) => H pt (FinSubset_ball_cons Hpt))). assert (L':forall (pt : X) (Hpt : InFinEnumC pt s0), ball (m:=Complete X) (((1 + proj1_sig (1 # 4)%Qpos) * proj1_sig ((1 # 5) * e)%Qpos + proj1_sig ((1 # 5) * e)%Qpos) * / (1 - proj1_sig (1 # 4)%Qpos)) (Cunit pt) (H' pt Hpt)). { intros pt Hpt. apply L. } destruct (IHs0 H' L') as [_ [A _]]. destruct (A x Hx) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. exact (FinSubset_ball_cons Hy0). + apply FinSubset_ball_orC in Hx. destruct Hx as [G | Hx | Hx] using orC_ind. auto using existsC_stable. apply existsWeaken. exists (Cunit a). split. intro abs; contradict abs. exists (Cunit a). split. left. reflexivity. reflexivity. rewrite -> Hx. setoid_replace ((3 # 5) * proj1_sig e) with (((5 # 4) * proj1_sig ((1 # 5) * e)%Qpos + proj1_sig ((1 # 5) * e)%Qpos) * (4 # 3)) by (simpl; ring). apply ball_sym, L. set (H':=(fun pt (Hpt : InFinEnumC pt s0) => H pt (FinSubset_ball_cons Hpt))). assert (L':forall (pt : X) (Hpt : InFinEnumC pt s0), ball (m:=Complete X) (((1 + proj1_sig (1 # 4)%Qpos) * proj1_sig ((1 # 5) * e)%Qpos + proj1_sig ((1 # 5) * e)%Qpos) * / (1 - proj1_sig (1 # 4)%Qpos)) (Cunit pt) (H' pt Hpt)). intros pt Hpt. apply L. destruct (IHs0 H' L') as [_ [_ A]]. destruct (A x Hx) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. exact (FinSubset_ball_cons Hy0). Qed. (** This means that our compact sets are totally bounded. *) Lemma CompactTotallyBoundedA : forall s e y, In y (CompactTotalBound s e) -> inCompact y s. Proof. intros s e y. unfold CompactTotalBound. generalize (CompactTotallyBoundedInCompact s (1#4)%Qpos ((1#5)*e) ((1#5)*e) QuarterLeHalf). generalize (CompactTotallyBounded_fun s (1#4)%Qpos ((1#5)*e) ((1#5)*e) QuarterLeHalf). generalize (approximate s ((1 # 5) * e)%Qpos). intros l. induction l. contradiction. intros F L [H|H]. rewrite <- H. apply L. eapply (IHl);[|apply H]. intros pt Hpt. apply L. Qed. Lemma CompactTotallyBoundedB : forall s e x, (inCompact x s) -> exists y, In y (CompactTotalBound s e) /\ ball (proj1_sig e) x y. Proof. intros s e x Hx. assert (Z:proj1_sig ((1 # 20) * e + (1 # 5) * e)%Qpos < proj1_sig ((7 # 20) * e)%Qpos). rewrite -> Qlt_minus_iff. simpl. ring_simplify. apply (Qpos_ispos ((200#2000)*e)). destruct (AlmostInExists_weak Z (Hx _ _)) as [y [Hy0 Hy1]]. clear Z. unfold CompactTotalBound. revert Hy0. cut (forall pt Hpt, ball ((3#5)*proj1_sig e) (Cunit pt) (@CompactTotallyBounded_fun s (1#4)%Qpos ((1#5)*e) ((1#5)*e) QuarterLeHalf pt Hpt)). { generalize (CompactTotallyBounded_fun s (1#4)%Qpos ((1#5)*e) ((1#5)*e) QuarterLeHalf). generalize (approximate s ((1 # 5) * e)%Qpos). intros l. induction l. contradiction. intros F HF [H|H]. econstructor. split. left. reflexivity. rewrite <- H in Hy1. clear - Hy1 HF. assert (QposEq e ((1#20)*e + (7#20)*e + (3#5)*e)) by (unfold QposEq; simpl; ring). unfold QposEq in H. rewrite H. clear H. apply ball_triangle with (Cunit a);[|apply HF]. apply ball_triangle with (Cunit (approximate x ((1#20)*e)%Qpos)). apply ball_approx_r. rewrite -> ball_Cunit. assumption. edestruct (fun F HF => IHl F HF H) as [y' [Hy'0 Hy'1]]; [|exists y';split;[right;apply Hy'0|assumption]]. intros pt Hpt. apply HF. } intros pt Hpt. assert (QposEq ((3#5)*e) ((5#3)*((1#5)*e) + (4#3)*((1#5)*e))) by (unfold QposEq; simpl; ring). unfold QposEq in H. rewrite H. clear H. pose proof (CompactTotallyBoundedNotFar s (1#4)%Qpos ((1 # 5) * e) ((1 # 5) * e) QuarterLeHalf Hpt). setoid_replace (proj1_sig ((5 # 3) * ((1 # 5) * e) + (4 # 3) * ((1 # 5) * e))%Qpos) with (((1 + proj1_sig (1 # 4)%Qpos) * proj1_sig ((1 # 5) * e)%Qpos + proj1_sig ((1 # 5) * e)%Qpos) / (1 - proj1_sig (1 # 4)%Qpos)). apply H. simpl. unfold Qdiv. setoid_replace (/ (1 - (1 # 4))) with (4#3) by reflexivity. ring. Qed. Lemma CompactTotallyBounded : forall s, TotallyBoundedSubset _ (fun z => inCompact z s). Proof. intros s e. exists (CompactTotalBound s e). apply CompactTotallyBoundedA. apply CompactTotallyBoundedB. Defined. (** And hence our compact sets are Bishop compact. *) Lemma CompactAsBishopCompact : forall s, CompactSubset _ (fun z => inCompact z s). Proof. intros s. split. apply CompactCompleteSubset. apply CompactTotallyBounded. abstract ( intros a b Hab; unfold inCompact; rewrite -> Hab; reflexivity). Defined. End CompactTotallyBounded. (** ** Bishop Compact is Compact. Next we must show that Bishop compact sets are compact according to our definition. Given a Bishop compact set we construct finite enumerations that approximate that set. *) Definition BishopCompactAsCompact_raw (P:Complete X->Prop) (HP:CompactSubset _ P) (e:QposInf) : (FinEnum X) := match e with |QposInfinity => nil |Qpos2QposInf e' => (let (l,_,_) := (totallyBoundedSubset HP ((1#2)*e')) in map (fun x => approximate x (Qpos2QposInf ((1#2)*e'))) l)%Qpos end. (** These approximations are coherent *) Lemma BishopCompactAsCompact_prf : forall P (HP:CompactSubset _ P), is_RegularFunction (@ball (FinEnum X)) (BishopCompactAsCompact_raw HP). Proof. cut (forall (P : RegularFunction (@ball X) -> Prop) (HP : CompactSubset (Complete X) P) (e1 e2 : Qpos), hemiMetric X (proj1_sig e1 + proj1_sig e2) (fun a : X => InFinEnumC a (let (l, _, _) := totallyBoundedSubset HP ((1 # 2) * e1)%Qpos in map (fun x : RegularFunction (@ball X) => approximate x ((1 # 2) * e1)%Qpos) l)) (fun a : X => InFinEnumC a (let (l, _, _) := totallyBoundedSubset HP ((1 # 2) * e2)%Qpos in map (fun x : RegularFunction (@ball X) => approximate x ((1 # 2) * e2)%Qpos) l))). intros Z P [HP0 HP HP1] e1 e2. split. apply (Qpos_nonneg (e1+e2)). split. apply Z. apply (hemiMetric_wd1 X (proj1_sig (e2+e1)%Qpos)). simpl; ring. apply Z. intros P [HP0 HP HP1] e1 e2 x Hx. unfold totallyBoundedSubset in Hx. destruct (HP ((1 # 2) * e1)%Qpos) as [l Hl0 Hl1]. unfold totallyBoundedSubset. destruct (HP ((1 # 2) * e2)%Qpos) as [r Hr0 Hr1]. simpl in *. assert (Z0:existsC (Complete X) (fun x' => In x' l /\ ball ((1#2)*proj1_sig e1) (Cunit x) x')). clear - Hx HP1. induction l. exfalso; exact (FinSubset_ball_nil Hx). simpl in Hx. apply FinSubset_ball_orC in Hx. destruct Hx as [ G | Hx | Hx] using orC_ind. auto using existsC_stable. apply existsWeaken. exists a. split; auto with *. rewrite -> Hx. apply (@ball_approx_l _ _ ((1#2)*e1)%Qpos). destruct (IHl Hx) as [G | z [Hz0 Hz1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists z. auto with *. destruct Z0 as [ G | z [Hz0 Hz1] ] using existsC_ind. auto using existsC_stable. destruct (Hr1 _ (Hl0 _ Hz0)) as [ y [Hy0 Hy1]]. apply existsWeaken. exists (approximate y (Qpos2QposInf ((1#2)%Qpos*e2))). split. clear - Hy0. induction r. elim Hy0. destruct Hy0 as [Hy0 | Hy0]. rewrite Hy0. intro abs; contradict abs. exists (approximate y ((1 # 2) * e2)%Qpos). split. left. reflexivity. reflexivity. apply FinSubset_ball_cons. apply IHr; auto. setoid_replace (proj1_sig e1+proj1_sig e2) with (proj1_sig ((1#2)*e1 + (1#2)*e2 + (1#2)*e2 + (1#2)*e1))%Qpos by (simpl; ring). apply ball_weak. apply Qpos_nonneg. rewrite <- ball_Cunit. repeat eapply ball_triangle. apply Hz1. change (ball (proj1_sig ((1 # 2) * e2)%Qpos) z y) in Hy1. apply Hy1. apply ball_approx_r. Qed. (** Hence Bishop compact sets are compact in our sense. *) Definition BishopCompactAsCompact (P:Complete X->Prop) (HP:CompactSubset _ P) : Compact X := Build_RegularFunction (BishopCompactAsCompact_prf HP). Section Isomorphism. (** ** Isomorphism We claim that Bishop compact sets correspond to our compact sets, but to be sure we need to show that the definitions are isomoprhic. We need to show that the conversions back and forth are equivalent to the identity. *) Hypothesis locatedX : locatedMetric X. Lemma BishopCompact_Compact_BishopCompact1 : forall (P:Complete X->Prop) (HP:CompactSubset _ P) x, P x -> inCompact x (BishopCompactAsCompact HP). Proof. intros P [HP1 HP2 HP3] x Hx e1 e2. unfold BishopCompactAsCompact, approximate, BishopCompactAsCompact_raw, totallyBoundedSubset. destruct (HP2 ((1 # 2) * e2)%Qpos) as [l Hl0 Hl1]. destruct (Hl1 x Hx) as [y [Hy0 Hy1]]. clear - Hy0 Hy1. induction l. contradiction. destruct Hy0 as [Hy0|Hy0]. rewrite Hy0. intro abs; contradict abs. exists (approximate y ((1 # 2) * e2)%Qpos). split. left. reflexivity. rewrite <- ball_Cunit. assert (QposEq (e1+e2) (e1 + ((1 # 2) * e2 + (1 # 2) * e2))) by (unfold QposEq; simpl; ring). unfold QposEq in H. rewrite H. clear H. apply ball_triangle with x. apply ball_approx_l. apply ball_triangle with y. assumption. apply ball_approx_r. apply FinSubset_ball_cons. apply IHl. auto with *. Qed. Lemma BishopCompact_Compact_BishopCompact2 : forall (P:Complete X->Prop) (HP:CompactSubset _ P) x, inCompact x (BishopCompactAsCompact HP) -> P x. Proof. intros P [HP1 HP2 HP3] x Hx. assert (Y:forall e:Qpos, proj1_sig ((7#8)*e)%Qpos < proj1_sig e). intros. rewrite -> Qlt_minus_iff. simpl. ring_simplify. apply (Qpos_ispos ((1#8)*e)). assert (A:forall (e:Qpos), {y | P y /\ ball (m:=Complete X) (proj1_sig e) x y}). intros e. assert (Hx':=Hx ((1#16)*e)%Qpos ((1#2)*e)%Qpos). unfold BishopCompactAsCompact, approximate, BishopCompactAsCompact_raw, totallyBoundedSubset in Hx'. clear - Hx' locatedX Y. destruct (HP2 ((1 # 2) * ((1 # 2) * e))%Qpos) as [l Hl0 Hl1]. clear Hl1. induction l. exfalso; exact (FinSubset_ball_nil Hx'). destruct (@Complete_located _ locatedX _ _ x a (Y e)) as [A|A]. exists a. split; auto. apply IHl. intros y Hy. apply Hl0; auto with *. apply FinSubset_ball_orC in Hx'. destruct Hx' as [G | Hx' | Hx'] using orC_ind. intro abs; contradict G; intro G; contradiction. elim A. clear - Hx'. rewrite <- ball_Cunit in Hx'. assert (QposEq ((7 # 8) * e) ((1#16)*e + ((1 # 16) * e + (1 # 2) * e) + (((1 # 2) * ((1 # 2) * e))))) by (unfold QposEq; simpl; ring). unfold QposEq in H. rewrite H. clear H. eapply ball_triangle. eapply ball_triangle. apply ball_approx_r. apply Hx'. apply ball_approx_l. assumption. set (f:=fun e => (let (y,_):= (A e) in y)). assert (Hf0:forall e:Qpos, ball (m:=Complete X) (proj1_sig e) (f e) x). intros e. unfold f. destruct (A e) as [y [_ Hy]]. apply ball_sym. assumption. assert (Hf: is_RegularFunction (@ball (Complete X)) (fun e => match e with QposInfinity => f (1#1)%Qpos | Qpos2QposInf e' => f e' end)). intros e1 e2. apply ball_triangle with x. apply Hf0. apply ball_sym. apply Hf0. set (f':=(Build_RegularFunction Hf)). assert (Hf1 : forall (e:Qpos), P (approximate f' e)). intros e. simpl; unfold f. destruct (A e). tauto. destruct (HP1 f') as [y Hy]. intros [e|]; apply Hf1. unfold ExtSubset in HP3. rewrite -> (HP3 x y); auto. rewrite <- Cunit_eq. rewrite -> m. intros e1 e2. apply ball_sym. rewrite Qplus_comm. apply ball_weak. rewrite Qplus_0_r. apply Qpos_nonneg. apply Hf0. Qed. Lemma BishopCompact_Compact_BishopCompact : forall (P:Complete X->Prop) (HP:CompactSubset _ P) x, P x <-> inCompact x (BishopCompactAsCompact HP). Proof. intros P HP x. split. apply BishopCompact_Compact_BishopCompact1. apply BishopCompact_Compact_BishopCompact2. Qed. Lemma Compact_BishopCompact_Compact : forall s, msp_eq s (BishopCompactAsCompact (CompactAsBishopCompact locatedX s)). Proof. intros s e1 e2. rewrite Qplus_0_r. assert (QposEq (e1 + e2) (e1 + (1#5)*((1#2)*e2) + ((3#5)*((1#2)*e2) + (1#2)*e2) + (1#10)*e2)) by (unfold QposEq; simpl; ring). unfold QposEq in H. rewrite H. clear H. apply ball_weak. apply Qpos_nonneg. apply ball_triangle with (approximate s ((1#5)*((1#2)*e2))%Qpos). apply regFun_prf. clear e1. rewrite -> FinEnum_map_Cunit. apply ball_triangle with (CompactTotalBound locatedX s ((1 # 2) * e2)). apply CompactTotalBoundNotFar. unfold ball, FinEnum. unfold BishopCompactAsCompact, approximate, BishopCompactAsCompact_raw. unfold totallyBoundedSubset, CompactAsBishopCompact, CompactTotallyBounded. change (FinEnum_ball (Complete X)) with (@ball (FinEnum (Complete X))). induction (CompactTotalBound locatedX s ((1 # 2) * e2)). apply ball_refl. apply Qpos_nonneg. destruct IHl as [_ [IHlA IHlB]]. split. apply Qpos_nonneg. split; intros x Hx; apply FinSubset_ball_orC in Hx; (destruct Hx as [G | Hx | Hx] using orC_ind; [auto using existsC_stable |apply existsWeaken |]). exists (Cunit (approximate a ((1 # 2) * e2)%Qpos)). split. intro abs; contradict abs. exists (Cunit (approximate a ((1 # 2) * e2)%Qpos)). split. left. reflexivity. reflexivity. rewrite -> Hx. apply ball_approx_r. destruct (IHlA x Hx) as [ G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. apply FinSubset_ball_cons. exact Hy0. exists a. split. intro abs; contradict abs. exists a. split. left. reflexivity. reflexivity. rewrite -> Hx. apply ball_approx_l. destruct (IHlB x Hx) as [ G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. apply FinSubset_ball_cons. exact Hy0. Qed. End Isomorphism. End Compact. Require Import CoRN.metric2.Prelength. Section CompactDistr. Variable X : MetricSpace. (** ** FinEnum distributes over Complete The FiniteEnumeration monad distributes over the Completion monad. This corresponds to a function from FinEnum (Complete X) to Complete (FinEnum X). *) Definition FinCompact_raw (x: FinEnum (Complete X)) (e:QposInf) : FinEnum X := map (fun x => approximate x e) x. Lemma FinCompact_prf : forall x, is_RegularFunction (@ball (FinEnum X)) (FinCompact_raw x). Proof. intros x. cut (forall (e1 e2:Qpos), hemiMetric X (proj1_sig e1 + proj1_sig e2) (fun a : X => InFinEnumC a (FinCompact_raw x e1)) (fun a : X => InFinEnumC a (FinCompact_raw x e2))). intros L e1 e2. split. apply (Qpos_nonneg (e1+e2)). split; auto. eapply hemiMetric_wd1;[|apply L]. unfold QposEq; simpl; ring. intros e1 e2. induction x. apply hemiMetric_refl. apply (Qpos_nonneg (e1+e2)). intros b Hb. apply FinSubset_ball_orC in Hb. destruct Hb as [G | Hb | Hb] using orC_ind. auto using existsC_stable. apply existsWeaken. exists (approximate a e2). split. intro abs; contradict abs. exists (approximate a e2). split. left. reflexivity. reflexivity. rewrite -> Hb. apply regFun_prf. destruct (IHx b Hb) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. apply FinSubset_ball_cons. exact Hy0. Qed. Definition FinCompact_fun (x: FinEnum (Complete X)) : Compact X := Build_RegularFunction (FinCompact_prf x). Lemma FinCompact_uc : is_UniformlyContinuousFunction FinCompact_fun Qpos2QposInf. Proof. cut (forall e (d1 d2:Qpos) (a b : FinEnum (Complete X)), (hemiMetric (Complete X) e (fun a0 : Complete X => InFinEnumC a0 a) (fun a : Complete X => InFinEnumC a b)) -> (hemiMetric X (proj1_sig d1 + e + proj1_sig d2) (fun a0 : X => InFinEnumC a0 (approximate (FinCompact_fun a) d1)) (fun a0 : X => InFinEnumC a0 (approximate (FinCompact_fun b) d2)))). - intros L e a b [_ [Hab0 Hab1]] d1 d2. split. apply (Qpos_nonneg (d1+e+d2)). split; auto. eapply hemiMetric_wd1;[|apply L;apply Hab1]. unfold QposEq; simpl; ring. - intros e d1 d2 a b Hab c Hc. simpl in Hc. unfold FinCompact_raw in Hc. assert (existsC (Complete X) (fun d => InFinEnumC d a /\ msp_eq c (approximate d d1))). clear - Hc. induction a as [|a a0]. exfalso; exact (FinSubset_ball_nil Hc). simpl in Hc. apply FinSubset_ball_orC in Hc. destruct Hc as [ G | Hc | Hc] using orC_ind. auto using existsC_stable. apply existsWeaken. exists a. split; auto. intro abs; contradict abs. exists a. split. left. reflexivity. reflexivity. destruct (IHa0 Hc) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. apply FinSubset_ball_cons. exact Hy0. destruct H as [ G | d [Hd0 Hd1]] using existsC_ind. auto using existsC_stable. destruct (Hab d Hd0) as [ G | z [Hz0 Hz1]] using existsC_ind. auto using existsC_stable. clear - Hd1 Hz0 Hz1. induction b. exfalso; exact (FinSubset_ball_nil Hz0). apply FinSubset_ball_orC in Hz0. destruct Hz0 as [ G | Hz0 | Hz0] using orC_ind. auto using existsC_stable. apply existsWeaken. exists (approximate a d2). split. intro abs; contradict abs. exists (approximate a d2). split. left. reflexivity. reflexivity. rewrite -> Hz0 in Hz1. rewrite -> Hd1. apply Hz1. destruct (IHb Hz0) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split; auto. apply FinSubset_ball_cons. exact Hy0. Qed. Definition FinCompact : FinEnum (Complete X) --> Compact X := Build_UniformlyContinuousFunction FinCompact_uc. Lemma FinCompact_correct : forall x (s:FinEnum (Complete X)), InFinEnumC x s <-> inCompact x (FinCompact s). Proof. intros x s. split. intros H e1 e2. simpl. induction s. exfalso; exact (FinSubset_ball_nil H). move H after IHs. apply FinSubset_ball_orC in H. destruct H as [G | H | H] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists (approximate a e2). split. left. reflexivity. specialize (H e1 e2). rewrite Qplus_0_r in H. exact H. apply FinSubset_ball_cons. apply IHs; auto. intros H. induction s. exfalso; exact (FinSubset_ball_nil (H (1#1) (1#1))%Qpos). unfold inCompact in H. simpl in H. set (P:= fun n (b:bool) => if b then (let e1 := (1#P_of_succ_nat n)%Qpos in let e2 := e1 in (ball (m:=X) (proj1_sig e1 + proj1_sig e2) (approximate x (Qpos2QposInf e1)) (approximate a (Qpos2QposInf e2)))) else (let e1 := (1#P_of_succ_nat n)%Qpos in let e2 := e1 in (FinSubset_ball (proj1_sig e1 + proj1_sig e2) (approximate x (Qpos2QposInf e1)) (FinCompact_raw s (Qpos2QposInf e2))))). assert (L: (forall n : nat, existsC bool (fun x => ~ ~ In x (true :: false :: nil) /\ P n x))). { intros n. specialize (H (1#P_of_succ_nat n)%Qpos (1#P_of_succ_nat n)%Qpos). apply FinSubset_ball_orC in H. destruct H as [ G | L | L] using orC_ind. auto using existsC_stable. apply existsWeaken. exists true. split; auto with *. apply existsWeaken. exists false. split; auto with *. } destruct (infinitePidgeonHolePrinicple _ _ _ L) as [G | c [_ Hc]] using existsC_ind. intro abs. contradict G; intro G. contradiction. destruct c. - intro abs; contradict abs. exists a. split. left. reflexivity. unfold P in Hc. apply ball_eq. intros e epos. destruct (((1#4)*exist _ _ epos)%Qpos) as [[en ed] He] eqn:des. destruct en as [|en|en]. inversion He. 2: inversion He. simpl in He. destruct (Hc (pred (nat_of_P ed))) as [G | m [Hm0 Hm1]] using existsC_ind. apply (msp_stable (msp _)), G. set (m' := (1#P_of_succ_nat m)%Qpos). apply ball_weak_le with (proj1_sig (m' + (m' + m') + m')%Qpos). unfold m'. simpl. setoid_replace ((1 # Pos.of_succ_nat m) + ((1 # Pos.of_succ_nat m) + (1 # Pos.of_succ_nat m)) + (1 # Pos.of_succ_nat m)) with ((1#P_of_succ_nat m)/(1#4)) by (simpl; field). apply Qle_shift_div_r. reflexivity. rewrite -> Qmult_comm. setoid_replace ((1#4)*e) with (proj1_sig ((1#4)*exist _ _ epos)%Qpos) by reflexivity. rewrite des. unfold Qle; simpl. rewrite Zpos_mult_morphism. apply Z.le_trans with (Z.pos en * Z.pos ed)%Z. rewrite Z.mul_comm, <- Z.le_mul_diag_r. apply Pos.le_1_l. reflexivity. apply Zmult_le_compat_l. 2: discriminate. rewrite Pos.of_nat_succ. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite <- (Nat.lt_succ_pred O _). apply le_n_S. exact Hm0. apply Pos2Nat.is_pos. discriminate. eapply ball_triangle;[|apply ball_approx_l]. eapply ball_triangle;[apply ball_approx_r|]. rewrite -> ball_Cunit. apply Hm1. - apply FinSubset_ball_cons. apply IHs. unfold P in Hc. intros e1 e2. apply FinSubset_ball_closed. intros d dpos. destruct (((1#4)*exist _ _ dpos)%Qpos) as [[dn dd] Hd] eqn:des. destruct dn as [|dn|dn]. inversion Hd. 2: inversion Hd. destruct (Hc (pred (nat_of_P dd))) as [G | m [Hm0 Hm1]] using existsC_ind. intro abs; contradict G; intro G; contradiction. set (m' := (1#P_of_succ_nat m)%Qpos). apply FinSubset_ball_weak_le with (proj1_sig ((e1 + m') + (m' + m') + (m' + e2))%Qpos). simpl. rewrite -> Qle_minus_iff. setoid_replace ( proj1_sig e1 + proj1_sig e2 + d + - (proj1_sig e1 + (1 # Pos.of_succ_nat m) + ((1 # Pos.of_succ_nat m) + (1 # Pos.of_succ_nat m)) + ((1 # Pos.of_succ_nat m) + proj1_sig e2))) with (d + - (proj1_sig m' + (proj1_sig m' + proj1_sig m') + proj1_sig m')) by (simpl; ring). rewrite <- Qle_minus_iff. unfold m'. autorewrite with QposElim. setoid_replace (proj1_sig (1 # Pos.of_succ_nat m)%Qpos + (proj1_sig (1 # Pos.of_succ_nat m)%Qpos + proj1_sig (1 # Pos.of_succ_nat m)%Qpos) + proj1_sig (1 # Pos.of_succ_nat m)%Qpos) with ((1#P_of_succ_nat m)/(1#4)) by (simpl; field). apply Qle_shift_div_r. constructor. rewrite -> Qmult_comm. setoid_replace ((1#4)*d) with (proj1_sig ((1#4)*exist _ _ dpos)%Qpos) by reflexivity. rewrite des. unfold Qle; simpl. rewrite Zpos_mult_morphism. apply Z.le_trans with (Z.pos dn * Z.pos dd)%Z. rewrite Z.mul_comm, <- Z.le_mul_diag_r. apply Pos.le_1_l. reflexivity. apply Zmult_le_compat_l. 2: auto with *. rewrite Pos.of_nat_succ. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite <- (Nat.lt_succ_pred O _). apply le_n_S. exact Hm0. apply Pos2Nat.is_pos. discriminate. eapply FinSubset_ball_triangle_r;[|apply regFun_prf]. eapply FinSubset_ball_triangle_l;[apply regFun_prf|]. apply Hm1. Qed. Lemma CompactCompleteCompact_prf : forall x, is_RegularFunction (@ball (Compact X)) (Cmap_raw FinCompact x). Proof. intros x e1 e2. unfold Cmap_raw. simpl. apply (@FinCompact_uc (e1+e2)%Qpos). unfold ball_ex. apply regFun_prf. Qed. Definition CompactCompleteCompact_fun x : Complete (Compact X) := Build_RegularFunction (CompactCompleteCompact_prf x). Lemma CompactCompleteCompact_uc : is_UniformlyContinuousFunction CompactCompleteCompact_fun Qpos2QposInf. Proof. intros e a b H d1 d2. simpl in *. apply (@FinCompact_uc (d1+e+d2)%Qpos). apply H. Qed. Definition CompactCompleteCompact : Compact (Complete X) --> Compact X := uc_compose Cjoin (Build_UniformlyContinuousFunction CompactCompleteCompact_uc). Lemma CompactCompleteCompact_correct : forall x s, inCompact x s <-> inCompact (Cjoin x) (CompactCompleteCompact s). Proof. intros x s. split. intros H e1 e2. simpl. unfold Cjoin_raw. simpl. assert (Z:=(H ((1#2)*e1) ((1#2)*e2))%Qpos). intro abs. unfold FinSubset_ball in Z. contradict Z; intros [z [Hz1 Hz0]]. revert abs. apply InFinEnumC_weaken in Hz1. rewrite -> FinCompact_correct in Hz1. apply FinSubset_ball_closed. intros d dpos. assert (Z0:=(Hz0 ((1#2)*e1) ((1#2)*exist _ _ dpos))%Qpos). assert (Z1:=(Hz1 ((1#2)*exist _ _ dpos) ((1#2)*e2))%Qpos). simpl in Z1. set (w0:=((1 # 2) * e1 + ((1 # 2) * e1 + (1 # 2) * e2) + (1 # 2) * exist _ _ dpos)%Qpos) in *. set (w1:= ((1 # 2) * exist _ _ dpos + (1 # 2) * e2)%Qpos) in *. assert (Qeq (proj1_sig e1 + proj1_sig e2 + d) (proj1_sig (w0 + w1)%Qpos)) by (unfold w0, w1; simpl; ring). apply (@FinSubset_ball_wd_full _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. eapply FinSubset_ball_triangle_l. apply Z0. apply Z1. intros H e1 e2. apply FinSubset_ball_closed. intros d dpos. set (d':=((1#4)*exist _ _ dpos)%Qpos). assert (Qeq (proj1_sig e1 + proj1_sig e2 + d) (proj1_sig ((e1 + (1#2)*d' + (1#2)*d') + (((d' + d') + (1#2)*d') + ((1#2)*d' + e2)))%Qpos)) by (unfold d'; simpl; ring). apply (@FinSubset_ball_wd_full _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. eapply FinSubset_ball_triangle_l. eapply ball_triangle. apply regFun_prf. apply ball_approx_r. eapply FinSubset_ball_triangle_r;[|apply regFun_prf]. assert (Z:= (H d' d')). simpl in Z. unfold Cjoin_raw in Z. intro abs. unfold FinSubset_ball in Z. contradict Z; intros [z [Hz1 Hz0]]. revert abs. apply InFinEnumC_weaken in Hz1. change (InFinEnumC (X:=X) z (approximate (FinCompact (approximate s ((1 # 2) * d')%Qpos)) ((1 # 2) * d')%Qpos)) in Hz1. apply FinSubset_ball_triangle_l with (Cunit z). rewrite -> ball_Cunit. assumption. clear - Hz1. induction ((approximate s ((1 # 2) * d')%Qpos)). exfalso; exact (FinSubset_ball_nil Hz1). apply FinSubset_ball_orC in Hz1. destruct Hz1 as [G | Hz1 | Hz1] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists a. split. left. reflexivity. rewrite -> Hz1. apply ball_approx_l. apply FinSubset_ball_cons. apply IHm; auto. Qed. End CompactDistr. (* A more synthetic presentation of CompactTotallyBounded_fun. *) Lemma InApproxCompact : forall {X : MetricSpace} (K : Compact X) (x : X) (d:Qpos) (e : Q), InFinEnumC x (approximate K d) -> locatedMetric X -> proj1_sig d < e -> { y:Complete X | inCompact y K /\ ball e (Cunit x) y }. Proof. intros X K x d e inx locX ltde. pose ((1#2)*(e-proj1_sig d)) as d2. pose (d2 / (proj1_sig d + e)) as k. assert (0 < proj1_sig d + e) as depos. { apply (Qlt_trans _ (proj1_sig d+0)). rewrite Qplus_0_r. apply Qpos_ispos. apply Qplus_lt_r. apply (Qlt_trans _ (proj1_sig d)). apply Qpos_ispos. exact ltde. } assert (0 < d2) as d2pos. { unfold d2. apply (Qle_lt_trans _ ((1#2)*0)). discriminate. apply Qmult_lt_l. reflexivity. unfold Qminus. rewrite <- Qlt_minus_iff. exact ltde. } assert (0 < k) as kpos. { unfold k. apply (Qpos_ispos (exist _ _ d2pos * Qpos_inv (exist _ _ depos))%Qpos). } assert (k <= 1#2) as khalf. { unfold k. apply Qle_shift_div_r. exact depos. unfold d2. apply Qmult_le_l. reflexivity. unfold Qminus. rewrite Qplus_comm. apply Qplus_le_l. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. } exists (CompactTotallyBounded_fun locX K (exist _ _ kpos) d (exist _ _ d2pos) khalf inx). split. apply CompactTotallyBoundedInCompact. pose proof (CompactTotallyBoundedNotFar locX K (exist _ _ kpos) d (exist _ _ d2pos) khalf inx) as H. apply (ball_weak_le) with (e:= (((1 + proj1_sig (exist (Qlt 0) k kpos)) * proj1_sig d + proj1_sig (exist (Qlt 0) d2 d2pos)) / (1 - proj1_sig (exist (Qlt 0) k kpos)))). 2: exact H. simpl. apply Qle_shift_div_r. unfold Qminus. rewrite <- Qlt_minus_iff. apply (Qle_lt_trans _ _ _ khalf). reflexivity. apply (Qplus_le_l _ _ (e*k - proj1_sig d)). ring_simplify. rewrite <- Qmult_plus_distr_r. unfold k, Qdiv. rewrite <- Qmult_assoc. rewrite <- (Qmult_comm (proj1_sig d + e)), Qmult_inv_r, Qmult_1_r. unfold d2. rewrite <- Qmult_plus_distr_l. setoid_replace ((1 # 2) + (1 # 2)) with 1%Q by reflexivity. rewrite Qmult_1_l. ring_simplify. apply Qle_refl. intro abs. rewrite abs in depos. exact (Qlt_irrefl 0 depos). Qed. Section CompactImage. (** ** Compact Image Given a function f : X -> Y, the image by f of a subset A : X -> Prop could be defined as fun y:Y => exists x:X, A x /\ y = f x. When the subset A is compact and f is uniformly continuous, we want to prove that the image f(A) is also compact. However this is hard to do with those definitions and the notion of Bishop compactness given above, because we have to lift exists x:X, A x /\ y = f x from Prop to Type, by developing an algorithm that constructs x. Our definition of compact by finite approximations allows to define the compact images directly in Prop, simply by mapping f over the approximations. In that definition, the function really applied is Cmap f : Complete X -> Complete Y. So a good example is X = Y = Q here. For more interesting continuous functions we will need X = Q and Y = R, which we will handle by joining the double completion in section CompactImageBind below. *) Variable z : Qpos. Variable X Y : MetricSpace. Hypothesis plX : PrelengthSpace X. Hypothesis plFEX : PrelengthSpace (FinEnum X). Variable f : X --> Y. Lemma FinSubset_ball_map : forall (e d:Qpos) a (b:FinEnum X), (QposInf_le d (mu f e)) -> FinSubset_ball (proj1_sig d) a b -> FinSubset_ball (proj1_sig e) (f a) (FinEnum_map z f b). Proof. intros e d a b Hd Hab. induction b. exfalso; exact (FinSubset_ball_nil Hab). apply FinSubset_ball_orC in Hab. destruct Hab as [G | Hab | Hab] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists (f a0). split. left. reflexivity. apply uc_prf. eapply ball_ex_weak_le. apply Hd. assumption. apply FinSubset_ball_cons. apply IHb. auto. Qed. Lemma FinSubset_ball_map2 : forall (e1 e2 d:Qpos) a (b:FinEnum X), (QposInf_le d ((mu f e1) + (mu f e2))) -> FinSubset_ball (proj1_sig d) a b -> FinSubset_ball (proj1_sig e1 + proj1_sig e2) (f a) (FinEnum_map z f b). Proof. intros e1 e2 d a b Hd Hab. induction b. exfalso; exact (FinSubset_ball_nil Hab). apply FinSubset_ball_orC in Hab. destruct Hab as [G | Hab | Hab] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists (f a0). split. left. reflexivity. apply (mu_sum plX e2 (e1::nil) f). eapply ball_ex_weak_le. apply Hd. assumption. apply FinSubset_ball_cons. apply IHb. auto. Qed. (* The approximations of K : Compact X are finite lists of X which do not have to be exactly inside K. When mapping a function f over those approximations, we must make sure that they converge towards the exact images of points of K by f. *) Definition CompactImage : Compact X --> Compact Y := Cmap plFEX (FinEnum_map z f). Lemma CompactImage_approx : forall (s : Compact X) (e : Qpos), approximate (CompactImage s) e = map f (approximate s (match mu f e with | QposInfinity => z | Qpos2QposInf d => d end)). Proof. intros. simpl. unfold FinEnum_map_modulus. destruct (mu f e); reflexivity. Qed. (* The image of s by Cmap f is included in CompactImage s. *) Lemma CompactImage_correct1 : forall (x : Complete X) (s : Compact X), inCompact x s -> inCompact (Cmap plX f x) (CompactImage s). Proof. intros x s H e1 e2. apply FinSubset_ball_closed. intros d1 d1pos. assert (Qeq (proj1_sig e1 + proj1_sig e2 + d1) (proj1_sig ((e1 + (1#4)*exist _ _ d1pos) + ((1#4)*exist _ _ d1pos + ((1#4)*exist _ _ d1pos)) + ((1#4)*exist _ _ d1pos + e2))%Qpos)) by (simpl; ring). apply (@FinSubset_ball_wd_full _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. apply FinSubset_ball_triangle_r with (approximate (CompactImage s) ((1#4)*exist _ _ d1pos)%Qpos); [|apply regFun_prf]. apply FinSubset_ball_triangle_l with (approximate (Cmap plX f x) ((1#4)*exist _ _ d1pos)%Qpos); [apply regFun_prf|]. remember (mu f ((1 # 4) * exist _ _ d1pos)) as dum. simpl. unfold FinEnum_map_modulus. simpl in Heqdum. rewrite <- Heqdum. destruct dum. - apply (FinSubset_ball_map2 ((1 # 4) * exist _ _ d1pos) ((1 # 4) * exist _ _ d1pos) (q+q)%Qpos). 2: apply H. simpl. simpl in Heqdum. rewrite <- Heqdum. apply Qle_refl. - assert (Z:=H z z). simpl in Z. destruct (@approximate _ (FinEnum_ball X) s z). exfalso; exact (FinSubset_ball_nil Z). intro abs; contradict abs. exists (f m). split. left. reflexivity. set (d:=((1 # 4) * exist _ _ d1pos)%Qpos). apply (mu_sum plX d (d::nil) f). simpl. unfold d. simpl. rewrite <- Heqdum. constructor. Qed. (* The reverse inclusion. To finish the proof, we would need sequential compacity, that this produced sequence in Complete X has a converging subsequence. *) Lemma CompactImage_correct2 : forall (y : Complete Y) (s : Compact X), locatedMetric Y -> inCompact y (CompactImage s) -> forall d:Qpos, { x:X | ball (proj1_sig d) (approximate y ((1 # 3) * d)%Qpos) (f x) /\ In x (approximate s (FinEnum_map_modulus z (mu f) ((1 # 3) * d))) }. Proof. intros y s locY inys d. specialize (inys ((1#3)*d)%Qpos ((1#3)*d)%Qpos). simpl in inys. assert ((1#3)*proj1_sig d+(1#3)*proj1_sig d < proj1_sig d) as H. { rewrite <- Qmult_plus_distr_l. rewrite <- (Qmult_1_l (proj1_sig d)) at 2. apply Qmult_lt_r. apply Qpos_ispos. reflexivity. } destruct (AlmostInExists locY H inys) as [n H0]. destruct ( @nth_error (msp_car Y) (@map (msp_car X) (msp_car Y) (@ucFun X Y f) (@approximate (list (msp_car X)) (FinEnum_ball X) s (Qpos2QposInf (FinEnum_map_modulus z (@mu X Y f) (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Zpos xH; Qden := xI xH |} (@eq_refl comparison Lt)) d))))) n) as [t|] eqn:des. 2: contradiction. destruct (nth_error (approximate s (FinEnum_map_modulus z (mu f) ((1#3)*d))) n) eqn:H1. - exists m. split. 2: exact (nth_error_In _ _ H1). pose proof (map_nth_error f n _ H1). simpl in des. simpl in H2. rewrite des in H2. inversion H2. subst t. clear H2 des. exact H0. - exfalso. apply nth_error_None in H1. rewrite <- (map_length f) in H1. apply nth_error_None in H1. simpl in des. simpl in H1. rewrite des in H1. discriminate. Qed. End CompactImage. Section CompactImageBind. Variable z : Qpos. Variable X Y : MetricSpace. Hypothesis plX : PrelengthSpace X. Hypothesis plFEX : PrelengthSpace (FinEnum X). Variable f : X --> Complete Y. Definition CompactImage_b : Compact X --> Compact Y := uc_compose (CompactCompleteCompact _) (CompactImage z plFEX f). Lemma CompactImage_b_correct1 : forall (x : Complete X) (s : Compact X), inCompact x s -> inCompact (Cbind plX f x) (CompactImage_b s). Proof. intros x s H. change (inCompact (Cjoin (Cmap_fun plX f x)) (CompactCompleteCompact _ (CompactImage z plFEX f s))). rewrite <- CompactCompleteCompact_correct. apply CompactImage_correct1;assumption. Qed. (* Lemma CompactImage_b_correctC *) End CompactImageBind. corn-8.20.0/metric2/Complete.v000066400000000000000000001204101473720167500160600ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.metric2.UniformContinuity. Require Export CoRN.model.structures.QposInf. Require Export CoRN.metric2.Classification. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.model.totalorder.QMinMax. Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. (** ** Complete metric space *) (** *** Regular functions A regular function is one way of representing elements in a complete metric space. A regular function that take a given error e, and returns an approximation within e of the value it is representing. These approximations must be coherent and the definition belows state this property. *) Definition is_RegularFunction {X:Type} (ball : Q->X->X->Prop) (x:QposInf -> X) : Prop := forall (e1 e2:Qpos), ball (proj1_sig e1 + proj1_sig e2) (x e1) (x e2). (** A regular function consists of an approximation function, and a proof that the approximations are coherent. *) Record RegularFunction {X:Type} (ball : Q->X->X->Prop) : Type := {approximate : QposInf -> X ;regFun_prf : is_RegularFunction ball approximate }. Lemma is_RegularFunction_wd : forall (X : MetricSpace) (x y:QposInf -> X), (forall q : Qpos, msp_eq (x q) (y q)) -> is_RegularFunction (@ball X) x -> is_RegularFunction (@ball X) y. Proof. intros. intros e1 e2. rewrite <- H, <- H. apply H0. Qed. Definition regFunEq {X:Type} (ball : Q->X->X->Prop) (f g : RegularFunction ball) : Prop := forall (e1 e2 : Qpos), ball (proj1_sig e1 + proj1_sig e2) (approximate f e1) (approximate g e2). Definition regFunBall {X:Type} (ball : Q->X->X->Prop) (e:Q) (f g : RegularFunction ball) : Prop := forall (d1 d2:Qpos), ball (proj1_sig d1 + e + proj1_sig d2) (approximate f d1) (approximate g d2). Section RegularFunction. Variable X:MetricSpace. (** The value of the approximation function at infinity is irrelevant, so we make a smart constructor that just takes a Qpos->X. *) Definition is_RegularFunction_noInf (x: Qpos -> X): Prop := forall e1 e2 : Qpos, ball (proj1_sig e1 + proj1_sig e2) (x e1) (x e2). Section mkRegularFunction. Variables (dummy: X). Let lift (f: Qpos -> X) (e: QposInf): X := match e with | QposInfinity => dummy (* if the recipient doesn't care, fine with me! *) | Qpos2QposInf e' => f e' end. Let transport (f: Qpos -> X): is_RegularFunction_noInf f -> is_RegularFunction (@ball X) (lift f). Proof. firstorder. Qed. Definition mkRegularFunction (f: Qpos -> X) (H: is_RegularFunction_noInf f) : RegularFunction (@ball X) := Build_RegularFunction (transport H). End mkRegularFunction. (** Regular functions form a metric space *) Lemma regFunEq_e : forall (f g : RegularFunction (@ball X)), (forall e : Qpos, ball (m:=X) (proj1_sig e + proj1_sig e) (approximate f e) (approximate g e)) -> (regFunEq f g). Proof. unfold regFunEq. intros f g H e1 e2. apply ball_closed. intros d dpos. setoid_replace (proj1_sig e1 + proj1_sig e2 + d) with ((proj1_sig e1 + ((1#4) *d) + (((1#4)*d) + ((1#4)*d)) +(((1#4)*d)+proj1_sig e2))) by (simpl; ring). eapply ball_triangle. eapply ball_triangle. apply (regFun_prf _ e1 ((1#4)*exist _ _ dpos)%Qpos). apply (H ((1 # 4) * exist (Qlt 0) d dpos)%Qpos). apply (regFun_prf _ ((1 # 4) * exist (Qlt 0) d dpos)%Qpos e2). Qed. Lemma regFunEq_e_small : forall (f g : RegularFunction (@ball X)) (E:Qpos), (forall (e:Qpos), proj1_sig e <= proj1_sig E -> ball (m:=X) (proj1_sig e+ proj1_sig e) (approximate f e) (approximate g e)) -> (regFunEq f g). Proof. intros f g E H. apply regFunEq_e. intros e. apply ball_closed. intros d dpos. assert (0 < (1#4)) as quarterPos. reflexivity. set (e':=Qpos_min (exist _ _ quarterPos*exist _ _ dpos) E). apply ball_weak_le with (proj1_sig ((e+e')+(e'+e')+(e'+e))%Qpos). apply (Qle_trans _ (proj1_sig ((e+exist _ _ quarterPos*exist _ _ dpos) +(exist _ _ quarterPos*exist _ _ dpos+exist _ _ quarterPos*exist _ _ dpos) +(exist _ _ quarterPos*exist _ _ dpos+e))%Qpos)). - simpl. ring_simplify. apply Qplus_le_r. apply (Qle_trans _ ((4#1) * ((1 # 4) * d))). 2: simpl; ring_simplify; apply Qle_refl. apply Qmult_le_l. reflexivity. apply Qpos_min_lb_l. - simpl. ring_simplify. apply Qle_refl. - apply ball_triangle with (approximate g e'). apply ball_triangle with (approximate f e'). apply regFun_prf. apply H. apply Qpos_min_lb_r. apply regFun_prf. Qed. Lemma regFunBall_wd : forall (e1 e2:Q) (x y : RegularFunction (@ball X)), (e1 == e2) -> (regFunBall e1 x y <-> regFunBall e2 x y). Proof. unfold regFunBall. split. - intros. rewrite <- H. apply H0. - intros. rewrite H. apply H0. Qed. Lemma regFun_is_MetricSpace : is_MetricSpace (@regFunBall _ (@ball X)). Proof. unfold regFunBall. split. - intros e epos f d1 d2. rewrite <- Qplus_assoc, (Qplus_comm e), Qplus_assoc. apply ball_weak. exact epos. apply regFun_prf. - intros e f g H d1 d2. apply ball_sym. rewrite Qplus_comm, <- (Qplus_comm e), Qplus_assoc. apply H. - intros e1 e2 a b c Hab Hbc d1 d2. apply ball_closed. intros d3 dpos. setoid_replace (proj1_sig d1+(e1+e2)+proj1_sig d2+d3) with ((proj1_sig d1 + e1 + (1#2)*d3)+((1#2)*d3 + e2 + proj1_sig d2)) by (simpl; ring). eapply ball_triangle. apply (Hab d1 ((1#2)*exist _ _ dpos)%Qpos). apply (Hbc ((1#2)*exist _ _ dpos)%Qpos). - intros e a b H d1 d2. apply ball_closed. intros d dpos. setoid_replace (proj1_sig d1+e+ proj1_sig d2+d) with (proj1_sig d1 + (e+d) + proj1_sig d2) by (simpl; ring). apply H, dpos. - intros. apply Qnot_lt_le. intro abs. assert (0 < -e * (1#3)). { apply (Qmult_lt_l _ _ (3#1)). reflexivity. apply (Qplus_lt_l _ _ e). ring_simplify. apply (Qlt_le_trans _ _ _ abs). discriminate. } specialize (H (exist _ _ H0) (exist _ _ H0)). simpl in H. apply msp_nonneg in H. 2: apply X. ring_simplify in H. apply (Qlt_not_le _ _ abs). apply (Qmult_le_l _ _ (3#9)). reflexivity. rewrite Qmult_0_r. exact H. - intros. apply (msp_stable (msp X)). intro abs. contradict H; intro H. apply abs. apply H. Qed. (** We define the completion of a metric space to be the space of regular functions *) Definition Complete : MetricSpace := Build_MetricSpace regFunBall_wd regFun_is_MetricSpace. Lemma regFunEq_equiv : forall (x y : Complete), regFunEq x y <-> msp_eq x y. Proof. (* Remove the middle 0. *) unfold regFunEq, msp_eq. split. - intros H e1 e2. rewrite Qplus_0_r. apply H. - intros H e1 e2. specialize (H e1 e2). rewrite Qplus_0_r in H. apply H. Qed. (** The ball of regular functions is related to the underlying ball in ways that you would expect. *) Lemma regFunBall_ball : forall (x y:Complete) (e0 : Q) (e1 e2:Qpos), ball e0 (approximate x e1) (approximate y e2) -> ball (proj1_sig e1 + e0 + proj1_sig e2) x y. Proof. intros x y e0 e1 e2 H d1 d2. setoid_replace (proj1_sig d1+(proj1_sig e1+e0+proj1_sig e2)+proj1_sig d2)%Q with ((proj1_sig d1+proj1_sig e1)+e0+(proj1_sig e2+proj1_sig d2)) by (simpl; ring). eapply ball_triangle. eapply ball_triangle. apply regFun_prf. apply H. apply regFun_prf. Qed. Lemma regFunBall_e : forall (x y:Complete) (e:Q), (forall d:Qpos, ball (proj1_sig d + e + proj1_sig d) (approximate x d) (approximate y d)) -> ball e x y. Proof. intros x y e H. apply ball_closed. intros d dpos. setoid_replace (e + d) with ((1#4)*d + ((1#4)*d+ e+(1#4)*d) + (1#4)*d) by (simpl; ring). apply (regFunBall_ball x y ((1 # 4) * d + e + (1 # 4) * d)%Q ((1#4)*exist _ _ dpos)%Qpos ((1#4)*exist _ _ dpos)%Qpos ). apply (H ((1#4)*(exist _ _ dpos))%Qpos). Qed. (** *** Cunit There is an injection from the original space to the complete space given by the constant regular function. *) Lemma Cunit_fun_prf (x:X) : is_RegularFunction (@ball X) (fun _ => x). Proof. intros d1 d2. apply ball_refl. apply (Qpos_nonneg (d1+d2)). Qed. Definition Cunit_fun (x:X) : Complete := Build_RegularFunction (Cunit_fun_prf x). Lemma Cunit_prf : is_UniformlyContinuousFunction Cunit_fun Qpos2QposInf. Proof. intros e a b Hab d1 d2. simpl in *. assert (QposEq (d1+e+d2) (e+(d1+d2))). { unfold QposEq; simpl; ring. } unfold QposEq in H. rewrite H. clear H. apply ball_weak. apply Qpos_nonneg. assumption. Qed. Definition Cunit : X --> Complete := Build_UniformlyContinuousFunction Cunit_prf. (** This injection preserves the metric *) Lemma ball_Cunit : forall (e:Q) a b, ball e (Cunit a) (Cunit b) <-> ball e a b. Proof. intros e a b. split. - intros. simpl in H. do 2 (apply ball_closed; intros). rewrite <- (Qplus_comm d). apply (H (exist _ _ H0) (exist _ _ H1)). - intros H d1 d2. pose proof (msp_nonneg (msp X) _ _ _ H). apply Qle_lteq in H0. destruct H0. apply (Cunit_prf (exist _ _ H0)). exact H. rewrite <- H0, Qplus_0_r. rewrite <- H0 in H. simpl. rewrite H. apply ball_refl. apply (Qpos_nonneg (d1+d2)). Qed. Lemma Cunit_eq : forall a b, msp_eq (Cunit a) (Cunit b) <-> msp_eq a b. Proof. intros a b. do 2 rewrite <- ball_eq_iff. split; intros H e epos; [rewrite <- (ball_Cunit e) | rewrite -> (ball_Cunit e)]; apply H; assumption. Qed. Lemma ball_approx_r : forall (x:Complete) (e:Qpos), ball (proj1_sig e) x (Cunit (approximate x e)). Proof. intros x e d1 d2. simpl. apply ball_weak. apply Qpos_nonneg. apply regFun_prf. Qed. Lemma ball_approx_l : forall (x:Complete) (e:Qpos), ball (proj1_sig e) (Cunit (approximate x e)) x. Proof. (* Set Firstorder Depth 6. firstorder fail with ball_sym ball_approx_r. *) pose ball_approx_r. pose ball_sym. auto. Qed. Lemma ball_ex_approx_r : forall (x:Complete) e, ball_ex e x (Cunit (approximate x e)). Proof. intros x [e|]; simpl. apply ball_approx_r. constructor. Qed. Lemma ball_ex_approx_l : forall (x:Complete) e, ball_ex e (Cunit (approximate x e)) x. Proof. intros x [e|]; simpl. apply ball_approx_l. constructor. Qed. Lemma regFunBall_Cunit (e: Qpos) (x: Complete) (y: X): regFunBall (proj1_sig e) x (Cunit y) <-> (forall d: Qpos, ball (proj1_sig d + proj1_sig e) (approximate x d) y). Proof with auto. unfold regFunBall. split; intros. apply ball_closed. simpl in *... intros. apply (H d (exist _ _ H0)). apply ball_weak... apply Qpos_nonneg. Qed. Lemma regFun_prf_ex : forall (r : Complete) (e1 e2 : QposInf), ball_ex (e1 + e2) (approximate r e1) (approximate r e2). Proof. intros r [e1|] [e2|]; try constructor. apply (@regFun_prf X (@ball X)). Qed. End RegularFunction. (* begin hide *) Arguments regFunEq_e_small [X]. Arguments is_RegularFunction [X]. Arguments Cunit {X}. Add Parametric Morphism X : (@Cunit_fun X) with signature (@msp_eq _) ==> (@msp_eq _) as Cunit_wd. Proof. exact (@uc_wd _ _ Cunit). Qed. (* end hide *) (** If two functions between complete metric spaces are equal on the images of [Cunit], then they are equal everywhere *) Lemma lift_eq_complete {X Y : MetricSpace} (f g : Complete X --> Y) : (forall x : X, msp_eq (f (Cunit x)) (g (Cunit x))) -> (forall x : Complete X, msp_eq (f x) (g x)). Proof. intros A x. apply ball_eq; intros e epos. pose (exist (Qlt 0) (1#2) eq_refl) as half. set (e2 := (half * exist _ _ epos)%Qpos). set (d := QposInf_min (mu f e2) (mu g e2)). setoid_replace e with (proj1_sig (e2+e2)%Qpos) by (simpl; ring). apply ball_triangle with (b := f (Cunit (approximate x d))). + apply (UniformContinuity.uc_prf f). apply (ball_ex_weak_le _ d); [apply QposInf_min_lb_l | apply ball_ex_approx_r]. + apply (ball_wd _ eq_refl _ _ (A (approximate x d)) _ _ (reflexivity _)). apply (UniformContinuity.uc_prf g). apply (ball_ex_weak_le _ d); [apply QposInf_min_lb_r | apply ball_ex_approx_l]. Qed. Lemma lift_eq_complete_2 : forall (A B C: MetricSpace) (f g : Complete A --> Complete B --> C), (forall a b, msp_eq (f (Cunit a) (Cunit b)) (g (Cunit a) (Cunit b))) -> (forall a b, msp_eq (f a b) (g a b)). Proof. intros A B C f g H a. apply lift_eq_complete. intro b. revert a. assert (@is_UniformlyContinuousFunction (Complete A) C (fun a => f a (Cunit b)) (mu f)). { intros e x y H0. apply (uc_prf f e x y H0). } assert (@is_UniformlyContinuousFunction (Complete A) C (fun a => g a (Cunit b)) (mu g)). { intros e x y H1. apply (uc_prf g e x y H1). } apply (@lift_eq_complete A C (Build_UniformlyContinuousFunction H0) (Build_UniformlyContinuousFunction H1)). simpl. intro a. apply H. Qed. Section Faster. Variable X : MetricSpace. Variable x : Complete X. (** A regular function is equivalent to the same function that returns a better approximation with a given error. One would not generally want to do this when doing computation; however it is quite a useful substitution to be able to make during reasoning. *) Section FasterInGeneral. Variable f : Qpos -> Qpos. Hypothesis Hf : forall x, proj1_sig (f x) <= proj1_sig x. Lemma fasterIsRegular : is_RegularFunction (@ball X) (fun e => (approximate x (QposInf_bind f e))). Proof. intros e1 e2. simpl. apply ball_weak_le with (proj1_sig (f e1 + f e2)%Qpos). simpl. apply Qplus_le_compat. apply Hf. apply Hf. apply regFun_prf. Qed. Definition faster : Complete X := Build_RegularFunction fasterIsRegular. Lemma fasterIsEq : msp_eq faster x. Proof. apply regFunEq_equiv. apply regFunEq_e. intros e. simpl. apply ball_weak_le with (proj1_sig (f e + e)%Qpos). simpl. apply Qplus_le_l. apply Hf. apply regFun_prf. Qed. End FasterInGeneral. Lemma QreduceApprox_prf : forall (e:Qpos), proj1_sig (Qpos_red e) <= proj1_sig e. Proof. intros e. destruct e. simpl. rewrite -> Qred_correct. apply Qle_refl. Qed. Definition QreduceApprox := faster Qpos_red QreduceApprox_prf. Lemma QreduceApprox_Eq : msp_eq QreduceApprox x. Proof. apply (fasterIsEq _ _). Qed. (** In particular, halving the error of the approximation is a common case. *) Lemma doubleSpeed_prf : forall (e:Qpos), proj1_sig ((1#2) * e)%Qpos <= proj1_sig e. Proof. intros e. autorewrite with QposElim. rewrite -> Qle_minus_iff. simpl. ring_simplify. apply (Qle_trans _ ((1#2) * 0)). rewrite Qmult_0_r. apply Qle_refl. apply Qmult_le_l. reflexivity. destruct e. apply Qlt_le_weak, q. Qed. Definition doubleSpeed := faster (Qpos_mult (exist (Qlt 0) (1#2) eq_refl)) doubleSpeed_prf. Lemma doubleSpeed_Eq : msp_eq doubleSpeed x. Proof. apply (fasterIsEq _ _). Qed. End Faster. Section Cjoin. Variable X : MetricSpace. (** *** Cjoin There is an injection from a twice completed space into a once completed space. This injection along with [Cunit] forms an isomorphism between a twice completed space and a once completed space. This proves that a complete metric space is complete. *) Definition Cjoin_raw (x:Complete (Complete X)) (e:QposInf) := (approximate (approximate x (QposInf_mult (Qpos2QposInf (1#2)) e)) (QposInf_mult (Qpos2QposInf (1#2)) e))%Qpos. Lemma Cjoin_fun_prf (x:Complete (Complete X)) : is_RegularFunction (@ball X) (Cjoin_raw x). Proof. intros d1 d2. rewrite <- ball_Cunit. setoid_replace (proj1_sig d1 + proj1_sig d2) with (proj1_sig ((1#2)*d1 + ((1#2)*d1+(1#2)*d2) + (1#2)*d2)%Qpos) by (simpl; ring). apply ball_triangle with (approximate x (Qpos_mult (exist (Qlt 0) (1#2) eq_refl) d2)). apply ball_triangle with (approximate x (Qpos_mult (exist (Qlt 0) (1#2) eq_refl) d1)). apply ball_approx_l. apply regFun_prf. apply ball_approx_r. Qed. Definition Cjoin_fun (x:Complete (Complete X)) : Complete X := Build_RegularFunction (Cjoin_fun_prf x). Lemma Cjoin_prf : is_UniformlyContinuousFunction Cjoin_fun Qpos2QposInf. Proof. intros e x y Hab d1 d2. do 2 rewrite <- ball_Cunit. setoid_replace (proj1_sig d1 + proj1_sig e + proj1_sig d2) with (proj1_sig (((1#2)*d1 + (1#2)*d1) + e + (((1#2)*d2) + (1#2)*d2)))%Qpos by (simpl; ring). apply ball_triangle with y. apply ball_triangle with x. apply ball_triangle with (Cunit (approximate x ((1#2) * d1)%Qpos)). rewrite -> ball_Cunit. refine (ball_approx_l _ _). apply ball_approx_l. assumption. eapply ball_triangle. apply ball_approx_r. rewrite -> ball_Cunit. refine (ball_approx_r _ _). Qed. Definition Cjoin : (Complete (Complete X)) --> (Complete X) := Build_UniformlyContinuousFunction Cjoin_prf. End Cjoin. Arguments Cjoin {X}. Lemma Cjoin_ball : forall (X : MetricSpace) (x : Complete (Complete X)) (e : Qpos), ball (proj1_sig e) (Cjoin_fun x) (approximate x e). Proof. intros X x e d1 d2. simpl. unfold Cjoin_raw. simpl. destruct x as [x xreg]; simpl. specialize (xreg ((1#2)*d1)%Qpos e ((1#2)*d1)%Qpos d2). simpl in xreg. setoid_replace (proj1_sig d1 + proj1_sig e + proj1_sig d2) with ((1 # 2) * proj1_sig d1 + ((1 # 2) * proj1_sig d1 + proj1_sig e) + proj1_sig d2) by ring. exact xreg. Qed. Section Cmap. Variable X Y : MetricSpace. Variable f : X --> Y. (** *** Cmap (slow) Uniformly continuous functions can be lifted to the completion of metric spaces. A faster version that works under some mild assumptions will be given later. But first the most generic version that we call [Cmap_slow]. *) Definition Cmap_slow_raw (x:Complete X) (e:QposInf) := f (approximate x (QposInf_mult (Qpos2QposInf (1#2)%Qpos) (QposInf_bind (mu f) e))). Lemma Cmap_slow_raw_strongInf : forall (x:Complete X) (d:QposInf) (e:QposInf), QposInf_le d (QposInf_mult (Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)) (QposInf_bind (mu f) e)) -> ball_ex e (f (approximate x d)) (Cmap_slow_raw x e). Proof. intros x [d|] [e|] Hd; try constructor. - apply uc_prf. simpl. case_eq (mu f e); simpl; trivial. intros q Hq. simpl in Hd. rewrite Hq in Hd. eapply ball_weak_le;[|apply regFun_prf]. simpl. simpl in Hd. apply (Qplus_le_l _ _ (-(1#2)*proj1_sig q)). ring_simplify. exact Hd. - unfold Cmap_slow_raw. simpl in *. apply uc_prf. destruct (mu f e) as [q|]. contradiction. constructor. Qed. Lemma Cmap_slow_raw_strong : forall (x:Complete X) (d:QposInf) (e:Qpos), QposInf_le d (QposInf_mult (Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)) (mu f e)) -> ball (proj1_sig e) (f (approximate x d)) (Cmap_slow_raw x e). Proof. intros. apply (Cmap_slow_raw_strongInf x d e). assumption. Qed. Lemma Cmap_slow_fun_prf (x:Complete X) : is_RegularFunction (@ball Y) (Cmap_slow_raw x). Proof. intros e1 e2. unfold Cmap_slow_raw. cut (forall (e1 e2:Qpos), (QposInf_le (mu f e2) (mu f e1)) -> ball (m:=Y) (proj1_sig e1 + proj1_sig e2) (f (approximate x (QposInf_mult (Qpos2QposInf (1#2)) (QposInf_bind (mu f) e1)))) (f (approximate x (QposInf_mult (Qpos2QposInf (1#2)) (QposInf_bind (mu f) e2))))). intros H. (* move this out *) assert (forall a b, {QposInf_le a b}+{QposInf_le b a}). intros [a|] [b|]; simpl; try tauto. apply Qle_total. destruct (H0 (mu f e2) (mu f e1)). auto. apply ball_sym. rewrite Qplus_comm. auto. clear e1 e2. intros e1 e2 H. apply ball_weak. apply Qpos_nonneg. apply ball_sym. simpl. apply Cmap_slow_raw_strong. simpl. destruct (mu f e1). simpl. destruct (mu f e2). simpl. apply Qmult_le_l. reflexivity. exact H. elim H. constructor. Qed. Definition Cmap_slow_fun (x:Complete X) : Complete Y := Build_RegularFunction (Cmap_slow_fun_prf x). Definition Cmap_slow_prf : is_UniformlyContinuousFunction Cmap_slow_fun (fun e => (QposInf_mult (Qpos2QposInf (1#2)) (mu f e))%Qpos). Proof. intros e0 x y Hxy. intros e1 e2. simpl. unfold Cmap_slow_raw. set (d1:=(QposInf_bind (fun y' : Qpos => ((1#2) * y')%Qpos) (mu f e1))). set (d2:=(QposInf_bind (fun y' : Qpos => ((1#2) * y')%Qpos) (mu f e2))). set (d0:=(QposInf_bind (fun y' : Qpos => ((1#4) * y')%Qpos) (mu f e0))). apply ball_triangle with (f (approximate y (QposInf_min d0 d2 ))). apply ball_triangle with (f (approximate x (QposInf_min d0 d1))). - apply uc_prf. eapply ball_ex_weak_le;[|apply regFun_prf_ex]. unfold d1. simpl. destruct (mu f e1); try constructor. destruct d0. simpl. rewrite Q_Qpos_min. simpl. apply (Qplus_le_l _ _ (-(1#2)*proj1_sig q)). ring_simplify. apply Qmin_lb_r. simpl. ring_simplify. apply Qle_refl. - apply uc_prf. destruct (mu f e0); try constructor. cut (forall z0 z1:Qpos, (proj1_sig z0 <= proj1_sig ((1#4)*q)%Qpos) -> (proj1_sig z1 <= proj1_sig ((1#4)*q)%Qpos) -> ball (proj1_sig q) (approximate x z0) (approximate y z1)). intros H. destruct d1; destruct d2; simpl; apply H; autorewrite with QposElim; auto with *. intros z0 z1 Hz0 Hz1. eapply ball_weak_le. 2:apply Hxy. rewrite -> Qle_minus_iff in *. simpl. simpl in Hz0, Hz1. apply (Qplus_le_compat _ _ _ _ Hz0) in Hz1. ring_simplify in Hz1. setoid_replace (8 # 16) with (1#2) in Hz1. ring_simplify. exact Hz1. reflexivity. - apply uc_prf. eapply ball_ex_weak_le;[|apply regFun_prf_ex]. unfold d2. simpl. destruct (mu f e2); try constructor. destruct d0; simpl. rewrite Q_Qpos_min. simpl. apply (Qplus_le_l _ _ (-(1#2)*proj1_sig q)). ring_simplify. apply Qmin_lb_r. ring_simplify. apply Qle_refl. Qed. Definition Cmap_slow : (Complete X) --> (Complete Y) := Build_UniformlyContinuousFunction Cmap_slow_prf. End Cmap. (** Cbind can be defined in terms of map and join *) Definition Cbind_slow (X Y:MetricSpace) (f:X-->Complete Y) := uc_compose Cjoin (Cmap_slow f). (** The completion operation, along with the map functor from a monad in the catagory of metric spaces. *) Section Monad_Laws. Variable X Y Z : MetricSpace. Notation "a =m b" := (msp_eq a b) (at level 70, no associativity). Lemma MonadLaw1 : forall a, Cmap_slow_fun (uc_id X) a =m a. Proof. intros x e1 e2. rewrite Qplus_0_r. simpl. eapply ball_weak_le; [|apply regFun_prf]. simpl. apply Qplus_le_l. rewrite <- (Qmult_1_l (proj1_sig e1)), Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. discriminate. Qed. Lemma MonadLaw2 : forall (f:Y --> Z) (g:X --> Y) a, Cmap_slow_fun (uc_compose f g) a =m (Cmap_slow_fun f (Cmap_slow_fun g a)). Proof. simpl. intros f g x e1 e2. rewrite Qplus_0_r. set (a := approximate (Cmap_slow_fun (uc_compose f g) x) e1). set (b:=(approximate (Cmap_slow_fun f (Cmap_slow_fun g x)) e2)). set (d0 := (QposInf_min (QposInf_mult (Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)) (mu (uc_compose f g) e1)) ((Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)) * QposInf_bind (mu g) (QposInf_mult (Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)) (mu f e2))))). apply ball_triangle with ((uc_compose f g) (approximate x d0)). apply ball_sym. apply Cmap_slow_raw_strong. unfold d0. apply QposInf_min_lb_l. unfold b; simpl. unfold Cmap_slow_raw. apply uc_prf. simpl. destruct (mu f e2) as [q|]; try constructor. simpl. apply ball_weak_le with (proj1_sig ((1#2)*q)%Qpos). simpl. rewrite <- (Qmult_1_l (proj1_sig q)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply (Cmap_slow_raw_strong g x d0). apply QposInf_min_lb_r. Qed. Lemma MonadLaw3 : forall (f:X --> Y) a, (Cmap_slow_fun f (Cunit_fun _ a)) =m (Cunit_fun _ (f a)). Proof. intros f x e1 e2. rewrite Qplus_0_r. refine (regFun_prf _ _ _). Qed. Lemma MonadLaw4 : forall (f:X --> Y) a, (Cmap_slow_fun f (Cjoin_fun a)) =m (Cjoin_fun ((Cmap_slow_fun (Cmap_slow f)) a)). Proof. intros f x e1 e2. pose (exist (Qlt 0) (1#2) eq_refl) as half. pose (exist (Qlt 0) (1#4) eq_refl) as quarter. pose (exist (Qlt 0) (1#8) eq_refl) as eightth. set (e2' := (half*e2)%Qpos). set (d0 := (QposInf_min (Qpos2QposInf quarter*(mu f e1)) (Qpos2QposInf (exist (Qlt 0) (1#8) eq_refl) *(mu f (half*e2))))%QposInf). simpl. unfold Cmap_slow_raw; simpl. unfold Cjoin_raw; simpl. unfold Cmap_slow_raw; simpl. assert (halfhalf: forall q, QposEq (quarter * q) (half * (half * q))%Qpos). { unfold QposEq. intro. simpl. ring. } apply ball_triangle with (f (approximate (approximate x d0) d0)). rewrite Qplus_0_r. apply uc_prf. destruct (mu f e1) as [q|]; try constructor. simpl. do 2 rewrite <- ball_Cunit. unfold d0. assert (QposEq q ((quarter*q + quarter*q) + (quarter*q+ quarter*q))%Qpos) as qeq. { unfold QposEq. simpl. ring. } pose proof (ball_wd (Complete (Complete X)) qeq) as bwd. apply (bwd _ _ (reflexivity _) _ _ (reflexivity _)). apply ball_triangle with x. apply ball_triangle with (Cunit (approximate x (half * (half * q))%Qpos)). rewrite -> ball_Cunit. unfold QposEq in halfhalf. rewrite halfhalf. apply ball_approx_l. unfold QposEq in halfhalf. rewrite halfhalf. apply ball_approx_l. apply ball_triangle with (Cunit (approximate x d0)). change (ball_ex (quarter * q)%Qpos x (Cunit (approximate x d0))). apply ball_ex_weak_le with (d0)%QposInf. apply QposInf_min_lb_l. destruct d0 as [d0|]; try constructor. apply ball_approx_r. rewrite -> ball_Cunit. change (ball_ex (quarter * q)%Qpos (approximate x d0) (Cunit (approximate (approximate x d0) d0))). apply ball_ex_weak_le with (d0)%QposInf. apply QposInf_min_lb_l. destruct d0 as [d0|]; try constructor. apply ball_approx_r. apply ball_sym. apply ball_weak_le with (proj1_sig (half*e2)%Qpos). simpl. rewrite <- (Qmult_1_l (proj1_sig e2)), Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply uc_prf. unfold half. simpl. unfold half in d0. simpl in d0. destruct (@mu X Y f (exist (Qlt 0) (1 # 2) (@eq_refl comparison Lt) * e2)); try constructor. simpl. do 2 rewrite <- ball_Cunit. assert (QposEq q ((half*q + quarter*q)+ (eightth*q+ eightth*q))%Qpos) as qeq. { unfold QposEq. simpl. ring. } pose proof (ball_wd (Complete (Complete X)) qeq) as bwd. apply (bwd _ _ (reflexivity _) _ _ (reflexivity _)). apply ball_triangle with x. apply ball_triangle with (Cunit (approximate x (half * (half * q))%Qpos)). - rewrite -> ball_Cunit. apply ball_approx_l. - unfold QposEq in halfhalf. rewrite halfhalf. apply ball_approx_l. - apply ball_triangle with (Cunit (approximate x d0)). change (ball_ex (eightth * q)%Qpos x (Cunit (approximate x d0))). apply ball_ex_weak_le with (d0)%QposInf. apply QposInf_min_lb_r. destruct d0 as [d0|]; try constructor. apply ball_approx_r. rewrite -> ball_Cunit. change (ball_ex (eightth * q)%Qpos (approximate x d0) (Cunit (approximate (approximate x d0) d0))). apply ball_ex_weak_le with (d0)%QposInf. apply QposInf_min_lb_r. destruct d0 as [d0|]; try constructor. apply ball_approx_r. Qed. Lemma MonadLaw5 : forall a, (Cjoin_fun (X:=X) (Cunit_fun _ a)) =m a. Proof. intros x e1 e2. simpl. setoid_replace (proj1_sig e1+0+proj1_sig e2) with (proj1_sig ((1#2)*e1 + e2 + (1#2)*e1)%Qpos) by (simpl; ring). apply ball_weak. apply Qpos_nonneg. apply regFun_prf. Qed. Lemma MonadLaw6 : forall a, Cjoin_fun ((Cmap_slow_fun (X:=X) Cunit) a) =m a. Proof. intros a e1 e2. simpl. setoid_replace (proj1_sig e1 + 0 + proj1_sig e2) with (proj1_sig ((1#2)*((1#2)*e1) + e2 + (3#4)*e1)%Qpos) by (simpl; ring). apply ball_weak. apply Qpos_nonneg. apply regFun_prf. Qed. Lemma MonadLaw7 : forall a, Cjoin_fun ((Cmap_slow_fun (X:=Complete (Complete X)) Cjoin) a) =m Cjoin_fun (Cjoin_fun a). Proof. intros x e1 e2. pose (half := fun e:Qpos => ((1#2)*e)%Qpos). apply ball_weak_le with (proj1_sig ((half (half e1)) + ((half (half e1)) + (half (half e1) + (half (half e2))) + (half (half e2))) + (half e2))%Qpos). unfold half. simpl. ring_simplify. apply Qplus_le_l. rewrite <- (Qmult_1_l (proj1_sig e1)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply (regFun_prf x). Qed. (** This final law isn't a monad law, rather it completes the isomorphism between a twice completed metric space and a one completed metric space. *) Lemma CunitCjoin : forall a, (Cunit_fun _ (Cjoin_fun (X:=X) a)) =m a. Proof. intros x e1 e2 d1 d2. rewrite Qplus_0_r. change (ball (proj1_sig d1 + (proj1_sig e1 + proj1_sig e2) + proj1_sig d2) (approximate (approximate x ((1#2) * d1)%Qpos) ((1#2) * d1)%Qpos) (approximate (approximate x e2) (Qpos2QposInf d2))). apply ball_weak_le with (proj1_sig (((1#2) * d1 + ((1#2) * d1 + e2) + d2))%Qpos). rewrite -> Qle_minus_iff. simpl. ring_simplify. auto with *. apply (regFun_prf x). Qed. End Monad_Laws. (** The monad laws are sometimes expressed in terms of bind and unit. *) Lemma BindLaw1 : forall X Y (f:X--> Complete Y) a, msp_eq (Cbind_slow f (Cunit_fun _ a)) (f a). Proof. intros X Y f a. change (msp_eq (Cjoin (Cmap_slow_fun f (Cunit_fun X a))) (f a)). rewrite -> (MonadLaw3 f a). apply MonadLaw5. Qed. Lemma BindLaw2 : forall X a, (msp_eq (Cbind_slow (Cunit:X --> Complete X) a) a). Proof. apply MonadLaw6. Qed. Lemma BindLaw3 : forall X Y Z (a:Complete X) (f:X --> Complete Y) (g:Y-->Complete Z), msp_eq (Cbind_slow g (Cbind_slow f a)) (Cbind_slow (uc_compose (Cbind_slow g) f) a). Proof. intros X Y Z a f g. change (msp_eq (Cjoin (Cmap_slow_fun g (Cjoin_fun (Cmap_slow f a)))) (Cjoin (Cmap_slow_fun (uc_compose (Cbind_slow g) f) a))). rewrite -> (MonadLaw2 (Cbind_slow g) f). unfold Cbind_slow. rewrite -> (MonadLaw4 g). rewrite -> (MonadLaw2 (Cjoin (X:=Z)) (Cmap_slow g)). symmetry. apply MonadLaw7. Qed. (** *** Strong Monad The monad is a strong monad because the map function itself is a uniformly continuous function. *) Section Strong_Monad. Variable X Y : MetricSpace. Let X_Y := UniformlyContinuousSpace X Y. Let CX_CY := UniformlyContinuousSpace (Complete X) (Complete Y). Lemma Cmap_strong_slow_prf : is_UniformlyContinuousFunction ((Cmap_slow (Y:=Y)):(X_Y -> CX_CY)) Qpos2QposInf. Proof. intros e f g H. split. apply Qpos_nonneg. intro x. apply ball_closed. intros e0 epos. set (he0 := ((1#2)*exist _ _ epos)%Qpos). set (d0 := QposInf_min (Qpos2QposInf (1#2)*(mu f he0)) (Qpos2QposInf (1#2)*(mu g he0))). set (a0 := approximate x d0). setoid_replace (proj1_sig e+e0) with (proj1_sig (he0 + e + he0)%Qpos) by (simpl; ring). apply ball_triangle with (Cunit (g a0)). apply ball_triangle with (Cunit (f a0)). assert (QposEq he0 he0) by reflexivity. pose proof (MonadLaw3 f a0). symmetry in H1. apply (ball_wd _ H0 _ _ (reflexivity _) _ _ H1). clear H1 H0. refine (uc_prf _ _ _ _ _). simpl. destruct (mu f he0) as [d1|];[|constructor]. eapply ball_ex_weak_le with d0. apply QposInf_min_lb_l. destruct d0 as [d0|];[|constructor]. apply ball_approx_r. rewrite -> ball_Cunit. apply H. assert (QposEq he0 he0) by reflexivity. pose proof (MonadLaw3 g a0). symmetry in H1. apply (ball_wd _ H0 _ _ H1 _ _ (reflexivity _)). clear H1 H0. apply (uc_prf (Cmap_slow g)). simpl. destruct (mu g he0) as [d2|];[|constructor]. eapply ball_ex_weak_le with d0. apply QposInf_min_lb_r. destruct d0 as [d0|];[|constructor]. apply ball_approx_l. Qed. Definition Cmap_strong_slow : (X --> Y) --> (Complete X --> Complete Y) := Build_UniformlyContinuousFunction Cmap_strong_slow_prf. (** Using strength we can show that [Complete] forms an applicative functor. The [ap] function is useful for making multiple argument maps. *) Definition Cap_slow_raw (f:Complete (X --> Y)) (x:Complete X) (e:QposInf) := approximate (Cmap_slow (approximate f ((Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl))*e)%QposInf) x) ((Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl))*e)%QposInf. Lemma Cap_slow_fun_prf (f:Complete (X --> Y)) (x:Complete X) : is_RegularFunction (@ball Y) (Cap_slow_raw f x). Proof. intros e1 e2. unfold Cap_slow_raw. unfold QposInf_mult, QposInf_bind. pose (exist (Qlt 0) (1#2) eq_refl) as half. set (he1 := (half * e1)%Qpos). set (he2 := (half * e2)%Qpos). set (f1 := (approximate f he1)). set (f2 := (approximate f he2)). change (Cmap_slow (Y:=Y) f1) with (Cmap_strong_slow f1). change (Cmap_slow (Y:=Y) f2) with (Cmap_strong_slow f2). set (y1 :=(Cmap_strong_slow f1 x)). set (y2 :=(Cmap_strong_slow f2 x)). setoid_replace (proj1_sig e1 + proj1_sig e2) with (proj1_sig (he1 + (he1 + he2) + he2)%Qpos) by (simpl; ring). rewrite <- ball_Cunit. apply ball_triangle with y2;[|apply ball_approx_r]. apply ball_triangle with y1;[apply ball_approx_l|]. apply (uc_prf Cmap_strong_slow). apply (@regFun_prf _ (@ball (X-->Y))). Qed. Definition Cap_slow_fun (f:Complete (X --> Y)) (x:Complete X) : Complete Y := Build_RegularFunction (Cap_slow_fun_prf f x). Lemma Cap_slow_help (f:Complete (X --> Y)) (x:Complete X) (e:Qpos) : ball (proj1_sig e) (Cap_slow_fun f x) (Cmap_slow (approximate f e) x). Proof. intros d1 d2. pose (exist (Qlt 0) (1#2) eq_refl) as half. set (d1' := (half * d1)%Qpos). set (f1 := (approximate f d1')). set (f2 := (approximate f e)). set (y1 := (Cmap_slow f1 x)). set (y2 := (Cmap_slow f2 x)). change (ball (proj1_sig d1 + proj1_sig e + proj1_sig d2) (approximate y1 d1') (approximate y2 (Qpos2QposInf d2))). setoid_replace (proj1_sig d1 + proj1_sig e + proj1_sig d2) with (proj1_sig (d1' + (d1' + e) + d2)%Qpos) by (simpl; ring). rewrite <- ball_Cunit. apply ball_triangle with y2;[|apply ball_approx_r]. apply ball_triangle with y1;[apply ball_approx_l|]. apply (uc_prf Cmap_strong_slow). apply (@regFun_prf _ (@ball (X-->Y))). Qed. Definition Cap_slow_modulus (f:Complete (X --> Y)) (e:Qpos) : QposInf := ((Qpos2QposInf (1#2)) *(mu (approximate f (Qpos2QposInf ((1#3)*e))%Qpos) ((1#3)*e)%Qpos))%QposInf. Lemma Cap_weak_slow_prf (f:Complete (X --> Y)) : is_UniformlyContinuousFunction (Cap_slow_fun f) (Cap_slow_modulus f). Proof. intros e x y H. set (e' := ((1#3)*e)%Qpos). setoid_replace (proj1_sig e) with (proj1_sig (e'+e'+e')%Qpos) by (simpl; ring). apply ball_triangle with (Cmap_slow (approximate f e') y). apply ball_triangle with (Cmap_slow (approximate f e') x). apply Cap_slow_help. apply (uc_prf). apply H. apply ball_sym. apply Cap_slow_help. Qed. Definition Cap_weak_slow (f:Complete (X --> Y)) : Complete X --> Complete Y := Build_UniformlyContinuousFunction (Cap_weak_slow_prf f). Lemma Cap_slow_prf : is_UniformlyContinuousFunction Cap_weak_slow Qpos2QposInf. Proof. intros e f1 f2 H. split. apply Qpos_nonneg. intro x. apply ball_closed. intros d dpos. setoid_replace (proj1_sig e + d) with (proj1_sig ((1#4)*exist _ _ dpos + ((1#4)*exist _ _ dpos + e + (1#4)*exist _ _ dpos) + (1#4)*exist _ _ dpos)%Qpos) by (simpl; ring). apply ball_triangle with (Cmap_strong_slow (approximate f2 ((1#4)*exist _ _ dpos)%Qpos) x). apply ball_triangle with (Cmap_strong_slow (approximate f1 ((1#4)*exist _ _ dpos)%Qpos) x). apply Cap_slow_help. apply (uc_prf Cmap_strong_slow). apply H. apply ball_sym. apply Cap_slow_help. Qed. Definition Cap_slow : Complete (X --> Y) --> Complete X --> Complete Y := Build_UniformlyContinuousFunction Cap_slow_prf. Lemma StrongMonadLaw1 : forall a b, msp_eq (Cap_slow_fun (Cunit_fun _ a) b) (Cmap_strong_slow a b). Proof. intros f x. apply regFunEq_equiv, regFunEq_e. intros e. apply ball_weak_le with (proj1_sig ((1#2)*e+e)%Qpos). simpl. rewrite -> Qle_minus_iff; ring_simplify. apply Qmult_le_0_compat. discriminate. apply Qpos_nonneg. refine (regFun_prf _ _ _). Qed. End Strong_Monad. Lemma Cmap_slow_wd_loc : forall (X Y : MetricSpace) (f g : X --> Y) (x : Complete X) (e : Qpos), (forall a : X, ball (proj1_sig e) (Cunit a) x -> msp_eq (f a) (g a)) -> @msp_eq _ (Cmap_slow_fun f x) (Cmap_slow_fun g x). Proof. intros. intros e1 e2. simpl. unfold Cmap_slow_raw; simpl. pose (QposInf_min (Qpos2QposInf (1#2)*(mu g e2)) (QposInf_min (Qpos2QposInf (1#2)*(mu f e1)) e)) as d. rewrite Qplus_0_r. apply (ball_triangle _ (proj1_sig e1) (proj1_sig e2) _ (f (approximate x d))). - apply (uc_prf f). destruct (mu f e1). 2: reflexivity. simpl. destruct d eqn:des. assert (Qle (proj1_sig q0) ((1 # 2) * proj1_sig q)). { pose proof (QposInf_min_lb_r (Qpos2QposInf (1 # 2) * mu g e2) (QposInf_min (Qpos2QposInf (1 # 2) * q) e)). subst d. rewrite des in H0. simpl in H0. apply (Qle_trans _ _ _ H0), Qpos_min_lb_l. } apply (Qplus_le_l _ _ ((1#2)*proj1_sig q)) in H0. ring_simplify in H0. rewrite Qplus_comm in H0. apply (ball_weak_le _ _ _ H0). apply (regFun_prf x ((1#2)*q)%Qpos q0). exfalso. subst d. destruct (mu g e2); discriminate. - rewrite H. + apply (uc_prf g). destruct (mu g e2). 2: reflexivity. simpl. destruct d eqn:des. assert (Qle (proj1_sig q0) ((1 # 2) * proj1_sig q)). { pose proof (QposInf_min_lb_l (Qpos2QposInf (1 # 2) * q) (QposInf_min (Qpos2QposInf (1 # 2) * mu f e1) e)). subst d. rewrite des in H0. exact H0. } apply (Qplus_le_l _ _ ((1#2)*proj1_sig q)) in H0. ring_simplify in H0. apply (ball_weak_le _ _ _ H0). apply (regFun_prf x q0 ((1#2)*q)%Qpos). exfalso. subst d. destruct (mu f e1); discriminate. + destruct d eqn:des. assert (proj1_sig q <= proj1_sig e). { destruct (Qpos2QposInf (1 # 2) * mu g e2)%QposInf. destruct (Qpos2QposInf (1 # 2) * mu f e1)%QposInf. simpl in d. subst d. inversion des. apply (Qle_trans _ (proj1_sig (Qpos_min q1 e))). apply Qpos_min_lb_r. apply Qpos_min_lb_r. subst d. simpl in des. inversion des. apply Qpos_min_lb_r. simpl in d. subst d. destruct (mu f e1). simpl in des. inversion des. apply Qpos_min_lb_r. simpl in des. inversion des. apply Qle_refl. } apply (ball_weak_le _ _ _ H0). apply ball_approx_l. exfalso. destruct (mu g e2), (mu f e1); discriminate. Qed. (* begin hide *) Opaque Complete. Add Parametric Morphism X Y : (@Cmap_slow_fun X Y) with signature (@msp_eq (UniformlyContinuousSpace X Y)) ==> (@msp_eq (Complete X)) ==> (@msp_eq (Complete Y)) as Cmap_slow_wd. Proof. intros f g Hfg x1 x2 Hy. transitivity (Cmap_slow_fun f x2). apply (@uc_wd _ _ (Cmap_slow f) _ _ Hy). generalize x2. apply (@uc_wd (X --> Y) (Complete X --> Complete Y) (Cmap_strong_slow X Y) _ _ Hfg). Qed. Add Parametric Morphism X Y : (@Cap_weak_slow X Y) with signature (@msp_eq _) ==> (@msp_eq _) as Cap_weak_slow_wd. Proof. intros x1 x2 Hx. apply (@uc_wd _ _ (Cap_slow X Y));assumption. Qed. Add Parametric Morphism X Y : (@Cap_slow_fun X Y) with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as Cap_slow_wd. Proof. intros x1 x2 Hx y1 y2 Hy. transitivity (Cap_slow_fun x1 y2). apply (@uc_wd _ _ (Cap_weak_slow x1) _ _ Hy). generalize y2. apply (@uc_wd _ _ (Cap_slow X Y));assumption. Qed. Transparent Complete. (* end hide *) (** A binary version of map *) Definition Cmap2_slow (X Y Z:MetricSpace) (f:X --> Y --> Z) := uc_compose (@Cap_slow Y Z) (Cmap_slow f). (** *** Completion and Classification The completion operations preserve locatedness, but not decidability. *) Lemma Complete_located : forall (X : MetricSpace), locatedMetric X -> locatedMetric (Complete X). Proof. intros X Hx e d x y Hed. pose (d - e) as c. assert (0 < c) as Hc. { apply Qlt_minus_iff in Hed. exact Hed. } set (c':=((1#5)*exist _ _ Hc)%Qpos). assert (proj1_sig c'+e+ proj1_sig c' < e+(3#1)*proj1_sig c') as H. { rewrite -> Qlt_minus_iff. simpl. ring_simplify. apply (Qpos_ispos ((25#125)*exist _ _ Hc)). } destruct (Hx _ _ (approximate x c') (approximate y c') H) as [H0 | H0]. - left. rewrite <- ball_Cunit in H0. setoid_replace d with (proj1_sig c' + (e + (3#1) * proj1_sig c') + proj1_sig c')%Q by (simpl; unfold c; ring). eapply ball_triangle;[eapply ball_triangle;[|apply H0]|]; [apply ball_approx_r|apply ball_approx_l]. - right. abstract ( intros H1; apply H0; rewrite <- ball_Cunit; eapply ball_triangle;[eapply ball_triangle;[|apply H1]|]; [apply ball_approx_l|apply ball_approx_r]). Defined. corn-8.20.0/metric2/CompleteProduct.v000066400000000000000000000111071473720167500174230ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.metric2.ProductMetric. Require Export CoRN.metric2.Complete. Set Implicit Arguments. Section CompleteProduct. (** *** Completion of product spaces. This section develops the strong monad properties of the Completion operation with respect to the product operation. *) Variable X Y:MetricSpace. Let XY := ProductMS X Y. (** The projection operations are uniformly continuous *) Lemma fst_uc : is_UniformlyContinuousFunction (fun p:XY => fst p) Qpos2QposInf. Proof. intros e a b [H _]. assumption. Qed. Local Open Scope uc_scope. Definition pi1 : XY --> X := Build_UniformlyContinuousFunction fst_uc. Lemma snd_uc : is_UniformlyContinuousFunction (fun p:XY => snd p) Qpos2QposInf. Proof. intros e a b [_ H]. assumption. Qed. Definition pi2 : XY --> Y := Build_UniformlyContinuousFunction snd_uc. Definition Cfst_raw (p:Complete XY) (e:QposInf) : X := (fst (approximate p e)). Definition Csnd_raw (p:Complete XY) (e:QposInf) : Y := (snd (approximate p e)). Lemma Cfst_prf : forall p, is_RegularFunction (@ball X) (Cfst_raw p). Proof. intros p e1 e2. destruct (regFun_prf p e1 e2). auto. Qed. Lemma Csnd_prf : forall p, is_RegularFunction (@ball Y) (Csnd_raw p). Proof. intros p e1 e2. destruct (regFun_prf p e1 e2). auto. Qed. Definition Cfst_fun (p:Complete XY) : Complete X := Build_RegularFunction (Cfst_prf p). Definition Csnd_fun (p:Complete XY) : Complete Y := Build_RegularFunction (Csnd_prf p). Lemma Cfst_uc : is_UniformlyContinuousFunction Cfst_fun Qpos2QposInf. Proof. intros e a b H e1 e2. destruct (H e1 e2). auto. Qed. Lemma Csnd_uc : is_UniformlyContinuousFunction Csnd_fun Qpos2QposInf. Proof. intros e a b H e1 e2. destruct (H e1 e2). auto. Qed. Definition Cfst : Complete XY --> Complete X := Build_UniformlyContinuousFunction Cfst_uc. Definition Csnd : Complete XY --> Complete Y := Build_UniformlyContinuousFunction Csnd_uc. (** The pairing function is uniformly continuous *) Lemma pair_uc_l : forall y:Y, @is_UniformlyContinuousFunction X XY (fun x => (x,y)) Qpos2QposInf. Proof. intros y e a b H. split; auto. apply ball_refl. apply QposMinMax.Qpos_nonneg. Qed. Lemma pair_uc_r : forall x:X, @is_UniformlyContinuousFunction Y XY (fun y => (x,y)) Qpos2QposInf. Proof. intros x e a b H. split; auto. apply ball_refl. apply QposMinMax.Qpos_nonneg. Qed. (** C(X*Y) is isomorphic to (C X)*(C Y) *) Definition Couple_raw (p: ProductMS (Complete X) (Complete Y)) (e:QposInf): XY := (approximate (fst p) e,approximate (snd p) e). Lemma Couple_prf : forall p, is_RegularFunction (@ball XY) (Couple_raw p). Proof. intros [p1 p2] e1 e2. split; simpl; apply regFun_prf. Qed. Definition Couple_fun (p: ProductMS (Complete X) (Complete Y)) : Complete XY := Build_RegularFunction (Couple_prf p). Lemma Couple_uc : is_UniformlyContinuousFunction Couple_fun Qpos2QposInf. Proof. intros e a b [Hl Hr] e1 e2. split; simpl; auto. Qed. Definition Couple : (ProductMS (Complete X) (Complete Y)) --> (Complete (ProductMS X Y)) := Build_UniformlyContinuousFunction Couple_uc. Lemma CoupleCorrect1 : forall p, msp_eq (Couple ((Cfst p), (Csnd p))) p. Proof. intros p e1 e2. rewrite Qplus_0_r. destruct (regFun_prf p e1 e2). split; simpl; auto. Qed. Lemma CoupleCorrect2 : forall p q, msp_eq (Cfst (Couple (p,q))) p. Proof. intros p q e1 e2. rewrite Qplus_0_r. apply (regFun_prf p e1 e2). Qed. Lemma CoupleCorrect3 : forall p q, msp_eq (Csnd (Couple (p,q))) q. Proof. intros p q e1 e2. rewrite Qplus_0_r. apply (regFun_prf q e1 e2). Qed. End CompleteProduct. (* begin hide *) Arguments Couple {X Y}. Arguments Cfst {X Y}. Arguments Csnd {X Y}. (* end hide *) corn-8.20.0/metric2/DistanceMetricSpace.v000066400000000000000000000114561473720167500201730ustar00rootroot00000000000000 Require Import CoRN.algebra.RSetoid. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.metric2.Metric. Require Import CoRN.reals.fast.CRArith. Local Open Scope CR. Record is_DistanceMetricSpace (X : RSetoid) (distance: X -> X -> CR) : Prop := Build_is_DistanceMetricSpace { dmsp_refl: forall x y, st_eq x y <-> distance x y == 0 ; dmsp_sym: forall x y, distance x y == distance y x ; dmsp_triangle: forall x y z, distance x z <= distance x y + distance y z ; dmsp_nonneg: forall x y, 0 <= distance x y }. Record DistanceMetricSpace: Type := Build_alt_MetricSpace { dmsp_is_setoid:> RSetoid; distance: dmsp_is_setoid -> dmsp_is_setoid -> CR; distance_wd: Proper (@st_eq _ ==> @st_eq _ ==> @msp_eq _) distance; dmsp : is_DistanceMetricSpace dmsp_is_setoid distance }. Arguments distance [d]. #[global] Existing Instance distance_wd. Section DistanceMetricSpace. (* Just mimicking Russell's code for MetricSpace here. *) Context {X: DistanceMetricSpace}. Lemma distance_refl (x y: X): st_eq x y <-> distance x y == 0. Proof. apply dmsp_refl, dmsp. Qed. Lemma distance_sym (x y: X): distance x y == distance y x. Proof. apply dmsp_sym, dmsp. Qed. Lemma distance_triangle (x y z: X): distance x z <= distance x y + distance y z. Proof. apply dmsp_triangle, dmsp. Qed. End DistanceMetricSpace. (* We show that a DistanceMetricSpace immediately yields a MetricSpace. *) Section from_alt. Variable (X: DistanceMetricSpace). Definition ball (q: Q) (x y: X): Prop := (0 <= q)%Q /\ distance x y <= inject_Q_CR q. Instance ball_wd: Proper (Qeq ==> @st_eq X ==> @st_eq X ==> iff) ball. Proof. intros ?? E ?? F ?? G. unfold ball. split. - intros [qpos H]. assert (Qle 0 y). rewrite <- E. exact qpos. split. exact H0. rewrite <- F, <- G. rewrite <- E. exact H. - intros [qpos H]. assert (Qle 0 x). rewrite E. exact qpos. split. exact H0. rewrite F, G. rewrite E. exact H. Qed. Lemma ball_refl e: Qle 0 e -> Reflexive (ball e). Proof. unfold Reflexive, ball. intros. split. exact H. rewrite (proj1 (distance_refl x x)). apply CRle_Qle. exact H. reflexivity. Qed. Lemma ball_sym e: Symmetric (ball e). Proof with auto. unfold Symmetric, ball. intros. destruct H as [qpos H]. split. exact qpos. rewrite distance_sym... Qed. Lemma ball_closed (e:Q) x y: (forall d:Q, 0 < d -> ball (e+d) x y)%Q -> ball e x y. Proof. unfold ball. intro H. assert (Qle 0 e). { apply Qnot_lt_le. intro abs. destruct (H (-e*(1#2))%Q). rewrite <- (Qmult_0_l (1#2)). apply Qmult_lt_r. reflexivity. apply (Qplus_lt_l _ _ e). ring_simplify. exact abs. clear H1. ring_simplify in H0. rewrite <- (Qmult_0_r (1#2)) in H0. apply Qmult_le_l in H0. exact (Qlt_not_le _ _ abs H0). reflexivity. } split. exact H0. apply CRle_not_lt. intro abs. apply CRlt_Qmid in abs. destruct abs as [q [H1 H2]]. specialize (H (q-e)%Q). revert H2. apply CRle_not_lt. setoid_replace q with (e+(q-e))%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; ring). apply H. unfold Qminus. rewrite <- Qlt_minus_iff. apply Qlt_from_CRlt, H1. Qed. Lemma ball_triangle (e1 e2 : Q) a b c : ball e1 a b -> ball e2 b c -> ball (e1+e2) a c. Proof with auto. unfold ball. intros. destruct H, H0. assert (Qle 0 (e1+e2)). { apply (Qle_trans _ (e1+0)). rewrite Qplus_0_r. exact H. apply Qplus_le_r. exact H0. } split. exact H3. apply CRle_trans with (distance a b + distance b c). apply distance_triangle. rewrite <- CRplus_Qplus. apply CRplus_le_compat; assumption. Qed. Lemma ball_eq x y: (forall e, Qlt 0 e -> ball e x y) -> st_eq x y. Proof. unfold ball. intros. apply distance_refl. apply CRle_antisym. split. 2: apply (dmsp_nonneg _ _ (dmsp X)). apply CRle_not_lt. intro abs. apply CRlt_Qmid in abs. destruct abs as [q [H1 H2]]. apply Qlt_from_CRlt in H1. specialize (H q H1) as [_ H]. revert H2. apply CRle_not_lt, H. Qed. Lemma is_MetricSpace: is_MetricSpace ball. Proof with auto. constructor. - apply ball_refl. - apply ball_sym. - apply ball_triangle. - apply ball_closed. - intros. destruct H. exact H. - unfold ball. split. destruct (Qlt_le_dec e 0). exfalso. contradict H; intros [H _]. exact (Qlt_not_le _ _ q H). exact q. apply CRle_not_lt. intro abs. contradict H; intros [_ H]. revert abs. apply CRle_not_lt, H. Qed. Definition ballSpace: MetricSpace. apply (@Build_MetricSpace X ball). intros. rewrite H. reflexivity. apply is_MetricSpace. Defined. End from_alt. (* Unfortunately, the other way around is not as direct, because the ball-based interface permits the distance between two points to be infinite, which CR does not support. *) corn-8.20.0/metric2/FinEnum.v000066400000000000000000001017541473720167500156630ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.Hausdorff. Require Import CoRN.logic.Classic. Require Export CoRN.stdlib_omissions.List. Require Export CoRN.metric2.Classification. Require Import CoRN.metric2.Complete. Require Import CoRN.metric2.Prelength. Set Implicit Arguments. Local Open Scope Q_scope. Section Finite. Variable X:MetricSpace. (** [FinSubset_ball] says that the distance between x and l is <= e. It is stated as a negation, to remind that a <= b means ~(b < a) in the real numbers. As shown by lemma AlmostInExists, the double negation can be removed, at the cost of slightly increasing e. *) Definition FinSubset_ball (e:Q) (x:X) (l:list X) : Prop := ~~ exists y:X, In y l /\ ball e x y. Definition InFinEnumC (x:X) (l:list X) : Prop := FinSubset_ball 0 x l. Lemma InFinEnumC_weaken : forall x l, In x l -> InFinEnumC x l. Proof. intros. intro abs. contradict abs. exists x. split. exact H. apply ball_refl. apply Qle_refl. Qed. Lemma FinSubset_ball_nil : forall e x, ~FinSubset_ball e x nil. Proof. intros e x H. unfold FinSubset_ball in H. contradict H; intros [y [H _]]. contradiction. Qed. Lemma FinSubset_ball_cons : forall x e a l, FinSubset_ball e x l -> FinSubset_ball e x (a :: l). Proof. intros. intro abs. unfold FinSubset_ball in H. contradict H; intros [z [H0 H1]]. contradict abs. exists z. split. right. exact H0. exact H1. Qed. Lemma FinSubset_ball_orC : forall e x a l, FinSubset_ball e x (a :: l) -> orC (ball e x a) (FinSubset_ball e x l). Proof. intros. intro abs. unfold FinSubset_ball in H. contradict H; intros [y [H H0]]. destruct H. - subst y. destruct abs. contradiction. - destruct abs. contradict H2. intro abs; contradict abs. exists y. split; assumption. Qed. Lemma FinSubset_ball_wd : forall x y d e l, d == e -> msp_eq x y -> (FinSubset_ball d x l <-> FinSubset_ball e y l). Proof. split. - intros H1 abs. unfold FinSubset_ball in H1. contradict H1; intros [z [H1 H2]]. contradict abs. exists z. split. exact H1. rewrite <- H, <- H0. exact H2. - intros H1 abs. unfold FinSubset_ball in H1. contradict H1; intros [z [H1 H2]]. contradict abs. exists z. split. exact H1. rewrite H, H0. exact H2. Qed. Lemma FinSubset_ball_weak_le : forall (e1 e2:Q) x l, e1 <= e2 -> FinSubset_ball e1 x l -> FinSubset_ball e2 x l. Proof. intros. intro abs. unfold FinSubset_ball in H0. contradict H0; intros [y [iny H0]]. contradict abs. exists y. split. exact iny. apply (ball_weak_le X x y H), H0. Qed. Lemma FinSubset_ball_nonneg : forall (e:Q) x l, FinSubset_ball e x l -> 0 <= e. Proof. intros. apply Qnot_lt_le. intro abs. unfold FinSubset_ball in H. contradict H; intros [y [_ H]]. apply (Qlt_not_le _ _ abs). apply (msp_nonneg (msp X) e x y H). Qed. Lemma FinSubset_ball_closed : forall (e:Q) x l, (forall d:Q, 0 < d -> FinSubset_ball (e+d) x l) -> FinSubset_ball e x l. Proof. induction l. - intros H. exfalso. exact (FinSubset_ball_nil (H (1#1) eq_refl)). - intros H abs. assert (~ball e x a) as A. { intro H0. contradict abs. exists a. split. left. reflexivity. exact H0. } assert (~ (exists y : X, In y l /\ ball e x y)) as B. { intros [y H1]. contradict abs. exists y. split. right. apply H1. apply H1. } clear abs. revert B. apply IHl. clear IHl. intros d dpos. (* Improve A *) assert (existsC Qpos (fun d => ~ball (e+proj1_sig d) x a)) as Aprime. { intros Y. apply A. apply ball_closed. intros d0 d0pos. apply (msp_stable (msp X)). apply (Y (exist _ _ d0pos)). } clear A. destruct Aprime as [G | d0 Hd0] using existsC_ind. intro abs; contradict G; intro G; contradiction. intros Z. destruct (Qlt_le_dec (proj1_sig d0) d). + revert Z. apply (@FinSubset_ball_weak_le (e + proj1_sig d0)). apply Qlt_le_weak. rewrite -> Qlt_minus_iff in *. setoid_replace (e + d + - (e + proj1_sig d0)) with (d + - proj1_sig d0) by (simpl; ring). assumption. intros Y. destruct d0 as [d0 d0pos]. apply (H d0 d0pos). intros [y abs]. contradict Y. exists y. simpl. split. 2: apply abs. destruct abs. destruct H0. 2: exact H0. subst y. contradiction. + specialize (H d dpos). unfold FinSubset_ball in H. contradict H; intros [y [iny H]]. destruct iny. subst y. contradict Hd0. apply (@ball_weak_le X (e + d)). rewrite -> Qle_minus_iff in *. setoid_replace (e + proj1_sig d0 + - (e + d)) with (proj1_sig d0 + - d) by (simpl; ring). assumption. exact H. contradict Z. exists y. split. exact H0. exact H. Qed. (** Left and right triangle laws for balls and [FinSubset_ball]. *) Lemma FinSubset_ball_triangle_l : forall e1 e2 x1 x2 l, (ball e1 x1 x2) -> FinSubset_ball e2 x2 l -> FinSubset_ball (e1 + e2) x1 l. Proof. intros. intro abs. unfold FinSubset_ball in H0. contradict H0; intros [y H0]. contradict abs. exists y. split. apply H0. eapply ball_triangle. apply H. apply H0. Qed. Lemma FinSubset_ball_app_l : forall e x l1 l2, FinSubset_ball e x l1 -> FinSubset_ball e x (l1 ++ l2). Proof. intros e x l1 l2 H abs. unfold FinSubset_ball in H. contradict H; intros [y H]. contradict abs. exists y. split. apply in_app_iff. left. apply H. apply H. Qed. Lemma FinSubset_ball_app_r : forall e x l1 l2, FinSubset_ball e x l2 -> FinSubset_ball e x (l1 ++ l2). Proof. intros e x l1 l2 H abs. unfold FinSubset_ball in H. contradict H; intros [y H]. contradict abs. exists y. split. apply in_app_iff. right. apply H. apply H. Qed. (* begin hide *) Hint Resolve FinSubset_ball_app_l FinSubset_ball_app_r. (* end hide *) Lemma FinSubset_ball_app_orC : forall e x l1 l2, FinSubset_ball e x (l1 ++ l2) -> orC (FinSubset_ball e x l1) (FinSubset_ball e x l2). Proof. intros e x l1 l2 H [H0 H1]. unfold FinSubset_ball in H. contradict H; intros [y [H H2]]. apply in_app_iff in H. destruct H. contradict H0. intro abs. contradict abs. exists y. split; assumption. contradict H1. intro abs. contradict abs. exists y. split; assumption. Qed. (** ** Equivalence Two finite enumerations, represented as lists, are equivalent if they (classically) have the same elements. *) Definition FinEnum_eq (a b:list X) : Prop := forall x, InFinEnumC x a <-> InFinEnumC x b. (** ** Metric Space Finite enumerations form a metric space under the Hausdorff metric for any stable metric space X. *) Definition FinEnum_ball (e:Q) (x y:list X) := hausdorffBall X e (fun a => InFinEnumC a x) (fun a => InFinEnumC a y). Lemma FinEnum_ball_e_wd : forall (e1 e2:Q) (a b : list X), (e1 == e2) -> (FinEnum_ball e1 a b <-> FinEnum_ball e2 a b). Proof. intros e1 e2 a b He. apply hausdorffBall_wd; auto with *. Qed. Lemma hemiMetric_closed : forall e A b, (forall d, 0 < d -> hemiMetric X (e+d) A (fun a => InFinEnumC a b)) -> hemiMetric X e A (fun a => InFinEnumC a b). Proof. intros e A b H x Hx. pose (fun n y => ball (e + (1#(P_of_succ_nat n))%Q) x y) as P. assert (forall n, existsC X (fun x => ~~In x b /\ P n x)) as HP. { intros n. unfold P. destruct (H (1#(P_of_succ_nat n))%Q eq_refl x Hx) as [HG | y [Hy0 Hy1]] using existsC_ind. apply existsC_stable; auto. clear - Hy0 Hy1. intro abs. unfold InFinEnumC, FinSubset_ball in Hy0. contradict Hy0; intros [y0 [Hy0 yeq]]. specialize (abs y0). contradict abs. split. intro abs. contradiction. rewrite <- yeq. exact Hy1. } destruct (infinitePidgeonHolePrinicple _ _ P HP) as [HG | y [Hy0 Hy1]] using existsC_ind. apply existsC_stable; auto. apply existsWeaken. exists y. split; auto using InFinEnumC_weaken. apply ball_closed. intros [n d] dpos. destruct n. inversion dpos. 2: inversion dpos. destruct (Hy1 (nat_of_P d)) as [HG | m [Hmd Hm]] using existsC_ind. apply (msp_stable (msp X) (e + (Zpos p#d))%Q); assumption. eapply ball_weak_le;[|apply Hm]. simpl. rewrite -> Qle_minus_iff. ring_simplify. rewrite <- Qle_minus_iff. apply Zmult_le_compat. apply Pos.le_1_l. simpl. apply Pos2Nat.inj_le. apply (Nat.le_trans _ _ _ Hmd). rewrite nat_of_P_o_P_of_succ_nat_eq_succ. apply le_S, Nat.le_refl. discriminate. discriminate. Qed. Lemma FinEnum_ball_closed : forall e a b, (forall d, 0 < d -> FinEnum_ball (e+d) a b) -> FinEnum_ball e a b. Proof. unfold FinEnum_ball, hausdorffBall. intros e a b Hab. split. - apply Qnot_lt_le. intro abs. specialize (Hab (-e * (1#2))). destruct Hab. rewrite <- (Qmult_0_l (1#2)). apply Qmult_lt_r. reflexivity. apply (Qplus_lt_l _ _ e). ring_simplify. exact abs. ring_simplify in H. rewrite <- (Qmult_0_r (1#2)) in H. apply Qmult_le_l in H. exact (Qlt_not_le _ _ abs H). reflexivity. - split; apply hemiMetric_closed; firstorder. Qed. Lemma FinEnum_ball_eq : forall a b : list X, (forall e : Qpos, FinEnum_ball (proj1_sig e) a b) -> FinEnum_eq a b. Proof. unfold FinEnum_ball, FinEnum_eq. cut (forall a b : list X, (forall e : Qpos, hemiMetric X (proj1_sig e) (fun a0 : X => InFinEnumC a0 a) (fun a0 : X => InFinEnumC a0 b)) -> forall x : X, InFinEnumC x a -> InFinEnumC x b). { unfold hausdorffBall. split; apply H; firstorder. } induction a. intros. exfalso. unfold InFinEnumC, FinSubset_ball in H0. contradict H0; intros [y [H0 _]]. contradiction. intros b H x Hx. intro abs. unfold InFinEnumC, FinSubset_ball in Hx. contradict Hx; intros [y [iny Hx]]. destruct iny. - subst y. assert (H':forall n :nat , existsC X (fun y : X => InFinEnumC y b /\ ball (m:=X) (1#(P_of_succ_nat n)) x y)). { intros e. apply (H (exist (Qlt 0) (1#(P_of_succ_nat e)) eq_refl)). intro H0. contradict H0. exists a. split. left. reflexivity. exact Hx. } assert (H'':forall n :nat , existsC X (fun y : X => ~~In y b /\ ball (m:=X) (1#(P_of_succ_nat n)) x y)). { intros n. destruct (H' n) as [HG | z [Hz0 Hz1]] using existsC_ind. auto using existsC_stable. clear - Hz1 Hz0. intro abs. unfold InFinEnumC, FinSubset_ball in Hz0. contradict Hz0; intros [y [iny Hz0]]. specialize (abs y). contradict abs. split. intro abs. contradiction. rewrite <- Hz0. exact Hz1. } destruct (infinitePidgeonHolePrinicple _ _ _ H'') as [HG | y [Hy0 Hy1]] using existsC_ind. contradict HG. intro HG. contradiction. revert abs. change (FinSubset_ball 0 x b). rewrite -> (FinSubset_ball_wd x y). 2: reflexivity. apply InFinEnumC_weaken, Hy0. apply ball_eq. intros [n d] dpos. destruct n. inversion dpos. 2: inversion dpos. replace d with (Pos.of_succ_nat (Init.Nat.pred (Pos.to_nat d))). destruct (Hy1 (pred (nat_of_P d))) as [HG | z [Hz0 Hz1]] using existsC_ind. apply (msp_stable (msp X) (Zpos p # Pos.of_succ_nat (Init.Nat.pred (Pos.to_nat d)))). auto. apply ball_weak_le with (1 # P_of_succ_nat z); auto. simpl. apply Zmult_le_compat; [..|auto with *]. apply Pos.le_1_l. simpl. assert (forall i j:nat, le i j -> Pos.of_succ_nat i <= Pos.of_succ_nat j)%positive. { intros. rewrite Pos.of_nat_succ, Pos.of_nat_succ. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. apply le_n_S, H0. discriminate. discriminate. } apply H0, Hz0. discriminate. rewrite Pos.of_nat_succ. rewrite <- (Pos2Nat.id d) at 2. apply f_equal. apply (Nat.lt_succ_pred O _). apply Pos2Nat.is_pos. - revert abs. apply IHa. intros e y0 Hy. apply H. intro abs. unfold InFinEnumC, FinSubset_ball in Hy. contradict Hy; intros [y1 Hy]. contradict abs. exists y1. split. right. apply Hy. apply Hy. intro abs; contradict abs. exists y. split; assumption. Qed. Lemma FinEnum_is_MetricSpace : is_MetricSpace FinEnum_ball. Proof. split. - intros e epos x. apply hausdorffBall_refl, epos. - intros e x y. apply hausdorffBall_sym. - intros e d x y z. apply hausdorffBall_triangle. - intros e x y. unfold FinEnum_ball. apply FinEnum_ball_closed. - intros. apply H. - intros e x y. apply hausdorffBall_stable. Qed. Definition FinEnum : MetricSpace := Build_MetricSpace FinEnum_ball_e_wd FinEnum_is_MetricSpace. Lemma FinEnum_eq_equiv : forall (x y : FinEnum), FinEnum_eq x y <-> msp_eq x y. Proof. unfold FinEnum_eq, msp_eq. split. - intros. split. apply Qle_refl. split. intros z H0. rewrite H in H0. intro abs. apply (abs z). split. exact H0. reflexivity. intros z H0. rewrite <- H in H0. intro abs. apply (abs z). split. exact H0. reflexivity. - split. + intros z H0. destruct H as [_ [H1 _]]. specialize (H1 x0 z). clear z. unfold existsC in H1. contradict H1; intros x1 [H1 H2]. unfold InFinEnumC, FinSubset_ball in H1. contradict H1; intros [t H1]. contradict H0. exists t. split. apply H1. rewrite H2. apply H1. + intros z H0. destruct H as [_ [_ H1]]. specialize (H1 x0 z). clear z. unfold existsC in H1. contradict H1; intros x1 [H1 H2]. unfold InFinEnumC, FinSubset_ball in H1. contradict H1; intros [t H1]. contradict H0. exists t. split. apply H1. rewrite H2. apply H1. Qed. Lemma FinSubset_ball_triangle_r : forall e1 e2 x (l1 l2 : FinEnum), FinSubset_ball e1 x l1 -> (ball e2 l1 l2) -> FinSubset_ball (e1 + e2) x l2. Proof. intros e1 e2 x l1 l2 H1 [epos [H2 _]]. revert l2 H1 H2. induction l1; intros l2 H1 H2. exfalso; exact (FinSubset_ball_nil H1). unfold hemiMetric in *. apply FinSubset_ball_orC in H1. destruct H1 as [G | H1 | H1] using orC_ind. intro abs; contradict G; intro G; contradiction. assert (Z:InFinEnumC a (a :: l1)). { intro abs; contradict abs. exists a. split. left; reflexivity. reflexivity. } destruct (H2 a Z) as [ G | z [Hz0 Hz1]] using existsC_ind. intro abs; contradict G; intro G; contradiction. clear - H1 Hz0 Hz1. apply FinSubset_ball_closed. intros d dpos. apply FinSubset_ball_triangle_l with z. apply ball_triangle with a; assumption. apply FinSubset_ball_weak_le with (e1:=0). apply Qlt_le_weak, dpos. exact Hz0. apply IHl1. assumption. intros y Hy. apply H2. apply FinSubset_ball_cons. exact Hy. Qed. Lemma FinEum_map_ball : forall (f:X -> X) (e:Qpos) (s:FinEnum), (forall x, ball (proj1_sig e) x (f x)) -> ball (proj1_sig e) s (map f s). Proof. intros f e s H. induction s. split. apply Qpos_nonneg. - split; intros a b abs; apply (FinSubset_ball_nil b). - destruct IHs as [IHs0 IHs1]. split. apply Qpos_nonneg. split; intros x y abs; unfold InFinEnumC, FinSubset_ball in y; contradict y ; intros [y [iny H0]]. destruct iny. + subst y. specialize (abs (f a)). contradict abs. split. apply InFinEnumC_weaken. left. reflexivity. rewrite H0. apply H. + destruct IHs1 as [IHs1 _]. pose proof (@FinSubset_ball_wd x y 0 0 s eq_refl H0) as [_ H2]. specialize (IHs1 x (H2 (InFinEnumC_weaken y s H1))). unfold existsC in IHs1. contradict IHs1. intros z [H3 H4]. specialize (abs z). contradict abs. split. 2: exact H4. simpl. apply FinSubset_ball_cons. exact H3. + destruct iny. subst y. specialize (abs a). contradict abs. split. apply InFinEnumC_weaken. left. reflexivity. rewrite H0. apply ball_sym, H. destruct IHs1 as [_ IHs1]. pose proof (@FinSubset_ball_wd x y 0 0 (map f s) eq_refl H0) as [_ H2]. specialize (IHs1 x (H2 (InFinEnumC_weaken y _ H1))). unfold existsC in IHs1. contradict IHs1. intros z [H3 H4]. specialize (abs z). contradict abs. split. 2: exact H4. simpl. apply FinSubset_ball_cons. exact H3. Qed. Section Strong. (** ** Strong Hausdroff Metric This section shows that the strong version of the Hausdroff metric is equivalen to the weak version when X is a located metric. *) Hypothesis almostDecideX : locatedMetric X. Lemma HemiMetricHemiMetricStrong : forall (e:Q) A b, hemiMetric X e A (fun a => InFinEnumC a b) -> hemiMetricStrong X e A (fun a => InFinEnumC a b). Proof. intros e A b H x Hx. generalize (H x Hx). clear H. revert x Hx. induction b; intros x Hx H d. - abstract (unfold existsC in H; contradict H; intros y [H _]; exact (FinSubset_ball_nil H)). - destruct (@almostDecideX e (e + proj1_sig d) x a). clear - e d. abstract ( simpl; rewrite -> Qlt_minus_iff; ring_simplify; auto with * ). exists a. clear - b0. abstract (auto using InFinEnumC_weaken with * ). assert (Z:existsC X (fun y : X => InFinEnumC y b /\ ball (m:=X) e x y)). { clear - H n. destruct (H) as [HG | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. split. 2: exact Hy1. apply FinSubset_ball_orC in Hy0. destruct Hy0 as [HG | Hy | Hy] using orC_ind. intro abs. contradict HG; intro HG; contradiction. 2: assumption. apply (ball_wd _ eq_refl _ _ (reflexivity _) _ _ Hy) in Hy1. contradiction. } exists (let (y,_) := (IHb x Hx Z d) in y). clear - IHb. abstract (destruct (IHb x Hx Z d) as [y [Hy0 Hy1]]; split; auto; apply FinSubset_ball_cons, Hy0). Defined. Lemma HausdorffBallHausdorffBallStrong : forall (e:Q) (a b:FinEnum), ball e a b -> hausdorffBallStrong X e (fun x => InFinEnumC x a) (fun x => InFinEnumC x b). Proof. intros e a b [H0 H1]. split; apply HemiMetricHemiMetricStrong; apply H1. Defined. Lemma HemiMetricStrongAlmostDecidableBody : forall (e d:Q) a (b : FinEnum), e < d -> {hemiMetric X d (fun x => msp_eq x a) (fun x => InFinEnumC x b)} + {~hemiMetric X e (fun x => msp_eq x a) (fun x => InFinEnumC x b)}. Proof. intros e d a b. induction b. - intros Hed. right. abstract (intros H; apply (H a); try reflexivity; intros x [Hx0 Hx1]; exact (FinSubset_ball_nil Hx0)). - intros Hed. destruct (IHb Hed) as [H|H]. left. abstract (intros x Hx; destruct (H x Hx) as [HG | z [Hz0 Hz1]] using existsC_ind; [apply existsC_stable; auto|]; apply existsWeaken; exists z; split; try assumption; apply FinSubset_ball_cons, Hz0). destruct (@almostDecideX _ _ a a0 Hed). + left. intros x Hx; apply existsWeaken; exists a0. split. auto using InFinEnumC_weaken with *. apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)). auto using InFinEnumC_weaken with *. + right. intros H0; assert (Haa:msp_eq a a) by reflexivity; destruct (H0 a Haa) as [HG | z [Hz0 Hz1]] using existsC_ind; [tauto|]. apply FinSubset_ball_orC in Hz0. destruct Hz0 as [HG | Hz2 | Hz2] using orC_ind. tauto. apply (ball_wd _ eq_refl _ _ (reflexivity _) _ _ Hz2) in Hz1. contradiction. apply H; intros x Hx; apply existsWeaken; exists z. split. exact Hz2. apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)). auto. Defined. Lemma HemiMetricStrongAlmostDecidable : forall (e d:Q) (a b : FinEnum), e < d -> {hemiMetric X d (fun x => InFinEnumC x a) (fun x => InFinEnumC x b)} + {~hemiMetric X e (fun x => InFinEnumC x a) (fun x => InFinEnumC x b)}. Proof. induction a. intros a _. left. intros x Hx _. exact (FinSubset_ball_nil Hx). intros b Hed. destruct (IHa b Hed) as [I|I]. destruct (@HemiMetricStrongAlmostDecidableBody _ _ a b Hed) as [J|J]. left. abstract ( intros x Hx; apply FinSubset_ball_orC in Hx; destruct Hx as [HG | ? | ?] using orC_ind; [auto using existsC_stable |apply J; assumption |apply I; assumption]). right. abstract (intros H; apply J; intros x Hx; apply H; intro abs; contradict abs; exists a; split; [left; reflexivity | apply Hx]). right. abstract (intros H; apply I; intros x Hx; apply H; apply FinSubset_ball_cons, Hx). Defined. (** Finite Enumerations preserve the locatedness property. *) Lemma FinEnum_located : locatedMetric FinEnum. Proof. intros e d a b Hed. destruct (Q.Qle_dec 0 e). - destruct (@HemiMetricStrongAlmostDecidable _ _ a b Hed). destruct (@HemiMetricStrongAlmostDecidable _ _ b a Hed). left. split. apply (Qle_trans _ _ _ q). apply Qlt_le_weak, Hed. split; assumption. right. intro abs. destruct abs, H0. contradiction. right. intro abs. destruct abs, H0. contradiction. - right. intro abs. destruct abs. contradiction. Defined. (** Finite Enumerations preserve the prelength property assuming X is a located metric space. If we change the definition of prelenght space to use a classical existential, then we could drop the located assumption of X. I believe there would be no harm in changing the definition this way, but it has not been done yet. *) Hypothesis preLengthX : PrelengthSpace X. Lemma FinEnum_prelength : PrelengthSpace FinEnum. Proof. intros a b e. revert a b. cut (forall d1 d2 : Qpos, proj1_sig e < proj1_sig (d1 + d2)%Qpos -> forall (a b:FinEnum), hemiMetricStrong X (proj1_sig e) (fun x : X => InFinEnumC x a) (fun x : X => InFinEnumC x b) -> exists2 c : FinEnum, ball (proj1_sig d1) a c & hemiMetric X (proj1_sig d2) (fun x : X => InFinEnumC x c) (fun x : X => InFinEnumC x b)). intros Z a b d1 d2 He H. destruct (HausdorffBallHausdorffBallStrong H) as [Hl Hr]. clear H. destruct (Z _ _ He _ _ Hl) as [c0 Hc0 Hc0c]. assert (He0: proj1_sig e < proj1_sig (d2 + d1)%Qpos). clear - He. abstract (simpl; rewrite -> Qplus_comm; assumption). destruct (Z _ _ He0 _ _ Hr) as [c1 Hc1 Hc1c]. clear Z Hl Hr. exists (c0 ++ c1). split. apply Qpos_nonneg. destruct Hc0 as [_ Hc0]. abstract ( destruct Hc0 as [Hc0a Hc0b]; destruct Hc1 as [Hc1a Hc1b]; split; intros x Hx; [destruct (Hc0a x Hx) as [ G | y [Hya Hyb]] using existsC_ind; [auto using existsC_stable | apply existsWeaken; exists y; unfold InFinEnumC; auto] |destruct (@FinSubset_ball_app_orC _ _ _ _ Hx) as [G | Hxl | Hxr] using orC_ind; [auto using existsC_stable |destruct (Hc0b x Hxl) as [ G | y [Hya Hyb]] using existsC_ind; [auto using existsC_stable | apply existsWeaken; exists y; auto] |destruct (Hc1c x Hxr) as [ G | y [Hya Hyb]] using existsC_ind; [auto using existsC_stable | apply existsWeaken; exists y; auto]]]). split. apply Qpos_nonneg. destruct Hc0 as [_ Hc0]. destruct Hc1 as [_ Hc1]. abstract ( destruct Hc0 as [Hc0a Hc0b]; destruct Hc1 as [Hc1a Hc1b]; split; intros x Hx; [destruct (@FinSubset_ball_app_orC _ _ _ _ Hx) as [G | Hxl | Hxr] using orC_ind; [auto using existsC_stable |destruct (Hc0c x Hxl) as [ G | y [Hya Hyb]] using existsC_ind; [auto using existsC_stable | apply existsWeaken; exists y; auto] |destruct (Hc1b x Hxr) as [ G | y [Hya Hyb]] using existsC_ind; [auto using existsC_stable | apply existsWeaken; exists y; auto]] |destruct (Hc1a x Hx) as [ G | y [Hya Hyb]] using existsC_ind; [auto using existsC_stable | apply existsWeaken; exists y; unfold InFinEnumC; auto]]). intros d1 d2 He a b H. induction a. exists nil. apply ball_refl. apply Qpos_nonneg. intros x Hx; exfalso; exact (FinSubset_ball_nil Hx). destruct IHa as [c1 Hc1a Hc1b]. abstract (intros x Hx d; apply (H x); apply FinSubset_ball_cons, Hx). destruct (Qpos_sub _ _ He) as [g Hg]. pose (exist (Qlt 0) (1#2) eq_refl) as half. destruct (fun z => H a z (half*g)%Qpos) as [b0 Hb0]. abstract (intro abs; contradict abs; exists a; split; [left; reflexivity | reflexivity]). clear H. destruct (@preLengthX a b0 (e + half * g)%Qpos d1 d2) as [c Hc0 Hc1]. abstract ( clear - Hg; unfold QposEq in Hg; rewrite -> Hg; simpl; rewrite -> Qlt_minus_iff; ring_simplify; apply (Qpos_ispos ((1#2)*g))). abstract (clear - Hb0; destruct Hb0; auto). exists (c :: c1). - split. apply Qpos_nonneg. split; intros x Hx. + apply FinSubset_ball_orC in Hx. destruct Hx as [ G | Hx | Hx ] using orC_ind. auto using existsC_stable. apply existsWeaken. exists c. split. intro abs; contradict abs; exists c; split; [left; reflexivity | reflexivity]. rewrite Hx. assumption. destruct Hc1a as [_ Hc1a]. destruct Hc1a as [Hc1a _]. destruct (Hc1a x Hx) as [ G | y [Hy0 Hy1]] using existsC_ind; [auto using existsC_stable|]. apply existsWeaken; exists y; split; auto. apply FinSubset_ball_cons. exact Hy0. + apply FinSubset_ball_orC in Hx. destruct Hx as [ G | Hx | Hx ] using orC_ind. auto using existsC_stable. apply existsWeaken; exists a; split. intro abs; contradict abs; exists a; split; [left; reflexivity | reflexivity]. apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)); auto with *. destruct Hc1a as [_ Hc1a]. destruct Hc1a as [_ Hc1a]; destruct (Hc1a x Hx) as [ G | y [Hy0 Hy1]] using existsC_ind; [auto using existsC_stable|]; apply existsWeaken; exists y; split; auto. apply (@FinSubset_ball_cons y). exact Hy0. - destruct Hb0 as [Hb0a Hb0b]; intros x Hx. apply FinSubset_ball_orC in Hx. destruct Hx as [ G | Hx | Hx ] using orC_ind. auto using existsC_stable. apply existsWeaken; exists b0; split; auto. apply (ball_wd _ eq_refl _ _ Hx _ _ (reflexivity _)); auto. apply Hc1b; auto. Defined. End Strong. End Finite. (* begin hide *) Add Parametric Morphism {X : MetricSpace} : (FinSubset_ball X) with signature Qeq ==> (@msp_eq _) ==> (@msp_eq (FinEnum X)) ==> iff as FinSubset_ball_wd_full. Proof. unfold FinEnum_eq. assert (Y:forall x1 x2 : Q, x1 == x2 -> forall y1 y2 : X, msp_eq y1 y2 ->forall z : FinEnum X, (FinSubset_ball _ x1 y1 z -> FinSubset_ball _ x2 y2 z)). { intros x1 x2 Hx y1 y2 Hy. induction z. intros. exfalso; exact (FinSubset_ball_nil H). intros H. apply FinSubset_ball_orC in H. destruct H as [G | H | H] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists a. split. left. reflexivity. unfold QposEq in Hx. rewrite <- Hx, <- Hy. assumption. apply FinSubset_ball_cons. apply IHz; assumption. } intros x1 x2 Hx y1 y2 Hy. cut (forall z1 x3 : FinEnum X, (forall x : X, InFinEnumC _ x z1 -> InFinEnumC _ x x3) -> (FinSubset_ball _ x1 y1 z1 -> FinSubset_ball _ x2 y2 x3)). { intros Z z1 z2 Hz. split. apply Z. intros x H. simpl in Hz. apply FinEnum_eq_equiv in Hz. rewrite <- (Hz x). exact H. intros H. eapply Y. unfold QposEq. simpl; symmetry. apply Hx. symmetry. apply Hy. eapply Z. intros a Ha. apply FinEnum_eq_equiv in Hz. apply <- (Hz a). apply Ha. eapply Y. unfold QposEq. simpl; symmetry. apply Hx. symmetry. apply Hy. assumption. } induction z1; intros z2 Hz. intro abs; exfalso; exact (FinSubset_ball_nil abs). intros H. apply FinSubset_ball_orC in H. destruct H as [G | H | H] using orC_ind. intro abs; contradict G; intro G; contradiction. assert (Z:InFinEnumC _ a z2). apply Hz. intro abs; contradict abs. exists a. split. left; reflexivity. reflexivity. rewrite -> Hx, Hy in H. clear - H Z. induction z2. exfalso; exact (FinSubset_ball_nil Z). apply FinSubset_ball_orC in Z. destruct Z as [G | Z | Z] using orC_ind. intro abs; contradict G; intro G; contradiction. rewrite -> Z in H. intro abs; contradict abs. exists a0. split. left. reflexivity. exact H. apply FinSubset_ball_cons. apply IHz2; auto. apply IHz1. intros b Hb. apply Hz. apply FinSubset_ball_cons. exact Hb. exact H. Qed. (* begin hide *) Arguments InFinEnumC [X]. Arguments FinSubset_ball [X]. (* end hide *) (** A list is equivalent to it's reverse as finite enumerations *) Lemma FinEnum_eq_rev : forall X (f:FinEnum X), msp_eq f (rev f). Proof. intros. apply FinEnum_eq_equiv. split. - intros H abs. unfold InFinEnumC, FinSubset_ball in H. contradict H; intros [y H]. contradict abs. exists y. split. rewrite <- in_rev. apply H. apply H. - intros H abs. unfold InFinEnumC, FinSubset_ball in H. contradict H; intros [y H]. contradict abs. exists y. split. rewrite in_rev. apply H. apply H. Qed. Local Open Scope uc_scope. (** [map] is comparable with classical in. A proper f with respect to the setoid equivalences would be enough. *) Lemma InFinEnumC_map : forall (X Y:MetricSpace) (f:X --> Y) a l, InFinEnumC a l -> InFinEnumC (f a) (map f l). Proof. intros. intro abs. unfold InFinEnumC, FinSubset_ball in H. contradict H; intros [y [H H0]]. contradict abs. exists (f y). split. apply in_map. exact H. rewrite H0. reflexivity. Qed. (** The map function for finite enumerations is uniformly continuous *) Definition FinEnum_map_modulus (z:Qpos) (muf : Qpos -> QposInf) (e:Qpos) := match (muf e) with | QposInfinity => z | Qpos2QposInf d => d end. (* if a is empty and b is not, then (map f a) and (map f b) are not equivalent, even if f is the constant function *) Lemma FinEnum_map_uc : forall z X Y (f:X --> Y), is_UniformlyContinuousFunction (map f:FinEnum X -> FinEnum Y) (FinEnum_map_modulus z (mu f)). Proof. intros z X Y f e. cut (forall (a b : FinEnum X) (d:Qpos), (QposInf_le d (mu f e)) -> ball (proj1_sig d) a b -> ball (m:=FinEnum Y) (proj1_sig e) (map f a) (map f b)). { intros Z a b. unfold FinEnum_map_modulus. case_eq (mu f e). intros d Hd H. apply Z with d; auto. rewrite Hd. simpl; auto with *. intros He H. apply Z with z; auto. rewrite He. constructor. } revert e. cut (forall (e d:Qpos), (QposInf_le d (mu f e)) -> forall (s1 s2 : FinEnum X), hemiMetric X (proj1_sig d) (fun a => InFinEnumC a s1) (fun a => InFinEnumC a s2) -> hemiMetric Y (proj1_sig e) (fun a => InFinEnumC a (map f s1:FinEnum Y)) (fun a => InFinEnumC a (map f s2))). { intros Z e s1 s2 d Hd [H0 H1]. split. apply Qpos_nonneg. split; apply (Z e d Hd); apply H1. } intros e d Hd s1 s2. intros H a Ha. induction s1. exfalso; exact (FinSubset_ball_nil Ha). apply FinSubset_ball_orC in Ha. destruct Ha as [G | Ha | Ha] using orC_ind. auto using existsC_stable. assert (Ha0:InFinEnumC a0 (a0::s1)). intro abs; contradict abs. exists a0. split. left. reflexivity. reflexivity. destruct (H a0 Ha0) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists (f y). split. apply InFinEnumC_map; assumption. rewrite Ha. apply (uc_prf f). apply ball_ex_weak_le with d; auto. apply IHs1; auto. intros b Hb. apply H. apply (@FinSubset_ball_cons _ b). exact Hb. Qed. (* begin hide *) Arguments FinEnum_map_uc z [X Y]. (* end hide *) Definition FinEnum_map z (X Y : MetricSpace) (f:X --> Y) : FinEnum X --> FinEnum Y := Build_UniformlyContinuousFunction (FinEnum_map_uc z f). (** maping [Cunit] is an injection from FinEnum X to FinEnum Complete X that preserves the metric *) Lemma FinEnum_map_Cunit : forall X (s1 s2:FinEnum X) (e:Qpos), ball (proj1_sig e) s1 s2 <-> ball (proj1_sig e) (map Cunit s1:FinEnum (Complete X)) (map Cunit s2). Proof. intros X s1 s2 e. split. - intros H. exact (@FinEnum_map_uc (1 # 1) _ _ Cunit e s1 s2 H). - revert s1 s2. cut (forall (s1 s2 : FinEnum X) , hemiMetric (Complete X) (proj1_sig e) (fun a => InFinEnumC a (map Cunit s1:FinEnum (Complete X))) (fun a => InFinEnumC a (map Cunit s2)) -> hemiMetric X (proj1_sig e) (fun a => InFinEnumC a s1) (fun a => InFinEnumC a s2)). { intros Z s1 s2. intros [epos [H0 H1]]. split. exact epos. split; apply Z; assumption. } intros s1 s2 H a Ha. induction s1. exfalso; exact (FinSubset_ball_nil Ha). apply FinSubset_ball_orC in Ha. destruct Ha as [G | Ha | Ha] using orC_ind. auto using existsC_stable. clear IHs1. assert (Ha0:InFinEnumC (Cunit a0) (map Cunit (a0::s1))). intro abs; contradict abs. exists (Cunit a0). split. left; reflexivity. reflexivity. destruct (H _ Ha0) as [G | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. clear - Ha Hy0 Hy1. induction s2. exfalso; exact (FinSubset_ball_nil Hy0). apply FinSubset_ball_orC in Hy0. destruct Hy0 as [G | Hy0 | Hy0] using orC_ind. auto using existsC_stable. apply existsWeaken. exists a1. split. intro abs; contradict abs. exists a1. split. left; reflexivity. reflexivity. rewrite Ha. rewrite <- ball_Cunit. rewrite <- Hy0. assumption. destruct (IHs2 Hy0) as [G | z [Hz0 Hz1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists z. split; auto. apply FinSubset_ball_cons. exact Hz0. apply IHs1; auto. intros b Hb. apply H. apply FinSubset_ball_cons. exact Hb. Qed. corn-8.20.0/metric2/Graph.v000066400000000000000000000517021473720167500153600ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.metric2.UniformContinuity. Require Export CoRN.metric2.Compact. Require Export CoRN.metric2.Prelength. Require Export CoRN.metric2.CompleteProduct. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.logic.Classic. Set Implicit Arguments. Local Open Scope Q_scope. Section Graph. (** * Graphing Uniformly continuous functions over compact sets can be graph. A graph of a funciton f : X --> Y is the the subset of X*Y {(x,f x) | x in S} where S is the domain under consideration. This graph is compact when S is a compact subset of X. *) Variable X Y:MetricSpace. Let XY := ProductMS X Y. (** [graphPoint] is the fundamental function of graphing. It will be lifted in various ways to produce a graph *) Definition graphPoint_raw (f:X -> Y) (x:X) : XY := (x,f x). Local Open Scope uc_scope. Variable f : X --> Y. Definition graphPoint_modulus (e:Qpos) : Qpos := match (mu f e) with | QposInfinity => e | Qpos2QposInf d => Qpos_min e d end. Lemma graphPoint_uc : is_UniformlyContinuousFunction (graphPoint_raw f) graphPoint_modulus. Proof. intros e a b H. unfold graphPoint_modulus in *. split. change (ball_ex e a b). eapply ball_ex_weak_le;[|apply H]. destruct (mu f e) as [d|]. apply Qpos_min_lb_l. apply Qle_refl. apply uc_prf. eapply ball_ex_weak_le;[|apply H]. destruct (mu f e) as [d|]. apply Qpos_min_lb_r. constructor. Qed. Definition graphPoint : X --> XY := Build_UniformlyContinuousFunction graphPoint_uc. (** The compact image of graphFunction is the graph of [Cmap f] over any compact set S *) Definition CompactGraph (plFEX:PrelengthSpace (FinEnum X)) : Compact X --> Compact XY := CompactImage (1#1) plFEX graphPoint. Lemma CompactGraph_correct1 : forall plX plFEX x s, (inCompact x s) -> inCompact (Couple (x,(Cmap plX f x))) (CompactGraph plFEX s). Proof. intros plX plFEX x s Hs. unfold CompactGraph. setoid_replace (Couple (X:=X) (Y:=Y) (x, (Cmap plX f x))) with (Cmap plX graphPoint x). auto using CompactImage_correct1. intros e1 e2. rewrite Qplus_0_r. split;simpl. unfold graphPoint_modulus. eapply ball_weak_le;[|apply regFun_prf]. destruct (mu f e2); simpl. assert (Qmin (proj1_sig e2) (proj1_sig q) <= proj1_sig e2) by auto with *. rewrite -> Qle_minus_iff in *. rewrite Q_Qpos_min. rewrite <- Qle_minus_iff. apply Qplus_le_r. rewrite <- Qle_minus_iff in H. exact H. apply Qle_refl. apply (mu_sum plX e2 (e1::nil) f). simpl. unfold graphPoint_modulus. eapply ball_ex_weak_le;[|apply regFun_prf_ex]. destruct (mu f e1) as [d0|]; try constructor. destruct (mu f e2) as [d|]; try constructor. simpl. rewrite Q_Qpos_min. assert (Qmin (proj1_sig e2) (proj1_sig d) <= proj1_sig d) by auto with *. apply Qplus_le_r. exact H. Qed. Lemma CompactGraph_correct2 : forall plFEX p s, inCompact p (CompactGraph plFEX s) -> inCompact (Cfst p) s. Proof. intros plFEX p s H e1 e2. simpl. unfold Cfst_raw. apply FinSubset_ball_closed. intros d dpos. set (d':=((1#2)*exist _ _ dpos)%Qpos). assert (Qeq (proj1_sig e1 + proj1_sig e2 + d) (proj1_sig ((e1 + d') + (d'+ e2))%Qpos)) by (simpl; ring). apply (@FinSubset_ball_wd_full _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. pose proof (H e1 d') as H'. clear H. unfold XY in *. destruct (approximate p e1) as [a b]. simpl in *. unfold FinEnum_map_modulus, graphPoint_modulus in H'. set (d2:=match mu f d' with | Qpos2QposInf d => Qpos_min d' d | QposInfinity => d' end) in *. eapply FinSubset_ball_triangle_r with (approximate s d2). clear - H'. induction (approximate s d2). exfalso; exact (FinSubset_ball_nil H'). apply FinSubset_ball_orC in H'. destruct H' as [G | [H' _] | H'] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists a0. split. left. reflexivity. assumption. apply FinSubset_ball_cons. apply IHl. assumption. eapply ball_weak_le;[|apply regFun_prf]. unfold d2. destruct (mu f d') as [d0|]; auto with *. simpl. rewrite Q_Qpos_min. assert (Qmin (proj1_sig d') (proj1_sig d0) <= proj1_sig d') by auto with *. apply Qplus_le_l. exact H. Qed. Lemma CompactGraph_correct3 : forall plX plFEX p s, inCompact p (CompactGraph plFEX s) -> msp_eq (Cmap plX f (Cfst p)) (Csnd p). Proof. intros plX plFEX p s H. apply ball_eq. intros e1 epos. apply regFunBall_e. intros e2. set (e':=((1#6)*exist _ _ epos)%Qpos). setoid_replace (proj1_sig e2 + e1 + proj1_sig e2) with (proj1_sig ((e2 + e') + ((e' + e') + (e' + e')) + (e2 + e'))%Qpos) by (unfold e'; simpl; ring). set (d' := graphPoint_modulus e'). assert (Hd'1 : proj1_sig d' <= proj1_sig e'). unfold d', graphPoint_modulus. destruct (mu f e'); auto with *. apply Qpos_min_lb_l. assert (Hd'2 : QposInf_le d' (mu f e')). unfold d', graphPoint_modulus. destruct (mu f e'). apply Qpos_min_lb_r. constructor. assert (H':= H d' d'). apply ball_triangle with (approximate (Csnd p) d'). apply ball_triangle with (f (Cfst_raw p d')). apply (mu_sum plX e' (e2::nil) f). simpl. apply ball_ex_weak_le with (mu f e2 + d')%QposInf. destruct (mu f e2); try constructor. destruct (mu f e'); try constructor. clear - Hd'2. simpl in *. apply Qplus_le_r. exact Hd'2. unfold Cfst_raw. simpl. assert (Z:=regFun_prf_ex p (mu f e2) d'). destruct (mu f e2); try constructor. destruct Z; auto. assert (L:existsC X (fun x => ball (proj1_sig d' + proj1_sig d') (approximate p d') (x, (f x)))). clear -H'. simpl in H'. unfold FinEnum_map_modulus, graphPoint_modulus in H'. induction (@approximate _ (FinEnum_ball X) s (Qpos2QposInf match @mu X Y f d' return Qpos with | Qpos2QposInf d => Qpos_min d' d | QposInfinity => d' end)). exfalso; exact (FinSubset_ball_nil H'). apply FinSubset_ball_orC in H'. destruct H' as [G | H | H] using orC_ind. intro abs; contradict G; intro G; contradiction. apply existsWeaken. exists a. apply H. auto. clear - L Hd'1 Hd'2 plX. destruct L as [G | a [Hl Hr]] using existsC_ind. apply (msp_stable (msp _)), G. apply ball_triangle with (f a). simpl. apply (mu_sum plX e' (e'::nil) f). simpl. unfold graphPoint_modulus in d'. apply ball_ex_weak_le with (d' + d')%Qpos. clear - Hd'2. destruct (mu f e'); try constructor. simpl in *. apply Qplus_le_compat; exact Hd'2. apply Hl. apply ball_sym. eapply ball_weak_le;[|apply Hr]. simpl. clear - Hd'1. apply Qplus_le_compat; exact Hd'1. eapply ball_weak_le;[|apply regFun_prf]. simpl. rewrite Qplus_comm. apply Qplus_le_r. exact Hd'1. Qed. Lemma CompactGraph_graph : forall (plX : PrelengthSpace X) plFEX p q1 q2 s, inCompact (Couple (p,q1)) (CompactGraph plFEX s) -> inCompact (Couple (p,q2)) (CompactGraph plFEX s) -> msp_eq q1 q2. Proof. intros plX plFEX p q1 q2 s Hq1 Hq2. transitivity (Cmap plX f p). symmetry. rewrite <- (CoupleCorrect2 p q1). refine (CompactGraph_correct3 _ _). apply Hq1. rewrite <- (CoupleCorrect2 p q2). refine (CompactGraph_correct3 _ _). apply Hq2. Qed. Lemma CompactGraph_correct : forall plX plFEX x y s, inCompact (Couple (x,y)) (CompactGraph plFEX s) <-> (inCompact x s /\ msp_eq y (Cmap plX f x)). Proof. intros plX plFEX x y s. split; intros H. split; rewrite <- (CoupleCorrect2 x y). apply (@CompactGraph_correct2 plFEX). exact H. symmetry. transitivity (Csnd (Couple (x,y))). refine (CompactGraph_correct3 _ _). apply H. apply CoupleCorrect3. destruct H as [H0 H1]. change (x, y) with (PairMS x y). rewrite -> H1. apply CompactGraph_correct1. auto. Qed. End Graph. Section GraphBind. (** ** Graph and Bind The previous section used [graphPoint] to produce the graph of [Cmap f] over any compact set S. In this section we use [graphPoint_b] to produce the graph of [Cbind f] over any compact set S. It proceeds in largely the same way. *) (*This section ought to be defined in terms of Graph, but I'm too tired to figure out how to do it properly. Instead I just brainlessly cut and paste and modify the above section. *) Variable X Y:MetricSpace. Let XY := ProductMS X Y. Definition graphPoint_b_raw (f:X -> Complete Y) (x:X) : Complete XY := Couple (Cunit x,f x). Local Open Scope uc_scope. Variable f : X --> Complete Y. Lemma graphPoint_b_uc : is_UniformlyContinuousFunction (graphPoint_b_raw f) (graphPoint_modulus f). Proof. intros e a b H d1 d2. split. change (ball_ex (Qpos2QposInf d1 + e + Qpos2QposInf d2) a b). eapply ball_ex_weak_le;[|apply H]. unfold graphPoint_modulus. destruct (mu f e) as [d|]. - simpl. apply Qle_trans with (proj1_sig e + 0). rewrite Qplus_0_r. apply Qpos_min_lb_l. rewrite <- (Qplus_comm (proj1_sig e)), <- Qplus_assoc. apply Qplus_le_r. apply (Qpos_nonneg (d1+d2)). - simpl. apply Qle_trans with (proj1_sig e + 0). rewrite Qplus_0_r. apply Qle_refl. rewrite <- (Qplus_comm (proj1_sig e)), <- Qplus_assoc. apply Qplus_le_r. apply (Qpos_nonneg (d1+d2)). - simpl. revert d1 d2. change (ball (proj1_sig e) (f a) (f b)). apply uc_prf. eapply ball_ex_weak_le;[|apply H]. unfold graphPoint_modulus. destruct (mu f e) as [d|]. apply Qpos_min_lb_r. constructor. Qed. Definition graphPoint_b : X --> Complete XY := Build_UniformlyContinuousFunction graphPoint_b_uc. Definition CompactGraph_b (plFEX:PrelengthSpace (FinEnum X)) : Compact X --> Compact XY := CompactImage_b (1#1) plFEX graphPoint_b. Local Open Scope Q_scope. Lemma CompactGraph_b_correct1 : forall plX plFEX x s, (inCompact x s) -> inCompact (Couple (x,(Cbind plX f x))) (CompactGraph_b plFEX s). Proof. intros plX plFEX x s Hs. unfold CompactGraph_b. setoid_replace (Couple (X:=X) (Y:=Y) (x, (Cbind plX f x))) with (Cbind plX graphPoint_b x). auto using CompactImage_b_correct1. intros e1 e2. rewrite Qplus_0_r. split. apply ball_weak_le with (proj1_sig (e1 + (graphPoint_modulus f ((1 # 2) * e2)))%Qpos) ;[|apply regFun_prf]. unfold graphPoint_modulus. destruct (mu f ((1#2)*e2)). simpl. rewrite Q_Qpos_min. assert (Qmin ((1#2)*proj1_sig e2) (proj1_sig q) <= ((1#2)*proj1_sig e2)) by auto with *. apply Qplus_le_r. apply (Qle_trans _ _ _ H). rewrite <- (Qmult_1_l (proj1_sig e2)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. simpl. apply Qplus_le_r. rewrite <- (Qmult_1_l (proj1_sig e2)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. simpl. unfold Cjoin_raw. rewrite <- ball_Cunit. setoid_replace (proj1_sig e1 + proj1_sig e2) with (proj1_sig ((1#2)*e1 + ((1#2)*e1 + (1#2)*e2) + (1#2)*e2)%Qpos) by (simpl; ring). eapply ball_triangle;[|apply ball_approx_r]. eapply ball_triangle. apply (ball_approx_l (approximate (Cmap_fun plX f x) (Qpos2QposInf ((1 # 2)%Qpos * e1))) ((1#2)*e1)). set (e1':=((1 # 2) * e1)%Qpos). set (e2':=((1 # 2) * e2)%Qpos). simpl. apply (mu_sum plX e2' (e1'::nil) f). apply ball_ex_weak_le with (e:= (mu f e1' + graphPoint_modulus f ((1 # 2) * e2))%QposInf). 2: apply regFun_prf_ex. unfold e1'. unfold graphPoint_modulus. replace (fold_right QposInf_plus (mu f e2') (map (mu f) (((1 # 2) * e1)%Qpos :: nil))) with (mu f ((1 # 2) * e1) + mu f e2')%QposInf by reflexivity. destruct (mu f ((1#2)*e1)) as [d0|]; try constructor. unfold e2'. destruct (mu f ((1 # 2) * e2)) as [d|]; try constructor. simpl. rewrite Q_Qpos_min. assert (Qmin (proj1_sig e2') (proj1_sig d) <= proj1_sig d) by auto with *. apply Qplus_le_r. exact H. Qed. Lemma CompactGraph_b_correct2 : forall plFEX p s, inCompact p (CompactGraph_b plFEX s) -> inCompact (Cfst p) s. Proof. intros plFEX p s H e1 e2. simpl. unfold Cfst_raw. apply FinSubset_ball_closed. intros d dpos. set (d':=((1#2)*exist _ _ dpos)%Qpos). assert (Qeq (proj1_sig e1 + proj1_sig e2 + d) (proj1_sig ((e1 + d') + (d'+ e2))%Qpos)) by (simpl; ring). apply (@FinSubset_ball_wd_full _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. assert (H':=H e1 d'). clear H. unfold XY in *. destruct (approximate p e1) as [a b]. simpl in *. unfold Cjoin_raw in H'. simpl in *. unfold FinEnum_map_modulus, graphPoint_modulus in H'. remember (match mu f ((1#2)*d') with | Qpos2QposInf d => Qpos_min ((1#2)*d') d | QposInfinity => ((1#2)*d')%Qpos end) as d2. simpl in Heqd2. rewrite <- Heqd2 in H'. eapply FinSubset_ball_triangle_r with (approximate s d2). clear - H'. induction (approximate s d2). exfalso; exact (FinSubset_ball_nil H'). apply FinSubset_ball_orC in H'. destruct H' as [G | [H' _] | H'] using orC_ind. intro abs; contradict G; intro G; contradiction. intro abs; contradict abs. exists a0. split. left. reflexivity. assumption. apply FinSubset_ball_cons. apply IHl. assumption. eapply ball_weak_le;[|apply regFun_prf]. rewrite Heqd2. destruct (@mu X (Complete Y) f (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) d')) as [d0|]. simpl. assert (Qmin ((1#2)* proj1_sig d') (proj1_sig d0) <= ((1#2)*proj1_sig d')) by auto with *. apply Qplus_le_l. rewrite Q_Qpos_min. apply (Qle_trans _ _ _ H). apply Qmult_le_l. reflexivity. simpl. rewrite <- (Qmult_1_l d) at 2. apply Qmult_le_r. apply dpos. discriminate. simpl. apply Qplus_le_l. rewrite <- (Qmult_1_l ((1 # 2) * d)) at 2. apply Qmult_le_r. apply (Qpos_ispos d'). discriminate. Qed. Lemma CompactGraph_b_correct3 : forall plX plFEX p s, inCompact p (CompactGraph_b plFEX s) -> msp_eq (Cbind plX f (Cfst p)) (Csnd p). Proof. intros plX plFEX p s H. apply ball_eq. intros e1 epos. apply regFunBall_e. intros e2. set (e':=((1#6)*exist _ _ epos)%Qpos). setoid_replace (proj1_sig e2 + e1 + proj1_sig e2) with (proj1_sig ((e2 + e') + ((e' + e') + (e' + e')) + (e2 + e'))%Qpos) by (unfold e'; simpl; ring). set (d' := graphPoint_modulus f ((1#2)*e')). assert (Hd'1 : proj1_sig d' <= proj1_sig e'). unfold d', graphPoint_modulus. destruct (mu f ((1#2)*e')); autorewrite with QposElim. apply Qle_trans with ((1#2)*proj1_sig e'); auto with *. rewrite <- (Qmult_1_l (proj1_sig e')) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. rewrite <- (Qmult_1_l (proj1_sig e')). apply Qmult_le_r. apply Qpos_ispos. discriminate. assert (Hd'2 : QposInf_le (d') (mu f ((1#2)*e'))). unfold d', graphPoint_modulus. destruct (mu f ((1#2)*e')). apply Qpos_min_lb_r. constructor. assert (H':= H ((1#2)*d')%Qpos d'). apply ball_triangle with (approximate (Csnd p) (Qpos2QposInf ((1#2)%Qpos*d'))). simpl (approximate (Cbind plX f (Cfst (X:=X) (Y:=Y) p)) e2). apply ball_triangle with (approximate (f (Cfst_raw p (Qpos2QposInf (1#2)*d'))) (Qpos2QposInf (1#2)*d'))%Qpos. unfold Cjoin_raw. simpl. apply ball_weak_le with (proj1_sig ((1#2)*e2 + ((1#2)*e2 + (1#2)*e') + (1#2)*d')%Qpos). simpl. clear - Hd'1. rewrite -> Qle_minus_iff in *. setoid_replace (proj1_sig e2 + (1 # 6) * e1 + - ((1 # 2) * proj1_sig e2 + ((1 # 2) * proj1_sig e2 + (1 # 2) * ((1 # 6) * e1)) + (1 # 2) * proj1_sig d')) with ((1 # 2) * (proj1_sig e' + - proj1_sig d')) by (simpl; ring). apply Qmult_le_0_compat. discriminate. exact Hd'1. cut (ball ((1 # 2) * proj1_sig e2 + (1 # 2) * proj1_sig e') (f (Cfst_raw p (mu f ((1 # 2) * e2)))) (f (Cfst_raw p ((1 # 2) * d')%Qpos))). intros L. apply L. apply (mu_sum plX ((1#2)*e') (((1#2)*e2)::nil) f)%Qpos. apply ball_ex_weak_le with (QposInf_plus (mu f ((1#2)*e2)) (Qpos2QposInf (1#2)*d'))%Qpos. simpl. destruct (@mu X (Complete Y) f (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) e2)) ; try constructor. simpl in Hd'2. destruct (@mu X (Complete Y) f (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) e')) ; try constructor. clear - Hd'2. simpl in *. apply Qplus_le_r. refine (Qle_trans _ _ _ _ Hd'2). rewrite <- (Qmult_1_l (proj1_sig d')) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. unfold Cfst_raw. assert (Z:=regFun_prf_ex p (mu f ((1#2)*e2)) (Qpos2QposInf (1#2)%Qpos*d')). destruct (mu f ((1#2)*e2)); try constructor. destruct Z; auto. assert (L:existsC X (fun x => ball (proj1_sig (((1#2)*d') + d')%Qpos) (approximate p (Qpos2QposInf (1#2)%Qpos*d')) (Couple_raw ((Cunit x), (f x)) (Qpos2QposInf ((1#2)*d')%Qpos)))). clear -H'. simpl in H'. unfold Cjoin_raw in H'. simpl in H'. unfold FinEnum_map_modulus, graphPoint_modulus in H'. remember (match mu f ((1 # 2) * d') with | Qpos2QposInf d => Qpos_min ((1 # 2) * d') d | QposInfinity => ((1 # 2) * d')%Qpos end) as mm. simpl in Heqmm. rewrite <- Heqmm in H'. induction (@approximate _ (FinEnum_ball X) s mm). exfalso; exact (FinSubset_ball_nil H'). apply FinSubset_ball_orC in H'. destruct H' as [G | H | H] using orC_ind. intro abs; contradict G; intro G; contradiction. apply existsWeaken. exists a. apply H. auto. clear - L Hd'1 Hd'2 plX. destruct L as [G | a [Hl Hr]] using existsC_ind. apply (msp_stable (msp _)), G. apply ball_triangle with (approximate (f a) (Qpos2QposInf ((1#2)%Qpos*d'))). apply ball_weak_le with (proj1_sig ((1#2)*d' + ((1#2)*e' + (1#2)*e') + (1#2)*d')%Qpos). clear - Hd'1. simpl. rewrite -> Qle_minus_iff in *. setoid_replace ( (1 # 6) * e1 + (1 # 6) * e1 + - ((1 # 2) * proj1_sig d' + ((1 # 2) * ((1 # 6) * e1) + (1 # 2) * ((1 # 6) * e1)) + (1 # 2) * proj1_sig d')) with (proj1_sig e' + - proj1_sig d') by (simpl; ring). exact Hd'1. simpl. rewrite <- ball_Cunit. eapply ball_triangle;[|apply (ball_approx_r _ ((1#2)*d')%Qpos)]. eapply ball_triangle;[apply (ball_approx_l _ ((1#2)*d'))|]. apply (mu_sum plX ((1#2)*e') (((1#2)*e')::nil) f)%Qpos. simpl. unfold graphPoint_modulus in d'. apply ball_ex_weak_le with (d' + d')%Qpos. clear - Hd'2. simpl in Hd'2. destruct (@mu X (Complete Y) f (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Z.pos xH; Qden := xO xH |} (@eq_refl comparison Lt)) e')) ; try constructor. simpl in *. apply Qplus_le_compat; exact Hd'2. simpl. eapply ball_weak_le;[|apply Hl]. simpl. apply Qplus_le_l. rewrite <- (Qmult_1_l (proj1_sig d')) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply ball_sym. eapply ball_weak_le;[|apply Hr]. apply Qplus_le_compat. 2: exact Hd'1. refine (Qle_trans _ _ _ _ Hd'1). rewrite <- (Qmult_1_l (proj1_sig d')). apply Qmult_le_r. apply Qpos_ispos. discriminate. eapply ball_weak_le;[|apply (regFun_prf (Csnd p) ((1#2)*d')%Qpos)]. rewrite Qplus_comm. apply Qplus_le_r. refine (Qle_trans _ _ _ _ Hd'1). rewrite <- (Qmult_1_l (proj1_sig d')). apply Qmult_le_r. apply Qpos_ispos. discriminate. Qed. Lemma CompactGraph_b_graph : forall (plX : PrelengthSpace X) plFEX p q1 q2 s, inCompact (Couple (p,q1)) (CompactGraph_b plFEX s) -> inCompact (Couple (p,q2)) (CompactGraph_b plFEX s) -> msp_eq q1 q2. Proof. intros plX plFEX p q1 q2 s Hq1 Hq2. transitivity (Cbind plX f p). symmetry. rewrite <- (CoupleCorrect2 p q1). refine (CompactGraph_b_correct3 _ _). apply Hq1. rewrite <- (CoupleCorrect2 p q2). refine (CompactGraph_b_correct3 _ _). apply Hq2. Qed. Lemma CompactGraph_b_correct : forall plX plFEX x y s, inCompact (Couple (x,y)) (CompactGraph_b plFEX s) <-> (inCompact x s /\ msp_eq y (Cbind plX f x)). Proof. intros plX plFEX x y s. split; intros H. split; rewrite <- (CoupleCorrect2 x y). apply (@CompactGraph_b_correct2 plFEX). exact H. symmetry. transitivity (Csnd (Couple (x,y))). refine (CompactGraph_b_correct3 _ _). apply H. apply CoupleCorrect3. destruct H as [H0 H1]. change (x, y) with (PairMS x y). rewrite -> H1. apply CompactGraph_b_correct1. auto. Qed. End GraphBind. corn-8.20.0/metric2/Hausdorff.v000066400000000000000000000365221473720167500162430ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.logic.Classic. Require Export CoRN.metric2.Metric. Require Import CoRN.metric2.Classification. Require Import Coq.Lists.List. From Coq Require Import ZArith. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. Local Open Scope Q_scope. Section HausdorffMetric. (** * Hausdorff Metric This module defines the Hausdorff metric on the subsets of a metric space X. Subsets are defined as predicates X -> Prop here. The Hausdorff distance between unbounded subsets is often infinite, which is accepted by our definition of a metric via the ball propositions. To get a separated metric we have to restrict to closed subsets of X, so that when the Hausdorff distance between A and B is zero, then A and B are subsets of each other (equality of subsets). One can still compute the Hausdorff distance between non-closed subsets, it is equal to the distance between the closures of the subsets. *) Variable X : MetricSpace. (** This is the (weak) hemiMetric, which makes an asymmetric metric. We make use of the classical quantifer in this definition, so that pairs of points {x,y} are compact subsets. *) Definition hemiMetric (e:Q) (A B: X -> Prop) := forall x:X, A x -> existsC X (fun (y:X) => B y /\ ball e x y). (** This (weak) metric, makes the full symmetric metric. *) Definition hausdorffBall (e:Q) (A B: X -> Prop) := 0 <= e /\ hemiMetric e A B /\ hemiMetric e B A. Lemma hemiMetric_wd1 : forall (e0 e1:Q) A B, (e0 == e1) -> hemiMetric e0 A B -> hemiMetric e1 A B. Proof. intros e0 e1 A B He H x Hx. destruct (H x Hx) as [HG | y [Hy Hxy]] using existsC_ind. apply existsC_stable; assumption. apply existsWeaken. exists y. split. exact Hy. unfold QposEq in He. rewrite -> He in Hxy; auto. Qed. Lemma hausdorffBall_wd1 : forall (e0 e1:Q) A B, (e0 == e1) -> hausdorffBall e0 A B -> hausdorffBall e1 A B. Proof. intros e0 e1 A B He [H0 H1]. split. rewrite <- He. exact H0. split; apply hemiMetric_wd1 with e0. exact He. apply H1. exact He. apply H1. Qed. Lemma hemiMetric_refl : forall (e:Q) A, 0 <= e -> hemiMetric e A A. Proof. intros e epos A x Hx. apply existsWeaken. exists x. split; try assumption. apply ball_refl. exact A. Qed. Lemma hausdorffBall_refl : forall (e:Q) A, 0 <= e -> hausdorffBall e A A. Proof. intros e A epos. split. exact epos. split; apply hemiMetric_refl; exact epos. Qed. Lemma hausdorffBall_sym : forall e A B, hausdorffBall e A B -> hausdorffBall e B A. Proof. intros e A B [H0 H1]. split. exact H0. split; apply H1. Qed. Lemma hemiMetric_triangle : forall e0 e1 A B C, hemiMetric e0 A B -> hemiMetric e1 B C -> hemiMetric (e0 + e1) A C. Proof. intros e0 e1 A B C H0 H1 x Hx. destruct (H0 x Hx) as [HG | y [Hy Hxy]] using existsC_ind. apply existsC_stable; assumption. destruct (H1 y Hy) as [HG | z [Hz Hyz]] using existsC_ind. apply existsC_stable; assumption. apply existsWeaken. exists z. split; try assumption. apply ball_triangle with y; assumption. Qed. Lemma hausdorffBall_triangle : forall e0 e1 A B C, hausdorffBall e0 A B -> hausdorffBall e1 B C -> hausdorffBall (e0 + e1) A C. Proof. intros e0 e1 A B C [H0A H0B] [H1A H1B]. split. apply (Qle_trans _ (e0 + 0)). rewrite Qplus_0_r. exact H0A. apply Qplus_le_r. exact H1A. split. apply hemiMetric_triangle with B. apply H0B. apply H1B. apply hemiMetric_wd1 with (e1 + e0)%Q. ring. apply hemiMetric_triangle with B. apply H1B. apply H0B. Qed. (** Unfortunately this isn't a metric for an aribitrary predicate. More assumptions are needed to show our definition of ball is closed. See FinEnum for an example of an instance of the Hausdorff metric. *) Lemma hemiMetric_stable :forall e A B, ~~(hemiMetric e A B) -> hemiMetric e A B. Proof. unfold hemiMetric. auto 7 using existsC_stable. Qed. Lemma hausdorffBall_stable :forall e A B, ~~(hausdorffBall e A B) -> hausdorffBall e A B. Proof. unfold hausdorffBall. firstorder using hemiMetric_stable. Qed. Lemma hemiMetric_wd :forall (e1 e2:Q), (e1 == e2) -> forall A1 A2, (forall x, A1 x <-> A2 x) -> forall B1 B2, (forall x, B1 x <-> B2 x) -> (hemiMetric e1 A1 B1 <-> hemiMetric e2 A2 B2). Proof. cut (forall e1 e2 : Q, e1 == e2 -> forall A1 A2 : X -> Prop, (forall x : X, A1 x <-> A2 x) -> forall B1 B2 : X -> Prop, (forall x : X, B1 x <-> B2 x) -> (hemiMetric e1 A1 B1 -> hemiMetric e2 A2 B2)). intros; split. eauto. symmetry in H0. assert (H1':forall x : X, A2 x <-> A1 x) by firstorder. assert (H2':forall x : X, B2 x <-> B1 x) by firstorder. eauto. intros e1 e2 He A1 A2 HA B1 B2 HB H x Hx. rewrite <- HA in Hx. destruct (H x Hx) as [HG | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. change (e1 == e2) in He. rewrite <- HB. split. exact Hy0. rewrite <- He. assumption. Qed. Lemma hausdorffBall_wd :forall (e1 e2:Q), (e1 == e2) -> forall A1 A2, (forall x, A1 x <-> A2 x) -> forall B1 B2, (forall x, B1 x <-> B2 x) -> (hausdorffBall e1 A1 B1 <-> hausdorffBall e2 A2 B2). Proof. intros. unfold hausdorffBall. setoid_replace (hemiMetric e1 A1 B1) with (hemiMetric e2 A2 B2). setoid_replace (hemiMetric e1 B1 A1) with (hemiMetric e2 B2 A2). 2: apply hemiMetric_wd; auto. 2: apply hemiMetric_wd; auto. rewrite H. reflexivity. Qed. End HausdorffMetric. Section HausdorffMetricStrong. Variable X : MetricSpace. (** ** Strong Hausdorff Metric This section introduces an alternative stronger notition of Haudorff metric that uses a constructive existential. *) Definition hemiMetricStrong (e:Q) (A B: X -> Prop) := forall x:X, A x -> forall d:Qpos, {y:X | B y /\ ball (e+ proj1_sig d) x y}. Definition hausdorffBallStrong (e:Q) (A B: X -> Prop) := (hemiMetricStrong e A B * hemiMetricStrong e B A)%type. Lemma hemiMetricStrong_wd1 : forall (e0 e1:Q) A B, (e0 == e1) -> hemiMetricStrong e0 A B -> hemiMetricStrong e1 A B. Proof. intros e0 e1 A B He H x Hx d. destruct (H x Hx d) as [y [Hy Hxy]]. exists y. split. exact Hy. rewrite <- He. exact Hxy. Qed. Lemma hausdorffBallStrong_wd1 : forall (e0 e1:Q) A B, (e0 == e1) -> hausdorffBallStrong e0 A B -> hausdorffBallStrong e1 A B. Proof. intros e0 e1 A B He [H0 H1]. split; apply hemiMetricStrong_wd1 with e0; assumption. Qed. Lemma hemiMetricStrong_refl : forall (e:Q) A, 0 <= e -> hemiMetricStrong e A A. Proof. intros e A epos x Hx d. exists x. split; try assumption. apply ball_refl. apply (Qle_trans _ (e+0)). rewrite Qplus_0_r. exact epos. apply Qplus_le_r. apply (Qpos_nonneg d). Qed. Lemma hausdorffBallStrong_refl : forall (e:Q) A, 0 <= e -> hausdorffBallStrong e A A. Proof. intros e A. split; apply hemiMetricStrong_refl; exact H. Qed. Lemma hausdorffBallStrong_sym : forall e A B, hausdorffBallStrong e A B -> hausdorffBallStrong e B A. Proof. intros e A B [H0 H1]. split; assumption. Qed. Lemma hemiMetricStrong_triangle : forall e0 e1 A B C, hemiMetricStrong e0 A B -> hemiMetricStrong e1 B C -> hemiMetricStrong (e0 + e1) A C. Proof. intros e0 e1 A B C H0 H1 x Hx d. assert (0 < (1#2)) as halfPos. reflexivity. destruct (H0 x Hx (exist _ _ halfPos*d)%Qpos) as [y [Hy Hxy]]. destruct (H1 y Hy (exist _ _ halfPos*d)%Qpos) as [z [Hz Hyz]]. exists z. split; try assumption. setoid_replace (e0 + e1 + proj1_sig d) with ((e0 + (1#2) * proj1_sig d) +(e1 + (1#2) * proj1_sig d))%Q by (simpl; ring). apply ball_triangle with y; assumption. Qed. Lemma hausdorffBallStrong_triangle : forall e0 e1 A B C, hausdorffBallStrong e0 A B -> hausdorffBallStrong e1 B C -> hausdorffBallStrong (e0 + e1) A C. Proof. intros e0 e1 A B C [H0A H0B] [H1A H1B]. split. apply hemiMetricStrong_triangle with B; assumption. apply hemiMetricStrong_wd1 with (e1 + e0)%Q. unfold QposEq. simpl. ring. apply hemiMetricStrong_triangle with B; assumption. Qed. (* Lemma hemiMetricStrong_closed : forall e A B, FinitelyEnumerable X B -> (forall d, hemiMetricStrong (e+d) A B) -> hemiMetricStrong e A B. Proof. intros e A B HB H x Hx d. destruct (H ((1#2)*d)%Qpos x Hx ((1#2)*d)%Qpos) as [y [Hy Hxy]]. exists y. split; try assumption. setoid_replace (e + d)%Qpos with (e + (1 # 2) * d + (1 # 2) * d)%Qpos by QposRing. assumption. Qed. Lemma hausdorffBallStrong_closed : forall e A B, FinitelyEnumerable X A -> FinitelyEnumerable X B -> (forall d, hausdorffBallStrong (e+d) A B) -> hausdorffBallStrong e A B. Proof. intros e A B HA HB H. split; apply hemiMetricStrong_closed; try assumption; intros d; destruct (H d); assumption. Qed. *) (* Lemma HemiMetricStrongHemiMetric : stableMetric X -> forall (e:Qpos) A B, SubFinite X B -> hemiMetricStrong e A B -> hemiMetric X e A B. Proof. intros HX e A B HB H. apply hemiMetric_closed; try assumption. unfold hemiMetric. intros d x Hx. apply existsWeaken. destruct (H x Hx d) as [y Hy]. exists y. assumption. Qed. Lemma HausdorffBallStrongHausdorffBall : stableMetric X -> forall (e:Qpos) A B, SubFinite X A -> SubFinite X B -> hausdorffBallStrong e A B -> hausdorffBall X e A B. Proof. intros HX e A B HA HB [H0 H1]. split; auto using HemiMetricStrongHemiMetric. Qed. *) Hypothesis almostDecideX : locatedMetric X. (* Lemma HemiMetricHemiMetricStrong : forall (e:Qpos) A B, FinitelyEnumerable X B -> hemiMetric X e A B -> hemiMetricStrong e A B. Proof. intros e A B [l Hl] H x Hx. generalize (H x Hx). clear H. revert B Hl x Hx. induction l; intros B Hl x Hx H d. exfalso. generalize H. apply existsC_ind. tauto. intros y [Hy0 Hy1]. apply -> Hl. apply Hy0. auto. destruct (almostDecideX e (e+d)%Qpos x a). abstract ( autorewrite with QposElim; rewrite Qlt_minus_iff; ring_simplify; auto with * ). exists a. destruct (Hl a); auto with *. set (B':=fun x => ~~In x l). assert ({ y : X | B' y /\ ball (m:=X) (e + d) x y}). apply IHl; auto. reflexivity. destruct (H) as [HG | y [Hy0 Hy1]] using existsC_ind. auto using existsC_stable. apply existsWeaken. exists y. abstract ( split; auto; intros Y; apply -> Hl;[apply Hy0|]; intros H; apply Y; destruct H as [H|H]; [rewrite H in n; contradiction|auto with *]). destruct X0 as [y [Hy0 Hy1]]. exists y. abstract ( split; auto; apply <- Hl; auto 7 with * ). Defined. Lemma HausdorffBallHausdorffBallStrong : forall (e:Qpos) A B, FinitelyEnumerable X A -> FinitelyEnumerable X B -> hausdorffBall X e A B -> hausdorffBallStrong e A B. intros e A B HA HB [H0 H1]. split; auto using HemiMetricHemiMetricStrong. Defined. Definition HemiMetricStrongAlmostDecidable : forall (e d:Qpos) A B, FinitelyEnumerable X A -> FinitelyEnumerable X B -> e < d -> hemiMetricStrong d A B + {hemiMetricStrong e A B->False}. Proof. assert (P1:forall (e d : Qpos) (a:X) (B : X -> Prop), FinitelyEnumerable X B -> e < d -> hemiMetricStrong d (fun x=>a=x) B + (hemiMetricStrong e (fun x=>a=x) B -> False)). intros e d a B [lB HB]. revert B HB. induction lB. intros B HB Hed. right. intros H. destruct (H a (refl_equal a) d) as [y [Hy _]]. apply -> HB. apply Hy. auto. intros B HB Hed. destruct (IHlB (fun x => ~~In x lB)) as [H|H]. tauto. assumption. left. intros x Hx d0. destruct (H x Hx d0) as [y [Hy0 Hy1]]. exists y. split; try assumption. assert (Z:=HB y); auto with *. apply <- HB. auto 7 with *. destruct (almostDecideX ((1#2)*(e+d))%Qpos d a a0). autorewrite with QposElim. rewrite Qlt_minus_iff. replace RHS with ((1#2)*(d + - e)) by ring. rewrite Qlt_minus_iff in Hed. Qauto_pos. left. intros x Hx d0. exists a0. destruct (HB a0). split; auto with *. apply ball_weak. rewrite <- Hx. assumption. right. intros H0. destruct (Qpos_lt_plus Hed) as [c Hc]. apply H. intros x Hx d0. destruct (H0 a (refl_equal a) (Qpos_min d0 ((1#2)*c)%Qpos)) as [y [Hy0 Hy1]]. destruct (HB y) as [Y _]. exists y. split. intros Z. apply Y. assumption. intros H1. apply Z; clear Z. destruct H1 as [H1 | H1]; try assumption. elim n. rewrite H1. apply ball_weak_le with (e + Qpos_min d0 ((1 # 2) * c))%Qpos; auto. autorewrite with QposElim. rewrite Hc. rewrite Qle_minus_iff. replace RHS with ((1 # 2) * c + - (Qmin d0 ((1 # 2) * c))) by ring. rewrite <- Qle_minus_iff. rapply Qpos_min_lb_r. apply ball_weak_le with (e + Qmin d0 ((1 # 2) * c))%Qpos; auto. autorewrite with QposElim. rewrite Qle_minus_iff. replace RHS with (d0 + - (Qmin d0 ((1 # 2) * c))) by ring. rewrite <- Qle_minus_iff. rapply Qmin_lb_l. congruence. intros e d A B HA HB Hed. cut (hemiMetric X d A B + {hemiMetricStrong e A B -> False}). clear - HB. intros [Y|Y]. left. apply HemiMetricHemiMetricStrong; auto. right; auto. destruct HA as [lA HA]. revert A HA HB Hed. induction lA. intros A HA HB _. left. intros x Hx. destruct (HA x) as [HAx _]. elim (HAx Hx). auto with *. intros A Ha HB Hed. pose (A':=fun x => ~~In x lA). destruct (IHlA A') as [I|I]; try assumption. unfold A'; tauto. destruct (P1 e d a B HB Hed) as [J|J]. left. intros x Hx. rewrite Ha in Hx. revert Hx. cut (In x (a::lA) -> existsC X (fun y : X => B y /\ ball (m:=X) d x y)). unfold existsC; tauto. intros Hx. destruct Hx as [Hx|Hx]. assert (J':hemiMetric X d (fun x : X => a = x) B). apply HemiMetricStrongHemiMetric; auto with *. clear - HB. destruct HB as [l Hl]. exists l. firstorder. apply J'. assumption. change (In x lA) in Hx. apply I. unfold A'; auto. right. intros H. apply J. intros x Hx d0. apply H. rewrite Ha. rewrite Hx. auto with *. right. intros H. apply I. intros x Hx d0. apply H. rewrite Ha. revert Hx. unfold A'. auto 7 with *. Defined. Definition HausdorffBallStrongAlmostDecidable : forall (e d:Qpos) A B, FinitelyEnumerable X A -> FinitelyEnumerable X B -> e < d -> hausdorffBallStrong d A B + {hausdorffBallStrong e A B->False}. Proof. intros e d A B HA HB Hed. destruct (HemiMetricStrongAlmostDecidable e d A B HA HB Hed). destruct (HemiMetricStrongAlmostDecidable e d B A HB HA Hed). left. split; assumption. right. intros [_ H]; auto. right. intros [H _]; auto. Defined. *) End HausdorffMetricStrong. (* Definition HausdorffBallAlmostDecidable : forall X, locatedMetric X -> forall (e d:Qpos) A B, FinitelyEnumerable X A -> FinitelyEnumerable X B -> e < d -> {hausdorffBall X d A B} + {~hausdorffBall X e A B}. Proof. intros X HX e d A B HA HB Hed. destruct (HausdorffBallStrongAlmostDecidable X HX e d A B HA HB Hed) as [Z|Z]. left. abstract ( apply HausdorffBallStrongHausdorffBall; (apply located_stable || apply FinitelyEnumerable_SubFinite || idtac);assumption). right. abstract ( intros H; apply Z; apply HausdorffBallHausdorffBallStrong; assumption). Defined. *) corn-8.20.0/metric2/Limit.v000066400000000000000000000327271473720167500154030ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import QArith. From Coq Require Import Bool. Require Export CoRN.metric2.Complete. Require Export MathClasses.theory.CoqStreams. Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.streams MathClasses.orders.naturals. (** ** Limits A predicate saying there exists a point in the stream where a predicate is satsified. We take the unusual step of putting this inductive type in Prop even though it contains constructive information. This is because we expect this proof to only be used in proofs of termination. *) Inductive LazyExists {A} (P : Stream A → Prop) (x : Stream A) : Prop := | LazyHere : P x → LazyExists P x | LazyFurther : (unit → LazyExists P (tl x)) → LazyExists P x. Arguments LazyHere {A P x}. Arguments LazyFurther {A P x}. #[global] Instance LazyExists_proper `{Setoid A} `{!Proper ((=) ==> iff) (P : Stream A → Prop)} : Proper ((=) ==> iff) (LazyExists P). Proof. assert (∀ s1, LazyExists P s1 → ∀ s2, s1 = s2 → LazyExists P s2) as prf. induction 1 as [|? ? IH]; intros s2 E. left. now rewrite <-E. right. intros _. apply (IH tt). now rewrite E. split; repeat intro; eapply prf; eauto. Qed. Lemma LazyExists_tl `{P : Stream A → Prop} `(ex : LazyExists P s) (Ptl : EventuallyForAll P s) : LazyExists P (tl s). Proof. destruct ex as [? | further]. left. destruct Ptl. now auto. apply (further tt). Defined. Lemma LazyExists_Str_nth_tl `{P : Stream A → Prop} `(ex : !LazyExists P s) (Ptl : EventuallyForAll P s) (n : nat) : LazyExists P (Str_nth_tl n s). Proof. induction n. easy. intros. simpl. rewrite <-tl_nth_tl. apply LazyExists_tl. now apply IHn. now apply ForAll_Str_nth_tl. Defined. Fixpoint LazyExists_inc `{P : Stream A → Prop} (n : nat) s : LazyExists P (Str_nth_tl n s) → LazyExists P s := match n return LazyExists P (Str_nth_tl n s) → LazyExists P s with | O => λ x, x | S n => λ ex, LazyFurther (λ _, LazyExists_inc n (tl s) ex) end. (* Fixpoint f (n m : nat) := match n with | O => m | S n => S (f n (f n m)) end. Fixpoint LazyExists_inc `{P : Stream A → Prop} (n : nat) `(ex : LazyExists P s) (H : EventuallyForAll P s) : LazyExists P s := match n with | O => ex | S n => LazyFurther (λ _, LazyExists_inc n (LazyExists_inc n (LazyExists_tl ex H) (EventuallyForAll_tl _ _ H)) (EventuallyForAll_tl _ _ H)) end. *) Section TakeUntil. (** takeUntil creates a list of of elements up to the first point where the predicate P is satisfied. For efficency reasons it doesn't actually build a list, but takes continuations for cons and nil instead. To build an actual list pass in the const and nil constructors. *) Fixpoint takeUntil {A B : Type} (P : Stream A → bool) {s : Stream A} (ex:LazyExists (fun x => Is_true (P x)) s) (cons: A → B → B) (nil : B) : B := (if P s as b return ((Is_true (P s) → Is_true b) → B) then λ _, nil else λ (n : Is_true (P s) → False), cons (hd s) (@takeUntil A B P (tl s) match ex with | LazyHere H => (False_ind _ (n H)) | LazyFurther ex0 => ex0 tt end cons nil)) (λ x, x). Lemma Is_true_neq_left x : x ≡ false → ¬Is_true x. Proof. intros E1 E2. pose proof (Is_true_eq_true x E2). subst. discriminate. Qed. Lemma takeUntil_wd {A B} {P : Stream A → bool} {s:Stream A} (ex1 ex2 : LazyExists (fun x => Is_true (P x)) s) (cons : A → B → B) (nil : B) : takeUntil P ex1 cons nil ≡ takeUntil P ex2 cons nil. Proof. assert (H:=ex1). induction H; case ex1; clear ex1; case ex2; clear ex2; simpl; destruct (P x); try contradiction; auto. intros ex2 ex1. rewrite (H0 tt (ex1 tt) (ex2 tt)). reflexivity. Qed. Lemma takeUntil_wd_alt `{Setoid A} `{Setoid B} `{!Proper ((=) ==> eq) (P : Stream A → bool)} `(ex1 : LazyExists (fun x => Is_true (P x)) s1) `(ex2 : LazyExists (fun x => Is_true (P x)) s2) (cons: A → B → B) `{!Proper ((=) ==> (=) ==> (=)) cons} (nil : B) : s1 = s2 → takeUntil P ex1 cons nil = takeUntil P ex2 cons nil. Proof with try easy. revert s2 ex2. assert (ex1':=ex1). induction ex1' as [s1 P1 | s1 P1 IH]; intros ? ? E; case ex1; clear ex1; case ex2; clear ex2; simpl; case_eq (P s1); case_eq (P s2); intros P2 P3 ? ?... destruct (eq_true_false_abs (P s1))... now rewrite E. destruct (eq_true_false_abs (P s1))... now rewrite E. destruct (eq_true_false_abs (P s1))... now rewrite E. destruct (eq_true_false_abs (P s1))... now rewrite E. now destruct (Is_true_neq_left _ P3). destruct (eq_true_false_abs (P s1))... now rewrite E. destruct (eq_true_false_abs (P s1))... now rewrite E. destruct (eq_true_false_abs (P s1))... now rewrite E. destruct (eq_true_false_abs (P s1))... now rewrite E. rewrite (IH tt); now rewrite E. Qed. Lemma takeUntil_end {A B} (P:Stream A → bool) `(ex:LazyExists (fun x => Is_true (P x)) seq) (cons:A → B → B) (nil : B) : Is_true (P seq) → takeUntil P ex cons nil ≡ nil. Proof. intros H. rewrite <- (takeUntil_wd (B:=B) (LazyHere (P:= (fun x => Is_true (P x))) H)). unfold takeUntil. destruct (P seq);[|contradiction]. reflexivity. Qed. Lemma takeUntil_step {A B} (P:Stream A → bool) `(ex:LazyExists (fun x => Is_true (P x)) s) (cons: A → B → B) (nil: B) : ¬Is_true (P s) → ∃ ex' : LazyExists (fun x => Is_true (P x)) (tl s), takeUntil P ex cons nil ≡ cons (hd s) (takeUntil P ex' cons nil). Proof. intros H. assert (ex':=ex). destruct ex' as [H0|ex']. elim H; assumption. exists (ex' tt). rewrite <- (takeUntil_wd (B:=B) (LazyFurther ex')). simpl. destruct (P s). elim H; constructor. reflexivity. Qed. Lemma takeUntil_elim {A B} (P:Stream A → bool) (cons: A → B → B) (nil: B) (Q: Stream A → B → Prop) : (∀ s, Is_true (P s) → Q s nil) → (∀ s x, Q (tl s) x → ¬Is_true (P s) → Q s (cons (hd s) x)) → ∀ `(ex : LazyExists (fun x => Is_true (P x)) s), Q s (takeUntil P ex cons nil). Proof. intros c1 c2 s ex. assert (ex':=ex). induction ex'. rewrite takeUntil_end; try assumption. eapply c1. apply H. assert (Z0:=takeUntil_end P ex cons nil). assert (Z1:=takeUntil_step P ex cons nil). assert (Z0':=c1 x). assert (Z1':=c2 x). destruct (P x). clear Z1. rewrite Z0; try constructor. apply Z0'. constructor. clear Z0 Z0'. destruct (Z1 (λ x, x)) as [ex' Z]. rewrite Z. clear Z Z1. eapply Z1'; auto. apply H0. constructor. Qed. (* Alternatively we can first compute the required length. This is useful in case we actually have to use the length *) Definition takeUntil_length `(P : Stream A → bool) `(ex : LazyExists (fun x => Is_true (P x)) s) : nat := takeUntil P ex (λ _, S) O. Fixpoint take {A B} (s : Stream A) (n : nat) (cons: A → B → B) (nil : B) : B := match n with | O => nil | S m => cons (hd s) (take (tl s) m cons nil) end. Lemma takeUntil_length_correct {A} (P : Stream A → bool) `(ex : !LazyExists (fun x => Is_true (P x)) s) : Is_true (P (Str_nth_tl (takeUntil_length P ex) s)). Proof. assert (ex':=ex). unfold takeUntil_length. induction ex' as [s|s ? IH]. now rewrite takeUntil_end. case_eq (P s); intros E. rewrite takeUntil_end; auto with *. destruct (takeUntil_step P ex (λ _ : A, S) O) as [ex1 E1]. now apply Is_true_neq_left. rewrite E1. now apply (IH tt). Qed. Lemma takeUntil_correct {A B} (P : Stream A → bool) `(ex : !LazyExists (fun x => Is_true (P x)) s) (cons: A → B → B) (nil : B) : takeUntil P ex cons nil ≡ take s (takeUntil_length P ex) cons nil. Proof with auto using Is_true_eq_left, Is_true_neq_left. assert (ex':=ex). unfold takeUntil_length. induction ex' as [s|s ? IH]. repeat rewrite takeUntil_end... case_eq (P s); intros E. repeat rewrite takeUntil_end... destruct (takeUntil_step P ex cons nil) as [ex1 E1]... rewrite E1. rewrite (IH tt)... destruct (takeUntil_step P ex (λ _, S) O) as [ex2 E2]... rewrite E2. simpl. rewrite (takeUntil_wd ex1 ex2 (λ _, S) O)... Qed. Lemma takeUntil_length_tl {A} (P : Stream A → bool) `(ex : !LazyExists (fun x => Is_true (P x)) s) (Ptl : EventuallyForAll (fun x => Is_true (P x)) s) : takeUntil_length P ex ≤ S (takeUntil_length P (LazyExists_tl ex Ptl)). Proof. unfold takeUntil_length. destruct ex. rewrite takeUntil_end. now apply nat_nonneg. easy. simpl. case_eq (P s); intros E. rewrite takeUntil_end. now apply nat_nonneg. apply Ptl. auto with *. reflexivity. Qed. Lemma takeUntil_length_Str_nth_tl {A} (P : Stream A → bool) `(ex : !LazyExists (fun x => Is_true (P x)) s) (Ptl : EventuallyForAll (fun x => Is_true (P x)) s) (n : nat) : takeUntil_length P ex ≤ n + takeUntil_length P (LazyExists_Str_nth_tl ex Ptl n). Proof with auto with *. revert s ex Ptl. induction n; intros. easy. transitivity (S (takeUntil_length P (LazyExists_tl ex Ptl))). apply takeUntil_length_tl. simpl. apply le_n_S. unfold takeUntil_length. setoid_rewrite (takeUntil_wd (LazyExists_Str_nth_tl ex Ptl (S n)) (LazyExists_Str_nth_tl (LazyExists_tl ex Ptl) (ForAll_Str_nth_tl 1 Ptl) n) (λ _, S) O). apply IHn. Qed. Lemma takeUntil_length_ForAllIf {A1 A2} (P1 : Stream A1 → bool) `(ex1 : LazyExists (fun x => Is_true (P1 x)) s1) {P2 : Stream A2 → bool} `(ex2 : LazyExists (fun x => Is_true (P2 x)) s2) (F : ForAllIf (fun x => Is_true (P2 x)) (fun x => Is_true (P1 x)) s2 s1) : takeUntil_length P1 ex1 ≤ takeUntil_length P2 ex2. Proof with auto using Is_true_eq_left, Is_true_neq_left. revert s2 ex2 F. assert (ex1':=ex1). unfold takeUntil_length. induction ex1' as [s1|s1 ? IH]; intros. rewrite takeUntil_end... apply Nat.le_0_l. case_eq (P1 s1); intros EP1. rewrite takeUntil_end... apply Nat.le_0_l. destruct (takeUntil_step _ ex1 (λ _, S) O) as [ex1' E1']... rewrite E1'. assert (ex2':=ex2). induction ex2' as [s2|s2 ? IH2]. destruct F. rewrite takeUntil_end in E1'... discriminate. case_eq (P2 s2); intros EP2. destruct F. rewrite takeUntil_end in E1'... discriminate. destruct (takeUntil_step _ ex2 (λ _, S) O) as [ex2' E2']... rewrite E2'. apply le_n_S, (IH tt). destruct F... Qed. End TakeUntil. Section Limit. Context {X : MetricSpace}. (** This proposition says that the entire stream is within e of l *) Definition NearBy (l : X) (ε : QposInf) := ForAll (λ s, ball_ex ε (hd s) l). Lemma NearBy_comp l1 l2 : l1 = l2 → ∀ ε1 ε2, QposEq ε1 ε2 → ∀ s, (NearBy l1 ε1 s ↔ NearBy l2 ε2 s). Proof. revert l1 l2. cut (∀ l1 l2 : X, l1 = l2 → ∀ ε1 ε2 : Qpos, QposEq ε1 ε2 → ∀ s : Stream X, NearBy l1 ε1 s → NearBy l2 ε2 s). intros. split. firstorder. intros. eapply H. symmetry. apply H0. unfold QposEq; symmetry. apply H1. assumption. unfold NearBy; simpl. intros l1 l2 Hl ε1 ε2 Hε. cofix F. intros s [H0 H]. constructor. apply (ball_wd X Hε _ _ (reflexivity _) _ _ Hl). assumption. auto. Qed. Lemma NearBy_weak l (ε1 ε2 : Qpos) : proj1_sig ε1 <= proj1_sig ε2 → ∀ s, NearBy l ε1 s → NearBy l ε2 s. Proof. unfold NearBy; simpl. cofix F. intros Hε s [H0 H]. constructor. eapply ball_weak_le. apply Hε. assumption. auto. Qed. Lemma NearBy_Infinity (s : Stream X) (x : X) : NearBy x QposInfinity s. Proof with trivial. unfold NearBy. simpl. revert s. cofix F. constructor... Qed. Lemma Nearby_tl `(H : NearBy l ε s) : NearBy l ε (tl s). Proof. now destruct H. Defined. Lemma Nearby_Str_nth_tl `(H : NearBy l ε s) : ∀ n, NearBy l ε (Str_nth_tl n s). Proof. induction n. easy. simpl. rewrite <-tl_nth_tl. now apply Nearby_tl. Defined. Lemma Nearby_EventuallyForAll l ε s : EventuallyForAll (NearBy l ε) s. Proof. revert s. cofix FIX. constructor. now apply Nearby_tl. now apply (FIX (tl s)). Defined. (** l is the limit if for every e there exists a point where the stream is always within e of l. *) Class Limit (s : Stream X) (l:X) := limit: ∀ ε, LazyExists (NearBy l ε) s. Global Instance Limit_tl `(H : Limit s l) : Limit (tl s) l. Proof. intros ε. destruct (H ε) as [[_ H']|H']. left; auto. apply H'. constructor. Defined. Global Instance Limit_Str_nth_tl `(H : Limit s l) : ∀ n, Limit (Str_nth_tl n s) l. Proof. intros n. revert s l H. induction n. tauto. intros. simpl. apply IHn. now apply Limit_tl. Defined. End Limit. (* begin hide *) Arguments NearBy [X]. Arguments Limit [X]. (* end hide *) corn-8.20.0/metric2/LocatedSubset.v000066400000000000000000000212031473720167500170510ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) (** * Located subsets A subset Y : X -> Prop of a metric space X is located when its distance function, fun x:X => d(x,Y), constructively exists. It is the generalization to continuous spaces of the computable subsets of the natural numbers. We cannot use the characteristic functions instead, because they are discontinuous. When X has dimension 2, a located subset of X can be drawn on a raster, ie a pixel grid. For each pixel, compute whether the distance of Y to the center of the pixel is less than the size of the pixel. If so, switch the pixel on otherwise leave it off. With our ball-based definition of metric space, this translates as a decidable sumbool. *) Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.metric2.Compact. Definition LocatedSubset (X : MetricSpace) (Y : X -> Prop) : Type := forall (d e : Q) (x:X), d < e -> { forall y:X, Y y -> ~ball d x y } + { exists y:X, Y y /\ ball e x y }. Lemma LocatedSubset_wd : forall (X : MetricSpace) (Y Z : X -> Prop), (forall x:X, Y x <-> Z x) -> LocatedSubset X Y -> LocatedSubset X Z. Proof. intros X Y Z YeqZ Yloc d e x dlte. destruct (Yloc d e x dlte) as [far|close]. - left. intros y H. apply far, YeqZ, H. - right. destruct close as [y [yin close]]. exists y. split. apply YeqZ, yin. exact close. Qed. Lemma LocatedSubset_stable : forall (X : MetricSpace) (Y : X -> Prop), LocatedSubset X Y -> LocatedSubset X (fun x => ~~Y x). Proof. intros. intros d e x dlte. specialize (X0 d e x dlte) as [far|close]. - left. intros y H abs. contradict H; intro H. revert abs. apply far, H. - right. destruct close as [y close]. exists y. split. intro abs. destruct close; contradiction. apply close. Qed. Lemma LocatedSubset_union : forall (X : MetricSpace) (Y Z : X -> Prop), LocatedSubset X Y -> LocatedSubset X Z -> LocatedSubset X (fun x => Y x \/ Z x). Proof. intros X Y Z Yloc Zloc d e x ltde. destruct (Yloc d e x ltde) as [farY|closeY]. - destruct (Zloc d e x ltde) as [farZ|closeZ]. left. intros y [H|H]. apply farY, H. apply farZ, H. right. destruct closeZ as [y closeZ]. exists y. split. right. apply closeZ. apply closeZ. - right. destruct closeY as [y closeY]. exists y. split. left. apply closeY. apply closeY. Qed. (* A finite subset is located when the metric itself is located. Even singletons need located metrics to be located. *) Fixpoint LocatedFinite (X : MetricSpace) (loc : locatedMetric X) (l : list X) {struct l} : LocatedSubset X (fun x => In x l). Proof. destruct l as [|a l]. - intros d e x ltde. left. intros y H. contradiction H. - intros d e x ltde. destruct (loc d e x a ltde). right. exists a. split. left; reflexivity. exact b. destruct (LocatedFinite X loc l d e x ltde) as [far|close]. + left. intros y H. destruct H. rewrite <- H. exact n. apply far, H. + right. destruct close as [y [H H0]]. exists y. split. right. exact H. exact H0. Defined. (* Slighlty more general than finite is totally bounded. *) Lemma TotallyBoundedIsLocated : forall (X : MetricSpace) (Y : X -> Prop), TotallyBoundedSubset X Y -> locatedMetric X -> LocatedSubset X Y. Proof. intros X Y totalBound loc d e x ltde. pose ((1#2)*(e-d)) as approxLen. pose (d+approxLen) as demid. assert (0 < approxLen) as approxLenPos. { unfold approxLen. rewrite <- (Qmult_0_r (1#2)). apply Qmult_lt_l. reflexivity. unfold Qminus. rewrite <- Qlt_minus_iff. exact ltde. } assert (demid < e). { unfold demid, approxLen. apply (Qplus_lt_l _ _ (-(1#2)*e)). ring_simplify. apply Qmult_lt_l. reflexivity. exact ltde. } (* The approximation of Y at precision (e-d)/2 is a finite subset of Y, such as any point of Y in close to a point in the finite subset within (e-d)/2. *) specialize (totalBound (exist _ _ approxLenPos)) as [l H0]. unfold proj1_sig in e0. destruct (LocatedFinite X loc l demid e x H) as [far|close]. + left. intros y H2 abs. (* The distance between x and any point of the finite approximation of Y is above oneThird. *) specialize (e0 y H2) as [t [H3 H4]]. specialize (far t H3). specialize (H0 t H3). contradict far. apply (ball_triangle X d approxLen _ _ _ abs) in H4. exact H4. + right. destruct close as [y [yin close]]. exists y. split. exact (H0 y yin). exact close. Defined. Lemma CompactIsLocated_close : forall (X : MetricSpace) (Y : Compact X) (x : Complete X) (d e : Q) (emdPos : 0 < e - d), locatedMetric X -> (exists y : Complete X, In y (map Cunit (approximate Y ((1 # 5) * exist (Qlt 0) (e - d) emdPos)%Qpos)) /\ ball (d+(3#10)*(e-d)) x y) -> exists y : Complete X, inCompact y Y /\ ball e x y. Proof. intros. destruct H as [y [yin close]]. (* Move the approx point z into the compact, as in the Bishop-compact proof. *) pose proof (@CompactTotalBoundNotFar X X0 Y (exist _ _ emdPos)) as H0. apply (HausdorffBallHausdorffBallStrong (Complete_located X0)) in H0. unfold proj1_sig in H0. destruct H0 as [H0 _]. specialize (H0 y (InFinEnumC_weaken _ _ _ yin) ((1#10)*(exist _ _ emdPos))%Qpos) as [z [H0 H2]]. exists z. split. apply inCompact_stable. intro abs. unfold InFinEnumC, FinSubset_ball in H0. contradict H0; intros [t [H0 H1]]. contradict abs. rewrite H1. apply (CompactTotallyBoundedA _ _ _ _ H0). apply (ball_triangle _ _ _ _ _ _ close) in H2. setoid_replace e with ((d+(3#10)*(e-d)) + ((3 # 5) * (e - d) + (1#10) * (e - d)))%Q. exact H2. ring. Qed. Lemma CompactIsLocated_far : forall (X : MetricSpace) (Y : Compact X) (x : Complete X) (d e : Q) (emdPos : 0 < e - d), locatedMetric X -> (forall y : Complete X, In y (map Cunit (approximate Y ((1 # 5) * exist (Qlt 0) (e - d) emdPos)%Qpos)) -> ~ ball (d+(1#5)*(e-d)) x y) -> forall y : Complete X, inCompact y Y -> ~ ball d x y. Proof. intros. intro abs. (* t is in the compact Y, so there is a point y in l within (e-d)/5 of t. So the distance between x and y is below d + (e-d)/5. *) pose proof (@InCompact_approxC X X0 _ _ ((1#5)*(exist _ _ emdPos)) H0) as H1. contradict H1; intro H1. destruct H1 as [z [H1 H3]]. specialize (H (Cunit z) (in_map _ _ _ H1)). contradict H. apply (ball_triangle _ _ _ _ _ _ abs) in H3. exact H3. Qed. (* This function does not have to compute very fast, because it is rarely used : compact subsets have a fast dedicated plotter. *) Lemma CompactIsLocated : forall (X : MetricSpace) (Y : Compact X), locatedMetric X -> LocatedSubset (Complete X) (fun z => inCompact z Y). Proof. intros X Y loc d e x ltde. assert (0 < e-d) as emdPos. { apply Qlt_minus_iff in ltde. exact ltde. } pose (d+(1#5)*(e-d)) as oneFifth. pose (d+(3#10)*(e-d)) as threeTenths. assert (oneFifth < threeTenths). { apply Qplus_lt_r, Qmult_lt_r. exact emdPos. reflexivity. } (* In CompactTotalBound the current factor is 5 to construct limit points of Complete X inside the compact Y. Maybe it would be faster to compare an approximation of x to approxY in X instead of Complete X. *) destruct (LocatedFinite (Complete X) (Complete_located loc) (map Cunit (approximate Y (Qpos2QposInf ((1#5)*(exist _ _ emdPos))))) oneFifth threeTenths x H) as [far|close]. + left. exact (CompactIsLocated_far X Y x d e emdPos loc far). + right. exact (CompactIsLocated_close X Y x d e emdPos loc close). Defined. corn-8.20.0/metric2/Metric.v000066400000000000000000000163671473720167500155520ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Export QArith. Require Import CoRN.algebra.RSetoid. Require Import MathClasses.interfaces.canonical_names. Require Import MathClasses.interfaces.abstract_algebra. Local Open Scope Q_scope. Set Implicit Arguments. (** * Metric Space We define a metric space over a setoid X by a ball relation B where B e x y means that the distance between the two points x and y is less than or equal to the rational number e ( d(x,y) <= e ). We do not take the usual definition of a distance function d : X^2 -> R_+, because constructively this function would have to be computable. For example this would prevent us to define metrics on functions d(f,g) := inf_x d(f(x), g(x)) where the infinimum does not always exist constructively. By using ball propositions instead, we make the distance function partial, it is not always defined. For topological applications, it is often enough to bound the distance instead of computing it exactly, this is precisely what the balls do. Interestingly, this definition by balls also handles infinite distances, by proving that forall e, not (B e x y). It generalizes the usual distance functions. This definition uses rational numbers instead of real numbers, which is simpler. It allows to define the real numbers as a certain metric space, namely the Cauchy completion of the rational numbers. Lastly, this definition could include one other property of the distance functions e < d -> {B d x y}+{~B e x y}. But those properties are only used late in the proofs, so we move them as additional definitions in module Classification.v (stability and locatedness). *) Record is_MetricSpace {X : Type} (B: Q -> relation X) : Prop := { msp_refl: forall e, 0 <= e -> Reflexive (B e) ; msp_sym: forall e, Symmetric (B e) ; msp_triangle: forall e1 e2 a b c, B e1 a b -> B e2 b c -> B (e1 + e2) a c ; msp_closed: forall e a b, (forall d, 0 < d -> B (e + d) a b) -> B e a b ; msp_nonneg : forall e a b, B e a b -> 0 <= e ; msp_stable : forall e a b, (~~B e a b) -> B e a b }. Record MetricSpace : Type := { msp_car :> Type ; ball : Q -> msp_car -> msp_car -> Prop ; ball_e_wd : forall (e d : Q) (x y : msp_car), e == d -> (ball e x y <-> ball d x y) ; msp : is_MetricSpace ball }. (* begin hide *) Arguments ball [m]. Definition msp_eq {m:MetricSpace} (x y : msp_car m) : Prop := ball 0 x y. #[global] Instance msp_Equiv (m : MetricSpace) : Equiv m := @msp_eq m. Add Parametric Morphism {m:MetricSpace} : (@ball m) with signature Qeq ==> (@msp_eq m) ==> (@msp_eq m) ==> iff as ball_wd. Proof. unfold msp_eq. split. - intros. assert (0+(x+0) == y). { rewrite Qplus_0_r, Qplus_0_l. exact H. } apply (ball_e_wd m y0 y1 H3). clear H H3 y. apply (msp_triangle (msp m)) with (b:=x0). apply (msp_sym (msp m)), H0. apply (msp_triangle (msp m)) with (b:=x1). exact H2. exact H1. - intros. assert (0+(y+0) == x). { rewrite Qplus_0_r, Qplus_0_l, H. reflexivity. } apply (ball_e_wd m x0 x1 H3). clear H H3 x. apply (msp_triangle (msp m)) with (b:=y0). exact H0. clear H0 x0. apply (msp_triangle (msp m)) with (b:=y1). exact H2. apply (msp_sym (msp m)), H1. Qed. Lemma msp_eq_refl : forall {m:MetricSpace} (x : m), msp_eq x x. Proof. intros. apply (msp_refl (msp m) (Qle_refl 0)). Qed. Lemma msp_eq_sym : forall {m:MetricSpace} (x y : m), msp_eq x y -> msp_eq y x. Proof. intros. apply (msp_sym (msp m)), H. Qed. Lemma msp_eq_trans : forall {m:MetricSpace} (x y z : m), msp_eq x y -> msp_eq y z -> msp_eq x z. Proof. unfold msp_eq. intros. rewrite <- (ball_wd m (Qplus_0_r 0) x x (msp_eq_refl x) z z (msp_eq_refl z)). exact (msp_triangle (msp m) _ _ _ y _ H H0). Qed. Add Parametric Relation {m:MetricSpace} : (msp_car m) msp_eq reflexivity proved by (msp_eq_refl) symmetry proved by (msp_eq_sym) transitivity proved by (msp_eq_trans) as msp_eq_rel. (* end hide *) #[global] Instance msp_Setoid (m : MetricSpace) : Setoid m := {}. Definition msp_as_RSetoid : MetricSpace -> RSetoid := fun m => Build_RSetoid (msp_Setoid m). Section Metric_Space. (* ** Ball lemmas *) Variable X : MetricSpace. (** These lemmas give direct access to the ball axioms of a metric space *) Lemma ball_refl : forall e (a:X), 0 <= e -> ball e a a. Proof. intros. apply (msp_refl (msp X) H). Qed. Lemma ball_sym : forall e (a b:X), ball e a b -> ball e b a. Proof. apply (msp_sym (msp X)). Qed. Lemma ball_triangle : forall e1 e2 (a b c:X), ball e1 a b -> ball e2 b c -> ball (e1 + e2) a c. Proof. apply (msp_triangle (msp X)). Qed. Lemma ball_closed : forall e (a b:X), (forall d, 0 < d -> ball (e + d) a b) -> ball e a b. Proof. apply (msp_closed (msp X)). Qed. Lemma ball_eq : forall (a b:X), (forall e, 0 < e -> ball e a b) -> msp_eq a b. Proof. intros. apply ball_closed. intros. rewrite Qplus_0_l. apply H, H0. Qed. Lemma ball_eq_iff : forall (a b:X), (forall e, 0 < e -> ball e a b) <-> msp_eq a b. Proof. split. apply ball_eq. intros H e epos. rewrite H. apply ball_refl. apply Qlt_le_weak, epos. Qed. (** The ball constraint on a and b can always be weakened. Here are two forms of the weakening lemma. *) Lemma ball_weak : forall e d (a b:X), 0 <= d -> ball e a b -> ball (e + d) a b. Proof. intros e d a b dpos B1. eapply ball_triangle. apply B1. apply ball_refl. exact dpos. Qed. Hint Resolve ball_refl ball_triangle ball_weak : metric. Lemma ball_weak_le : forall (e d:Q) (a b:X), e <= d -> ball e a b -> ball d a b. Proof. intros e d a b Hed B1. setoid_replace d with (e + (d-e)) by ring. apply (ball_triangle _ _ _ b). exact B1. apply ball_refl. unfold Qminus. rewrite <- Qle_minus_iff. exact Hed. Qed. (* If d(x,y) is infinite and d(x,z) is finite, then d(z,y) is infinite. *) Lemma ball_infinite : forall (x y z : X) (e : Q), (forall d : Q, ~ball d x y) -> ball e x z -> (forall d : Q, ~ball d z y). Proof. intros. intro abs. apply (H (e+d)). exact (ball_triangle e d x z y H0 abs). Qed. Lemma ball_stable : forall e (x y : X), ~~(ball e x y) -> ball e x y. Proof. intros. apply (msp_stable (msp X)), H. Qed. End Metric_Space. (* begin hide *) #[global] Hint Resolve ball_refl ball_sym ball_triangle ball_weak : metric. (* end hide *) corn-8.20.0/metric2/MetricMorphisms.v000066400000000000000000000300131473720167500174340ustar00rootroot00000000000000Require Import CoRN.metric2.Metric. Require MathClasses.theory.jections. Require Import CoRN.model.totalorder.QposMinMax Coq.Setoids.Setoid CoRN.stdlib_omissions.Q CoRN.model.totalorder.QMinMax CoRN.metric2.Complete CoRN.metric2.Prelength MathClasses.interfaces.abstract_algebra. Local Open Scope uc_scope. (* Given an embedding of a setoid [X] into a metric space [Y] then [X] is also a metric space. Moreover this embedding is uniformly continuous. *) Section metric_embedding. Context `{Setoid X'} {Y : MetricSpace}. Context (f : X' -> Y) {inj : Injective f}. Definition Eball (q: Q) (x y: X'): Prop := ball q (f x) (f y). Local Existing Instance injective_mor. Global Instance Eball_wd : Proper (Qeq ==> (=) ==> (=) ==> iff) Eball. Proof. intros ?? E ?? F ?? G. unfold Eball. destruct inj. pose proof (@sm_proper _ _ _ _ f injective_mor x0 y0 F). pose proof (@sm_proper _ _ _ _ f injective_mor x1 y1 G). apply (ball_wd Y E _ _ H0 _ _ H1). Qed. Let is_MetricSpace: is_MetricSpace Eball. Proof. constructor; unfold ball. - intros e H0 x. apply ball_refl, H0. - intros e x y. apply ball_sym. - intros. now eapply ball_triangle; eauto. - intros. now apply ball_closed. - intros. apply (msp_nonneg (msp Y)) in H0. exact H0. - intros. apply (msp_stable (msp Y)), H0. Qed. Program Definition Emetric: MetricSpace := Build_MetricSpace _ is_MetricSpace. Next Obligation. rewrite H0. reflexivity. Qed. Let X := Emetric. Lemma Eball_spec ε (x y : X) : ball ε x y ↔ ball ε (f x) (f y). Proof. intuition. Qed. Lemma Eball_ex_spec ε (x y : X) : ball_ex ε x y ↔ ball_ex ε (f x) (f y). Proof. destruct ε; intuition. Qed. Lemma metric_embed_uc_prf : is_UniformlyContinuousFunction (f : X → Y) Qpos2QposInf. Proof. now intros ε x y E. Qed. Definition metric_embed_uc : X --> Y := Build_UniformlyContinuousFunction metric_embed_uc_prf. End metric_embedding. Class AppInverse `(f : X → Y) := app_inverse : Y → Qpos → X. Arguments app_inverse {X Y} f {AppInverse}. Class DenseEmbedding `{Equiv X} {Y : MetricSpace} (f : X → Y) `{!AppInverse f} := { dense_embed_setoid : Setoid X ; dense_injective :: Injective f ; dense_inverse : ∀ x (ε:Qpos), ball (proj1_sig ε) (f (app_inverse f x ε)) x }. (* Given a dense embedding of a setoid [X] into a prelength space [Y] then [X] is also a prelength space. Moreover, the completion of [X] is isomorphic to the completion of [Y]. *) Section dense_prelength_embedding. Context `{Setoid X'} {Y : MetricSpace} (plY : PrelengthSpace Y) (f : X' → Y) `{!AppInverse f} `{!DenseEmbedding f}. Let X := Emetric f. Lemma Qpos_lt_1_mult_l (x : Qpos) (y : Q) : (y < 1 → y * proj1_sig x < proj1_sig x)%Q. Proof with auto with qarith. intros E. destruct x; simpl. rewrite <-(Qmult_1_l x), Qmult_assoc. apply Qmult_lt_compat_r. exact q. rewrite Qmult_1_r. exact E. Qed. Lemma EPrelengthSpace_aux (x y : Qpos) (z : Q) : (z < 1 → 0 < proj1_sig x - z * proj1_sig (Qpos_min x y))%Q. Proof with auto. intros E. apply (proj1 (Qlt_minus_iff _ _)). destruct (Qle_total (`y) (`x)) as [F|F]. pose proof (proj1 (Qpos_le_min_r x y) F). unfold QposEq in H0. rewrite H0. apply Qlt_le_trans with (`y)... apply Qpos_lt_1_mult_l... pose proof (proj1 (Qpos_le_min_l x y) F). unfold QposEq in H0. rewrite H0. apply Qpos_lt_1_mult_l... Qed. (* Luckily this lives in [Prop] because it looks very inefficient *) Lemma EPrelengthSpace : PrelengthSpace X. Proof with auto with qarith. intros x y ε δ1 δ2 E F. pose (exist (Qlt 0) (1#2) eq_refl) as half. pose (exist (Qlt 0) (1#3) eq_refl) as third. simpl in *. assert (` ε < ` (δ1 + δ2)%Qpos)%Q as EE by (exact E). destruct (Qpos_sub _ _ EE) as [γ Eγ]. assert (1#3 < 1)%Q as G... pose proof (EPrelengthSpace_aux δ1 γ (1#3) G) as E1. pose proof (EPrelengthSpace_aux δ2 γ (1#3) G) as E2. destruct (@plY (f x) (f y) ε (exist _ _ E1) (exist _ _ E2)) as [z Ez1 Ez2]... - simpl. apply (Qlt_le_trans _ (`ε + (`γ - (2 # 3) * proj1_sig (Qpos_min γ (Qpos_min (Qpos_min (half * δ1 + half * δ2) (half * γ + half * δ2)) (half * δ1 + half * γ))))))%Q. rewrite <-(Qplus_0_r (`ε)) at 1. apply Qplus_lt_r. apply EPrelengthSpace_aux... do 5 rewrite Q_Qpos_min. simpl. rewrite <-Qmin_plus_distr_l. rewrite (Qmin_comm (`γ)). rewrite <-Qmin_assoc. setoid_replace (Qmin ((1 # 2) * ` δ1 + (1 # 2) * ` γ) (` γ)) with (Qmin ((1 # 2) * ` δ1 + (1 # 2) * ` γ) ((1#2) * ` γ + (1#2)*` γ)). rewrite <-Qmin_plus_distr_l. rewrite <-Qmin_plus_distr_r. repeat rewrite <-Qmin_mult_pos_distr_r... unfold Qminus. unfold QposEq in Eγ. rewrite (Qplus_assoc (` ε)), <- Eγ. simpl. ring_simplify. setoid_replace (-2#6) with (-1#3). apply Qle_refl. reflexivity. ring_simplify ((1 # 2) * ` γ + (1 # 2) * ` γ)%Q. reflexivity. - exists (app_inverse f z (exist (Qlt 0) (1#3) eq_refl * Qpos_min γ (Qpos_min δ1 δ2))). assert (QposEq δ1 (exist _ _ E1 + (third * Qpos_min δ1 γ))) by (unfold QposEq; simpl; ring). apply (Eball_wd _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. eapply ball_triangle; eauto. eapply ball_weak_le. 2: now apply ball_sym, dense_inverse. simpl. autorewrite with QposElim. apply Qmult_le_compat_l; eauto with qarith. assert (QposEq δ2 (third * Qpos_min δ2 γ + exist _ _ E2)) by (unfold QposEq; simpl; ring). apply (Eball_wd _ _ _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. eapply ball_triangle; eauto. eapply ball_weak_le. 2: now apply dense_inverse. simpl. autorewrite with QposElim. apply Qmult_le_compat_l; eauto with qarith. Qed. Let plX := EPrelengthSpace. (* Now we also have an embedding of the completion of [X] into the completion of [Y] *) Definition Eembed : Complete X --> Complete Y := Cmap plX (metric_embed_uc f). Instance: Setoid_Morphism Eembed := {}. Instance Eembed_injective: Injective Eembed. Proof. split; try apply _. intros x y E ε1 ε2. apply Eball_spec, E. Qed. (* And back... *) Lemma dense_regular_prf (y : Y) : is_RegularFunction_noInf _ (app_inverse f y : Qpos → X). Proof. intros ε1 ε2. simpl. eapply ball_triangle. now eapply dense_inverse. now eapply ball_sym, dense_inverse. Qed. Definition dense_regular (y : Y) : Complete X := mkRegularFunction (app_inverse f y (exist (Qlt 0) (1#1) eq_refl) : X) (dense_regular_prf y). Definition metric_embed_back_prf : is_UniformlyContinuousFunction dense_regular Qpos2QposInf. Proof. intros ε x y E δ1 δ2. simpl in *. eapply ball_triangle. eapply ball_triangle. now eapply dense_inverse. apply E. now eapply ball_sym, dense_inverse. Qed. Definition metric_embed_back_uc : Y --> Complete X := Build_UniformlyContinuousFunction metric_embed_back_prf. Definition Eembed_inverse : Complete Y --> Complete X := Cbind plY metric_embed_back_uc. Global Instance: Inverse Eembed := Eembed_inverse. Instance: Setoid_Morphism Eembed_inverse := {}. Instance Eembed_surjective : Surjective Eembed. Proof. pose (exist (Qlt 0) (1#2) eq_refl) as half. split; [| apply _]. intros x y E. rewrite <-E. intros ε1 ε2. simpl. unfold Cjoin_raw. simpl. rewrite Qplus_0_r. setoid_replace (proj1_sig ε1 + proj1_sig ε2)%Q with (proj1_sig (half * ε1 + (half * ε1 + ε2))%Qpos) by (simpl; ring). eapply ball_triangle. now eapply dense_inverse. now apply regFun_prf. Qed. Global Instance: Bijective Eembed := {}. Global Instance: Inverse Eembed_inverse := Eembed. Global Instance: Bijective Eembed_inverse. Proof. apply jections.flip_bijection. Qed. Let F := Eembed. (* Given a function [g : X → X] that agrees with a uniformly continious function [h : Y → Y], then [g] is also uniformly continious. Moreover, [map g] and [map h] agree. *) Section unary_functions. Context (g' : X' → X') (h : Y --> Y) (g_eq_h : ∀ x, f (g' x) = h (f x)). Lemma unary_uc_prf : is_UniformlyContinuousFunction (g' : X → X) (mu h). Proof. intros ε a b H0. apply Eball_spec. apply (ball_wd _ (QposEq_refl ε) _ _ (g_eq_h _) _ _ (g_eq_h _)). eapply uc_prf. now destruct (mu h ε). Qed. Definition unary_uc : X --> X := Build_UniformlyContinuousFunction unary_uc_prf. Let g := unary_uc. Lemma preserves_unary_fun x : F (Cmap plX g x) = Cmap plY h (F x). Proof. intros e1 e2. apply regFunEq_equiv. apply regFunEq_e. intros ε. simpl. rewrite QposInf_bind_id. apply (ball_wd _ eq_refl _ _ (g_eq_h _) _ _ (reflexivity _)). apply ball_refl. apply (Qpos_nonneg (ε + ε)). Qed. End unary_functions. (* And a similar result for binary functions *) Section binary_functions. Context (g' : X' → X → X) (h : Y --> Y --> Y) (g_eq_h : ∀ x y, f (g' x y) = h (f x) (f y)). Program Let g'' (x : X) := unary_uc (g' x) (h (f x)) _. Lemma binary_uc_prf : is_UniformlyContinuousFunction (g'' : X → (X --> X)) (mu h). Proof. intros ε x y E. split. apply Qpos_nonneg. intro z. apply Eball_spec. simpl. apply (ball_wd _ (QposEq_refl ε) _ _ (g_eq_h _ _) _ _ (g_eq_h _ _)). apply (uc_prf h). now destruct (mu h ε). Qed. Definition binary_uc : X --> X --> X := Build_UniformlyContinuousFunction binary_uc_prf. Let g := binary_uc. Lemma preserves_binary_fun x y : F (Cmap2 plX plX g x y) = Cmap2 plY plY h (F x) (F y). Proof. intros e1 e2. apply regFunEq_equiv, regFunEq_e. intros ε. simpl. unfold Cap_raw. simpl. apply (ball_wd _ eq_refl _ _ (g_eq_h _ _) _ _ (reflexivity _)). rewrite 2!QposInf_bind_id. apply ball_refl. apply (Qpos_nonneg (ε + ε)). Qed. End binary_functions. (* Given a function [g : X → Complete X] that agrees with a uniformly continious function [h : Y → Complete Y], then [g] is also uniformly continious. Moreover, [bind g] and [bind h] agree. *) Section unary_complete_functions. Context (g' : X' → Complete X) (h : Y --> Complete Y) (g_eq_h : ∀ x, F (g' x) = h (f x)). Definition unary_complete_uc_prf : is_UniformlyContinuousFunction (g' : X → Complete X) (mu h). Proof. pose (exist (Qlt 0) (1#4) eq_refl) as quarter. intros ε x y E δ1 δ2. apply Eball_spec. apply ball_closed. intros δ3 dpos. setoid_replace (proj1_sig δ1 + proj1_sig ε + proj1_sig δ2 + δ3)%Q with (proj1_sig ((δ1 + quarter * exist _ _ dpos) + (quarter * exist _ _ dpos + ε + quarter * exist _ _ dpos) + (δ2 + quarter * exist _ _ dpos))%Qpos) by (simpl; ring). eapply ball_triangle. eapply ball_triangle. specialize (g_eq_h x). apply regFunEq_equiv in g_eq_h. apply g_eq_h. apply Eball_ex_spec in E. apply (uc_prf h). apply E. apply ball_sym. specialize (g_eq_h y). apply regFunEq_equiv in g_eq_h. apply g_eq_h. Qed. Definition unary_complete_uc : X --> Complete X := Build_UniformlyContinuousFunction unary_complete_uc_prf. Let g := unary_complete_uc. Lemma preserves_unary_complete_fun x : F (Cbind plX g x) = Cbind plY h (F x). Proof. pose (exist (Qlt 0) (1#2) eq_refl) as half. intros ? ?. rewrite Qplus_0_r. apply regFunEq_e. intros ε. simpl. unfold Cjoin_raw. simpl. rewrite QposInf_bind_id. apply ball_weak. apply Qpos_nonneg. assert (QposEq ε (half * ε + half * ε)) by (unfold QposEq; simpl; ring). apply (ball_wd _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. pose proof (g_eq_h (approximate x (mu h (half * ε)))). apply regFunEq_equiv in H0. apply H0. Qed. End unary_complete_functions. End dense_prelength_embedding. corn-8.20.0/metric2/Prelength.v000066400000000000000000000517651473720167500162600ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.metric2.Complete. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.stdlib_omissions.List. Require Import CoRN.stdlib_omissions.Q. Set Implicit Arguments. Local Open Scope Q_scope. Section Prelength_Space. (** ** Prelength space In a length metric space, the distances between points can be realized by continuous paths between the points. Loosely speaking they are metric spaces without holes. Because the notion of continuous paths makes most sense in complete metric spaces, here we use a weaker notion of a prelength space. In this case two points are within e of each other if you can get between the two points making arbitarily short hops while covering a distance arbitrarily close to e. *) Variable X:MetricSpace. (** The notion of a prelength space is neatly characterized by the following simple definition. *) Definition PrelengthSpace := forall (a b:X) (e d1 d2:Qpos), proj1_sig e < proj1_sig (d1+d2)%Qpos -> ball (proj1_sig e) a b -> exists2 c:X, ball (proj1_sig d1) a c & ball (proj1_sig d2) c b. (** There is some evidence that we should be using the classical existential in the above definition. For now we take the middle road and use the [Prop] based existential. This show that the exists statement is not used in computations, but still every occurance is constructive. *) Hypothesis prelength : PrelengthSpace. (** This proves that you can construct a trail of points between a and b that is arbitarily close to e and with arbitrarily short hops. *) Lemma trail : forall dl (e : Qpos) (a b:X), ball (proj1_sig e) a b -> proj1_sig e < Qpos_sum dl -> let n := length dl in (exists2 f : nat -> X, f 0 = a /\ f n = b & forall i z, i < n -> ball (proj1_sig (nth i dl z)) (f i) (f (S i)))%nat. Proof. induction dl. intros e a b H H1. simpl in *. - exfalso. destruct e. simpl in H1. apply (Qlt_not_le _ _ H1). apply Qlt_le_weak, q. - rename a into x. intros e a b B pe. simpl in pe. destruct dl. simpl in *. pose (f:= (fun n => match n with O => a | S _ => b end)). exists f; auto. intros [|i] z H;[|exfalso; auto with *]. clear z H. ring_simplify in pe. apply ball_weak_le with (proj1_sig e). apply Qlt_le_weak; assumption. assumption. set (Sigma := Qpos_sum (q::dl)). pose (g := ((Qmax 0 (proj1_sig e- proj1_sig x))+Sigma) * (1#2)). assert ((Qmax 0 (proj1_sig e- proj1_sig x)) match n with O => a | S n' => f' n' end). auto. intros [|i] z Hi. simpl. congruence. apply Hf'3. auto with *. Qed. Variable Y:MetricSpace. (** The major application of prelength spaces is that it allows one to reduce the problem of [ball (e1 + e2) (f a) (f b)] to [ball (mu f e1 + mu f e2) a b] instead of reducing it to [ball (mu f (e1 + e2)) a b]. This new reduction allows one to continue reasoning by making use of the triangle law. Below we show a more general lemma allowing for arbitarily many terms in the sum. *) Lemma mu_sum : forall e0 (es : list Qpos) (f:UniformlyContinuousFunction X Y) a b, ball_ex (fold_right QposInf_plus (mu f e0) (map (mu f) es)) a b -> ball (proj1_sig (fold_right Qpos_plus e0 es)) (f a) (f b). Proof. intros e0 es f a b Hab. apply ball_closed. intros e' epos. setoid_replace (proj1_sig (fold_right Qpos_plus e0 es + exist _ _ epos)%Qpos) with (proj1_sig (fold_right Qpos_plus e0 (exist _ _ epos::es))) by (simpl; ring). set (ds := map (mu f) es) in *. set (d0 := (mu f e0)) in *. set (d' := (mu f (exist _ _ epos))) in *. assert (H:{ds' | (map Qpos2QposInf ds')=d0::d'::ds}+{In QposInfinity (d0::d'::ds)}). generalize (d0::d'::ds); clear. induction l as [|[d|] ds]. left. exists (@nil Qpos). reflexivity. destruct IHds as [[ds' Hds']|Hds]. left. exists (d::ds'). rewrite <- Hds'. reflexivity. firstorder. firstorder. destruct H as [[ds' Hds']|Hds]. destruct ds' as [|g0 [|g' gs]]; try discriminate Hds'. inversion Hds'. clear Hds'. unfold d0 in *; clear d0. unfold d' in *; clear d'. unfold ds in *; clear ds. replace (fold_right QposInf_plus (mu f e0) (map (mu f) es)) with (Qpos2QposInf (fold_right Qpos_plus g0 gs)) in Hab. simpl in Hab. assert (proj1_sig (fold_right Qpos_plus g0 gs) < Qpos_sum ((g' :: gs)++(g0::nil))) as H. { simpl. apply (Qle_lt_trans _ (Qpos_sum (gs ++ g0::nil))). clear - g0. induction gs. simpl. rewrite Qplus_0_r. apply Qle_refl. simpl. apply Qplus_le_r, IHgs. rewrite -> Qlt_minus_iff. ring_simplify. destruct g'; exact q. } case (trail _ _ _ _ Hab H). clear Hab H. cut (map Qpos2QposInf (g' :: gs) = map (mu f) (exist _ _ epos :: es)). clear H2 H1. generalize (exist _ _ epos::es) (g'::gs) a. clear gs g' es epos e' a. induction l as [|e es]; intros gs a Hes x [Ha Hb] H; destruct gs; try discriminate Hes. simpl in *. apply uc_prf. rewrite <- H0. rewrite <- Hb. rewrite <- Ha. simpl. apply (H 0%nat g0). auto with *. simpl. inversion Hes; clear Hes. eapply ball_triangle. apply uc_prf. rewrite <- H2. rewrite <- Ha. simpl; apply (H 0%nat g0). simpl; auto with *. apply (IHes _ (x 1%nat) H3 (fun i => x (S i))). auto with *. intros. apply (H (S i) z). simpl; auto with *. simpl; congruence. rewrite <- H2. rewrite <- H0. clear - gs. induction gs. reflexivity. simpl. rewrite <- IHgs. reflexivity. assert (H:forall (e:Qpos) es, proj1_sig e < proj1_sig (fold_right Qpos_plus e0 es)%Qpos -> (mu f e)=QposInfinity -> ball (m:=Y) (proj1_sig (fold_right Qpos_plus e0 es)) (f a) (f b)). { intros e esx He Hmu. apply ball_weak_le with (proj1_sig e);[apply Qlt_le_weak; assumption|]. apply uc_prf. rewrite Hmu. constructor. } case (in_inv Hds). intros Hd0. apply H with e0. clear - es. induction es. simpl. rewrite -> Qlt_minus_iff. ring_simplify. exact epos. simpl. apply (Qlt_le_trans _ _ _ IHes). simpl. apply Qplus_le_r. rewrite <- Qplus_0_l, Qplus_assoc. apply Qplus_le_l. rewrite Qplus_0_r. apply Qpos_nonneg. assumption. clear Hds. change (d'::ds) with (map (mu f) (exist _ _ epos::es)). induction (exist _ _ epos::es); intros Hds. elim Hds. simpl in Hds. destruct Hds as [Ha0|Hds]. apply H with a0. simpl. rewrite -> Qlt_minus_iff. ring_simplify. destruct (fold_right Qpos_plus e0 l); exact q. assumption. simpl. eapply ball_weak_le with (proj1_sig (fold_right Qpos_plus e0 l)). simpl. rewrite -> Qle_minus_iff; ring_simplify. auto with *. auto. Qed. End Prelength_Space. Section Map. Local Open Scope uc_scope. Variable X Y : MetricSpace. Hypothesis plX : PrelengthSpace X. Variable f : X --> Y. (** *** A more effictient [Cmap] and [Cbind] The main application of prelength spaces is to allow one to use a more natural and more efficent map function for complete metric spaces. Since this map function is more widely used in practice, it gets the name [Cmap] while the original map function is stuck with the name [Cmap_slow] as a reminder to try to use the function defined here if possible. *) Definition Cmap_raw (x:Complete X) (e:QposInf) := f (approximate x (QposInf_bind (mu f) e)). Lemma Cmap_fun_prf (x:Complete X) : is_RegularFunction (@ball Y) (fun e => f (approximate x (QposInf_bind (mu f) e))). Proof. intros e1 e2. simpl. apply (@mu_sum X plX Y e2 (e1::nil)). simpl. destruct (mu f e1) as [d1|]. destruct (mu f e2) as [d2|]. apply (@regFun_prf _ (@ball X)). constructor. constructor. Qed. Definition Cmap_fun (x:Complete X) : Complete Y := Build_RegularFunction (Cmap_fun_prf x). Lemma Cmap_prf : is_UniformlyContinuousFunction Cmap_fun (mu f). Proof. intros e0 x y Hxy e1 e2. simpl. rewrite <- Qplus_assoc. apply (@mu_sum X plX Y e2 (e1::e0::nil)). simpl. destruct (mu f e1) as [d1|];[|constructor]. destruct (mu f e0) as [d0|];[|constructor]. destruct (mu f e2) as [d2|];[|constructor]. simpl in *. rewrite Qplus_assoc. apply Hxy. Qed. Definition Cmap : (Complete X) --> (Complete Y) := Build_UniformlyContinuousFunction Cmap_prf. (** [Cmap] is equivalent to the original [Cmap_slow] *) Lemma Cmap_correct : msp_eq Cmap (Cmap_slow f). Proof. apply ucEq_equiv. intros x e1 e2. simpl. unfold Cmap_slow_raw. rewrite Qplus_0_r. apply (@mu_sum X plX Y e2 (e1::nil)). simpl. destruct (mu f e1) as [d1|]; try constructor. destruct (mu f e2) as [d2|]; try constructor. simpl. eapply ball_weak_le;[|apply regFun_prf]. simpl. apply Qplus_le_r. rewrite <- (Qmult_1_l (proj1_sig d2)), Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. discriminate. Qed. Lemma Cmap_fun_correct : forall x, msp_eq (Cmap_fun x) (Cmap_slow_fun f x). Proof. apply Cmap_correct. Qed. End Map. Section fast_Monad_Laws. Local Open Scope uc_scope. Variable X Y Z : MetricSpace. Hypothesis plX : PrelengthSpace X. Hypothesis plY : PrelengthSpace Y. Notation "a =m b" := (msp_eq a b) (at level 70, no associativity). Lemma fast_MonadLaw1 a : Cmap plX (uc_id X) a =m a. Proof. destruct (Cmap_correct plX (uc_id X)). rewrite H0. apply MonadLaw1. Qed. Lemma fast_MonadLaw2 (f:Y --> Z) (g:X --> Y) a : Cmap plX (uc_compose f g) a =m (Cmap plY f (Cmap plX g a)). Proof. destruct (Cmap_correct plX (f ∘ g)). rewrite H0. clear H0 H. destruct (Cmap_correct plY f). rewrite H0. clear H0 H. destruct (Cmap_correct plX g). rewrite H0. clear H0 H. apply MonadLaw2. Qed. Lemma fast_MonadLaw3 (f:X --> Y) a : Cmap plX f (Cunit a) =m Cunit (f a). Proof. destruct (Cmap_correct plX f). rewrite H0. clear H0 H. apply MonadLaw3. Qed. (* State them all in such a shape some day... *) End fast_Monad_Laws. Local Open Scope uc_scope. (** [Cmap] preserves extensional equality *) Lemma map_eq_complete {X Y : MetricSpace} {plX : PrelengthSpace X} (f g : X --> Y) : (forall x : X, msp_eq (f x) (g x)) -> (forall x : Complete X, msp_eq (Cmap plX f x) (Cmap plX g x)). Proof. intros A x. apply lift_eq_complete. intro y. rewrite fast_MonadLaw3, fast_MonadLaw3, A. reflexivity. Qed. (** Similarly we define a new Cbind *) Definition Cbind X Y plX (f:X-->Complete Y) := uc_compose Cjoin (Cmap plX f). Lemma Cbind_correct : forall X Y plX (f:X-->Complete Y), msp_eq (Cbind plX f) (Cbind_slow f). Proof. unfold Cbind, Cbind_slow. intros X Y plX f. rewrite -> (Cmap_correct). reflexivity. Qed. Lemma Cbind_fun_correct : forall X Y plX (f:X-->Complete Y) x, msp_eq (Cbind plX f x) (Cbind_slow f x). Proof. apply Cbind_correct. Qed. (** Similarly we define a new Cmap_strong *) Lemma Cmap_strong_prf : forall (X Y:MetricSpace) (plX:PrelengthSpace X), is_UniformlyContinuousFunction (@Cmap X Y plX) Qpos2QposInf. Proof. intros X Y plX e a b Hab. apply (ball_wd _ eq_refl _ _ (Cmap_correct _ _) _ _ (Cmap_correct _ _)). apply Cmap_strong_slow_prf. auto. Qed. Definition Cmap_strong X Y plX : (X --> Y) --> (Complete X --> Complete Y) := Build_UniformlyContinuousFunction (@Cmap_strong_prf X Y plX). Lemma Cmap_strong_correct : forall X Y plX, msp_eq (@Cmap_strong X Y plX) (@Cmap_strong_slow X Y). Proof. intros X Y plX. split. apply Qle_refl. intro f. destruct (Cmap_correct plX f) as [_ H0]. split. apply Qle_refl. intro x. apply H0. Qed. (** Similarly we define a new Cap *) Definition Cap_raw X Y plX (f:Complete (X --> Y)) (x:Complete X) (e:QposInf) := approximate (Cmap plX (approximate f (Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)*e)%QposInf) x) (Qpos2QposInf (exist (Qlt 0) (1#2) eq_refl)*e)%QposInf. Lemma Cap_fun_prf X Y plX (f:Complete (X --> Y)) (x:Complete X) : is_RegularFunction (@ball Y) (Cap_raw plX f x). Proof. intros e1 e2. pose (exist (Qlt 0) (1#2) eq_refl) as half. unfold Cap_raw. unfold Cap_raw. unfold QposInf_mult, QposInf_bind. set (he1 := (half * e1)%Qpos). set (he2 := (half * e2)%Qpos). set (f1 := (approximate f he1)). set (f2 := (approximate f he2)). change (Cmap (Y:=Y) plX f1) with (Cmap_strong Y plX f1). change (Cmap (Y:=Y) plX f2) with (Cmap_strong Y plX f2). set (y1 :=(Cmap_strong Y plX f1 x)). set (y2 :=(Cmap_strong Y plX f2 x)). setoid_replace (proj1_sig e1 + proj1_sig e2) with (proj1_sig (he1 + (he1 + he2) + he2))%Qpos by (simpl; ring). rewrite <- ball_Cunit. apply ball_triangle with y2;[|apply ball_approx_r]. apply ball_triangle with y1;[apply ball_approx_l|]. apply (uc_prf (Cmap_strong Y plX)). apply (@regFun_prf _ (@ball (X-->Y))). Qed. Definition Cap_fun X Y plX (f:Complete (X --> Y)) (x:Complete X) : Complete Y := Build_RegularFunction (Cap_fun_prf plX f x). Lemma Cap_fun_correct : forall X Y plX (f:Complete (X --> Y)) x, msp_eq (Cap_fun plX f x) (Cap_slow_fun f x). Proof. intros X Y plX f x e1 e2. pose (exist (Qlt 0) (1#2) eq_refl) as half. simpl. unfold Cap_raw, Cap_slow_raw. set (e1':=(half * e1)%Qpos). set (e2':=(half * e2)%Qpos). rewrite Qplus_0_r. change (ball (proj1_sig e1 + proj1_sig e2) (approximate (Cmap plX (approximate f (half * e1)%Qpos) x) e1') (approximate (Cmap_slow (approximate f (half * e2)%Qpos) x) e2')). setoid_replace (proj1_sig e1 + proj1_sig e2) with (proj1_sig (e1' + ((half * e1)%Qpos + (half * e2)%Qpos) + e2'))%Qpos by (unfold e1', e2'; simpl; ring). generalize x e1' e2'. assert (ball (proj1_sig (half * e1 + half * e2)%Qpos) (Cmap plX (approximate f (half * e1)%Qpos)) (Cmap_slow (approximate f (half * e2)%Qpos))). { assert (QposEq (half * e1 + half * e2) (half * e1 + half * e2)) by reflexivity. apply (ball_wd _ H _ _ (Cmap_correct _ _) _ _ (reflexivity _)). set (f1:=(approximate f (half * e1)%Qpos)). set (f2:=(approximate f (half * e2)%Qpos)). apply Cmap_strong_slow_prf. apply (@regFun_prf _ (@ball (X-->Y))). } apply H. Qed. Definition Cap_modulus X Y (f:Complete (X --> Y)) (e:Qpos) : QposInf := mu (approximate f ((1#3)*e)%Qpos) ((1#3)*e). Lemma Cap_weak_prf X Y plX (f:Complete (X --> Y)) : is_UniformlyContinuousFunction (Cap_fun plX f) (Cap_modulus f). Proof. intros e x y H. set (e' := ((1#3)*e)%Qpos). setoid_replace (proj1_sig e) with (proj1_sig (e'+e'+e')%Qpos) by (simpl; ring). apply ball_triangle with (Cmap plX (approximate f e') y). apply ball_triangle with (Cmap plX (approximate f e') x). - apply (ball_wd _ eq_refl _ _ (Cap_fun_correct plX f x) _ _ (reflexivity _)). simpl (Cmap plX (approximate f e') x). apply (ball_wd _ eq_refl _ _ (reflexivity _) _ _ (Cmap_fun_correct _ _ _)). apply Cap_slow_help. - apply (uc_prf). apply H. - apply ball_sym. apply (ball_wd _ eq_refl _ _ (Cap_fun_correct plX f y) _ _ (reflexivity _)). simpl (Cmap plX (approximate f e') y). apply (ball_wd _ eq_refl _ _ (reflexivity _) _ _ (Cmap_fun_correct _ _ _)). apply Cap_slow_help. Qed. Definition Cap_weak X Y plX (f:Complete (X --> Y)) : Complete X --> Complete Y := Build_UniformlyContinuousFunction (Cap_weak_prf plX f). Lemma Cap_weak_correct : forall X Y plX (f:Complete (X --> Y)), msp_eq (Cap_weak plX f) (Cap_weak_slow f). Proof. intros. split. apply Qle_refl. apply (Cap_fun_correct plX f). Qed. Lemma Cap_prf X Y plX : is_UniformlyContinuousFunction (@Cap_weak X Y plX) Qpos2QposInf. Proof. intros e a b Hab. apply (ball_wd _ eq_refl _ _ (Cap_weak_correct plX a) _ _ (Cap_weak_correct plX b)). apply Cap_slow_prf. assumption. Qed. Definition Cap X Y plX : Complete (X --> Y) --> Complete X --> Complete Y := Build_UniformlyContinuousFunction (Cap_prf plX). Lemma Cap_correct : forall X Y plX, msp_eq (Cap Y plX) (Cap_slow X Y). Proof. intros. split. apply Qle_refl. intro f. split. apply Qle_refl. apply (Cap_fun_correct plX f). Qed. (* begin hide *) Add Parametric Morphism X Y plX : (@Cmap_fun X Y plX) with signature (@msp_eq _) ==> (@msp_eq (Complete X)) ==> (@msp_eq (Complete Y)) as Cmap_wd. Proof. intros x1 x2 Hx y1 y2 Hy. rewrite -> Cmap_fun_correct. set (a:=(Cmap_slow_fun x1 y1)). rewrite -> Cmap_fun_correct. apply Cmap_slow_wd; auto. Qed. Lemma Cmap_wd_loc : forall (X Y : MetricSpace) (plX : PrelengthSpace X) (f g : X --> Y) (x : Complete X) (e : Qpos), (forall a : X, ball (proj1_sig e) (Cunit a) x -> msp_eq (f a) (g a)) -> msp_eq (Cmap_fun plX f x) (Cmap_fun plX g x). Proof. intros. rewrite Cmap_fun_correct. rewrite Cmap_fun_correct. apply Cmap_slow_wd_loc with (e:=e). exact H. Qed. Add Parametric Morphism X Y H : (@Cap_weak X Y H) with signature (@msp_eq _) ==> (@msp_eq _) as Cap_weak_wd. Proof. intros x1 x2 Hx. apply (@uc_wd _ _ (Cap Y H));assumption. Qed. Add Parametric Morphism X Y H : (@Cap_fun X Y H) with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as Cap_wd. Proof. intros x1 x2 Hx y1 y2 Hy. transitivity (Cap_fun H x1 y2). apply (@uc_wd _ _ (Cap_weak H x1) _ _ Hy). generalize y2. apply (@uc_wd _ _ (Cap Y H));assumption. Qed. (* end hide *) (** Similarly we define a new [Cmap2]. *) Definition Cmap2 (X Y Z:MetricSpace) (Xpl : PrelengthSpace X) (Ypl : PrelengthSpace Y) (f : X --> Y --> Z) : Complete X --> Complete Y --> Complete Z := uc_compose (@Cap Y Z Ypl) (Cmap Xpl f). (** Completion of a metric space preserves the prelength property. In fact the completion of a prelenght space is a length space, but we have not formalized the notion of a length space yet. *) Lemma CompletePL : forall X, PrelengthSpace X -> PrelengthSpace (Complete X). Proof. intros X Xpl x y e d1 d2 He Hxy. destruct (Qpos_sub _ _ He) as [x0 q]. pose (exist (Qlt 0) (4#1) eq_refl) as four. pose (exist (Qlt 0) (1#5) eq_refl) as fifth. pose (gA := (fifth*x0)%Qpos). pose (g := Qpos_min (Qpos_min ((1#2)*d1) ((1#2)*d2)) gA). unfold PrelengthSpace in Xpl. assert (Hd1: proj1_sig g < proj1_sig d1). { unfold g. eapply Qle_lt_trans. apply Qpos_min_lb_l. eapply Qle_lt_trans. apply Qpos_min_lb_l. simpl. rewrite <- (Qmult_1_l (proj1_sig d1)). rewrite Qmult_assoc. apply Qmult_lt_r. apply Qpos_ispos. reflexivity. } assert (Hd2: proj1_sig g < proj1_sig d2). { unfold g. eapply Qle_lt_trans. apply Qpos_min_lb_l. eapply Qle_lt_trans. apply Qpos_min_lb_r. simpl. rewrite <- (Qmult_1_l (proj1_sig d2)). rewrite Qmult_assoc. apply Qmult_lt_r. apply Qpos_ispos. reflexivity. } destruct (Qpos_sub _ _ Hd1) as [d1' Hd1']. destruct (Qpos_sub _ _ Hd2) as [d2' Hd2']. assert (He': proj1_sig (g + e + g)%Qpos < proj1_sig (d1' + d2')%Qpos). { simpl. apply (Qplus_lt_l _ _ (proj1_sig g+ proj1_sig g)). setoid_replace (proj1_sig d1' + proj1_sig d2' + (proj1_sig g + proj1_sig g)) with (proj1_sig ((g+d1')%Qpos) + proj1_sig (g+d2')%Qpos) by (simpl; ring). unfold QposEq in *. rewrite <- Hd1'. rewrite <- Hd2'. clear d1' Hd1' d2' Hd2'. apply Qle_lt_trans with (proj1_sig (e + four*gA)%Qpos). apply (Qle_trans _ (proj1_sig e+(4#1)*proj1_sig g)). ring_simplify. apply Qle_refl. apply Qplus_le_r. apply Qmult_le_l. reflexivity. apply Qpos_min_lb_r. rewrite -> q. apply Qplus_lt_r. simpl. rewrite Qmult_assoc, <- (Qmult_1_l (proj1_sig x0)), Qmult_assoc. apply Qmult_lt_r. destruct x0; exact q0. reflexivity. } destruct (Xpl _ _ _ _ _ He' (Hxy g g)) as [c Hc1 Hc2]. exists (Cunit c). rewrite Hd1'. eapply ball_triangle. apply ball_approx_r. rewrite -> ball_Cunit. assumption. rewrite Hd2'. rewrite Qplus_comm. eapply ball_triangle with (Cunit (approximate y g)). rewrite -> ball_Cunit. assumption. apply ball_approx_l. Qed. corn-8.20.0/metric2/ProductMetric.v000066400000000000000000000313241473720167500171010ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.Metric. Require Import CoRN.metric2.Classification. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.metric2.Prelength. Require Import CoRN.metric2.Complete. Require Import CoRN.metric2.LocatedSubset. Set Implicit Arguments. (** ** Product Metric The product of two metric spaces forms a metric space *) Section ProductMetric. Variable X Y : MetricSpace. Definition prod_ball e (a b:X*Y) := ball e (fst a) (fst b) /\ ball e (snd a) (snd b). Lemma prod_ball_refl : forall (e:Q) a, 0 <= e -> prod_ball e a a. Proof. intros e a. split; apply ball_refl; exact H. Qed. Lemma prod_ball_sym : forall e a b, prod_ball e a b -> prod_ball e b a. Proof. intros e a b [H1 H2]. split; auto with *. Qed. Lemma prod_ball_triangle : forall e1 e2 a b c, prod_ball e1 a b -> prod_ball e2 b c -> prod_ball (e1 + e2) a c. Proof. intros e1 e2 a b c [H1 H2] [H3 H4]. split; eauto with metric. Qed. Lemma prod_ball_closed : forall e a b, (forall d, 0 < d -> prod_ball (e + d) a b) -> prod_ball e a b. Proof. intros e a b H. unfold prod_ball in *. split; apply ball_closed; firstorder. Qed. Lemma prod_is_MetricSpace : is_MetricSpace prod_ball. Proof. split. - intros. intros a. apply prod_ball_refl, H. - exact prod_ball_sym. - exact prod_ball_triangle. - exact prod_ball_closed. - intros. destruct H. apply (msp_nonneg (msp X)) in H. exact H. - intros. split. + apply (msp_stable (msp X)). intro abs. contradict H; intros [H _]. contradiction. + apply (msp_stable (msp Y)). intro abs. contradict H; intros [_ H]. contradiction. Qed. Definition ProductMS : MetricSpace. Proof. exists (prod X Y) prod_ball. 2: apply prod_is_MetricSpace. intros e1 e2 a1 a2 He. split. - intros [H H0]. split; rewrite <- He; assumption. - intros [H H0]. split; rewrite He; assumption. Defined. (** Product metrics preserve properties of metric spaces such as being a prelenght space, being stable, being located, and being deciable *) Lemma ProductMS_prelength : PrelengthSpace X -> PrelengthSpace Y -> PrelengthSpace ProductMS. Proof. intros HX HY a b e d1 d2 Hed Hab. destruct (HX (fst a) (fst b) e d1 d2 Hed (proj1 Hab)) as [c1 Hc1]. destruct (HY (snd a) (snd b) e d1 d2 Hed (proj2 Hab)) as [c2 Hc2]. exists (c1,c2); split; assumption. Defined. Lemma ProductMS_located : locatedMetric X -> locatedMetric Y -> locatedMetric ProductMS. Proof. unfold locatedMetric. intros H0 H1 e d x y Hed. destruct (H0 _ _ (fst x) (fst y) Hed) as [A | A]. destruct (H1 _ _ (snd x) (snd y) Hed) as [B | B]. left. split; assumption. right; intros [_ H]. apply B; assumption. right; intros [H _]. apply A; assumption. Defined. Lemma ProductMS_decidable : decidableMetric X -> decidableMetric Y -> decidableMetric ProductMS. Proof. unfold decidableMetric. intros H0 H1 e x y. destruct (H0 e (fst x) (fst y)) as [A | A]. destruct (H1 e (snd x) (snd y)) as [B | B]. left. split; assumption. right; intros [_ H]. apply B; assumption. right; intros [H _]. apply A; assumption. Defined. (** This defines a pairing function with types of a metric space *) Definition PairMS (x:X) (y:Y) : ProductMS := (x,y). End ProductMetric. (* begin hide *) Arguments PairMS [X Y]. Add Parametric Morphism X Y : (@PairMS X Y) with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as PairMS_wd. Proof. intros. split; assumption. Qed. (* end hide *) Local Open Scope uc_scope. (** [together] forms the tensor of two functions operating between metric spaces *) Lemma together_uc : forall A B C D (f:A --> C) (g:B --> D), is_UniformlyContinuousFunction (fun (p:ProductMS A B) => (f (fst p), g (snd p)):ProductMS C D) (fun x => QposInf_min (mu f x) (mu g x)). Proof. intros A B C D f g e a b H. split; simpl; apply uc_prf; apply ball_ex_weak_le with (QposInf_min (mu f e) (mu g e)). apply QposInf_min_lb_l. destruct (QposInf_min (mu f e) (mu g e)) as [q|]; auto. destruct H; auto. apply QposInf_min_lb_r. destruct (QposInf_min (mu f e) (mu g e)) as [q|]; auto. destruct H; auto. Qed. Definition together A B C D (f:A --> C) (g:B --> D) : (ProductMS A B --> ProductMS C D) := Build_UniformlyContinuousFunction (together_uc f g). (** Uniformly continuous functions on the product space can be curried: *) Section uc_curry. Context {A B C: MetricSpace} (f: ProductMS A B --> C). Definition uc_curry_help_prf (a: A): is_UniformlyContinuousFunction (fun b => f (a, b)) (mu f). Proof with auto. repeat intro. destruct f. clear f. simpl in *. apply uc_prf. destruct (mu e)... split... apply ball_refl. apply Qpos_nonneg. Qed. Definition uc_curry_help (a: A): B --> C := Build_UniformlyContinuousFunction (uc_curry_help_prf a). Definition uc_curry_prf: is_UniformlyContinuousFunction uc_curry_help (mu f). Proof with auto. repeat intro. split. apply Qpos_nonneg. intro. simpl. destruct f. clear f. simpl in *. apply uc_prf. destruct (mu e)... split... apply ball_refl. apply Qpos_nonneg. Qed. Definition uc_curry: A --> B --> C := Build_UniformlyContinuousFunction uc_curry_prf. End uc_curry. (** Uncurry probably cannot be defined because because there is no way to construct a uniform modulus of continuity from the domain-indexed set of uni-formly continuous functions. Hence, we can convert only one way, and so non-curried versions of binary functions are strictly more valuable than their curried representations. Consequently, it can be argued that binary functions should always be defined in non-curried form. *) (** Completion distributes over products: *) Section completion_distributes. Context {X Y: MetricSpace}. Definition distrib_Complete (xy: Complete (ProductMS X Y)) : ProductMS (Complete X) (Complete Y). Proof. refine (@Build_RegularFunction _ _ (fun e => fst (approximate xy e)) _, @Build_RegularFunction _ _ (fun e => snd (approximate xy e)) _). intros e1 e2. apply xy. intros e1 e2. apply xy. Defined. Lemma distrib_Complete_uc_prf: is_UniformlyContinuousFunction distrib_Complete (fun e => e). Proof. unfold distrib_Complete. intros ??? H. split; repeat intro; simpl; apply H. Qed. Definition distrib_Complete_uc: Complete (ProductMS X Y) --> ProductMS (Complete X) (Complete Y) := Build_UniformlyContinuousFunction distrib_Complete_uc_prf. Definition undistrib_Complete (xy: ProductMS (Complete X) (Complete Y)) : Complete (ProductMS X Y). Proof. refine (@Build_RegularFunction (ProductMS X Y) _ (fun e => (approximate (fst xy) e, approximate (snd xy) e)) _). intros e1 e2. split. apply (regFun_prf (fst (xy))). apply (regFun_prf (snd (xy))). Defined. Lemma undistrib_Complete_uc_prf: is_UniformlyContinuousFunction undistrib_Complete (fun e => e). Proof. unfold distrib_Complete. intros ??? H. split; repeat intro; simpl; apply H. Qed. Definition undistrib_Complete_uc: ProductMS (Complete X) (Complete Y) --> Complete (ProductMS X Y) := Build_UniformlyContinuousFunction undistrib_Complete_uc_prf. Lemma distrib_after_undistrib_Complete xy : msp_eq (distrib_Complete (undistrib_Complete xy)) xy. Proof. intros. unfold distrib_Complete, undistrib_Complete. simpl. split; apply regFunEq_equiv, regFunEq_e; simpl; intros; apply ball_refl. apply (Qpos_nonneg (e+e)). apply (Qpos_nonneg (e+e)). Qed. Lemma undistrib_after_distrib_Complete xy : msp_eq (undistrib_Complete (distrib_Complete xy)) xy. Proof. intros. unfold undistrib_Complete. apply regFunEq_equiv. apply (@regFunEq_e (ProductMS X Y)). split; simpl; apply ball_refl. apply (Qpos_nonneg (e+e)). apply (Qpos_nonneg (e+e)). Qed. End completion_distributes. (** The diagonal function [x ⟼ (x,x)] is a uniformly continuous function from a metric space X to the product space [X × X] *) Require Import Coq.Unicode.Utf8. Section diag. Variable X:MetricSpace. Definition diag_raw : X → (ProductMS X X) := λ x, (x,x). Lemma diag_uc : (is_UniformlyContinuousFunction diag_raw (λ ε, ε)%Qpos). Proof. repeat try red; intuition. Qed. Definition diag: X --> (ProductMS X X) := Build_UniformlyContinuousFunction diag_uc. End diag. (* The curried and non-curried ways of lifting a function of 2 variables into the completed spaces are equal. *) Lemma Cmap2_curry : forall (A B C: MetricSpace) (Apl : PrelengthSpace A) (Bpl : PrelengthSpace B) (f : ProductMS A B --> C) (a : Complete A) (b : Complete B), @msp_eq (Complete C) (Cmap2 Apl Bpl (uc_curry f) a b) (uc_compose (Cmap (ProductMS_prelength Apl Bpl) f) undistrib_Complete_uc (a,b)). Proof. intros. intros e1 e2. rewrite Qplus_0_r. assert ((1#2)*proj1_sig e1 + proj1_sig e2 <= proj1_sig e1 + proj1_sig e2). { apply Qplus_le_l. rewrite <- (Qmult_1_l (proj1_sig e1)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. } apply (ball_weak_le _ _ _ H). apply (mu_sum (ProductMS_prelength Apl Bpl) e2 (((1#2)*e1)%Qpos :: nil) f). simpl. clear H. destruct (mu f (exist (Qlt 0) (1#2) (@eq_refl comparison Lt) * e1)). 2: reflexivity. destruct (mu f e2). 2: reflexivity. split; apply regFun_prf. Qed. Definition uc_flip (X Y : MetricSpace) : ProductMS X Y --> ProductMS Y X. Proof. apply (@Build_UniformlyContinuousFunction (ProductMS X Y) (ProductMS Y X) (fun xy => pair (snd xy) (fst xy)) (fun e => e)). intros e a b H. simpl. split; apply H. Defined. Definition uc_assoc (X Y Z : MetricSpace) : ProductMS (ProductMS X Y) Z --> ProductMS X (ProductMS Y Z). Proof. apply (@Build_UniformlyContinuousFunction (ProductMS (ProductMS X Y) Z) (ProductMS X (ProductMS Y Z)) (fun xyz => pair (fst (fst xyz)) (pair (snd (fst xyz)) (snd xyz))) (fun e => e)). intros e a b H. simpl. split. - simpl. destruct H, H. exact H. - simpl. destruct H, H. split; assumption. Defined. Definition uc_complete_curry {X Y Z : MetricSpace} (f : Complete (ProductMS X Y) --> Z) : Complete X --> Complete Y --> Z := uc_curry (uc_compose f undistrib_Complete_uc). Lemma Cmap2_comm : forall (X Y : MetricSpace) (Xpl : PrelengthSpace X) (f : ProductMS X X --> Y), (forall a b :X, msp_eq (f (a,b)) (f (b,a))) -> forall (a b:Complete X), @msp_eq (Complete Y) (uc_complete_curry (Cmap (ProductMS_prelength Xpl Xpl) f) a b) (uc_complete_curry (Cmap (ProductMS_prelength Xpl Xpl) f) b a). Proof. intros. assert (ucEq (Cmap (ProductMS_prelength Xpl Xpl) f) (Cmap (ProductMS_prelength Xpl Xpl) (uc_compose f (uc_flip X X)))). { intro x. apply Cmap_wd. apply ucEq_equiv. intros xy. simpl. rewrite H. destruct xy. reflexivity. reflexivity. } specialize (H0 (undistrib_Complete (a,b))). simpl in H0. simpl. intros e1 e2. specialize (H0 e1 e2). simpl. simpl in H0. assert (forall x, eq (QposInf_bind (λ e : Qpos, e) x) x). { intro x. destruct x;reflexivity. } rewrite H1 in H0. apply H0. Qed. Lemma undistrib_Located : forall (X Y : MetricSpace) (A : Complete (ProductMS X Y) -> Prop), LocatedSubset _ A -> LocatedSubset (ProductMS (Complete X) (Complete Y)) (fun xy => exists p, msp_eq p (undistrib_Complete xy) /\ A p). Proof. intros X Y A loc d e p ltde. destruct (loc d e (undistrib_Complete p) ltde) as [far|close]. - left. intros y H abs. destruct H as [q [H H0]]. apply (far q H0). rewrite H. intros d1 d2; split; simpl; apply abs. - right. destruct close as [y [Ay close]]. exists (distrib_Complete y). split. exists y. split. symmetry. apply undistrib_after_distrib_Complete. exact Ay. rewrite <- distrib_after_undistrib_Complete. split; intros d1 d2; apply close. Defined. corn-8.20.0/metric2/Ranges.v000066400000000000000000000011521473720167500155300ustar00rootroot00000000000000 Require Import Program MathClasses.interfaces.canonical_names util.Container QArith QMinMax CRlattice. Definition Range (T: Type) := prod T T. #[global] Instance in_QRange: Container Q (Range Q) := λ r x, (Qmin (fst r) (snd r) <= x <= Qmax (fst r) (snd r))%Q. #[global] Instance in_CRRange: Container (msp_car CR) (Range (msp_car CR)) := λ r x, (ucFun (ucFun CRmin (fst r)) (snd r) <= x)%CR ∧ (x <= ucFun (ucFun CRmax (fst r)) (snd r))%CR. #[global] Instance in_sig_Range `{Container A (Range A)} (P: A → Prop): Container (sig P) (Range (sig P)) := λ r x, In (` (fst r), ` (snd r)) (` x). corn-8.20.0/metric2/StepFunction.v000066400000000000000000000660151473720167500167430ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.model.structures.OpenUnit. Require Import CoRN.tactics.CornTac. Require Import CoRN.tactics.Qauto. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.algebra.COrdFields. Set Implicit Arguments. Local Open Scope Q_scope. Section StepFunction. Variable X:Type. (** * Step Functions We represent step functions from [[a,b]] to [X] as binary trees. The tree nodes store rational numbers between 0 and 1, that represent the relative cut of the previous interval of definition. So a rational number o at the root means we cut [[a,b]] into the subintervals [[a, a+(b-a)*o]] and [[a+(b-a)*o, b]]. The leaves of the trees store values in [X], that represent constant functions at those leaf intervals. The initial interval of definition [[a,b]] is not given in the inductive type StepF, it must be provided a posteriori when we want to interpret a StepF as an actual function. The step functions are not defined at the rational glue points, because constructively all total functions must be continuous. This is enough to implement integration where functions only need to be defined almost everywhere. StepF is an applicative functor. A function f : X -> Y maps on a StepF X by keeping the same cuts (tree nodes) and applying f at the leaves. When the StepF X is interpreted as an actual function, this functor is just function composition ([[a,b]] -> X) -> (X -> Y) -> ([[a,b]] -> Y). By splitting we can merge 2 trees of cuts, and that yields the applicative functor Ap : StepF (X->Y) -> StepF X -> StepF Y. *) Inductive StepF :Type:= |constStepF:X-> StepF |glue:OpenUnit-> StepF -> StepF -> StepF. Fixpoint StepFfold (Y : Type) (f : X -> Y) (g : OpenUnit -> Y -> Y -> Y) (s : StepF) {struct s} : Y := match s with | constStepF x => f x | glue b t1 t2 => g b (StepFfold f g t1) (StepFfold f g t2) end. (** If f is a step function, so is f(1-x). This symmetry operation is useful reasoning about step functions because of the symetric nature of the glue constructor. *) Definition Mirror :StepF -> StepF := StepFfold constStepF (fun a l r => glue (OpenUnitDual a) r l). (** [Split] decomposes (and scales) a step function at a point o. It is essentially an inverse operation of glue *) Fixpoint Split (s : StepF) (a : OpenUnit) : StepF*StepF. Proof. destruct s as [x | b t1 t2]. - exact (constStepF x, constStepF x). - destruct (Q_dec a b) as [[ltab|ltba]|_]. + (* a < b so we split the left branch t1 and keep the same right branch t2. *) destruct (Split t1 (OpenUnitDiv a b ltab)) as [L R]. exact (L, (glue (OpenUnitDualDiv b a ltab) R t2)). + (* b < a so we split the right branch t2 and keep the same left branch t1. *) destruct (Split t2 (OpenUnitDualDiv a b ltba)) as [L R]. refine ((glue (OpenUnitDiv b a ltba) t1 L), R). + exact (t1,t2). Defined. Definition SplitL (s:StepF) (o:OpenUnit) : StepF := fst (Split s o). Definition SplitR (s:StepF) (o:OpenUnit) : StepF := snd (Split s o). (** Induction principles for reasoning about [Split], [SplitR], and [SplitL] *) Lemma Split_ind : forall s a (P:StepF*StepF -> Prop), (P (SplitL s a,SplitR s a)) -> P (Split s a). Proof. intros s a P. unfold SplitL, SplitR. destruct (Split s a). auto with *. Qed. Lemma SplitLR_glue_ind : forall s1 s2 (a b:OpenUnit) (P:StepF -> StepF -> Prop), (forall (H:a < b), P (SplitL s1 (OpenUnitDiv a b H)) (glue (OpenUnitDualDiv b a H) (SplitR s1 (OpenUnitDiv a b H)) s2)) -> (forall (H:b < a), P (glue (OpenUnitDiv b a H) s1 (SplitL s2 (OpenUnitDualDiv a b H))) (SplitR s2 (OpenUnitDualDiv a b H))) -> (a == b -> P s1 s2) -> P (SplitL (glue b s1 s2) a) (SplitR (glue b s1 s2) a). Proof. intros s1 s2 a b P Hl Hr Heq. unfold SplitL, SplitR. simpl. destruct (Q_dec a b) as [[Hab|Hab]|Hab]; try apply Split_ind; simpl; auto with *. Qed. Lemma SplitL_glue_ind : forall s1 s2 (a b:OpenUnit) (P:StepF -> Prop), (forall (H:a < b), P (SplitL s1 (OpenUnitDiv a b H))) -> (forall (H:b < a), P (glue (OpenUnitDiv b a H) s1 (SplitL s2 (OpenUnitDualDiv a b H)))) -> (a == b -> P (s1)) -> P (SplitL (glue b s1 s2) a). Proof. intros. apply (SplitLR_glue_ind s1 s2 a b (fun a b => P a)); assumption. Qed. Lemma SplitR_glue_ind : forall s1 s2 (a b:OpenUnit) (P:StepF -> Prop), (forall (H:a < b), P (glue (OpenUnitDualDiv b a H) (SplitR s1 (OpenUnitDiv a b H)) s2)) -> (forall (H:b < a), P (SplitR s2 (OpenUnitDualDiv a b H))) -> (a == b -> P (s2)) -> P (SplitR (glue b s1 s2) a). Proof. intros. apply (SplitLR_glue_ind s1 s2 a b (fun a b => P b)); assumption. Qed. Lemma SplitGlue : forall x y:StepF, forall o, (Split (glue o x y) o)=(x, y). Proof. intros. simpl. destruct (Q_dec o o) as [[H1|H1]|H1]; try (elim (Qlt_not_le _ _ H1); auto with * ); simpl; auto with *. Qed. Lemma SplitLGlue : forall x y:StepF, forall o, (SplitL (glue o x y) o)=x. Proof. unfold SplitL. intros. rewrite SplitGlue. reflexivity. Qed. Lemma SplitRGlue : forall x y:StepF, forall o, (SplitR (glue o x y) o)=y. Proof. unfold SplitR. intros. rewrite SplitGlue. reflexivity. Qed. (** As stepping point to a proper setoid equality on step functions, [StepF_Qeq] specifies equality of step function upto [Qeq] on rational glue points *) Fixpoint StepF_Qeq (s1 s2: StepF) : Prop := match s1, s2 with |constStepF x, constStepF y => x = y |glue a x1 x2, glue b y1 y2 => a == b /\ (StepF_Qeq x1 y1) /\ (StepF_Qeq x2 y2) |_, _ => False end. Lemma StepF_Qeq_refl : forall (s: StepF), StepF_Qeq s s. Proof. induction s; simpl; auto with *. Qed. Lemma StepF_Qeq_sym : forall (s t: StepF), StepF_Qeq s t -> StepF_Qeq t s. Proof. induction s; induction t; try contradiction; simpl; auto with *. intros [H0 [H1 H2]]. repeat split; eauto with *. Qed. Lemma StepF_Qeq_trans : forall (s t u: StepF), StepF_Qeq s t -> StepF_Qeq t u -> StepF_Qeq s u. Proof. induction s; induction t; induction u; try contradiction; simpl; auto with *. intros; transitivity x0; assumption. intros [H0 [H1 H2]] [H3 [H4 H5]]. repeat split; [rewrite H0 | |]; eauto. Qed. (* begin hide *) Hint Resolve StepF_Qeq_refl StepF_Qeq_sym StepF_Qeq_trans. (* end hide *) (** [Mirror] behaves well with respect to this equality *) Lemma Mirror_resp_Qeq : forall (s t:StepF), StepF_Qeq s t -> StepF_Qeq (Mirror s) (Mirror t). Proof. induction s; induction t; intros Hst; simpl in *; try assumption; try contradiction. destruct Hst as [Ho [Hst1 Hst2]]. repeat split. rewrite -> Ho; reflexivity. apply IHs2; assumption. apply IHs1; assumption. Qed. (* begin hide *) Hint Resolve Mirror_resp_Qeq. (* end hide *) Lemma MirrorMirror : forall (s:StepF), (StepF_Qeq (Mirror (Mirror s)) s). Proof. induction s. simpl; reflexivity. repeat split; auto with *. simpl; ring. Qed. (* begin hide *) Hint Resolve MirrorMirror. (* end hide *) (** Splits interacts with Mirror in the way you expect *) Lemma SplitR_resp_Qeq : forall (s t:StepF) (a b:OpenUnit), a == b -> StepF_Qeq s t -> StepF_Qeq (SplitR s a) (SplitR t b). Proof. induction s; induction t; intros a b Hab Hst; simpl in *; try assumption; try contradiction. destruct Hst as [Ho [Hst1 Hst2]]. apply SplitR_glue_ind; intros Hao; apply SplitR_glue_ind; intros Hbo; repeat split; auto with *; try solve [elim (Qlt_not_le _ _ Hao); rewrite -> Hab; rewrite -> Ho; try rewrite -> Hbo; auto with * |elim (Qlt_not_le _ _ Hbo); rewrite <- Hab; rewrite <- Ho; try rewrite -> Hao; auto with *]; try apply IHs1; try apply IHs2; auto with *; simpl; try (rewrite -> Hab; rewrite -> Ho; reflexivity). Qed. (* begin hide *) Hint Resolve SplitR_resp_Qeq. (* end hide *) Lemma MirrorSplitL_Qeq : forall (s:StepF) (a b:OpenUnit), b == (OpenUnitDual a) -> (StepF_Qeq (Mirror (SplitL s a)) (SplitR (Mirror s) b)). Proof. induction s. auto with *. intros a b Hab; simpl in Hab. simpl. apply SplitL_glue_ind; intros Hao; apply: SplitR_glue_ind; intros Hoa; simpl in Hoa; try (repeat split; auto with *; try apply IHs1; try apply IHs2; simpl; rewrite -> Hab; field; auto with * ). elim (Qlt_not_le _ _ Hao). rewrite -> Qlt_minus_iff in Hoa. rewrite -> Qle_minus_iff. replace RHS with (1 - o + - (1 - a)). rewrite <- Hab. auto with *. now simpl; ring. elim (Qlt_not_le _ _ Hao). rewrite -> Qle_minus_iff. replace RHS with (1 - o + - (1 - a)). rewrite <- Hab. rewrite <- Hoa. ring_simplify. auto with *. now simpl; ring. intros H; ring_simplify in H. revert H; change (~(a==0)); auto with *. elim (Qlt_not_le _ _ Hao). rewrite -> Qle_minus_iff. rewrite -> Qlt_minus_iff in Hoa. replace RHS with (1 - a + - (1 - o)). rewrite <- Hab. auto with *. now simpl; ring. elim (Qlt_not_le _ _ Hao). rewrite -> Qle_minus_iff. replace RHS with (1 - a + - (1 - o)). rewrite <- Hab. rewrite <- Hoa. ring_simplify. auto with *. now simpl; ring. elim (Qlt_not_le _ _ Hoa). rewrite -> Hab. rewrite -> Hao. auto with *. elim (Qlt_not_le _ _ Hoa). rewrite -> Hab. rewrite -> Hao. auto with *. Qed. Lemma MirrorSplitR_Qeq: forall (s:StepF) (a b:OpenUnit), b == (OpenUnitDual a) -> (StepF_Qeq (Mirror (SplitR s a)) (SplitL (Mirror s) b)). Proof. intros s a b H. apply StepF_Qeq_trans with (Mirror (SplitR (Mirror (Mirror s)) a)); auto with *. apply StepF_Qeq_trans with (Mirror (Mirror (SplitL (Mirror s) b))); auto with *. apply Mirror_resp_Qeq. apply StepF_Qeq_sym. apply MirrorSplitL_Qeq. simpl in *. rewrite -> H. ring. Qed. Lemma SplitL_resp_Qeq : forall (s t:StepF) (a b:OpenUnit), a == b -> StepF_Qeq s t -> StepF_Qeq (SplitL s a) (SplitL t b). Proof. intros s t a b H H0. apply StepF_Qeq_trans with (Mirror (Mirror (SplitL s a))); auto with *. apply StepF_Qeq_trans with (Mirror (SplitR (Mirror s) (OpenUnitDual a))). apply Mirror_resp_Qeq. apply MirrorSplitL_Qeq; auto with *. apply StepF_Qeq_trans with (Mirror (SplitR (Mirror t) (OpenUnitDual b))). apply Mirror_resp_Qeq. apply SplitR_resp_Qeq; auto with *. simpl; rewrite -> H; reflexivity. apply StepF_Qeq_trans with (Mirror (Mirror (SplitL t b))); auto with *. apply Mirror_resp_Qeq. apply StepF_Qeq_sym. apply MirrorSplitL_Qeq; auto with *. Qed. (* begin hide *) Hint Resolve SplitL_resp_Qeq. (* end hide *) (** The following three lemmas are the key lemmas about Splits. They characterise how Splits distribute across each other. *) Lemma SplitLSplitL : forall (s:StepF) (a b c:OpenUnit), (a*b==c) -> (StepF_Qeq (SplitL (SplitL s a) b) (SplitL s c)). Proof. induction s. intros a b c _. apply StepF_Qeq_refl. intros a b c H. apply SplitL_glue_ind; intros Hao. apply SplitL_glue_ind; intros Hco. apply IHs1. simpl. rewrite <- H; field. auto with *. elim (Qlt_not_le a c). apply Qlt_trans with o; assumption. rewrite <- H. replace RHS with (1*a). replace LHS with (b*a). apply Qmult_le_compat_r; auto with *. now simpl; ring. now simpl; ring. elim (Qlt_not_le a c). rewrite -> Hco. apply Qlt_le_trans with o; auto with *. rewrite <- H. replace RHS with (1*a). replace LHS with (b*a). apply Qmult_le_compat_r; auto with *. now simpl; ring. now simpl; ring. apply SplitL_glue_ind; intros Hbd. apply SplitL_glue_ind; intros Hco. apply SplitL_resp_Qeq; auto with *. simpl. rewrite <- H. field; auto with *. elim (Qlt_not_le _ _ Hbd). simpl. apply Qle_shift_div_r; auto with *. rewrite -> Qmult_comm; rewrite -> H; auto with *. elim (Qlt_not_le _ _ Hbd). simpl. apply Qle_shift_div_r; auto with *. rewrite -> Qmult_comm; rewrite -> H; rewrite -> Hco; auto with *. apply SplitL_glue_ind; intros Hco. elim (Qlt_not_le _ _ Hbd). simpl. apply Qle_shift_div_l; auto with *. rewrite -> Qmult_comm; rewrite -> H; auto with *. repeat split; auto with *. simpl. rewrite <- H. field; auto with *. apply IHs2. simpl. rewrite <- H. field; repeat split; auto with *. clear - Hao; rewrite -> Qlt_minus_iff in Hao. auto with *. elim (Qlt_not_le _ _ Hbd). simpl. apply Qle_shift_div_l; auto with *. rewrite -> Qmult_comm; rewrite -> H; auto with *. assert (Y:o==c). rewrite <- H. rewrite -> Hbd. simpl. field. auto with *. apply SplitL_glue_ind; intros Hco; try (elim (Qlt_not_le _ _ Hco); rewrite -> Y; auto with * ). auto with *. apply SplitL_glue_ind; intros Hco. apply SplitL_resp_Qeq; auto with *. simpl. rewrite <- H. rewrite -> Hao. field; auto with *. elim (Qlt_not_le _ _ Hco). rewrite <- H. rewrite <- Hao. replace RHS with (1*a). replace LHS with (b*a). apply Qmult_le_compat_r; auto with *. now simpl; ring. now simpl; ring. elim (Qlt_not_le b 1). auto with *. rewrite <- Hao in Hco. rewrite -> Hco in H. apply Qmult_lt_0_le_reg_r with a. auto with *. ring_simplify. rewrite -> H. auto with *. Qed. Lemma SplitRSplitR : forall (s:StepF) (a b c:OpenUnit), (a+b-a*b==c) -> (StepF_Qeq (SplitR (SplitR s a) b) (SplitR s c)). Proof. intros s a b c H. apply StepF_Qeq_trans with (Mirror (Mirror (SplitR (SplitR s a) b))); auto with *. apply StepF_Qeq_trans with (Mirror (Mirror (SplitR s c))); auto with *. apply Mirror_resp_Qeq. apply StepF_Qeq_trans with (SplitL (SplitL (Mirror s) (OpenUnitDual a)) (OpenUnitDual b)). apply StepF_Qeq_trans with (SplitL (Mirror (SplitR s a)) (OpenUnitDual b)). apply MirrorSplitR_Qeq; auto with *. apply SplitL_resp_Qeq; auto with *. apply MirrorSplitR_Qeq; auto with *. apply StepF_Qeq_trans with (SplitL (Mirror s) (OpenUnitDual c)). apply SplitLSplitL. simpl. rewrite <- H. ring. apply StepF_Qeq_sym. apply MirrorSplitR_Qeq; auto with *. Qed. Lemma SplitLSplitR : forall (s:StepF) (a b c d:OpenUnit), (a+b-a*b==c) -> (d*c==a) -> (StepF_Qeq (SplitL (SplitR s a) b) (SplitR (SplitL s c) d)). Proof. induction s. intros a b c d _ _. apply StepF_Qeq_refl. intros a b c d H0 H1. apply SplitR_glue_ind; intros Hao. assert (Hao':~ o - a == 0). intros H. elim (Qlt_not_le _ _ Hao). rewrite -> Qle_minus_iff. replace RHS with (- (o- a)). rewrite -> H. auto with *. now simpl; ring. apply SplitL_glue_ind; intros Hbz; simpl in Hbz. apply SplitL_glue_ind; intros Hco. apply IHs1; simpl; [rewrite <- H0|rewrite <- H1]; field; auto with *. elim (Qlt_not_le _ _ Hbz). rewrite -> Qlt_minus_iff in Hco. rewrite -> Qle_minus_iff. replace RHS with ((a + b - a*b + -o)/(1 -a)). rewrite -> H0. apply Qle_shift_div_l; auto with *. replace LHS with 0. auto with *. now simpl; ring. now (simpl; field; auto with * ). elim (Qlt_not_le _ _ Hbz). rewrite -> Qle_minus_iff. replace RHS with ((a + b - a*b + -o)/(1 -a)). rewrite -> H0. rewrite -> Hco. replace RHS with 0. auto with *. now (simpl; field; auto with * ). now (simpl; field; auto with * ). apply SplitL_glue_ind; intros Hco. elim (Qlt_not_le _ _ Hbz). rewrite -> Qlt_minus_iff in Hco. rewrite -> Qle_minus_iff. replace RHS with ((o + -(a + b - a*b))/(1 -a)). rewrite -> H0. apply Qle_shift_div_l; auto with *. replace LHS with 0. auto with *. now simpl; ring. simpl; field. now auto with *. apply SplitR_glue_ind; intros Hdz; simpl in Hdz. repeat split; simpl. field_simplify; auto with *. apply Qmult_comp. rewrite <- H1; ring. apply Qinv_comp. replace LHS with (a + b - a*b - a). rewrite -> H0. replace RHS with (c - (d*c)). rewrite -> H1. reflexivity. now simpl; ring. now simpl; ring. apply SplitR_resp_Qeq; auto with *; simpl. rewrite <- H1; field; auto with *. apply SplitL_resp_Qeq; auto with *; simpl. rewrite <- H0; field; auto with *. elim (Qlt_not_le _ _ Hdz). apply Qle_shift_div_l; auto with *. rewrite -> H1; auto with *. elim (Qlt_not_le _ _ Hao). rewrite <- H1. rewrite -> Hdz. replace RHS with (o:Q). auto with *. simpl. field. now auto with *. elim (Qlt_not_le _ _ Hbz). rewrite <- Hco. rewrite <- H0. replace RHS with (b:Q); [ | simpl; field]; auto with *. apply SplitL_glue_ind; intros Hco. elim (Qlt_not_le _ _ Hco). rewrite <- H0. rewrite -> Hbz. replace RHS with (o:Q); [ | simpl; field]; auto with *. elim (Qlt_not_le _ _ Hco). rewrite <- H0. rewrite -> Hbz. replace LHS with (o:Q); [ | simpl; field]; auto with *. apply SplitR_resp_Qeq; simpl; auto with *. rewrite <- H1. rewrite -> Hco. field; auto with *. apply SplitL_glue_ind; intros Hco. elim (Qlt_not_le _ _ Hco). rewrite <- H0. apply Qlt_le_weak. rewrite -> Qlt_minus_iff in *. replace RHS with (a + - o + b*(1-a)). assert (Z:0 < (1-a)) by auto with *. Qauto_pos. now simpl; ring. assert (Hco':~ c - o == 0). intros H. elim (Qlt_not_le _ _ Hco). rewrite -> Qle_minus_iff. replace RHS with (c-o). rewrite -> H. auto with *. replace LHS with (-(c-o)). rewrite -> H. simpl; ring. now simpl; ring. apply SplitR_glue_ind; intros Hdz; simpl in Hdz. elim (Qlt_not_le _ _ Hdz). apply Qle_shift_div_r; auto with *. rewrite -> H1; auto with *. apply IHs2; simpl; [rewrite <- H0|rewrite <- H1]; field; auto with *. elim (Qlt_not_le _ _ Hao). rewrite <- H1. rewrite -> Hdz. replace LHS with (o:Q); [ | simpl; field]; auto with *. elim (Qlt_not_le _ _ Hao). rewrite <- H1. rewrite <- Hco. rewrite -> Qle_minus_iff. replace RHS with (c * (1-d)). apply Qlt_le_weak. assert (Z:0 < (1-d)) by auto with *. Qauto_pos. now simpl; ring. apply SplitL_glue_ind; intros Hco. elim (Qlt_not_le _ _ Hco). rewrite <- Hao. rewrite <- H1. rewrite -> Qle_minus_iff. replace RHS with (c * (1-d)). apply Qlt_le_weak. assert (Z:0 < (1-d)) by auto with *. Qauto_pos. now simpl; ring. apply SplitR_glue_ind; intros Hdz; simpl in Hdz. elim (Qlt_not_le _ _ Hdz). apply Qle_shift_div_r; auto with *. rewrite <- Hao. rewrite -> H1; auto with *. elim (Qlt_not_le _ _ Hdz). apply Qle_shift_div_l; auto with *. rewrite <- Hao. rewrite -> H1; auto with *. apply SplitL_resp_Qeq; simpl; auto with *. rewrite <- H0. rewrite <- Hao. field; auto with *. elim (Qlt_not_le (d*c) a). rewrite -> Hao. rewrite -> Hco. rewrite -> Qlt_minus_iff. replace RHS with (o * (1-d)). assert (Z:0 < (1-d)) by auto with *. Qauto_pos. now simpl; ring. rewrite -> H1. auto with *. Qed. End StepFunction. (* begin hide *) Add Parametric Relation X : (StepF X) (@StepF_Qeq X) reflexivity proved by (@StepF_Qeq_refl X) symmetry proved by (@StepF_Qeq_sym X) transitivity proved by (@StepF_Qeq_trans X) as StepF_Qeq_Setoid. (* end hide *) (** Step functions are a functor *) Definition Map(X Y:Type):(X->Y)->(StepF X)->(StepF Y). Proof. revert X Y. fix Map 4. intros X Y f [x| a t1 t2]. exact (constStepF (f x)). exact (glue a (Map _ _ f t1) (Map _ _ f t2)). Defined. Notation "f ^@> x" := (Map f x) (at level 15, left associativity) : sfscope. Local Open Scope sfscope. (** Step functions are an applicative functor *) Fixpoint Ap (X Y:Type) (f:StepF (X->Y)) (a:StepF X) : StepF Y := match f with |constStepF f0 => f0 ^@> a |glue o f0 f1 => let (l,r):=Split a o in (glue o (Ap f0 l) (Ap f1 r)) end. Notation "f <@> x" := (Ap f x) (at level 15, left associativity) : sfscope. Definition Map2 (X Y Z:Type) (f:(X->Y->Z)) a b := f ^@> a <@> b. Add Parametric Morphism X Y f : (@Map X Y f) with signature (@StepF_Qeq X) ==> (@StepF_Qeq Y) as Map_resp_Qeq. Proof. induction x; induction y; try contradiction; intros Hs. simpl in *. rewrite Hs. reflexivity. destruct Hs as [Ho [Hl Hr]]. repeat split; auto with *. Qed. (** These lemmas show how ap distributes over glue *) Lemma ApGlue : forall X Y (fl fr:StepF (X -> Y)) o b, (glue o fl fr) <@> b = glue o (fl <@> (SplitL b o)) (fr <@> (SplitR b o)). Proof. intros. simpl. apply Split_ind. reflexivity. Qed. Lemma ApGlueGlue : forall X Y (fl fr:StepF (X -> Y)) o l r, (glue o fl fr) <@> (glue o l r) = glue o (fl <@> l) (fr <@> r). Proof. intros. rewrite ApGlue, SplitLGlue, SplitRGlue. reflexivity. Qed. (* begn hide *) Add Parametric Morphism X Y : (@Ap X Y) with signature (@StepF_Qeq (X->Y)) ==> (@StepF_Qeq X) ==> (@StepF_Qeq Y) as Ap_resp_Qeq. Proof. induction x; induction y; try contradiction; intros Hf s1 s2 Hs. simpl in *. rewrite Hf. apply Map_resp_Qeq. assumption. destruct Hf as [Ho [Hl Hr]]. do 2 rewrite ApGlue. repeat split; auto. apply IHx1; auto with *. apply SplitL_resp_Qeq; auto with *. apply IHx2; auto with *. apply SplitR_resp_Qeq; auto with *. Qed. (* end hide *) Section Ap. (* begin hide *) Hint Resolve StepF_Qeq_refl SplitL_resp_Qeq SplitR_resp_Qeq. (* end hide *) (** Splits commute with maps *) Lemma SplitMap (X Y:Type):forall x:(StepF X), forall a, forall f:X->Y, (Split (Map f x) a) = let (l,r) := Split x a in (Map f l,Map f r). Proof. intros s a f. revert a. induction s. simpl; auto. intros a. simpl. destruct (Q_dec a o) as [[H0|H0]|H0]. rewrite IHs1. destruct (Split s1 (OpenUnitDiv a o H0)). auto with *. rewrite IHs2. destruct (Split s2 (OpenUnitDualDiv a o H0)). auto with *. auto. Qed. Lemma SplitLMap (X Y:Type): forall x:(StepF X), forall a, forall f:X->Y, SplitL (Map f x) a = Map f (SplitL x a). Proof. intros. unfold SplitL. rewrite SplitMap. destruct (Split x a). simpl. auto. Qed. Lemma SplitRMap(X Y:Type): forall x:(StepF X), forall a, forall f:X->Y, SplitR (Map f x) a = Map f (SplitR x a). Proof. intros. unfold SplitR. rewrite SplitMap. destruct (Split x a). simpl. auto. Qed. (** These lemmas show how ap distributes over split and uses mirror properties to get the symetric cases *) Lemma SplitLAp_Qeq (X Y:Type) : forall (f: StepF (X -> Y)) s o, StepF_Qeq (SplitL (f <@> s) o) ((SplitL f o) <@> (SplitL s o)). Proof. induction f; intros. simpl. rewrite SplitLMap; auto with *. rewrite ApGlue. unfold SplitL at 1 3. simpl. destruct (Q_dec o0 o) as [[Ho|Ho]|Ho]. do 2 apply Split_ind. simpl. eapply StepF_Qeq_trans; try assumption. apply IHf1. apply Ap_resp_Qeq; auto with *. apply SplitLSplitL. simpl. field; auto with *. do 2 apply Split_ind. simpl. apply Split_ind. repeat split; auto with *. apply Ap_resp_Qeq; auto with *. apply StepF_Qeq_sym. apply SplitLSplitL. simpl. field; auto with *. eapply StepF_Qeq_trans; try assumption. apply IHf2. apply Ap_resp_Qeq; auto with *. apply SplitLSplitR; simpl; field; auto with *. simpl. apply Ap_resp_Qeq; auto with *. Qed. Lemma MirrorMap (X Y:Type) : forall (f: X -> Y) s, (Mirror (Map f s)) = (Map f (Mirror s)). Proof. intros f. induction s. reflexivity. change (Mirror (glue o (Map f s1) (Map f s2)) = glue (OpenUnitDual o) (Map f (Mirror s2)) (Map f (Mirror s1))). rewrite <- IHs1. rewrite <- IHs2. reflexivity. Qed. Lemma MirrorAp_Qeq (X Y: Type) : forall (f: StepF (X -> Y)) s, StepF_Qeq (Mirror (f <@> s)) ((Mirror f) <@> (Mirror s)). Proof. induction f; intros s. simpl. rewrite MirrorMap. auto with *. rewrite ApGlue. change (StepF_Qeq (glue (OpenUnitDual o) (Mirror (f2 <@> (SplitR s o))) (Mirror (f1 <@> (SplitL s o)))) ((glue (OpenUnitDual o) (Mirror f2) (Mirror f1)) <@> (Mirror s))). rewrite ApGlue. repeat split; auto with *. eapply StepF_Qeq_trans. apply IHf2. apply Ap_resp_Qeq; auto with *. apply MirrorSplitR_Qeq. reflexivity. eapply StepF_Qeq_trans. apply IHf1. apply Ap_resp_Qeq; auto with *. apply MirrorSplitL_Qeq. reflexivity. Qed. Lemma SplitRAp_Qeq (X Y:Type) : forall (f: StepF (X -> Y)) s o, StepF_Qeq (SplitR (f <@> s) o) ((SplitR f o) <@> (SplitR s o)). Proof. intros f s o. eapply StepF_Qeq_trans. apply StepF_Qeq_sym. apply MirrorMirror. eapply StepF_Qeq_trans;[|apply MirrorMirror]. apply Mirror_resp_Qeq. eapply StepF_Qeq_trans;[|apply StepF_Qeq_sym; apply MirrorAp_Qeq]. eapply StepF_Qeq_trans. apply MirrorSplitR_Qeq. reflexivity. eapply StepF_Qeq_trans. apply SplitL_resp_Qeq. reflexivity. apply MirrorAp_Qeq. eapply StepF_Qeq_trans. apply SplitLAp_Qeq. apply StepF_Qeq_sym. apply Ap_resp_Qeq; apply MirrorSplitR_Qeq; reflexivity. Qed. End Ap. Section ApplicativeFunctor. (** These are the laws of an applicative functor *) Lemma Ap_identity : forall X (a:StepF X), constStepF (fun x => x) <@> a = a. Proof. induction a. reflexivity. simpl in *. rewrite IHa1. rewrite IHa2. reflexivity. Qed. Lemma Map_identity : forall X (a:StepF X), (fun x => x) ^@> a = a. Proof. exact Ap_identity. Qed. (* begin hide *) Hint Resolve Ap_resp_Qeq. Hint Resolve SplitLAp_Qeq SplitRAp_Qeq. Hint Resolve StepF_Qeq_refl StepF_Qeq_sym StepF_Qeq_trans SplitL_resp_Qeq SplitR_resp_Qeq. (* end hide *) Let compose X Y Z (x : Y ->Z) (y:X -> Y) z := x (y z). Lemma Ap_composition_Qeq : forall X Y Z (a:StepF (Y->Z)) (b:StepF (X->Y)) (c:StepF X), StepF_Qeq (constStepF (@compose X Y Z) <@> a <@> b <@> c) (a <@> (b <@> c)). Proof. induction a. simpl. induction b. simpl. induction c. auto. repeat split; auto. intros c. simpl in *. destruct (Split c o). repeat split; auto. intros b c. simpl in *. do 2 apply Split_ind. simpl. apply Split_ind. repeat split; eauto. Qed. Lemma Map_composition_Qeq : forall X Y Z (a:StepF (Y->Z)) (b:StepF (X->Y)) (c:StepF X), StepF_Qeq ((fun x y z => x (y z)) ^@> a <@> b <@> c) (a <@> (b <@> c)). Proof. exact Ap_composition_Qeq. Qed. Lemma Ap_homomorphism : forall X Y (f:X->Y) (a:X), (constStepF f <@> constStepF a) = (constStepF (f a)). Proof. reflexivity. Qed. Lemma Map_homomorphism : forall X Y (f:X->Y) (a:X), (f ^@> constStepF a) = (constStepF (f a)). Proof. exact Ap_homomorphism. Qed. Lemma Ap_interchange : forall X Y (f:StepF (X->Y)) (a:X), (f <@> constStepF a) = (constStepF (fun g => g a)) <@> f. Proof. induction f. reflexivity. intros a. simpl. rewrite IHf1. rewrite IHf2. reflexivity. Qed. Lemma Map_interchange : forall X Y (f:StepF (X->Y)) (a:X), (f <@> constStepF a) = (fun g => g a) ^@> f. Proof. exact Ap_interchange. Qed. Lemma Map_compose_Map : forall X Y Z (f:Y->Z) (g:X -> Y) a, ((fun a => f (g a)) ^@> a) = (f ^@> (g ^@> a)). Proof. induction a; simpl; congruence. Qed. End ApplicativeFunctor. corn-8.20.0/metric2/StepFunctionMonad.v000066400000000000000000000304071473720167500177160ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Bas Spitters Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Export CoRN.metric2.StepFunctionSetoid. Require Import CoRN.model.structures.OpenUnit. Require Import CoRN.tactics.CornTac. Require Import CoRN.logic.CornBasics. (** ** Monad Here we define bind and join for the step function monad, and prove that they satify the monad laws. *) Set Implicit Arguments. (** This version of [StepF] has type [Setoid] that carries its equivalence relation with it. *) Definition StepFS (X : RSetoid) : RSetoid. Proof. exists (StepF X) (@StepF_eq X). apply StepF_Sth. Defined. Local Open Scope setoid_scope. Local Open Scope sfstscope. (** We redefine several functions to return a setoid type. *) Definition StFReturn (X : RSetoid) : X-->(StepFS X). Proof. intros. exists (@constStepF X). abstract (auto with *). Defined. Definition SplitLS0(X : RSetoid):OpenUnit->(StepFS X)->(StepFS X):= (fun o x => SplitL x o). Definition SplitLS(X : RSetoid):OpenUnit->(StepFS X)-->(StepFS X). Proof. intros o. exists (fun x => (SplitLS0 o x)). abstract (intros; apply: SplitL_wd;auto with *). Defined. Definition SplitRS0(X : RSetoid):OpenUnit->(StepFS X)->(StepFS X):= (fun o x => SplitR x o). Definition SplitRS(X : RSetoid):OpenUnit->(StepFS X)-->(StepFS X). Proof. intros o. exists (fun x => (SplitRS0 o x)). abstract (intros; apply: SplitR_wd;auto with *). Defined. Definition MirrorS(X : RSetoid):(StepFS X)-->(StepFS X). Proof. exists (@Mirror X). abstract (intros; change (Mirror x1 == Mirror x2); rewrite -> Mirror_eq_Mirror; assumption). Defined. (** Definition of bind. *) Definition StFBind00(X Y : RSetoid) : (StepFS X) -> (X --> (StepFS Y)) -> (StepFS Y). Proof. fix StFBind00 1. intro m. case m. intros x f. exact (f x). intros o m1 m2 f. exact (glue o (StFBind00 m1 (compose (SplitLS Y o) f)) (StFBind00 m2 (compose (SplitRS Y o) f))). Defined. Lemma StFBind_wd1(X Y : RSetoid):forall m, forall x1 x2 : X --> StepFS Y, st_eq x1 x2 -> st_eq (StFBind00 m x1) (StFBind00 m x2). Proof. induction m. intros x1 x2 H. simpl; auto with *. apply H. intros x1 x2 H. simpl. apply glue_resp_StepF_eq. apply IHm1. intro. simpl. unfold compose0. apply SplitL_wd; auto with *. apply H. apply IHm2. intro. simpl. unfold compose0. apply SplitR_wd; auto with *. apply H. Qed. Definition StFBind1(X Y : RSetoid) : (StepFS X) -> (X --> (StepFS Y)) --> (StepFS Y). Proof. intros m. exists (fun f=> (@StFBind00 X Y m f)). apply StFBind_wd1. Defined. Lemma MirrorBind(X Y : RSetoid):forall (x:StepF X) (f:X --> (StepFS Y)), Mirror (StFBind00 x f)==(StFBind00 (Mirror x) (compose (MirrorS Y) f)). Proof. induction x. reflexivity. intros. simpl. rewrite MirrorGlue. apply glue_wd; auto with *. rewrite -> IHx2. simpl. change (StFBind00 (Mirror x2) (compose1 (MirrorS Y) (compose1 (SplitRS Y o) f)) == StFBind00 (Mirror x2) (compose1 (SplitLS Y (OpenUnitDual o)) (compose1 (MirrorS Y) f))). apply StFBind_wd1. intro. simpl. unfold compose0. unfold SplitRS0, SplitLS0. apply MirrorSplitR; auto with *. rewrite -> IHx1. simpl. change (StFBind00 (Mirror x1) (compose1 (MirrorS Y) (compose1 (SplitLS Y o) f)) == StFBind00 (Mirror x1) (compose1 (SplitRS Y (OpenUnitDual o)) (compose1 (MirrorS Y) f))). apply StFBind_wd1. intro. simpl. unfold compose0. unfold SplitRS0, SplitLS0. apply MirrorSplitL; auto with *. Qed. Lemma SplitLBind (X Y : RSetoid) : forall (y:(StepF X)) (o:OpenUnit) (f: (X-->(StepFS Y))), SplitL (StFBind00 y f) o == StFBind00 (SplitL y o) (compose1 (SplitLS Y o) f). Proof. induction y. reflexivity. intros p f. simpl. apply SplitL_glue_ind; apply SplitL_glue_ind; intros H H0; try solve [ elim (Qlt_not_le o p); auto with * | elim (Qlt_not_le _ _ H0) || elim (Qlt_not_le _ _ H); rewrite -> H || rewrite -> H0; auto with *]. setoid_replace (OpenUnitDiv p o H0) with (OpenUnitDiv p o H) by (unfold ou_eq; reflexivity). rewrite -> IHy1. apply StFBind_wd1. intros x. simpl. unfold compose0. apply StepF_Qeq_eq. apply (SplitLSplitL (f x) o (OpenUnitDiv p o H) p). simpl. simpl. field. auto with *. (* o IHy2. apply StFBind_wd1. intro. simpl. unfold compose0, SplitLS0, SplitRS0. apply StepF_Qeq_eq. apply ((SplitLSplitR (f x) o) (OpenUnitDualDiv p o H)); simpl; field; auto with *. (* p==o *) apply StFBind_wd1. intro. simpl. unfold compose0, SplitLS0, SplitRS0. apply SplitL_wd. auto with *. symmetry; auto with *. Qed. Lemma SplitRBind (X Y : RSetoid) : forall (y:(StepF X)) (o:OpenUnit) (f: (X-->(StepFS Y))), SplitR (StFBind00 y f) o == StFBind00 (SplitR y o) (compose1 (SplitRS Y o) f). Proof. induction y. reflexivity. intros p f. simpl. apply SplitR_glue_ind; apply SplitR_glue_ind; intros H H0; try solve [ elim (Qlt_not_le o p); auto with * | elim (Qlt_not_le _ _ H0) || elim (Qlt_not_le _ _ H); rewrite -> H || rewrite -> H0; auto with *]. simpl. apply glue_wd. unfold ou_eq; reflexivity. setoid_replace (OpenUnitDiv _ _ H0) with (OpenUnitDiv _ _ H) by (unfold ou_eq; reflexivity). rewrite -> IHy1. apply StFBind_wd1. intro. simpl. unfold compose0, SplitLS0, SplitRS0. symmetry. apply StepF_Qeq_eq. apply ((SplitLSplitR (f x) p) (OpenUnitDualDiv _ _ H)); simpl; field; auto with *. apply StFBind_wd1. intro x. simpl. unfold compose0, SplitLS0. symmetry. apply: (@StepF_Qeq_eq). apply (SplitRSplitR (f x)). simpl. field. auto with *. (* o IHy2. apply StFBind_wd1. intros x. simpl. unfold compose0. apply StepF_Qeq_eq. apply (SplitRSplitR (f x) o (OpenUnitDualDiv _ _ H) p). simpl. field. auto with *. (* p==o *) apply StFBind_wd1. intro. simpl. unfold compose0, SplitLS0, SplitRS0. apply SplitR_wd;auto with *. symmetry. auto with *. Qed. Lemma StFBind_wd(X Y : RSetoid): forall x1 x2 : StepFS X, st_eq x1 x2 -> st_eq (StFBind1 Y x1) (StFBind1 Y x2). Proof. induction x1. intro y. induction y. simpl. intro H. intro f. apply f. exact H. simpl. intro H. destruct H as [Hl Hr] using (eq_glue_ind y1). intro f. rewrite <- (IHy1 Hl (compose1 (SplitLS Y o) f)). simpl. unfold compose0. clear IHy1. rewrite <- (IHy2 Hr (compose1 (SplitRS Y o) f)). simpl. unfold compose0. unfold SplitLS0, SplitRS0. symmetry. apply: @glueSplit. intros y H f. simpl in H. destruct H as [Hl Hr] using (glue_eq_ind x1_1). simpl. rewrite -> (IHx1_1 _ Hl (compose1 (SplitLS Y o) f)). rewrite -> (IHx1_2 _ Hr (compose1 (SplitRS Y o) f)). clear IHx1_1 IHx1_2. change ((StFBind1 _ (glue o (SplitL y o) (SplitR y o)) f) == StFBind00 y f). clear Hl Hr x1_1 x1_2. simpl. rewrite <- (glueSplit (StFBind00 y f) o). rewrite -> SplitLBind. rewrite -> SplitRBind. reflexivity. Qed. Definition StFBind(X Y : RSetoid) : (StepFS X) --> (X --> (StepFS Y)) --> (StepFS Y). Proof. exists (fun m => (@StFBind1 X Y m)). exact (@StFBind_wd X Y). Defined. Add Parametric Morphism X Y : (@StFBind00 X Y) with signature (@StepF_eq X ==> (@st_eq _) ==> @StepF_eq Y) as StFBind00_wd. Proof. intros x y Hxy f g Hfg. transitivity (StFBind00 x g). apply StFBind_wd1; assumption. apply: StFBind_wd; assumption. Qed. (** Join is defined in terms of bind. *) Definition StFJoin (X : RSetoid):(StepFS (StepFS X))-->(StepFS X):= (flip (@StFBind (StepFS X) X) (@id (StepFS X))). Lemma JoinGlue(X : RSetoid): forall o a b, (StFJoin X (glue o a b))==(glue o (StFBind (StepFS X) _ a (SplitLS X o)) (StFBind (StepFS X) _ b (SplitRS X o))). Proof. intros. simpl. transitivity (glue o (StFBind00 (SplitL (glue o a b) o) (compose1 (SplitLS X o) id)) (StFBind00 (SplitR (glue o a b) o) (compose1 (SplitRS X o) id))). apply glue_wd; auto with *. apply StFBind00_wd; try reflexivity. rewrite SplitLGlue. reflexivity. apply StFBind00_wd; try reflexivity. rewrite SplitRGlue. reflexivity. apply glue_wd; auto with *. rewrite <- SplitLBind. simpl. rewrite SplitLGlue. apply StFBind_wd1. intro x. reflexivity. rewrite <- SplitRBind. simpl. rewrite SplitRGlue. apply StFBind_wd1. intro x. reflexivity. Qed. Section Monad_Laws. (** Here we prove the monad laws. *) Variable X Y : RSetoid. Lemma ReturnBind(x:X)(f:X-->StepFS Y): (StFBind X Y (StFReturn X x) f)==(f x). Proof. simpl; auto with *. Qed. Let Bind_compose(Z : RSetoid)(f:X-->StepFS Y)(g:Y-->StepFS Z):= (compose ((flip (StFBind Y Z)) g) f). Lemma BindBind(Z : RSetoid)(m:StepF X)(f:X-->StepFS Y)(g:Y-->StepFS Z): (StFBind Y Z (StFBind X Y m f) g) == (StFBind X Z m (Bind_compose f g)). Proof. revert f g. induction m. simpl. unfold compose0. simpl; auto with *. simpl. intros. apply glue_resp_StepF_eq. clear IHm2 m2. simpl in IHm1. rewrite -> (IHm1 (compose1 (SplitLS Y o) f) (compose1 (SplitLS Z o) g)). clear IHm1. apply StFBind_wd1. intro. simpl. unfold compose0. symmetry. apply: SplitLBind. clear IHm1 m1. simpl in IHm2. rewrite -> (IHm2 (compose1 (SplitRS Y o) f) (compose1 (SplitRS Z o) g)). clear IHm2. apply StFBind_wd1. intro. simpl. unfold compose0. symmetry. apply: SplitRBind. Qed. Lemma BindReturn(m:StepF X): (StFBind X X m (StFReturn X)) == m. Proof. unfold StFBind. induction m. simpl. auto with *. simpl. unfold StFBind00. simpl. apply glue_resp_StepF_eq. clear IHm2 m2. simpl in IHm1. assert (extEq (StepFS X) (StFReturn X) (compose1 (SplitLS X o) (StFReturn X))). intro. simpl. auto with *. pose (s:=Morphism_prf (StFBind1 X m1) (StFReturn X) (compose1 (SplitLS X o) (StFReturn X)) H). rewrite -> s in IHm1. clear s H. assumption. clear IHm1 m1. simpl in IHm2. assert (extEq (StepFS X) (StFReturn X) (compose1 (SplitRS X o) (StFReturn X))). intro; simpl; auto with *. pose (s:=Morphism_prf (StFBind1 X m2) (StFReturn X) (compose1 (SplitRS X o) (StFReturn X)) H). rewrite -> s in IHm2. clear s H. assumption. Qed. End Monad_Laws. (* (\f x -> f >>= (\g -> x >>= \a -> return (g a))) f: S (X -->Y) x: S X a: X g: X--> Y \a -> return (g a) :X --> S Y = (compose return g) x >>= \a -> return (g a) : SY x >>= : (X --> S Y) --> SY = (bind x) \g -> ,... : (X-->Y) -> SY (StFBinf x (compose return g)) :SY (compose return) : (X-->Y)-->(X-->SY) (compose (StFBinf x) (compose return)) :(X-->Y)-->SY *) (** Lastly, we prove that the applicative functor is the canonical one for this monad. *) Lemma ApBind(X Y : RSetoid): forall (x:(StepFS X)) (f:StepFS (X-->Y)) , (f<@>x== (@StFBind _ _ f (compose (StFBind _ _ x) (compose (StFReturn _))))). Proof. apply: StepF_ind2. intros s s0 t t0 Hs Ht H. rewrite <- Hs, <- Ht at 1. rewrite -> H. unfold StFBind. simpl. transitivity (StFBind00 t0 (compose1 (StFBind1 Y s) (compose2 X (StFReturn Y)))). apply: StFBind_wd; auto. apply StFBind_wd1. intros a. apply: StFBind_wd; auto. reflexivity. intros o s s0 t t0 IHf1 IHf2. rewrite ApGlueGlue. rewrite -> IHf1, IHf2. simpl. apply glue_wd; try reflexivity; apply StFBind_wd1; intro x; unfold StFBind1, compose1, compose0; simpl. unfold SplitLS0. rewrite SplitLGlue. apply StFBind_wd1. intro y. reflexivity. unfold SplitRS0. rewrite SplitRGlue. apply StFBind_wd1. intro y. reflexivity. Qed. corn-8.20.0/metric2/StepFunctionSetoid.v000066400000000000000000000631441473720167500201130ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.algebra.RSetoid. Require Export CoRN.metric2.StepFunction. Require Import CoRN.model.structures.OpenUnit. Require Import CoRN.tactics.CornTac. Require Import CoRN.tactics.Qauto. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.algebra.COrdFields. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. (** ** Step Functions over setoids In this section we redevelop step functions over a setoid X. The applicative functor StepF lifts equivalence relations (setoids). When type X has an equivalence relation eqX, then StepF X inherits an equivalence relation StepF_eq, by checking that the leaf values in X are equivalent for each rational argument. Moreover, a morphism f : X --> Y lifts to a morphism map StepF f : StepF X --> StepF Y. In other words, StepF is an endofunctor of the category of setoids. *) Local Open Scope setoid_scope. (** We lift ap to the setoid version. Map is a notation calling ap so that all lemmas about ap automatically apply to Map. *) Definition Ap (X Y : RSetoid) : (StepF (X --> Y))->(StepF X)->(StepF Y) := fun f x => (@Ap X Y (StepFunction.Map (@evalMorphism X Y) f) x). Notation "f <@> x" := (Ap f x) (at level 15, left associativity) : sfstscope. Notation "f ^@> x" := (Ap (constStepF f) x) (at level 15, left associativity) : sfstscope. Notation "f <@^ x" := (Ap f (constStepF x)) (at level 15, left associativity) : sfstscope. Local Open Scope sfstscope. (** We lift lemmas about map, ap, mirror, and glue *) Lemma MirrorGlue : forall (X : RSetoid) (o : OpenUnit) (al ar : StepF X), Mirror (glue o al ar) = glue (OpenUnitDual o) (Mirror ar) (Mirror al). Proof. reflexivity. Qed. Lemma MapGlue : forall (X Y : RSetoid) (f : (X --> Y)) (o : OpenUnit) (al ar : StepF X), f ^@> (glue o al ar) = glue o (f ^@> al) (f ^@> ar). Proof. reflexivity. Qed. Lemma ApGlue : forall (X Y : RSetoid) (fl fr : StepF (X --> Y)) (o : OpenUnit) (b : StepF X), (glue o fl fr) <@> b = glue o (fl <@> (SplitL b o)) (fr <@> (SplitR b o)). Proof. intros X Y fl fr o b. unfold Ap. simpl (StepFunction.Map (@evalMorphism X Y) (glue o fl fr)). rewrite ApGlue. reflexivity. Qed. Lemma ApGlueGlue : forall (X Y : RSetoid) (fl fr : StepF (X --> Y)) (o : OpenUnit) (l r : StepF X), (glue o fl fr) <@> (glue o l r) = glue o (fl <@> l) (fr <@> r). Proof. intros X Y fl fr o l r. unfold Ap. simpl (StepFunction.Map (@evalMorphism X Y) (glue o fl fr)). rewrite ApGlueGlue. reflexivity. Qed. Lemma SplitLMap : forall (X Y : RSetoid) (x : StepF X) (a : OpenUnit) (f : X --> Y), SplitL (f ^@> x) a = f ^@> (SplitL x a). Proof. intros X Y x a f. unfold Ap. simpl. rewrite SplitLMap. reflexivity. Qed. Lemma SplitRMap : forall (X Y : RSetoid) (x : StepF X) (a : OpenUnit) (f : X --> Y), SplitR (f ^@> x) a = f ^@> (SplitR x a). Proof. intros X Y x a f. unfold Ap. simpl. rewrite SplitRMap. reflexivity. Qed. Section EquivalenceA. (** A step function over [Prop], a characteristic function, can be folded into [Prop], which holds for the always true characteristic function *) Definition StepFfoldProp : StepF iffSetoid -> Prop := (StepFfold (X:=iffSetoid) (fun x => x ) (fun _ a b => a /\ b )). Definition st_eqS0 {X : RSetoid} : X -> X --> iffSetoid. Proof. intros x. exists (st_eq x). abstract ( intros x1 x2 Hx; simpl; rewrite -> Hx; reflexivity). Defined. Definition st_eqS {X : RSetoid} : X --> X --> iffSetoid. Proof. exists (st_eqS0). abstract ( intros x1 x2 Hx y; simpl; rewrite -> Hx; reflexivity). Defined. (** ** Equivalence An equivalence relation on step functions is implemented by lifiting the equivalence relation on the underlying setoid to step functions. The results is a characteristic function saying where two step functions are equivalent. The step functions are considered equivalent if this characteristic function says they are equivalent everywhere. *) Definition StepF_eq {X : RSetoid} (f g:StepF X):Prop:= (StepFfoldProp (st_eqS ^@> f <@> g)). Notation "x === y" := (StepF_eq x y) (at level 70). (** With equality defined we can complete the proof that split is the opposite of glue *) Lemma glue_StepF_eq : forall {X : RSetoid} (s:StepF X) (s1 s2:StepF X), forall a, s1 === (SplitL s a) -> s2 === (SplitR s a) -> (glue a s1 s2) === s. Proof. intros X s s1 s2 a H0 H1. unfold StepF_eq. rewrite MapGlue. rewrite ApGlue. split; assumption. Qed. Lemma glue_eq_ind : forall {X : RSetoid} (s1 s2 s:StepF X) a (P:Prop), (s1 === SplitL s a -> s2 === SplitR s a -> P) -> (glue a s1 s2 === s) -> P. Proof. intros X s1 s2 s a P H H0. unfold StepF_eq in *. rewrite -> MapGlue in *. rewrite ApGlue in H0. destruct H0. auto. Qed. (** The equivalence relation is reflexive *) Lemma StepF_eq_refl : forall {X : RSetoid} (x : StepF X), x === x. Proof. intro X. induction x. change (st_eq x x). reflexivity. apply glue_StepF_eq. simpl; rewrite SplitLGlue; assumption. simpl; rewrite SplitRGlue; assumption. Qed. (* begin hide *) Hint Resolve StepF_eq_refl. (* end hide *) (** StepF_Qeq is a refinement of any setoid equality *) Lemma StepF_Qeq_eq : forall {X : RSetoid} (s t:StepF X), (StepF_Qeq s t) -> s === t. Proof. intro X. induction s; induction t; try contradiction; simpl. intros H. rewrite H. auto with *. intros [H [H0 H1]]. apply glue_StepF_eq. apply IHs1. apply SplitL_glue_ind; intros H2; try (elim (Qlt_not_le _ _ H2); rewrite -> H); auto with *. apply IHs2. apply SplitR_glue_ind; intros H2; try (elim (Qlt_not_le _ _ H2); rewrite -> H); auto with *. Qed. Lemma glueSplit : forall {X : RSetoid} (s : StepF X), forall a, (glue a (SplitL s a) (SplitR s a)) === s. Proof. intros X s a. apply glue_StepF_eq; auto with *. Qed. End EquivalenceA. (* begin hide *) #[global] Hint Resolve StepF_eq_refl : sfarith. (* end hide *) Notation "x == y" := (StepF_eq x y) (at level 70) : sfstscope. Section EquivalenceB. Variable X Y : RSetoid. Lemma Map_resp_StepF_eq: forall f:X-->Y, (forall x y, (st_eq x y)-> (st_eq (f x) (f y))) -> forall s t:(StepF X), s == t -> (f ^@> s) == (f ^@> t). Proof. intros f H. induction s. induction t. unfold StepF_eq, Map2, StepFfoldProp ;simpl;auto with *. unfold StepF_eq, Map2, StepFfoldProp. simpl; intuition. intros t H0. unfold StepF_eq, Map2 in H0. rewrite MapGlue in H0. rewrite ApGlue in H0. unfold StepF_eq, Map2. repeat rewrite MapGlue. rewrite ApGlue. rewrite SplitLMap. rewrite SplitRMap. destruct H0 as [H0l H0R]. split. apply IHs1; auto. apply IHs2; auto. Qed. End EquivalenceB. Lemma StepFfoldPropglue:forall (y:StepF iffSetoid) o, StepFfoldProp (glue o (SplitL y o) (SplitR y o)) <-> StepFfoldProp y. Proof. induction y. unfold StepF_eq, StepFfoldProp. simpl; tauto. simpl. intro o0. apply SplitLR_glue_ind; intros H. generalize (IHy1 (OpenUnitDiv o0 o H)). unfold StepFfoldProp; simpl; tauto. generalize (IHy2 (OpenUnitDualDiv o0 o H)). unfold StepFfoldProp; simpl; tauto. simpl. reflexivity. Qed. Lemma StepFfoldProp_morphism:forall x y:(StepF iffSetoid), (StepF_eq x y) -> ((StepFfoldProp x)<->(StepFfoldProp y)). Proof. induction x. induction y. auto with *. unfold StepF_eq. simpl. unfold StepFfoldProp;simpl;intuition. intros y H0. unfold StepF_eq, Map2 in H0. rewrite MapGlue in H0. rewrite ApGlue in H0. destruct H0 as [H0l H0r]. change ((StepFfoldProp x1 /\ StepFfoldProp x2) <-> StepFfoldProp y). rewrite -> (IHx1 (SplitL y o)); auto with *. rewrite -> (IHx2 (SplitR y o)); auto with *. apply: StepFfoldPropglue. Qed. Lemma StepFfoldPropSplitR : forall (s : StepF iffSetoid) (a : OpenUnit), StepFfoldProp s -> StepFfoldProp (SplitR s a). Proof. intros s a H. rewrite <- (StepFfoldPropglue s a) in H. destruct H; auto. Qed. Lemma StepFfoldPropSplitL : forall (s : StepF iffSetoid) (a : OpenUnit), StepFfoldProp s -> StepFfoldProp (SplitL s a). Proof. intros s a H. rewrite <- (StepFfoldPropglue s a) in H. destruct H; auto. Qed. Section EquivalenceC. Variable X : RSetoid. (* begin hide *) Hint Resolve StepF_Qeq_eq StepF_Qeq_refl SplitL_resp_Qeq SplitR_resp_Qeq. (* end hide *) Lemma StepF_eq_resp_Qeq : forall (s t : StepF X) u v, (StepF_Qeq s t) -> (StepF_Qeq u v) -> s == u -> t == v. Proof. induction s; induction t; try contradiction. intros u v Hst Huv Hsu. simpl in Hst. unfold StepF_eq in *. rewrite <- Hst. rewrite <- (StepFfoldProp_morphism ((st_eqS) ^@> constStepF x <@> u)); auto. apply: (Map_resp_StepF_eq); auto with *. intros a b Hab. simpl. rewrite -> Hab. reflexivity. intros u v [H [Hst0 Hst1]] Huv Hsu. destruct Hsu as [Hsu1 Hsu2] using (glue_eq_ind s1). apply glue_StepF_eq. eapply IHs1. assumption. unfold SplitL; apply SplitL_resp_Qeq. apply H. apply Huv. assumption. eapply IHs2. assumption. unfold SplitR; apply SplitR_resp_Qeq. apply H. apply Huv. assumption. Qed. Lemma Mirror_eq_Mirror : forall (s t : StepF X), Mirror s == Mirror t <-> s == t. Proof. induction s. induction t; simpl. reflexivity. change (constStepF x == (Mirror t2) /\ constStepF x == (Mirror t1) <-> constStepF x == t1 /\ constStepF x == t2). tauto. intros t. rewrite MirrorGlue. split; apply (@glue_eq_ind X); intros H0 H1. apply glue_StepF_eq. rewrite <- IHs1. eapply StepF_eq_resp_Qeq;[| |apply H1]; auto with *. apply StepF_Qeq_sym. apply MirrorSplitL_Qeq; auto with *. rewrite <- IHs2. eapply StepF_eq_resp_Qeq;[| |apply H0]; auto with *. apply StepF_Qeq_sym. apply MirrorSplitR_Qeq; auto with *. apply glue_StepF_eq. apply StepF_eq_resp_Qeq with (Mirror s2) (Mirror (SplitR t o)); auto. apply MirrorSplitR_Qeq; apply Qeq_refl. rewrite -> IHs2. assumption. apply StepF_eq_resp_Qeq with (Mirror s1) (Mirror (SplitL t o)); auto. apply MirrorSplitL_Qeq; apply Qeq_refl. rewrite -> IHs1. assumption. Qed. Lemma SplitL_resp_Xeq : forall (s1 s2 : StepF X) a, s1 == s2 -> SplitL s1 a == SplitL s2 a. Proof. induction s1. intros s2 a H. unfold StepF_eq in *. change (StepFfoldProp ((st_eqS x:X-->iffSetoid) ^@> SplitL s2 a)). rewrite <- SplitLMap. apply StepFfoldPropSplitL. assumption. intros s2 a H. destruct H using (glue_eq_ind s1_1). apply SplitL_glue_ind; intros Hao. apply StepF_eq_resp_Qeq with (SplitL s1_1 (OpenUnitDiv a o Hao)) (SplitL (SplitL s2 o) (OpenUnitDiv a o Hao)); auto. apply SplitLSplitL. simpl; field; auto with *. apply glue_StepF_eq. apply StepF_eq_resp_Qeq with s1_1 (SplitL s2 o); auto. apply StepF_Qeq_sym. apply SplitLSplitL. simpl; field; auto with *. apply StepF_eq_resp_Qeq with (SplitL s1_2 (OpenUnitDualDiv a o Hao)) (SplitL (SplitR s2 o) (OpenUnitDualDiv a o Hao)); auto. apply SplitLSplitR; simpl; field; auto with *. apply StepF_eq_resp_Qeq with s1_1 (SplitL s2 o); auto with *. Qed. Lemma SplitR_resp_Xeq : forall (s1 s2:StepF X) a, s1 == s2 -> SplitR s1 a == SplitR s2 a. Proof. intros s1 s2 a H. pose (b:=OpenUnitDual a). apply StepF_eq_resp_Qeq with (Mirror (SplitL (Mirror s1) b)) (Mirror (SplitL (Mirror s2) b)); try (unfold Mirror, SplitR, SplitL, b;eapply StepF_Qeq_trans;[apply Mirror_resp_Qeq; apply StepF_Qeq_sym; apply MirrorSplitR_Qeq; reflexivity|apply MirrorMirror]). rewrite -> Mirror_eq_Mirror. apply SplitL_resp_Xeq. rewrite -> Mirror_eq_Mirror. assumption. Qed. (** equalitiy is transitive *) Lemma StepF_eq_trans:forall x y z : StepF X, x == y -> y == z -> x == z. Proof. induction x. intros. unfold StepF_eq in *. set (A:=((st_eqS :X-->X-->iffSetoid) ^@> constStepF x)) in *. rewrite <- (StepFfoldProp_morphism (A <@> y)); auto with *. apply: (Map_resp_StepF_eq); auto with *. intros a b Hab. simpl. rewrite -> Hab. reflexivity. intros. destruct H using (glue_eq_ind x1). apply glue_StepF_eq. eapply IHx1. apply H. apply SplitL_resp_Xeq. assumption. eapply IHx2. apply H1. apply SplitR_resp_Xeq. assumption. Qed. Lemma glue_resp_StepF_eq:forall (x x' y y':StepF X) o, (x==x')->(y==y')-> (glue o x y)==(glue o x' y'). Proof. intros. unfold StepF_eq. rewrite MapGlue. rewrite ApGlueGlue. split; assumption. Qed. (** equality is symmetric *) Lemma StepF_eq_sym :forall x y: StepF X, x == y -> y == x. Proof. intros x y. revert x. induction y. unfold StepF_eq. simpl. intro x0. induction x0. unfold StepFfoldProp. simpl. intros. symmetry; assumption. simpl. unfold StepFfoldProp; simpl; intuition; auto with *. intros x H. assert (H0:=(SplitL_resp_Xeq _ _ o H)). rewrite SplitLGlue in H0. assert (H1:=(SplitR_resp_Xeq _ _ o H)). rewrite SplitRGlue in H1. apply glue_StepF_eq;auto with *. Qed. End EquivalenceC. (* begin hide *) Add Parametric Relation (X : RSetoid) : (StepF X) (@StepF_eq X) reflexivity proved by (@StepF_eq_refl X) symmetry proved by (@StepF_eq_sym X) transitivity proved by (@StepF_eq_trans X) as StepF_SetoidTheory. #[global] Hint Resolve StepF_eq_sym StepF_eq_trans. Add Morphism (StepFfoldProp) with signature (@StepF_eq iffSetoid) ==> iff as StepFfoldProp_mor. Proof. exact StepFfoldProp_morphism. Qed. (* end hide *) Lemma StepF_Sth (X : RSetoid) : (Setoid_Theory (StepF X) (@StepF_eq X)). split; unfold Reflexive, Symmetric, Transitive; eauto with sfarith. Qed. (** ** Common subdivision view This lemma allows to do induction over two step function as if the functions had the same subdivisions. *) Lemma StepF_ind2 : forall (X Y : RSetoid) (P : StepF X -> StepF Y -> Prop), (forall (s s0 : StepF X) (t t0 : StepF Y), (s==s0) -> (t==t0) -> P s t -> P s0 t0) -> (forall (x:X) (y:Y), P (constStepF x) (constStepF y)) -> (forall (o : OpenUnit) (s s0 : StepF X) (t t0 : StepF Y), P s t -> P s0 t0 -> P (glue o s s0) (glue o t t0)) -> forall (s:StepF X) (t:StepF Y), P s t. Proof. intros X Y P wd c0 c1. induction s. induction t. apply c0. apply wd with (s:=(glue o (constStepF x) (constStepF x))) (t:=glue o t1 t2); try reflexivity. apply (glueSplit (constStepF x) o). apply c1; assumption. intros t. eapply wd. reflexivity. apply glueSplit with (a:=o). apply c1; auto. Qed. Lemma glue_injl {X : RSetoid} :forall o (x y x1 y1:StepF X), (glue o x y)==(glue o x1 y1) -> (x==x1). Proof. intros. destruct H as [H _] using (glue_eq_ind x). rewrite SplitLGlue in H. assumption. Qed. Lemma glue_injr {X:RSetoid} :forall o (x y x1 y1:StepF X), (glue o x y)==(glue o x1 y1) -> (y==y1). Proof. intros. destruct H as [_ H] using (glue_eq_ind x). rewrite SplitRGlue in H. assumption. Qed. (** Decompose an equality over glue into two parts *) Lemma eq_glue_ind {X : RSetoid} : forall (s1 s2 s : StepF X) (a : OpenUnit) (P : Prop), ((SplitL s a) == s1 -> (SplitR s a) == s2 -> P) -> s == (glue a s1 s2) -> P. Proof. intros s1 s2 s a P H H0. symmetry in H0. destruct H0 as [H0l H0r] using (glue_eq_ind s1). symmetry in H0l, H0r. auto. Qed. Lemma MirrorSplitR {X : RSetoid} : forall (s : StepF X) (a b : OpenUnit), (b == OpenUnitDual a)%Q -> (Mirror (SplitR s a)) == (SplitL (Mirror s) b). Proof. intros. apply StepF_Qeq_eq; auto with *. apply MirrorSplitR_Qeq; auto with *. Qed. Lemma MirrorSplitL {X : RSetoid} : forall (s : StepF X) (a b : OpenUnit), (b == OpenUnitDual a)%Q -> (Mirror (SplitL s a)) == (SplitR (Mirror s) b). Proof. intros. apply StepF_Qeq_eq; auto with *. apply MirrorSplitL_Qeq; auto with *. Qed. (** Lift the distribution lemmas between ap and split to work over step functions *) Lemma SplitRAp :forall (X Y : RSetoid) (f : StepF (Y --> X)) (s : StepF Y) (o : OpenUnit), (SplitR (f <@> s) o) == (SplitR f o <@> SplitR s o). Proof. intros X Y f s o. apply StepF_Qeq_eq; auto with *. unfold Ap. rewrite <- StepFunction.SplitRMap. apply SplitRAp_Qeq. Qed. Lemma SplitLAp :forall (X Y : RSetoid) (f : StepF (Y --> X)) (s : StepF Y) (o : OpenUnit), (SplitL (f <@> s) o) == (SplitL f o <@> SplitL s o). Proof. intros X Y f s o. apply StepF_Qeq_eq; auto with *. unfold Ap. rewrite <- StepFunction.SplitLMap. apply SplitLAp_Qeq. Qed. (* begin hide *) Add Parametric Morphism s : (@constStepF s) with signature (@st_eq s) ==> (@StepF_eq s) as constStepF_wd. Proof. auto. Qed. Add Parametric Morphism s : (@glue s) with signature ou_eq ==> (@StepF_eq s) ==> (@StepF_eq s) ==> (@StepF_eq s) as glue_wd. Proof. intros o1 o2 Ho x1 x2 Hx y1 y2 Hy. transitivity (glue o1 x2 y2). apply glue_resp_StepF_eq; auto. apply StepF_Qeq_eq. repeat split; auto; reflexivity. Qed. Add Parametric Morphism X : (@SplitL X) with signature (@StepF_eq X) ==> ou_eq ==> (@StepF_eq X) as SplitL_wd. Proof. intros x1 x2 Hx o1 o2 Ho. transitivity (SplitL x2 o1). apply SplitL_resp_Xeq; auto. apply StepF_Qeq_eq. apply SplitL_resp_Qeq; auto; reflexivity. Qed. Add Parametric Morphism X : (@SplitR X) with signature (@StepF_eq X) ==> ou_eq ==> (@StepF_eq X) as SplitR_wd. Proof. intros x1 x2 Hx o1 o2 Ho. transitivity (SplitR x2 o1). apply SplitR_resp_Xeq; auto. apply StepF_Qeq_eq. apply SplitR_resp_Qeq; auto; reflexivity. Qed. Add Parametric Morphism X Y : (@Ap X Y) with signature (@StepF_eq (extSetoid X Y)) ==> (@StepF_eq X) ==> (@StepF_eq Y) as Ap_wd. Proof. intros f. induction f; intros g Hfg. induction g; intros x1. simpl. induction x1; intros x2. induction x2. intros H. transitivity (x ^@> (constStepF x2)). destruct x as [x Hx]. clear Hfg. apply: Hx ; assumption. apply: Hfg. intros H. rewrite MapGlue. symmetry. symmetry in H. destruct H as [Hl Hr] using (glue_eq_ind x2_1). apply glue_StepF_eq. symmetry. symmetry in Hl. apply IHx2_1. assumption. symmetry. symmetry in Hr. apply IHx2_2. assumption. intros H. rewrite MapGlue. destruct H as [Hl Hr] using (glue_eq_ind x1_1). apply glue_StepF_eq. rewrite SplitLMap. apply IHx1_1; auto. rewrite SplitRMap. apply IHx1_2; auto. symmetry. rewrite ApGlue. destruct Hfg as [Hfg0 Hfg1] using (eq_glue_ind g1). apply glue_StepF_eq; symmetry. rewrite SplitLMap. apply IHg1; try rewrite -> H0; auto with *. rewrite SplitRMap. apply IHg2; try rewrite -> H0; auto with *. intros s s' Hs. destruct Hfg as [Hfg0 Hfg1] using (glue_eq_ind f1). rewrite ApGlue. apply glue_StepF_eq; auto with *. rewrite -> SplitLAp. apply IHf1; try rewrite -> Hs; auto with *. rewrite -> SplitRAp. apply IHf2; try rewrite -> Hs; auto with *. Qed. (* end hide *) Lemma GlueAp : forall (X Y : RSetoid) (f : StepF (X --> Y)) (o : OpenUnit) (l r : StepF X), f <@> (glue o l r) == glue o ((SplitL f o) <@> l) ((SplitR f o) <@> r). Proof. intros X Y f o l r. set (A:= ((SplitL f o)<@>l)). set (B:= ((SplitR f o)<@>r)). rewrite <- (glueSplit f o). rewrite ApGlueGlue. reflexivity. Qed. (** ** Applicative Functor Here we prove the axioms of an applicative functor. *) Lemma Map_homomorphism (X Y : RSetoid) : forall (f:X-->Y) (a:X), (f ^@> constStepF a) == (constStepF (f a)). Proof. reflexivity. Qed. Lemma Map_identity (X : RSetoid) : forall (a:StepF X), (@id X) ^@> a == a. Proof. intros a. now rewrite <-(Map_identity a) at 2. Qed. Lemma Map_composition (X Y Z : RSetoid) : forall (a:StepF (Y-->Z)) (b:StepF (X-->Y)) (c:StepF X), ((@compose X Y Z) ^@> a <@> b <@> c) == (a <@> (b <@> c)). Proof. induction a. simpl. apply (StepF_ind2 (X --> Y) X); auto with *. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht. auto. intros o s s0 t t0 H H0. rewrite -> Map_homomorphism. rewrite ApGlueGlue. do 2 rewrite MapGlue. rewrite ApGlueGlue. rewrite <- H. rewrite <- H0. reflexivity. intros b c. rewrite MapGlue. repeat rewrite ApGlue. apply glue_resp_StepF_eq. rewrite -> IHa1. rewrite -> SplitLAp. reflexivity. rewrite -> IHa2. rewrite -> SplitRAp. reflexivity. Qed. (** Here we show that the rest of the BCKW combinators lift to step functions. Hence all of the lambda calculus lifts to operate over step functions. Step functions form about a nice of an applicative functor as is possible. *) Lemma Map_discardable (X Y : RSetoid) : forall (a:StepF X) (b:StepF Y), ((@const _ _) ^@> a <@> b == a). Proof. apply StepF_ind2; auto with *. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht; auto. intros o s s0 t t0 H0 H1. rewrite MapGlue. rewrite ApGlueGlue. rewrite -> H0, H1;reflexivity. Qed. Lemma Map_commutative W X Y : forall (f:StepF (W --> X --> Y)) (x:StepF X) (w:StepF W), ((@flip _ _ _) ^@> f <@> x <@> w) == (f <@> w <@> x). Proof. induction f. simpl. apply StepF_ind2; auto with *. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht;auto. intros o s s0 t t0 H0 H1. rewrite -> Map_homomorphism. do 2 rewrite MapGlue. do 2 rewrite ApGlueGlue. rewrite -> H0, H1; reflexivity. intros x w. rewrite MapGlue. do 4 rewrite ApGlue. apply glue_resp_StepF_eq; auto. Qed. Lemma Map_copyable X Y : forall (f:StepF (X --> X --> Y)) (x:StepF X), ((@join _ _) ^@> f <@> x) == (f <@> x <@> x). Proof. apply StepF_ind2; auto with *. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht; auto. intros o s s0 t t0 H0 H1. rewrite MapGlue. do 3 rewrite ApGlueGlue. rewrite -> H0, H1;reflexivity. Qed. (* begin hide *) #[global] Hint Rewrite ApGlueGlue ApGlue GlueAp SplitRAp SplitLAp SplitLGlue SplitRGlue Map_homomorphism : StepF_rew. #[global] Hint Rewrite Map_composition Map_discardable Map_commutative Map_identity Map_copyable : StepF_eval. (* end hide *) (** This tactic is usefully for symbolically evaluating functions written in (BCKWI) combinator form that are ap'ed to step functions *) Ltac evalStepF := progress (repeat rewrite <- Map_homomorphism; autorewrite with StepF_eval). Lemma Ap_interchange (X Y : RSetoid) : forall (f:StepF (X-->Y)) (a:X), (f <@^ a) == (flip id a) ^@> f. Proof. intros f a. evalStepF. reflexivity. Qed. (** Map'ing the S combinator (which is also called ap) *) Lemma Map_ap X Y Z : forall (f:StepF (X --> Y --> Z)) (x:StepF (X --> Y)) (a:StepF X), ((@ap _ _ _) ^@> f <@> x <@> a) == (f <@> a <@> (x <@> a)). Proof. intros f x a. unfold ap. evalStepF. reflexivity. Qed. (* begin hide *) #[global] Hint Rewrite Map_ap : StepF_eval. (* end hide *) Ltac rewriteStepF := autorewrite with StepF_rew. Lemma StepFfoldPropForall_Ap : forall X (f:StepF (X --> iffSetoid)) (x:StepF X), (forall y, StepFfoldProp (f <@> constStepF y)) -> StepFfoldProp (f <@> x). Proof. intros X f x H. revert f H. induction x. intros f H. apply H. intros f H. rewrite <- (glueSplit f o). rewrite ApGlueGlue. split. apply IHx1. intros y. assert (H0:=H y). rewrite <- (glueSplit f o) in H0. rewrite ApGlue in H0. destruct H0 as [H0 _]. assumption. apply IHx2. intros y. assert (H0:=H y). rewrite <- (glueSplit f o) in H0. rewrite ApGlue in H0. destruct H0 as [_ H0]. assumption. Qed. (** A common case that we will encounter is that a predicate holds for all step functions when it is define via map (or map2 or map3) and the underlying function holds for all X. *) Lemma StepFfoldPropForall_Map : forall X (f:X --> iffSetoid) (x:StepF X), (forall a, f a) -> StepFfoldProp (f ^@> x). Proof. intros X f x H. apply StepFfoldPropForall_Ap. assumption. Qed. Lemma StepFfoldPropForall_Map2 : forall X Y (f:X --> Y --> iffSetoid) x y, (forall a b, f a b) -> StepFfoldProp (f ^@> x <@> y). Proof. intros X Y f x y H. apply StepFfoldPropForall_Ap. intros b. rewrite <- (Map_commutative (constStepF f) (constStepF b)). rewriteStepF. apply StepFfoldPropForall_Map. intros a. apply: H. Qed. Lemma StepFfoldPropForall_Map3 : forall X Y Z (f:X --> Y --> Z --> iffSetoid) x y z, (forall a b c, f a b c) -> StepFfoldProp (f ^@> x <@> y <@> z). Proof. intros X Y Z f x y z H. apply StepFfoldPropForall_Ap. intros c. rewrite <- (Map_commutative ((constStepF f) <@> x) (constStepF c)). rewrite <- Map_composition. rewriteStepF. rewrite <- (Map_commutative (constStepF (compose flip f)) (constStepF c)). rewriteStepF. apply StepFfoldPropForall_Map2. intros a b. apply: H. Qed. (** The implication operation can be lifted to work on characteristic functions *) Definition imp0:Prop->iffSetoid-->iffSetoid. Proof. intro A. exists (fun B:Prop=>(A->B)). simpl. unfold canonical_names.equiv. intuition. Defined. Definition imp:iffSetoid-->iffSetoid-->iffSetoid. Proof. exists imp0. simpl. unfold canonical_names.equiv, extEq. intuition. simpl. intuition. Defined. Definition StepF_imp (f g:StepF iffSetoid):Prop:= (StepFfoldProp (imp ^@> f <@> g)). Lemma StepFfoldPropglue_rew:(forall o x y, (StepFfoldProp (glue o x y))<->((StepFfoldProp x)/\StepFfoldProp y)). Proof. auto with *. Qed. (* begin hide *) #[global] Hint Rewrite StepFfoldPropglue_rew:StepF_rew. (* end hide *) Lemma StepF_imp_imp:forall x y:(StepF iffSetoid), (StepF_imp x y) -> ((StepFfoldProp x)->(StepFfoldProp y)). Proof. induction x. induction y. auto with *. unfold StepF_imp. unfold StepFfoldProp;simpl;intuition. intros y. unfold StepF_imp, Map2. rewriteStepF. intros. rewrite <- (StepFfoldPropglue y o). rewriteStepF. intuition. Qed. corn-8.20.0/metric2/UCFnMonoid.v000066400000000000000000000017561473720167500162640ustar00rootroot00000000000000Require Import Coq.Unicode.Utf8 MathClasses.theory.CoqStreams CoRN.metric2.UniformContinuity MathClasses.interfaces.abstract_algebra. (** Uniform continuous maps from a metric space to itself (endomaps) form a monoid under composition *) Section uniform_cont_fn_monoid. Context {X:MetricSpace}. Open Scope uc_scope. (* for the _ --> _ notation *) Instance ucfn_unit: MonUnit (X --> X) := @uc_id X. Instance ucfn_compose {X}: SgOp (X --> X) := @uc_compose X X X. Instance ucfn_monoid: Monoid (X --> X). Proof. repeat split. - apply Qle_refl. - reflexivity. - apply Qle_refl. - intros; symmetry; apply H. - apply Qle_refl. - intros. transitivity (y a). apply H. apply H0. - apply Qle_refl. - reflexivity. - apply Qle_refl. - intros. simpl. transitivity (x (y0 a)). destruct H0. rewrite H1. reflexivity. apply H. - apply Qle_refl. - reflexivity. - apply Qle_refl. - reflexivity. Qed. End uniform_cont_fn_monoid. corn-8.20.0/metric2/UniformContinuity.v000066400000000000000000000230311473720167500200160ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.Metric. Require Export CoRN.model.structures.QposInf. Require Import CoRN.stdlib_omissions.List. Set Implicit Arguments. (** This extended notition of ball operates over QposInf, allowing one to say, ball Infinity a b, holds for all a and b. *) Definition ball_ex (X: MetricSpace) (e: QposInf): X -> X -> Prop := match e with | Qpos2QposInf e' => ball (proj1_sig e') | QposInfinity => fun a b => True end. (* begin hide *) Arguments ball_ex [X]. (* end hide *) Lemma ball_ex_weak_le : forall (X:MetricSpace) (e d:QposInf) (a b:X), QposInf_le e d -> ball_ex e a b -> ball_ex d a b. Proof. intros X e d a b Hed Hab. destruct d as [d|]; destruct e as [e|]. eapply (ball_weak_le X). apply Hed. assumption. elim Hed. constructor. assumption. Qed. Lemma ball_ex_dec : forall (X:MetricSpace), (forall e (a b:X), {ball e a b}+{~ball e a b}) -> forall e (a b:X), {ball_ex e a b}+{~ball_ex e a b}. Proof. intros X ball_dec e a b. destruct e as [e|]. apply (ball_dec (proj1_sig e) a b). simpl. auto. Defined. Section UniformlyContinuousFunction. (** ** Uniform Continuity *) Variable X Y : MetricSpace. (** This is the traditional definitition of uniform continuity with an explicitly given modulus of continuity *) Definition is_UniformlyContinuousFunction (f: X -> Y) (mu: Qpos -> QposInf) := forall e a b, ball_ex (mu e) a b -> ball (proj1_sig e) (f a) (f b). (** Every uniformly continuous function is automatically well defined *) Lemma is_UniformlyContinuousFunction_wd : forall (f1 f2:X -> Y) (mu1 mu2: Qpos -> QposInf), (forall x, msp_eq (f1 x) (f2 x)) -> (forall x, QposInf_le (mu2 x) (mu1 x)) -> (is_UniformlyContinuousFunction f1 mu1) -> (is_UniformlyContinuousFunction f2 mu2). Proof. intros f1 f2 mu1 mu2 Hf Hmu H e a b Hab. assert (QposEq e e) by reflexivity. apply (ball_wd Y H0 _ _ (Hf a) _ _ (Hf b)). apply H. eapply ball_ex_weak_le. apply Hmu. assumption. Qed. (** A uniformly continuous function consists of a function, a modulus of continuity, and a proof that the function is uniformly continuous with that modulus *) Record UniformlyContinuousFunction : Type := {ucFun :> X -> Y ;mu : Qpos -> QposInf ;uc_prf : is_UniformlyContinuousFunction ucFun mu }. (** Given a uniformly continuous function with a modulus mu, it is also uniformly continuous with any smaller modulus *) Lemma uc_prf_smaller : forall (f:UniformlyContinuousFunction) (mu2 : Qpos -> QposInf), (forall e, QposInf_le (mu2 e) (mu f e)) -> is_UniformlyContinuousFunction (ucFun f) mu2. Proof. intros f my2 H. eapply is_UniformlyContinuousFunction_wd. intros; reflexivity. apply H. apply uc_prf. Qed. (** *** The metric space of uniformly continuous functions The space of uniformly continuous functions from a metric space *) Definition ucEq (f g : UniformlyContinuousFunction) := forall x:X, msp_eq (f x) (g x). Definition ucBall e (f g : UniformlyContinuousFunction) := 0 <= e /\ forall a:X, ball e (f a) (g a). Lemma uc_is_MetricSpace : is_MetricSpace ucBall. Proof. constructor. - firstorder using ball_refl. - firstorder using ball_sym. - intros e1 e2 f g h H1 H2. destruct H1, H2. split. apply (Qle_trans _ (e1+0)). rewrite Qplus_0_r. exact H. apply Qplus_le_r, H1. intro a. apply ball_triangle with (g a); auto. - intros e f g H. split. + apply Qnot_lt_le. intro abs. specialize (H (-e *(1#2))). destruct H. rewrite <- (Qmult_0_l (1#2)). apply Qmult_lt_r. reflexivity. apply (Qplus_lt_r _ _ e). ring_simplify. exact abs. ring_simplify in H. apply (Qlt_not_le _ _ abs). rewrite <- (Qmult_le_l _ _ (1#2)). rewrite Qmult_0_r. exact H. reflexivity. + intro a. apply ball_closed. firstorder. - intros e a b H. apply H. - intros. split. apply Qnot_lt_le. intro abs. contradict H; intro H. destruct H. apply (Qle_not_lt _ _ H abs). intros. apply (msp_stable (msp Y)). intro abs. contradict H; intro H. apply abs, H. Qed. Lemma ucBall_e_wd : forall (e1 e2:Q) x y, e1 == e2 -> (ucBall e1 x y <-> ucBall e2 x y). Proof. intros. unfold ucBall in *. split. - intros H0. destruct H0. split. rewrite <- H. exact H0. intro a. apply (ball_e_wd _ _ _ H), H1. - intros. destruct H0. split. rewrite H. exact H0. intro a. apply (ball_e_wd _ _ _ H), H1. Qed. (** mu_ex generalizes mu analogous to how ball_ex generalizes ball: *) Definition mu_ex (f: UniformlyContinuousFunction) (e: QposInf): QposInf := match e with | Qpos2QposInf e' => mu f e' | QposInfinity => QposInfinity end. Lemma uc_ex_prf (u: UniformlyContinuousFunction) (e: QposInf) (a b: X): ball_ex (mu_ex u e) a b -> ball_ex e (ucFun u a) (ucFun u b). Proof with auto. intros. destruct e... simpl in *. apply uc_prf. assumption. Qed. End UniformlyContinuousFunction. (* begin hide *) Arguments is_UniformlyContinuousFunction [X Y]. (* Add Setoid UniformlyContinuousFunction ucEq uc_setoid as uc_Setoid. *) (* end hide *) Definition UniformlyContinuousSpace (X Y:MetricSpace) : MetricSpace := Build_MetricSpace (@ucBall_e_wd X Y) (@uc_is_MetricSpace X Y). Lemma ucEq_equiv : forall X Y (x y : UniformlyContinuousSpace X Y), ucEq x y <-> msp_eq x y. Proof. unfold msp_eq, ucEq. split. - intros. split. apply Qle_refl. intros. apply H. - intros. destruct H. apply H0. Qed. Notation "x --> y" := (UniformlyContinuousSpace x y) (at level 55, right associativity) : uc_scope. Local Open Scope uc_scope. (* begin hide *) Add Parametric Morphism (X Y:MetricSpace) (f : X --> Y) : (ucFun f) with signature (@msp_eq X) ==> (@msp_eq Y) as uc_wd. Proof. intros x0 x1 Hx. apply ball_eq. intros e epos. apply (uc_prf f (exist _ _ epos)). destruct (mu f (exist _ _ epos));[|constructor]. simpl. assert (QposEq q q) by reflexivity. apply (ball_wd X H _ _ Hx x1 x1 (reflexivity _)). apply ball_refl. apply Qpos_nonneg. Qed. #[global] Instance uc_wd_more_Proper (X Y : MetricSpace): Proper (@ucEq _ _ ==> @msp_eq X ==> @msp_eq Y) (@ucFun X Y). Proof. intros ?? E ?? F. now rewrite F. Qed. Definition ucFun2 (X Y Z:MetricSpace) (f: X --> Y --> Z) (x:X) (y:Y) := f x y. Add Parametric Morphism (X Y Z:MetricSpace) f : (@ucFun2 X Y Z f) with signature (@msp_eq X) ==> (@msp_eq Y) ==> (@msp_eq Z) as ucFun2_wd. Proof. intros x y Hxy x0 y0 Hxy0. unfold ucFun2. rewrite -> Hxy0. generalize y0. apply ucEq_equiv. rewrite -> Hxy. reflexivity. Qed. (* end hide *) (** *** The category of metric spaces. Metric spaces with uniformly continuous functions form a category. The identity function is uniformly continuous. *) Lemma uc_id_prf (X:MetricSpace) : is_UniformlyContinuousFunction (fun (x:X) => x) Qpos2QposInf. Proof. intros e a b Hab. assumption. Qed. Definition uc_id (X:MetricSpace) : UniformlyContinuousFunction X X := Build_UniformlyContinuousFunction (uc_id_prf X). (** The composition of two uniformly continuous functions is uniformly continuous *) Lemma uc_compose_prf (X Y Z:MetricSpace) (g: Y --> Z) (f:X --> Y) : is_UniformlyContinuousFunction (fun x => g (f x)) (fun e => QposInf_bind (mu f) (mu g e)). Proof. revert g f. intros [g mu_g Hg] [f mu_f Hf] e a b Hab. unfold is_UniformlyContinuousFunction in *. simpl in *. apply Hg. clear Hg. destruct (mu_g e) as [mge|]; firstorder. Qed. Definition uc_compose (X Y Z:MetricSpace) (g: Y --> Z) (f:X --> Y) : X --> Z := Build_UniformlyContinuousFunction (uc_compose_prf g f). (* begin hide *) Add Parametric Morphism X Y Z : (@uc_compose X Y Z) with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as uc_compose_wd. Proof. intros x1 x2 Hx y1 y2 Hy. apply ucEq_equiv. intros x. simpl. apply ucEq_equiv in Hx. rewrite -> (Hx (y1 x)). apply uc_wd. apply ucEq_equiv in Hy. rewrite -> (Hy x). reflexivity. Qed. (* end hide *) Notation "f ∘ g" := (uc_compose f g) (at level 40, left associativity) : uc_scope. Lemma is_uc_uc_compose0 : forall X Y Z (f:Y-->Z), is_UniformlyContinuousFunction (@uc_compose X Y Z f) (mu f). Proof. intros X Y Z f e x y Hxy. split. apply Qpos_nonneg. intro z. simpl. simpl in Hxy. apply uc_prf. destruct (mu f e); auto. apply Hxy. Qed. Definition uc_compose_uc0 X Y Z (f:Y-->Z) : (X-->Y) --> X --> Z := Build_UniformlyContinuousFunction (is_uc_uc_compose0 f). Lemma is_uc_uc_compose : forall X Y Z, is_UniformlyContinuousFunction (@uc_compose_uc0 X Y Z) Qpos2QposInf. Proof. intros X Y Z e x y Hxy. split. apply Qpos_nonneg. intro z. split. apply Qpos_nonneg. intro z0. simpl. apply Hxy. Qed. Definition uc_compose_uc X Y Z : (Y-->Z)-->(X-->Y)-->X-->Z := Build_UniformlyContinuousFunction (@is_uc_uc_compose X Y Z). corn-8.20.0/metric2/list_separates.v000066400000000000000000000030311473720167500173310ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import Unicode.Utf8 Setoid List Permutation Setoid Morphisms SetoidPermutation stdlib_omissions.Pair. Fixpoint separates {A} (l: list A): list (A * list A) := match l with | nil => nil | x :: xs => (x, xs) :: map (fun pq => (fst pq, x :: snd pq)) (separates xs) end. (** separates (0::1::2::nil)= (0, 1 :: 2 :: nil) :: (1, 0 :: 2 :: nil) :: (2, 0 :: 1 :: nil) :: nil *) Lemma separates_length {A} (l: list A): length (separates l) = length l. Proof. induction l. intuition. simpl. rewrite map_length. congruence. Qed. Lemma separates_elem_lengths {A} (l x: list A): In x (map (@snd _ _) (separates l)) → length l = S (length x). Proof with auto. revert x. induction l; simpl. intuition. intros x [[] | C]... rewrite map_map in C. simpl in C. destruct (proj1 (in_map_iff _ _ _) C) as [x0 [[]?]]. rewrite (IHl (snd x0)). reflexivity. apply in_map_iff. eauto. Qed. #[global] Instance separates_Proper {A}: Proper (@Permutation _ ==> SetoidPermutation (pair_rel eq (@Permutation _))) (@separates A). Proof with simpl; auto; intuition. intros ?? P. induction P... 3:eauto. apply s_perm_skip. split... apply (map_perm_proper (pair_rel eq (@Permutation A)))... intros ?? [??]. split... rewrite s_perm_swap. repeat apply s_perm_skip... do 2 rewrite map_map. apply (map_perm_proper (pair_rel eq (SetoidPermutation eq)))... intros ?? [C D]. split... apply perm_trans with (l':=(x :: y :: snd x0))... do 2 apply perm_skip... apply SetoidPermutation_eq... Qed. corn-8.20.0/metrics/000077500000000000000000000000001473720167500142245ustar00rootroot00000000000000corn-8.20.0/metrics/CMetricSpaces.v000066400000000000000000000506231473720167500171060ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.metrics.Prod_Sub. Require Export CoRN.metrics.Equiv. Section Definition_MS. (** ** Definition of Metric Space *) Record CMetricSpace : Type := {scms_crr :> CPsMetricSpace; ax_d_apdiag_imp_grzero : apdiag_imp_grzero scms_crr (cms_d (c:=scms_crr))}. End Definition_MS. Section MS_basics. (** ** Metric Space basics *) Lemma d_CMetricSpace_apdiag_imp_grzero : forall X : CMetricSpace, apdiag_imp_grzero (cms_crr X) (cms_d (c:=X)). Proof. intro X. apply ax_d_apdiag_imp_grzero. Qed. Lemma d_zero_imp_eq : forall (X : CMetricSpace) (a b : X), a[-d]b[=][0] -> a[=]b. Proof. intros X a b. intro H. apply not_ap_imp_eq. red in |- *. intro H1. generalize H. apply ap_imp_neq. apply Greater_imp_ap. apply ax_d_apdiag_imp_grzero. exact H1. Qed. Lemma is_CMetricSpace_diag_zero : forall (X : CSetoid) (d : CSetoid_bin_fun X X IR) (H : com d) (H1 : tri_ineq d) (H2 : nneg d) (H3 : diag_zero X d) (H4 : apdiag_imp_grzero X d), CMetricSpace. Proof. intros X d H H1 H2 H3 H4. set (H5 := Build_is_CPsMetricSpace X d H H2 (diag_zero_imp_pos_imp_ap X d H3) H1) in *. set (H6 := Build_CPsMetricSpace X d H5) in *. set (H7 := Build_CMetricSpace H6 H4) in *. exact H7. Qed. End MS_basics. Section prodandsub. (** ** Product-Metric-Spaces and Sub-Metric-Spaces *) (** The product of two metric spaces is again a metric space. *) Lemma Prod0CMetricSpaces_apdiag_grzero : forall X Y : CMetricSpace, apdiag_imp_grzero (Prod0CPsMetricSpace X Y) (cms_d (c:=Prod0CPsMetricSpace X Y)). Proof. intros X Y. unfold apdiag_imp_grzero in |- *. intros x y. case x. case y. intros c c0 c1 c2. simpl in |- *. intro H. elim H. intro H1. apply plus_resp_pos_nonneg. apply ax_d_apdiag_imp_grzero. exact H1. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. intro H1. astepr ((c2[-d]c0)[+](c1[-d]c)). apply plus_resp_pos_nonneg. apply ax_d_apdiag_imp_grzero. exact H1. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Definition Prod0CMetricSpace (X Y : CMetricSpace) := Build_CMetricSpace (Prod0CPsMetricSpace X Y) (Prod0CMetricSpaces_apdiag_grzero X Y). (** A subspace of a metric space is again a metric space. *) Arguments SubPsMetricSpace [X]. Lemma SubMetricSpace_apdiag_grzero : forall (X : CMetricSpace) (P : X -> CProp), apdiag_imp_grzero (SubPsMetricSpace P) (cms_d (c:=SubPsMetricSpace P)). Proof. intros X P. unfold apdiag_imp_grzero in |- *. intros x y. simpl in |- *. case x. case y. simpl in |- *. intros. apply ax_d_apdiag_imp_grzero. auto. Qed. Definition SubMetricSpace (X : CMetricSpace) (P : X -> CProp) := Build_CMetricSpace (SubPsMetricSpace P) (SubMetricSpace_apdiag_grzero X P). Arguments SubMetricSpace [X]. End prodandsub. Section Zeroff. (** ** Pseudo Metric Spaces vs Metric Spaces *) (** Not all pseudo metric spaces are a metric space: *) Lemma zf_nis_CMetricSpace : forall X : CSetoid, {x : X | {y : X | x[#]y}} -> Not (apdiag_imp_grzero (zf_as_CPsMetricSpace X) (cms_d (c:=zf_as_CPsMetricSpace X))). Proof. intros X Z. red in |- *. intro H. set (H1 := Build_CMetricSpace (zf_as_CPsMetricSpace X) H) in *. set (H2 := d_CMetricSpace_apdiag_imp_grzero H1) in *. generalize H2. unfold H1 in |- *. simpl in |- *. unfold apdiag_imp_grzero in |- *. unfold Zero_fun in |- *. simpl in |- *. unfold zero_fun in |- *. elim Z. intros x Z1. elim Z1. intros y Z2. intros H3. set (H4 := H3 x y Z2) in *. set (H5 := less_irreflexive_unfolded IR [0] H4) in *. exact H5. Qed. (** But a pseudo metric space induces a metric space: *) Definition metric_ap (X : CPsMetricSpace) (x y : X) : CProp := [0][<]x[-d]y. Definition metric_eq (X : CPsMetricSpace) (x y : X) : Prop := x[-d]y[=][0]. Lemma metric_ap_irreflexive : forall X : CPsMetricSpace, irreflexive (metric_ap X). Proof. intro X. unfold irreflexive in |- *. intro x. red in |- *. unfold metric_ap in |- *. set (H0 := pos_imp_ap_imp_diag_zero X (cms_d (c:=X)) (ax_d_pos_imp_ap X (cms_d (c:=X)) (CPsMetricSpace_is_CPsMetricSpace X)) (ax_d_nneg X (cms_d (c:=X)) (CPsMetricSpace_is_CPsMetricSpace X))) in *. generalize H0. unfold diag_zero in |- *. intros H1 H2. set (H3 := less_wdr IR [0] (x[-d]x) [0] H2 (H1 x)) in *. set (H4 := less_irreflexive_unfolded IR [0] H3) in *. exact H4. Qed. Lemma metric_ap_symmetric : forall X : CPsMetricSpace, Csymmetric (metric_ap X). Proof. intro X. unfold Csymmetric in |- *. intros x y. unfold metric_ap in |- *. intro H. astepr (x[-d]y). exact H. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma metric_ap_cotransitive : forall X : CPsMetricSpace, cotransitive (metric_ap X). Proof. intro X. unfold cotransitive in |- *. unfold metric_ap in |- *. intros x y H z. cut (ZeroR[<](x[-d]z)[+](z[-d]y)). intro H0. apply positive_Sum_two. exact H0. apply less_leEq_trans with (x[-d]y). exact H. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma metric_ap_tight : forall X : CPsMetricSpace, tight_apart (metric_eq X) (metric_ap X). Proof. intro X. unfold tight_apart in |- *. unfold metric_ap in |- *. unfold metric_eq in |- *. intros x y. split. intro H. cut (ZeroR[<=]x[-d]y). rewrite -> leEq_def in |- *. intro H1. cut (Not (x[-d]y[#][0])). intro H2. apply not_ap_imp_eq. exact H2. red in |- *. intro H2. set (H3 := less_conf_ap IR (x[-d]y) [0]) in *. elim H3. intros H4 H5. set (H6 := H4 H2) in *. elim H6. intuition. intuition. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. intro H. red in |- *. intro H0. set (H1 := less_wdr IR [0] (x[-d]y) [0] H0 H) in *. set (H2 := less_irreflexive_unfolded IR [0] H1) in *. exact H2. Qed. Definition Metric_CSet_is_CSetoid (X : CPsMetricSpace) := Build_is_CSetoid X (metric_eq X) (metric_ap X) (metric_ap_irreflexive X) (metric_ap_symmetric X) (metric_ap_cotransitive X) ( metric_ap_tight X). Definition Metric_CSetoid (X : CPsMetricSpace) := Build_CSetoid X (metric_eq X) (metric_ap X) (Metric_CSet_is_CSetoid X). Definition metric_d (X : CPsMetricSpace) (x y : Metric_CSetoid X) := x[-d]y. Lemma metric_d_strext : forall X : CPsMetricSpace, bin_fun_strext (Metric_CSetoid X) (Metric_CSetoid X) IR (metric_d X). Proof. intro X. unfold bin_fun_strext in |- *. intros x1 x2 y1 y2. simpl in |- *. unfold metric_d in |- *. unfold metric_ap in |- *. intro H. apply positive_Sum_two. set (H0 := less_conf_ap IR (x1[-d]y1) (x2[-d]y2)) in *. elim H0. intros H1 H2. set (H4 := H1 H) in *. elim H4. intro H5. astepr ((x1[-d]x2)[+](y1[-d]y2)[+][0]). astepr ((x1[-d]x2)[+](y1[-d]y2)[+]((x1[-d]y1)[-](x1[-d]y1))). astepr ((x1[-d]x2)[+](y1[-d]y2)[+](x1[-d]y1)[-](x1[-d]y1)). apply shift_less_minus. astepl (x1[-d]y1). apply less_leEq_trans with (x2[-d]y2). exact H5. apply leEq_transitive with ((x2[-d]x1)[+](x1[-d]y2)). apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. astepr ((x2[-d]x1)[+](y1[-d]y2)[+](x1[-d]y1)). astepr ((x2[-d]x1)[+]((y1[-d]y2)[+](x1[-d]y1))). apply plus_resp_leEq_lft. astepr ((x1[-d]y1)[+](y1[-d]y2)). apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. astepl ((y1[-d]y2)[+](x2[-d]x1)[+](x1[-d]y1)). astepr ((y1[-d]y2)[+](x1[-d]x2)[+](x1[-d]y1)). astepl ((y1[-d]y2)[+]((x2[-d]x1)[+](x1[-d]y1))). astepr ((y1[-d]y2)[+]((x1[-d]x2)[+](x1[-d]y1))). astepl ((y1[-d]y2)[+]((x1[-d]y1)[+](x2[-d]x1))). astepr ((y1[-d]y2)[+]((x1[-d]y1)[+](x1[-d]x2))). astepl ((y1[-d]y2)[+](x1[-d]y1)[+](x2[-d]x1)). astepr ((y1[-d]y2)[+](x1[-d]y1)[+](x1[-d]x2)). apply plus_resp_eq. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. intro H5. astepr ((x1[-d]x2)[+](y1[-d]y2)[+][0]). astepr ((x1[-d]x2)[+](y1[-d]y2)[+]((x2[-d]y2)[-](x2[-d]y2))). astepr ((x1[-d]x2)[+](y1[-d]y2)[+](x2[-d]y2)[-](x2[-d]y2)). apply shift_less_minus. astepl (x2[-d]y2). apply less_leEq_trans with (x1[-d]y1). exact H5. apply leEq_transitive with ((x1[-d]x2)[+](x2[-d]y1)). apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. astepr ((x1[-d]x2)[+](y1[-d]y2)[+](x2[-d]y2)). astepr ((x1[-d]x2)[+]((y1[-d]y2)[+](x2[-d]y2))). apply plus_resp_leEq_lft. astepr ((x2[-d]y2)[+](y1[-d]y2)). astepr ((x2[-d]y2)[+](y2[-d]y1)). apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. apply plus_resp_eq. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Definition Metric_d (X : CPsMetricSpace) := Build_CSetoid_bin_fun (Metric_CSetoid X) (Metric_CSetoid X) IR ( metric_d X) (metric_d_strext X). Lemma Metric_d_com : forall X : CPsMetricSpace, com (Metric_d X). Proof. intro X. unfold com in |- *. intros x y. unfold Metric_d in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma Metric_d_nneg : forall X : CPsMetricSpace, nneg (Metric_d X). Proof. intro X. unfold nneg in |- *. intros x y. unfold Metric_d in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma Metric_d_pos_imp_ap : forall X : CPsMetricSpace, pos_imp_ap (Metric_d X). Proof. intro X. unfold pos_imp_ap in |- *. intros x y. unfold Metric_d in |- *. simpl in |- *. unfold metric_d in |- *. unfold metric_ap in |- *. intuition. Qed. Lemma Metric_d_tri_ineq : forall X : CPsMetricSpace, tri_ineq (Metric_d X). Proof. intro X. unfold tri_ineq in |- *. intros x y z. unfold Metric_d in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Definition QuotientCSetoid_is_CPsMetricSpace (X : CPsMetricSpace) := Build_is_CPsMetricSpace (Metric_CSetoid X) (Metric_d X) ( Metric_d_com X) (Metric_d_nneg X) (Metric_d_pos_imp_ap X) (Metric_d_tri_ineq X). Definition QuotientCPsMetricSpace (X : CPsMetricSpace) := Build_CPsMetricSpace (Metric_CSetoid X) (Metric_d X) (QuotientCSetoid_is_CPsMetricSpace X). Lemma Metric_d_apdiag_grzero : forall X : CPsMetricSpace, apdiag_imp_grzero (QuotientCPsMetricSpace X) (cms_d (c:=QuotientCPsMetricSpace X)). Proof. intro X. unfold apdiag_imp_grzero in |- *. intros x y. simpl in |- *. unfold metric_ap in |- *. unfold metric_d in |- *. intuition. Qed. Definition QuotientCMetricSpace (X : CPsMetricSpace) := Build_CMetricSpace (QuotientCPsMetricSpace X) (Metric_d_apdiag_grzero X). (** Some pseudo metric spaces already are a metric space: *) Lemma dIR_apdiag_grzero : apdiag_imp_grzero IR_as_CPsMetricSpace (cms_d (c:=IR_as_CPsMetricSpace)). Proof. unfold apdiag_imp_grzero in |- *. intros x y. simpl in |- *. unfold dIR in |- *. intro H. set (H0 := AbsIR_pos) in *. generalize H0. simpl in |- *. intro H1. apply H1. apply minus_ap_zero. exact H. Qed. Definition IR_as_CMetricSpace := Build_CMetricSpace IR_as_CPsMetricSpace dIR_apdiag_grzero. (** In that case the induced metric space is equivalent to the original one: *) Definition emb (X : CPsMetricSpace) : X -> QuotientCMetricSpace X. Proof. intros x. unfold QuotientCMetricSpace in |- *. simpl in |- *. exact x. Defined. Lemma emb_strext : forall X : CPsMetricSpace, fun_strext (emb X). Proof. intro X. unfold fun_strext in |- *. unfold emb in |- *. simpl in |- *. unfold metric_ap in |- *. apply ax_d_pos_imp_ap. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Definition Emb (X : CPsMetricSpace) := Build_CSetoid_fun X (QuotientCMetricSpace X) (emb X) (emb_strext X). Lemma Quotient_pres_CMetricSpace : forall X : CMetricSpace, isopsmetry X (QuotientCPsMetricSpace X) (Emb X). Proof. intro X. unfold isopsmetry in |- *. unfold Emb in |- *. simpl in |- *. unfold emb in |- *. split. unfold bijective in |- *. split. unfold injective in |- *. simpl in |- *. intros a0 a1. unfold metric_ap in |- *. apply ax_d_apdiag_imp_grzero. unfold surjective in |- *. intro b. simpl in |- *. exists b. unfold metric_eq in |- *. apply pos_imp_ap_imp_diag_zero. apply d_pos_imp_ap. apply d_nneg. unfold equivalent_psmetric in |- *. simpl in |- *. split. split. apply CPsMetricSpace_is_CPsMetricSpace. apply Build_is_CPsMetricSpace. unfold com in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. unfold nneg in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. unfold pos_imp_ap in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_pos_imp_ap. apply CPsMetricSpace_is_CPsMetricSpace. unfold tri_ineq in |- *. simpl in |- *. unfold metric_d in |- *. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. split. exists 0. unfold metric_d in |- *. intros x y. apply eq_imp_leEq. rational. exists 0. unfold metric_d in |- *. intros x y. apply eq_imp_leEq. rational. Qed. End Zeroff. Section Limitt. (** ** Limit *) (** A sequence in a metric space has at most one limit. *) Arguments MSseqLimit [X]. (* begin hide *) Lemma nz : forall n m : nat, n <= Nat.max n m. Proof. intro n. intro m. intuition. Qed. (* end hide *) (* begin hide *) Lemma d_wd : forall (X : CPsMetricSpace) (a b c : X), a[=]b -> a[-d]c[=]b[-d]c. Proof. intros X a b c. intros H. apply not_ap_imp_eq. red in |- *. intro H1. cut (a[#]b or c[#]c). intro H2. elim H2. apply eq_imp_not_ap. exact H. apply ap_irreflexive_unfolded. cut (a[-d]c[#]b[-d]c -> a[#]b or c[#]c). intro H2. apply H2. exact H1. apply csbf_strext. Qed. (* end hide *) Lemma unique_MSseqLim : forall (X : CMetricSpace) (seq : nat -> X) (a b : X), MSseqLimit seq a and MSseqLimit seq b -> a[=]b. Proof. intros X seq a b. unfold MSseqLimit in |- *. simpl in |- *. intros H. apply d_zero_imp_eq. apply not_ap_imp_eq. red in |- *. intro H1. set (H2 := recip_ap_zero IR (a[-d]b) H1) in *. set (H3 := Archimedes' (OneR[/] a[-d]b[//]H1)) in *. elim H3. intros n H4. set (H6 := less_transitive_unfolded IR ([1][/] a[-d]b[//]H1) ( nring n) (nring n[+][1]) H4 (nring_less_succ IR n)) in *. elim H. intros H5 H7. elim (H5 (S (S n)) (ap_symmetric_unfolded IR [0] ([0][+][1][+][1]) (less_imp_ap IR [0] ([0][+][1][+][1]) (less_transitive_unfolded IR [0] ([0][+][1]) ( [0][+][1][+][1]) (less_plusOne IR [0]) (less_plusOne IR (ZeroR[+][1])))))). intros x H8. elim (H7 (S (S n)) (ap_symmetric_unfolded IR [0] ([0][+][1][+][1]) (less_imp_ap IR [0] ([0][+][1][+][1]) (less_transitive_unfolded IR [0] ([0][+][1]) ( [0][+][1][+][1]) (less_plusOne IR [0]) (less_plusOne IR ([0][+][1]:IR)))))). intros y H9. set (H10 := H9 (Nat.max y x)) in *. set (H11 := H8 (Nat.max x y)) in *. simpl in |- *. set (H12 := H11 (nz x y)) in *. set (H13 := H10 (nz y x)) in *. set (H14 := ap_symmetric_unfolded IR [0] ([0][+][1][+][1]) (less_imp_ap IR [0] ([0][+][1][+][1]) (less_transitive_unfolded IR [0] ([0][+][1]) ( [0][+][1][+][1]) (less_plusOne IR [0]) (less_plusOne IR ([0][+][1]))))) in *. cut ((seq (Nat.max x y)[-d]a)[+](seq (Nat.max y x)[-d]b)[<] nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[+] nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)). intro H15. cut (nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[+] nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[<=] (seq (Nat.max x y)[-d]a)[+](seq (Nat.max y x)[-d]b)). rewrite -> leEq_def in |- *. intro H16. auto. cut (nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[+] nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)[<=] a[-d]b). intro H16. apply leEq_transitive with (a[-d]b). exact H16. astepr ((seq (Nat.max x y)[-d]a)[+](seq (Nat.max x y)[-d]b)). astepr ((a[-d]seq (Nat.max x y))[+](seq (Nat.max x y)[-d]b)). apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. astepl ((seq (Nat.max x y)[-d]b)[+](a[-d]seq (Nat.max x y))). astepr ((seq (Nat.max x y)[-d]b)[+](seq (Nat.max x y)[-d]a)). apply plus_resp_eq. simpl in |- *. apply d_com. apply plus_resp_eq. apply d_wd. cut (Nat.max x y = Nat.max y x -> seq (Nat.max x y)[=]seq (Nat.max y x)). intro H17. apply H17. apply Nat.max_comm. intro H17. rewrite H17. apply eq_reflexive. astepl ((Two:IR)[*]nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)). astepl (nexp IR (S n) ([1][/] [0][+][1][+][1][//]H14)). astepl (([1][/] [0][+][1][+][1][//]H14)[^]S n). astepl ([1][/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14). apply leEq_transitive with ([1][/] nring (S n)[//] ap_symmetric_unfolded IR [0] (nring (S n)) (less_imp_ap IR [0] (nring (S n)) (pos_Snring IR n))). apply leEq_transitive with ([1][/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14). 2: apply less_leEq. 2: set (Hn := bin_less_un) in *. 2: generalize Hn. 2: simpl in |- *. 2: intro Hn'. 2: apply Hn'. apply recip_resp_leEq. apply nexp_resp_pos. astepr (Two:IR). apply pos_two. apply eq_imp_leEq. apply eq_reflexive_unfolded. apply shift_div_leEq. apply (pos_Snring IR n). apply shift_leEq_mult' with H1. 2: apply less_leEq. 2: apply H6. cut ([0][<]a[-d]b or a[-d]b[<][0]). intro H16. elim H16. intro H17. exact H17. intro H17. set (H18 := ax_d_nneg X (cms_d (c:=X))) in *. generalize H18. unfold nneg in |- *. intro H19. set (H20 := H19 (CPsMetricSpace_is_CPsMetricSpace X) a b) in *. rewrite -> leEq_def in H20. set (H21 := H20 H17) in *. intuition. apply ap_imp_less. apply ap_symmetric_unfolded. exact H1. astepl ((OneR[/] [0][+][1][+][1][//]H14)[^]S n). astepl (OneR[^]S n[/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14). astepl (OneR[/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H14). astepl ((OneR[+][1])[*] ([1][/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14)). apply mult_cancel_lft with (OneR[/] [0][+][1][+][1][//]H14). apply div_resp_ap_zero_rev. apply ap_symmetric_unfolded. apply less_imp_ap. apply pos_one. astepr (([1][/] [0][+][1][+][1][//]H14)[*]([0][+][1][+][1])[*] ([1][/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14)). astepr (OneR[*] ([1][/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14)). astepr (OneR[/] ([0][+][1][+][1])[^]S (S n)[//]nexp_resp_ap_zero (S (S n)) H14). astepr (OneR[*][1][/] ([0][+][1][+][1])[*]([0][+][1][+][1])[^]S n[//] mult_resp_ap_zero IR ([0][+][1][+][1]) (([0][+][1][+][1])[^]S n) H14 (nexp_resp_ap_zero (S n) H14)). astepr ([1][*][1][/] ([0][+][1][+][1])[^]S (S n)[//] nexp_resp_ap_zero (S (S n)) H14). rational. astepr (([1][/] [0][+][1][+][1][//]H14)[*]Two[*] nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)). astepr (([1][/] [0][+][1][+][1][//]H14)[*]([0][+][1][+][1])[*] nexp IR (S (S n)) ([1][/] [0][+][1][+][1][//]H14)). apply mult_wdr. 3: apply plus_resp_less_both. 3: exact H12. 3: exact H13. astepr (([1][/] [0][+][1][+][1][//]H14)[^]S (S n)). apply eq_symmetric_unfolded. apply nexp_distr_recip. astepl ([1][+][1][/] ([0][+][1][+][1])[^]S (S n)[//] nexp_resp_ap_zero (S (S n)) H14). 2: rational. astepl ([0][+][1][+][1][/] ([0][+][1][+][1])[^]S (S n)[//] nexp_resp_ap_zero (S (S n)) H14). rstepr ([0][+][1][+][1][/] ([0][+][1][+][1])[*]([0][+][1][+][1])[^]S n[//] mult_resp_ap_zero IR ([0][+][1][+][1]) (([0][+][1][+][1])[^]S n) H14 (nexp_resp_ap_zero (S n) H14)). astepl ([0][+][1][+][1][/] ([0][+][1][+][1])[*]([0][+][1][+][1])[^]S n[//] mult_resp_ap_zero IR ([0][+][1][+][1]) (([0][+][1][+][1])[^]S n) H14 (nexp_resp_ap_zero (S n) H14)). apply eq_reflexive_unfolded. Qed. End Limitt. corn-8.20.0/metrics/CPMSTheory.v000066400000000000000000000473471473720167500163670ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.metrics.Prod_Sub. Section lists. (** ** Lists *) (** List and membership of lists are used in the definition of %''totally bounded''% #"totally bounded"#. Note that we use the Leibniz equality in the definition of [MSmember], and not the setoid equality. So we are really talking about finite sets of representants, instead of finite subsetoids. This seems to make the proofs a bit easier. *) Fixpoint MSmember (X : CSetoid) (x : X) (l : list X) {struct l} : CProp := match l with | nil => False | cons y m => MSmember X x m or x = y end. Arguments MSmember [X]. Definition to_IR (P : IR -> CProp) : subcsetoid_crr IR P -> IR. Proof. intro a. case a. intros b C. exact b. Defined. Definition from_IR (P : IR -> CProp) (x : IR) (H : P x) : subcsetoid_crr IR P. Proof. set (H0 := Build_subcsetoid_crr IR P) in *. set (H1 := H0 x H) in *. exact H1. Defined. Definition list_IR (P : IR -> CProp) : list (SubPsMetricSpace IR_as_CPsMetricSpace P) -> list IR. Proof. intro l. induction l as [| a l Hrecl]. apply (@nil IR). apply (cons (to_IR P a) Hrecl). Defined. Lemma is_P : forall (P : IR -> CProp) (l : list (SubPsMetricSpace IR_as_CPsMetricSpace P)) (x : IR), pred_wd IR P -> member x (list_IR P l) -> P x. Proof. intros P l x Q. induction l as [| a l Hrecl]. simpl in |- *. intuition. case a. simpl in |- *. intros b C D. elim D. intro E. apply Hrecl. exact E. unfold pred_wd in Q. intro H. apply Q with b. exact C. apply eq_symmetric_unfolded. exact H. Qed. (** If a real number is element of a list in the above defined sense, it is an element of the list in the sense of [member], that uses the setoid equality. *) Lemma member1 : forall (P : IR -> CProp) (x0 : subcsetoid_crr IR P) (l : list (SubPsMetricSpace IR_as_CPsMetricSpace P)), MSmember (X:=SubPsMetricSpace IR_as_CPsMetricSpace P) x0 l -> member (to_IR P x0) (list_IR P l). Proof. intros P x0 l. induction l as [| a l Hrecl]. simpl in |- *. intuition. simpl in |- *. intros H. elim H. intro H1. left. apply Hrecl. exact H1. simpl in |- *. intros. right. rewrite b. intuition. Qed. (** The image under a certain mapping of an element of a list $l$ #l# is member of the list of images of elements of $l$ #l#. *) Lemma map_member : forall (X Z : CPsMetricSpace) (f : X -> Z) (l : list X) (m : X), MSmember m l -> MSmember (f m) (map f l). Proof. intros X Z f l m. induction l as [| a l Hrecl]. simpl in |- *. auto. simpl in |- *. intro H. elim H. intro H1. left. apply Hrecl. exact H1. intro H1. right. rewrite H1. intuition. Qed. End lists. Section loc_and_bound. (** ** Pseudo Metric Space theory *) Definition Re_co_do (X Z : CSetoid) (f : CSetoid_fun X Z) : X -> Build_SubCSetoid Z (fun y : Z => {x : X | f x[=]y}). Proof. intros x. exists (f x). exists x. apply eq_reflexive. Defined. Lemma Re_co_do_strext : forall (X Z : CSetoid) (f : CSetoid_fun X Z), fun_strext (Re_co_do X Z f). Proof. intros X Z f. unfold fun_strext in |- *. intros x y. simpl in |- *. apply (csf_strext X Z f). Qed. Definition re_co_do (X Z : CSetoid) (f : CSetoid_fun X Z) : CSetoid_fun X (Build_SubCSetoid Z (fun y : Z => {x : X | f x[=]y})) := Build_CSetoid_fun X (Build_SubCSetoid Z (fun y : Z => {x : X | f x[=]y})) (Re_co_do X Z f) (Re_co_do_strext X Z f). Lemma re_co_do_well_def : forall (X Z : CSetoid) (f : CSetoid_fun X Z), pred_wd Z (fun y : Z => {x : X | f x[=]y}). Proof. intros X Z f. unfold pred_wd in |- *. intros x y. intros H0 H1. elim H0. intros x0 H3. exists x0. astepr x. exact H3. Qed. Arguments MSmember [X]. (** Again we see that the image under a certain mapping of an element of a list $l$ #l# is member of the list of images of elements of $l$ #l#. *) Lemma map_member' : forall (X Z : CPsMetricSpace) (f : CSetoid_fun X Z) (l : list X) (m : X), MSmember m l -> MSmember (X:=Build_SubCSetoid Z (fun y : Z => {x0 : X | f x0[=]y})) (re_co_do X Z f m) (map (re_co_do X Z f) l). Proof. intros X Z f l m. induction l as [| a l Hrecl]. simpl in |- *. auto. simpl in |- *. intro H. elim H. intro H1. left. apply Hrecl. exact H1. intro H1. right. rewrite H1. intuition. Qed. Definition bounded (X : CPsMetricSpace) : CProp := {n : IR | forall x y : X, x[-d]y[<=]n}. Definition MStotally_bounded (X : CPsMetricSpace) : CProp := forall n : nat, {l : list X | forall x : X, {y : X | MSmember y l | x[-d]y[<=]one_div_succ n}}. (** Total boundedness is preserved under uniformly continuous mappings. *) Arguments SubPsMetricSpace [X]. Lemma unicon_resp_totallybounded : forall (X Z : CPsMetricSpace) (f : CSetoid_fun X Z) (H : uni_continuous'' f), MStotally_bounded X -> MStotally_bounded (SubPsMetricSpace (fun y : Z => {x : X | f x[=]y})). Proof. intros X Z f. unfold uni_continuous'' in |- *. intro H. unfold MStotally_bounded in |- *. intro H1. intro n. elim H. intros mod_ H3. elim (H1 (mod_ n)). intros l H2. simpl in |- *. exists (map (re_co_do X Z f) l). intros x. elim x. intros r H5. elim H5. intros k H6. elim (H2 k). intros m H7 H8. exists (re_co_do X Z f m). 2: simpl in |- *. 2: astepl (f k[-d]f m). 2: apply H3. 2: exact H8. apply map_member'. exact H7. Qed. Lemma MStotallybounded_totallybounded : forall (P : IR -> CProp) (H0 : {x : IR | P x}), pred_wd IR P -> MStotally_bounded (SubPsMetricSpace (X:=IR_as_CPsMetricSpace) P) -> totally_bounded P. Proof. intros P H0 Q. unfold MStotally_bounded in |- *. intro H. unfold totally_bounded in |- *. constructor. exact H0. intros e H1. set (H2 := OneR[/] e[//]ap_symmetric_unfolded IR [0] e (less_imp_ap IR [0] e H1)) in *. unfold AbsSmall in |- *. set (H3 := Archimedes H2) in *. elim H3. intros m H4. elim H with m. intros l H5. exists (list_IR P l). intro x. apply is_P. exact Q. intros x H6. generalize H5. simpl in |- *. intro H7. elim (H7 (from_IR P x H6)). intros x0 H8 H9. exists (to_IR P x0). apply member1. exact H8. split. generalize H9. unfold dIR_as_CSetoid_fun in |- *. unfold dIR in |- *. case x0. intros. simpl in |- *. apply leEq_transitive with ([--](one_div_succ (R:=IR) m)). apply inv_resp_leEq. unfold one_div_succ in |- *. apply shift_div_leEq. unfold Snring in |- *. apply less_transitive_unfolded with (nring (R:=IR) m). apply less_leEq_trans with H2. unfold H2 in |- *. apply recip_resp_pos. exact H1. exact H4. simpl in |- *. astepl (nring (R:=IR) m[+][0]). apply plus_resp_less_lft. apply pos_one. apply shift_leEq_mult' with (ap_symmetric_unfolded IR [0] e (less_imp_ap IR [0] e H1)). exact H1. apply leEq_transitive with (nring (R:=IR) m). exact H4. unfold Snring in |- *. simpl in |- *. apply less_leEq. astepl (nring (R:=IR) m[+][0]). apply plus_resp_less_lft. apply pos_one. apply inv_cancel_leEq. astepr (one_div_succ (R:=IR) m). apply leEq_transitive with (AbsIR (x[-]scs_elem)). apply inv_leEq_AbsIR. unfold AbsIR in |- *. simpl in |- *. generalize H10. simpl in |- *. intuition. generalize H9. case x0. intros x1 Q0 H10. simpl in |- *. apply leEq_transitive with (one_div_succ (R:=IR) m). generalize H10. unfold dIR_as_CSetoid_fun in |- *. unfold dIR in |- *. simpl in |- *. intro H11. apply leEq_transitive with (AbsIR (x[-]x1)). apply leEq_AbsIR. unfold AbsIR in |- *. simpl in |- *. exact H11. unfold one_div_succ in |- *. apply shift_div_leEq. unfold Snring in |- *. apply less_transitive_unfolded with (nring (R:=IR) m). apply less_leEq_trans with H2. unfold H2 in |- *. apply recip_resp_pos. exact H1. exact H4. simpl in |- *. astepl (nring (R:=IR) m[+][0]). apply plus_resp_less_lft. apply pos_one. apply shift_leEq_mult' with (ap_symmetric_unfolded IR [0] e (less_imp_ap IR [0] e H1)). exact H1. apply leEq_transitive with (nring (R:=IR) m). exact H4. unfold Snring in |- *. simpl in |- *. apply less_leEq. astepl (nring (R:=IR) m[+][0]). apply plus_resp_less_lft. apply pos_one. Qed. (** Every image under an uniformly continuous function of an totally bounded pseudo metric space has an infimum and a supremum. *) Lemma infimum_exists : forall (X : CPsMetricSpace) (f : CSetoid_fun X IR_as_CPsMetricSpace), uni_continuous'' f -> MStotally_bounded X -> forall x : X, {z : IR | set_glb_IR (fun y : IR_as_CPsMetricSpace => {x : X | f x[=]y}) z}. Proof. intros X f H0 H1 x. apply totally_bounded_has_glb. apply MStotallybounded_totallybounded. 3: apply unicon_resp_totallybounded. 3: exact H0. 3: exact H1. 2: unfold IR_as_CPsMetricSpace in |- *. 2: simpl in |- *. 2: apply re_co_do_well_def. exists (f x). exists x. apply eq_reflexive. Qed. Lemma supremum_exists : forall (X : CPsMetricSpace) (f : CSetoid_fun X IR_as_CPsMetricSpace), uni_continuous'' f -> MStotally_bounded X -> forall x : X, {z : IR | set_lub_IR (fun y : IR_as_CPsMetricSpace => {x : X | f x[=]y}) z}. Proof. intros X f H0 H1 x. apply totally_bounded_has_lub. apply MStotallybounded_totallybounded. 3: apply unicon_resp_totallybounded. 3: exact H0. 3: exact H1. 2: unfold IR_as_CPsMetricSpace in |- *. 2: simpl in |- *. 2: apply re_co_do_well_def. exists (f x). exists x. apply eq_reflexive. Qed. (** A subspace $P$#P# of a pseudo metric space $X$#X# is said to be located if for all elements $x$#x# of $X$#X# there exists an infimum for the distance between $x$#x# and the elements of $P$#P#. *) Arguments dsub'_as_cs_fun [X]. Definition located (X : CPsMetricSpace) (P : X -> CProp) := forall (x : X) (r : SubPsMetricSpace P), {z : IR | set_glb_IR (fun v : IR => {y : SubPsMetricSpace P | dsub'_as_cs_fun P x y[=]v}) z}. Arguments located [X]. Definition located' (X : CPsMetricSpace) (P : X -> CProp) := forall (x : X) (y : SubPsMetricSpace P), {z : IR | set_glb_IR (fun v : IR => {y : SubPsMetricSpace P | x[-d]from_SubPsMetricSpace X P y[=]v}) z}. Arguments located' [X]. Lemma located_imp_located' : forall (X : CPsMetricSpace) (P : X -> CProp), located P -> located' P. Proof. intros X P. unfold located in |- *. unfold located' in |- *. intros H x y. set (H0 := H x y) in *. elim H0. intros x0 H1. exists x0. unfold dsub' in H1. generalize H1. unfold dsub'_as_cs_fun in |- *. unfold dsub' in |- *. simpl in |- *. unfold set_glb_IR in |- *. intros. split. intro x1. elim H2. intros a b H3. apply a. elim H3. intros. exists x2. astepl (x[-d]from_SubPsMetricSpace X P x2). exact p. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. intros e H3. elim H2. intros. set (H8 := b e H3) in *. elim H8. intros. exists x1. elim p. intros. exists x2. astepl (from_SubPsMetricSpace X P x2[-d]x). exact p0. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. exact q. Qed. (** Every totally bounded pseudo metric space is located. *) Lemma MStotally_bounded_imp_located : forall (X : CPsMetricSpace) (P : X -> CProp), MStotally_bounded (SubPsMetricSpace P) -> located P. Proof. intros X P H. unfold located in |- *. intros x y. set (H0 := infimum_exists (SubPsMetricSpace P) (dsub'_as_cs_fun P x)) in *. set (H1 := H0 (dsub'_uni_continuous'' X P x) H y) in *. elim H1. intros x0 H2. elim H2. intros. simpl in |- *. exists x0. unfold set_glb_IR in |- *. split. intro x1. intro H6. apply a. generalize b. intros. elim H6. intros. exists x2. simpl in |- *. exact p. intros e H3. set (H7 := b e H3) in *. apply H7. Qed. (** For all $x$#x# in a pseudo metric space $X$#X#, for all located subspaces $P$#P# of $X$#X#, [Floc] chooses for a given natural number $n$#n# an $y$#y# in $P$#P# such that: $d(x,y)\leq \mbox{inf}\{d(x,p)|p \in P\}+(n+1)^{-1}$ #d(x,y) ≤ inf{d(x,p)| pϵP} + (n+1)-1#. [Flocfun] does (almost) the same, but has a different type. This enables one to use the latter as an argument of [map]. *) Definition Floc (X : CPsMetricSpace) (P : X -> CProp) (H0 : located' P) (H2 : SubPsMetricSpace P) (n : nat) (x : X) : {y : SubPsMetricSpace P | {z : IR | set_glb_IR (fun v : IR => {y : SubPsMetricSpace P | x[-d]from_SubPsMetricSpace X P y[=]v}) z | x[-d]from_SubPsMetricSpace X P y[<=]z[+]one_div_succ n}}. Proof. rename H2 into y. unfold located' in H0. set (H1 := H0 x y) in *. elim H1. intros x0 H3. unfold set_glb_IR in H3. elim H3. intros H4 H5. elim (H5 (one_div_succ n)). intros x1 H6 H7. elim H6. intros x2 H8. eapply existT with (P := fun y0 : SubPsMetricSpace P => {z : IR | set_glb_IR (fun v : IR => {y1 : SubPsMetricSpace P | x[-d]from_SubPsMetricSpace X P y1[=]v}) z | x[-d]from_SubPsMetricSpace X P y0[<=]z[+]one_div_succ n}) (x := x2). eapply exist2T with (P := fun z : IR => set_glb_IR (fun v : IR => {y1 : SubPsMetricSpace P | x[-d]from_SubPsMetricSpace X P y1[=]v}) z) (Q := fun z : IR => x[-d]from_SubPsMetricSpace X P x2[<=]z[+]one_div_succ n) (x := x0). unfold set_glb_IR in |- *. apply H3. apply shift_leEq_plus'. astepl (x1[-]x0). apply less_leEq. apply H7. apply one_div_succ_pos. Defined. Definition Flocfun (X : CPsMetricSpace) (P : X -> CProp) (H0 : located' P) (H2 : SubPsMetricSpace P) (n : nat) : X -> SubPsMetricSpace P. Proof. intros. set (H1 := Floc X P H0 H2 n X0) in *. elim H1. intros. exact x. Defined. (** A located subset $P$#P# of a totally bounded pseudo metric space $X$ #X# is totally bounded. *) Lemma locatedsub_totallybounded_imp_totallyboundedsub : forall (X : CPsMetricSpace) (P : X -> CProp), SubPsMetricSpace P -> located' P -> MStotally_bounded X -> MStotally_bounded (SubPsMetricSpace P). Proof. intros X P y H0. unfold MStotally_bounded in |- *. intros H1 n. elim (H1 (3 * n + 2)). intros l H2. unfold located' in H0. simpl in |- *. exists (map (Flocfun X P H0 y (3 * n + 2)) l). simpl in |- *. intro x. elim (H2 (from_SubPsMetricSpace X P x)). intros xj xjl H3. exists (Flocfun X P H0 y (n + (n + (n + 0)) + 2) xj). apply map_member with (f := Flocfun X P H0 y (n + (n + (n + 0)) + 2)). exact xjl. unfold Flocfun in |- *. unfold sigT_rec in |- *. unfold sigT_rect in |- *. case Floc. intros. elim s. intros x2 p0 q. generalize H3. case x. intros xn Pn H4. apply leEq_transitive with ((xn[-d]xj)[+](xj[-d]from_SubPsMetricSpace X P x0)). case x0. intros. simpl in |- *. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. astepr (one_div_succ (R:=IR) (n + (n + (n + 0)) + 2)[+] (one_div_succ (n + (n + (n + 0)) + 2)[+] one_div_succ (n + (n + (n + 0)) + 2))). apply plus_resp_leEq_both. apply H4. apply leEq_transitive with (x2[+]one_div_succ (n + (n + (n + 0)) + 2)). apply leEq_transitive with (xj[-d]from_SubPsMetricSpace X P x0). apply eq_imp_leEq. apply csbf_wd_unfolded. intuition. intuition. exact q. apply plus_resp_leEq. apply leEq_transitive with (from_SubPsMetricSpace X P x[-d]xj). unfold set_glb_IR in p0. elim p0. intros. apply a. unfold SubPsMetricSpace in |- *. simpl in |- *. exists x. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. apply H3. astepr ([1][*]one_div_succ (R:=IR) n). astepr (((Three:IR)[/] Three:IR[//]three_ap_zero IR)[*]one_div_succ n). astepl (one_div_succ (n + (n + (n + 0)) + 2)[+] (Two:IR)[*]one_div_succ (n + (n + (n + 0)) + 2)). astepl (OneR[*]one_div_succ (n + (n + (n + 0)) + 2)[+] (Two:IR)[*]one_div_succ (n + (n + (n + 0)) + 2)). astepl ((OneR[+]Two)[*]one_div_succ (n + (n + (n + 0)) + 2)). stepl ((Three:IR)[*]one_div_succ (n + (n + (n + 0)) + 2)). 2: apply mult_wdl. 2: rational. astepr ((Three:IR)[*]([1][/] Three[//]three_ap_zero IR)[*]one_div_succ n). astepr ((Three:IR)[*](([1][/] Three[//]three_ap_zero IR)[*]one_div_succ n)). apply mult_wdr. unfold one_div_succ in |- *. unfold Snring in |- *. simpl in |- *. astepr (OneR[/] (Three:IR)[*](nring n[+][1])[//] mult_resp_ap_zero IR Three (nring n[+][1]) (three_ap_zero IR) (nringS_ap_zero IR n)). apply eq_div. apply mult_wdr. astepl (Three[*]nring (R:=IR) n[+]Three[*][1]). simpl in |- *. astepr (nring (R:=IR) (n + (n + (n + 0)))[+]Two[+][1]). astepr (nring (R:=IR) n[+]nring (n + (n + 0))[+]Two[+][1]). astepr (nring (R:=IR) n[+](nring n[+]nring (n + 0))[+]Two[+][1]). 3: apply mult_wdl. 3: rational. 2: simpl in |- *. 2: rational. astepr (nring (R:=IR) n[+](nring n[+]nring (n + 0))[+]Two[+][1]). astepr (nring (R:=IR) n[+](nring n[+]nring (n + 0))[+](Two[+][1])). astepl ((ZeroR[+][1][+][1][+][1])[*]nring n[+]([0][+][1][+][1][+][1])). simpl in |- *. astepl (ZeroR[+][1][+][1][+][1][+]([0][+][1][+][1][+][1])[*]nring n). astepr (ZeroR[+][1][+][1][+][1][+](nring n[+](nring n[+]nring (n + 0)))). apply plus_resp_eq. astepr (nring (R:=IR) n[+](nring n[+](nring n[+]nring 0))). simpl in |- *. rational. Qed. (** Here are some definitions that could come in handy: *) Definition MSCauchy_seq (X : CPsMetricSpace) (seq : nat -> X) : CProp := forall n : nat, {m : nat | forall i j : nat, m <= i -> m <= j -> seq i[-d]seq j[<=]one_div_succ n}. Arguments MSseqLimit' [X]. Definition MSComplete (X : CPsMetricSpace) : CProp := forall seq : nat -> X, MSCauchy_seq X seq -> {lim : X | MSseqLimit' seq lim}. (** A compact pseudo metric space is a pseudo metric space which is complete and totally bounded. *) Definition MSCompact (X : CPsMetricSpace) : CProp := MSComplete X and MStotally_bounded X. (** A subset $P$#P# is %\emph{open}%#open# if for all $x$#x# in $P$#P# there exists an open sphere with centre $x$#x# that is contained in $P$#P#. *) Definition open (X : CPsMetricSpace) (P : X -> CProp) := forall x : X, P x -> {e : IR | [0][<]e and (forall z : X, z[-d]x[<]e -> P z)}. Arguments open [X]. (** The operator [infima] gives the infimum for the distance between an element $x$#x# of a located pseudo metric space $X$#X# and the elements of a subspace $P$#P# of $X$#X#. *) Definition infima (X : CPsMetricSpace) (P : X -> CProp) (H : located' P) (a : SubPsMetricSpace P) : X -> IR. Proof. intros H0. unfold located' in H. elim (H H0 a). intros. exact x. Defined. Arguments infima [X]. (** A non-empty totally bounded sub-pseudo-metric-space $P$#P# is said to be %\emph{well contained}% #well contained# in an open sub-pseudo-metric-space $Q$#Q# if $Q$#Q# contains all points that are in some sense close to $P$#P#. *) Definition well_contained (X : CPsMetricSpace) (P Q : X -> CProp) (a : SubPsMetricSpace P) := open Q -> forall H : MStotally_bounded (SubPsMetricSpace P), {r : IR | [0][<]r | forall q : X, infima P (located_imp_located' X P (MStotally_bounded_imp_located X P H)) a q[<=]r -> Q q}. End loc_and_bound. corn-8.20.0/metrics/CPseudoMSpaces.v000066400000000000000000000170211473720167500172320ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.Intervals. (** * Metric Spaces (traditional) *) Section Relations. (** ** Relations necessary for Pseudo Metric Spaces and Metric Spaces %\begin{convention}% Let [A : CSetoid], [d : (CSetoid_bin_fun A A IR)]. %\end{convention}% *) Variable A : CSetoid. Variable d : CSetoid_bin_fun A A IR. Set Implicit Arguments. Unset Strict Implicit. Definition com : Prop := forall x y : A, d x y[=]d y x. Definition nneg : Prop := forall x y : A, [0][<=]d x y. Definition pos_imp_ap : CProp := forall x y : A, [0][<]d x y -> x[#]y. Definition tri_ineq : Prop := forall x y z : A, d x z[<=]d x y[+]d y z. Set Strict Implicit. Unset Implicit Arguments. Definition diag_zero (X : CSetoid) (d : CSetoid_bin_fun X X IR) : Prop := forall x : X, d x x[=][0]. Definition apdiag_imp_grzero (X : CSetoid) (d : CSetoid_bin_fun X X IR) : CProp := forall x y : X, x[#]y -> [0][<]d x y. End Relations. Section Definition_PsMS0. (** ** Definition of Pseudo Metric Space *) (** A pseudo metric space consists of a setoid and a %''pseudo metric''% #"pseudo metric"#, also called %''distance''% #"distance"#, a binairy function that fulfils certain properties. *) Record is_CPsMetricSpace (A : CSetoid) (d : CSetoid_bin_fun A A IR) : Type := {ax_d_com : com d; ax_d_nneg : nneg d; ax_d_pos_imp_ap : pos_imp_ap d; ax_d_tri_ineq : tri_ineq d}. Record CPsMetricSpace : Type := {cms_crr :> CSetoid; cms_d : CSetoid_bin_fun cms_crr cms_crr IR; cms_proof : is_CPsMetricSpace cms_crr cms_d}. End Definition_PsMS0. Arguments cms_d {c}. Infix "[-d]" := cms_d (at level 68, left associativity). Section PsMS_axioms. (** ** Pseudo Metric Space axioms %\begin{convention}% Let [A] be a pseudo metric space. %\end{convention}% *) Variable A : CPsMetricSpace. Lemma CPsMetricSpace_is_CPsMetricSpace : is_CPsMetricSpace A cms_d. Proof cms_proof A. Lemma d_com : com (cms_d (c:=A)). Proof. elim CPsMetricSpace_is_CPsMetricSpace. auto. Qed. Lemma d_nneg : nneg (cms_d (c:=A)). Proof. elim CPsMetricSpace_is_CPsMetricSpace. auto. Qed. Lemma d_pos_imp_ap : pos_imp_ap (cms_d (c:=A)). Proof. elim CPsMetricSpace_is_CPsMetricSpace. auto. Qed. Lemma d_tri_ineq : tri_ineq (cms_d (c:=A)). Proof. elim CPsMetricSpace_is_CPsMetricSpace. auto. Qed. End PsMS_axioms. Section PsMS_basics. (** ** Pseudo Metric Space basics %\begin{convention}% Let [Y] be a pseudo metric space. %\end{convention}% *) Variable Y : CPsMetricSpace. Lemma rev_tri_ineq : forall a b c : cms_crr Y, AbsSmall (b[-d]c) ((a[-d]b)[-](a[-d]c)). Proof. intros. unfold AbsSmall in |- *. split. apply shift_leEq_minus. apply shift_plus_leEq'. unfold cg_minus in |- *. cut ([--][--](b[-d]c)[=]b[-d]c). intros. apply leEq_wdr with ((a[-d]b)[+](b[-d]c)). apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. apply eq_symmetric_unfolded. apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. exact H. apply cg_inv_inv. astepr (c[-d]b). apply shift_minus_leEq. apply shift_leEq_plus'. apply shift_minus_leEq. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. (** Instead of taking [pos_imp_ap] as axiom, we could as well have taken [diag_zero]. *) Lemma diag_zero_imp_pos_imp_ap : forall (X : CSetoid) (d : CSetoid_bin_fun X X IR), diag_zero X d -> pos_imp_ap d. Proof. intros X d. unfold diag_zero in |- *. unfold pos_imp_ap in |- *. intros H. intros x y H0. cut (x[#]x or x[#]y). intro H1. elim H1. cut (Not (x[#]x)). intros H3 H4. set (H5 := H3 H4) in *. intuition. apply ap_irreflexive_unfolded. intro H2. exact H2. apply (csbf_strext X X IR d). astepl ZeroR. apply less_imp_ap. exact H0. Qed. Lemma pos_imp_ap_imp_diag_zero : forall (X : CSetoid) (d : CSetoid_bin_fun X X IR), pos_imp_ap d -> nneg d -> diag_zero X d. Proof. intros X d. unfold pos_imp_ap in |- *. unfold nneg in |- *. intros H H6. unfold diag_zero in |- *. intro x. apply not_ap_imp_eq. red in |- *. intro H0. set (H1 := less_conf_ap IR (d x x) [0]) in *. generalize H1. unfold Iff in |- *. intro H2. elim H2. intros H3 H4. set (H5 := H3 H0) in *. elim H5. generalize H6. intros H7 H8. set (H9 := H7 x x) in *. rewrite -> leEq_def in H9. set (H10 := H9 H8) in *. exact H10. intro H7. set (H8 := H x x) in *. set (H9 := H8 H7) in *. set (H10 := ap_irreflexive_unfolded X x H9) in *. exact H10. Qed. Lemma is_CPsMetricSpace_diag_zero : forall (X : CSetoid) (d : CSetoid_bin_fun X X IR), com d /\ tri_ineq d /\ nneg d /\ diag_zero X d -> is_CPsMetricSpace X d. Proof. intros X d H. elim H. intros H1 H2. elim H2. intros H3 H4. elim H4. intros H5 H6. apply (Build_is_CPsMetricSpace X d H1 H5 (diag_zero_imp_pos_imp_ap X d H6) H3). Qed. End PsMS_basics. Section Zerof. (** ** Zero function *) (** Every setoid forms with the binary function that always returns zero, a pseudo metric space. *) Definition zero_fun (X : CSetoid) (x y : X) : IR := ZeroR. Lemma zero_fun_strext : forall X : CSetoid, bin_fun_strext X X IR (zero_fun X). Proof. intro X. unfold bin_fun_strext in |- *. unfold zero_fun in |- *. intros x1 x2 y1 y2 Z. set (H := ap_irreflexive_unfolded IR [0] Z) in *. intuition. Qed. Definition Zero_fun (X : CSetoid) := Build_CSetoid_bin_fun X X IR (zero_fun X) (zero_fun_strext X). Lemma zero_fun_com : forall X : CSetoid, com (Zero_fun X). Proof. intro X. unfold com in |- *. intros x y. unfold Zero_fun in |- *. simpl in |- *. unfold zero_fun in |- *. intuition. Qed. Lemma zero_fun_nneg : forall X : CSetoid, nneg (Zero_fun X). Proof. intro X. unfold nneg in |- *. intros x y. unfold Zero_fun in |- *. simpl in |- *. unfold zero_fun in |- *. apply eq_imp_leEq. intuition. Qed. Lemma zero_fun_pos_imp_ap : forall X : CSetoid, pos_imp_ap (Zero_fun X). Proof. intro X. unfold pos_imp_ap in |- *. intros x y. unfold Zero_fun in |- *. simpl in |- *. unfold zero_fun in |- *. intro Z. set (H := less_irreflexive IR [0] Z) in *. intuition. Qed. Lemma zero_fun_tri_ineq : forall X : CSetoid, tri_ineq (Zero_fun X). Proof. intro X. unfold tri_ineq in |- *. intros x y z. unfold Zero_fun in |- *. simpl in |- *. unfold zero_fun in |- *. apply eq_imp_leEq. rational. Qed. Definition zf_is_CPsMetricSpace (X : CSetoid) := Build_is_CPsMetricSpace X (Zero_fun X) (zero_fun_com X) ( zero_fun_nneg X) (zero_fun_pos_imp_ap X) (zero_fun_tri_ineq X). Definition zf_as_CPsMetricSpace (X : CSetoid) := Build_CPsMetricSpace X (Zero_fun X) (zf_is_CPsMetricSpace X). End Zerof. corn-8.20.0/metrics/ContFunctions.v000066400000000000000000000424411473720167500172140ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.metrics.CPseudoMSpaces. Section Continuous_functions. (** ** Continuous functions, uniformly continuous functions and Lipschitz functions %\begin{convention}% Let [A] and [B] be pseudo metric spaces. %\end{convention}% *) Variable A : CPsMetricSpace. Variable B : CPsMetricSpace. (** We will look at some notions of continuous functions. *) Definition continuous (f : CSetoid_fun A B) : CProp := forall (x : A) (n : nat) (H : Two[#][0]), {m : nat | forall y : A, x[-d]y[<]([1][/] Two[//]H)[^]m -> f x[-d]f y[<]([1][/] Two[//]H)[^]n}. Definition continuous' (f : CSetoid_fun A B) : CProp := forall (x : A) (n : nat), {m : nat | forall y : A, x[-d]y[<=]one_div_succ m -> f x[-d]f y[<=]one_div_succ n}. Definition uni_continuous (f : CSetoid_fun A B) : CProp := forall (n : nat) (H : Two[#][0]), {m : nat | forall x y : A, x[-d]y[<]([1][/] Two:IR[//]H)[^]m -> f x[-d]f y[<]([1][/] Two:IR[//]H)[^]n}. Definition uni_continuous' (f : CSetoid_fun A B) : CProp := forall n : nat, {m : nat | forall x y : A, x[-d]y[<=]one_div_succ m -> f x[-d]f y[<=]one_div_succ n}. Definition uni_continuous'' (f : CSetoid_fun A B) : CProp := {mds : nat -> nat | forall (n : nat) (x y : A), x[-d]y[<=]one_div_succ (mds n) -> f x[-d]f y[<=]one_div_succ n}. Definition lipschitz (f : CSetoid_fun A B) : CProp := {n : nat | forall x y : A, f x[-d]f y[<=]Two[^]n[*](x[-d]y)}. Definition lipschitz' (f : CSetoid_fun A B) : CProp := {n : nat | forall x y : A, f x[-d]f y[<=]nring n[*](x[-d]y)}. Definition lipschitz_c (f : CSetoid_fun A B) (C : IR) : CProp := forall x1 x2 : A, f x1 [-d] f x2 [<=] C [*] (x1 [-d] x2). End Continuous_functions. Arguments continuous [A B]. Arguments uni_continuous [A B]. Arguments lipschitz [A B]. Arguments continuous' [A B]. Arguments uni_continuous' [A B]. Arguments uni_continuous'' [A B]. Arguments lipschitz' [A B]. Arguments lipschitz_c [A B]. Section Lemmas. (* begin hide *) Lemma nexp_power : forall p : nat, nexp IR p Two[=]nring (power p 2). Proof. simple induction p. simpl in |- *. algebra. intros n H. astepr (nring (R:=IR) (power n 2 * 2)). astepr (nring (R:=IR) (power n 2)[*]Two). astepl (nexp IR n Two[*]Two). apply mult_wdl. exact H. Qed. (* end hide *) Lemma continuous_imp_continuous' : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), continuous f -> continuous' f. Proof. intros A B f. unfold continuous in |- *. intro H. unfold continuous' in |- *. intros x n. set (H1 := two_ap_zero IR) in *. elim H with x (S n) H1. intros p H2. exists (power p 2). intro y. intro H3. apply leEq_transitive with ((OneR[/] Two:IR[//]H1)[^]S n). apply less_leEq. apply H2. apply leEq_less_trans with (one_div_succ (R:=IR) (power p 2)). exact H3. unfold one_div_succ in |- *. astepr (OneR[^]p[/] (Two:IR)[^]p[//]nexp_resp_ap_zero p H1). astepr (OneR[/] (Two:IR)[^]p[//]nexp_resp_ap_zero p H1). apply recip_resp_less. apply nexp_resp_pos. apply pos_two. unfold Snring in |- *. apply less_wdr with (nexp IR p Two[+][1]). apply shift_less_plus. apply minusOne_less. astepl (OneR[+]nexp IR p Two). stepr (OneR[+]nring (power p 2)). apply plus_resp_eq. apply nexp_power. simpl in |- *. algebra. apply less_leEq. astepl (OneR[^]S n[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H1). astepl (OneR[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H1). unfold one_div_succ in |- *. unfold Snring in |- *. apply bin_less_un. Qed. Lemma continuous'_imp_continuous : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), continuous' f -> continuous f. Proof. intros A B f. unfold continuous' in |- *. intro H. unfold continuous in |- *. intros x n H0. elim H with x (power n 2). intros p H1. exists (S p). intros y H2. apply leEq_less_trans with (one_div_succ (R:=IR) (power n 2)). apply H1. apply less_leEq. apply less_transitive_unfolded with (([1][/] Two:IR[//]H0)[^]S p). exact H2. unfold one_div_succ in |- *. astepl (OneR[^]S p[/] (Two:IR)[^]S p[//]nexp_resp_ap_zero (S p) H0). astepl (OneR[/] (Two:IR)[^]S p[//]nexp_resp_ap_zero (S p) H0). apply recip_resp_less. unfold Snring in |- *. apply nring_pos. intuition. apply nat_less_bin_nexp. unfold one_div_succ in |- *. unfold Snring in |- *. astepr (OneR[^]n[/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H0). astepr (OneR[/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H0). apply recip_resp_less. apply nexp_resp_pos. apply pos_two. astepr (nring (R:=IR) (power n 2)[+][1]). astepl (nexp IR n Two[+][0]). apply plus_resp_leEq_less. apply eq_imp_leEq. apply nexp_power. apply pos_one. Qed. Lemma uni_continuous_imp_uni_continuous' : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), uni_continuous f -> uni_continuous' f. Proof. intros A B f. unfold uni_continuous in |- *. intro H. unfold uni_continuous' in |- *. intro n. set (H0 := two_ap_zero IR) in *. elim H with (S n) H0. intros p H1. exists (power p 2). intros x y H2. apply less_leEq. apply less_transitive_unfolded with ((OneR[/] Two:IR[//]H0)[^]S n). apply H1. apply leEq_less_trans with (one_div_succ (R:=IR) (power p 2)). exact H2. unfold one_div_succ in |- *. unfold Snring in |- *. astepr (OneR[^]p[/] (Two:IR)[^]p[//]nexp_resp_ap_zero p H0). astepr (OneR[/] (Two:IR)[^]p[//]nexp_resp_ap_zero p H0). apply recip_resp_less. apply nexp_resp_pos. apply pos_two. astepr (nring (R:=IR) (power p 2)[+][1]). astepl (nexp IR p Two[+][0]). apply plus_resp_leEq_less. apply eq_imp_leEq. apply nexp_power. apply pos_one. unfold one_div_succ in |- *. unfold Snring in |- *. astepl (OneR[^]S n[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H0). astepl (OneR[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H0). apply bin_less_un. Qed. Lemma uni_continuous'_imp_uni_continuous : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), uni_continuous' f -> uni_continuous f. Proof. intros A B f. unfold uni_continuous' in |- *. intro H. unfold uni_continuous in |- *. intros n H0. elim H with (power n 2). intros p H1. exists (S p). intros x y H2. apply leEq_less_trans with (one_div_succ (R:=IR) (power n 2)). apply H1. apply less_leEq. apply less_transitive_unfolded with ((OneR[/] Two:IR[//]H0)[^]S p). exact H2. unfold one_div_succ in |- *. unfold Snring in |- *. astepl (OneR[^]S p[/] (Two:IR)[^]S p[//]nexp_resp_ap_zero (S p) H0). astepl (OneR[/] (Two:IR)[^]S p[//]nexp_resp_ap_zero (S p) H0). apply bin_less_un. unfold one_div_succ in |- *. astepr (OneR[^]n[/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H0). astepr (OneR[/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H0). apply recip_resp_less. apply nexp_resp_pos. apply pos_two. unfold Snring in |- *. astepr (nring (R:=IR) (power n 2)[+][1]). astepl (nexp IR n Two[+][0]). apply plus_resp_leEq_less. apply eq_imp_leEq. apply nexp_power. apply pos_one. Qed. Lemma uni_continuous'_imp_uni_continuous'' : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), uni_continuous' f -> uni_continuous'' f. Proof. intros A B f. unfold uni_continuous' in |- *. unfold uni_continuous'' in |- *. apply choice with (P := fun n m : nat => forall x y : A, x[-d]y[<=]one_div_succ m -> f x[-d]f y[<=]one_div_succ n). Qed. Lemma lipschitz_imp_lipschitz' : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), lipschitz f -> lipschitz' f. Proof. intros A B f. unfold lipschitz in |- *. intro H. unfold lipschitz' in |- *. elim H. intros n H0. elim Archimedes with ((Two:IR)[^]n). intros m H1. exists m. intros x y. apply leEq_transitive with ((Two:IR)[^]n[*](x[-d]y)). apply H0. apply mult_resp_leEq_rht. exact H1. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma lipschitz'_imp_lipschitz : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), lipschitz' f -> lipschitz f. Proof. intros A B f. unfold lipschitz' in |- *. intro H. unfold lipschitz in |- *. elim H. intros m H1. exists m. intros x y. apply leEq_transitive with (nring m[*](x[-d]y)). apply H1. apply mult_resp_leEq_rht. case m. simpl in |- *. apply less_leEq. apply pos_one. intro n. astepl (Snring IR n). apply less_leEq. apply nat_less_bin_nexp. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma lip_c_imp_lip : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B) (C : IR), lipschitz_c f C -> lipschitz' f. Proof. unfold lipschitz_c. unfold lipschitz'. intros. assert ({n : nat| C [<=] nring n}). apply Archimedes. destruct X as [n H1]. exists n. intros. assert (f x[-d]f y [<=] C[*](x[-d]y)). apply H. apply leEq_transitive with (C[*](x[-d]y)); auto. apply mult_resp_leEq_rht; auto. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. (** Every uniformly continuous function is continuous and every Lipschitz function is uniformly continuous. *) Lemma uni_continuous_imp_continuous : forall (C D : CPsMetricSpace) (f : CSetoid_fun C D), uni_continuous f -> continuous f. Proof. intros C D F. red in |- *. unfold uni_continuous in |- *. intros H0 n u H3. elim H0 with u H3. intros. exists x. intro y. apply p. Qed. Lemma lipschitz_imp_uni_continuous : forall (C D : CPsMetricSpace) (f : CSetoid_fun C D), lipschitz f -> uni_continuous f. Proof. red in |- *. unfold lipschitz in |- *. intros C D f H n H0. elim H. intros. exists (n + x). intros x0 y H1. apply leEq_less_trans with (Two[^]x[*](x0[-d]y)). apply p. apply mult_cancel_less with (([1][/] Two:IR[//]H0)[^]x). apply nexp_resp_pos. apply div_resp_pos. apply pos_two. apply pos_one. apply less_wdr with (([1][/] Two:IR[//]H0)[^](n + x)). apply less_wdl with (x0[-d]y). exact H1. astepr (Two[^]x[*](x0[-d]y)[*]([1][^]x[/] Two[^]x[//]nexp_resp_ap_zero x H0)). astepr (Two[^]x[*](x0[-d]y)[*]([1][/] Two[^]x[//]nexp_resp_ap_zero x H0)). rational. apply eq_symmetric_unfolded. astepr (([1][/] Two:IR[//]H0)[^](n + x)). apply nexp_plus. Qed. End Lemmas. Section Identity. (** ** Identity *) (** The identity function is Lipschitz. Hence it is uniformly continuous and continuous. *) Lemma id_is_lipschitz : forall X : CPsMetricSpace, lipschitz (id_un_op X). Proof. intro X. red in |- *. simpl in |- *. exists 0. intros x y. astepr (OneR[*](x[-d]y)). astepr (x[-d]y). apply leEq_reflexive. Qed. Lemma id_is_uni_continuous : forall X : CPsMetricSpace, uni_continuous (id_un_op X). Proof. intro X. apply lipschitz_imp_uni_continuous. apply id_is_lipschitz. Qed. Lemma id_is_continuous : forall X : CPsMetricSpace, continuous (id_un_op X). Proof. intro X. apply uni_continuous_imp_continuous. apply id_is_uni_continuous. Qed. End Identity. Section Constant. (** ** Constant functions %\begin{convention}% Let [B] and [X] be pseudo metric spaces. %\end{convention}% *) (** Any constant function is Lipschitz. Hence it is uniformly continuous and continuous. *) Variable B : CPsMetricSpace. Variable X : CPsMetricSpace. Lemma const_fun_is_lipschitz : forall b : B, lipschitz (Const_CSetoid_fun X B b). Proof. intro b. red in |- *. exists 1. intros. astepr (Two[^]1[*](x[-d]y)). astepr (Two[*](x[-d]y)). unfold Const_CSetoid_fun in |- *. rewrite -> leEq_def in |- *. red in |- *. simpl in |- *. intros H. apply (ap_irreflexive_unfolded B b). apply (ax_d_pos_imp_ap B (cms_d (c:=B)) (CPsMetricSpace_is_CPsMetricSpace B)). apply leEq_less_trans with (([0][+][1][+][1])[*](x[-d]y)). astepr ((Two:IR)[*](x[-d]y)). apply shift_leEq_mult' with (two_ap_zero IR). apply pos_two. astepl ZeroR. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. exact H. Qed. Lemma const_fun_is_uni_continuous : forall b : B, uni_continuous (Const_CSetoid_fun X B b). Proof. intro b. apply lipschitz_imp_uni_continuous. apply const_fun_is_lipschitz. Qed. Lemma const_fun_is_continuous : forall b : B, continuous (Const_CSetoid_fun X B b). Proof. intro b. apply uni_continuous_imp_continuous. apply const_fun_is_uni_continuous. Qed. End Constant. Section Composition. (** ** Composition %\begin{convention}% Let [B],[C] and [X] be pseudo metric spaces. Let [f : (CSetoid_fun X B)] and [g : (CSetoid_fun B C)]. %\end{convention}% *) (** The composition of two Lipschitz/uniformly continous/continuous functions is again Lipschitz/uniformly continuous/continuous. *) Variable X : CPsMetricSpace. Variable B : CPsMetricSpace. Variable f : CSetoid_fun X B. Variable C : CPsMetricSpace. Variable g : CSetoid_fun B C. Lemma comp_resp_lipschitz : lipschitz f -> lipschitz g -> lipschitz (compose_CSetoid_fun X B C f g). Proof. unfold lipschitz in |- *. intros H H0. elim H. intros x H1. elim H0. intros x0 H2. exists (x + x0). simpl in |- *. intros x1 y. apply leEq_transitive with ((Two:IR)[^]x0[*](f x1[-d]f y)). apply H2. astepr (Two[^](x + x0)[*](x1[-d]y)). astepr (Two[^]x[*]Two[^]x0[*](x1[-d]y)). astepr (Two[^]x0[*]Two[^]x[*](x1[-d]y)). rstepr (Two[^]x0[*](Two[^]x[*](x1[-d]y))). apply mult_resp_leEq_lft. apply H1. apply nexp_resp_nonneg. apply less_leEq. apply pos_two. Qed. Lemma comp_resp_uni_continuous : uni_continuous f -> uni_continuous g -> uni_continuous (compose_CSetoid_fun X B C f g). Proof. unfold uni_continuous in |- *. intros H H0. simpl in |- *. intros n H1. elim H0 with n H1. intro x. intro H3. elim H with x H1. intro x0. intro H4. exists x0. intros x1 y H5. apply H3. apply H4. exact H5. Qed. Lemma comp_resp_continuous : continuous f -> continuous g -> continuous (compose_CSetoid_fun X B C f g). Proof. unfold continuous in |- *. intros H H0 x n H1. simpl in |- *. elim H0 with (f x) n H1. intros. elim H with x x0 H1. intros. exists x1. intros y H2. apply p. apply p0. exact H2. Qed. End Composition. Section Limit. (** ** Limit *) Definition MSseqLimit (X : CPsMetricSpace) (seq : nat -> X) (lim : X) : CProp := forall (n : nat) (H : Two[#][0]), {N : nat | forall m : nat, N <= m -> seq m[-d]lim[<]([1][/] Two:IR[//]H)[^]n}. Arguments MSseqLimit [X]. Definition MSseqLimit' (X : CPsMetricSpace) (seq : nat -> X) (lim : X) : CProp := forall n : nat, {N : nat | forall m : nat, N <= m -> seq m[-d]lim[<=]one_div_succ n}. Arguments MSseqLimit' [X]. Lemma MSseqLimit_imp_MSseqLimit' : forall (X : CPsMetricSpace) (seq : nat -> X) (lim : X), MSseqLimit seq lim -> MSseqLimit' seq lim. Proof. intros X seq lim. unfold MSseqLimit in |- *. intro H. unfold MSseqLimit' in |- *. intro n. set (H2 := two_ap_zero IR) in *. elim H with (S n) H2. intros p H3. exists p. intros m H4. apply less_leEq. apply less_transitive_unfolded with ((OneR[/] Two:IR[//]H2)[^]S n). apply H3. exact H4. unfold one_div_succ in |- *. unfold Snring in |- *. astepl (OneR[^]S n[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H2). astepl (OneR[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H2). apply bin_less_un. Qed. Lemma MSseqLimit'_imp_MSseqLimit : forall (X : CPsMetricSpace) (seq : nat -> X) (lim : X), MSseqLimit' seq lim -> MSseqLimit seq lim. Proof. intros X seq lim. unfold MSseqLimit' in |- *. intro H. unfold MSseqLimit in |- *. intros n H0. elim H with (power n 2). intros p H1. exists p. intros m H2. apply leEq_less_trans with (one_div_succ (R:=IR) (power n 2)). apply H1. exact H2. unfold one_div_succ in |- *. astepr (OneR[^]n[/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H0). astepr (OneR[/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H0). apply recip_resp_less. apply nexp_resp_pos. apply pos_two. unfold Snring in |- *. simpl in |- *. apply less_wdr with (nexp IR n Two[+][1]). apply shift_less_plus. astepl (nexp IR n Two[-][1]). apply minusOne_less. astepl (OneR[+]nexp IR n Two). astepr (OneR[+]nring (power n 2)). apply plus_resp_eq. apply nexp_power. Qed. Definition seqcontinuous' (A B : CPsMetricSpace) (f : CSetoid_fun A B) : CProp := forall (seq : nat -> A) (lim : A), MSseqLimit' seq lim -> MSseqLimit' (fun m : nat => f (seq m)) (f lim). Arguments seqcontinuous' [A B]. Lemma continuous'_imp_seqcontinuous' : forall (A B : CPsMetricSpace) (f : CSetoid_fun A B), continuous' f -> seqcontinuous' f. Proof. intros A B f. unfold continuous' in |- *. intro H. unfold seqcontinuous' in |- *. intros seq lim. unfold MSseqLimit' in |- *. intro H0. intro n. elim H with lim n. intros p H1. elim H0 with p. intros q H2. exists q. intro m. intro H3. astepl (f lim[-d]f (seq m)). apply H1. astepl (seq m[-d]lim). apply H2. exact H3. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. End Limit. corn-8.20.0/metrics/Equiv.v000066400000000000000000000342501473720167500155100ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.metrics.IR_CPMSpace. Section equivalent. (** ** Equivalent Pseudo Metric Spaces *) (** We say that two pseudo metric spaces are equivalent, when there exists a bijective, structure-preserving function between them. *) Definition equivalent_psmetric (X : CSetoid) (d0 d1 : CSetoid_bin_fun X X IR) : CProp := (is_CPsMetricSpace X d0 and is_CPsMetricSpace X d1) and {n : nat | forall x y : X, d0 x y[<=]nring (S n)[*]d1 x y} and {n : nat | forall x y : X, d1 x y[<=]nring (S n)[*]d0 x y}. Definition isopsmetry (X Y : CPsMetricSpace) (f : CSetoid_fun X Y) := bijective f and equivalent_psmetric X (cms_d (c:=X)) (compose_CSetoid_bin_un_fun X Y IR (cms_d (c:=Y)) f). Arguments isopsmetry [X Y]. Lemma isopsmetry_imp_bij : forall (X Y : CPsMetricSpace) (f : CSetoid_fun X Y), isopsmetry f -> bijective f. Proof. intros X Y f H. unfold isopsmetry in H. elim H. intuition. Qed. Lemma isopsmetry_imp_lipschitz : forall (X Y : CPsMetricSpace) (f : CSetoid_fun X Y), isopsmetry f -> lipschitz' f. Proof. intros X Y f. unfold isopsmetry in |- *. unfold equivalent_psmetric in |- *. intro H. elim H. clear H. intros H0 H1. elim H1. clear H1. intros H10 H11. elim H11. clear H11. intros H110 H111. unfold lipschitz' in |- *. elim H111. clear H111. simpl in |- *. intros n H111'. exists (S n). simpl in |- *. exact H111'. Qed. Lemma id_is_isopsmetry : forall X : CPsMetricSpace, isopsmetry (id_un_op X). Proof. intro X. unfold isopsmetry in |- *. split. apply id_is_bij. unfold equivalent_psmetric in |- *. simpl in |- *. unfold id_un_op in |- *. split. split. apply CPsMetricSpace_is_CPsMetricSpace. apply Build_is_CPsMetricSpace. unfold com in |- *. intros x y. simpl in |- *. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. unfold nneg in |- *. simpl in |- *. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. unfold pos_imp_ap in |- *. simpl in |- *. apply ax_d_pos_imp_ap. apply CPsMetricSpace_is_CPsMetricSpace. unfold tri_ineq in |- *. simpl in |- *. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. split. exists 0. intros x y. simpl in |- *. astepr (OneR[*](x[-d]y)). astepr (x[-d]y). apply leEq_reflexive. exists 0. intros x y. simpl in |- *. astepr (OneR[*](x[-d]y)). astepr (x[-d]y). apply leEq_reflexive. Qed. Lemma comp_resp_isopsmetry : forall (X Y Z : CPsMetricSpace) (f : CSetoid_fun X Y) (g : CSetoid_fun Y Z), isopsmetry f -> isopsmetry g -> isopsmetry (compose_CSetoid_fun X Y Z f g). Proof. intros X Y Z f g. unfold isopsmetry in |- *. intros H0 H1. elim H0. intros H00 H01. elim H1. intros H10 H11. split. apply comp_resp_bij. exact H00. exact H10. unfold equivalent_psmetric in |- *. split. split. apply CPsMetricSpace_is_CPsMetricSpace. unfold equivalent_psmetric in H01. elim H01. intros H010 H011. elim H010. intros H0100 H0101. elim H11. intros H110 H111. elim H110. intros H1100 H1101. apply Build_is_CPsMetricSpace. unfold com in |- *. simpl in |- *. intros x y. elim H1101. intros. generalize ax_d_com. unfold com in |- *. simpl in |- *. intro H2. apply H2. unfold nneg in |- *. intros x y. simpl in |- *. elim H1101. intros. generalize ax_d_nneg. unfold nneg in |- *. simpl in |- *. intro H2. apply H2. elim H1101. intros. generalize ax_d_pos_imp_ap. unfold pos_imp_ap in |- *. simpl in |- *. intros H2 x y H3. set (H5 := csf_strext X Y f) in *. generalize H5. unfold fun_strext in |- *. intro H6. apply H6. auto. unfold tri_ineq in |- *. simpl in |- *. intros x y z. elim H1101. intros. generalize ax_d_tri_ineq. unfold tri_ineq in |- *. simpl in |- *. intro H2. apply H2. split. unfold equivalent_psmetric in H01. elim H01. intros H010 H011. elim H011. intros H0110 H0111. unfold equivalent_psmetric in H11. elim H11. intros H110 H111. elim H111. intros H1110 H1111. elim H0110. simpl in |- *. intros n H0110'. elim H1110. simpl in |- *. intros m H1110'. exists (S m * S n). intros x y. apply leEq_transitive with ((nring n[+][1])[*](f x[-d]f y)). apply H0110'. apply leEq_transitive with ((nring n[+][1])[*](nring m[+][1])[*](g (f x)[-d]g (f y))). astepr ((nring n[+][1])[*]((nring m[+][1])[*](g (f x)[-d]g (f y)))). apply mult_resp_leEq_lft. apply H1110'. apply less_leEq. astepr (nring (R:=IR) (S n)). apply pos_nring_S. apply mult_resp_leEq_rht. apply leEq_transitive with (nring (R:=IR) (S m * S n)). apply eq_imp_leEq. astepl (nring (R:=IR) (S n)[*](nring m[+][1])). astepl (nring (R:=IR) (S n)[*]nring (S m)). astepl (nring (R:=IR) (S m)[*]nring (S n)). astepl (nring (R:=IR) (S m * S n)). apply eq_reflexive. astepr (nring (R:=IR) (S (S m * S n))). apply less_leEq. apply nring_less_succ. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. unfold equivalent_psmetric in H01. elim H01. intros H010 H011. elim H011. intros H0110 H0111. unfold equivalent_psmetric in H11. elim H11. intros H110 H111. elim H111. intros H1110 H1111. elim H0111. simpl in |- *. intros n H0111'. elim H1111. simpl in |- *. intros m H1111'. exists (S m * S n). intros x y. apply leEq_transitive with (nring (R:=IR) (S m)[*](f x[-d]f y)). apply H1111'. apply leEq_transitive with (nring (S m)[*]nring (S n)[*](x[-d]y)). astepr (nring (S m)[*](nring (S n)[*](x[-d]y))). apply mult_resp_leEq_lft. apply H0111'. apply less_leEq. apply pos_nring_S. apply mult_resp_leEq_rht. apply leEq_transitive with (nring (R:=IR) (S m * S n)). apply eq_imp_leEq. astepl (nring (R:=IR) (S m * S n)). apply eq_reflexive. astepr (nring (R:=IR) (S (S m * S n))). apply less_leEq. apply nring_less_succ. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma inv_isopsmetry : forall (X Y : CPsMetricSpace) (f : CSetoid_fun X Y) (H : isopsmetry f), isopsmetry (Inv f (isopsmetry_imp_bij X Y f H)). Proof. intros X Y f H. unfold isopsmetry in |- *. split. apply Inv_bij. unfold isopsmetry in H. unfold equivalent_psmetric in H. elim H. intros. elim b. intros. elim a0. intros. elim b0. intros. unfold equivalent_psmetric in |- *. split. split. apply CPsMetricSpace_is_CPsMetricSpace. apply Build_is_CPsMetricSpace. unfold com in |- *. intros x y. unfold Inv in |- *. simpl in |- *. apply ax_d_com. exact a1. unfold nneg in |- *. intros x y. unfold Inv in |- *. simpl in |- *. apply ax_d_nneg. exact a1. unfold pos_imp_ap in |- *. intros x y. unfold Inv in |- *. simpl in |- *. intro H7. set (H6 := inv_strext) in *. set (H5 := H6 X Y f (isopsmetry_imp_bij X Y f (a, ((a1, b1), (a2, b2))))) in *. generalize H5. unfold fun_strext in |- *. intros H4. apply H4. set (H8 := ax_d_pos_imp_ap) in *. set (H9 := H8 X (cms_d (c:=X)) a1) in *. generalize H9. unfold pos_imp_ap in |- *. intro H10. apply H10. apply H7. unfold tri_ineq in |- *. unfold Inv in |- *. simpl in |- *. set (H3 := ax_d_tri_ineq) in *. set (H4 := H3 X (cms_d (c:=X)) a1) in *. generalize H4. unfold tri_ineq in |- *. intro H5. intros x y z. apply H5. split. elim b2. simpl in |- *. intros m P. exists m. intros y0 y1. elim a. intros. unfold surjective in b3. elim (b3 y0). intros x0 b4. elim (b3 y1). intros x1 b5. astepl (f x0[-d]y1). astepl (f x0[-d]f x1). apply leEq_transitive with (nring (S m)[*](x0[-d]x1)). simpl in |- *. apply P. simpl in |- *. apply eq_imp_leEq. apply mult_wdr. set (H4 := csbf_wd) in *. set (H5 := H4 X X IR (cms_d (c:=X))) in *. generalize H5. unfold bin_fun_wd in |- *. intro H6. apply H6. cut (invfun f (isopsmetry_imp_bij X Y f ((a3, b3), (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x0)[=] invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) y0). intros. astepr (invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x0)). apply eq_symmetric. apply inv2. set (H10 := csf_wd) in *. set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))))) in *. generalize H7. unfold fun_wd in |- *. unfold Inv in |- *. simpl in |- *. intro H8. apply H8. exact b4. cut (invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x1)[=] invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) y1). intros. astepr (invfun f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))) (f x1)). apply eq_symmetric. apply inv2. set (H10 := csf_wd) in *. set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (a3, b3) (pair (a1, b1) (pair a2 (existT (fun n : nat => forall x y : X, f x[-d]f y[<=](nring n[+][1])[*](x[-d]y)) m P))))))) in *. generalize H7. unfold fun_wd in |- *. unfold Inv in |- *. simpl in |- *. intro H8. apply H8. exact b5. elim a2. simpl in |- *. intros m P. exists m. intros y0 y1. elim a. intros. unfold surjective in b3. elim (b3 y0). intros x0 b4. elim (b3 y1). intros x1 b5. astepr ((nring m[+][1])[*](f x0[-d]f x1)). apply leEq_transitive with (x0[-d]x1). 2: apply P. apply eq_imp_leEq. set (H4 := csbf_wd) in *. set (H5 := H4 X X IR (cms_d (c:=X))) in *. generalize H5. unfold bin_fun_wd in |- *. intro H6. apply H6. cut (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) y0[=] invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x0)). intros. astepl (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x0)). apply inv2. set (H10 := csf_wd) in *. set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))))) in *. generalize H7. unfold fun_wd in |- *. unfold Inv in |- *. simpl in |- *. intro H8. apply H8. apply eq_symmetric. exact b4. cut (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) y1[=] invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x1)). intros. astepl (invfun f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))) (f x1)). apply inv2. set (H10 := csf_wd) in *. set (H7 := H10 Y X (Inv f (isopsmetry_imp_bij X Y f (pair (pair a3 b3) (pair (pair a1 b1) (pair (existT (fun n : nat => forall x y : X, x[-d]y[<=](nring n[+][1])[*](f x[-d]f y)) m P) b2)))))) in *. generalize H7. unfold fun_wd in |- *. unfold Inv in |- *. simpl in |- *. intro H8. apply H8. apply eq_symmetric. exact b5. Qed. Definition MSequivalent (X Y : CPsMetricSpace) := {f : CSetoid_fun X Y | isopsmetry f}. (** Not all pseudo metric spaces are equivalent: *) Lemma MSequivalent_discr : Not (MSequivalent IR_as_CPsMetricSpace (zf_as_CPsMetricSpace IR)). Proof. red in |- *. unfold MSequivalent in |- *. unfold isopsmetry in |- *. unfold equivalent_psmetric in |- *. intros H0. elim H0. intros f H0'. elim H0'. intros H1 H2. elim H2. intros H3 H4. elim H4. intros H5 H6. elim H5. intros n. simpl in |- *. unfold zero_fun in |- *. unfold dIR in |- *. intro H7. cut (OneR[<=][0]). rewrite -> leEq_def in |- *. intro H8. set (H9 := H8 (pos_one IR)) in *. exact H9. astepr ((nring (R:=IR) n[+][1])[*][0]). astepl (ABSIR ([1][-][0])). apply H7. unfold ABSIR in |- *. astepl (Max [--]([1][-][0]) ([1][-][0])). astepl (Max [--]([1][-][0]) [1]). apply leEq_imp_Max_is_rht. astepl ([--]OneR). astepl (ZeroR[-][1]). apply shift_minus_leEq. astepr (Two:IR). apply less_leEq. apply pos_two. apply Max_comm. Qed. End equivalent. corn-8.20.0/metrics/IR_CPMSpace.v000066400000000000000000000330101473720167500163750ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.metrics.ContFunctions. Section Reals. (** ** Real numbers *) (** %\begin{convention}% Let [X] be a pseudo metric space. %\end{convention}% *) (** The real numbers with the usual distance form a pseudo metric space. *) Definition dIR (x y : IR) : IR := ABSIR (x[-]y). Lemma bin_fun_strext_dIR : bin_fun_strext IR IR IR dIR. Proof. unfold bin_fun_strext in |- *. unfold dIR in |- *. intros. apply cg_minus_strext. apply un_op_strext_unfolded with AbsIR. auto. Qed. Definition dIR_as_CSetoid_fun := Build_CSetoid_bin_fun IR IR IR dIR bin_fun_strext_dIR. Lemma dIR_nneg : forall x y : IR, [0][<=]dIR_as_CSetoid_fun x y. Proof. unfold dIR_as_CSetoid_fun in |- *. unfold dIR in |- *. simpl in |- *. intros. apply AbsIR_nonneg. Qed. Lemma dIR_com : forall x y : IR, dIR_as_CSetoid_fun x y[=]dIR_as_CSetoid_fun y x. Proof. unfold dIR_as_CSetoid_fun in |- *. unfold dIR in |- *. simpl in |- *. exact AbsIR_minus. Qed. Lemma dIR_pos_imp_ap : forall x y : IR, [0][<]dIR_as_CSetoid_fun x y -> x[#]y. Proof. unfold dIR_as_CSetoid_fun in |- *. simpl in |- *. intros x y H. cut (x[#]x or y[#]x). intro H0. apply ap_symmetric_unfolded. elim H0. intro H1. cut False. intuition. cut (Not (x[#]x)). intro H2. exact (H2 H1). apply ap_irreflexive_unfolded. intro H1. exact H1. apply bin_fun_strext_dIR. astepr ZeroR. apply ap_symmetric_unfolded. apply less_imp_ap. exact H. unfold dIR in |- *. astepr (ABSIR ZeroR). apply eq_symmetric_unfolded. apply AbsIRz_isz. apply AbsIR_wd. apply eq_symmetric_unfolded. apply cg_minus_correct. Qed. (* begin hide *) Lemma IR_tri_ineq : forall a b : IR, AbsIR (a[+]b)[<=]AbsIR a[+]AbsIR b. Proof. intros a b. astepr (AbsIR (AbsIR a[+]AbsIR b)). apply AbsSmall_imp_AbsIR. unfold AbsSmall in |- *. split. apply inv_cancel_leEq. astepr (AbsIR (AbsIR a[+]AbsIR b)). astepl ([--]a[+][--]b). astepr (AbsIR a[+]AbsIR b). apply plus_resp_leEq_both. apply inv_leEq_AbsIR. apply inv_leEq_AbsIR. apply eq_symmetric_unfolded. apply AbsIR_eq_x. astepl (ZeroR[+]ZeroR). apply plus_resp_leEq_both. apply AbsIR_nonneg. apply AbsIR_nonneg. astepr (AbsIR a[+]AbsIR b). apply plus_resp_leEq_both. apply leEq_AbsIR. apply leEq_AbsIR. apply eq_symmetric_unfolded. apply AbsIR_eq_x. astepl (ZeroR[+]ZeroR). apply plus_resp_leEq_both. apply AbsIR_nonneg. apply AbsIR_nonneg. apply AbsIR_eq_x. astepl (ZeroR[+]ZeroR). apply plus_resp_leEq_both. apply AbsIR_nonneg. apply AbsIR_nonneg. Qed. (* end hide *) Lemma dIR_tri_ineq : tri_ineq dIR_as_CSetoid_fun. Proof. unfold tri_ineq in |- *. intros x y z. unfold dIR_as_CSetoid_fun in |- *. unfold dIR in |- *. simpl in |- *. astepl (ABSIR (x[+]([--]y[+]y)[-]z)). astepl (ABSIR (x[+][--]y[+](y[-]z))). astepl (ABSIR (x[-]y[+](y[-]z))). apply IR_tri_ineq. apply AbsIR_wd. rational. apply AbsIR_wd. rational. Qed. Definition IR_dIR_is_CPsMetricSpace := Build_is_CPsMetricSpace IR dIR_as_CSetoid_fun dIR_com dIR_nneg dIR_pos_imp_ap dIR_tri_ineq. Definition IR_as_CPsMetricSpace := Build_CPsMetricSpace IR dIR_as_CSetoid_fun IR_dIR_is_CPsMetricSpace. Variable X : CPsMetricSpace. Lemma rev_tri_ineq' : forall a b c : X, cms_d (c:=IR_as_CPsMetricSpace) (a[-d]b) (a[-d]c)[<=]b[-d]c. Proof. simpl in |- *. unfold dIR in |- *. intros a b c. apply AbsSmall_imp_AbsIR. apply rev_tri_ineq. Qed. (** A pseudo metric is Lipschitz. Hence it is uniformly continuous and continuous. *) Lemma d_is_lipschitz : forall a : X, lipschitz (projected_bin_fun X X IR_as_CPsMetricSpace (cms_d (c:=X)) a). Proof. intro a. red in |- *. simpl in |- *. exists 0. intros x y. astepr (OneR[*](x[-d]y)). astepr (x[-d]y). apply rev_tri_ineq'. Qed. Lemma d_is_uni_continuous : forall a : X, uni_continuous (projected_bin_fun X X IR_as_CPsMetricSpace (cms_d (c:=X)) a). Proof. intro a. apply lipschitz_imp_uni_continuous. apply d_is_lipschitz. Qed. Lemma d_is_continuous : forall a : X, continuous (projected_bin_fun X X IR_as_CPsMetricSpace (cms_d (c:=X)) a). Proof. intro a. apply uni_continuous_imp_continuous. apply d_is_uni_continuous. Qed. End Reals. Section Addition. (** ** Addition of continuous functions *) (** The sum of two Lipschitz/uniformly continous/continuous functions is again Lipschitz/uniformly continuous/continuous. *) Lemma plus_resp_lipschitz : forall (X : CPsMetricSpace) (f g : CSetoid_fun X IR_as_CPsMetricSpace) (H : lipschitz f) (H1 : lipschitz g), lipschitz (compose_CSetoid_bin_fun X IR_as_CPsMetricSpace IR_as_CPsMetricSpace f g (csg_op (c:=IR))). Proof. red in |- *. unfold lipschitz in |- *. intros X f g H H1. elim H. intros x H2. elim H1. intros x0 H3. exists (Nat.max x x0 + 1). intros x1 y. astepl (dIR (f x1[+]g x1) (f y[+]g y)). unfold dIR in |- *. unfold dIR in |- *. astepl (ABSIR (g x1[-]g y[+](f x1[-]f y))). apply leEq_transitive with (ABSIR (g x1[-]g y)[+]ABSIR (f x1[-]f y)). apply IR_tri_ineq. apply leEq_transitive with ((Two:IR)[^]x0[*](x1[-d]y)[+]ABSIR (f x1[-]f y)). apply plus_resp_leEq. astepl (g x1[-d]g y). apply H3. apply leEq_transitive with (Two[^]x0[*](x1[-d]y)[+]Two[^]x[*](x1[-d]y)). apply plus_resp_leEq_lft. astepl (f x1[-d]f y). apply H2. astepr ((Two:IR)[*]Two[^]Nat.max x x0[*](x1[-d]y)). apply leEq_transitive with (Two[^]Nat.max x x0[*](x1[-d]y)[+]Two[^]Nat.max x x0[*](x1[-d]y)). apply plus_resp_leEq_both. apply mult_resp_leEq_rht. apply great_nexp_resp_le. apply less_leEq. apply one_less_two. intuition. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. apply mult_resp_leEq_rht. apply great_nexp_resp_le. apply less_leEq. apply one_less_two. intuition. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. apply eq_imp_leEq. rational. astepl (Two[^]1[*]Two[^]Nat.max x x0[*](x1[-d]y)). 2: apply AbsIR_wd. apply mult_wdl. astepl ((Two:IR)[^](Nat.max x x0 + 1)). 2: astepl ((Two:IR)[^]Nat.max x x0[*]Two[^]1). 2: apply mult_commutes. astepr ((Two:IR)[^](Nat.max x x0 + 1)). rational. rational. Qed. Lemma plus_resp_uni_continuous : forall (X : CPsMetricSpace) (f g : CSetoid_fun X IR_as_CPsMetricSpace) (H : uni_continuous f) (H1 : uni_continuous g), uni_continuous (compose_CSetoid_bin_fun X IR_as_CPsMetricSpace IR_as_CPsMetricSpace f g (csg_op (c:=IR))). Proof. unfold uni_continuous in |- *. unfold IR_as_CPsMetricSpace in |- *. unfold dIR_as_CSetoid_fun in |- *. unfold dIR in |- *. intros X f g H H0. intros n H1. elim (H (S n) H1). intros x H2. elim (H0 (S n) H1). intros x0 H3. exists (Nat.max x x0). intros x1 y H6. astepl (ABSIR (f x1[-]f y[+](g x1[-]g y))). apply leEq_less_trans with (ABSIR (f x1[-]f y)[+]ABSIR (g x1[-]g y)). apply IR_tri_ineq. apply less_leEq_trans with ((OneR[/] Two:IR[//]H1)[^]S n[+]ABSIR (g x1[-]g y)). apply plus_resp_less_rht. generalize H2. simpl in |- *. intro H7. apply H7. generalize H6. intro H8. apply less_leEq_trans with (nexp IR (Nat.max x x0) ([1][/] [0][+][1][+][1][//]H1)). apply H8. 3: simpl in |- *. astepl (nexp IR (Nat.max x x0) ([1][/] Two:IR[//]H1)). astepr (nexp IR x ([1][/] Two:IR[//]H1)). astepl ((OneR[/] Two:IR[//]H1)[^]Nat.max x x0). astepr ((OneR[/] Two:IR[//]H1)[^]x). apply small_nexp_resp_le. apply shift_leEq_div. apply pos_two. astepl ZeroR. apply less_leEq. apply pos_one. apply shift_div_leEq. apply pos_two. astepr (Two:IR). apply less_leEq. apply one_less_two. intuition. apply leEq_transitive with ((OneR[/] Two:IR[//]H1)[^]S n[+]([1][/] Two:IR[//]H1)[^]S n). apply plus_resp_leEq_lft. apply less_leEq. generalize H3. simpl in |- *. intro H7. apply H7. apply less_leEq_trans with (nexp IR (Nat.max x x0) ([1][/] Two:IR[//]H1)). exact H6. astepr (nexp IR x0 ([1][/] Two:IR[//]H1)). astepl ((OneR[/] Two:IR[//]H1)[^]Nat.max x x0). astepr ((OneR[/] Two:IR[//]H1)[^]x0). apply small_nexp_resp_le. apply shift_leEq_div. apply pos_two. astepl ZeroR. apply less_leEq. apply pos_one. apply shift_div_leEq. apply pos_two. astepr (Two:IR). apply less_leEq. apply one_less_two. intuition. apply eq_imp_leEq. astepl ((Two:IR)[*]([1][/] Two:IR[//]H1)[^]S n). astepl ((Two:IR)[*]([1][^]S n[/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H1)). astepl ((Two:IR)[*]([1][/] (Two:IR)[^]S n[//]nexp_resp_ap_zero (S n) H1)). astepl ((Two:IR)[*] (([1][/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H1)[*]([1][/] Two:IR[//]H1))). 2: apply mult_wdr. 2: astepl (([1][/] Two:IR[//]H1)[^]S n). 3: astepl (([1][/] Two:IR[//]H1)[^]n[*]([1][/] Two:IR[//]H1)). rstepl (([1][/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H1)[*]Two[*] ([1][/] Two:IR[//]H1)). astepl (([1][/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H1)[*] (Two[*]([1][/] Two:IR[//]H1))). rstepl (([1][/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H1)[*][1]). rstepl ([1][/] (Two:IR)[^]n[//]nexp_resp_ap_zero n H1). astepl ((OneR[/] Two:IR[//]H1)[^]n). apply eq_reflexive. 3: apply AbsIR_wd. 3: rational. astepr ((OneR[/] Two:IR[//]H1)[^]S n). apply eq_reflexive. astepr (([1][/] Two:IR[//]H1)[^]n[*]([1][/] Two:IR[//]H1)). apply eq_reflexive. Qed. Lemma plus_resp_continuous : forall (X : CPsMetricSpace) (f g : CSetoid_fun X IR_as_CPsMetricSpace) (H : continuous f) (H1 : continuous g), continuous (compose_CSetoid_bin_fun X IR_as_CPsMetricSpace IR_as_CPsMetricSpace f g (csg_op (c:=IR))). Proof. unfold continuous in |- *. simpl in |- *. unfold dIR in |- *. intros X f g H H0. intros x n H1. simpl in |- *. elim (H x (S n) H1). intros xn H2. elim (H0 x (S n) H1). intros x0 H3. exists (Nat.max xn x0). intros y H6. astepl (ABSIR (f x[-]f y[+](g x[-]g y))). apply leEq_less_trans with (ABSIR (f x[-]f y)[+]ABSIR (g x[-]g y)). apply IR_tri_ineq. apply less_leEq_trans with ((OneR[/] [0][+][1][+][1][//]H1)[^]S n[+]ABSIR (g x[-]g y)). apply plus_resp_less_rht. apply H2. apply less_leEq_trans with (nexp IR (Nat.max xn x0) ([1][/] [0][+][1][+][1][//]H1)). exact H6. astepl ((OneR[/] [0][+][1][+][1][//]H1)[^]Nat.max xn x0). astepr ((OneR[/] [0][+][1][+][1][//]H1)[^]xn). apply small_nexp_resp_le. apply shift_leEq_div. astepr (Two:IR). apply pos_two. astepl ZeroR. apply less_leEq. apply pos_one. apply shift_div_leEq. astepr (Two:IR). apply pos_two. astepr (OneR[+][1]). astepr (Two:IR). apply less_leEq. apply one_less_two. rational. intuition. apply leEq_transitive with ((OneR[/] [0][+][1][+][1][//]H1)[^]S n[+] ([1][/] [0][+][1][+][1][//]H1)[^]S n). apply plus_resp_leEq_lft. apply less_leEq. apply H3. apply less_leEq_trans with (nexp IR (Nat.max xn x0) ([1][/] [0][+][1][+][1][//]H1)). exact H6. astepl ((OneR[/] [0][+][1][+][1][//]H1)[^]Nat.max xn x0). astepr ((OneR[/] [0][+][1][+][1][//]H1)[^]x0). apply small_nexp_resp_le. apply shift_leEq_div. astepr (Two:IR). apply pos_two. astepl ZeroR. apply less_leEq. apply pos_one. apply shift_div_leEq. astepr (Two:IR). apply pos_two. astepr (OneR[+][1]). astepr (Two:IR). apply less_leEq. apply one_less_two. rational. intuition. apply eq_imp_leEq. astepl ((Two:IR)[*]([1][/] [0][+][1][+][1][//]H1)[^]S n). astepr ((OneR[/] [0][+][1][+][1][//]H1)[^]n). astepl ((Two:IR)[*] ([1][^]S n[/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H1)). astepl ((Two:IR)[*]([1][/] ([0][+][1][+][1])[^]S n[//]nexp_resp_ap_zero (S n) H1)). astepl ((Two:IR)[*] (([1][/] ([0][+][1][+][1])[^]n[//]nexp_resp_ap_zero n H1)[*] ([1][/] [0][+][1][+][1][//]H1))). 2: apply mult_wdr. 2: astepl (([1][/] [0][+][1][+][1][//]H1)[^]S n). 3: astepl (([1][/] [0][+][1][+][1][//]H1)[^]n[*]([1][/] [0][+][1][+][1][//]H1)). 3: astepr (([1][/] [0][+][1][+][1][//]H1)[^]n[*]([1][/] [0][+][1][+][1][//]H1)). 3: apply eq_reflexive. rstepl (([1][/] ([0][+][1][+][1])[^]n[//]nexp_resp_ap_zero n H1)[*]Two[*] ([1][/] [0][+][1][+][1][//]H1)). astepl (([1][/] ([0][+][1][+][1])[^]n[//]nexp_resp_ap_zero n H1)[*] (Two[*]([1][/] [0][+][1][+][1][//]H1))). rstepl (([1][/] ([0][+][1][+][1])[^]n[//]nexp_resp_ap_zero n H1)[*][1]). rstepl ([1][/] ([0][+][1][+][1])[^]n[//]nexp_resp_ap_zero n H1). astepl ((OneR[/] [0][+][1][+][1][//]H1)[^]n). apply eq_reflexive. astepr (([1][/] [0][+][1][+][1][//]H1)[^]S n). apply eq_reflexive. apply AbsIR_wd. rational. Qed. End Addition. corn-8.20.0/metrics/LipExt.v000066400000000000000000000325541473720167500156310ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* Formalization of the theorem about extension of real-valued Lipschitz functions. This theorem originally belongs to McShane and Kirchbraun. Theorem. Let M - metric space, let X - subset of M. Let f - Lipschitz function from X to reals with constant C. Then the function defined by \tilde f (y) = inf_{x \in X} { f(x) + C * d_M (x, y)} is the extension of f and has the same Lipshitz constant. The constructive proof also has a restriction on totally boundness of subset X. *) Require Import CoRN.metrics.ContFunctions. Require Import CoRN.metrics.CMetricSpaces. Require Import CoRN.metrics.CPMSTheory. Section LipschitzExtension. Variable M : CMetricSpace. Variable P : M -> CProp. Variable C : IR. Variable f : CSetoid_fun (SubMetricSpace M P) IR_as_CMetricSpace. Hypothesis set_bounded : MStotally_bounded (SubMetricSpace M P). Hypothesis non_empty : {x : M | P x}. Hypothesis constant_positive : [0][<]C. Hypothesis f_lip : lipschitz_c f C. Section BuildExtension. Definition cdsub' (y : M) : CSetoid_fun (SubMetricSpace M P) IR_as_CMetricSpace. Proof. intros. apply Build_CSetoid_fun with (fun x : (SubMetricSpace M P) => C [*] (dsub' M P y x)). red. intros x y0 H1. elim (bin_op_strext_unfolded _ _ _ _ _ _ H1). intros H3. elim (ap_irreflexive_unfolded _ _ H3). intros H3. apply (dsub'_strext M P y); auto. Defined. Lemma f_uni_cont: uni_continuous f. Proof. assert (lipschitz' f). apply (lip_c_imp_lip (SubMetricSpace M P) IR_as_CMetricSpace f C). apply f_lip. assert (lipschitz f). apply (lipschitz'_imp_lipschitz (SubMetricSpace M P) IR_as_CMetricSpace f); auto. apply lipschitz_imp_uni_continuous; auto. Qed. Lemma dsub'_is_lipschitz : forall (y : M) (x1 x2 : SubMetricSpace M P), C[*]dIR (dsub' M P y x1) (dsub' M P y x2)[<=]C[*](dsub M P x1 x2). Proof. intros. apply mult_resp_leEq_lft. 2: apply less_leEq. 2: apply constant_positive. unfold dsub'. unfold dsub. case x1. case x2. intros. simpl. astepl (dIR (y[-d]scs_elem0) (y[-d]scs_elem)). apply rev_tri_ineq'. unfold dIR. apply ABSIR_wd. assert ((y[-d]scs_elem0)[=](scs_elem0[-d]y)). apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. assert ((y[-d]scs_elem)[=](scs_elem[-d]y)). apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. algebra. Qed. Lemma exp_prop : forall (k : nat) (n : nat) (H : Two[#][0]), Two[^]k[*]nexp IR (n + k) ([1][/] (Two:IR)[//]H)[=] nexp IR n ([1][/] (Two:IR)[//]H). Proof. intros. astepl ((zexp Two H k)[*](nexp IR (n + k) ([1][/] Two[//]H) )). stepl ((zexp Two H k)[*](zexp Two H (- (n + k)%nat))). astepr (zexp Two H (k + (- (n + k)%nat))). apply eq_symmetric. apply zexp_plus. astepl (zexp Two H (-n)). apply (zexp_inv_nexp IR Two H n). replace (- n)%Z with (k + - (n + k)%nat)%Z; auto with zarith. apply eq_reflexive. intros. auto with zarith. assert ((n + k)%Z = (n + k)%nat). symmetry. apply inj_plus. auto with zarith. apply mult_wd; auto. apply eq_reflexive. apply (zexp_inv_nexp IR Two H (n+k)). Qed. Lemma cdsub'_uni_cont : forall y : M, uni_continuous (cdsub' y). Proof. intros. unfold uni_continuous. unfold cdsub'. simpl. intros. elim (power_big C Two). intros k H1. 3: apply one_less_two. 2: apply less_leEq; apply constant_positive. exists (n + k). intros. astepl (C[*](dIR (dsub' M P y x) (dsub' M P y y0))). cut (C[*]dIR (dsub' M P y x) (dsub' M P y y0)[<=]C[*](dsub M P x y0)). intros. cut (C[*](dsub M P x y0)[<] nexp IR n ([1][/] Two[//]H)). intros. apply leEq_less_trans with (C[*](dsub M P x y0)); auto with algebra. cut (Two[^]k[*](dsub M P x y0)[<] nexp IR n ([1][/] Two[//]H)). intros. cut (C[*](dsub M P x y0)[<=]Two[^]k[*](dsub M P x y0)). intros. apply leEq_less_trans with (Two[^]k[*](dsub M P x y0)); auto with algebra. apply mult_resp_leEq_rht; auto. apply dsub_nneg. astepr (Two[^]k[*](nexp IR (n + k) ([1][/] Two[//]H))). apply mult_resp_less_lft; auto. apply nexp_resp_pos. cut (([1]:IR)[<]Two). cut ([0][<]([1]:IR)). intros. apply less_transitive_unfolded with ([1]:IR); auto. apply pos_one. apply one_less_two. apply exp_prop. apply dsub'_is_lipschitz. unfold dIR. astepr (ABSIR (C[*](dsub' M P y x[-]dsub' M P y y0))). apply AbsIR_mult. apply less_leEq. apply constant_positive. apply ABSIR_wd; auto with algebra. Qed. Definition f_multi_ext (y : M) : CSetoid_fun (SubMetricSpace M P) IR_as_CMetricSpace. Proof. intros. apply Build_CSetoid_fun with (fun x : (SubMetricSpace M P) => f (x) [+] (cdsub' y x)). red. intros x y0 H1. elim (bin_op_strext_unfolded _ _ _ _ _ _ H1). apply (csf_strext (SubMetricSpace M P) IR_as_CMetricSpace f). apply (csf_strext (SubMetricSpace M P) IR_as_CMetricSpace (cdsub' y)). Defined. Lemma f_multi_ext_uni_continuous : forall y : M, uni_continuous (A:=SubMetricSpace M P) (B:=IR_as_CPsMetricSpace) (f_multi_ext y). Proof. intros. unfold f_multi_ext. apply (plus_resp_uni_continuous (SubMetricSpace M P) f (cdsub' y) f_uni_cont (cdsub'_uni_cont y)). Qed. Lemma inf_f_multi_ext_exists : forall y : M, {z : IR | set_glb_IR (fun v : IR_as_CMetricSpace => {x : SubMetricSpace M P | f_multi_ext y x[=]v}) z}. Proof. intros. elim (infimum_exists (SubMetricSpace M P) (f_multi_ext y)). 3: apply set_bounded. intros x H. exists x. apply H. assert (uni_continuous (f_multi_ext y)). apply f_multi_ext_uni_continuous. assert (uni_continuous' (f_multi_ext y)). apply uni_continuous_imp_uni_continuous'; auto. apply uni_continuous'_imp_uni_continuous''; auto. elim non_empty. intros x H. exists x. apply H. Qed. Definition lip_extension_f (y : M) : IR. Proof. intros. assert ({z : IR | set_glb_IR (fun v : IR_as_CMetricSpace => {x : SubMetricSpace M P | f_multi_ext y x[=]v}) z}). apply inf_f_multi_ext_exists. destruct X. exact x. Defined. Lemma lip_extension_strext_case: forall (x : M) (y : M) (z1 : IR) (z2 : IR) (H : z1[<]z2) (H1 : set_glb_IR (fun v : IR => sigT (fun x : subcsetoid_crr M P => f x[+]C[*]dsub' M P y x[=]v)) z1) (H2 : set_glb_IR (fun v : IR => sigT (fun x0 : subcsetoid_crr M P => f x0[+]C[*]dsub' M P x x0[=]v)) z2), x [#] y. Proof. unfold set_glb_IR. intros. destruct H1 as [l s]. destruct H2 as [l0 s0]. assert {x0 : IR | sigT (fun x1 : subcsetoid_crr M P => f x1[+]C[*]dsub' M P y x1[=]x0) | x0[-]z1[<](z2 [-] z1)}. apply s. apply shift_zero_less_minus; auto. destruct X. destruct s1. assert (z2[<=]f x1[+]C[*]dsub' M P x x1). apply (l0 (f x1[+]C[*]dsub' M P x x1)). exists x1. algebra. assert (x0 [<] z2). apply plus_cancel_less with ([--]z1). algebra. assert (f x1[+]C[*]dsub' M P y x1 [<] f x1[+]C[*]dsub' M P x x1). apply less_leEq_trans with z2; auto. astepl (x0). auto. assert ((from_SubPsMetricSpace M P x1[-d] y)[#](from_SubPsMetricSpace M P x1[-d]x)). apply less_imp_ap. apply mult_cancel_less with (z := C). apply constant_positive. astepl (C[*]dsub' M P y x1). astepr (C[*]dsub' M P x x1). apply plus_cancel_less with (f x1). astepl (f x1[+]C[*]dsub' M P y x1). astepr (f x1[+]C[*]dsub' M P x x1). auto. set (H1 := csbf_strext _ _ _ (cms_d (c:=M)) _ _ _ _ X1). elim H1. assert (Not (from_SubPsMetricSpace M P x1[#]from_SubPsMetricSpace M P x1)). apply ap_irreflexive_unfolded. contradiction. intros. apply ap_symmetric_unfolded. auto. Qed. Lemma lip_extension_strext : fun_strext (lip_extension_f). Proof. unfold fun_strext. unfold lip_extension_f. intros x y. elim inf_f_multi_ext_exists. elim inf_f_multi_ext_exists. simpl. intros z1 H1 z2 H2 H. elim (ap_imp_less IR z1 z2); auto; intros. unfold f_multi_ext. apply (lip_extension_strext_case x y z1 z2 a H1 H2). apply ap_symmetric_unfolded. apply (lip_extension_strext_case y x z2 z1 b H2 H1). apply ap_symmetric_unfolded. auto. Qed. Definition lip_extension := Build_CSetoid_fun M IR_as_CPsMetricSpace (lip_extension_f) (lip_extension_strext). Lemma lip_unfolded : forall (x x1: SubMetricSpace M P), f x[-]f x1[<=]C[*]dsub' M P (from_SubPsMetricSpace M P x) x1. Proof. intros. unfold dsub'. astepr (C[*](x[-d]x1)). apply leEq_transitive with (AbsIR (f x[-] f x1)). apply leEq_AbsIR. astepl (f x[-d]f x1). assert (lipschitz_c f C). apply f_lip. apply X. apply mult_wd; algebra. case x. case x1. intros. simpl. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. End BuildExtension. Section ExtensionProperties. Lemma lip_extension_keeps_fun : forall (x : SubMetricSpace M P), lip_extension (from_SubPsMetricSpace M P x) [=] f x. Proof. intros. unfold lip_extension. simpl. unfold lip_extension_f. elim inf_f_multi_ext_exists. unfold set_glb_IR. simpl. intros y H. destruct H as [l s]. apply leEq_imp_eq. apply l. exists x. assert (dsub' M P (from_SubPsMetricSpace M P x) x[=][0]). unfold dsub'. assert (diag_zero M (cms_d (c:=M))). apply pos_imp_ap_imp_diag_zero. apply ax_d_pos_imp_ap. apply (CPsMetricSpace_is_CPsMetricSpace M). apply ax_d_nneg. apply (CPsMetricSpace_is_CPsMetricSpace M). apply H. astepl (f x[+]C[*][0]). astepl (f x[+][0]). algebra. assert (forall e : IR, [0] [<]e -> f x [-] y [<] e). intros. assert (sig2T IR (fun x0 : IR => sigT (fun x1 : subcsetoid_crr M P => f x1[+]C[*]dsub' M P (from_SubPsMetricSpace M P x) x1[=]x0)) (fun x : IR => x[-]y[<]e)). apply s. auto. destruct X0. destruct s0. assert (f x [<=] f x1[+]C[*]dsub' M P (from_SubPsMetricSpace M P x) x1). astepr (C[*] dsub' M P (from_SubPsMetricSpace M P x) x1 [+] f x1). apply shift_leEq_plus. apply lip_unfolded. apply leEq_less_trans with (f x1[+]C[*]dsub' M P (from_SubPsMetricSpace M P x) x1[-]y). apply minus_resp_leEq; auto. astepl (x0 [-] y); auto. astepl (f x [-] y [+] y). astepr ([0] [+] y). apply plus_resp_leEq. apply approach_zero; auto. Qed. Lemma extension_also_lipschitz_case : forall (y1 : M) (y2 : M) (fy2 : IR) (Hfy2 : set_glb_IR (fun v : IR => sigT (fun x : subcsetoid_crr M P => f x[+]C[*]dsub' M P y2 x[=]v)) fy2) (fy1 : IR) (Hfy1 : set_glb_IR (fun v : IR => sigT (fun x : subcsetoid_crr M P => f x[+]C[*]dsub' M P y1 x[=]v)) fy1) (e : IR) (X : [0][<]e), fy2[-]fy1[<=]C[*](y1[-d]y2)[+]e. Proof. intros. destruct Hfy1. destruct Hfy2 as [l0 s0]. assert ({x : IR | sigT (fun x0 : SubMetricSpace M P => f x0[+]C[*]dsub' M P y1 x0[=]x) | x[-]fy1[<]e}). apply s. auto. destruct X0 as [fx1 Ht Hl1]. destruct Ht as [x1 He1]. assert (fy2 [<=] f x1[+]C[*]dsub' M P y2 x1). apply l0; auto. exists x1. apply eq_reflexive_unfolded. assert (fx1[-]e[<=]fy1). apply less_leEq. apply shift_minus_less. apply shift_less_plus'; auto. (* Inequalites are simple and symmetric*) apply leEq_transitive with ((f x1[+]C[*]dsub' M P y2 x1)[-](fx1[-]e)). apply minus_resp_leEq_both; auto. astepl (f x1[+]C[*]dsub' M P y2 x1[-]fx1[+]e). apply plus_resp_leEq. astepl (f x1[+]C[*]dsub' M P y2 x1[-](f x1[+]C[*]dsub' M P y1 x1)). astepl (f x1[+]C[*]dsub' M P y2 x1[-]f x1[-]C[*]dsub' M P y1 x1). astepl (f x1[-]f x1[+]C[*]dsub' M P y2 x1[-]C[*]dsub' M P y1 x1). astepl ([0][+]C[*]dsub' M P y2 x1[-]C[*]dsub' M P y1 x1). astepl (C[*]dsub' M P y2 x1[-]C[*]dsub' M P y1 x1). astepl (C[*](dsub' M P y2 x1[-]dsub' M P y1 x1)). apply mult_resp_leEq_lft. 2: apply less_leEq. 2: apply constant_positive. unfold dsub'. astepr (y2[-d]y1). apply leEq_transitive with (AbsIR ((from_SubPsMetricSpace M P x1[-d]y2)[-] (from_SubPsMetricSpace M P x1[-d]y1))). apply leEq_AbsIR. apply AbsSmall_imp_AbsIR. apply rev_tri_ineq. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. rational. Qed. Lemma extension_also_liscphitz : lipschitz_c (lip_extension) C. Proof. unfold lipschitz_c. unfold lip_extension. unfold lip_extension_f. intros y1 y2. intros. simpl. elim inf_f_multi_ext_exists. elim inf_f_multi_ext_exists. unfold f_multi_ext. unfold dIR. simpl. intros fy2 Hfy2 fy1 Hfy1. apply AbsSmall_imp_AbsIR. assert (forall e : IR, [0][<]e -> AbsSmall (C[*](y1[-d]y2)[+]e) (fy1[-]fy2)). intros. unfold AbsSmall. split. astepr ([--](fy2 [-] fy1)). apply inv_resp_leEq. apply extension_also_lipschitz_case; auto. rational. astepr (C[*](y2[-d]y1)[+]e). astepl (fy1 [-] fy2). apply (extension_also_lipschitz_case y2 y1 fy1 Hfy1 fy2 Hfy2 e X). assert (y2[-d]y1[=]y1[-d]y2). apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. algebra. apply AbsSmall_approach. auto. Qed. End ExtensionProperties. End LipschitzExtension. corn-8.20.0/metrics/Prod_Sub.v000066400000000000000000000240041473720167500161300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.metrics.IR_CPMSpace. Section prodpsmetrics. (** ** Product-Pseudo-Metric-Spaces *) (** The product metric here defined is: $ d_{prod}((a_1,b_1),(a_2,b_2)):= d_A(a_1,a_2)+d_B(b_1,b_2)$ # dprod((a1,b1),(a2,b2)):= dA(a1,b1)+dB(b1,b2)#. This is %\emph{not}% #not# the one used to make the metric of $\RR^{2}$ #IR2# out of the metric of $\RR$ #IR#. *) Definition dprod0 (A B : CPsMetricSpace) (c d : prodT A B) : IR. Proof. case c. intros c0 c1. case d. intros c2 c3. exact ((c0[-d]c2)[+](c1[-d]c3)). Defined. Lemma dprod0_strext : forall A B : CPsMetricSpace, bin_fun_strext (ProdCSetoid A B) (ProdCSetoid A B) IR (dprod0 A B). Proof. intros A B. unfold bin_fun_strext in |- *. intros x1 x2 y1 y2. unfold dprod0 in |- *. case x1. case x2. case y1. case y2. intros c c0 c1 c2 c3 c4 c5 c6 H. set (H1 := cs_bin_op_strext IR csg_op (c5[-d]c1) (c3[-d]c) (c6[-d]c2) (c4[-d]c0) H) in *. elim H1. intros. set (H2 := csbf_strext A A IR cms_d c5 c3 c1 c a) in *. elim H2. intros. left. simpl in |- *. left. exact a0. intros. right. simpl in |- *. left. exact b. intros. set (H2 := csbf_strext B B IR cms_d c6 c4 c2 c0 b) in *. elim H2. intros. left. simpl in |- *. right. exact a. intros. right. simpl in |- *. right. exact b0. Qed. Definition d_prod0 (A B : CPsMetricSpace) := Build_CSetoid_bin_fun (ProdCSetoid A B) (ProdCSetoid A B) IR ( dprod0 A B) (dprod0_strext A B). Lemma prod0cpsmetricspace_is_CPsMetricSpace : forall A B : CPsMetricSpace, is_CPsMetricSpace (ProdCSetoid A B) (d_prod0 A B). Proof. intros A B. apply (Build_is_CPsMetricSpace (ProdCSetoid A B) (d_prod0 A B)). unfold com in |- *. intros x y. unfold d_prod0 in |- *. simpl in |- *. unfold dprod0 in |- *. case x. case y. intros. apply (cs_bin_op_wd IR csg_op). apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. unfold nneg in |- *. intros. unfold d_prod0 in |- *. simpl in |- *. unfold dprod0 in |- *. case x. case y. intros. astepl (ZeroR[+][0]). apply plus_resp_leEq_both. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. unfold pos_imp_ap in |- *. intros x y. unfold d_prod0 in |- *. simpl in |- *. unfold dprod0 in |- *. case x. case y. intros c c0 c1 c2 H. unfold prod_ap in |- *. unfold prod_rect in |- *. set (H0 := positive_Sum_two IR (c1[-d]c) (c2[-d]c0) H) in *. elim H0. intros. left. apply ax_d_pos_imp_ap with (d := cms_d (c:=A)). apply CPsMetricSpace_is_CPsMetricSpace. exact a. intros. right. apply ax_d_pos_imp_ap with (d := cms_d (c:=B)). apply CPsMetricSpace_is_CPsMetricSpace. exact b. unfold tri_ineq in |- *. intros. unfold d_prod0 in |- *. simpl in |- *. unfold dprod0 in |- *. case x. case y. case z. intros c c0 c1 c2 c3 c4. astepr ((c3[-d]c1)[+]((c4[-d]c2)[+]((c1[-d]c)[+](c2[-d]c0)))). astepr ((c3[-d]c1)[+]((c4[-d]c2)[+](c1[-d]c)[+](c2[-d]c0))). astepr ((c3[-d]c1)[+]((c1[-d]c)[+](c4[-d]c2)[+](c2[-d]c0))). astepr ((c3[-d]c1)[+]((c1[-d]c)[+]((c4[-d]c2)[+](c2[-d]c0)))). astepr ((c3[-d]c1)[+](c1[-d]c)[+]((c4[-d]c2)[+](c2[-d]c0))). apply plus_resp_leEq_both. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Definition Prod0CPsMetricSpace (A B : CPsMetricSpace) := Build_CPsMetricSpace (ProdCSetoid A B) (d_prod0 A B) (prod0cpsmetricspace_is_CPsMetricSpace A B). End prodpsmetrics. Section subpsmetrics. (** ** Sub-Pseudo-Metric-Spaces *) (** The pseudo metric on a subspace $Y$ #Y# of a pseudo metric space $X$ #X# is the pseudo metric on $X$ #X# restricted to $Y$ #Y#. *) Definition restr_bin_fun (X : CPsMetricSpace) (P : cms_crr X -> CProp) (f : CSetoid_bin_fun X X IR) (a b : Build_SubCSetoid X P) : IR := match a, b with | Build_subcsetoid_crr _ _ x p, Build_subcsetoid_crr _ _ y q => f x y end. Arguments restr_bin_fun [X]. Definition restr_bin_fun' (X : CPsMetricSpace) (P : cms_crr X -> CProp) (f : CSetoid_bin_fun X X IR) (a : X) (b : Build_SubCSetoid X P) : IR := match b with | Build_subcsetoid_crr _ _ y q => f a y end. Arguments restr_bin_fun' [X]. Lemma restr_bin_fun_strext : forall (X : CPsMetricSpace) (P : cms_crr X -> CProp) (f : CSetoid_bin_fun X X IR), bin_fun_strext (Build_SubCSetoid X P) (Build_SubCSetoid X P) IR (restr_bin_fun P f). Proof. intros X P f. red in |- *. intros x1 x2 y1 y2. case y2. case y1. case x2. case x1. do 8 intro. intro H. exact (csbf_strext _ _ _ f _ _ _ _ H). Qed. Definition Build_SubCSetoid_bin_fun (X : CPsMetricSpace) (P : cms_crr X -> CProp) (f : CSetoid_bin_fun X X IR) : CSetoid_bin_fun (Build_SubCSetoid X P) (Build_SubCSetoid X P) IR := Build_CSetoid_bin_fun (Build_SubCSetoid X P) (Build_SubCSetoid X P) IR (restr_bin_fun P f) (restr_bin_fun_strext X P f). Definition dsub (X : CPsMetricSpace) (P : cms_crr X -> CProp) := Build_SubCSetoid_bin_fun X P (cms_d (c:=X)). Arguments dsub [X]. Lemma dsub_com : forall (X : CPsMetricSpace) (P : cms_crr X -> CProp), com (dsub P). Proof. intros X P. unfold com in |- *. intros x y. unfold dsub in |- *. case y. case x. intros a H b H0. simpl in |- *. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma dsub_nneg : forall (X : CPsMetricSpace) (P : cms_crr X -> CProp), nneg (dsub P). Proof. intros X P. unfold nneg in |- *. intros x y. unfold dsub in |- *. case y. case x. intros a H b H0. simpl in |- *. apply ax_d_nneg. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma dsub_pos_imp_ap : forall (X : CPsMetricSpace) (P : cms_crr X -> CProp), pos_imp_ap (dsub P). Proof. intros X P. unfold pos_imp_ap in |- *. intros x y. unfold dsub in |- *. case y. case x. intros a H b H0. simpl in |- *. apply ax_d_pos_imp_ap. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Lemma dsub_tri_ineq : forall (X : CPsMetricSpace) (P : cms_crr X -> CProp), tri_ineq (dsub P). Proof. intros X P. unfold tri_ineq in |- *. intros x y z. unfold dsub in |- *. case z. case y. case x. intros a H b H0 c H1. simpl in |- *. apply ax_d_tri_ineq. apply CPsMetricSpace_is_CPsMetricSpace. Qed. Definition is_SubPsMetricSpace (X : CPsMetricSpace) (P : cms_crr X -> CProp) : is_CPsMetricSpace (Build_SubCSetoid X P) (dsub P) := Build_is_CPsMetricSpace (Build_SubCSetoid X P) (dsub P) ( dsub_com X P) (dsub_nneg X P) (dsub_pos_imp_ap X P) ( dsub_tri_ineq X P). Definition SubPsMetricSpace (X : CPsMetricSpace) (P : cms_crr X -> CProp) : CPsMetricSpace := Build_CPsMetricSpace (Build_SubCSetoid X P) (dsub P) (is_SubPsMetricSpace X P). Arguments SubPsMetricSpace [X]. Definition from_SubPsMetricSpace (X : CPsMetricSpace) (P : X -> CProp) : SubPsMetricSpace P -> X. Proof. unfold SubPsMetricSpace in |- *. simpl in |- *. intro x. case x. intros y Q. exact y. Defined. (** The function [dsub'] is used in the definition of %''located''% #"located"#. It enables one to speak about a distance between an element of a pseudo metric space and a certain subspace. *) Definition dsub' (X : CPsMetricSpace) (P : X -> CProp) (x : X) (y : SubPsMetricSpace P) := from_SubPsMetricSpace X P y[-d]x. Arguments dsub' [X]. Lemma dsub'_strext : forall (X : CPsMetricSpace) (P : X -> CProp) (x : X), fun_strext (dsub' P x). Proof. intros X P x. unfold fun_strext in |- *. intros x0 y. unfold dsub' in |- *. case y. case x0. intros a b c d. simpl in |- *. intro H. set (H1 := csbf_strext _ _ _ (cms_d (c:=X)) _ _ _ _ H) in *. elim H1. intuition. intro H2. set (H3 := ap_irreflexive_unfolded X x H2) in *. intuition. Qed. Definition dsub'_as_cs_fun (X : CPsMetricSpace) (P : X -> CProp) (x : X) := Build_CSetoid_fun (SubPsMetricSpace P) IR_as_CPsMetricSpace ( dsub' P x) (dsub'_strext X P x). Arguments dsub'_as_cs_fun [X]. Lemma dsub'_uni_continuous'' : forall (X : CPsMetricSpace) (P : X -> CProp) (x : X), uni_continuous'' (dsub'_as_cs_fun P x). Proof. intros X P x. unfold dsub'_as_cs_fun in |- *. unfold dsub' in |- *. apply uni_continuous'_imp_uni_continuous''. unfold from_SubPsMetricSpace in |- *. unfold uni_continuous' in |- *. simpl in |- *. intro n. exists n. intros x0 x1. case x0. case x1. intros. generalize H. simpl in |- *. intro. apply leEq_transitive with (scs_elem0[-d]scs_elem). 2: exact H0. unfold dIR in |- *. astepl (AbsIR ((scs_elem0[-d]x)[-](scs_elem[-d]x))). astepl (AbsIR ((x[-d]scs_elem0)[-](scs_elem[-d]x))). astepl (AbsIR ((x[-d]scs_elem0)[-](x[-d]scs_elem))). apply AbsSmall_imp_AbsIR. apply rev_tri_ineq. apply csf_wd. apply cg_minus_wd. intuition. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. apply csf_wd. apply cg_minus_wd. apply ax_d_com. apply CPsMetricSpace_is_CPsMetricSpace. intuition. Qed. End subpsmetrics. corn-8.20.0/model/000077500000000000000000000000001473720167500136565ustar00rootroot00000000000000corn-8.20.0/model/Zmod/000077500000000000000000000000001473720167500145675ustar00rootroot00000000000000corn-8.20.0/model/Zmod/Cmod.v000066400000000000000000000057471473720167500156550ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.Zmod.ZMod. Require Export CoRN.logic.CLogic. (** * CProp-valued lemmas about 'mod' *) Lemma Zmod_pos:(forall (k l:nat)(H:(l>0)%Z), (k mod l)%Z=0 or {p:positive|(k mod l)%Z =(Zpos p)}):CProp. Proof. simpl. intros k l. intro H0. set (H:= (Z_mod_lt k l H0)). elim H. clear H. intros H1 H2. elim (Z_le_lt_eq_dec 0 (k mod l)%Z H1). case (k mod l)%Z. intuition. intros p H. right. exists p. reflexivity. intros p H3. 2:intuition. cut False. intuition. cut (Zneg p < 0)%Z. intuition. unfold Z.lt. intuition. Qed. Definition mod_nat: forall (k l:nat)(H:(l>0)%Z),nat. Proof. intros k l H3. set (H:= (Zmod_pos k l H3)). elim H. intro H0. exact 0. intro H0. elim H0. intros p H1. exact (nat_of_P p). Defined. Lemma mod_nat_correct: forall (k l:nat)(H:(l>0)%Z), (k mod l)%Z = (Z_of_nat (mod_nat k l H)). Proof. intros k l H. unfold mod_nat. unfold sum_rec. unfold sum_rect. case ( Zmod_pos k l H). tauto. unfold sigT_rec. unfold sigT_rect. intro H0. case H0. simpl. intro x. set (H1:= (inject_nat_convert x)). intuition. Qed. Lemma nat_Z_div:forall (a b c r:nat)(b' r':Z), a=b*c+r->r((Z_of_nat a)=c*b'+r')%Z->(0<=r' ((Z_of_nat r)=r'). Proof. intros a b c0 r b' r' H H1 H2 H3. cut (c0>0)%Z. intro H5. 2:intuition. set (H4:=(Z_div_mod_eq_full (Z_of_nat a) (Z_of_nat c0))). cut ((Z_of_nat a mod (Z_of_nat c0))%Z = r'). intro H6. rewrite<- H6. cut ((Z_of_nat a mod (Z_of_nat c0))%Z= (Z_of_nat r)). intro H7. rewrite<- H7. reflexivity. rewrite H. set (H8:= (Zmod_cancel_multiple c0 r b H5)). set (H9:= (inj_mult b c0)). set (H10:= (inj_plus (b*c0) r)). rewrite H10. rewrite H9. rewrite H8. apply Zmod_small. intuition. intuition. rewrite H2. replace (Z_of_nat c0 * b' + r')%Z with ( b'*Z_of_nat c0 + r')%Z. 2:intuition. set (H8:= (Zmod_cancel_multiple c0 r' b' H5)). rewrite H8. apply Zmod_small; intuition. Qed. corn-8.20.0/model/Zmod/IrrCrit.v000066400000000000000000000213651473720167500163430ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* IrrCrit.v, v1.1, 27aug2004, Bart Kirkels *) (** printing [=] %\ensuremath=% #=# *) (** printing [+X*] %\ensuremath{+ X*}% #&+ X*;# *) Require Export CoRN.model.Zmod.Zm. Require Export CoRN.model.rings.Zring. Require Export CoRN.algebra.CPoly_Degree. (** * An irreducibility criterion Let [p] be a (positive) prime number. Our goal is to prove that if an integer polynomial is irreducible over the prime field Fp, then it is irreducible over Z. *) Parameter p : positive. Axiom Hprime : (Prime p). Definition fp := (Fp p Hprime). (** ** Integers modulo [p] *) Definition zfp (a:Z) := (a:fp). Lemma fpeq_wd : forall a b:Z, a=b -> (zfp a)[=](zfp b). Proof. intros a b heq. simpl. unfold zfp in *. unfold ZModeq in *. elim heq. auto with *. Qed. (** ** Integer polynomials over Fp *) Definition zx := (cpoly_cring Z_as_CRing). Definition fpx := (cpoly_cring fp). Fixpoint zxfpx (p:zx) : fpx := match p with | cpoly_zero _ => (cpoly_zero fp : fpx) | cpoly_linear _ c p1 => (zfp c)[+X*](zxfpx p1) end. Definition P (f g:zx):= f[=]g -> (zxfpx f)[=](zxfpx g). Lemma fpxeq_wd : forall f g:zx, f[=]g -> (zxfpx f)[=](zxfpx g). Proof. apply (cpoly_double_ind Z_as_CRing P); unfold P. induction p0 as [|c p0]. trivial. intro H. astepl ((zfp c)[+X*](zxfpx p0)). apply (_linear_eq_zero fp). split. astepr (zfp 0). apply fpeq_wd. elim H. auto. apply IHp0. elim H. auto with *. induction p0 as [|c p0]. trivial. intro H. astepr ((zfp c)[+X*](zxfpx p0)). apply (_zero_eq_linear fp). split. astepr (zfp 0). apply fpeq_wd. elim H. auto. apply IHp0. elim H. auto with *. intros p0 q c d H1 H2. astepr ((zfp d)[+X*](zxfpx q)). astepl ((zfp c)[+X*](zxfpx p0)). apply (_linear_eq_linear fp). split. apply fpeq_wd. elim H2. auto. apply H1. elim H2. auto. Qed. #[global] Hint Resolve fpxeq_wd : algebra. (** ** Lemmas In this section we prove the lemmas we will need, about integer polynomials, viewed over a prime field. *) Lemma mult_zero : forall (R:CRing)(f:cpoly_cring R), (cpoly_mult_op R f (cpoly_zero R))[=](cpoly_zero R). Proof. intros R f. simpl; apply cpoly_mult_zero. Qed. #[global] Hint Resolve mult_zero : algebra. Lemma fp_resp_zero : zxfpx(cpoly_zero Z_as_CRing)[=](cpoly_zero fp). Proof. intuition. Qed. Lemma fpx_resp_mult_cr : forall (c:Z_as_CRing)(f:zx), (cpoly_mult_cr_cs fp (zxfpx f) (zfp c)) [=] (zxfpx (cpoly_mult_cr_cs _ f c)). Proof. induction f as [|c0 f]. intuition. astepr (zxfpx ((c[*]c0)[+X*](cpoly_mult_cr_cs _ f c))). astepr ((zfp (c[*]c0))[+X*](zxfpx (cpoly_mult_cr_cs _ f c))). astepr (((zfp c)[*](zfp c0))[+X*](zxfpx (cpoly_mult_cr_cs _ f c))). astepr (((zfp c)[*](zfp c0))[+X*](cpoly_mult_cr_cs fp (zxfpx f) (zfp c))). astepr (cpoly_mult_cr_cs fp ((zfp c0)[+X*](zxfpx f)) (zfp c)). intuition. Qed. #[global] Hint Resolve fpx_resp_mult_cr : algebra. Lemma fpx_resp_plus : forall f g:zx, (cpoly_plus_op fp (zxfpx f) (zxfpx g))[=] (zxfpx (cpoly_plus_op _ f g)). Proof. induction f as [|c f]. intuition. induction g as [|c0 g]. intuition. astepl (cpoly_plus fp (zxfpx (c[+X*]f)) (zxfpx (c0[+X*]g))). astepr (zxfpx (cpoly_plus_op _ (c[+X*]f) (c0[+X*]g))). astepr (zxfpx ((c[+]c0)[+X*](cpoly_plus_op _ f g))). astepr ((zfp (c[+]c0))[+X*](zxfpx (cpoly_plus_op _ f g))). astepl (((zfp c)[+](zfp c0))[+X*] (cpoly_plus_op fp (zxfpx f) (zxfpx g))). auto with *. Qed. #[global] Hint Resolve fpx_resp_plus : algebra. Lemma fpx_resp_mult : forall f g:zx, (cpoly_mult_op fp (zxfpx f) (zxfpx g)) [=] (zxfpx (cpoly_mult_op _ f g)). Proof. induction f as [|c f]. intro g. astepl (cpoly_mult_op fp (cpoly_zero fp)(zxfpx g)). astepl (cpoly_zero fp). astepr (zxfpx (cpoly_zero Z_as_CRing)). astepr (cpoly_zero fp); intuition. induction g as [|c0 g]. astepl (cpoly_mult_op fp (zxfpx (c[+X*]f)) (cpoly_zero fp)). astepl (cpoly_zero fp). astepr (zxfpx (cpoly_zero Z_as_CRing)); try algebra. apply fpxeq_wd. apply eq_symmetric. apply (mult_zero Z_as_CRing). astepr (zxfpx (cpoly_mult_op Z_as_CRing (c[+X*]f) (c0[+X*]g))). astepl (cpoly_mult_op fp (zxfpx (c[+X*]f)) (zxfpx (c0[+X*]g))). astepr (zxfpx (cpoly_plus_op _ ((c[*]c0)[+X*](cpoly_mult_cr_cs _ g c)) (([0]:Z_as_CRing)[+X*](cpoly_mult _ f (c0[+X*]g))))). astepr (zxfpx (((c[*]c0)[+]([0]:Z_as_CRing))[+X*](cpoly_plus_op _ (cpoly_mult_cr_cs _ g c) (cpoly_mult _ f (c0[+X*]g))))). astepr (zxfpx ((c[*]c0)[+X*](cpoly_plus_op _ (cpoly_mult_cr_cs _ g c) (cpoly_mult _ f (c0[+X*]g))))). astepr ( (zfp c[*]c0) [+X*] (zxfpx (cpoly_plus_op _ (cpoly_mult_cr_cs _ g c) (cpoly_mult _ f (c0[+X*]g))))). astepl (cpoly_mult_op fp ((zfp c)[+X*](zxfpx f)) (zxfpx (c0[+X*]g))). astepl (cpoly_plus_op fp (cpoly_mult_cr_cs fp (zxfpx (c0[+X*]g)) (zfp c)) ((zfp ([0]:Z_as_CRing))[+X*](cpoly_mult_op fp (zxfpx f) (zxfpx (c0[+X*]g))))). astepl (cpoly_plus_op fp (cpoly_mult_cr_cs fp ((zfp c0)[+X*](zxfpx g)) (zfp c)) (([0]:fp)[+X*](zxfpx (cpoly_mult_op _ f (c0[+X*]g))))). astepl (cpoly_plus_op fp (((zfp c)[*](zfp c0))[+X*](cpoly_mult_cr_cs fp (zxfpx g) (zfp c))) (([0]:fp)[+X*](zxfpx (cpoly_mult_op _ f (c0[+X*]g))))). astepl (cpoly_plus_op fp ((zfp (c[*]c0))[+X*](zxfpx (cpoly_mult_cr_cs _ g c))) (([0]:fp)[+X*](zxfpx (cpoly_mult_op _ f (c0[+X*]g))))). astepl ((zfp (c[*]c0)[+]([0]:fp))[+X*](cpoly_plus_op fp (zxfpx (cpoly_mult_cr_cs _ g c)) (zxfpx (cpoly_mult_op _ f (c0[+X*]g))))). intuition. Qed. #[global] Hint Resolve fpx_resp_mult : algebra. Lemma fpx_resp_coef : forall (f:zx)(n:nat), (zfp (nth_coeff n f)) [=] (nth_coeff n (zxfpx f)). Proof. induction f. intuition. induction n. intuition. astepl (zfp (nth_coeff n f)). astepr (nth_coeff n (zxfpx f)). apply (IHf n). Qed. #[global] Hint Resolve fpx_resp_coef : algebra. (** ** Working towards the criterion *** Definitions We prove the criterion for monic integers of degree greater than 1. This property is first defined, so that reducibility can be defined next. We then prove that a reducible integer polynomial is reducible over Fp. Finally irreducibility is defined. *) Definition degree_ge_monic (R:CRing)(n:nat)(f:(cpoly_cring R)) := {m:nat | (n >= m)%nat | monic m f}. Lemma fpx_resp_deggemonic : forall (f:zx)(n:nat), degree_ge_monic _ n f -> degree_ge_monic _ n (zxfpx f). Proof. intros f n; unfold degree_ge_monic. intro X; elim X. intros m Hm Hfmonm. exists m. exact Hm. elim Hfmonm. intros Hnthcoeff Hdegf. unfold monic. split. astepl (zfp (nth_coeff m f)). assert ([1][=]nth_coeff m f); intuition. simpl in H. rewrite <- H. intuition. red. intros. astepl (zfp (nth_coeff m0 f)). assert ([0][=]nth_coeff m0 f); intuition. simpl in H0. rewrite <- H0. intuition. Qed. #[global] Hint Resolve fpx_resp_deggemonic : algebra. Definition reducible (R:CRing)(f:(cpoly_cring R)) := degree_ge_monic R 2%nat f and {g:(cpoly_cring R) | degree_ge_monic R 1%nat g | {h:(cpoly_cring R) | degree_ge_monic R 1%nat h | f[=](cpoly_mult_op R g h) }}. Lemma fpx_resp_red : forall f:zx, (reducible _ f)->(reducible fp (zxfpx f)). Proof. intros f Hfred; elim Hfred. intros Hfok Hfred2; elim Hfred2. intros g Hgok Hfred3; elim Hfred3. intros h Hhok Hfgh; unfold reducible. intuition. exists (zxfpx g). intuition. exists (zxfpx h). intuition. astepr (zxfpx (cpoly_mult_op _ g h)). apply fpxeq_wd. exact Hfgh. Qed. #[global] Hint Resolve fpx_resp_red : algebra. Definition irreducible (R:CRing)(f:(cpoly_cring R)) := Not (reducible R f). (** *** The criterion And now we can state and prove the irreducibility criterion. *) Theorem irrcrit : forall f:zx, (irreducible fp (zxfpx f)) -> (irreducible _ f). Proof. unfold irreducible. intro f. cut ((reducible _ f) -> (reducible fp (zxfpx f))). intros X H X0. apply H. apply X. exact X0. apply fpx_resp_red. Qed. corn-8.20.0/model/Zmod/ZBasics.v000066400000000000000000000533231473720167500163220ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* ZBasics.v, by Vince Barany *) From Coq Require Export ZArith. Require Export CoRN.logic.CLogic. From Coq Require Import Lia. (** * Basic facts on Z ** Arithmetic over nat *) Section narith. Lemma le_trans : forall l k n : nat, k <= l -> l <= n -> k <= n. Proof. intros l k n Hkl Hln. induction n as [| n Hrecn]. inversion Hln. rewrite <- H. exact Hkl. inversion Hln. rewrite <- H. exact Hkl. apply le_S. apply Hrecn. assumption. Qed. Lemma minus_n_Sk : forall n k : nat, k < n -> n - k = S (n - S k). Proof. intros n k Hlt. induction n as [| n Hrecn]. inversion Hlt. rewrite <- Nat.sub_succ_l. simpl in |- *. reflexivity. unfold lt in Hlt. inversion Hlt. auto. apply (le_trans (S k)). auto. assumption. Qed. Lemma le_minus : forall n k : nat, n - k <= n. Proof. intros n. induction n as [| n Hrecn]. simpl in |- *. auto. intro k. case k. simpl in |- *. auto. intro k'. simpl in |- *. apply (le_trans n). apply Hrecn. auto. Qed. Lemma minus_n_minus_n_k : forall k n : nat, k <= n -> k = n - (n - k). Proof. intros k n Hle. induction k as [| k Hreck]. rewrite Nat.sub_0_r. symmetry in |- *. apply Nat.sub_diag. set (K := k) in |- * at 2. rewrite Hreck. unfold K in |- *; clear K. rewrite (minus_n_Sk n k). rewrite (minus_n_Sk n (n - S k)). reflexivity. unfold lt in |- *. rewrite <- (minus_n_Sk n k). apply le_minus. unfold lt in |- *. exact Hle. unfold lt in |- *. exact Hle. apply (le_trans (S k)). auto. exact Hle. Qed. End narith. #[global] Hint Resolve Nat.le_trans: zarith. #[global] Hint Resolve minus_n_Sk: zarith. #[global] Hint Resolve le_minus: zarith. #[global] Hint Resolve minus_n_minus_n_k: zarith. (** ** Arithmetic over Z *) Section zarith. Definition Zdec : forall a : Z, {a = 0%Z} + {a <> 0%Z}. Proof. intro a. case a. left; reflexivity. intro; right; discriminate. intro; right; discriminate. Defined. (* True in any ring *) Lemma unique_unit : forall u : Z, (forall a : Z, (a * u)%Z = a) -> u = 1%Z. Proof. intros. rewrite <- (Zmult_1_l u). rewrite (H 1%Z). reflexivity. Qed. Lemma Zmult_zero_div : forall a b : Z, (a * b)%Z = 0%Z -> a = 0%Z \/ b = 0%Z. Proof. intros a b. case a; case b; intros; auto; try discriminate. Qed. Lemma Zmult_no_zero_div : forall a b : Z, a <> 0%Z -> b <> 0%Z -> (a * b)%Z <> 0%Z. Proof. intros a b Ha Hb. intro Hfalse. generalize (Zmult_zero_div a b Hfalse). tauto. Qed. Lemma Zmult_unit_oneforall : forall u a : Z, a <> 0%Z -> (a * u)%Z = a -> forall b : Z, (b * u)%Z = b. Proof. intros u a H0 Hu b. apply (Zmult_absorb a). assumption. rewrite Zmult_assoc. rewrite (Zmult_comm a b). rewrite <- Zmult_assoc. rewrite Hu. reflexivity. Qed. Lemma Zunit_eq_one : forall u a : Z, a <> 0%Z -> (a * u)%Z = a -> u = 1%Z. Proof. intros u a H1 H2. apply unique_unit. intro. apply (Zmult_unit_oneforall u a H1 H2). Qed. Lemma Zmult_intro_lft : forall a b c : Z, a <> 0%Z -> (a * b)%Z = (a * c)%Z -> b = c. Proof. intros a b c Ha Habc. cut ((b - c)%Z = 0%Z); auto with zarith. elim (Zmult_zero_div a (b - c)). intro; elim Ha; assumption. tauto. rewrite Zmult_comm; rewrite BinInt.Zmult_minus_distr_r; rewrite (Zmult_comm b a); rewrite (Zmult_comm c a). auto with zarith. Qed. Lemma Zmult_intro_rht : forall a b c : Z, a <> 0%Z -> (b * a)%Z = (c * a)%Z -> b = c. Proof. intros a b c. rewrite (Zmult_comm b a); rewrite (Zmult_comm c a); apply Zmult_intro_lft. Qed. Lemma succ_nat: forall (m:nat),Zpos (P_of_succ_nat m) = (Z_of_nat m + 1)%Z. Proof. intro m. induction m. reflexivity. simpl. case (P_of_succ_nat m). simpl. reflexivity. simpl. reflexivity. simpl. reflexivity. Qed. End zarith. #[global] Hint Resolve Zdec: zarith. #[global] Hint Resolve unique_unit: zarith. #[global] Hint Resolve Zmult_zero_div: zarith. #[global] Hint Resolve Zmult_no_zero_div: zarith. #[global] Hint Resolve Zmult_unit_oneforall: zarith. #[global] Hint Resolve Zunit_eq_one: zarith. #[global] Hint Resolve Zmult_intro_lft: zarith. #[global] Hint Resolve Zmult_intro_rht: zarith. (** ** Facts on inequalities over Z *) Section zineq. Lemma Zgt_Zge: forall (n m:Z), (n>m)%Z -> (n>=m)%Z. Proof. intros n m. intuition. Qed. Lemma Zle_antisymm : forall a b : Z, (a >= b)%Z -> (b >= a)%Z -> a = b. Proof. auto with zarith. Qed. Definition Zlt_irref : forall a : Z, ~ (a < a)%Z := Z.lt_irrefl. Lemma Zgt_irref : forall a : Z, ~ (a > a)%Z. Proof. intro a. intro Hlt. generalize (Z.gt_lt a a Hlt). apply Zlt_irref. Qed. Lemma Zlt_NEG_0 : forall p : positive, (Zneg p < 0)%Z. Proof. intro p; unfold Z.lt in |- *; simpl in |- *; reflexivity. Qed. Lemma Zgt_0_NEG : forall p : positive, (0 > Zneg p)%Z. Proof. intro p; unfold Z.gt in |- *; simpl in |- *; reflexivity. Qed. Lemma Zle_NEG_0 : forall p : positive, (Zneg p <= 0)%Z. Proof. intro p; intro H0; inversion H0. Qed. Lemma Zge_0_NEG : forall p : positive, (0 >= Zneg p)%Z. Proof. intro p; intro H0; inversion H0. Qed. Lemma Zle_NEG_1 : forall p : positive, (Zneg p <= -1)%Z. Proof. intro p. case p; intros; intro H0; inversion H0. Qed. Lemma Zge_1_NEG : forall p : positive, (-1 >= Zneg p)%Z. Proof. intro p. case p; intros; intro H0; inversion H0. Qed. Lemma Zlt_0_POS : forall p : positive, (0 < Zpos p)%Z. Proof. intro p; unfold Z.lt in |- *; simpl in |- *; reflexivity. Qed. Lemma Zgt_POS_0 : forall p : positive, (Zpos p > 0)%Z. Proof. intro p; unfold Z.gt in |- *; simpl in |- *; reflexivity. Qed. Lemma Zle_0_POS : forall p : positive, (0 <= Zpos p)%Z. Proof. intro p; intro H0; inversion H0. Qed. Lemma Zge_POS_0 : forall p : positive, (Zpos p >= 0)%Z. Proof. intro p; intro H0; inversion H0. Qed. Lemma Zle_1_POS : forall p : positive, (1 <= Zpos p)%Z. Proof. intro p. case p; intros; intro H0; inversion H0. Qed. Lemma Zge_POS_1 : forall p : positive, (Zpos p >= 1)%Z. Proof. intro p. case p; intros; intro H0; inversion H0. Qed. Lemma Zle_neg_pos : forall p q : positive, (Zneg p <= Zpos q)%Z. Proof. intros; unfold Z.le in |- *; simpl in |- *; discriminate. Qed. Lemma ZPOS_neq_ZERO : forall p : positive, Zpos p <> 0%Z. Proof. intros; intro; discriminate. Qed. Lemma ZNEG_neq_ZERO : forall p : positive, Zneg p <> 0%Z. Proof. intros; intro; discriminate. Qed. Lemma Zge_gt_succ : forall a b : Z, (a >= b + 1)%Z -> (a > b)%Z. Proof. auto with zarith. Qed. Lemma Zge_gt_pred : forall a b : Z, (a - 1 >= b)%Z -> (a > b)%Z. Proof. auto with zarith. Qed. Lemma Zgt_ge_succ : forall a b : Z, (a + 1 > b)%Z -> (a >= b)%Z. Proof. auto with zarith. Qed. Lemma Zgt_ge_pred : forall a b : Z, (a > b - 1)%Z -> (a >= b)%Z. Proof. auto with zarith. Qed. Lemma Zlt_asymmetric : forall a b : Z, {(a < b)%Z} + {a = b} + {(a > b)%Z}. Proof. intros a b. set (d := (a - b)%Z). replace a with (b + d)%Z; [ idtac | unfold d in |- *; lia ]. case d; simpl in |- *. left; right; auto with zarith. intro p. right. rewrite <- (Zplus_0_r b). replace (b + 0 + Zpos p)%Z with (b + Zpos p)%Z; auto with zarith. intro p. left; left. rewrite <- (Zplus_0_r b). replace (b + 0 + Zneg p)%Z with (b + Zneg p)%Z by auto with zarith. cut (Zneg p < 0)%Z. auto with zarith. apply Zlt_NEG_0. Qed. Lemma Zle_neq_lt : forall a b : Z, (a <= b)%Z -> a <> b -> (a < b)%Z. Proof. auto with zarith. Qed. Lemma Zmult_pos_mon_le_lft : forall a b c : Z, (a >= b)%Z -> (c >= 0)%Z -> (c * a >= c * b)%Z. Proof. auto with zarith. Qed. Lemma Zmult_pos_mon_le_rht : forall a b c : Z, (a >= b)%Z -> (c >= 0)%Z -> (a * c >= b * c)%Z. Proof. auto with zarith. Qed. Lemma Zmult_pos_mon_lt_lft : forall a b c : Z, (a > b)%Z -> (c > 0)%Z -> (c * a > c * b)%Z. Proof. intros a b c. induction c as [| p| p]. auto with zarith. intros Hab H0. induction p as [p Hrecp| p Hrecp| ]. 3: auto with zarith. replace (Zpos (xI p)) with (2 * Zpos p + 1)%Z by auto with zarith. repeat rewrite Zmult_plus_distr_l. cut (2 * Zpos p * a > 2 * Zpos p * b)%Z. auto with zarith. repeat rewrite <- Zmult_assoc. cut (Zpos p * a > Zpos p * b)%Z; auto with zarith. replace (Zpos (xO p)) with (2 * Zpos p)%Z by auto with zarith. repeat rewrite <- Zmult_assoc. cut (Zpos p * a > Zpos p * b)%Z; auto with zarith. intros Hab H0. inversion H0. Qed. Lemma Zmult_pos_mon_lt_rht : forall a b c : Z, (a > b)%Z -> (c > 0)%Z -> (a * c > b * c)%Z. intros a b c; rewrite (Zmult_comm a c); rewrite (Zmult_comm b c); apply Zmult_pos_mon_lt_lft. Qed. Lemma Zmult_pos_mon : forall a b : Z, (a * b > 0)%Z -> (a * b >= a)%Z. Proof. intros a b. case a. auto with zarith. case b. auto with zarith. intros. set (pp := Zpos p0) in |- * at 2. rewrite <- (Zmult_1_l pp). unfold pp in |- *; clear pp. rewrite Zmult_comm. apply Zmult_pos_mon_le_rht. apply Zge_POS_1. apply Zge_POS_0. intros p q; simpl in |- *; intro H0; inversion H0. intros p H0. apply (Zge_trans (Zneg p * b) 0 (Zneg p)). auto with zarith. apply Zge_0_NEG. Qed. Lemma Zdiv_pos_pos : forall a b : Z, (a * b > 0)%Z -> (a > 0)%Z -> (b > 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *; simpl in |- *; intros; try discriminate; auto. Qed. Lemma Zdiv_pos_nonneg : forall a b : Z, (a * b > 0)%Z -> (a >= 0)%Z -> (b > 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *; simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto). Qed. Lemma Zdiv_pos_neg : forall a b : Z, (a * b > 0)%Z -> (a < 0)%Z -> (b < 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *; simpl in |- *; intros; try discriminate; auto. Qed. Lemma Zdiv_pos_nonpos : forall a b : Z, (a * b > 0)%Z -> (a <= 0)%Z -> (b < 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *; simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto). Qed. Lemma Zdiv_neg_pos : forall a b : Z, (a * b < 0)%Z -> (a > 0)%Z -> (b < 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *; simpl in |- *; intros; try discriminate; auto. Qed. Lemma Zdiv_neg_nonneg : forall a b : Z, (a * b < 0)%Z -> (a >= 0)%Z -> (b < 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *; simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto). Qed. Lemma Zdiv_neg_neg : forall a b : Z, (a * b < 0)%Z -> (a < 0)%Z -> (b > 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt in |- *; simpl in |- *; intros; try discriminate; auto. Qed. Lemma Zdiv_neg_nonpos : forall a b : Z, (a * b < 0)%Z -> (a <= 0)%Z -> (b > 0)%Z. Proof. intros a b; induction a as [| p| p]; [ induction b as [| p| p] | induction b as [| p0| p0] | induction b as [| p0| p0] ]; unfold Z.lt, Z.gt, Z.le, Z.ge in |- *; simpl in |- *; intros H0 H1; (try discriminate; auto); ( try elim H1; auto). Qed. Lemma Zcompat_lt_plus: forall (n m p:Z),(n < m)%Z-> (p+n < p+m)%Z. Proof. intros n m p. intuition. Qed. Transparent Zplus. Lemma lt_succ_Z_of_nat: forall (m:nat)( k n:Z), (Z_of_nat (S m)<(k+n))%Z -> (Z_of_nat m <(k+n))%Z. Proof. intros m k n. simpl. set (H:=(succ_nat m)). rewrite H. intuition. Qed. Opaque Zplus. End zineq. #[global] Hint Resolve Z.lt_gt: zarith. #[global] Hint Resolve Z.gt_lt: zarith. #[global] Hint Resolve Z.le_ge: zarith. #[global] Hint Resolve Z.ge_le: zarith. #[global] Hint Resolve Z.lt_irrefl: zarith. #[global] Hint Resolve Zle_antisymm: zarith. #[global] Hint Resolve Zlt_irref: zarith. #[global] Hint Resolve Zgt_irref: zarith. #[global] Hint Resolve Zlt_NEG_0: zarith. #[global] Hint Resolve Zgt_0_NEG: zarith. #[global] Hint Resolve Zle_NEG_0: zarith. #[global] Hint Resolve Zge_0_NEG: zarith. #[global] Hint Resolve Zle_NEG_1: zarith. #[global] Hint Resolve Zge_1_NEG: zarith. #[global] Hint Resolve Zlt_0_POS: zarith. #[global] Hint Resolve Zgt_POS_0: zarith. #[global] Hint Resolve Zle_0_POS: zarith. #[global] Hint Resolve Zge_POS_0: zarith. #[global] Hint Resolve Zle_1_POS: zarith. #[global] Hint Resolve Zge_POS_1: zarith. #[global] Hint Resolve ZBasics.Zle_neg_pos: zarith. #[global] Hint Resolve ZPOS_neq_ZERO: zarith. #[global] Hint Resolve ZNEG_neq_ZERO: zarith. #[global] Hint Resolve Zgt_ge_succ: zarith. #[global] Hint Resolve Zgt_ge_pred: zarith. #[global] Hint Resolve Zge_gt_succ: zarith. #[global] Hint Resolve Zge_gt_pred: zarith. #[global] Hint Resolve Zlt_asymmetric: zarith. #[global] Hint Resolve Zle_neq_lt: zarith. #[global] Hint Resolve Zmult_pos_mon_le_lft: zarith. #[global] Hint Resolve Zmult_pos_mon_le_rht: zarith. #[global] Hint Resolve Zmult_pos_mon_lt_lft: zarith. #[global] Hint Resolve Zmult_pos_mon_lt_rht: zarith. #[global] Hint Resolve Zmult_pos_mon: zarith. #[global] Hint Resolve Zdiv_pos_pos: zarith. #[global] Hint Resolve Zdiv_pos_neg: zarith. #[global] Hint Resolve Zdiv_pos_nonpos: zarith. #[global] Hint Resolve Zdiv_pos_nonneg: zarith. #[global] Hint Resolve Zdiv_neg_pos: zarith. #[global] Hint Resolve Zdiv_neg_neg: zarith. #[global] Hint Resolve Zdiv_neg_nonpos: zarith. #[global] Hint Resolve Zdiv_neg_nonneg: zarith. (** ** Facts on the absolute value-function over Z *) Section zabs. Lemma Zabs_idemp : forall a : Z, Z.abs (Z.abs a) = Z.abs a. Proof. intro a; case a; auto. Qed. Lemma Zabs_nonneg : forall (a : Z) (p : positive), Z.abs a <> Zneg p. Proof. intros; case a; intros; discriminate. Qed. Lemma Zabs_geq_zero : forall a : Z, (0 <= Z.abs a)%Z. Proof. intro a. case a; unfold Z.abs in |- *; auto with zarith. Qed. Lemma Zabs_elim_nonneg : forall a : Z, (0 <= a)%Z -> Z.abs a = a. Proof. intro a. case a; auto. intros p Hp; elim Hp. apply Zgt_0_NEG. Qed. Lemma Zabs_zero : forall a : Z, Z.abs a = 0%Z -> a = 0%Z. Proof. intro a. case a. tauto. intros; discriminate. intros; discriminate. Qed. Lemma Zabs_Zopp : forall a : Z, Z.abs (- a) = Z.abs a. Proof. intro a. case a; auto with zarith. Qed. Lemma Zabs_geq : forall a : Z, (a <= Z.abs a)%Z. Proof. intro a. unfold Z.abs in |- *. case a; auto with zarith. Qed. Lemma Zabs_Zopp_geq : forall a : Z, (- a <= Z.abs a)%Z. intro a. rewrite <- Zabs_Zopp. apply Zabs_geq. Qed. Lemma Zabs_Zminus_symm : forall a b : Z, Z.abs (a - b) = Z.abs (b - a). intros a b. replace (a - b)%Z with (- (b - a))%Z by auto with zarith. apply Zabs_Zopp. Qed. Lemma Zabs_lt_pos : forall a b : Z, (Z.abs a < b)%Z -> (0 < b)%Z. Proof. intros a b Hab. unfold Z.lt in |- *. elim (Zcompare_Gt_Lt_antisym b 0). intros H1 H2. apply H1. fold (b > 0)%Z in |- *. apply (Zgt_le_trans b (Z.abs a) 0); auto with zarith. Qed. Lemma Zabs_le_pos : forall a b : Z, (Z.abs a <= b)%Z -> (0 <= b)%Z. Proof. intros a b Hab. apply (Z.le_trans 0 (Z.abs a) b). auto with zarith. assumption. Qed. Lemma Zabs_lt_elim : forall a b : Z, (a < b)%Z -> (- a < b)%Z -> (Z.abs a < b)%Z. Proof. intros a b. case a; auto with zarith. Qed. Lemma Zabs_le_elim : forall a b : Z, (a <= b)%Z -> (- a <= b)%Z -> (Z.abs a <= b)%Z. Proof. intros a b. case a; auto with zarith. Qed. Lemma Zabs_mult_compat : forall a b : Z, (Z.abs a * Z.abs b)%Z = Z.abs (a * b). Proof. intros a b. case a; case b; intros; auto with zarith. Qed. (* triangle inequality (with Zplus) *) Let case_POS : forall p q r : positive, (Zpos q + Zneg p)%Z = Zpos r -> (Z.abs (Zpos q + Zneg p) <= Z.abs (Zpos q) + Z.abs (Zneg p))%Z. Proof. intros p q r Hr. rewrite Hr. simpl in |- *. rewrite <- Hr. fold (Zpos q + Zpos p)%Z in |- *. unfold Z.le in |- *. rewrite (Zcompare_plus_compat (Zneg p) (Zpos p) (Zpos q)). apply (ZBasics.Zle_neg_pos p). Defined. Let case_NEG : forall p q r : positive, (Zpos q + Zneg p)%Z = Zneg r -> (Z.abs (Zpos q + Zneg p) <= Z.abs (Zpos q) + Z.abs (Zneg p))%Z. intros p q r Hr. rewrite <- (Z.opp_involutive (Zpos q + Zneg p)) in Hr. rewrite <- (Z.opp_involutive (Zneg r)) in Hr. generalize (Z.opp_inj (- (Zpos q + Zneg p)) (- Zneg r) Hr). intro Hr'. rewrite Zopp_plus_distr in Hr'. unfold Z.opp in Hr'. rewrite <- (Zabs_Zopp (Zpos q + Zneg p)). rewrite Zopp_plus_distr. unfold Z.opp in |- *. rewrite <- (Zabs_Zopp (Zpos q)). unfold Z.opp in |- *. rewrite <- (Zabs_Zopp (Zneg p)). unfold Z.opp in |- *. rewrite (Zplus_comm (Zneg q) (Zpos p)). rewrite (Zplus_comm (Z.abs (Zneg q)) (Z.abs (Zpos p))). rewrite Zplus_comm in Hr'. apply (case_POS _ _ _ Hr'). Defined. Lemma Zabs_triangle : forall a b : Z, (Z.abs (a + b) <= Z.abs a + Z.abs b)%Z. intros a b. case a; case b. 1-5, 7, 9: auto with zarith. intros p q. generalize (case_POS p q) (case_NEG p q). case (Zpos q + Zneg p)%Z. auto with zarith. intros p0 case_POS0 case_NEG0. apply (case_POS0 p0). reflexivity. intros p0 case_POS0 case_NEG0. apply (case_NEG0 p0). reflexivity. intros p q. rewrite (Zplus_comm (Zneg q) (Zpos p)). rewrite (Zplus_comm (Z.abs (Zneg q)) (Z.abs (Zpos p))). generalize (case_POS q p) (case_NEG q p). case (Zpos p + Zneg q)%Z. auto with zarith. intros p0 case_POS0 case_NEG0. apply (case_POS0 p0). reflexivity. intros p0 case_POS0 case_NEG0. apply (case_NEG0 p0). reflexivity. Qed. (* triangle inequality with Zminus *) Lemma Zabs_Zminus_triangle : forall a b : Z, (Z.abs (Z.abs a - Z.abs b) <= Z.abs (a - b))%Z. assert (case : forall a b : Z, (Z.abs a - Z.abs b <= Z.abs (a - b))%Z). intros a b. unfold Z.le in |- *. unfold Zminus in |- *. rewrite <- (Zcompare_plus_compat (Z.abs a + - Z.abs b) (Z.abs (a + - b)) (Z.abs b)) . rewrite (Zplus_comm (Z.abs a) (- Z.abs b)). rewrite Zplus_assoc. rewrite (Zplus_comm (Z.abs b) (- Z.abs b)). rewrite Zplus_opp_l. rewrite Zplus_0_l. assert (l : forall a b : Z, a = (b + (a - b))%Z). auto with zarith. set (a' := a) in |- * at 2. rewrite (l a b). unfold a' in |- *. fold (a - b)%Z in |- *. apply (Zabs_triangle b (a - b)). intros a b. apply Zabs_le_elim. apply case. replace (- (Z.abs a - Z.abs b))%Z with (Z.abs b - Z.abs a)%Z by auto with zarith. rewrite Zabs_Zminus_symm. apply case. Qed. End zabs. #[global] Hint Resolve Zabs_idemp: zarith. #[global] Hint Resolve Zabs_nonneg: zarith. #[global] Hint Resolve Zabs_geq_zero: zarith. #[global] Hint Resolve Zabs_elim_nonneg: zarith. #[global] Hint Resolve Zabs_zero: zarith. #[global] Hint Resolve Zabs_Zopp: zarith. #[global] Hint Resolve Zabs_geq: zarith. #[global] Hint Resolve Zabs_Zopp_geq: zarith. #[global] Hint Resolve Zabs_Zminus_symm: zarith. #[global] Hint Resolve Zabs_lt_pos: zarith. #[global] Hint Resolve Zabs_le_pos: zarith. #[global] Hint Resolve Zabs_lt_elim: zarith. #[global] Hint Resolve Zabs_le_elim: zarith. #[global] Hint Resolve Zabs_mult_compat: zarith. #[global] Hint Resolve Zabs_triangle: zarith. #[global] Hint Resolve Zabs_Zminus_triangle: zarith. (** ** Facts on the sign-function over Z *) Section zsign. Lemma Zsgn_mult_compat : forall a b : Z, (Z.sgn a * Z.sgn b)%Z = Z.sgn (a * b). Proof. intros a b. case a; case b; intros; auto with zarith. Qed. Lemma Zmult_sgn_abs : forall a : Z, (Z.sgn a * Z.abs a)%Z = a. Proof. intro a. case a; intros; auto with zarith. Qed. Lemma Zmult_sgn_eq_abs : forall a : Z, Z.abs a = (Z.sgn a * a)%Z. Proof. intro a. case a; intros; auto with zarith. Qed. Lemma Zsgn_plus_l : forall a b : Z, Z.sgn a = Z.sgn b -> Z.sgn (a + b) = Z.sgn a. Proof. intros a b. case a; case b; simpl in |- *; auto; intros; try discriminate. Qed. Lemma Zsgn_plus_r : forall a b : Z, Z.sgn a = Z.sgn b -> Z.sgn (a + b) = Z.sgn b. Proof. intros. rewrite Zplus_comm. apply Zsgn_plus_l. auto. Qed. Lemma Zsgn_opp : forall z : Z, Z.sgn (- z) = (- Z.sgn z)%Z. Proof. intro z. case z; simpl in |- *; auto. Qed. Lemma Zsgn_ZERO : forall z : Z, Z.sgn z = 0%Z -> z = 0%Z. Proof. intros z. case z; simpl in |- *; intros; auto; try discriminate. Qed. Lemma Zsgn_pos : forall z : Z, Z.sgn z = 1%Z -> (z > 0)%Z. Proof. intros z. case z; simpl in |- *; intros; auto with zarith; try discriminate. Qed. Lemma Zsgn_neg : forall z : Z, Z.sgn z = (-1)%Z -> (z < 0)%Z. Proof. intros z. case z; simpl in |- *; intros; auto with zarith; try discriminate. Qed. End zsign. #[global] Hint Resolve Zsgn_mult_compat: zarith. #[global] Hint Resolve Zmult_sgn_abs: zarith. #[global] Hint Resolve Zmult_sgn_eq_abs: zarith. #[global] Hint Resolve Zsgn_plus_l: zarith. #[global] Hint Resolve Zsgn_plus_r: zarith. #[global] Hint Resolve Zsgn_opp: zarith. #[global] Hint Resolve Zsgn_ZERO: zarith. #[global] Hint Resolve Zsgn_pos: zarith. #[global] Hint Resolve Zsgn_neg: zarith. corn-8.20.0/model/Zmod/ZDivides.v000066400000000000000000000612331473720167500165040ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* ZDivides.v, by Vince Barany *) Require Export CoRN.model.Zmod.ZBasics. (** * The Divides-function over Z In this section the function Zdivides will be defined. Various facts on this Zdivides will then be proved. *) Definition Zdivides (a b : Z) : Prop := exists q : Z, (q * a)%Z = b. (* : Grammar is replaced by Notation *) (* : Syntax is discontinued *) Section zdivides. Lemma Zdivides_ref : forall a : Z, Zdivides a a. Proof. intro. exists 1%Z. auto with zarith. Qed. Lemma Zdivides_trans : forall a b c : Z, Zdivides a b -> Zdivides b c -> Zdivides a c. Proof. intros. unfold Zdivides in H; elim H; intros. unfold Zdivides in H0; elim H0; intros. exists (x0 * x)%Z. rewrite <- H2. rewrite <- H1. auto with zarith. Qed. Lemma Zdivides_zero_rht : forall z : Z, Zdivides z 0. Proof. intro. exists 0%Z. auto with zarith. Qed. Lemma Zdivides_zero_lft : forall z : Z, Zdivides 0 z -> z = 0%Z. Proof. intro z. intro Hdiv; elim Hdiv. auto with zarith. Qed. Lemma Zdivides_one : forall z : Z, Zdivides 1 z. Proof. intro. exists z. auto with zarith. Qed. (* Zdivides_antysym see below *) Lemma Zdivides_mult_intro_lft : forall a b c : Z, Zdivides (a * b) c -> Zdivides b c. Proof. intros a b c H. unfold Zdivides in H; elim H; intros q H_. exists (q * a)%Z. rewrite <- Zmult_assoc. assumption. Qed. Lemma Zdivides_mult_intro_rht : forall a b c : Z, Zdivides (a * b) c -> Zdivides a c. Proof. intros a b c H. unfold Zdivides in H; elim H; intros q H_. exists (q * b)%Z. rewrite <- Zmult_assoc. rewrite (Zmult_comm b a). assumption. Qed. Lemma Zdivides_mult_lft : forall a b : Z, Zdivides b (a * b). Proof. intros. exists a. auto with zarith. Qed. Lemma Zdivides_mult_rht : forall a b : Z, Zdivides a (a * b). Proof. intros. exists b. auto with zarith. Qed. Lemma Zdivides_mult_elim_lft : forall a b c : Z, Zdivides a c -> Zdivides a (b * c). Proof. intros. apply (Zdivides_trans a c (b * c)). assumption. apply Zdivides_mult_lft. Qed. Lemma Zdivides_mult_elim_rht : forall a b c : Z, Zdivides a b -> Zdivides a (b * c). Proof. intros. apply (Zdivides_trans a b (b * c)). assumption. apply Zdivides_mult_rht. Qed. Lemma Zdivides_mult_cancel_lft : forall a b c : Z, Zdivides a b -> Zdivides (c * a) (c * b). Proof. intros. unfold Zdivides in H; elim H; intros. exists x. rewrite <- H0. rewrite Zmult_assoc. rewrite Zmult_assoc. rewrite (Zmult_comm x c). reflexivity. Qed. Lemma Zdivides_mult_cancel_rht : forall a b c : Z, Zdivides a b -> Zdivides (a * c) (b * c). Proof. intros. unfold Zdivides in H; elim H; intros. exists x. rewrite <- H0. auto with zarith. Qed. Let Zdiv_one_is_one : forall a : Z, (a > 0)%Z -> Zdivides a 1 -> a = 1%Z. Proof. intros a H0 H1. unfold Zdivides in H1; elim H1; intros q H1_. apply Zle_antisymm. auto with zarith. rewrite <- (Zplus_0_l a). rewrite <- H1_. rewrite <- (Zmult_1_l (0 + a)). rewrite (Zplus_0_l a). apply (Zmult_pos_mon_le_rht q 1 a). 2: auto with zarith. cut (q > 0)%Z. auto with zarith. rewrite Zmult_comm in H1_. apply (Zdiv_pos_pos a); auto with zarith. Defined. Lemma Zdivides_antisymm : forall a b : Z, (a > 0)%Z -> (b > 0)%Z -> Zdivides a b -> Zdivides b a -> a = b. Proof. intros a b H01 H02 H1 H2. unfold Zdivides in H1; elim H1; intros q1 H1_. unfold Zdivides in H2; elim H2; intros q2 H2_. generalize H2_; intro H12_. rewrite <- H1_ in H12_. rewrite Zmult_assoc in H12_. rewrite Zmult_comm in H12_. rewrite <- H1_. rewrite <- (Zmult_1_l a). assert (Zdivides q1 1). replace 1%Z with (q2 * q1)%Z. apply Zdivides_mult_elim_lft. apply Zdivides_ref. apply (Zunit_eq_one (q2 * q1) a). auto with zarith. assumption. replace q1 with 1%Z. auto with zarith. symmetry in |- *. rewrite Zmult_comm in H1_; rewrite <- H1_ in H02. apply Zdiv_one_is_one; auto. apply (Zdiv_pos_pos a); auto. Qed. Lemma Zdivides_plus_elim : forall a b c : Z, Zdivides a b -> Zdivides a c -> Zdivides a (b + c). Proof. intros a b c H1 H2. unfold Zdivides in H1; elim H1; intros q1 H1_. unfold Zdivides in H2; elim H2; intros q2 H2_. exists (q1 + q2)%Z. rewrite Zmult_plus_distr_l. auto with zarith. Qed. Lemma Zdivides_opp_elim_lft : forall a b : Z, Zdivides a b -> Zdivides (- a) b. Proof. intros a b H. unfold Zdivides in H; elim H; intros q H_. exists (- q)%Z. rewrite Zmult_opp_opp. assumption. Qed. Lemma Zdivides_opp_elim_rht : forall a b : Z, Zdivides a b -> Zdivides a (- b). Proof. intros a b H. unfold Zdivides in H; elim H; intros q H_. exists (- q)%Z. rewrite Zopp_mult_distr_l_reverse. auto with zarith. Qed. Lemma Zdivides_opp_elim : forall a b : Z, Zdivides a b -> Zdivides (- a) (- b). Proof. intros. apply Zdivides_opp_elim_lft. apply Zdivides_opp_elim_rht. assumption. Qed. Lemma Zdivides_opp_intro_lft : forall a b : Z, Zdivides (- a) b -> Zdivides a b. Proof. intros a b H. rewrite <- (Z.opp_involutive a). apply (Zdivides_opp_elim_lft _ _ H). Qed. Lemma Zdivides_opp_intro_rht : forall a b : Z, Zdivides a (- b) -> Zdivides a b. Proof. intros a b H. rewrite <- (Z.opp_involutive b). apply (Zdivides_opp_elim_rht _ _ H). Qed. Lemma Zdivides_opp_intro : forall a b : Z, Zdivides (- a) (- b) -> Zdivides a b. Proof. intros. apply Zdivides_opp_intro_lft. apply Zdivides_opp_intro_rht. assumption. Qed. Lemma Zdivides_minus_elim : forall a b c : Z, Zdivides a b -> Zdivides a c -> Zdivides a (b - c). Proof. intros. unfold Zminus in |- *. apply Zdivides_plus_elim. assumption. apply Zdivides_opp_elim_rht. assumption. Qed. Lemma Zdivides_mult_elim : forall a b c d : Z, Zdivides a b -> Zdivides c d -> Zdivides (a * c) (b * d). Proof. intros a b c d H1 H2. unfold Zdivides in H1; elim H1; intros q1 H1_. unfold Zdivides in H2; elim H2; intros q2 H2_. exists (q1 * q2)%Z. rewrite <- H1_. rewrite <- H2_. rewrite Zmult_assoc. rewrite Zmult_assoc. rewrite <- (Zmult_assoc q1 q2 a). rewrite (Zmult_comm q2 a). rewrite Zmult_assoc. reflexivity. Qed. Lemma Zdivides_mult_ll : forall a b c d : Z, (a * b)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. Proof. intros a b c d Heq Ha Hdiv. elim Hdiv; intros x Hx. rewrite <- Hx in Heq. exists x. apply (Zmult_intro_lft a). assumption. rewrite Heq. rewrite Zmult_assoc. rewrite (Zmult_comm x a). auto. Qed. Lemma Zdivides_mult_lr : forall a b c d : Z, (a * b)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. Proof. intros a b c d; rewrite (Zmult_comm d c); apply Zdivides_mult_ll. Qed. Lemma Zdivides_mult_rl : forall a b c d : Z, (b * a)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. Proof. intros a b c d; rewrite (Zmult_comm b a); apply Zdivides_mult_ll. Qed. Lemma Zdivides_mult_rr : forall a b c d : Z, (b * a)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. intros a b c d; rewrite (Zmult_comm b a); rewrite (Zmult_comm d c); apply Zdivides_mult_ll. Qed. Lemma Zdivides_abs_elim_lft : forall a b : Z, Zdivides a b -> Zdivides (Z.abs a) b. Proof. intros a b. case a; simpl in |- *; auto. intros p H. generalize (Zdivides_opp_elim_lft (Zneg p) b H). simpl in |- *; auto. Qed. Lemma Zdivides_abs_elim_rht : forall a b : Z, Zdivides a b -> Zdivides a (Z.abs b). Proof. intros a b. case b; simpl in |- *; auto. intros p H. generalize (Zdivides_opp_elim_rht a (Zneg p) H). simpl in |- *; auto. Qed. Lemma Zdivides_abs_elim : forall a b : Z, Zdivides a b -> Zdivides (Z.abs a) (Z.abs b). Proof. intros. apply Zdivides_abs_elim_lft. apply Zdivides_abs_elim_rht. assumption. Qed. Lemma Zdivides_abs_intro_lft : forall a b : Z, Zdivides (Z.abs a) b -> Zdivides a b. Proof. intros a b. case a; simpl in |- *; auto. intros p; apply (Zdivides_opp_intro_lft (Zneg p) b). Qed. Lemma Zdivides_abs_intro_rht : forall a b : Z, Zdivides a (Z.abs b) -> Zdivides a b. Proof. intros a b. case b; simpl in |- *; auto. intros p; apply (Zdivides_opp_intro_rht a (Zneg p)). Qed. Lemma Zdivides_abs_intro : forall a b : Z, Zdivides (Z.abs a) (Z.abs b) -> Zdivides a b. Proof. intros. apply Zdivides_abs_intro_lft. apply Zdivides_abs_intro_rht. assumption. Qed. Lemma Zdivisor_pos_le : forall a b : Z, (a > 0)%Z -> Zdivides b a -> (a >= b)%Z. Proof. unfold Zdivides in |- *. intros. elim H0. intros. rewrite <- H1. rewrite Zmult_comm. apply Zmult_pos_mon. rewrite Zmult_comm. rewrite H1. assumption. Qed. Lemma Zdivisor_small : forall a b : Z, Zdivides b a -> (Z.abs a < b)%Z -> a = 0%Z. Proof. intros a b Hdiv Hlt. generalize (Zdivides_abs_elim_rht _ _ Hdiv); intro Hdivabs. set (A := a). assert (HA : A = a). auto. generalize HA. case A. auto. intros p Hp. assert (Hfalse : (b < b)%Z). apply (Z.le_lt_trans b (Z.abs a) b). apply Z.ge_le. apply (Zdivisor_pos_le (Z.abs a) b). rewrite <- Hp; simpl in |- *; auto with zarith. assumption. assumption. elim (Z.lt_irrefl b Hfalse). intros p Hp. assert (Hfalse : (b < b)%Z). apply (Z.le_lt_trans b (Z.abs a) b). apply Z.ge_le. apply (Zdivisor_pos_le (Z.abs a) b). rewrite <- Hp; simpl in |- *. auto with zarith. assumption. assumption. elim (Z.lt_irrefl b Hfalse). Qed. Lemma Zmodeq_small : forall a b c : Z, (0 <= a < c)%Z -> (0 <= b < c)%Z -> Zdivides c (a - b) -> a = b. Proof. intros a b c Ha Hb Hc. cut ((a - b)%Z = 0%Z); auto with zarith. apply (Zdivisor_small (a - b) c). assumption. apply Zabs_lt_elim; auto with zarith. Qed. Lemma Zdiv_remainder_unique : forall a b q1 r1 q2 r2 : Z, a = (q1 * b + r1)%Z -> (0 <= r1 < b)%Z -> a = (q2 * b + r2)%Z -> (0 <= r2 < b)%Z -> r1 = r2. Proof. intros a b q1 r1 q2 r2 Hq1 Hr1 Hq2 Hr2. apply (Zmodeq_small r1 r2 b). assumption. assumption. assert ((r1 - r2)%Z = ((q2 - q1) * b)%Z). rewrite Hq1 in Hq2. rewrite BinInt.Zmult_minus_distr_r. auto with zarith. rewrite H. apply Zdivides_mult_elim_lft. apply Zdivides_ref. Qed. Lemma Zdiv_quotient_unique : forall a b q1 r1 q2 r2 : Z, a = (q1 * b + r1)%Z -> (0 <= r1 < b)%Z -> a = (q2 * b + r2)%Z -> (0 <= r2 < b)%Z -> q1 = q2. Proof. intros a b q1 r1 q2 r2 Hq1 Hr1 Hq2 Hr2. assert (Hr : r1 = r2). apply (Zdiv_remainder_unique a b q1 r1 q2 r2); assumption. rewrite Hr in Hq1. rewrite Hq1 in Hq2. assert (Hb0 : b <> 0%Z). assert (Hbpos : (0 < b)%Z). apply (Z.le_lt_trans 0 r1 b). tauto. tauto. auto with zarith. assert (Hb : (q1 * b)%Z = (q2 * b)%Z). auto with zarith. apply (Zmult_intro_rht _ _ _ Hb0 Hb). Qed. Lemma Zmod0_Zopp : forall a b : Z, b <> 0%Z -> (a mod b)%Z = 0%Z -> (a mod - b)%Z = 0%Z. Proof. intros a b. generalize (Z_mod_lt (Z.abs a) (Z.abs b)). case a. case b; unfold Z.abs, Z.opp, Z.modulo, Z.div_eucl in |- *; auto with zarith. case b; unfold Z.abs, Z.opp, Z.modulo, Z.div_eucl in |- *. auto with zarith. intros p q. elim (BinIntDef.Z.pos_div_eucl q (Zpos p)); intros Q R. intros Hlt Hp HR; rewrite HR; auto with zarith. intros p q. elim (BinIntDef.Z.pos_div_eucl q (Zpos p)); intros Q R. case R. auto with zarith. intro r'; intros H0 H1 H2. enough (Zpos r' = Zpos p) by auto with zarith. fold (- Zpos p)%Z in H2. auto with zarith. intro r'; intros H0 H1 H2. elim H0; auto with zarith. case b; unfold Z.abs, Z.opp, Z.modulo, Z.div_eucl in |- *. auto with zarith. intros p q. elim (BinIntDef.Z.pos_div_eucl q (Zpos p)); intros Q R. case R; intros r' H0; intros; try (cut (Zpos r' = Zpos p); elim H0); auto with zarith. intros p q. elim (BinIntDef.Z.pos_div_eucl q (Zpos p)); intros Q R. case R; intros; try discriminate; try tauto. Qed. Lemma Zdiv_Zopp : forall a b : Z, (a mod b)%Z = 0%Z -> (a / - b)%Z = (- (a / b))%Z. Proof. intros a b. unfold Z.modulo, Z.div, Z.div_eucl in |- *. case a. auto. intro A. case b; unfold Z.opp in |- *. auto. intro B. elim (BinIntDef.Z.pos_div_eucl A (Zpos B)); intros q r. intro Hr; rewrite Hr; auto. intro B. generalize (Z_mod_lt (Zpos A) (Zpos B)). unfold Z.modulo, Z.div_eucl in |- *. elim (BinIntDef.Z.pos_div_eucl A (Zpos B)); intros q r. case r. intros _ HR; fold (- q)%Z in |- *; fold (- - q)%Z in |- *; rewrite Z.opp_involutive; auto. intros R Hlt HR. assert (H : Zpos R = Zpos B). rewrite <- (Zplus_0_r (Zpos B)); rewrite <- HR; rewrite Zplus_assoc; fold (- Zpos B)%Z in |- *. auto with zarith. rewrite H in Hlt. elim Hlt; auto with zarith. intros R Hlt HR. elim Hlt; auto with zarith; intro Hfalse; elim Hfalse; auto with zarith. intro A. case b; unfold Z.opp in |- *. auto. intro B. generalize (Z_mod_lt (Zpos A) (Zpos B)). unfold Z.modulo, Z.div_eucl in |- *. elim (BinIntDef.Z.pos_div_eucl A (Zpos B)); intros q r. case r. intros _ HR; fold (- q)%Z in |- *; fold (- - q)%Z in |- *; rewrite Z.opp_involutive; auto. intros R Hlt HR. assert (H : Zpos R = Zpos B). rewrite <- (Zplus_0_r (Zpos R)); rewrite <- HR; unfold Zminus in |- *; rewrite Zplus_assoc; auto with zarith. rewrite H in Hlt. elim Hlt; auto with zarith. intros R Hlt HR. elim Hlt; auto with zarith; intro Hfalse; elim Hfalse; auto with zarith. intro B. generalize (Z_mod_lt (Zpos A) (Zpos B)). unfold Z.modulo, Z.div_eucl in |- *. elim (BinIntDef.Z.pos_div_eucl A (Zpos B)); intros q r. case r. intros _ HR; fold (- q)%Z in |- *; auto. intros; discriminate. intros; discriminate. Qed. Lemma Zmod0_Zdivides_pos : forall a b : Z, (b > 0)%Z -> Zdivides b a -> (a mod b)%Z = 0%Z. Proof. intros a b Hb Hdiv. elim Hdiv; intros q Hq. rewrite (Z_div_mod_eq_full a b) in Hq. rewrite <- (Zplus_0_r (q * b)) in Hq. symmetry in |- *. apply (Zdiv_remainder_unique (q * b + 0) b q 0 (a / b) (a mod b)). reflexivity. auto with zarith. rewrite (Zmult_comm (a / b) b); exact Hq. apply Z_mod_lt; auto with zarith. Qed. Lemma Zdivides_Zmod0_pos : forall a b : Z, (a mod b)%Z = 0%Z -> Zdivides b a. Proof. intros a b Hmod. rewrite (Z_div_mod_eq_full a b). rewrite (Zmult_comm b (a / b)); rewrite Hmod; rewrite Zplus_0_r. exists (a / b)%Z. reflexivity. Qed. Lemma Zmod0_Zdivides : forall a b : Z, b <> 0%Z -> Zdivides b a -> (a mod b)%Z = 0%Z. Proof. intros a b. case b. tauto. intros p _; apply Zmod0_Zdivides_pos; auto with zarith. intros p _. generalize (Zmod0_Zdivides_pos a (Zpos p)); intro H. fold (- Zpos p)%Z in |- *. intro Hdiv. apply Zmod0_Zopp. intro; discriminate. apply H. auto with zarith. rewrite <- (Z.opp_involutive (Zpos p)). apply Zdivides_opp_elim_lft. assumption. Qed. Lemma Zdivides_Zmod0 : forall a b : Z, b <> 0%Z -> (a mod b)%Z = 0%Z -> Zdivides b a. Proof. intros a b. case b. tauto. intros p _; apply Zdivides_Zmod0_pos; auto with zarith. intros p _. generalize (Zdivides_Zmod0_pos a (Zpos p)); intro H. fold (- Zpos p)%Z in |- *. intro Hmod. apply Zdivides_opp_elim_lft. apply H. auto with zarith. rewrite <- (Z.opp_involutive (Zpos p)). apply Zmod0_Zopp. simpl in |- *; intros; discriminate. assumption. Qed. Lemma Zmod_mult_cancel_lft : forall a b : Z, ((a * b) mod a)%Z = 0%Z. Proof. intros a b. case a. auto with zarith. intro p. apply Zmod0_Zdivides_pos. auto with zarith. apply Zdivides_mult_elim_rht. apply Zdivides_ref. intro p. apply Zmod0_Zdivides. auto with zarith. apply Zdivides_mult_elim_rht. apply Zdivides_ref. Qed. Lemma Zmod_mult_cancel_rht : forall a b : Z, ((a * b) mod b)%Z = 0%Z. Proof. intros a b. rewrite Zmult_comm. apply Zmod_mult_cancel_lft. Qed. Lemma Zdiv_mult_cancel_lft : forall a b : Z, a <> 0%Z -> (a * b / a)%Z = b. Proof. intros a b. case a. auto with zarith. intros p _. apply (Zdiv_quotient_unique (Zpos p * b) (Zpos p) (Zpos p * b / Zpos p) ((Zpos p * b) mod Zpos p) b 0). rewrite (Zmult_comm (Zpos p * b / Zpos p) (Zpos p)). apply Z_div_mod_eq_full. apply Z_mod_lt; auto with zarith. rewrite Zplus_0_r; auto with zarith. auto with zarith. intros p _. fold (- Zpos p)%Z in |- *. rewrite Zdiv_Zopp. cut ((- Zpos p * b / Zpos p)%Z = (- b)%Z); auto with zarith. unfold Z.opp in |- *; fold (- b)%Z in |- *. apply (Zdiv_quotient_unique (Zneg p * b) (Zpos p) (Zneg p * b / Zpos p) ((Zneg p * b) mod Zpos p) (- b) 0). rewrite (Zmult_comm (Zneg p * b / Zpos p) (Zpos p)). apply Z_div_mod_eq_full. apply Z_mod_lt; auto with zarith. rewrite Zplus_0_r; rewrite Zmult_opp_comm; fold (- Zpos p)%Z in |- *; auto with zarith. auto with zarith. rewrite Zmult_opp_comm. apply Zmod_mult_cancel_lft. Qed. Lemma Zdiv_mult_cancel_rht : forall a b : Z, b <> 0%Z -> (a * b / b)%Z = a. Proof. intros a b. rewrite Zmult_comm. apply Zdiv_mult_cancel_lft. Qed. Lemma Zdiv_plus_elim : forall a b d : Z, Zdivides d a -> Zdivides d b -> ((a + b) / d)%Z = (a / d + b / d)%Z. Proof. intros a b d Ha Hb. case (Zdec d). intro Hd; rewrite Hd; case (a + b)%Z; case a; case b; simpl in |- *; auto. intro Hd. elim Ha; clear Ha; intros x Ha; rewrite <- Ha. elim Hb; clear Hb; intros y Hb; rewrite <- Hb. rewrite <- Zmult_plus_distr_l. repeat rewrite Zdiv_mult_cancel_rht; auto. Qed. Lemma Zdiv_elim : forall a b d : Z, d <> 0%Z -> Zdivides d a -> Zdivides d b -> (a / d)%Z = (b / d)%Z -> a = b. Proof. intros a b d Hd Ha Hb. elim Ha; clear Ha; intros x Ha; rewrite <- Ha. elim Hb; clear Hb; intros y Hb; rewrite <- Hb. repeat rewrite Zdiv_mult_cancel_rht; auto. intro Hxy; rewrite Hxy; auto. Qed. Lemma Zabs_div_lft : forall a : Z, (Z.abs a / a)%Z = Z.sgn a. Proof. intro a. rewrite Zmult_sgn_eq_abs. case (Zdec a). intro Ha. rewrite Ha. simpl in |- *. auto with zarith. apply Zdiv_mult_cancel_rht. Qed. Lemma Zabs_div_rht : forall a : Z, (a / Z.abs a)%Z = Z.sgn a. Proof. intro a. set (A := Z.abs a). set (sa := Z.sgn a). replace a with (Z.abs a * Z.sgn a)%Z. unfold sa in |- *; clear sa. case (Zdec A). unfold A in |- *; intro HA. cut (a = 0%Z); auto with zarith. intro Ha; rewrite Ha; auto with zarith. unfold A in |- *; apply Zdiv_mult_cancel_lft. rewrite Zmult_comm. auto with zarith. Qed. Lemma Zdiv_same : forall a : Z, a <> 0%Z -> (a / a)%Z = 1%Z. Proof. intros a. case a. tauto. intros; apply Z_div_same; auto with zarith. intros A HA. fold (- Zpos A)%Z in |- *. rewrite Zdiv_Zopp. simpl in |- *. replace (Zpos A) with (Z.abs (Zneg A)); auto. rewrite Zabs_div_rht. auto. replace (- Zpos A)%Z with (-1 * Zpos A)%Z; auto with zarith. apply Zmod_mult_cancel_rht. Qed. Lemma Zmult_div_simpl_1 : forall a b c d : Z, (a * b)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. Proof. intros a b c d Heq Ha Hdiv. elim Hdiv; intros x Hx. rewrite <- Hx in Heq. rewrite (Zmult_comm x a) in Heq. rewrite <- Zmult_assoc in Heq. exists x. apply (Zmult_intro_lft a); auto. Qed. Lemma Zmult_div_simpl_2 : forall a b c d : Z, (a * b)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. Proof. intros a b c d; rewrite (Zmult_comm d c); apply Zmult_div_simpl_1. Qed. Lemma Zmult_div_simpl_3 : forall a b c d : Z, (b * a)%Z = (c * d)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. Proof. intros a b c d; rewrite (Zmult_comm b a); apply Zmult_div_simpl_1. Qed. Lemma Zmult_div_simpl_4 : forall a b c d : Z, (b * a)%Z = (d * c)%Z -> a <> 0%Z -> Zdivides a c -> Zdivides d b. intros a b c d; rewrite (Zmult_comm b a); rewrite (Zmult_comm d c); apply Zmult_div_simpl_1. Qed. Lemma Zdivides_dec : forall a b : Z, {Zdivides a b} + {~ Zdivides a b}. Proof. intros a b. case (Zdec b). intro Hb. rewrite Hb. left. apply Zdivides_zero_rht. intro Hb. case (Zdec a). intro Ha. rewrite Ha. right. intro H0. rewrite (Zdivides_zero_lft b H0) in Hb. elim Hb. auto. intro Ha. generalize (Zdivides_Zmod0 b a Ha). generalize (Zmod0_Zdivides b a Ha). case (Zdec (b mod a)); auto. Qed. End zdivides. #[global] Hint Resolve Zdivides_zero_lft: zarith. #[global] Hint Resolve Zdivides_zero_rht: zarith. #[global] Hint Resolve Zdivides_one: zarith. #[global] Hint Resolve Zdivides_ref: zarith. #[global] Hint Resolve Zdivides_trans: zarith. #[global] Hint Resolve Zdivides_mult_intro_lft: zarith. #[global] Hint Resolve Zdivides_mult_intro_rht: zarith. #[global] Hint Resolve Zdivides_mult_lft: zarith. #[global] Hint Resolve Zdivides_mult_rht: zarith. #[global] Hint Resolve Zdivides_mult_elim_lft: zarith. #[global] Hint Resolve Zdivides_mult_elim_rht: zarith. #[global] Hint Resolve Zdivides_mult_cancel_lft: zarith. #[global] Hint Resolve Zdivides_mult_cancel_rht: zarith. #[global] Hint Resolve Zdivides_antisymm: zarith. #[global] Hint Resolve Zdivides_plus_elim: zarith. #[global] Hint Resolve Zdivides_opp_elim_lft: zarith. #[global] Hint Resolve Zdivides_opp_elim_rht: zarith. #[global] Hint Resolve Zdivides_opp_elim: zarith. #[global] Hint Resolve Zdivides_opp_intro_lft: zarith. #[global] Hint Resolve Zdivides_opp_intro_rht: zarith. #[global] Hint Resolve Zdivides_opp_intro: zarith. #[global] Hint Resolve Zdivides_minus_elim: zarith. #[global] Hint Resolve Zdivides_mult_elim: zarith. #[global] Hint Resolve Zdivides_mult_ll: zarith. #[global] Hint Resolve Zdivides_mult_lr: zarith. #[global] Hint Resolve Zdivides_mult_rl: zarith. #[global] Hint Resolve Zdivides_mult_rr: zarith. #[global] Hint Resolve Zdivides_abs_elim_lft: zarith. #[global] Hint Resolve Zdivides_abs_elim_rht: zarith. #[global] Hint Resolve Zdivides_abs_elim: zarith. #[global] Hint Resolve Zdivides_abs_intro_lft: zarith. #[global] Hint Resolve Zdivides_abs_intro_rht: zarith. #[global] Hint Resolve Zdivides_abs_intro: zarith. #[global] Hint Resolve Zdivisor_pos_le: zarith. #[global] Hint Resolve Zdivisor_small: zarith. #[global] Hint Resolve Zmodeq_small: zarith. #[global] Hint Resolve Zdiv_remainder_unique: zarith. #[global] Hint Resolve Zdiv_quotient_unique: zarith. #[global] Hint Resolve Zmod0_Zopp: zarith. #[global] Hint Resolve Zdiv_Zopp: zarith. #[global] Hint Resolve Zmod0_Zdivides: zarith. #[global] Hint Resolve Zdivides_Zmod0: zarith. #[global] Hint Resolve Zmod_mult_cancel_lft: zarith. #[global] Hint Resolve Zmod_mult_cancel_rht: zarith. #[global] Hint Resolve Zdiv_mult_cancel_lft: zarith. #[global] Hint Resolve Zdiv_mult_cancel_rht: zarith. #[global] Hint Resolve Zdiv_plus_elim: zarith. #[global] Hint Resolve Zdiv_elim: zarith. #[global] Hint Resolve Zabs_div_lft: zarith. #[global] Hint Resolve Zabs_div_rht: zarith. #[global] Hint Resolve Zdiv_same: zarith. #[global] Hint Resolve Zmult_div_simpl_1: zarith. #[global] Hint Resolve Zmult_div_simpl_2: zarith. #[global] Hint Resolve Zmult_div_simpl_3: zarith. #[global] Hint Resolve Zmult_div_simpl_4: zarith. #[global] Hint Resolve Zdivides_dec: zarith. Section ineq. Lemma Zmod_POS_nonNEG : forall a b p : positive, (Zpos a mod Zpos b)%Z <> Zneg p. Proof. intros a b p. generalize (Z_mod_lt (Zpos a) (Zpos b)). intro H. elim H. intros H0 H1. intro Hfalse. rewrite Hfalse in H0. elim H0. auto with zarith. auto with zarith. Qed. Lemma Zdiv_POS : forall a b : positive, (Zpos b * (Zpos a / Zpos b) <= Zpos a)%Z. Proof. intros a b. rewrite <- (Zplus_0_r (Zpos b * (Zpos a / Zpos b))). set (lhs := (Zpos b * (Zpos a / Zpos b) + 0)%Z) in *. rewrite (Z_div_mod_eq_full (Zpos a) (Zpos b)). unfold lhs in |- *. apply Zplus_le_compat_l. auto with zarith. generalize (Z_mod_lt (Zpos a) (Zpos b)). intro H. elim H. auto with zarith. auto with zarith. Qed. Lemma Zmod_lt_POS : forall a b : positive, (Zpos a < Zpos b)%Z -> (Zpos a mod Zpos b)%Z = Zpos a. Proof. intros a b Hlt. apply (Zdiv_remainder_unique (Zpos a) (Zpos b) (Zpos a / Zpos b) (Zpos a mod Zpos b) 0 (Zpos a)); auto with zarith. rewrite Zmult_comm. apply Z_div_mod_eq_full. apply Z_mod_lt; auto with zarith. Qed. Lemma Zdiv_lt_POS : forall a b : positive, (Zpos a < Zpos b)%Z -> (Zpos a / Zpos b)%Z = 0%Z. Proof. intros a b Hlt. apply (Zdiv_quotient_unique (Zpos a) (Zpos b) (Zpos a / Zpos b) (Zpos a mod Zpos b) 0 (Zpos a)); auto with zarith. rewrite Zmult_comm. apply Z_div_mod_eq_full. apply Z_mod_lt; auto with zarith. Qed. End ineq. #[global] Hint Resolve Zmod_POS_nonNEG: zarith. #[global] Hint Resolve Zdiv_POS: zarith. #[global] Hint Resolve Zmod_lt_POS: zarith. #[global] Hint Resolve Zdiv_lt_POS: zarith. corn-8.20.0/model/Zmod/ZGcd.v000066400000000000000000001333511473720167500156130ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* ZGcd.v, by Vince Barany *) Require Export CoRN.model.Zmod.ZDivides. Require Export Coq.Init.Wf. From Coq Require Import Lia. (** * The GCD-function over Z In this file we will define a GCD-function over Z. To do that we first look at a GCD-function over the positive numbers. At the end we will also define what it is for two numbers to be relatively prime, and what prime numbers are. ** GCD over `positive' *) Section pgcd. Definition pp := (positive * positive)%type. Definition pp_lt (x y : pp) := let (a, b) := x in let (c, d) := y in (b ?= d)%positive = Datatypes.Lt. Lemma pp_lt_wf : Wf.well_founded pp_lt. Proof. red in |- *. intros x. assert (forall (n : nat) (a b : positive), nat_of_P b < n -> Acc pp_lt (a, b)). simple induction n. intros a b H0. elim (Nat.nlt_0_r _ H0). intros n0 Hind a b HSn0. assert (Hdisj : nat_of_P b < n0 \/ nat_of_P b = n0). lia. elim Hdisj. apply Hind. intro Heq. assert (Hy : forall y : pp, pp_lt y (a, b) -> Acc pp_lt y). intro y; elim y; intros c d Hdb. unfold pp_lt in Hdb. assert (Hd : nat_of_P d < n0). rewrite <- Heq. apply nat_of_P_lt_Lt_compare_morphism. exact Hdb. apply Hind. exact Hd. exact (Acc_intro (a, b) Hy). elim x; intros a b. apply (H (S (nat_of_P b))). auto. Qed. Lemma rem_lt : forall a b r : positive, (Zpos a mod Zpos b)%Z = Zpos r -> pp_lt (b, r) (a, b). Proof. intros a b r Hr. generalize (Z_mod_lt (Zpos a) (Zpos b)). intro H; elim H; clear H. intros H0 H1. rewrite Hr in H1. unfold pp_lt in |- *. auto with zarith. auto with zarith. Qed. Lemma rem_dec : forall a b : positive, ((Zpos a mod Zpos b)%Z = 0%Z) or ({r : positive| (Zpos a mod Zpos b)%Z = Zpos r}). Proof. intros a b. set (r := (Zpos a mod Zpos b)%Z) in *. assert (Hr : r = (Zpos a mod Zpos b)%Z); auto; generalize Hr. case (Zpos a mod Zpos b)%Z. intros; left; auto. intros p Hp; right; exists p; auto. intros p Hp; unfold r in Hp; elim (Zmod_POS_nonNEG _ _ _ Hp). Defined. (* Eval compute in (rem_dec 3 2). *) Definition pp_gcd_ind (ab : pp) : (forall cd : pp, pp_lt cd ab -> positive * (Z * Z)) -> positive * (Z * Z) := prod_rec (fun ab : positive * positive => (forall cd : pp, pp_lt cd ab -> positive * (Z * Z)) -> positive * (Z * Z)) (fun (a b : positive) (Hind : forall cd : pp, pp_lt cd (a, b) -> positive * (Z * Z)) => match rem_dec a b with | inl _ => (b, (0%Z, 1%Z)) | inr (existT _ r' Hr') => let (d, uv) := Hind (b, r') (rem_lt a b r' Hr') in let (u, v) := uv in (d, (v, (u - Zpos a / Zpos b * v)%Z)) end) ab. (* Eval compute in (pp_gcd_ind (3%positive, 2%positive)). *) Lemma pp_gcd_ind_ext : forall (x : pp) (f g : forall y : pp, pp_lt y x -> positive * (Z * Z)), (forall (y : pp) (p : pp_lt y x), f y p = g y p) -> pp_gcd_ind x f = pp_gcd_ind x g. Proof. intros x; elim x; intros a b. intros f g Hext. simpl in |- *. case (rem_dec a b). auto. intro Hex; elim Hex; intros r Hr. rewrite Hext. auto. Qed. Definition p_gcd_duv (a b : positive) := Fix pp_lt_wf (fun _: pp => (positive * (Z * Z))%type) pp_gcd_ind (a, b). Definition p_gcd (a b : positive) := let (d, _) := p_gcd_duv a b in d. Definition p_gcd_coeff_a (a b : positive) := let (_, uv) := p_gcd_duv a b in let (u, _) := uv in u. Definition p_gcd_coeff_b (a b : positive) := let (_, uv) := p_gcd_duv a b in let (_, v) := uv in v. Lemma p_gcd_duv_rec_zero : forall a b : positive, (Zpos a mod Zpos b)%Z = 0%Z -> p_gcd_duv a b = (b, (0%Z, 1%Z)). Proof. intros a b Hr. unfold p_gcd_duv. rewrite Fix_eq. simpl. case (rem_dec a b). auto. intro Hex; elim Hex; intros r' Hr'. rewrite Hr in Hr'. discriminate. apply pp_gcd_ind_ext. Qed. Lemma p_gcd_rec_zero : forall a b : positive, (Zpos a mod Zpos b)%Z = 0%Z -> p_gcd a b = b. Proof. intros a b H0. unfold p_gcd in |- *. rewrite p_gcd_duv_rec_zero. reflexivity. exact H0. Qed. Lemma p_gcd_coeff_a_rec_zero : forall a b : positive, (Zpos a mod Zpos b)%Z = 0%Z -> p_gcd_coeff_a a b = 0%Z. Proof. intros a b H0. unfold p_gcd_coeff_a in |- *. rewrite p_gcd_duv_rec_zero. reflexivity. exact H0. Qed. Lemma p_gcd_coeff_b_rec_zero : forall a b : positive, (Zpos a mod Zpos b)%Z = 0%Z -> p_gcd_coeff_b a b = 1%Z. Proof. intros a b H0. unfold p_gcd_coeff_b in |- *. rewrite p_gcd_duv_rec_zero. reflexivity. exact H0. Qed. Lemma p_gcd_duv_rec : forall a b r : positive, (Zpos a mod Zpos b)%Z = Zpos r -> p_gcd_duv a b = (let (d, uv) := p_gcd_duv b r in let (u, v) := uv in (d, (v, (u - Zpos a / Zpos b * v)%Z))). Proof. intros a b r Hr. unfold p_gcd_duv. fold (p_gcd_duv b r). rewrite Fix_eq; simpl. case (rem_dec a b). rewrite Hr; intros; discriminate. intro Hex; elim Hex; intros r' Hr'. fold (p_gcd_duv b r'). rewrite Hr in Hr'. inversion Hr'. auto. apply pp_gcd_ind_ext. Qed. Lemma p_gcd_rec : forall a b r : positive, (Zpos a mod Zpos b)%Z = Zpos r -> p_gcd a b = p_gcd b r. Proof. intros a b r Hr. unfold p_gcd in |- *. rewrite (p_gcd_duv_rec a b r Hr). elim (p_gcd_duv b r); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma p_gcd_rec_coeff_a : forall a b r : positive, (Zpos a mod Zpos b)%Z = Zpos r -> p_gcd_coeff_a a b = p_gcd_coeff_b b r. Proof. intros a b r Hr. unfold p_gcd_coeff_a in |- *. unfold p_gcd_coeff_b in |- *. rewrite (p_gcd_duv_rec a b r Hr). elim (p_gcd_duv b r); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma p_gcd_rec_coeff_b : forall a b r : positive, (Zpos a mod Zpos b)%Z = Zpos r -> p_gcd_coeff_b a b = (p_gcd_coeff_a b r - Zpos a / Zpos b * p_gcd_coeff_b b r)%Z. Proof. intros a b r Hr. unfold p_gcd_coeff_a in |- *. unfold p_gcd_coeff_b in |- *. rewrite (p_gcd_duv_rec a b r Hr). elim (p_gcd_duv b r); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma pp_gcd_lin_comb : forall x : pp, let (a, b) := x in Zpos (p_gcd a b) = (p_gcd_coeff_a a b * Zpos a + p_gcd_coeff_b a b * Zpos b)%Z. Proof. apply (well_founded_ind pp_lt_wf (fun x : pp => let (a, b) := x in Zpos (p_gcd a b) = (p_gcd_coeff_a a b * Zpos a + p_gcd_coeff_b a b * Zpos b)%Z)). intros x; elim x; intros a b. unfold p_gcd, p_gcd_coeff_a, p_gcd_coeff_b in |- *. intros Hind. case (rem_dec a b). intros Hr. rewrite (p_gcd_duv_rec_zero a b Hr). auto with zarith. intros Hr. elim Hr; clear Hr; intros r Hr. generalize (Hind (b, r) (rem_lt a b r Hr)). rewrite (p_gcd_duv_rec a b r Hr). elim (p_gcd_duv b r); intros d' uv'; elim uv'; intros u' v'. intro Hd'; rewrite Hd'. set (q := (Zpos a / Zpos b)%Z) in *. rewrite (Z_div_mod_eq_full (Zpos a) (Zpos b)). fold q in |- *. rewrite Hr. rewrite Zmult_plus_distr_r. rewrite BinInt.Zmult_minus_distr_r. rewrite (Zmult_assoc v' (Zpos b) q). rewrite (Zmult_comm (v' * Zpos b) q). rewrite (Zmult_assoc q v' (Zpos b)). lia. Qed. Lemma p_gcd_lin_comb : forall a b : positive, Zpos (p_gcd a b) = (p_gcd_coeff_a a b * Zpos a + p_gcd_coeff_b a b * Zpos b)%Z. Proof. intros a b. apply (pp_gcd_lin_comb (a, b)). Qed. Lemma pp_gcd_is_divisor : forall ab : pp, let (a, b) := ab in Zdivides (Zpos (p_gcd a b)) (Zpos a) /\ Zdivides (Zpos (p_gcd a b)) (Zpos b). Proof. apply (well_founded_ind pp_lt_wf (fun y : pp => let (u, v) := y in Zdivides (Zpos (p_gcd u v)) (Zpos u) /\ Zdivides (Zpos (p_gcd u v)) (Zpos v))). intro x; elim x; intros a b. unfold p_gcd, p_gcd_coeff_a, p_gcd_coeff_b in |- *. intros Hind. case (rem_dec a b). intros Hr. rewrite (p_gcd_duv_rec_zero a b Hr). auto with zarith. intros Hr; elim Hr; clear Hr; intros r Hr. generalize (Hind (b, r) (rem_lt a b r Hr)). rewrite (p_gcd_duv_rec a b r Hr). elim (p_gcd_duv b r); intros d' uv'; elim uv'; intros u' v'. intro Hd'. split. rewrite (Z_div_mod_eq_full (Zpos a) (Zpos b)). rewrite Hr. apply Zdivides_plus_elim. apply Zdivides_mult_elim_rht. tauto. tauto. tauto. Qed. Lemma p_gcd_is_divisor : forall a b : positive, Zdivides (Zpos (p_gcd a b)) (Zpos a) /\ Zdivides (Zpos (p_gcd a b)) (Zpos b). Proof. intros a b. apply (pp_gcd_is_divisor (a, b)). Qed. Lemma p_gcd_duv_symm : forall a b : positive, a <> b -> p_gcd_duv a b = (p_gcd b a, (p_gcd_coeff_b b a, p_gcd_coeff_a b a)). Proof. intros a b Hdiff. unfold p_gcd, p_gcd_coeff_a, p_gcd_coeff_b in |- *. set (rel := (Zpos a ?= Zpos b)%Z) in *. cut ((Zpos a ?= Zpos b)%Z = rel). case rel. intro Hegal. assert (Heq : Zpos a = Zpos b). apply Zle_antisymm. intro H; rewrite H in Hegal; discriminate. apply Z.le_ge; intro H; rewrite H in Hegal; discriminate. inversion Heq. tauto. intro Hlt. rewrite (p_gcd_duv_rec a b a). elim (p_gcd_duv b a); intros d uv; elim uv; intros u v. cut ((Zpos a / Zpos b)%Z = 0%Z). intros H0; rewrite H0. rewrite Zmult_0_l. unfold Zminus in |- *. simpl in |- *. rewrite Zplus_0_r. reflexivity. apply (Zdiv_lt_POS a b Hlt). apply (Zmod_lt_POS a b Hlt). intro Hgt. rewrite (p_gcd_duv_rec b a b). elim (p_gcd_duv a b); intros d uv; elim uv; intros u v. cut ((Zpos b / Zpos a)%Z = 0%Z). intros H0; rewrite H0. rewrite Zmult_0_l. unfold Zminus in |- *; simpl in |- *. rewrite Zplus_0_r. reflexivity. apply (Zdiv_lt_POS b a); apply Z.gt_lt; assumption. apply (Zmod_lt_POS b a); apply Z.gt_lt; assumption. auto. Qed. Lemma p_gcd_symm : forall a b : positive, p_gcd a b = p_gcd b a. Proof. intros a b. case (Zdec (Zpos a - Zpos b)). intro H0. cut (Zpos a = Zpos b). intro Heq. inversion Heq. reflexivity. auto with zarith. intro Hdiff. cut (a <> b). intro Hneq. unfold p_gcd in |- *. rewrite (p_gcd_duv_symm a b Hneq). auto. intro Hfalse. apply Hdiff. rewrite Hfalse. auto with zarith. Qed. End pgcd. (** ** GCD over Z *) Section zgcd. Definition Zis_gcd (a b d : Z) := (a = 0%Z -> b = 0%Z -> d = 0%Z) /\ (a <> 0%Z \/ b <> 0%Z -> (d > 0)%Z /\ Zdivides d a /\ Zdivides d b /\ (forall q : Z, Zdivides q a /\ Zdivides q b -> Zdivides q d)). Lemma Zis_gcd_unique : forall a b d e : Z, Zis_gcd a b d -> Zis_gcd a b e -> d = e. Proof. intros a b d e. unfold Zis_gcd in |- *. intros Hd He. elim Hd; intros Hdl Hdr. elim He; intros Hel Her. induction a as [| p| p]. induction b as [| p| p]. transitivity 0%Z. apply Hdl; reflexivity; reflexivity. symmetry in |- *. apply Hel; reflexivity; reflexivity. elim Hdr. intros Hd0 Hddiv. elim Her. intros He0 Hediv. elim Hddiv; intros _ Hddiv2. elim Hddiv2; intros _ Hdgcd. elim Hediv; intros _ Hediv2. elim Hediv2; intros _ Hegcd. apply (Zdivides_antisymm _ _ Hd0 He0). apply Hegcd; tauto. apply Hdgcd; tauto. right; discriminate. right; discriminate. elim Hdr. intros Hd0 Hddiv. elim Her. intros He0 Hediv. elim Hddiv; intros _ Hddiv2. elim Hddiv2; intros _ Hdgcd. elim Hediv; intros _ Hediv2. elim Hediv2; intros _ Hegcd. apply (Zdivides_antisymm _ _ Hd0 He0). apply Hegcd; tauto. apply Hdgcd; tauto. right. discriminate. right. discriminate. elim Hdr. intros Hd0 Hddiv. elim Her. intros He0 Hediv. elim Hddiv; intros _ Hddiv2. elim Hddiv2; intros _ Hdgcd. elim Hediv; intros _ Hediv2. elim Hediv2; intros _ Hegcd. apply (Zdivides_antisymm _ _ Hd0 He0). apply Hegcd; tauto. apply Hdgcd; tauto. left. discriminate. left. discriminate. elim Hdr. intros Hd0 Hddiv. elim Her. intros He0 Hediv. elim Hddiv; intros _ Hddiv2. elim Hddiv2; intros _ Hdgcd. elim Hediv; intros _ Hediv2. elim Hediv2; intros _ Hegcd. apply (Zdivides_antisymm _ _ Hd0 He0). apply Hegcd; tauto. apply Hdgcd; tauto. left. discriminate. left. discriminate. Qed. Definition Zgcd_duv (a b : Z) := match a, b with | Z0, Z0 => (0%Z, (0%Z, 0%Z)) | Z0, Zpos b' => (Zpos b', (0%Z, 1%Z)) | Z0, Zneg b' => (Zpos b', (0%Z, (-1)%Z)) | Zpos a', Z0 => (Zpos a', (1%Z, 0%Z)) | Zpos a', Zpos b' => (Zpos (p_gcd a' b'), (p_gcd_coeff_a a' b', p_gcd_coeff_b a' b')) | Zpos a', Zneg b' => (Zpos (p_gcd a' b'), (p_gcd_coeff_a a' b', (- p_gcd_coeff_b a' b')%Z)) | Zneg a', Z0 => (Zpos a', ((-1)%Z, 0%Z)) | Zneg a', Zpos b' => (Zpos (p_gcd a' b'), ((- p_gcd_coeff_a a' b')%Z, p_gcd_coeff_b a' b')) | Zneg a', Zneg b' => (Zpos (p_gcd a' b'), ((- p_gcd_coeff_a a' b')%Z, (- p_gcd_coeff_b a' b')%Z)) end. Definition Zgcd (a b : Z) := let (d, _) := Zgcd_duv a b in d. Definition Zgcd_coeff_a (a b : Z) := let (_, uv) := Zgcd_duv a b in let (u, _) := uv in u. Definition Zgcd_coeff_b (a b : Z) := let (_, uv) := Zgcd_duv a b in let (_, v) := uv in v. Lemma Zgcd_duv_zero_rht : forall a : Z, Zgcd_duv a 0 = (Z.abs a, (Z.sgn a, 0%Z)). Proof. intro a. case a; auto with zarith. Qed. Lemma Zgcd_zero_rht : forall a : Z, Zgcd a 0 = Z.abs a. Proof. intro a. unfold Zgcd in |- *. rewrite Zgcd_duv_zero_rht. reflexivity. Qed. Lemma Zgcd_coeff_a_zero_rht : forall a : Z, Zgcd_coeff_a a 0 = Z.sgn a. Proof. intro a. unfold Zgcd_coeff_a in |- *. rewrite Zgcd_duv_zero_rht. reflexivity. Qed. Lemma Zgcd_coeff_b_zero_rht : forall a : Z, Zgcd_coeff_b a 0 = 0%Z. Proof. intro a. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_zero_rht. reflexivity. Qed. Lemma Zgcd_duv_Zopp_l : forall a b : Z, Zgcd_duv (- a) b = (let (d, uv) := Zgcd_duv a b in let (u, v) := uv in (d, ((- u)%Z, v))). Proof. intros a b. case a; case b; intros; simpl in |- *; repeat rewrite Z.opp_involutive; reflexivity. Qed. Lemma Zgcd_Zopp_l : forall a b : Z, Zgcd (- a) b = Zgcd a b. Proof. intros a b. case a; case b; auto with zarith. Qed. Lemma Zgcd_coeff_a_Zopp_l : forall a b : Z, Zgcd_coeff_a (- a) b = (- Zgcd_coeff_a a b)%Z. Proof. intros. unfold Zgcd_coeff_a in |- *. rewrite Zgcd_duv_Zopp_l. elim (Zgcd_duv a b); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma Zgcd_coeff_b_Zopp_l : forall a b : Z, Zgcd_coeff_b (- a) b = Zgcd_coeff_b a b. Proof. intros. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_Zopp_l. elim (Zgcd_duv a b); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma Zgcd_duv_Zopp_r : forall a b : Z, Zgcd_duv a (- b) = (let (d, uv) := Zgcd_duv a b in let (u, v) := uv in (d, (u, (- v)%Z))). Proof. intros a b. case a; case b; intros; simpl in |- *; repeat rewrite Z.opp_involutive; reflexivity. Qed. Lemma Zgcd_Zopp_r : forall a b : Z, Zgcd a (- b) = Zgcd a b. Proof. intros a b. case a; case b; auto with zarith. Qed. Lemma Zgcd_coeff_a_Zopp_r : forall a b : Z, Zgcd_coeff_a a (- b) = Zgcd_coeff_a a b. Proof. intros. unfold Zgcd_coeff_a in |- *. rewrite Zgcd_duv_Zopp_r. elim (Zgcd_duv a b); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma Zgcd_coeff_b_Zopp_r : forall a b : Z, Zgcd_coeff_b a (- b) = (- Zgcd_coeff_b a b)%Z. Proof. intros. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_Zopp_r. elim (Zgcd_duv a b); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma Zgcd_duv_abs : forall a b : Z, Zgcd_duv a b = (let (d, uv) := Zgcd_duv (Z.abs a) (Z.abs b) in let (u, v) := uv in (d, ((Z.sgn a * u)%Z, (Z.sgn b * v)%Z))). Proof. intros a b. case a; case b; intros; unfold Z.abs, Z.sgn, Zgcd_duv in |- *; repeat (fold (- (1))%Z in |- *; rewrite <- Zopp_mult_distr_l); repeat rewrite Zmult_1_l; reflexivity. Qed. Lemma Zgcd_abs : forall a b : Z, Zgcd a b = Zgcd (Z.abs a) (Z.abs b). Proof. intros a b. case a; case b; auto with zarith. Qed. Lemma Zgcd_coeff_a_abs : forall a b : Z, Zgcd_coeff_a a b = (Z.sgn a * Zgcd_coeff_a (Z.abs a) (Z.abs b))%Z. Proof. intros. unfold Zgcd_coeff_a in |- *. rewrite Zgcd_duv_abs. elim (Zgcd_duv (Z.abs a) (Z.abs b)); intros d uv; elim uv; intros u v. reflexivity. Qed. Lemma Zgcd_coeff_b_abs : forall a b : Z, Zgcd_coeff_b a b = (Z.sgn b * Zgcd_coeff_b (Z.abs a) (Z.abs b))%Z. Proof. intros. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_abs. elim (Zgcd_duv (Z.abs a) (Z.abs b)); intros d uv; elim uv; intros u v. reflexivity. Qed. Let Zgcd_duv_rec_subsubcase : forall a b : positive, Zgcd_duv (Zpos a) (Zpos b) = (let (d, uv) := Zgcd_duv (Zpos b) (Zpos a mod Zpos b) in let (u, v) := uv in (d, (v, (u - Zpos a / Zpos b * v)%Z))). Proof. intros a b. unfold Zgcd_duv in |- *. unfold p_gcd, p_gcd_coeff_a, p_gcd_coeff_b in |- *. case (rem_dec a b). intro Hr. rewrite Hr. rewrite (p_gcd_duv_rec_zero a b Hr). rewrite Zmult_0_r. auto with zarith. intro Hr; elim Hr; clear Hr; intros r Hr. rewrite Hr. rewrite (p_gcd_duv_rec a b r Hr). elim (p_gcd_duv b r); intros d' uv'; elim uv'; intros u' v'. auto. Qed. Let Zgcd_duv_rec_subcase : forall (a : Z) (pb : positive), Zgcd_duv a (Zpos pb) = (let (d, uv) := Zgcd_duv (Zpos pb) (Z.abs a mod Zpos pb) in let (u, v) := uv in (d, ((Z.sgn a * v)%Z, (u - Z.abs a / Zpos pb * v)%Z))). Proof. intros a pb. case a. unfold Zgcd_duv in |- *; simpl in |- *; reflexivity. intro pa. unfold Z.abs, Z.sgn in |- *. rewrite Zgcd_duv_rec_subsubcase. elim (Zgcd_duv (Zpos pb) (Zpos pa mod Zpos pb)); intros d uv; elim uv; intros u v. rewrite Zmult_1_l. reflexivity. intro pa. rewrite (Zgcd_duv_abs (Zneg pa) (Zpos pb)). unfold Z.abs, Z.sgn in |- *. rewrite Zgcd_duv_rec_subsubcase. elim (Zgcd_duv (Zpos pb) (Zpos pa mod Zpos pb)); intros d uv; elim uv; intros u v. rewrite Zmult_1_l. reflexivity. Qed. Lemma Zgcd_duv_rec : forall a b : Z, b <> 0%Z -> Zgcd_duv a b = (let (d, uv) := Zgcd_duv b (Z.abs a mod Z.abs b) in let (u, v) := uv in (d, ((Z.sgn a * v)%Z, (u - Z.sgn b * (Z.abs a / Z.abs b) * v)%Z))). Proof. intros a b Hb. set (B := b) in *. cut (B = b). case b. intro HB'. rewrite HB' in Hb. elim Hb. reflexivity. intros pb HB'. rewrite HB'. rewrite Zgcd_duv_rec_subcase. unfold Z.abs, Z.sgn in |- *. fold (Z.abs a) in |- *. fold (Z.sgn a) in |- *. elim (Zgcd_duv (Zpos pb) (Z.abs a mod Zpos pb)); intros d uv; elim uv; intros u v. rewrite Zmult_1_l. reflexivity. intros pb HB'. rewrite HB'. fold (- Zpos pb)%Z in |- *. rewrite Zgcd_duv_Zopp_r. rewrite Zgcd_duv_Zopp_l. rewrite Zgcd_duv_rec_subcase. unfold Z.opp, Z.abs, Z.sgn in |- *. fold (Z.abs a) in |- *. fold (Z.sgn a) in |- *. elim (Zgcd_duv (Zpos pb) (Z.abs a mod Zpos pb)); intros d uv; elim uv; intros u v. fold (- u)%Z in |- *. rewrite Zopp_mult_distr_l_reverse. unfold Zminus in |- *. rewrite <- Zopp_plus_distr. auto with zarith. auto. Qed. Lemma Zgcd_rec : forall a b : Z, b <> 0%Z -> Zgcd a b = Zgcd b (Z.abs a mod Z.abs b). Proof. intros a b Hb. unfold Zgcd in |- *. rewrite Zgcd_duv_rec. elim (Zgcd_duv b (Z.abs a mod Z.abs b)); intros d uv; elim uv; intros u v. reflexivity. exact Hb. Qed. Lemma Zgcd_coeff_a_rec : forall a b : Z, b <> 0%Z -> Zgcd_coeff_a a b = (Z.sgn a * Zgcd_coeff_b b (Z.abs a mod Z.abs b))%Z. Proof. intros a b Hb. unfold Zgcd_coeff_a in |- *. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_rec. elim (Zgcd_duv b (Z.abs a mod Z.abs b)); intros d uv; elim uv; intros u v. reflexivity. exact Hb. Qed. Lemma Zgcd_coeff_b_rec : forall a b : Z, b <> 0%Z -> Zgcd_coeff_b a b = (Zgcd_coeff_a b (Z.abs a mod Z.abs b) - Z.sgn b * (Z.abs a / Z.abs b) * Zgcd_coeff_b b (Z.abs a mod Z.abs b))%Z. Proof. intros a b Hb. unfold Zgcd_coeff_a in |- *. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_rec. elim (Zgcd_duv b (Z.abs a mod Z.abs b)); intros d uv; elim uv; intros u v. reflexivity. exact Hb. Qed. Lemma Zgcd_duv_divisor : forall a b : Z, a <> 0%Z -> Zdivides b a -> Zgcd_duv a b = (Z.abs b, (0%Z, Z.sgn b)). Proof. intros a b Ha. case b. intros Hdiv. replace a with 0%Z; simpl in |- *; auto. symmetry in |- *. auto with zarith. intros pb Hdiv. simpl in |- *. rewrite Zgcd_duv_rec_subcase. replace (Z.abs a mod Zpos pb)%Z with 0%Z. rewrite Zgcd_duv_zero_rht. rewrite Zmult_0_r. rewrite Zmult_0_r. simpl in |- *. reflexivity. symmetry in |- *. auto with zarith. intros pb Hdiv. simpl in |- *. fold (- Zpos pb)%Z in |- *. rewrite Zgcd_duv_Zopp_r. rewrite Zgcd_duv_rec_subcase. replace (Z.abs a mod Zpos pb)%Z with 0%Z. rewrite Zgcd_duv_zero_rht. rewrite Zmult_0_r. rewrite Zmult_0_r. simpl in |- *. reflexivity. symmetry in |- *. auto with zarith. Qed. Lemma Zgcd_divisor : forall a b : Z, a <> 0%Z -> Zdivides b a -> Zgcd a b = Z.abs b. Proof. intros. unfold Zgcd in |- *. rewrite Zgcd_duv_divisor; auto. Qed. Lemma Zgcd_coeff_a_divisor : forall a b : Z, a <> 0%Z -> Zdivides b a -> Zgcd_coeff_a a b = 0%Z. Proof. intros. unfold Zgcd_coeff_a in |- *. rewrite Zgcd_duv_divisor; auto. Qed. Lemma Zgcd_coeff_b_divisor : forall a b : Z, a <> 0%Z -> Zdivides b a -> Zgcd_coeff_b a b = Z.sgn b. Proof. intros. unfold Zgcd_coeff_b in |- *. rewrite Zgcd_duv_divisor; auto. Qed. Lemma Zgcd_duv_symm : forall a b : Z, Z.abs a <> Z.abs b -> Zgcd_duv a b = (Zgcd b a, (Zgcd_coeff_b b a, Zgcd_coeff_a b a)). Proof. intros a b. unfold Zgcd, Zgcd_coeff_a, Zgcd_coeff_b in |- *. cut (forall p q : positive, Zpos p <> Zpos q -> p <> q). case a; case b; simpl in |- *; intros; unfold p_gcd, p_gcd_coeff_a, p_gcd_coeff_b in |- *; try rewrite p_gcd_duv_symm; auto. intros p q Hneq; intro Hfalse. apply Hneq; rewrite Hfalse; auto. Qed. Lemma Zgcd_symm : forall a b : Z, Zgcd a b = Zgcd b a. Proof. intros a b. case a; case b; simpl in |- *; intros; unfold Zgcd, Zgcd_duv in |- *; try rewrite p_gcd_symm; auto. Qed. Lemma Zgcd_coeff_a_symm : forall a b : Z, Z.abs a <> Z.abs b -> Zgcd_coeff_a a b = Zgcd_coeff_b b a. Proof. intros a b Hneq. unfold Zgcd_coeff_a, Zgcd_coeff_b in |- *. rewrite (Zgcd_duv_symm a b Hneq). auto. Qed. Lemma Zgcd_coeff_b_symm : forall a b : Z, Z.abs a <> Z.abs b -> Zgcd_coeff_b a b = Zgcd_coeff_a b a. Proof. intros a b Hneq. unfold Zgcd_coeff_a, Zgcd_coeff_b in |- *. rewrite (Zgcd_duv_symm a b Hneq). auto. Qed. Lemma Zgcd_is_divisor : forall a b : Z, Zdivides (Zgcd a b) a. Proof. intros a b. case a. auto with zarith. case b. auto with zarith. intros pb pa; generalize (p_gcd_is_divisor pa pb); tauto. intros pb pa; generalize (p_gcd_is_divisor pa pb); tauto. case b. auto with zarith. intros pb pa; generalize (p_gcd_is_divisor pa pb); intro H. apply Zdivides_opp_intro_rht; simpl in |- *. tauto. intros pb pa; generalize (p_gcd_is_divisor pa pb); intro H. apply Zdivides_opp_intro_rht; simpl in |- *. tauto. Qed. Definition Zgcd_is_divisor_lft := Zgcd_is_divisor. Lemma Zgcd_is_divisor_rht : forall a b : Z, Zdivides (Zgcd a b) b. Proof. intros a b. rewrite Zgcd_symm. apply Zgcd_is_divisor_lft. Qed. Lemma Zgcd_lin_comb : forall a b : Z, Zgcd a b = (Zgcd_coeff_a a b * a + Zgcd_coeff_b a b * b)%Z. Proof. intros a b. unfold Zgcd, Zgcd_coeff_a, Zgcd_coeff_b in |- *. case a; case b; simpl in |- *; intros; repeat rewrite Zmult_opp_comm; simpl in |- *; try rewrite p_gcd_lin_comb; auto. Qed. Lemma Zgcd_zero : forall a b : Z, Zgcd a b = 0%Z -> a = 0%Z /\ b = 0%Z. Proof. intros a b. case a; case b; unfold Zgcd in |- *; simpl in |- *; intros; try discriminate; try tauto. Qed. Lemma Zgcd_nonneg : forall a b : Z, (0 <= Zgcd a b)%Z. Proof. intros a b. case a; case b; unfold Zgcd in |- *; simpl in |- *; auto with zarith. Qed. (* Zgcd_nonneg says Zgcd is never negative, so it might as well return nat: *) Definition Zgcd_nat (a b: Z): nat := match Zgcd a b with | Zpos p => nat_of_P p | _ => 0%nat end. Lemma Zgcd_nat_divides (a b: Z): exists c: Z, (c * Zgcd_nat a b = a)%Z. Proof with auto. intros. unfold Zgcd_nat. pose proof (Zgcd_nonneg a b) as E. destruct (Zgcd_is_divisor a b) as [c ?]. exists c. destruct (Zgcd a b)... rewrite inject_nat_convert... exfalso. apply E. reflexivity. Qed. Lemma Zgcd_nat_sym (a b: Z): Zgcd_nat a b = Zgcd_nat b a. Proof. unfold Zgcd_nat. intros. rewrite Zgcd_symm. reflexivity. Qed. Lemma Zgcd_nonzero : forall a b : Z, 0%Z <> Zgcd a b -> a <> 0%Z \/ b <> 0%Z. Proof. intros a b. case a. case b. rewrite Zgcd_zero_rht; simpl in |- *; tauto. intros; right; intro; discriminate. intros; right; intro; discriminate. intros; left; intro; discriminate. intros; left; intro; discriminate. Qed. Lemma Zgcd_pos : forall a b : Z, a <> 0%Z \/ b <> 0%Z -> (0 < Zgcd a b)%Z. Proof. intros a b Hab. generalize (Zgcd_nonneg a b); intro Hnonneg. cut (Zgcd a b <> 0%Z). auto with zarith. intro H0. generalize (Zgcd_zero a b H0). tauto. Qed. Lemma Zgcd_is_gcd : forall a b : Z, Zis_gcd a b (Zgcd a b). Proof. intros a b. unfold Zis_gcd in |- *. split. intros Ha Hb; rewrite Ha; rewrite Hb; auto with zarith. intros Hab. split. generalize (Zgcd_pos a b Hab); auto with zarith. split. apply Zgcd_is_divisor_lft. split. apply Zgcd_is_divisor_rht. intros q Hq. rewrite Zgcd_lin_comb. apply Zdivides_plus_elim. apply Zdivides_mult_elim_lft; tauto. apply Zdivides_mult_elim_lft; tauto. Qed. Lemma Zgcd_intro : forall a b d : Z, Zis_gcd a b d -> Zgcd a b = d. Proof. intros a b d Hisgcd. apply (Zis_gcd_unique a b (Zgcd a b) d). apply Zgcd_is_gcd. exact Hisgcd. Qed. Lemma Zgcd_intro_unfolded : forall a b d : Z, a <> 0%Z \/ b <> 0%Z -> (d > 0)%Z -> Zdivides d a -> Zdivides d b -> (forall q : Z, Zdivides q a /\ Zdivides q b -> Zdivides q d) -> Zgcd a b = d. Proof. intros. apply Zgcd_intro. unfold Zis_gcd in |- *. tauto. Qed. Lemma Zdiv_gcd_elim_lft : forall a b q : Z, Zdivides a q -> Zdivides (Zgcd a b) q. intros a b q Hdiv; apply (Zdivides_trans (Zgcd a b) a q); [ apply Zgcd_is_divisor_lft | assumption ]. Qed. Lemma Zdiv_gcd_elim_rht : forall a b q : Z, Zdivides b q -> Zdivides (Zgcd a b) q. intros a b q Hdiv; apply (Zdivides_trans (Zgcd a b) b q); [ apply Zgcd_is_divisor_rht | assumption ]. Qed. Lemma Zdiv_gcd_elim : forall a b q : Z, Zdivides q a -> Zdivides q b -> Zdivides q (Zgcd a b). Proof. intros a b q Ha Hb. cut (a <> 0%Z \/ b <> 0%Z -> Zdivides q (Zgcd a b)). case (Zdec a); case (Zdec b); auto. intros Hb0 Ha0; rewrite Ha0 in Ha; rewrite Ha0; rewrite Hb0. rewrite Zgcd_zero_rht; auto. intro Hnon0; generalize (Zgcd_is_gcd a b); unfold Zis_gcd in |- *; intro H; elim H; clear H; intros H0 H1; elim H1; clear H1. intros _ H1; elim H1; clear H1; intros _ H1; elim H1; clear H1; intros _ Hdiv. generalize (Hdiv q); intro Hq; auto. auto. Qed. Lemma Zgcd_mod0_lft : forall a b : Z, Zgcd a b <> 0%Z -> (a mod Zgcd a b)%Z = 0%Z. Proof. intros; apply Zmod0_Zdivides; auto; apply Zgcd_is_divisor_lft. Qed. Lemma Zgcd_mod0_rht : forall a b : Z, Zgcd a b <> 0%Z -> (b mod Zgcd a b)%Z = 0%Z. Proof. intros a b. rewrite Zgcd_symm. apply Zgcd_mod0_lft. Qed. Lemma Zgcd_div_mult_lft : forall a b : Z, Zgcd a b <> 0%Z -> a = (a / Zgcd a b * Zgcd a b)%Z. Proof. intros a b H0. generalize (Zgcd_mod0_lft a b); intro Hmod0. rewrite <- Zplus_0_r. rewrite <- Hmod0. rewrite Zmult_comm. apply Z_div_mod_eq_full. assumption. Qed. Lemma Zgcd_div_mult_rht : forall a b : Z, Zgcd a b <> 0%Z -> b = (b / Zgcd a b * Zgcd a b)%Z. Proof. intros a b. rewrite Zgcd_symm. apply Zgcd_div_mult_lft. Qed. Lemma Zgcd_idemp : forall a : Z, (a > 0)%Z -> Zgcd a a = a. Proof. intros a Ha. rewrite Zgcd_rec. rewrite Z_mod_same. rewrite Zgcd_zero_rht. auto with zarith. replace (Z.abs a) with a. assumption. symmetry in |- *; auto with zarith. auto with zarith. Qed. Lemma Zgcd_zero_lft : forall a : Z, Zgcd 0 a = Z.abs a. Proof. intro a. rewrite Zgcd_symm. apply Zgcd_zero_rht. Qed. Lemma Zgcd_one_lft : forall a : Z, Zgcd 1 a = 1%Z. Proof. intro a. generalize (Zgcd_is_divisor_lft 1 a). cut (0 < Zgcd 1 a)%Z. auto with zarith. apply Zgcd_pos. left; intro; discriminate. Qed. Lemma Zgcd_one_rht : forall a : Z, Zgcd a 1 = 1%Z. Proof. intro a. rewrite Zgcd_symm. apply Zgcd_one_lft. Qed. Lemma Zgcd_le_lft : forall a b : Z, (a > 0)%Z -> (Zgcd a b <= a)%Z. Proof. intros a b Ha. generalize (Zgcd_is_divisor_lft a b). auto with zarith. Qed. Lemma Zgcd_le_rht : forall a b : Z, (b > 0)%Z -> (Zgcd a b <= b)%Z. Proof. intros. rewrite Zgcd_symm. apply Zgcd_le_lft. assumption. Qed. Lemma Zgcd_gcd_rl : forall a b : Z, Zgcd a (Zgcd a b) = Zgcd a b. Proof. intros a b. case (Zdec a). intro H0; rewrite H0; repeat rewrite Zgcd_zero_lft; auto with zarith. intro H0. replace (Zgcd a b) with (Z.abs (Zgcd a b)). rewrite Zgcd_abs. replace (Z.abs (Z.abs (Zgcd a b))) with (Zgcd a b). apply Zgcd_divisor. auto with zarith. apply Zdivides_abs_elim_rht. apply Zgcd_is_divisor_lft. generalize (Zgcd_nonneg a b); rewrite Zabs_idemp; auto with zarith. generalize (Zgcd_nonneg a b); auto with zarith. Qed. Lemma Zgcd_gcd_rr : forall a b : Z, Zgcd b (Zgcd a b) = Zgcd a b. Proof. intros a b; rewrite (Zgcd_symm a b); apply Zgcd_gcd_rl. Qed. Lemma Zgcd_gcd_ll : forall a b : Z, Zgcd (Zgcd a b) a = Zgcd a b. Proof. intros a b; rewrite (Zgcd_symm (Zgcd a b) a); apply Zgcd_gcd_rl. Qed. Lemma Zgcd_gcd_lr : forall a b : Z, Zgcd (Zgcd a b) b = Zgcd a b. intros a b; rewrite (Zgcd_symm a b); rewrite (Zgcd_symm (Zgcd b a) b); apply Zgcd_gcd_rl. Qed. Lemma Zgcd_mult_elim_ll : forall a b : Z, Zgcd (b * a) a = Z.abs a. Proof. intros a b. elim (Zdec (b * a)). intro Hab; rewrite Hab; rewrite Zgcd_zero_lft; reflexivity. intro Hab; apply Zgcd_divisor; auto with zarith. Qed. Lemma Zgcd_mult_elim_lr : forall a b : Z, Zgcd (a * b) a = Z.abs a. Proof. intros. rewrite Zmult_comm. apply Zgcd_mult_elim_ll. Qed. Lemma Zgcd_mult_elim_rl : forall a b : Z, Zgcd a (b * a) = Z.abs a. Proof. intros. rewrite Zgcd_symm. apply Zgcd_mult_elim_ll. Qed. Lemma Zgcd_mult_elim_rr : forall a b : Z, Zgcd a (a * b) = Z.abs a. Proof. intros. rewrite Zmult_comm. rewrite Zgcd_symm. apply Zgcd_mult_elim_ll. Qed. Lemma Zgcd_plus_elim_rr : forall a b c : Z, Zdivides a c -> Zgcd a (b + c) = Zgcd a b. Proof. intros a b c Hdiv. elim (Zdec a). intro H0; rewrite H0; repeat rewrite Zgcd_zero_lft. replace c with 0%Z. rewrite Zplus_0_r; auto. rewrite H0 in Hdiv. symmetry in |- *. auto with zarith. intro Ha. apply Zdivides_antisymm. generalize (Zgcd_pos a (b + c)); auto with zarith. generalize (Zgcd_pos a b); auto with zarith. rewrite (Zgcd_lin_comb a b). apply Zdivides_plus_elim. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_lft. apply Zdivides_mult_elim_lft. set (x := (b + c)%Z) in *; replace b with (b + c - c)%Z. unfold x in |- *. apply Zdivides_minus_elim. apply Zgcd_is_divisor_rht. apply (Zdivides_trans (Zgcd a (b + c)) a c). apply Zgcd_is_divisor_lft. assumption. lia. rewrite (Zgcd_lin_comb a (b + c)). apply Zdivides_plus_elim. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_lft. apply Zdivides_mult_elim_lft. apply Zdivides_plus_elim. apply Zgcd_is_divisor_rht. apply (Zdivides_trans (Zgcd a b) a c). apply Zgcd_is_divisor_lft. assumption. Qed. Lemma Zgcd_plus_elim_rl : forall a b c : Z, Zdivides a c -> Zgcd a (c + b) = Zgcd a b. Proof. intros a b c. rewrite Zplus_comm. apply Zgcd_plus_elim_rr. Qed. Lemma Zgcd_plus_elim_lr : forall a b c : Z, Zdivides b c -> Zgcd (a + c) b = Zgcd a b. Proof. intros a b c. rewrite (Zgcd_symm a b). rewrite (Zgcd_symm (a + c) b). apply Zgcd_plus_elim_rr. Qed. Lemma Zgcd_plus_elim_ll : forall a b c : Z, Zdivides b c -> Zgcd (c + a) b = Zgcd a b. Proof. intros a b c. rewrite Zplus_comm. apply Zgcd_plus_elim_lr. Qed. Lemma Zgcd_minus_elim_rr : forall a b c : Z, Zdivides a c -> Zgcd a (b - c) = Zgcd a b. Proof. intros a b c Hdiv. unfold Zminus in |- *. apply Zgcd_plus_elim_rr. auto with zarith. Qed. Lemma Zgcd_minus_elim_rl : forall a b c : Z, Zdivides a c -> Zgcd a (c - b) = Zgcd a b. Proof. intros a b c Hdiv. replace (c - b)%Z with (- (b - c))%Z. rewrite Zgcd_Zopp_r. apply Zgcd_minus_elim_rr. assumption. lia. Qed. Lemma Zgcd_minus_elim_lr : forall a b c : Z, Zdivides b c -> Zgcd (a - c) b = Zgcd a b. Proof. intros a b c. rewrite (Zgcd_symm a b). rewrite (Zgcd_symm (a - c) b). apply Zgcd_minus_elim_rr. Qed. Lemma Zgcd_minus_elim_ll : forall a b c : Z, Zdivides b c -> Zgcd (c - a) b = Zgcd a b. Proof. intros a b c. rewrite (Zgcd_symm a b). rewrite (Zgcd_symm (c - a) b). apply Zgcd_minus_elim_rl. Qed. Lemma Zgcd_mod_lft : forall a b : Z, (b > 0)%Z -> Zgcd (a mod b) b = Zgcd a b. Proof. intros a b Hb. replace (a mod b)%Z with (a - b * (a / b))%Z. apply Zgcd_minus_elim_lr. apply Zdivides_mult_elim_rht. apply Zdivides_ref. generalize (Z_div_mod_eq_full a b). auto with zarith. Qed. Lemma Zgcd_mod_rht : forall a b : Z, (a > 0)%Z -> Zgcd a (b mod a) = Zgcd a b. Proof. intros a b Ha. repeat rewrite (Zgcd_symm a); apply Zgcd_mod_lft; exact Ha. Qed. Lemma Zgcd_div_gcd_1 : forall a b : Z, Zgcd a b <> 0%Z -> Zgcd (a / Zgcd a b) (b / Zgcd a b) = 1%Z. Proof. intros a b Hab. apply Zdivides_antisymm; auto with zarith. apply Z.lt_gt. apply Zgcd_pos. generalize (Zgcd_nonzero a b); intro Hnz; elim Hnz; auto. intro Ha; left; intro Hfalse; generalize (Zgcd_div_mult_lft a b); rewrite Hfalse; simpl in |- *; tauto. intro Hb; right; intro Hfalse; generalize (Zgcd_div_mult_rht a b); rewrite Hfalse; simpl in |- *; tauto. cut (1%Z = (Zgcd_coeff_a a b * (a / Zgcd a b) + Zgcd_coeff_b a b * (b / Zgcd a b))%Z). intro H1; rewrite H1. apply Zdivides_plus_elim. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_lft. apply Zdivides_mult_elim_lft. apply Zgcd_is_divisor_rht. generalize (Zgcd_lin_comb a b); intro Hlincomb; generalize (Zgcd_is_divisor_lft a b); intro Hdivb; elim Hdivb; intros y Hy; generalize (Zgcd_is_divisor_rht a b); intro Hdiva; elim Hdiva; intros x Hx; set (d := Zgcd a b). move d after Hy. fold d in Hx; fold d in Hy. replace 1%Z with (Zgcd a b / d)%Z; auto with zarith. rewrite Hlincomb. set (u := Zgcd_coeff_a a b); set (v := Zgcd_coeff_b a b). rewrite Zdiv_plus_elim; auto with zarith. rewrite <- Hx; rewrite <- Hy. repeat rewrite Zmult_assoc. repeat rewrite Zdiv_mult_cancel_rht; auto. Qed. End zgcd. #[global] Hint Resolve Zgcd_duv_zero_rht: zarith. #[global] Hint Resolve Zgcd_zero_rht: zarith. #[global] Hint Resolve Zgcd_coeff_a_zero_rht: zarith. #[global] Hint Resolve Zgcd_coeff_b_zero_rht: zarith. #[global] Hint Resolve Zgcd_duv_Zopp_l: zarith. #[global] Hint Resolve Zgcd_Zopp_l: zarith. #[global] Hint Resolve Zgcd_coeff_a_Zopp_l: zarith. #[global] Hint Resolve Zgcd_coeff_b_Zopp_l: zarith. #[global] Hint Resolve Zgcd_duv_Zopp_r: zarith. #[global] Hint Resolve Zgcd_Zopp_r: zarith. #[global] Hint Resolve Zgcd_coeff_a_Zopp_r: zarith. #[global] Hint Resolve Zgcd_coeff_b_Zopp_r: zarith. #[global] Hint Resolve Zgcd_duv_abs: zarith. #[global] Hint Resolve Zgcd_abs: zarith. #[global] Hint Resolve Zgcd_coeff_a_abs: zarith. #[global] Hint Resolve Zgcd_coeff_b_abs: zarith. #[global] Hint Resolve Zgcd_duv_rec: zarith. #[global] Hint Resolve Zgcd_rec: zarith. #[global] Hint Resolve Zgcd_coeff_a_rec: zarith. #[global] Hint Resolve Zgcd_coeff_b_rec: zarith. #[global] Hint Resolve Zgcd_duv_divisor: zarith. #[global] Hint Resolve Zgcd_divisor: zarith. #[global] Hint Resolve Zgcd_coeff_a_divisor: zarith. #[global] Hint Resolve Zgcd_coeff_b_divisor: zarith. #[global] Hint Resolve Zgcd_duv_symm: zarith. #[global] Hint Resolve Zgcd_symm: zarith. #[global] Hint Resolve Zgcd_coeff_a_symm: zarith. #[global] Hint Resolve Zgcd_coeff_b_symm: zarith. #[global] Hint Resolve Zgcd_is_divisor_lft: zarith. #[global] Hint Resolve Zgcd_is_divisor_rht: zarith. #[global] Hint Resolve Zgcd_lin_comb: zarith. #[global] Hint Resolve Zgcd_zero: zarith. #[global] Hint Resolve Zgcd_nonneg: zarith. #[global] Hint Resolve Zgcd_nonzero: zarith. #[global] Hint Resolve Zgcd_pos: zarith. #[global] Hint Resolve Zgcd_is_gcd: zarith. #[global] Hint Resolve Zgcd_intro: zarith. #[global] Hint Resolve Zgcd_intro_unfolded: zarith. #[global] Hint Resolve Zdiv_gcd_elim_lft: zarith. #[global] Hint Resolve Zdiv_gcd_elim_rht: zarith. #[global] Hint Resolve Zdiv_gcd_elim: zarith. #[global] Hint Resolve Zgcd_mod0_lft: zarith. #[global] Hint Resolve Zgcd_mod0_rht: zarith. #[global] Hint Resolve Zgcd_div_mult_lft: zarith. #[global] Hint Resolve Zgcd_div_mult_rht: zarith. #[global] Hint Resolve Zgcd_idemp: zarith. #[global] Hint Resolve Zgcd_zero_lft: zarith. #[global] Hint Resolve Zgcd_zero_rht: zarith. #[global] Hint Resolve Zgcd_one_lft: zarith. #[global] Hint Resolve Zgcd_one_rht: zarith. #[global] Hint Resolve Zgcd_le_lft: zarith. #[global] Hint Resolve Zgcd_le_rht: zarith. #[global] Hint Resolve Zgcd_gcd_ll: zarith. #[global] Hint Resolve Zgcd_gcd_lr: zarith. #[global] Hint Resolve Zgcd_gcd_rl: zarith. #[global] Hint Resolve Zgcd_gcd_rr: zarith. #[global] Hint Resolve Zgcd_mult_elim_ll: zarith. #[global] Hint Resolve Zgcd_mult_elim_lr: zarith. #[global] Hint Resolve Zgcd_mult_elim_rl: zarith. #[global] Hint Resolve Zgcd_mult_elim_rr: zarith. #[global] Hint Resolve Zgcd_plus_elim_ll: zarith. #[global] Hint Resolve Zgcd_plus_elim_lr: zarith. #[global] Hint Resolve Zgcd_plus_elim_rl: zarith. #[global] Hint Resolve Zgcd_plus_elim_rr: zarith. #[global] Hint Resolve Zgcd_minus_elim_ll: zarith. #[global] Hint Resolve Zgcd_minus_elim_lr: zarith. #[global] Hint Resolve Zgcd_minus_elim_rl: zarith. #[global] Hint Resolve Zgcd_minus_elim_rr: zarith. #[global] Hint Resolve Zgcd_mod_lft: zarith. #[global] Hint Resolve Zgcd_mod_rht: zarith. #[global] Hint Resolve Zgcd_div_gcd_1: zarith. (** ** Relative primality *) Section zrelprime. Definition Zrelprime (a b : Z) := Zgcd a b = 1%Z. Lemma Zrelprime_dec : forall a b : Z, {Zrelprime a b} + {~ Zrelprime a b}. Proof. intros a b. unfold Zrelprime in |- *. case (Zdec (Zgcd a b - 1)). intro H1. left. auto with zarith. intro Hn1. right. auto with zarith. Qed. Lemma Zrelprime_irref : forall a : Z, (a > 1)%Z -> ~ Zrelprime a a. Proof. intros a Ha. unfold Zrelprime in |- *. rewrite Zgcd_idemp. auto with zarith. auto with zarith. Qed. Lemma Zrelprime_symm : forall a b : Z, Zrelprime a b -> Zrelprime b a. Proof. unfold Zrelprime in |- *. intros. rewrite Zgcd_symm. assumption. Qed. Lemma Zrelprime_one_lft : forall a : Z, Zrelprime 1 a. Proof. intro a. unfold Zrelprime in |- *. apply Zgcd_one_lft. Qed. Lemma Zrelprime_one_rht : forall a : Z, Zrelprime a 1. Proof. intro a. unfold Zrelprime in |- *. apply Zgcd_one_rht. Qed. Lemma Zrelprime_nonzero_rht : forall a b : Z, Zrelprime a b -> Z.abs a <> 1%Z -> b <> 0%Z. Proof. intros a b H Ha. intro Hfalse. rewrite Hfalse in H. unfold Zrelprime in H. rewrite Zgcd_zero_rht in H. tauto. Qed. Lemma Zrelprime_nonzero_lft : forall a b : Z, Zrelprime a b -> Z.abs b <> 1%Z -> a <> 0%Z. Proof. intros. apply (Zrelprime_nonzero_rht b a). apply Zrelprime_symm. assumption. assumption. Qed. Lemma Zrelprime_mult_intro : forall a b x y : Z, Zrelprime (a * x) (b * y) -> Zrelprime a b. Proof. intros a b x y. unfold Zrelprime in |- *. intro H1. apply Zgcd_intro_unfolded; auto with zarith. generalize (Zgcd_nonzero (a * x) (b * y)); rewrite H1; intro H0; elim H0; auto with zarith. intros q Hq. rewrite <- H1. apply Zdiv_gcd_elim; apply Zdivides_mult_elim_rht; tauto. Qed. Lemma Zrelprime_divides_intro : forall a b p q : Z, Zdivides a p -> Zdivides b q -> Zrelprime p q -> Zrelprime a b. Proof. intros a b p q Ha Hb; elim Ha; intros x Hx; rewrite <- Hx; elim Hb; intros y Hy; rewrite <- Hy; rewrite (Zmult_comm x a); rewrite (Zmult_comm y b); apply Zrelprime_mult_intro. Qed. Lemma Zrelprime_div_mult_intro : forall a b c : Z, Zrelprime a b -> Zdivides a (b * c) -> Zdivides a c. Proof. intros a b c Hab Hdiv. case (Zdec (Z.abs a - 1)). intro H1. exists (c * Z.sgn a)%Z. rewrite <- Zmult_assoc. replace (Z.sgn a * a)%Z with (Z.abs a) by auto with zarith. replace (Z.abs a) with 1%Z; auto with zarith. intro Hn1. unfold Zrelprime in Hab. generalize (Zgcd_lin_comb a b). rewrite Hab. set (u := Zgcd_coeff_a a b); set (v := Zgcd_coeff_b a b). intro H1. replace c with (u * a * c + v * b * c)%Z. apply Zdivides_plus_elim. auto with zarith. rewrite <- Zmult_assoc. auto with zarith. symmetry in |- *. rewrite <- (Zmult_1_l c). replace (u * a * (1 * c))%Z with (u * a * c)%Z. replace (v * b * (1 * c))%Z with (v * b * c)%Z. rewrite H1. auto with zarith. rewrite Zmult_1_l; auto. rewrite Zmult_1_l; auto. Qed. Lemma Zrelprime_mult_div_simpl : forall a b x y : Z, Zrelprime a b -> (x * a)%Z = (y * b)%Z -> Zdivides b x. Proof. intros a b x y Hab Heq. case (Zdec a). intro Ha; rewrite Ha in Hab; unfold Zrelprime in Hab; rewrite Zgcd_zero_lft in Hab. exists (Z.sgn b * x)%Z; rewrite Zmult_comm; rewrite Zmult_assoc; rewrite (Zmult_comm b (Z.sgn b)); rewrite <- Zmult_sgn_eq_abs; rewrite Hab; apply Zmult_1_l. intro Ha. apply (Zmult_div_simpl_3 a x y b Heq Ha). apply (Zrelprime_div_mult_intro a b y Hab). exists x. rewrite Heq; apply Zmult_comm. Qed. Lemma Zrelprime_div_mult_elim : forall a b c : Z, Zrelprime a b -> Zdivides a c -> Zdivides b c -> Zdivides (a * b) c. Proof. intros a b c Hab Ha Hb. elim Ha; intros x Hx. elim Hb; intros y Hy. rewrite <- Hx. rewrite (Zmult_comm x a). cut (Zdivides b x); auto with zarith. apply (Zrelprime_mult_div_simpl a b x y Hab). rewrite Hx; rewrite Hy; auto. Qed. Lemma Zrelprime_gcd_mult_elim_lft : forall a b c : Z, Zrelprime a b -> Zgcd (a * b) c = (Zgcd a c * Zgcd b c)%Z. Proof. intros a b c. unfold Zrelprime in |- *. case (Zdec (a * b)). intro Hab0. generalize (Zmult_zero_div a b Hab0); intro Hab. elim Hab; intro H1; rewrite Hab0; rewrite H1; repeat rewrite Zgcd_zero_lft; repeat rewrite Zgcd_zero_rht; intro H2; rewrite Zgcd_abs; rewrite H2; rewrite Zgcd_one_lft; auto with zarith. intros Hab0 Hrelprime. apply Zdivides_antisymm. apply Z.lt_gt; apply Zgcd_pos; auto. rewrite <- (Zmult_0_r (Zgcd a c)). apply Zmult_pos_mon_lt_lft. apply Z.lt_gt; apply Zgcd_pos; left; rewrite Zmult_comm in Hab0; auto with zarith. apply Z.lt_gt; apply Zgcd_pos; left; auto with zarith. rewrite (Zgcd_lin_comb a c); rewrite (Zgcd_lin_comb b c). repeat rewrite Zmult_plus_distr_r; repeat rewrite Zmult_plus_distr_l. apply Zdivides_plus_elim; apply Zdivides_plus_elim; auto with zarith. apply Zdiv_gcd_elim. apply Zdivides_mult_elim; auto with zarith. apply Zrelprime_div_mult_elim; auto with zarith. apply (Zrelprime_divides_intro (Zgcd a c) (Zgcd b c) a b); auto with zarith. Qed. Lemma Zrelprime_gcd_mult_elim_rht : forall a b c : Z, Zrelprime a b -> Zgcd c (a * b) = (Zgcd c a * Zgcd c b)%Z. Proof. intros a b c; rewrite (Zgcd_symm c (a * b)); rewrite (Zgcd_symm c a); rewrite (Zgcd_symm c b); apply Zrelprime_gcd_mult_elim_lft. Qed. Lemma Zrelprime_mult_elim_lft : forall a b c : Z, Zrelprime a c -> Zrelprime b c -> Zrelprime (a * b) c. Proof. intros a b c. unfold Zrelprime in |- *. intros Ha Hb. generalize (Zgcd_lin_comb a c); rewrite Ha; set (p := Zgcd_coeff_a a c) in *; set (q := Zgcd_coeff_b a c) in *. generalize (Zgcd_lin_comb b c); rewrite Hb; set (r := Zgcd_coeff_a b c) in *; set (s := Zgcd_coeff_b b c) in *. intros Hla Hlb. apply Zdivides_antisymm. apply Z.lt_gt; apply Zgcd_pos. case (Zdec c); auto. intro Hc0. left. rewrite Hc0 in Ha; rewrite Zgcd_zero_rht in Ha; rewrite Hc0 in Hb; rewrite Zgcd_zero_rht in Hb; intro Hfalse. generalize (Zmult_zero_div _ _ Hfalse); intro H0; elim H0. intro Ha0; rewrite Ha0 in Ha; discriminate. intro Hb0; rewrite Hb0 in Hb; discriminate. auto with zarith. replace 1%Z with ((r * b + s * c) * (p * a + q * c))%Z. repeat rewrite Zmult_plus_distr_r; repeat rewrite Zmult_plus_distr_l; rewrite (Zmult_comm p a); rewrite (Zmult_comm a b); apply Zdivides_plus_elim; apply Zdivides_plus_elim; auto with zarith. rewrite <- Hla; rewrite <- Hlb; auto with zarith. auto with zarith. Qed. End zrelprime. #[global] Hint Resolve Zrelprime_dec: zarith. #[global] Hint Resolve Zrelprime_irref: zarith. #[global] Hint Resolve Zrelprime_symm: zarith. #[global] Hint Resolve Zrelprime_one_lft: zarith. #[global] Hint Resolve Zrelprime_one_rht: zarith. #[global] Hint Resolve Zrelprime_nonzero_rht: zarith. #[global] Hint Resolve Zrelprime_nonzero_lft: zarith. #[global] Hint Resolve Zrelprime_mult_intro: zarith. #[global] Hint Resolve Zrelprime_divides_intro: zarith. #[global] Hint Resolve Zrelprime_div_mult_intro: zarith. #[global] Hint Resolve Zrelprime_mult_div_simpl: zarith. #[global] Hint Resolve Zrelprime_div_mult_elim: zarith. #[global] Hint Resolve Zrelprime_gcd_mult_elim_lft: zarith. #[global] Hint Resolve Zrelprime_gcd_mult_elim_rht: zarith. #[global] Hint Resolve Zrelprime_mult_elim_lft: zarith. (** ** Primes Let p be a positive number. *) Section prime. Variable p : positive. Definition Prime := p <> 1%positive /\ (forall x : positive, Zdivides (Zpos x) (Zpos p) -> x = 1%positive \/ x = p). Lemma prime_rel_prime : Prime -> forall x : positive, (Zpos x < Zpos p)%Z -> Zrelprime (Zpos p) (Zpos x). Proof. intros Hprime x Hx. unfold Prime in Hprime. elim Hprime. intros H1 Hdiv. unfold Zrelprime in |- *. set (d := Zgcd (Zpos p) (Zpos x)). cut (0 < d)%Z. cut (d < Zpos p)%Z. cut (Zdivides d (Zpos p)). cut (d = Zgcd (Zpos p) (Zpos x)); auto. case d. auto with zarith. intros D HD HDiv HDlt HDpos. generalize (Hdiv D HDiv); intro H0; elim H0. intro HD1; rewrite HD1; auto. intro HDp; rewrite HDp in HDlt; elim (Zlt_irref _ HDlt). auto with zarith. unfold d in |- *; auto with zarith. apply (Z.le_lt_trans d (Zpos x) (Zpos p)); unfold d in |- *; auto with zarith. unfold d in |- *; apply Zgcd_pos; auto with zarith. Qed. (* Lemma Zprime_dec: (p:Z) {(Zprime p)} + {~(Zprime p)}. *) End prime. corn-8.20.0/model/Zmod/ZMod.v000066400000000000000000000461601473720167500156360ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* ZMod.v, by Vince Barany *) Require Export CoRN.model.Zmod.ZGcd. (** * Working modulo a positive number over Z ** Facts on `mod' *) Section zmod. Definition Zmod_same := Z_mod_same. Lemma Zmod_zero_lft : forall m : Z, (0 mod m)%Z = 0%Z. Proof. intro m. case m; auto. Qed. Lemma Zmod_zero_rht : forall a : Z, (a mod 0)%Z = ltac:(match eval hnf in (1 mod 0) with | 0 => exact 0%Z | _ => exact a end). Proof. intro a. case a; auto. Qed. Lemma Zmod_Zmod : forall m a : Z, (m > 0)%Z -> ((a mod m) mod m)%Z = (a mod m)%Z. Proof. intros m a Hm. apply (Zdiv_remainder_unique (a mod m) m (a mod m / m) ((a mod m) mod m) 0 (a mod m)). rewrite Zmult_comm. apply Z_div_mod_eq_full. apply Z_mod_lt; auto. auto with zarith. apply Z_mod_lt; auto. Qed. Lemma Zmod_cancel_multiple : forall m a b : Z, (m > 0)%Z -> ((b * m + a) mod m)%Z = (a mod m)%Z. Proof. intros m a b Hm. rewrite Zplus_comm. apply Z_mod_plus. exact Hm. Qed. Lemma Zmod_multiple : forall m a : Z, (m > 0)%Z -> ((a * m) mod m)%Z = 0%Z. Proof. intros m a Hm. rewrite <- (Zplus_0_r (a * m)). rewrite Zmod_cancel_multiple; auto. Qed. Lemma Zmod_minus_intro : forall m a b : Z, (m > 0)%Z -> ((a - b) mod m)%Z = 0%Z -> (a mod m)%Z = (b mod m)%Z. Proof. intros m a b Hm H0. assert (Hdiv : Zdivides m (a - b)); auto with zarith. elim Hdiv; intros q Hq. replace a with (q * m + b)%Z; auto with zarith. apply Zmod_cancel_multiple. assumption. Qed. Lemma Zmod_plus_compat : forall m a b : Z, (m > 0)%Z -> ((a + b) mod m)%Z = ((a mod m + b mod m) mod m)%Z. Proof. intros m a b Hm. rewrite <- (Zmod_Zmod m (a + b) Hm). apply Zmod_minus_intro. exact Hm. apply Zmod0_Zdivides. auto with zarith. replace (a mod m)%Z with (a - m * (a / m))%Z. replace (b mod m)%Z with (b - m * (b / m))%Z. replace ((a + b) mod m)%Z with (a + b - m * ((a + b) / m))%Z. unfold Zminus in |- *; repeat rewrite Zplus_assoc. repeat rewrite Zopp_plus_distr; repeat rewrite Z.opp_involutive. rewrite (Zplus_comm (a + b) (- (m * ((a + b) / m)))). repeat rewrite <- Zplus_assoc. apply Zdivides_plus_elim. auto with zarith. rewrite (Zplus_assoc (m * (a / m)) (- b) (m * (b / m))). rewrite (Zplus_comm (m * (a / m)) (- b)). rewrite <- (Zplus_assoc (- b) (m * (a / m)) (m * (b / m))). rewrite (Zplus_assoc (- a) (- b) (m * (a / m) + m * (b / m))). rewrite <- Zopp_plus_distr. repeat rewrite Zplus_assoc. rewrite Zplus_opp_r. auto with zarith. generalize (Z_div_mod_eq_full (a + b) m); auto with zarith. generalize (Z_div_mod_eq_full b m); auto with zarith. generalize (Z_div_mod_eq_full a m); auto with zarith. Qed. Lemma Zmod_plus_compat_rht : forall m a b : Z, (m > 0)%Z -> ((a + b) mod m)%Z = ((a + b mod m) mod m)%Z. Proof. intros m a b Hm. rewrite (Zmod_plus_compat m a b Hm). rewrite <- (Zmod_Zmod m (a + b mod m) Hm). rewrite (Zmod_plus_compat m a (b mod m) Hm). rewrite Zmod_Zmod; auto. rewrite Zmod_Zmod; auto. Qed. Lemma Zmod_plus_compat_lft : forall m a b : Z, (m > 0)%Z -> ((a + b) mod m)%Z = ((a mod m + b) mod m)%Z. Proof. intros m a b Hm. rewrite (Zplus_comm a b). rewrite (Zplus_comm (a mod m) b). apply Zmod_plus_compat_rht. auto. Qed. Lemma Zmod_opp_elim : forall m a : Z, (m > 0)%Z -> (- a mod m)%Z = ((m - a mod m) mod m)%Z. Proof. intros m a Hm. apply Zmod_minus_intro. exact Hm. replace (- a - (m - a mod m))%Z with (- m + (a mod m - a))%Z; auto with zarith. replace (- m)%Z with (-1 * m)%Z; auto with zarith. rewrite Zmod_cancel_multiple; auto. replace (a mod m - a)%Z with (- (a / m) * m)%Z; auto with zarith. generalize (Z_div_mod_eq_full a m). set (q := (a / m)%Z); set (r := (a mod m)%Z); intro Ha; rewrite Ha. rewrite Zplus_comm; unfold Zminus in |- *; rewrite Zopp_plus_distr; rewrite Zplus_assoc; rewrite Zplus_opp_r; rewrite Zplus_0_l; rewrite Zopp_mult_distr_l_reverse; rewrite Zmult_comm; reflexivity. Qed. Lemma Zmod_minus_elim : forall m a b : Z, (m > 0)%Z -> (a mod m)%Z = (b mod m)%Z -> ((a - b) mod m)%Z = 0%Z. Proof. intros m a b Hm Heq. unfold Zminus in |- *. rewrite (Zmod_plus_compat m a (- b) Hm). rewrite Heq. rewrite Zmod_opp_elim; auto. rewrite <- (Zmod_plus_compat m b (m - b mod m) Hm). unfold Zminus in |- *. rewrite Zplus_assoc. rewrite (Zplus_comm b m). rewrite <- Zplus_assoc. fold (b - b mod m)%Z in |- *. replace (b - b mod m)%Z with (b / m * m)%Z. rewrite Zplus_comm. rewrite Zmod_cancel_multiple; auto. apply Zmod_same; auto. set (q := (b / m)%Z); set (r := (b mod m)%Z). rewrite (Z_div_mod_eq_full b m). fold q in |- *; fold r in |- *. rewrite Zmult_comm. unfold Zminus in |- *. rewrite <- Zplus_assoc. rewrite Zplus_opp_r. auto with zarith. Qed. Lemma Zmod_mult_compat : forall m a b : Z, (m > 0)%Z -> ((a * b) mod m)%Z = ((a mod m * (b mod m)) mod m)%Z. Proof. intros m a b Hm. rewrite <- (Zmod_Zmod m (a * b) Hm). apply Zmod_minus_intro; auto. apply Zmod0_Zdivides. auto with zarith. replace (a mod m)%Z with (a - m * (a / m))%Z. replace (b mod m)%Z with (b - m * (b / m))%Z. replace ((a * b) mod m)%Z with (a * b - m * (a * b / m))%Z. unfold Zminus in |- *; repeat rewrite Zplus_assoc. repeat rewrite Zmult_plus_distr_l. repeat rewrite Zmult_plus_distr_r. repeat rewrite Zopp_plus_distr; repeat rewrite Z.opp_involutive. rewrite (Zplus_comm (a * b)). repeat rewrite <- Zplus_assoc. apply Zdivides_plus_elim. auto with zarith. repeat rewrite Zplus_assoc. rewrite Zplus_opp_r. repeat rewrite Zopp_mult_distr_l_reverse; repeat rewrite Zopp_mult_distr_r; repeat rewrite Z.opp_involutive. simpl in |- *. apply Zdivides_plus_elim; auto with zarith. generalize (Z_div_mod_eq_full (a * b) m); auto with zarith. generalize (Z_div_mod_eq_full b m); auto with zarith. generalize (Z_div_mod_eq_full a m); auto with zarith. Qed. Lemma Zmod_mult_compat_rht : forall m a b : Z, (m > 0)%Z -> ((a * b) mod m)%Z = ((a * (b mod m)) mod m)%Z. Proof. intros m a b Hm. rewrite (Zmod_mult_compat m a b Hm). rewrite <- (Zmod_Zmod m (a * (b mod m)) Hm). rewrite (Zmod_mult_compat m a (b mod m) Hm). rewrite Zmod_Zmod; auto. rewrite Zmod_Zmod; auto. Qed. Lemma Zmod_mult_compat_lft : forall m a b : Z, (m > 0)%Z -> ((a * b) mod m)%Z = ((a mod m * b) mod m)%Z. Proof. intros m a b Hm. rewrite (Zmult_comm a b). rewrite (Zmult_comm (a mod m) b). apply Zmod_mult_compat_rht. auto. Qed. Lemma Zmod_mult_elim_lft : forall m a b c : Z, (m > 0)%Z -> Zrelprime a m -> ((a * b) mod m)%Z = ((a * c) mod m)%Z -> (b mod m)%Z = (c mod m)%Z. Proof. intros m a b c Hm Hrelprime Hmulteq. assert (Hm0 : m <> 0%Z); auto with zarith. generalize (Zdivides_Zmod0 _ _ Hm0 (Zmod_minus_elim m _ _ Hm Hmulteq)); intro Hdiv. rewrite (Zmult_comm a b) in Hdiv; rewrite (Zmult_comm a c) in Hdiv; rewrite <- BinInt.Zmult_minus_distr_r in Hdiv. apply Zmod_minus_intro; auto. apply Zmod0_Zdivides. auto with zarith. apply (Zrelprime_div_mult_intro m a (b - c)). apply Zrelprime_symm; assumption. rewrite Zmult_comm; assumption. Qed. Lemma Zmod_mult_elim_rht : forall m a b c : Z, (m > 0)%Z -> Zrelprime a m -> ((b * a) mod m)%Z = ((c * a) mod m)%Z -> (b mod m)%Z = (c mod m)%Z. intros m a b c; rewrite (Zmult_comm b a); rewrite (Zmult_comm c a); apply Zmod_mult_elim_lft. Qed. Lemma Zmod_opp_zero : forall m a : Z, (m > 0)%Z -> (a mod m)%Z = 0%Z -> (- a mod m)%Z = 0%Z. Proof. intros m a Hm Ha. rewrite (Zmod_opp_elim m a Hm). rewrite Ha. unfold Zminus in |- *; simpl in |- *; rewrite Zplus_0_r. apply (Z_mod_same m Hm). Qed. Lemma Zmod_small : forall m a : Z, (m > 0)%Z -> (0 <= a < m)%Z -> (a mod m)%Z = a. Proof. intros m a Hm Ha. apply (Zmodeq_small (a mod m) a m). apply (Z_mod_lt a m Hm). exact Ha. replace (a mod m - a)%Z with (- m * (a / m))%Z. auto with zarith. generalize (Z_div_mod_eq_full a m). set (q := (a / m)%Z); set (r := (a mod m)%Z); intro H; rewrite H. rewrite Zplus_comm; unfold Zminus in |- *; rewrite Zopp_plus_distr; rewrite Zplus_assoc; rewrite Zplus_opp_r; rewrite Zplus_0_l; rewrite Zopp_mult_distr_l_reverse; rewrite Zmult_comm; reflexivity. Qed. Lemma Zmod_opp_nonzero : forall m a : Z, (m > 0)%Z -> (a mod m)%Z <> 0%Z -> (- a mod m)%Z = (m - a mod m)%Z. Proof. intros m a Hm Ha. rewrite (Zmod_opp_elim m a Hm). apply Zmod_small. exact Hm. generalize (Z_mod_lt a m Hm); intro Hlt. auto with zarith. Qed. Lemma Zmod_one_lft : forall m : Z, (m > 1)%Z -> (1 mod m)%Z = 1%Z. Proof. intros m Hm. apply Zmod_small; auto with zarith. Qed. Lemma Zmod_one_rht : forall a : Z, (a mod 1)%Z = 0%Z. Proof. intro a. generalize (Z_mod_lt a 1). auto with zarith. Qed. Lemma Zmod_lin_comb : forall m a : Z, (m > 0)%Z -> (Zgcd a m < m)%Z -> ((a * Zgcd_coeff_a a m) mod m)%Z = Zgcd a m. Proof. intros m a Hm Hgcd. generalize (Zgcd_lin_comb a m); intro Hlincomb. rewrite (Z_div_mod_eq_full (Zgcd_coeff_a a m * a) m) in Hlincomb. rewrite Zmult_comm in Hlincomb. rewrite Zplus_comm in Hlincomb. rewrite Zplus_assoc in Hlincomb. rewrite <- Zmult_plus_distr_l in Hlincomb. replace (Zgcd a m) with (Zgcd a m mod m)%Z. rewrite Hlincomb. rewrite Zmod_plus_compat; auto. rewrite Zmod_Zmod; auto. rewrite <- Zmod_plus_compat; auto. apply Zmod_minus_intro; auto. set (u := Zgcd_coeff_a a m). set (v := Zgcd_coeff_b a m). rewrite (Zplus_comm ((v + u * a / m) * m) (u * a)). unfold Zminus in |- *. rewrite Zopp_plus_distr. rewrite Zplus_assoc. rewrite (Zmult_comm a u). rewrite Zplus_opp_r. rewrite Zplus_0_l. rewrite <- Zopp_mult_distr_l_reverse. apply Zmod_multiple; auto. apply Zmod_small; auto. auto with zarith. Qed. Lemma Zmod_relprime_inv : forall m a : Z, (m > 1)%Z -> Zrelprime a m -> ((a * Zgcd_coeff_a a m) mod m)%Z = 1%Z. Proof. intros m a Hm H1. unfold Zrelprime in H1. generalize (Zgcd_lin_comb a m). intro Hlc. rewrite H1 in Hlc. rewrite (Zmult_comm (Zgcd_coeff_a a m) a) in Hlc. assert (Hqr : (a * Zgcd_coeff_a a m)%Z = (- Zgcd_coeff_b a m * m + 1)%Z). rewrite Zplus_comm. rewrite Hlc. rewrite <- Zplus_assoc. rewrite Zopp_mult_distr_l_reverse. auto with zarith. set (Hdivmod:=Z_div_mod_eq_full (a * Zgcd_coeff_a a m) m). rewrite (Zmult_comm m (a * Zgcd_coeff_a a m / m)) in Hdivmod. apply (Zdiv_remainder_unique _ _ _ _ (- Zgcd_coeff_b a m) 1 Hdivmod). apply Z_mod_lt. auto with zarith. exact Hqr. auto with zarith. Qed. End zmod. #[global] Hint Resolve Zmod_zero_lft: zarith. #[global] Hint Resolve Zmod_zero_rht: zarith. #[global] Hint Resolve Zmod_same: zarith. #[global] Hint Resolve Zmod_Zmod: zarith. #[global] Hint Resolve Zmod_cancel_multiple: zarith. #[global] Hint Resolve Zmod_multiple: zarith. #[global] Hint Resolve Zmod_minus_intro: zarith. #[global] Hint Resolve Zmod_plus_compat: zarith. #[global] Hint Resolve Zmod_plus_compat_lft: zarith. #[global] Hint Resolve Zmod_plus_compat_rht: zarith. #[global] Hint Resolve Zmod_opp_elim: zarith. #[global] Hint Resolve Zmod_minus_elim: zarith. #[global] Hint Resolve Zmod_mult_compat: zarith. #[global] Hint Resolve Zmod_mult_compat_lft: zarith. #[global] Hint Resolve Zmod_mult_compat_rht: zarith. #[global] Hint Resolve Zmod_opp_zero: zarith. #[global] Hint Resolve Zmod_small: zarith. #[global] Hint Resolve Zmod_opp_nonzero: zarith. #[global] Hint Resolve Zmod_one_lft: zarith. #[global] Hint Resolve Zmod_one_rht: zarith. #[global] Hint Resolve Zmod_lin_comb: zarith. #[global] Hint Resolve Zmod_relprime_inv: zarith. (* ** Equality modulo m Let m be a positive number. *) Section zmodeq. Variable m : positive. Definition Zmodeq (a b : Z) := Zdivides m (a - b). Lemma Zmodeq_dec : forall a b : Z, {Zmodeq a b} + {~ Zmodeq a b}. Proof. intros a b. unfold Zmodeq in |- *. apply Zdivides_dec. Qed. Lemma Zmodeq_modeq : forall a b : Z, Zmodeq a b -> (a mod m)%Z = (b mod m)%Z. Proof. intros a b H. apply Zmod_minus_intro. auto with zarith. unfold Zmodeq in H. apply Zmod0_Zdivides. intro Hfalse; inversion Hfalse. assumption. Qed. Lemma Zmodeq_eqmod : forall a b : Z, (a mod m)%Z = (b mod m)%Z -> Zmodeq a b. Proof. intros a b H. unfold Zmodeq in |- *. apply Zdivides_Zmod0. intro Hfalse; inversion Hfalse. apply Zmod_minus_elim; auto with zarith. Qed. Lemma Zmodeq_refl : forall a : Z, Zmodeq a a. Proof. intros. unfold Zmodeq in |- *. unfold Zminus in |- *. rewrite Zplus_opp_r. apply Zdivides_zero_rht. Qed. Lemma Zmodeq_symm : forall a b : Z, Zmodeq a b -> Zmodeq b a. Proof. unfold Zmodeq in |- *. intros. replace (b - a)%Z with (- (a - b))%Z; auto with zarith. Qed. Lemma Zmodeq_trans : forall a b c : Z, Zmodeq b a -> Zmodeq a c -> Zmodeq b c. Proof. unfold Zmodeq in |- *. intros. replace (b - c)%Z with (b - a + (a - c))%Z; auto with zarith. Qed. Lemma Zmodeq_zero : forall a : Z, Zmodeq a 0 <-> Zdivides m a. Proof. unfold Zmodeq in |- *; unfold Zdivides in |- *. intros. unfold Zminus in |- *. simpl in |- *. rewrite Zplus_0_r. tauto. Qed. Lemma Zmodeq_rem : forall a : Z, Zmodeq a (a mod m). Proof. intros. unfold Zmodeq in |- *. exists (a / m)%Z. rewrite Zmult_comm. generalize (Z_div_mod_eq_full a m). auto with zarith. Qed. Lemma Zmodeq_plus_compat : forall a b c d : Z, Zmodeq a b -> Zmodeq c d -> Zmodeq (a + c) (b + d). Proof. intros a b c d. unfold Zmodeq in |- *. unfold Zdivides in |- *. intros Hab Hcd. elim Hab. intros q1 H1. elim Hcd. intros q2 H2. exists (q1 + q2)%Z. rewrite Zmult_plus_distr_l. auto with zarith. Qed. Definition Zmodeq_plus_elim := Zmodeq_plus_compat. Lemma Zmodeq_plus_elim_lft : forall a b c : Z, Zmodeq a b -> Zmodeq (c + a) (c + b). Proof. intros. apply Zmodeq_plus_compat. apply Zmodeq_refl. assumption. Qed. Lemma Zmodeq_plus_elim_rht : forall a b c : Z, Zmodeq a b -> Zmodeq (a + c) (b + c). Proof. intros. apply Zmodeq_plus_compat. assumption. apply Zmodeq_refl. Qed. Lemma Zmodeq_mult_elim_lft : forall a b c : Z, Zmodeq a b -> Zmodeq (c * a) (c * b). Proof. intros. unfold Zmodeq in |- *. unfold Zminus in |- *. rewrite (Zmult_comm c b). rewrite <- Zopp_mult_distr_l_reverse. rewrite (Zmult_comm c a). rewrite <- Zmult_plus_distr_l. fold (a - b)%Z in |- *. apply Zdivides_mult_elim_rht. assumption. Qed. Lemma Zmodeq_mult_elim_rht : forall a b c : Z, Zmodeq a b -> Zmodeq (a * c) (b * c). Proof. intros. rewrite (Zmult_comm a c). rewrite (Zmult_comm b c). apply Zmodeq_mult_elim_lft. assumption. Qed. Lemma Zmodeq_mult_compat : forall a b c d : Z, Zmodeq a b -> Zmodeq c d -> Zmodeq (a * c) (b * d). Proof. intros a b c d Hab Hcd. apply (Zmodeq_trans (b * c)). apply Zmodeq_mult_elim_rht; assumption. apply Zmodeq_mult_elim_lft; assumption. Qed. Definition Zmodeq_mult_elim := Zmodeq_mult_compat. Lemma Zmodeq_opp_elim : forall a b : Z, Zmodeq a b -> Zmodeq (- a) (- b). Proof. intros a b H. replace (- a)%Z with (-1 * a)%Z; auto with zarith. replace (- b)%Z with (-1 * b)%Z; auto with zarith. apply Zmodeq_mult_elim. apply Zmodeq_refl. exact H. Qed. Lemma Zmodeq_opp_intro : forall a b : Z, Zmodeq (- a) (- b) -> Zmodeq a b. Proof. intros a b H. rewrite <- (Z.opp_involutive a). rewrite <- (Z.opp_involutive b). apply (Zmodeq_opp_elim _ _ H). Qed. Lemma Zmodeq_gcd_compat_lft : forall a b : Z, Zmodeq a b -> Zgcd m a = Zgcd m b. Proof. unfold Zmodeq in |- *. intros a b H0. elim H0; intros q Hq. replace (Zgcd m b) with (Zgcd m (b + q * m)); auto with zarith. rewrite Hq. replace (b + (a - b))%Z with a; auto with zarith. Qed. Lemma Zmodeq_gcd_compat_rht : forall a b : Z, Zmodeq a b -> Zgcd a m = Zgcd b m. Proof. intros. rewrite (Zgcd_symm a m). rewrite (Zgcd_symm b m). apply Zmodeq_gcd_compat_lft. assumption. Qed. Lemma Zmodeq_relprime : forall a b : Z, Zmodeq a b -> Zrelprime a m -> Zrelprime b m. Proof. intros a b H. unfold Zrelprime in |- *. rewrite (Zmodeq_gcd_compat_rht a b H). tauto. Qed. Lemma Zmodeq_mod_elim : forall a b : Z, Zmodeq a b -> Zmodeq (a mod m) (b mod m). Proof. intros a b H. apply Zmodeq_eqmod. rewrite Zmod_Zmod; auto with zarith. rewrite Zmod_Zmod; auto with zarith. Qed. Lemma Zmodeq_mod_elim_lft : forall a b : Z, Zmodeq a b -> Zmodeq (a mod m) b. Proof. intros a b H. apply Zmodeq_eqmod. rewrite Zmod_Zmod; auto with zarith. Qed. Lemma Zmodeq_mod_elim_rht : forall a b : Z, Zmodeq a b -> Zmodeq a (b mod m). Proof. intros a b H. apply Zmodeq_eqmod. rewrite Zmod_Zmod; auto with zarith. Qed. Lemma Zmodeq_mod_intro : forall a b : Z, Zmodeq (a mod m) (b mod m) -> Zmodeq a b. Proof. intros a b H. apply Zmodeq_eqmod. rewrite <- (Zmod_Zmod m a); auto with zarith. rewrite <- (Zmod_Zmod m b); auto with zarith. Qed. Lemma Zmodeq_mod_intro_lft : forall a b : Z, Zmodeq (a mod m) b -> Zmodeq a b. Proof. intros a b H. apply Zmodeq_eqmod. rewrite <- (Zmod_Zmod m a); auto with zarith. Qed. Lemma Zmodeq_mod_intro_rht : forall a b : Z, Zmodeq a (b mod m) -> Zmodeq a b. Proof. intros a b H. apply Zmodeq_eqmod. rewrite <- (Zmod_Zmod m b); auto with zarith. Qed. End zmodeq. #[global] Hint Resolve Zmodeq_dec: zarith. #[global] Hint Resolve Zmodeq_modeq: zarith. #[global] Hint Resolve Zmodeq_eqmod: zarith. #[global] Hint Resolve Zmodeq_refl: zarith. #[global] Hint Resolve Zmodeq_symm: zarith. #[global] Hint Resolve Zmodeq_trans: zarith. #[global] Hint Resolve Zmodeq_zero: zarith. #[global] Hint Resolve Zmodeq_rem: zarith. #[global] Hint Resolve Zmodeq_plus_compat: zarith. #[global] Hint Resolve Zmodeq_plus_elim: zarith. #[global] Hint Resolve Zmodeq_plus_elim_lft: zarith. #[global] Hint Resolve Zmodeq_plus_elim_rht: zarith. #[global] Hint Resolve Zmodeq_mult_elim_lft: zarith. #[global] Hint Resolve Zmodeq_mult_elim_rht: zarith. #[global] Hint Resolve Zmodeq_mult_compat: zarith. #[global] Hint Resolve Zmodeq_mult_elim: zarith. #[global] Hint Resolve Zmodeq_opp_intro: zarith. #[global] Hint Resolve Zmodeq_opp_elim: zarith. #[global] Hint Resolve Zmodeq_gcd_compat_lft: zarith. #[global] Hint Resolve Zmodeq_gcd_compat_rht: zarith. #[global] Hint Resolve Zmodeq_relprime: zarith. #[global] Hint Resolve Zmodeq_mod_elim: zarith. #[global] Hint Resolve Zmodeq_mod_elim_lft: zarith. #[global] Hint Resolve Zmodeq_mod_elim_rht: zarith. #[global] Hint Resolve Zmodeq_mod_intro: zarith. #[global] Hint Resolve Zmodeq_mod_intro_lft: zarith. #[global] Hint Resolve Zmodeq_mod_intro_rht: zarith. (* Notation " a ~ b ( 'mod' m ) " := (Zmodeq m a b) (at level 1, a,b,m at level 10). Syntax constr level 5: Zmodeq_print [ (Zmodeq $c1 $c2 $c3) ] -> [ $c2 "~" $c3 "(" "mod" $c1 ")" ]. *) corn-8.20.0/model/Zmod/Zm.v000066400000000000000000000333361473720167500153540ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* Zm.v, by Vince Barany *) Require Export CoRN.model.Zmod.ZMod. Require Export CoRN.algebra.CFields. (** * Zm Let m be a positive integer. We will look at the integers modulo m and prove that they form a ring. Eventually we will proof that Zp is even a field for p prime. *) (* Definition of rings Zm *) Open Scope Z_scope. Section zm. Variable m:positive. Lemma m_gt_0 : m>0. Proof. red; simpl; reflexivity. Qed. (* This was a "Local"! *) (** ** Zm is a CSetoid *) Section zm_setoid. Definition ZModeq (a b:Z) : Prop := (Zmodeq m a b). Definition ZModap (a b:Z) : CProp := (Not (Zmodeq m a b)). Lemma Zmodeq_wd : forall a b:Z, a=b -> a mod m = b mod m. Proof. intros a b Heq. elim Heq. auto. Qed. Lemma Zmodap_irreflexive: (irreflexive ZModap). Proof. red. intro x. intro H. elim H. apply Zmodeq_refl. Qed. Lemma Zmodap_symmetric: (Csymmetric ZModap). Proof. red. intros x y H. intro H0. elim H. apply Zmodeq_symm. exact H0. Qed. Lemma Zmodap_cotransitive: (cotransitive ZModap). Proof. red. intros x y H. intros z. elim (Zmodeq_dec m x z). elim (Zmodeq_dec m y z). intros Hyz Hxz. elim H. apply (Zmodeq_trans _ _ _ _ Hxz (Zmodeq_symm _ _ _ Hyz)). intros _ Hxz. right. intro Hzy. apply H. apply (Zmodeq_trans _ _ _ _ Hxz Hzy). intro H_xz. left. intro Hxz. elim H_xz. exact Hxz. Qed. Lemma Zmodap_tight_apart: (tight_apart ZModeq ZModap). Proof. red. intros x y. split. elim (Zmodeq_dec m x y). intros H Hnn. exact H. intros Hn Hnn. elim Hnn. intro H. elim Hn. exact H. intro H. intro Hnn. elim Hnn. exact H. Qed. (* Begin_Tex_Verb *) Lemma Zm_is_CSetoid : (is_CSetoid _ ZModeq ZModap). Proof. (* End_Tex_Verb *) apply Build_is_CSetoid. exact Zmodap_irreflexive. exact Zmodap_symmetric. exact Zmodap_cotransitive. exact Zmodap_tight_apart. Qed. (* Begin_Tex_Verb *) Definition Zm_csetoid := (Build_CSetoid Z ZModeq ZModap Zm_is_CSetoid). (* End_Tex_Verb *) End zm_setoid. (** ** Zm is a CAbGroup *) Section zm_group. Definition Zm_plus (a b:Zm_csetoid) : Zm_csetoid := (a+b). (* ? `((a%m)+(b%m))%m` ? *) (* Begin_Tex_Verb *) Lemma Zm_plus_strext : (bin_fun_strext _ _ _ Zm_plus). Proof. (* End_Tex_Verb *) red. intros. elim (Zmodeq_dec m x1 x2). elim (Zmodeq_dec m y1 y2). intros Hyeq Hxeq. elim X. auto with zarith. intros Hyneq _. right. intro Hyeq. elim Hyneq. exact Hyeq. intros Hxneq. left. intro Hxeq. elim Hxneq. exact Hxeq. Qed. (* Begin_Tex_Verb *) Lemma Zm_plus_wd : (bin_fun_wd _ _ _ Zm_plus). Proof. (* End_Tex_Verb *) apply bin_fun_strext_imp_wd. exact Zm_plus_strext. Qed. (* Begin_Tex_Verb *) Definition Zm_plus_op := (Build_CSetoid_bin_op _ _ Zm_plus_strext). (* End_Tex_Verb *) (* Begin_Tex_Verb *) Lemma Zm_plus_associative : (associative Zm_plus_op). Proof. (* End_Tex_Verb *) red. intros x y z. simpl. unfold ZModeq. unfold Zm_plus. rewrite Zplus_assoc. apply Zmodeq_refl. Qed. (* Begin_Tex_Verb *) Definition Zm_csemi_grp := (Build_CSemiGroup Zm_csetoid Zm_plus_op Zm_plus_associative). (* End_Tex_Verb *) (* Begin_Tex_Verb *) Lemma Zm_plus_zero_rht: (is_rht_unit Zm_plus_op 0). Proof. (* End_Tex_Verb *) red; simpl. intros. unfold ZModeq. unfold Zm_plus. rewrite Zplus_0_r. auto with zarith. Qed. (* Begin_Tex_Verb *) Lemma Zm_plus_zero_lft: (is_lft_unit Zm_plus_op 0). Proof. (* End_Tex_Verb *) red; simpl. intros. unfold ZModeq. auto with zarith. Qed. (* Begin_Tex_Verb *) Lemma Zm_plus_commutes: (commutes Zm_plus_op). Proof. (* End_Tex_Verb *) red; simpl. intros. unfold ZModeq. unfold Zm_plus. rewrite Zplus_comm. auto with zarith. Qed. (* Begin_Tex_Verb *) Definition Zm_is_CMonoid := (Build_is_CMonoid Zm_csemi_grp 0 Zm_plus_zero_rht Zm_plus_zero_lft). (* End_Tex_Verb *) (* Begin_Tex_Verb *) Definition Zm_cmonoid := (Build_CMonoid _ _ Zm_is_CMonoid). (* End_Tex_Verb *) (* Tex_Prose \subsection{Integers modulo m form a group} *) (* Begin_Tex_Verb *) Definition Zm_opp (x:Zm_cmonoid) : Zm_cmonoid := -x. (* End_Tex_Verb *) (* Begin_Tex_Verb *) Lemma Zm_opp_strext : (un_op_strext _ Zm_opp). Proof. (* End_Tex_Verb *) red; red; simpl. intros x y. unfold ZModeq; unfold ZModap; unfold Zm_plus; unfold Zm_opp. intro Hneq. intro Heq. apply Hneq. apply Zmodeq_opp_elim. exact Heq. Qed. (* Begin_Tex_Verb *) Lemma Zm_opp_well_def : (un_op_wd _ Zm_opp). Proof. (* End_Tex_Verb *) unfold un_op_wd. apply fun_strext_imp_wd. exact Zm_opp_strext. Qed. (* Begin_Tex_Verb *) Definition Zm_opp_op := (Build_CSetoid_un_op _ _ Zm_opp_strext). (* End_Tex_Verb *) (* Begin_Tex_Verb *) Lemma Zm_is_CGroup : (is_CGroup _ Zm_opp_op). Proof. (* End_Tex_Verb *) unfold is_CGroup. unfold is_inverse. simpl. unfold ZModeq; unfold Zm_plus; unfold Zm_opp. intro. rewrite Zplus_opp_r. rewrite Zplus_opp_l. auto with zarith. Qed. (* Begin_Tex_Verb *) Definition Zm_cgroup := (Build_CGroup _ _ Zm_is_CGroup). (* End_Tex_Verb *) Lemma Zm_is_CAbGroup : (is_CAbGroup Zm_cgroup). Proof. unfold is_CAbGroup. exact Zm_plus_commutes. Qed. Definition Zm_cabgroup := (Build_CAbGroup _ Zm_is_CAbGroup). End zm_group. (** ** Zm is a CRing *) Section zm_ring. Hypothesis Hnontriv: ~(m=xH). Lemma m_gt_1: m>1. Proof. unfold Z.gt. generalize Hnontriv. case m; simpl; intros; auto. elim Hnontriv0; auto. Qed. (* Dit was een Local! *) Section zm_def. (* Begin_Tex_Verb *) Definition Zm_mult (x y:Zm_cabgroup) : Zm_cabgroup := x*y. (* End_Tex_Verb *) (* Begin_Tex_Verb *) Lemma Zm_mult_strext : (bin_fun_strext _ _ _ Zm_mult). Proof. (* End_Tex_Verb *) red; simpl. unfold ZModap;unfold Zm_mult; simpl. intros x1 x2 y1 y2. intro H. elim (Zmodeq_dec m x1 x2). elim (Zmodeq_dec m y1 y2). intros Hyeq Hxeq. elim H. apply Zmodeq_mult_elim; auto with zarith. intros Hyneq _. right. intro Hyeq. elim Hyneq. exact Hyeq. intros Hxneq. left. intro Hxeq. elim Hxneq. exact Hxeq. Qed. (* Begin_Tex_Verb *) Lemma Zm_mult_wd : (bin_fun_wd _ _ _ Zm_mult). Proof. (* End_Tex_Verb *) apply bin_fun_strext_imp_wd. exact Zm_mult_strext. Qed. (* Begin_Tex_Verb *) Definition Zm_mult_op := (Build_CSetoid_bin_op _ _ Zm_mult_strext). (* End_Tex_Verb *) (* Begin_Tex_Verb *) Lemma Zm_mult_assoc : (associative Zm_mult_op). Proof. (* End_Tex_Verb *) unfold associative. intros x y z. simpl. unfold ZModeq; unfold Zm_mult. rewrite Zmult_assoc. apply Zmodeq_refl. Qed. (* Begin_Tex_Verb *) Lemma Zm_mult_commutative: forall x y:Zm_cabgroup, (Zm_mult_op x y) [=] (Zm_mult_op y x). Proof. (* End_Tex_Verb *) intros x y. simpl. unfold ZModeq; unfold Zm_mult. rewrite Zmult_comm. apply Zmodeq_refl. Qed. (* Begin_Tex_Verb *) Lemma Zm_mult_one : forall x:Zm_cabgroup, (Zm_mult_op x 1)[=]x. Proof. (* End_Tex_Verb *) intro. simpl. unfold ZModeq; unfold Zm_mult. rewrite Zmult_1_r. apply Zmodeq_refl. Qed. Lemma Zm_mult_onel : forall x:Zm_cabgroup, (Zm_mult_op 1 x)[=]x. Proof. intro. astepl (Zm_mult_op x 1). exact (Zm_mult_one x). exact (Zm_mult_commutative x 1). Qed. Definition Zm_mult_semigroup := (Build_CSemiGroup Zm_csetoid Zm_mult_op Zm_mult_assoc). Lemma Zm_mult_one_r : is_rht_unit Zm_mult_op 1. Proof. red. exact Zm_mult_one. Qed. Lemma Zm_mult_one_l : is_lft_unit Zm_mult_op 1. Proof. red. exact Zm_mult_onel. Qed. (* Begin_Tex_Verb *) Lemma Zm_mult_monoid: (is_CMonoid Zm_mult_semigroup 1). Proof. (* End_Tex_Verb *) apply Build_is_CMonoid. exact Zm_mult_one_r. exact Zm_mult_one_l. Qed. (* Begin_Tex_Verb *) Lemma Zm_mult_plus_dist : (distributive Zm_mult_op Zm_plus_op). Proof. (* End_Tex_Verb *) red; simpl. intros x y z. unfold ZModeq; unfold Zm_mult; unfold Zm_plus. rewrite <-Zmult_plus_distr_r. apply Zmodeq_refl. Qed. (* Begin_Tex_Verb *) Lemma Zm_non_triv : (ZModap 1 0). Proof. (* End_Tex_Verb *) unfold ZModap. intro Hfalse. generalize (Zmodeq_modeq _ _ _ Hfalse). rewrite Zmod_zero_lft. rewrite Zmod_one_lft; auto. intro H. assert False. discriminate. elim H0. (* Discriminate in itself caused an error in Coq *) exact m_gt_1. Qed. (* Begin_Tex_Verb *) Lemma Zm_is_CRing : (is_CRing Zm_cabgroup 1 Zm_mult_op). Proof. (* End_Tex_Verb *) apply Build_is_CRing with Zm_mult_assoc. exact Zm_mult_monoid. exact Zm_mult_commutative. exact Zm_mult_plus_dist. exact Zm_non_triv. Qed. End zm_def. (* Begin_Tex_Verb *) Definition Zm_cring := (Build_CRing _ _ _ Zm_is_CRing) : CRing. Definition Zm := Zm_cring. (* End_Tex_Verb *) Section zm_ring_basics. Definition Zm_mult_ord (a:Zm)(h:nat) := (a[^]h[=][1]) /\ forall k:nat, (lt k h)->~(a[^]k[=][1]). End zm_ring_basics. End zm_ring. (** ** Zp is a field From now on m is prime. *) Section zp_def. (* Dit was een Local!!! *) Hypothesis Hprime: (Prime m). Lemma p_not_1: ~m=xH. Proof. unfold Prime in Hprime. elim Hprime; intros; assumption. Qed. Lemma p_gt_0: m>0. Proof. red; simpl; reflexivity. Qed. Lemma p_gt_1: m>1. Proof. unfold Z.gt. generalize p_not_1. case m; simpl; intro H; auto. elim H; auto. Qed. Definition Zp := (Zm p_not_1). (** *** The inverse element in Zp Let x in Zp, such that x is apart from [0]. Then we will show that there is an inverse element y such that x[*]y [=] [1] in Zp. *) Section zp_nonzero. Variable x: Zp. Hypothesis Hx: x[#][0]. Lemma Zp_nonz_mod: 0<(Z.modulo x m)(x[#]y)). Proof. (* End_Tex_Verb *) intros x y Hx Hy. simpl. unfold ZModap; unfold Zp_inv. intro Hinv. intro Heq. generalize (Zmodeq_modeq _ _ _ Heq); clear Heq; intro Heq. elim Hinv. apply Zmodeq_eqmod. generalize (Zmod_relprime_inv m x p_gt_1 (Zp_nonz_relprime x Hx)). rewrite <- (Zmod_relprime_inv m y p_gt_1 (Zp_nonz_relprime y Hy)). rewrite (Zmod_mult_compat m x); auto. rewrite (Zmod_mult_compat m y); auto. (*unfold p.*) rewrite Heq. rewrite <-Zmod_mult_compat; auto. rewrite <-Zmod_mult_compat; auto. intro Hmult. apply (Zmod_mult_elim_lft _ _ _ _ p_gt_0 (Zp_nonz_relprime y Hy) Hmult). exact m_gt_0. exact m_gt_0. exact p_gt_0. exact p_gt_0. Qed. (* Begin_Tex_Verb *) Lemma Zp_is_CField: (is_CField Zp Zp_inv). Proof. (* End_Tex_Verb *) red; red. intros x. simpl; unfold ZModap; unfold ZModeq; unfold Zm_mult; unfold Zp_inv. intros Hx. elim (Zp_nonz_mod x Hx); intros Hxmod0 Hxmodp. split. apply Zmodeq_eqmod. rewrite Zmod_one_lft; auto. (*rewrite <-Zmod_mult_compat; auto.*) (*rewrite Zmod_Zmod; auto.*) apply Zmod_relprime_inv; auto. exact p_gt_1. apply Zrelprime_symm. unfold Zrelprime. rewrite <-Zgcd_mod_rht; auto. generalize Hxmod0. set (d:=(Z.modulo x m)). cut (d=(Z.modulo x m)); auto. case d. intros _ Hfalse; elim (Zlt_irref _ Hfalse). intros D HD _. rewrite <-HD in Hxmodp. (*fold p;*) (*rewrite <-HD.*) elim (prime_rel_prime m Hprime D Hxmodp); auto. intros D _ Hfalse; elim (Zge_0_NEG _ Hfalse). exact p_gt_0. exact p_gt_1. (*rewrite Zm_mult_commutative.*) apply Zmodeq_eqmod. rewrite Zmod_one_lft; auto. cut ((x * Zgcd_coeff_a x m) mod m = 1). intro H; elim H. apply Zmodeq_wd. apply Zmult_comm. apply Zmod_relprime_inv; auto. exact p_gt_1. apply Zrelprime_symm. unfold Zrelprime. rewrite <-Zgcd_mod_rht; auto. generalize Hxmod0. set (d:=(Z.modulo x m)). cut (d=(Z.modulo x m)); auto. case d. intros _ Hfalse; elim (Zlt_irref _ Hfalse). intros D HD _. rewrite <-HD in Hxmodp. (*fold p; rewrite <-HD.*) elim (prime_rel_prime m Hprime D Hxmodp); auto. intros D _ Hfalse; elim (Zge_0_NEG _ Hfalse). exact p_gt_0. exact p_gt_1. Qed. (* Begin_Tex_Verb *) Definition Fp : CField := (Build_CField _ _ Zp_is_CField Zp_inv_strext). (* End_Tex_Verb *) Definition Fp_inv (x:Fp)(Hx:x[#][0]) : Fp := (Zp_inv x Hx). End zp_def. (* Basic properties of Zp *) Section zp_prop. End zp_prop. End zm. corn-8.20.0/model/abgroups/000077500000000000000000000000001473720167500155005ustar00rootroot00000000000000corn-8.20.0/model/abgroups/CRabgroup.v000066400000000000000000000035151473720167500175570ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.model.groups.CRgroup. Require Import CoRN.reals.fast.CRcorrect. Require Export CoRN.algebra.CAbGroups. Require Import CoRN.tactics.CornTac. (** ** Example of a abelian group: $\langle$#⟨#[CR],[+]$\rangle$#⟩# *) Local Open Scope uc_scope. Lemma CRisCAbGroup : is_CAbGroup CRasCGroup. Proof. intros x y. change (x+y==y+x)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[+](CRasCauchy_IR y)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepr ((CRasCauchy_IR y)[+](CRasCauchy_IR x)); [| now apply CR_plus_as_Cauchy_IR_plus]. apply cag_commutes. Qed. Definition CRasCAbGroup : CAbGroup := Build_CAbGroup _ CRisCAbGroup. Canonical Structure CRasCAbGroup. corn-8.20.0/model/abgroups/QSposabgroup.v000066400000000000000000000031441473720167500203160ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.groups.QSposgroup. Require Import CoRN.algebra.CAbGroups. (** ** Example of an abelian group: $\langle$#⟨#[Qpos],$(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2#$\rangle$#⟩# The positive rational numbers form with the operation $(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2# an abelian group. *) Lemma Qpos_multdiv2_is_CAbGroup : is_CAbGroup Qpos_multdiv2_as_CGroup. Proof. intros x y. simpl. QposRing. Qed. Definition Qpos_multdiv2_as_CAbGroup := Build_CAbGroup Qpos_multdiv2_as_CGroup Qpos_multdiv2_is_CAbGroup. corn-8.20.0/model/abgroups/Qabgroup.v000066400000000000000000000030051473720167500174450ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.groups.Qgroup. Require Import CoRN.algebra.CAbGroups. (** ** Example of an abelian group: $\langle$#⟨#[Q],[[+]]$\rangle$#⟩# *) (** Addition is commutative, so the rationals form with the addition a CAbGroup. *) Lemma Q_is_CAbGroup : is_CAbGroup Q_as_CGroup. Proof. red in |- *. exact Qplus_is_commut1. Qed. Definition Q_as_CAbGroup := Build_CAbGroup Q_as_CGroup Q_is_CAbGroup. Canonical Structure Q_as_CAbGroup. corn-8.20.0/model/abgroups/Qposabgroup.v000066400000000000000000000027571473720167500202040ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.groups.Qposgroup. Require Import CoRN.algebra.CAbGroups. (** ** Example of an abelian group: $\langle$#⟨#[Qpos],[[*]]$\rangle$#⟩# The positive rationals form with the multiplication a CAbgroup. *) Definition Qpos_mult_is_CAbGroup : is_CAbGroup Qpos_as_CGroup. Proof. intros x y; simpl. QposRing. Qed. Definition Qpos_mult_as_CAbGroup := Build_CAbGroup Qpos_as_CGroup Qpos_mult_is_CAbGroup. corn-8.20.0/model/abgroups/Zabgroup.v000066400000000000000000000030671473720167500174660ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.groups.Zgroup. Require Import CoRN.algebra.CAbGroups. (** ** Example of an abelian group: $\langle$#⟨#[Z],[[+]]$\rangle$#⟩# *) Lemma Z_is_CAbGroup : is_CAbGroup Z_as_CGroup. Proof. red in |- *. simpl in |- *. exact Zplus_is_commut. Qed. Definition Z_as_CAbGroup := Build_CAbGroup Z_as_CGroup Z_is_CAbGroup. (** The term [Z_as_CAbGroup] is of type [CAbGroup]. Hence we have proven that [Z] is a constructive Abelian group. *) Canonical Structure Z_as_CAbGroup. corn-8.20.0/model/fields/000077500000000000000000000000001473720167500151245ustar00rootroot00000000000000corn-8.20.0/model/fields/CRfield.v000066400000000000000000000060171473720167500166270ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRFieldOps. Require Export CoRN.model.rings.CRring. Require Export CoRN.algebra.CFields. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.tactics.CornTac. (** ** Example of a field: $\langle$#⟨#[CR],[+],[*]$\rangle$#⟩# *) Local Open Scope uc_scope. Lemma CRisCField : is_CField CRasCRing CRinvT. Proof. intros x x_. split. change (x*(CRinvT x x_)==1)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[*](CRasCauchy_IR (CRinvT x x_))); [| now apply CR_mult_as_Cauchy_IR_mult]. stepl ((CRasCauchy_IR x)[*](f_rcpcl (CRasCauchy_IR x) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_))); [| now apply bin_op_is_wd_un_op_rht; apply CR_inv_as_Cauchy_IR_inv]. eapply eq_transitive. apply field_mult_inv. apply: CR_inject_Q_as_Cauchy_IR_inject_Q. change ((CRinvT x x_)*x==1)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR (CRinvT x x_))[*](CRasCauchy_IR x)); [| now apply CR_mult_as_Cauchy_IR_mult]. stepl ((f_rcpcl (CRasCauchy_IR x) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_))[*](CRasCauchy_IR x)); [| now apply bin_op_is_wd_un_op_lft; apply CR_inv_as_Cauchy_IR_inv]. eapply eq_transitive. apply field_mult_inv_op. apply: CR_inject_Q_as_Cauchy_IR_inject_Q. Qed. Lemma CRinv_strext : forall x y x_ y_, CRapartT (CRinvT x x_) (CRinvT y y_) -> CRapartT x y. Proof. intros x y x_ y_ H. apply CR_ap_as_Cauchy_IR_ap_2. apply cf_rcpsx with (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ y_). stepl (CRasCauchy_IR (CRinvT x x_)%CR); [| now apply eq_symmetric; apply (CR_inv_as_Cauchy_IR_inv_short x x_)]. stepr (CRasCauchy_IR (CRinvT y y_)%CR); [| now apply eq_symmetric; apply (CR_inv_as_Cauchy_IR_inv_short y y_)]. apply CR_ap_as_Cauchy_IR_ap_1. apply H. Qed. Definition CRasCField : CField := Build_CField CRasCRing CRinvT CRisCField CRinv_strext. Canonical Structure CRasCField. corn-8.20.0/model/fields/Qfield.v000066400000000000000000000031041473720167500165150ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.rings.Qring. Require Import CoRN.algebra.CFields. (** ** Example of a field: $\langle$#⟨#[Q],[[+]],[[*]]$\rangle$#⟩# As we have seen, there is a inverse for the multiplication for non-zeroes. So, [Q] not only forms a ring, but even a field. *) Lemma Q_is_CField : is_CField Q_as_CRing Qinv_dep. Proof. red in |- *. intro. unfold is_inverse in |- *. apply Qinv_is_inv. Qed. Definition Q_as_CField := Build_CField _ _ Q_is_CField Qinv_strext. Canonical Structure Q_as_CField. corn-8.20.0/model/groups/000077500000000000000000000000001473720167500151755ustar00rootroot00000000000000corn-8.20.0/model/groups/CRgroup.v000066400000000000000000000054311473720167500167500ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRGroupOps. Require Export CoRN.model.monoids.CRmonoid. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.tactics.CornTac. (** ** Example of a group: $\langle$#⟨#[CR],[+]$\rangle$#⟩# *) Local Open Scope uc_scope. Lemma CRopp_strext : un_op_strext CRasCSetoid CRopp. Proof. intros x y H. change (CRapartT x y)%CR. apply CR_ap_as_Cauchy_IR_ap_2. apply: un_op_strext_unfolded. 1:stepl (CRasCauchy_IR (-x)%CR); [| now apply eq_symmetric; apply CR_opp_as_Cauchy_IR_opp]. stepr (CRasCauchy_IR (-y)%CR); [| now apply eq_symmetric; apply CR_opp_as_Cauchy_IR_opp]. apply CR_ap_as_Cauchy_IR_ap_1. apply H. Qed. Definition CRoppasUnOp : CSetoid_un_op CRasCSetoid := Build_CSetoid_fun _ _ _ CRopp_strext. Lemma CRisCGroup : is_CGroup CRasCMonoid CRoppasUnOp. Proof. split. change (x-x==0)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[+](CRasCauchy_IR (- x)%CR)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepl ((CRasCauchy_IR x)[+][--](CRasCauchy_IR x)); [| now apply plus_resp_eq; apply CR_opp_as_Cauchy_IR_opp]. apply: eq_transitive. 1:apply cg_rht_inv_unfolded. apply: CR_inject_Q_as_Cauchy_IR_inject_Q. change (-x + x==0)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR (-x)%CR)[+](CRasCauchy_IR x)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepl ([--](CRasCauchy_IR x)[+](CRasCauchy_IR x)); [| now apply bin_op_is_wd_un_op_lft; apply CR_opp_as_Cauchy_IR_opp]. eapply eq_transitive. apply cg_lft_inv_unfolded. apply: CR_inject_Q_as_Cauchy_IR_inject_Q. Qed. Definition CRasCGroup : CGroup := Build_CGroup _ _ CRisCGroup. Canonical Structure CRasCGroup. corn-8.20.0/model/groups/QSposgroup.v000066400000000000000000000031651473720167500175130ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.monoids.QSposmonoid. Require Import CoRN.algebra.CGroups. (** ** Example of a group: $\langle$#⟨#[Qpos],$(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2#$\rangle$#⟩# The positive rationals form with the operation $(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2# a CGroup. *) Lemma Qpos_multdiv2_is_CGroup : is_CGroup Qpos_multdiv2_as_CMonoid divmult4. Proof. intro x. unfold is_inverse. split; simpl; field; auto with *. Qed. Definition Qpos_multdiv2_as_CGroup := Build_CGroup Qpos_multdiv2_as_CMonoid divmult4 Qpos_multdiv2_is_CGroup. corn-8.20.0/model/groups/Qgroup.v000066400000000000000000000030641473720167500166440ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.monoids.Qmonoid. Require Import CoRN.algebra.CGroups. (** ** Example of a group: $\langle$#⟨#[Q],[[+]]$\rangle$#⟩# The rational numbers with addition form a group. The inverse function is taking the opposite. *) Lemma Q_is_CGroup : is_CGroup Q_as_CMonoid Qopp_is_fun. Proof. split. apply Qplus_opp_r. simpl. rewrite Qplus_comm. apply Qplus_opp_r. Qed. Definition Q_as_CGroup := Build_CGroup Q_as_CMonoid Qopp_is_fun Q_is_CGroup. Canonical Structure Q_as_CGroup. corn-8.20.0/model/groups/Qposgroup.v000066400000000000000000000030301473720167500173570ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.monoids.Qposmonoid. Require Export CoRN.algebra.CGroups. (** ** Example of a group: $\langle$#⟨#[Qpos],[[*]]$\rangle$#⟩# The positive rational numbers form a multiplicative group. *) Lemma Qpos_is_CGroup : is_CGroup Qpos_mult_as_CMonoid Qpos_inv_op. Proof. intros x. split; simpl; autorewrite with QposElim; field; apply Qpos_nonzero. Qed. Definition Qpos_as_CGroup := Build_CGroup Qpos_mult_as_CMonoid Qpos_inv_op Qpos_is_CGroup. corn-8.20.0/model/groups/Zgroup.v000066400000000000000000000031421473720167500166520ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.monoids.Zmonoid. Require Import CoRN.algebra.CGroups. (** ** Example of a group: $\langle$#⟨#[Z],[[+]]$\rangle$#⟩# *) Lemma Z_is_CGroup : is_CGroup Z_as_CMonoid Zopp_is_fun. Proof. red in |- *. simpl in |- *. intro x. split; simpl in |- *. apply Zplus_opp_r. apply Zplus_opp_l. Qed. Definition Z_as_CGroup := Build_CGroup Z_as_CMonoid Zopp_is_fun Z_is_CGroup. (** The term [Z_as_CGroup] is of type [CGroup]. Hence we have proven that [Z] is a constructive group. *) Canonical Structure Z_as_CGroup. corn-8.20.0/model/lattice/000077500000000000000000000000001473720167500153035ustar00rootroot00000000000000corn-8.20.0/model/lattice/CRlattice.v000066400000000000000000000163001473720167500173440ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.model.partialorder.CRpartialorder. Require Import CoRN.order.SemiLattice. Require Import CoRN.order.Lattice. (** ** Example of a Lattice: *) Definition CRLattice : Lattice := makeLattice CRPartialOrder (ucFun2 CRmin) (ucFun2 CRmax) CRmin_lb_l CRmin_lb_r CRmin_glb CRmax_ub_l CRmax_ub_r CRmax_lub. Section CRLattice. Let CRlat := CRLattice. Local Open Scope CR_scope. Definition CRmin_comm : forall x y : CR, CRmin x y == CRmin y x := @meet_comm (sl CRlat). Definition CRmin_assoc : forall x y z : CR, CRmin x (CRmin y z) == CRmin (CRmin x y) z:= @meet_assoc (sl CRlat). Definition CRmin_idem : forall x : CR, CRmin x x == x := @meet_idem (sl CRlat). Definition CRle_min_l : forall x y : CR, x <= y <-> CRmin x y == x := @le_meet_l (sl CRlat). Definition CRle_min_r : forall x y : CR, y <= x <-> CRmin x y == y := @le_meet_r (sl CRlat). Definition CRmin_monotone_r : forall a : CR, CRmonotone (CRmin a) := @meet_monotone_r (sl CRlat). Definition CRmin_monotone_l : forall a : CR, CRmonotone (fun x => CRmin x a) := @meet_monotone_l (sl CRlat). Definition CRmin_le_compat : forall w x y z : CR, w <= y -> x <= z -> CRmin w x <= CRmin y z := @meet_le_compat (sl CRlat). Definition CRmax_comm : forall x y : CR, CRmax x y == CRmax y x := @join_comm CRlat. Definition CRmax_assoc : forall x y z : CR, CRmax x (CRmax y z) == CRmax (CRmax x y) z:= @join_assoc CRlat. Definition CRmax_idem : forall x : CR, CRmax x x == x := @join_idem CRlat. Definition CRle_max_l : forall x y : CR, y <= x <-> CRmax x y == x := @le_join_l CRlat. Definition CRle_max_r : forall x y : CR, x <= y <-> CRmax x y == y := @le_join_r CRlat. Definition CRmax_monotone_r : forall a : CR, CRmonotone (CRmax a) := @join_monotone_r CRlat. Definition CRmax_monotone_l : forall a : CR, CRmonotone (fun x => CRmax x a) := @join_monotone_l CRlat. Definition CRmax_le_compat : forall w x y z : CR, w<=y -> x<=z -> CRmax w x <= CRmax y z := @join_le_compat CRlat. Definition CRmin_max_absorb_l_l : forall x y : CR, CRmin x (CRmax x y) == x := @meet_join_absorb_l_l CRlat. Definition CRmax_min_absorb_l_l : forall x y : CR, CRmax x (CRmin x y) == x := @join_meet_absorb_l_l CRlat. Definition CRmin_max_absorb_l_r : forall x y : CR, CRmin x (CRmax y x) == x := @meet_join_absorb_l_r CRlat. Definition CRmax_min_absorb_l_r : forall x y : CR, CRmax x (CRmin y x) == x := @join_meet_absorb_l_r CRlat. Definition CRmin_max_absorb_r_l : forall x y : CR, CRmin (CRmax x y) x == x := @meet_join_absorb_r_l CRlat. Definition CRmax_min_absorb_r_l : forall x y : CR, CRmax (CRmin x y) x == x := @join_meet_absorb_r_l CRlat. Definition CRmin_max_absorb_r_r : forall x y : CR, CRmin (CRmax y x) x == x := @meet_join_absorb_r_r CRlat. Definition CRmax_min_absorb_r_r : forall x y : CR, CRmax (CRmin y x) x == x := @join_meet_absorb_r_r CRlat. Definition CRmin_max_eq : forall x y : CR, CRmin x y == CRmax x y -> x == y := @meet_join_eq CRlat. (* Distribution is has not been proven yet *) (* Definition CRmax_min_distr_r : forall x y z : CR, CRmax x (CRmin y z) == CRmin (CRmax x y) (CRmax x z) := @join_meet_distr_r (sl CRlat). Definition CRmax_min_distr_l : forall x y z : CR, CRmax (CRmin y z) x == CRmin (CRmax y x) (CRmax z x) := @join_meet_distr_l (sl CRlat). Definition CRmin_max_distr_r : forall x y z : CR, CRmin x (CRmax y z) == CRmax (CRmin x y) (CRmin x z) := @meet_join_distr_r (sl CRlat). Definition CRmin_max_distr_l : forall x y z : CR, CRmin (CRmax y z) x == CRmax (CRmin y x) (CRmin z x) := @meet_join_distr_l (sl CRlat). (*I don't know who wants modularity laws, but here they are *) Definition CRmax_min_modular_r : forall x y z : CR, CRmax x (CRmin y (CRmax x z)) == CRmin (CRmax x y) (CRmax x z) := @join_meet_modular_r (sl CRlat). Definition CRmax_min_modular_l : forall x y z : CR, CRmax (CRmin (CRmax x z) y) z == CRmin (CRmax x z) (CRmax y z) := @join_meet_modular_l (sl CRlat). Definition CRmin_max_modular_r : forall x y z : CR, CRmin x (CRmax y (CRmin x z)) == CRmax (CRmin x y) (CRmin x z) := @meet_join_modular_r (sl CRlat). Definition CRmin_max_modular_l : forall x y z : CR, CRmin (CRmax (CRmin x z) y) z == CRmax (CRmin x z) (CRmin y z) := @meet_join_modular_l (sl CRlat). Definition CRmin_max_disassoc : forall x y z : CR, CRmin (CRmax x y) z <= CRmax x (CRmin y z) := @meet_join_disassoc (sl CRlat). Lemma CRplus_monotone_r : forall a, CRmonotone (CRplus a). Proof. intros x y z H e. simpl. do 2 (unfold Cap_raw; simpl). ring_simplify. rapply Qle_trans;[|apply (H ((1#2)*e)%Qpos)]. rewrite Qle_minus_iff. autorewrite with QposElim. ring_simplify. rapply mult_resp_nonneg. discriminate. rapply Qpos_nonneg. Qed. Lemma CRplus_monotone_l : forall a, CRmonotone (fun x => CRplus x a). Proof. intros x y z H e. simpl. do 2 (unfold Cap_raw; simpl). ring_simplify. rapply Qle_trans;[|apply (H ((1#2)*e)%Qpos)]. rewrite Qle_minus_iff. autorewrite with QposElim. ring_simplify. rapply mult_resp_nonneg. discriminate. rapply Qpos_nonneg. Qed. Definition CRmin_plus_distr_r : forall x y z : CR, x + CRmin y z == CRmin (x+y) (x+z) := fun a => @monotone_meet_distr (sl CRlat) _ (CRplus_monotone_r a). Definition CRmin_plus_distr_l : forall x y z : CR, CRmin y z + x == CRmin (y+x) (z+x) := fun a => @monotone_meet_distr (sl CRlat) _ (CRplus_monotone_l a). Definition CRmax_plus_distr_r : forall x y z : CR, x + CRmax y z == CRmax (x+y) (x+z) := fun a => @monotone_join_distr (sl CRlat) _ (CRplus_monotone_r a). Definition CRmax_plus_distr_l : forall x y z : CR, CRmax y z + x == CRmax (y+x) (z+x) := fun a => @monotone_join_distr (sl CRlat) _ (CRplus_monotone_l a). Definition CRmin_minus_distr_l : forall x y z : CR, CRmin y z - x == CRmin (y-x) (z-x) := (fun x => CRmin_plus_distr_l (-x)). Definition CRmax_minus_distr_l : forall x y z : CR, CRmax y z - x == CRmax (y-x) (z-x) := (fun x => CRmax_plus_distr_l (-x)). Definition CRmin_max_de_morgan : forall x y : CR, -(CRmin x y) == CRmax (-x) (-y) := @antitone_meet_join_distr (sl CRlat) _ CRopp_le_compat. Definition CRmax_min_de_morgan : forall x y : CR, -(CRmax x y) == CRmin (-x) (-y) := @antitone_join_meet_distr (sl CRlat) _ CRopp_le_compat. *) End CRLattice. corn-8.20.0/model/metric2/000077500000000000000000000000001473720167500152235ustar00rootroot00000000000000corn-8.20.0/model/metric2/BoundedFunction.v000066400000000000000000000031321473720167500204770ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.metric2.Complete. Require Import CoRN.model.metric2.CRmetric. Require Import CoRN.model.metric2.LinfMetric. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.tactics.CornTac. Set Implicit Arguments. Local Open Scope uc_scope. (** ** Example of a Complete Metric Space: BoundedFunction *) Definition BoundedFunction := Complete LinfStepQ. Definition sup : BoundedFunction --> CR := Cmap LinfStepQPrelengthSpace StepQSup_uc. corn-8.20.0/model/metric2/CRmetric.v000066400000000000000000000046121473720167500171250ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.metric2.Complete. Require Export CoRN.metric2.Prelength. Require Import CoRN.model.metric2.Qmetric. Require Import MathClasses.interfaces.canonical_names. Set Implicit Arguments. Local Open Scope uc_scope. (** * Complete Metric Space: Computable Reals (CR) *) Definition CR : MetricSpace := Complete Q_as_MetricSpace. Delimit Scope CR_scope with CR. Bind Scope CR_scope with CR. #[global] Instance inject_Q_CR: Cast Q (msp_car CR) := ucFun (@Cunit Q_as_MetricSpace). (* Since (@Cunit Q_as_MetricSpace) is a bundled function with a modulus and uses a bundled representation of a metricspace as its domain, we can't define: Coercion inject_Q: Q_as_MetricSpace --> CR := (@Cunit Q_as_MetricSpace). However, is is possible to define: Coercion inject_Q' (x : Q) : CR := (@Cunit Q_as_MetricSpace x). We omit this for backward, and forward, compatibity (we can't define it for Q → AR either). *) (* begin hide *) #[global] Instance inject_Q_CR_wd: Proper (Qeq ==> (=)) inject_Q_CR. Proof. intros x y xyeq. apply (uc_wd (@Cunit Q_as_MetricSpace)). unfold msp_eq. simpl. rewrite xyeq. apply Qball_Reflexive. discriminate. Qed. (* end hide *) Notation "' x" := (inject_Q_CR x) : CR_scope. Notation "x == y" := (@msp_eq CR x y) (at level 70, no associativity) : CR_scope. corn-8.20.0/model/metric2/IntegrableFunction.v000066400000000000000000000035451473720167500212030ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.metric2.Complete. Require Import CoRN.model.metric2.CRmetric. Require Import CoRN.model.metric2.L1metric. Require Import CoRN.model.metric2.LinfMetric. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.tactics.CornTac. Require Import CoRN.model.metric2.BoundedFunction. Set Implicit Arguments. Local Open Scope uc_scope. (** ** Example of a Complete Metric Space: IntegrableFunction *) Definition IntegrableFunction := Complete L1StepQ. Definition Integral : IntegrableFunction --> CR := Cmap L1StepQPrelengthSpace IntegralQ_uc. (** Every bounded function is integrable. *) Definition BoundedAsIntegrable : BoundedFunction --> IntegrableFunction := Cmap LinfStepQPrelengthSpace LinfAsL1. corn-8.20.0/model/metric2/L1metric.v000066400000000000000000000370051473720167500170770ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.model.structures.StepQsec. Require Export CoRN.metric2.UniformContinuity. Require Import CoRN.metric2.Prelength. Require Import CoRN.model.structures.OpenUnit. From Coq Require Import QArith. Require Import CoRN.model.totalorder.QMinMax. From Coq Require Import Qabs. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.algebra.COrdFields2. Require Import CoRN.tactics.CornTac. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope sfstscope. Local Open Scope StepQ_scope. Opaque Qred. (** ** L1 metric for Step Functions The L1 metric is measured by the integral of the absolute value of the difference between step functions. *** Integeral for Step Functions. *) Definition IntegralQ:(StepQ)->Q:=(StepFfold (fun x => x) (fun b (x y:QS) => (Qred (affineCombo b x y:QS))))%Q. Definition L1Norm(f:StepF QS):Q:=(IntegralQ (StepQabs f)). Definition L1Distance(f g:StepF QS):Q:=(L1Norm (f - g)). Definition L1Ball (e:Q)(f g:StepF QS):Prop:=((L1Distance f g)<= e)%Q. (* Definition test1:=(constStepF (1:QS)). Definition test2:=(glue (ou 1/2) (constStepF (0:QS)) (constStepF (1:QS))). Eval lazy beta zeta delta iota in (L1Distance test1 test2):Q. Why is compute so slow? Eval compute in (L1Distance test1 test2):Q. Eval lazy beta zeta delta iota in (L1Distance test2 test1):Q. Eval lazy beta zeta delta iota in (L1Ball (1#1)%Qpos test2 test1). Eval compute in (Mesh test2). *) Lemma L1ball_dec : forall e a b, {L1Ball e a b}+{~L1Ball e a b}. Proof. intros e a b. unfold L1Ball. set (d:=L1Distance a b). destruct (Qlt_le_dec_fast e d) as [Hdc|Hdc]. right. abstract auto with *. left. exact Hdc. Defined. (** The integral of the glue of two step functions. *) Lemma Integral_glue : forall o s t, (IntegralQ (glue o s t) == o*(IntegralQ s) + (1-o)*(IntegralQ t))%Q. Proof. intros o s t. unfold IntegralQ. simpl. rewrite -> Qred_correct. reflexivity. Qed. (** The integral of the split of a step function. *) Lemma IntegralSplit : forall (o:OpenUnit) x, (IntegralQ x == affineCombo o (IntegralQ (SplitL x o)) (IntegralQ (SplitR x o)))%Q. Proof. intros o x. revert o. induction x. unfold IntegralQ. simpl. intros. unfold affineCombo; simpl in x; ring. intros p. rewrite -> Integral_glue. apply SplitLR_glue_ind; intros H. rewrite -> Integral_glue. unfold affineCombo in *. rewrite -> (IHx1 (OpenUnitDiv p o H)). unfold IntegralQ; simpl; fold IntegralQ. unfold affineCombo; field; auto with *. (*why does this not work*) rewrite -> Integral_glue. simpl. unfold IntegralQ; simpl; fold IntegralQ. repeat rewrite Qred_correct. unfold affineCombo in *. rewrite -> (IHx2 (OpenUnitDualDiv p o H)). unfold IntegralQ; simpl; fold IntegralQ. unfold affineCombo; field; auto with *. unfold affineCombo in *. rewrite -> H. reflexivity. Qed. (* begin hide *) #[global] Hint Resolve IntegralSplit : StepQArith. Add Morphism IntegralQ with signature (@StepF_eq _) ==> Qeq as IntegralQ_wd. Proof. induction x. intros x2 H. simpl. induction x2. auto with *. rewrite -> Integral_glue. simpl. destruct H as [H0 H1] using (eq_glue_ind x2_1). rewrite <- IHx2_1; auto with *. rewrite <- IHx2_2; auto with *. simpl in x; unfold affineCombo; ring. intros y H. destruct H as [H0 H1] using (glue_eq_ind x1). rewrite -> Integral_glue. rewrite -> (IHx1 _ H0). rewrite -> (IHx2 _ H1). symmetry. apply IntegralSplit. Qed. Add Morphism L1Norm with signature (@StepF_eq _) ==> Qeq as L1Norm_wd. Proof. unfold L1Norm. intros x y Hxy. rewrite -> Hxy. reflexivity. Qed. Add Morphism L1Distance with signature (@StepF_eq _) ==> (@StepF_eq _) ==> Qeq as L1Distance_wd. Proof. unfold L1Distance. intros x1 x2 Hx y1 y2 Hy. rewrite -> Hx. rewrite -> Hy. reflexivity. Qed. #[global] Hint Rewrite Integral_glue: StepF_rew. (* end hide *) (** How the intergral intreacts with arithemetic functions on step functions. *) Lemma Integral_plus:forall s t, ((IntegralQ s)+(IntegralQ t)==(IntegralQ (s + t)))%Q. Proof. apply StepF_ind2; try reflexivity. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht; auto. intros o s s0 t t0 H0 H1. unfold StepQplus. rewriteStepF. replace LHS with (o*(IntegralQ s + IntegralQ t) + (1-o)*(IntegralQ s0 + IntegralQ t0))%Q by simpl; ring. rewrite -> H0, H1. reflexivity. Qed. Lemma Integral_opp:forall s, (-(IntegralQ s)==(IntegralQ (- s)))%Q. Proof. induction s. reflexivity. unfold StepQopp in *. rewriteStepF. rewrite <- IHs1. rewrite <- IHs2. ring. Qed. Lemma Integral_minus:forall s t, ((IntegralQ s)-(IntegralQ t)==(IntegralQ (s - t)))%Q. Proof. intros s t. unfold Qminus. rewrite -> Integral_opp, Integral_plus. apply IntegralQ_wd. ring. Qed. Lemma Integral_scale :forall q x, (q*(IntegralQ x) == (IntegralQ (QscaleS q^@>x)))%Q. Proof. intros q x. induction x. reflexivity. rewriteStepF. rewrite <- IHx1. rewrite <- IHx2. ring. Qed. Lemma Abs_Integral : forall x, (Qabs (IntegralQ x) <= IntegralQ (QabsS ^@> x))%Q. Proof. intros x. induction x. apply Qle_refl. rewriteStepF. eapply Qle_trans. apply Qabs_triangle. do 2 rewrite -> Qabs_Qmult. rewrite -> (Qabs_pos o); auto with *. rewrite -> (Qabs_pos (1-o)); auto with *. apply: plus_resp_leEq_both;simpl; apply: mult_resp_leEq_lft; simpl; auto with *. Qed. Lemma Abs_Integral_Norm : forall x, (Qabs (IntegralQ x) <= L1Norm x)%Q. Proof. exact Abs_Integral. Qed. (** The integral of a nonnegative function is nonnegative. *) Lemma Integral_resp_nonneg :forall x, (constStepF (0:QS)) <= x -> (0 <= (IntegralQ x))%Q. Proof. intros x. unfold StepQ_le. rewriteStepF. induction x. auto. rewriteStepF. intros [Hxl Hxr]. apply: plus_resp_nonneg; apply: mult_resp_nonneg; simpl; auto with *. Qed. Lemma Integral_resp_le :forall x y, x <= y -> (IntegralQ x <= IntegralQ y)%Q. Proof. intros x y H. rewrite -> Qle_minus_iff. rewrite -> Integral_opp, Integral_plus. apply Integral_resp_nonneg. revert H. apply StepF_imp_imp. unfold StepF_imp. rewriteStepF. set (g:= QleS 0). pose (f:=(ap (compose (@ap _ _ _) (compose (compose imp) QleS)) (compose (compose g) (compose (flip QplusS) QoppS)))). cut (StepFfoldProp (f ^@> x <@> y)). unfold f. evalStepF. tauto. apply StepFfoldPropForall_Map2. intros a b. change (a <= b -> 0 <= b + (- a))%Q. rewrite -> Qle_minus_iff. tauto. Qed. (** Properties of the L1 norm. *) Lemma L1Norm_glue : forall o s t, (L1Norm (glue o s t) == o*L1Norm s + (1-o)*L1Norm t)%Q. Proof. intros o s t. unfold L1Norm. rewrite <- Integral_glue. reflexivity. Qed. Lemma L1Norm_nonneg : forall x, (0 <= (L1Norm x))%Q. Proof. intros x. apply Integral_resp_nonneg. unfold StepQ_le. rewriteStepF. set (g:=QleS 0). cut (StepFfoldProp ((compose g QabsS) ^@> x)). evalStepF. tauto. apply StepFfoldPropForall_Map. intros a. apply: Qabs_nonneg. Qed. Lemma L1Norm_Zero : forall s, (L1Norm s <= 0)%Q -> s == (constStepF (0:QS)). Proof. intros s. intros Hs. induction s. apply: Qle_antisym. eapply Qle_trans;[apply Qle_Qabs|assumption]. rewrite <- (Qopp_involutive x). change 0 with (- (- 0))%Q. apply Qopp_le_compat. eapply Qle_trans;[apply Qle_Qabs|]. rewrite -> Qabs_opp. assumption. unfold L1Norm, StepQabs in *. rewrite MapGlue in Hs. rewrite -> Integral_glue in Hs. apply glue_StepF_eq. apply IHs1. unfold L1Norm. setoid_replace 0 with (0/o); [| simpl; field; auto with *]. apply Qle_shift_div_l; auto with *. rewrite -> Qmult_comm. apply Qle_trans with (-((1 - o) * IntegralQ (QabsS ^@> s2)))%Q. rewrite -> Qle_minus_iff. rewrite -> Qle_minus_iff in Hs. replace RHS with (0 + - (o * IntegralQ (QabsS ^@> s1) + (1 - o) * IntegralQ (QabsS ^@> s2)))%Q by simpl; ring. assumption. change 0 with (-0)%Q. apply Qopp_le_compat. apply: mult_resp_nonneg; simpl; auto with *. apply: L1Norm_nonneg. apply IHs2. unfold L1Norm. setoid_replace 0 with (0/(1-o)); [| simpl; field; auto with *]. apply Qle_shift_div_l; auto with *. rewrite -> Qmult_comm. apply Qle_trans with (-(o * IntegralQ (QabsS ^@> s1)))%Q. rewrite -> Qle_minus_iff. rewrite -> Qle_minus_iff in Hs. replace RHS with (0 + - (o * IntegralQ (QabsS ^@> s1) + (1 - o) * IntegralQ (QabsS ^@> s2)))%Q by simpl; ring. assumption. change 0 with (-0)%Q. apply Qopp_le_compat. apply: mult_resp_nonneg; simpl; auto with *. apply L1Norm_nonneg. Qed. Lemma L1Norm_scale : forall q s, (L1Norm (QscaleS q ^@> s) == Qabs q * L1Norm s)%Q. Proof. intros q s. unfold L1Norm. rewrite -> Integral_scale. apply IntegralQ_wd. unfold StepF_eq. set (g:= st_eqS). set (q0 := (QscaleS q)). set (q1 := (QscaleS (Qabs q))). set (f:= ap (compose g (compose QabsS q0)) (compose q1 QabsS)). cut (StepFfoldProp (f ^@> s)). unfold f. evalStepF. tauto. apply StepFfoldPropForall_Map. intros a. apply: Qabs_Qmult. Qed. (** L1 ball has all the required properties. *) Lemma L1ball_refl : forall e x, Qle 0 e -> (L1Ball e x x). Proof. intros e x epos. unfold L1Ball, L1Distance. setoid_replace (x-x) with (constStepF (0:QS)); [| ring]. change (0 <= e)%Q. auto with *. Qed. Lemma L1ball_sym : forall e x y, (L1Ball e x y) -> (L1Ball e y x). Proof. intros e x y. unfold L1Ball, L1Distance. unfold L1Norm. setoid_replace (x-y) with (-(y-x)); [| ring]. rewrite -> StepQabsOpp. auto. Qed. Lemma L1ball_triangle : forall e d x y z, (L1Ball e x y) -> (L1Ball d y z) -> (L1Ball (e+d) x z). Proof. intros e d x y z. unfold L1Ball, L1Distance. unfold L1Norm. setoid_replace (x-z) with ((x-y)+(y-z)); [| ring]. intros He Hd. autorewrite with QposElim. apply Qle_trans with (IntegralQ (StepQabs (x-y) + StepQabs (y-z)))%Q. apply Integral_resp_le. apply StepQabs_triangle. rewrite <- Integral_plus. apply: plus_resp_leEq_both; assumption. Qed. Lemma L1ball_closed : forall e x y, (forall d, Qlt 0 d -> (L1Ball (e+d) x y)) -> (L1Ball e x y). Proof. unfold L1Ball. intros e a b H. assert (forall x, (forall d : Qpos, x <= e+ proj1_sig d) -> x <= e)%Q. { intros. apply: shift_zero_leEq_minus'. apply inv_cancel_leEq. apply approach_zero_weak. intros. replace LHS with (x[-]e). apply: shift_minus_leEq;simpl. replace RHS with (e+ e0)%Q by simpl; ring. exact (H0 (exist _ _ X)). unfold cg_minus; simpl; ring. } apply H0. intros [d dpos]. apply H, dpos. Qed. Lemma L1ball_eq : forall x y, (forall e : Q, Qlt 0 e -> L1Ball e x y) -> StepF_eq x y. Proof. intros x y H. unfold L1Ball in H. setoid_replace y with (constStepF (0:QS)+y); [| ring]. set (z:=constStepF (0:QS)). setoid_replace x with (x - y + y); [| ring]. apply StepQplus_wd; try reflexivity. unfold z; clear z. apply L1Norm_Zero. apply Qnot_lt_le. intro H0. assert (H1:0<(1#2)*( L1Norm (QminusS ^@> x <@> y))). apply: mult_resp_pos; simpl; auto with *. apply: (Qle_not_lt _ _ (H _ H1)). simpl. rewrite -> Qlt_minus_iff. unfold L1Distance. unfold StepQminus. simpl. ring_simplify. assumption. Qed. Definition L1S : RSetoid := Build_RSetoid (StepF_Sth QS). (* begin hide *) Canonical Structure L1S. (* end hide *) (** *** Example of a Metric Space *) Lemma L1_is_MetricSpace : (is_MetricSpace L1Ball). Proof. split. - intros e H x. apply L1ball_refl, H. - apply: L1ball_sym. - apply: L1ball_triangle. - apply: L1ball_closed. - intros. unfold L1Ball, L1Distance in H. apply (Qle_trans _ (L1Norm (a-b))). apply L1Norm_nonneg. exact H. - intros. unfold L1Ball, L1Distance. unfold L1Ball, L1Distance in H. apply Qnot_lt_le. intro abs. contradict H; intro H. exact (Qle_not_lt _ _ H abs). Qed. (* begin hide *) Lemma L1Ball_e_wd : forall (e1 e2:Q) x y, Qeq e1 e2 -> (L1Ball e1 x y <-> L1Ball e2 x y). Proof. intros x1 x2 y1 y2 Hx. unfold L1Ball. rewrite -> Hx. reflexivity. Qed. (* end hide *) Definition L1StepQ : MetricSpace := @Build_MetricSpace L1S _ L1Ball_e_wd L1_is_MetricSpace. (* begin hide *) Canonical Structure L1StepQ. (* end hide *) (** The L1 metric is a prelength space. *) Lemma L1StepQPrelengthSpace : PrelengthSpace L1StepQ. Proof. intros x y e d1 d2 He Hxy. set (d:=(d1+d2)%Qpos) in *. simpl in *. unfold L1Ball in *. unfold L1Distance in *. pose (d1':=constStepF (proj1_sig d1)). pose (d2':=constStepF (proj1_sig d2)). pose (d':=constStepF ((/proj1_sig d))). set (f:=(d'*(x*d2' + y*d1'))%SQ). assert (X:(((d1' + d2')*d')==constStepF (1:QS))%SQ). { change (constStepF (proj1_sig (d1 + d2)%Qpos/proj1_sig (d1 + d2)%Qpos:QS)==constStepF (X:=QS) 1). apply constStepF_wd. simpl. field. intro. destruct d1, d2, e. simpl in H. simpl in He. rewrite H in He. exact (Qlt_irrefl 0 (Qlt_trans _ _ _ q1 He)). } exists (f). setoid_replace (x - f)%SQ with (d1' * d' * (x - y))%SQ. change ((d1' * d')%SQ * (x - y)%SQ) with (QscaleS (proj1_sig d1/ proj1_sig d)%Qpos ^@> (x-y)%SQ). rewrite -> L1Norm_scale. rewrite -> Qabs_pos; auto with *. unfold Qdiv. rewrite <- Qmult_assoc, <- (Qmult_comm (L1Norm (x-y))), Qmult_assoc. apply Qle_shift_div_r; auto with *. apply: mult_resp_leEq_lft; simpl; auto with *. apply Qle_trans with (proj1_sig e); auto with *. destruct d1,d. simpl. apply Qle_shift_div_l. exact q0. rewrite Qmult_0_l. apply Qlt_le_weak, q. setoid_replace (x - f) with (constStepF (1:QS)*x - f); [| simpl; ring]. rewrite <- X. unfold f. simpl; ring. setoid_replace (f -y) with (d2' * d' * (x - y))%SQ. change ((d2' * d')%SQ * (x - y)%SQ) with (QscaleS (proj1_sig d2/proj1_sig d)%Qpos ^@> (x-y)%SQ). rewrite -> L1Norm_scale. rewrite -> Qabs_pos; auto with *. unfold Qdiv. rewrite <- Qmult_assoc, <- (Qmult_comm (L1Norm (x-y))), Qmult_assoc. apply Qle_shift_div_r; auto with *. apply: mult_resp_leEq_lft; simpl;auto with *. apply Qle_trans with (proj1_sig e); auto with *. destruct d2,d. simpl. apply Qle_shift_div_l. exact q0. rewrite Qmult_0_l. apply Qlt_le_weak, q. setoid_replace (f- y) with (f - constStepF (1:QS)*y); [| simpl; ring]. rewrite <- X. unfold f. simpl. ring. Qed. (** Integration is uniformly continuous. *) Lemma integral_uc_prf : @is_UniformlyContinuousFunction L1StepQ Q_as_MetricSpace IntegralQ Qpos2QposInf. Proof. intros e x y. simpl in *. rewrite -> Qball_Qabs. rewrite -> Integral_minus. unfold L1Ball, L1Distance. generalize (x - y). clear x y. intros x. intros Hx. eapply Qle_trans. apply Abs_Integral_Norm. assumption. Qed. Local Open Scope uc_scope. Definition IntegralQ_uc : L1StepQ --> Q_as_MetricSpace := Build_UniformlyContinuousFunction integral_uc_prf. corn-8.20.0/model/metric2/LinfDistMonad.v000066400000000000000000000273611473720167500201160ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Bas Spitters Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.StepFunctionMonad. Require Import CoRN.model.structures.OpenUnit. Require Import CoRN.tactics.CornTac. Require Import CoRN.metric2.Complete. Require Export CoRN.model.metric2.LinfMetricMonad. Require Export CoRN.metric2.StepFunctionSetoid. Require Import CoRN.tactics.Qauto. (** ** Completion distributes over Step Functions We prove the that StepF distributes over Complete using the function swap (which we call dist) as in Jones, Duponcheel - composing monads *) Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope sfstscope. Section Dist. (* M= Complete, N= StepF dist = distribComplete*) Local Open Scope sfstscope. Variable X: MetricSpace. (** The dist function exchanges StepF (under the infinity metric) and Complete monads *) Definition dist_raw (x:StepFSup (Complete X)) (e:QposInf): (StepFSup X):= (Map (fun z=> approximate z e) x). Lemma dist_prf : forall (x:StepFSup (Complete X)), is_RegularFunction (@ball (StepFSup X)) (dist_raw x). Proof. unfold dist_raw. intros x a b. induction x. - apply (@regFun_prf _ (@ball X)). - simpl (ball (m:=StepFSup X)). set (f:=(fun z : RegularFunction (@ball X) => approximate z a)) in *. set (g:=(fun z : RegularFunction (@ball X) => approximate z b)) in *. simpl. setoid_rewrite (StepFSupBallGlueGlue). auto. Qed. Definition dist1 (x:StepFSup (Complete X)): (Complete (StepFSup X)). Proof. exists (dist_raw x). abstract (apply (dist_prf x)). Defined. Add Morphism dist1 with signature (@msp_eq _) ==> (@msp_eq _) as dist1_wd. Proof. induction x. induction y. intros H d1 d2. apply: H. intros H d1 d2. destruct H. split. apply IHy1; assumption. apply IHy2; assumption. intros y H d1 d2. simpl. unfold dist_raw. simpl. apply StepF_eq_equiv in H. destruct H as [Hl Hr] using (glue_eq_ind x1 x2 y o). rewrite <- (@glueSplit (msp_as_RSetoid X) (Map (fun z : Complete X => approximate z d2) y) o). rewrite StepFunction.SplitLMap, StepFunction.SplitRMap. rewrite -> (StepFSupBallGlueGlue _ (proj1_sig d1 + 0 + proj1_sig d2) o (Map (fun z : RegularFunction (ball (m:=X)) => approximate z d1) x1) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z d1) x2)). split; revert d1 d2. apply IHx1, StepF_eq_equiv, Hl. apply IHx2, StepF_eq_equiv, Hr. Qed. Lemma dist1_uc : is_UniformlyContinuousFunction dist1 Qpos2QposInf. Proof. intros e. apply: StepF_ind2. simpl (ball_ex). intros s s0 t t0 Hs Ht H. unfold ball_ex. apply StepF_eq_equiv in Hs. apply StepF_eq_equiv in Ht. rewrite <- Hs, <- Ht. assumption. intros. assumption. intros o s s0 t t0 Hl Hr H d1 d2. simpl. unfold dist_raw. simpl. (* fold (glue o (Map (fun z : RegularFunction (@ball X) => approximate z (Qpos2QposInf d1)) s) (Map (fun z : RegularFunction (@ball X) => approximate z (Qpos2QposInf d1)) s0)). fold (glue o (Map (fun z : RegularFunction (@ball X) => approximate z (Qpos2QposInf d2)) t) (Map (fun z : RegularFunction (@ball X) => approximate z (Qpos2QposInf d2)) t0)). *) simpl in *. rewrite -> (StepFSupBallGlueGlue _ (proj1_sig d1 + proj1_sig e + proj1_sig d2) o (Map (fun z : RegularFunction (ball (m:=X)) => approximate z d1) s) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z d1) s0) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z d2) t) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z d2) t0)). rewrite -> StepFSupBallGlueGlue in H. destruct H. split; revert d1 d2. exact (Hl H). exact (Hr H0). Qed. Local Open Scope uc_scope. Local Open Scope sfstscope. Local Open Scope sfscope. Definition dist: (StepFSup (Complete X))-->(Complete (StepFSup X)). Proof. apply (@Build_UniformlyContinuousFunction _ _ dist1 (fun e => e)). abstract (exact dist1_uc). Defined. End Dist. Arguments dist {X}. Definition distconst(X : MetricSpace):(Complete X)->Complete (StepFSup X). Proof. intros x. exists (fun e => (@constStepF (msp_as_RSetoid X) (approximate x e ))). abstract (intros e1 e2; simpl; unfold StepFSupBall, StepFfoldProp; simpl; apply x). Defined. Lemma distConst(X : MetricSpace):forall (x:Complete X), msp_eq (dist (@constStepF (msp_as_RSetoid (Complete X)) x)) (distconst x). Proof. intros. intros e1 e2. simpl. unfold dist_raw. simpl. unfold StepFSupBall, StepFfoldProp;simpl. rewrite Qplus_0_r. apply x. Qed. Lemma dist_glue(X:MetricSpace)(o:OpenUnit): forall (x y:(StepFSup (Complete X))), msp_eq (dist (glue o x y)) (Cmap2_slow (glue_uc _ o) (dist x) (dist y)). Proof. pose (exist (Qlt 0) (1#2) eq_refl) as half. intros. simpl. intros e e1. simpl. unfold dist_raw. simpl. unfold Cmap_slow_fun. simpl. unfold Cap_slow_raw. simpl. unfold dist_raw. rewrite -> (StepFSupBallGlueGlue _ (proj1_sig e + 0 + proj1_sig e1) o (Map (fun z : RegularFunction (ball (m:=X)) => approximate z e) x) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z e) y)). assert (forall w:StepF (msp_as_RSetoid (Complete X)), StepFSupBall (X:=X) (proj1_sig e + proj1_sig e1) (Map (fun z : RegularFunction (@ball X) => approximate z e) w) (Map (fun z : RegularFunction (@ball X) => approximate z (half * (half * e1))%Qpos) w)). induction w. unfold StepFSupBall. unfold StepFfoldProp. simpl. rewrite <- ball_Cunit. apply ball_triangle with x0. apply ball_approx_l. apply ball_weak_le with (proj1_sig (half * (half * e1))%Qpos). rewrite -> Qle_minus_iff. simpl. replace RHS with ((3#4)*proj1_sig e1); [| simpl; ring]. Qauto_nonneg. apply ball_approx_r. simpl. rewrite -> (StepFSupBallGlueGlue _ (proj1_sig e + proj1_sig e1) o0 (Map (fun z : RegularFunction (ball (m:=X)) => approximate z e) w1) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z e) w2) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z (half * (half * e1))%Qpos) w1) (Map (fun z : RegularFunction (ball (m:=X)) => approximate z (half * (half * e1))%Qpos) w2)). intuition. rewrite Qplus_0_r. split; apply H. Qed. Section DistributionLaws. (** Now we show the laws for dist are satified, except for the last one which we have not completed yet. *) (* M= Complete, N= StepF dist = distribComplete*) (* prod≔mapM joinN . distN mapM joinN: MNN-> MN distN: NMN -> MNN *) Let prod(X:MetricSpace):= (uc_compose (Cmap_slow (StFJoinSup X)) (@dist (StepFSup X))). (* dorp ≔joinM . mapM dist MNM -> MMN -> MN *) Let dorp(X:MetricSpace):= (uc_compose Cjoin (Cmap_slow (@dist X))). (* dist . mapN (mapM f)≍mapM (mapN f) . dist NM->NM->MN = NM -> MN ->MN*) Lemma distmapmap: forall X Y (f : UniformlyContinuousSpace X Y), (ucEq (uc_compose (dist) (Map_uc (@Cmap_slow _ _ f))) (uc_compose (Cmap_slow (Map_uc f)) (dist))). Proof. pose (exist (Qlt 0) (1#2) eq_refl) as half. intros. intro x. induction x. intros e e1. simpl. unfold dist_raw. simpl. rewrite Qplus_0_r. change (ballS Y (proj1_sig e + proj1_sig e1) (Cmap_slow_raw f x e) (f (approximate x (QposInf_bind (fun y' : Qpos => (half * y')%Qpos) (mu f e1))))). unfold Cmap_slow_raw. simpl. set (ee:=(QposInf_bind (fun y' : Qpos => (half * y')%Qpos) (mu f e))). set (ee1:=(QposInf_bind (fun y' : Qpos => (half * y')%Qpos) (mu f e1))). rewrite <- ball_Cunit. assert (H:ball (m:=(Complete Y)) (proj1_sig e + proj1_sig e1) ((Cmap_slow f) (Cunit (approximate x ee))) ((Cmap_slow f) (Cunit (approximate x ee1)))). apply ball_triangle with (Cmap_slow f x);apply: (uc_prf (Cmap_slow f));[apply: ball_ex_approx_l|apply: ball_ex_approx_r]. apply H. intros e1 e2. simpl. unfold dist_raw. simpl. rewrite -> (@StepFSupBallGlueGlue Y (proj1_sig e1+0+proj1_sig e2) o (Map (fun z : RegularFunction (ball (m:=Y)) => approximate z e1) (Map (Cmap_slow_fun f) x1)) (Map (fun z : RegularFunction (ball (m:=Y)) => approximate z e1) (Map (Cmap_slow_fun f) x2)) (Map f (Map (fun z : RegularFunction (ball (m:=X)) => approximate z (QposInf_bind (fun y' : Qpos => ((1 # 2) * y')%Qpos) (mu f e2))) x1)) (Map f (Map (fun z : RegularFunction (ball (m:=X)) => approximate z (QposInf_bind (fun y' : Qpos => ((1 # 2) * y')%Qpos) (mu f e2))) x2))). split; revert e1 e2 ; [apply IHx1|apply IHx2]. Qed. (* dist . returnM≍mapM returnN*) Lemma distreturn: forall X, (ucEq (uc_compose dist (StFReturn_uc _)) (@Cmap_slow _ _ (StFReturn_uc X))). Proof. pose (exist (Qlt 0) (1#2) eq_refl) as half. intros X x. simpl. unfold StFReturn_uc. intros e e1. simpl. unfold dist_raw. simpl. unfold StepFSupBall. (* From here onwards the proof is too difficult *) change (ballS X (proj1_sig e + 0 + proj1_sig e1) (approximate x e) (approximate x (half * e1)%Qpos)). simpl. rewrite Qplus_0_r. apply ball_weak_le with (proj1_sig (Qpos_plus e (half * e1)%Qpos)). 2: apply (regFun_prf_ex x e (half * e1)%Qpos). rewrite -> Qle_minus_iff. simpl. replace RHS with ((1#2)* proj1_sig e1); [| simpl; ring]. Qauto_nonneg. Qed. (*dist . mapN returnM≍returnM*) Lemma distmapret: forall (X:MetricSpace), ucEq (uc_compose dist (@Map_uc _ _ (@Cunit X))) (@Cunit (StepFSup X)). Proof. intros X x e1 e2. rewrite Qplus_0_r. simpl. unfold dist_raw. unfold StepFSupBall. assert (@StepF_eq (msp_as_RSetoid X) (Map (fun z : Complete X => approximate z e1) (Map (Cunit_fun X) x)) (Map (fun z => (approximate ((Cunit_fun X) z) e1)) x)). { apply StepF_Qeq_eq; rewrite <- Map_compose_Map; reflexivity. } rewrite H. clear H. simpl. rewrite (Map_identity _ x). set (b:=(@ballS X (proj1_sig e1+proj1_sig e2))). set (f:=(@join _ _) ^@> (constStepF b)). cut (StepFfoldProp (f <@> x )). unfold f; evalStepF; tauto. apply: StepFfoldPropForall_Map. simpl. (* Is there a general solution to avoid StepF_Qeq_eq??*) intro a. apply ball_refl. apply (Qpos_nonneg (e1+e2)). Qed. (* We skip the proof of the following lemma since the obvious induction proof does not work since glue does not work well with join In our current setting it would be more natural to check the distributive laws using a (unit, bind) presentation. Unfortunately, we have been unable to find one in the literature. *) (* prod . mapN dorp≍dorp . prod*) (* Lemma prodmadorp:(ucEq (uc_compose (prod _) (@Map_uc _ _ (dorp _))) (uc_compose (dorp _) (@prod (Complete X))) ). *) End DistributionLaws. corn-8.20.0/model/metric2/LinfMetric.v000066400000000000000000000236021473720167500174510ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.model.structures.StepQsec. Require Import CoRN.metric2.Prelength. Require Import CoRN.model.metric2.L1metric. Require Export CoRN.model.metric2.LinfMetricMonad. Require Import CoRN.model.structures.OpenUnit. From Coq Require Import QArith. Require Import CoRN.model.totalorder.QMinMax. From Coq Require Import Qabs. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.algebra.COrdFields2. Require Import CoRN.tactics.CornTac. Set Implicit Arguments. Local Open Scope sfstscope. Local Open Scope StepQ_scope. Opaque Qmax Qabs. (** *** Sup for Step Functions on Q. *) Definition StepQSup : (StepQ)->Q := StepFfold (fun x => x) (fun b (x y:QS) => Qmax x y)%Q. (** The Sup of the glue of two step functions. *) Lemma StepQSup_glue : forall o s t, (StepQSup (glue o s t) = Qmax (StepQSup s) (StepQSup t))%Q. Proof. reflexivity. Qed. (** The sup of the split of a step function. *) Lemma StepQSupSplit : forall (o:OpenUnit) x, (StepQSup x == Qmax (StepQSup (SplitL x o)) (StepQSup (SplitR x o)))%Q. Proof. intros o x. revert o. induction x. intros o. change (x == Qmax x x)%Q. rewrite -> Qmax_idem. reflexivity. intros s. apply SplitLR_glue_ind; intros H. change (Qmax (StepQSup x1) (StepQSup x2) == Qmax (StepQSup (SplitL x1 (OpenUnitDiv s o H))) (Qmax (StepQSup (SplitR x1 (OpenUnitDiv s o H))) (StepQSup x2)))%Q. rewrite -> Qmax_assoc. rewrite <- IHx1. reflexivity. change (Qmax (StepQSup x1) (StepQSup x2) == Qmax (Qmax (StepQSup x1) (StepQSup (SplitL x2 (OpenUnitDualDiv s o H)))) (StepQSup (SplitR x2 (OpenUnitDualDiv s o H))))%Q. rewrite <- Qmax_assoc. rewrite <- IHx2. reflexivity. reflexivity. Qed. (* begin hide *) Add Morphism StepQSup with signature (@StepF_eq _) ==> Qeq as StepQSup_wd. Proof. unfold IntegralQ. induction x. intros x2 H. simpl. induction x2. simpl. auto with *. change (StepQSup (glue o x2_1 x2_2))%Q with (Qmax (StepQSup x2_1) (StepQSup x2_2)). destruct H as [H0 H1] using (eq_glue_ind x2_1). rewrite <- IHx2_1; auto with *. rewrite <- IHx2_2; auto with *. intros y H. destruct H as [H0 H1] using (glue_eq_ind x1). change (StepQSup (glue o x1 x2))%Q with (Qmax (StepQSup x1) (StepQSup x2)). rewrite -> (IHx1 _ H0). rewrite -> (IHx2 _ H1). symmetry. apply StepQSupSplit. Qed. (* end hide *) (** How the sup interacts with various arithmetic operations on step functions. *) Lemma StepQSup_resp_le : forall x y, x <= y -> (StepQSup x <= StepQSup y)%Q. Proof. apply: StepF_ind2; auto. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht; auto. intros o s s0 t t0 H0 H1. unfold StepQ_le. rewriteStepF. intros [Hl Hr]. repeat rewrite StepQSup_glue. apply Qmax_le_compat; auto. Qed. Lemma StepQSup_plus : forall x y, (StepQSup (x + y) <= StepQSup x + StepQSup y )%Q. Proof. apply StepF_ind2; auto with *. intros s s0 t t0 Hs Ht. rewrite -> Hs, Ht; auto. intros o s s0 t t0 H0 H1. unfold StepQplus. rewriteStepF. repeat rewrite StepQSup_glue. eapply Qle_trans;[apply Qmax_le_compat;[apply H0|apply H1]|]. rewrite -> Qmax_plus_distr_l. apply Qmax_le_compat; apply: plus_resp_leEq_lft; simpl; auto with *. Qed. (** The Linf metric on step function over Q. *) Definition LinfStepQ : MetricSpace := StepFSup Q_as_MetricSpace. Definition LinfStepQPrelengthSpace := StepFSupPrelengthSpace QPrelengthSpace. Lemma StepF_eq_change_base_setoid_const : forall (s : StepFunction.StepF Q) (q : Q), (@StepF_eq (msp_as_RSetoid Q_as_MetricSpace) (constStepF q) s) <-> (@StepF_eq QS (constStepF q) s). Proof. induction s. - intro q. apply Qball_0. - split. + intro metricEq. symmetry. apply (@glue_StepF_eq QS). unfold SplitL, StepFunction.SplitL. simpl. apply SplitL_resp_Xeq with (a:=o) in metricEq. rewrite (StepFunction.SplitLGlue) in metricEq. unfold StepFunction.SplitL in metricEq. simpl in metricEq. symmetry. apply (IHs1 q), metricEq. unfold SplitR, StepFunction.SplitR. simpl. apply SplitR_resp_Xeq with (a:=o) in metricEq. rewrite StepFunction.SplitRGlue in metricEq. unfold StepFunction.SplitR in metricEq. simpl in metricEq. symmetry. apply (IHs2 q), metricEq. + intro stdEq. symmetry. apply (@glue_StepF_eq (msp_as_RSetoid (Q_as_MetricSpace))). unfold SplitL, StepFunction.SplitL. simpl. apply SplitL_resp_Xeq with (a:=o) in stdEq. rewrite (StepFunction.SplitLGlue) in stdEq. unfold StepFunction.SplitL in stdEq. simpl in stdEq. symmetry. apply (IHs1 q), stdEq. unfold SplitR, StepFunction.SplitR. simpl. apply SplitR_resp_Xeq with (a:=o) in stdEq. rewrite StepFunction.SplitRGlue in stdEq. unfold StepFunction.SplitR in stdEq. simpl in stdEq. symmetry. apply (IHs2 q), stdEq. Qed. Lemma StepF_eq_change_base_setoid : forall s t : StepFunction.StepF Q, (@StepF_eq (msp_as_RSetoid Q_as_MetricSpace) s t) <-> (@StepF_eq QS s t). Proof. induction s. - intro t. apply StepF_eq_change_base_setoid_const. - intro t. split. + intro metricEq. apply glue_StepF_eq. apply SplitL_resp_Xeq with (a:=o) in metricEq. rewrite StepFunction.SplitLGlue in metricEq. apply IHs1 in metricEq. exact metricEq. apply SplitR_resp_Xeq with (a:=o) in metricEq. rewrite StepFunction.SplitRGlue in metricEq. apply IHs2 in metricEq. exact metricEq. + intro stdEq. apply glue_StepF_eq. apply SplitL_resp_Xeq with (a:=o) in stdEq. rewrite (StepFunction.SplitLGlue) in stdEq. apply IHs1 in stdEq. exact stdEq. apply SplitR_resp_Xeq with (a:=o) in stdEq. rewrite StepFunction.SplitRGlue in stdEq. apply IHs2 in stdEq. exact stdEq. Qed. (** Sup is uniformly continuous. *) Lemma sup_uc_prf : @is_UniformlyContinuousFunction LinfStepQ Q_as_MetricSpace (StepQSup:LinfStepQ -> Q) Qpos2QposInf. Proof. intros e x y. simpl. rewrite -> Qball_Qabs. revert x y. apply: StepF_ind2. intros s s0 t t0 Hs Ht. simpl. intros H H1. rewrite <- Hs, <- Ht in H1. specialize (H H1). refine (Qle_trans _ _ _ _ H). rewrite <- (StepQSup_wd s s0). rewrite <- (StepQSup_wd t t0). apply Qle_refl. apply StepF_eq_change_base_setoid, Ht. apply StepF_eq_change_base_setoid, Hs. intros x y. rewrite <- Qball_Qabs. auto. intros o s s0 t t0 H0 H1 H2. simpl in *. rewrite StepQSup_glue, StepQSup_glue. assert (X:forall a b, (-(a-b)==b-a)%Q). intros; ring. unfold StepFSupBall in H2. revert H2. rewrite (GlueAp (ballS Q_as_MetricSpace (proj1_sig e) ^@> glue o s s0)). rewrite (GlueAp (constStepF (ballS Q_as_MetricSpace (proj1_sig e)))). rewrite SplitLGlue, SplitRGlue. intros [H2a H2b]. apply Qabs_case; intros H; [|rewrite <- Qabs_opp in H0, H1; rewrite -> X in *]; (rewrite -> Qmax_minus_distr_l; unfold Qminus; apply Qmax_lub;[|clear H0; rename H1 into H0]; (eapply Qle_trans;[|apply H0; auto]); (eapply Qle_trans;[|apply Qle_Qabs]); unfold Qminus; apply: plus_resp_leEq_lft; simpl; auto with * ). Qed. Local Open Scope uc_scope. Definition StepQSup_uc : LinfStepQ --> Q_as_MetricSpace := Build_UniformlyContinuousFunction sup_uc_prf. (** There is an injection from Linf to L1. *) Lemma LinfAsL1_uc_prf : is_UniformlyContinuousFunction (fun (x:LinfStepQ) => (x:L1StepQ)) Qpos2QposInf. Proof. intros e. apply: StepF_ind2. simpl. intros s s0 t t0 Hs Ht H. intro H0. rewrite <- Hs, <- Ht in H0. specialize (H H0). clear H0. unfold L1Ball. apply StepF_eq_change_base_setoid in Hs. apply StepF_eq_change_base_setoid in Ht. rewrite <- (L1Distance_wd s s0 Hs t t0 Ht). exact H. intros x y Hxy. change (Qball (proj1_sig e) x y) in Hxy. rewrite -> Qball_Qabs in Hxy. apply Hxy. intros o s s0 t t0 Hst Hst0 H. simpl. unfold L1Ball. unfold L1Distance. unfold L1Norm. unfold StepQminus. change (@glue (msp_as_RSetoid Q_as_MetricSpace) o s s0) with (@glue QS o s s0). rewrite (MapGlue QminusS). change (@glue (msp_as_RSetoid Q_as_MetricSpace) o t t0) with (@glue QS o t t0). rewrite (ApGlueGlue (QminusS ^@> s) (QminusS ^@> s0)). unfold StepQabs. rewrite MapGlue. rewrite -> Integral_glue. setoid_replace (proj1_sig e) with (o*proj1_sig e + (1-o)*proj1_sig e)%Q; [| simpl; ring]. simpl in H. unfold StepFSupBall, StepFfoldProp in H. simpl in H. rewrite (MapGlue (ballS Q_as_MetricSpace (proj1_sig e))) in H. rewrite (ApGlueGlue (ballS Q_as_MetricSpace (proj1_sig e) ^@> s) (ballS Q_as_MetricSpace (proj1_sig e) ^@> s0)) in H. destruct H as [H0 H1]. apply Qplus_le_compat. repeat rewrite -> (Qmult_comm o). apply Qmult_le_compat_r; auto with *. apply Hst. assumption. repeat rewrite -> (Qmult_comm (1-o)). apply Qmult_le_compat_r; auto with *. apply Hst0. assumption. Qed. Definition LinfAsL1 : LinfStepQ --> L1StepQ := Build_UniformlyContinuousFunction LinfAsL1_uc_prf. corn-8.20.0/model/metric2/LinfMetricMonad.v000066400000000000000000000366471473720167500204450ustar00rootroot00000000000000(* Copyright © 2007-2008 Russell O’Connor Bas Spitters Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.StepFunctionSetoid. Require Import CoRN.metric2.StepFunctionMonad. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.structures.OpenUnit. From Coq Require Import QArith. Require Import CoRN.model.totalorder.QMinMax. From Coq Require Import Qabs. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.metric2.Prelength. Require Import CoRN.algebra.COrdFields2. Require Import CoRN.tactics.CornTac. Set Implicit Arguments. Local Open Scope sfstscope. Local Open Scope setoid_scope. (** ** Linf metric for Step Functions The Linf metric for [StepF X] is obtained by lifting the ball predicate on X *) Section StepFSupBall. Set Implicit Arguments. Variable X:MetricSpace. (** A setoid verion of the ball predicate *) Definition ballS0 (m : MetricSpace): Q -> (msp_as_RSetoid m) -> (msp_as_RSetoid m) --> iffSetoid := fun (e : Q) (x : m) => Build_Morphism (msp_as_RSetoid m) iffSetoid (ball e x) (fun (x1 x2 : m) (H : msp_eq x1 x2) => ball_wd m (reflexivity e) x x (reflexivity x) x1 x2 H). Definition ballS (m : MetricSpace): Q -> (msp_as_RSetoid m) --> (msp_as_RSetoid m) --> iffSetoid. Proof. intros e. exists (ballS0 m e). intros. simpl. split; rewrite -> H; auto with *. Defined. (** The definition of the usp metric *) Definition StepFSupBall (e:Q) (f:StepF (msp_as_RSetoid X)) (g:StepF (msp_as_RSetoid X)) := StepFfoldProp (((@ballS X e)^@> f) <@> g). Lemma StepFSupBallGlueGlue : forall e o fl fr gl gr, StepFSupBall e (glue o fl fr) (glue o gl gr) <-> StepFSupBall e fl gl /\ StepFSupBall e fr gr. Proof. intros e o fl fr gl gr. unfold StepFSupBall at 1. rewrite MapGlue. rewrite ApGlueGlue. reflexivity. Qed. End StepFSupBall. Arguments StepFSupBall [X]. Add Parametric Morphism X : (@StepFSupBall X) with signature Qeq ==> (@StepF_eq _) ==> (@StepF_eq _) ==> iff as StepFSupBall_wd. Proof. unfold StepFSupBall. intros a1 a2 Ha x1 x2 Hx y1 y2 Hy. apply StepFfoldProp_morphism. rewrite -> Hx. rewrite -> Hy. setoid_replace (ballS X a1) with (ballS X a2). reflexivity. intros x y. simpl. rewrite -> Ha. reflexivity. Qed. Lemma StepFSupBall_e_wd : forall X (e1 e2:Q) x y, Qeq e1 e2 -> (StepFSupBall e1 x y <-> @StepFSupBall X e2 x y). Proof. intros. rewrite H. reflexivity. Qed. Section SupMetric. (** The StepFSupBall satifies the requirements of a metric. *) Variable X : MetricSpace. Lemma StepFSupBall_refl : forall (e:Q) (x:StepF (msp_as_RSetoid X)), Qle (0#1) e -> StepFSupBall e x x. Proof. intros e x epos. unfold StepFSupBall. set (b:=(@ballS X e)). set (f:=(@join _ _) ^@> (constStepF b)). cut (StepFfoldProp (f <@> x )). unfold f. evalStepF. auto. apply: StepFfoldPropForall_Map. simpl. auto with *. Qed. Lemma StepFSupBall_sym : forall e (x y:StepF (msp_as_RSetoid X)), (StepFSupBall e x y) -> (StepFSupBall e y x). Proof. intros e x y. unfold StepFSupBall. set (b:=(@ballS X e)). apply StepF_imp_imp. unfold StepF_imp. set (f:=ap (compose (@ap _ _ _) (compose (compose imp) b)) (flip (b))). cut (StepFfoldProp (f ^@> x <@> y)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map2. intros a b0. simpl. unfold compose0. auto with *. Qed. Lemma StepFSupBall_triangle : forall e d (x y z:StepF (msp_as_RSetoid X)), (StepFSupBall e x y) -> (StepFSupBall d y z) -> (StepFSupBall (e+d) x z). Proof. intros e d x y z. unfold StepFSupBall. set (be:=(@ballS X e)). set (bd:=(@ballS X d)). set (bed:=(@ballS X (e+d) )). intro H. apply StepF_imp_imp. revert H. apply StepF_imp_imp. unfold StepF_imp. pose (f:= ap (compose (@ap _ _ _) (compose (compose (compose (@compose _ _ _) imp)) be)) (compose (flip (compose (@ap _ _ _) (compose (compose imp) bd))) bed)). cut (StepFfoldProp (f ^@> x <@> y <@> z)). unfold f. evalStepF. tauto. apply StepFfoldPropForall_Map3. apply: (ball_triangle X e d). Qed. Lemma StepFSupBall_closed : forall e (x y:StepF (msp_as_RSetoid X)), (forall d, Qlt (0#1) d -> (StepFSupBall (e+d) x y)) -> (StepFSupBall e x y). Proof. intros e. apply: (StepF_ind2). - intros. rewrite -> H, H0 in H1. apply H1. intro. rewrite -> H, H0. apply H2. - apply: ball_closed. - intros o s s0 t t0 IH0 IH1 H. unfold StepFSupBall in *. rewrite MapGlue. rewrite ApGlue. simpl. split. rewrite SplitLGlue. apply IH0. clear IH0. intros d dpos. pose (H2:=H d). rewrite -> MapGlue in H2. rewrite ApGlue in H2. rewrite SplitRGlue in H2. rewrite SplitLGlue in H2. destruct H2. exact dpos. auto. rewrite SplitRGlue. apply IH1. clear IH1. intros d dpos. pose (H2:=H d). rewrite -> MapGlue in H2. rewrite ApGlue in H2. rewrite SplitRGlue in H2. rewrite SplitLGlue in H2. destruct H2. exact dpos. auto. Qed. Lemma StepFSupBall_eq : forall (x y : StepF (msp_as_RSetoid X)), (forall e : Qpos, StepFSupBall (proj1_sig e) x y) -> StepF_eq x y. Proof. apply: (StepF_ind2). - intros s s0 t t0 H H0 H1 H2. rewrite -> H, H0 in H1. apply H1. intro. rewrite -> H, H0. apply H2. - intros. apply ball_eq. intros. specialize (H (exist _ _ H0)). exact H. - intros o s s0 t t0 H H0 H1. unfold StepFSupBall in *. apply glue_resp_StepF_eq. apply H. clear H. intro e. pose (H2:=H1 e). rewrite -> MapGlue in H2. rewrite ApGlue in H2. rewrite SplitRGlue in H2. rewrite SplitLGlue in H2. destruct H2; auto. apply H0. clear H0. intro e. pose (H2:=H1 e). rewrite -> MapGlue in H2. rewrite ApGlue in H2. rewrite SplitRGlue in H2. rewrite SplitLGlue in H2. destruct H2; auto. Qed. Lemma StepFSupBall_nonneg : forall (e : Q) (a b : StepFS (msp_as_RSetoid X)), StepFSupBall e a b -> Qle (0#1) e. Proof. induction a. - (* a is the constant function x *) induction b. intro H0. unfold StepFSupBall, StepFfoldProp in H0. simpl in H0. exact (msp_nonneg (msp X) e x x0 H0). intros [H0 _]. exact (IHb1 H0). - intros b H. unfold StepFSupBall, StepFfoldProp in H. simpl in H. unfold Ap in H. simpl in H. destruct (@Split X b o). destruct H. apply (IHa1 _ H). Qed. Lemma StepFSupBall_stable : forall (e : Q) (a b : StepFS (msp_as_RSetoid X)), (~~StepFSupBall e a b) -> StepFSupBall e a b. Proof. induction a. - induction b. unfold StepFSupBall, StepFfoldProp. simpl. intros. apply (msp_stable (msp X)), H. intros. split. apply IHb1. intro abs. contradict H; intros [H _]. contradiction. apply IHb2. intro abs. contradict H; intros [_ H]. contradiction. - unfold StepFSupBall, StepFfoldProp, Ap. simpl. intros b H. destruct (@Split X b o). split. apply IHa1. intro abs. contradict H; intros [H _]. contradiction. apply IHa2. intro abs. contradict H; intros [_ H]. contradiction. Qed. (** *** Example of a Metric Space *) Lemma StepFSupBall_is_MetricSpace : is_MetricSpace (@StepFSupBall X). Proof. split. - intros. intro x. apply StepFSupBall_refl, H. - apply: StepFSupBall_sym. - apply: StepFSupBall_triangle. - apply: StepFSupBall_closed. - exact StepFSupBall_nonneg. - exact StepFSupBall_stable. Qed. Definition StepFSup : MetricSpace := Build_MetricSpace (@StepFSupBall_e_wd X) StepFSupBall_is_MetricSpace. Lemma StepF_eq_equiv : forall (x y : StepFSup), StepF_eq x y <-> msp_eq x y. Proof. split. - intro H. simpl. rewrite H. apply (ball_refl StepFSup). discriminate. - intro H. apply StepFSupBall_eq. simpl in H. intro e. exact (ball_weak_le StepFSup x y (Qpos_nonneg e) H). Qed. (** The StepFSup is is a prelength space. *) Lemma StepFSupPrelengthSpace : PrelengthSpace X -> PrelengthSpace StepFSup. Proof. intros pl. apply: StepF_ind2. intros s s0 t t0 Hs Ht H e d1 d2 He H0. rewrite <- Hs, <- Ht in H0. destruct (H _ _ _ He H0) as [c Hc0 Hc1]. exists c. rewrite <- Hs; auto. rewrite <- Ht; auto. intros a b e d1 d2 He Hab. destruct (pl a b e d1 d2 He Hab) as [c Hc0 Hc1]. exists (@constStepF (msp_as_RSetoid X) c); auto. intros o s s0 t t0 IHl IHr e d1 d2 He H. simpl in H. rewrite -> StepFSupBallGlueGlue in H. destruct H as [Hl Hr]. destruct (IHl _ _ _ He Hl) as [c Hc0 Hc1]. destruct (IHr _ _ _ He Hr) as [d Hd0 Hd1]. exists (glue o c d); simpl; rewrite -> StepFSupBallGlueGlue; auto. Qed. End SupMetric. (* begin hide *) Canonical Structure StepFSup. (* end hide *) Lemma StepFSupBallBind(X:MetricSpace): ((forall (e : Qpos) (a b : StepF (StepFS (msp_as_RSetoid X))) , forall f:(StepFS (msp_as_RSetoid X)) -->(StepFS (msp_as_RSetoid X)), (forall c d, (StepFSupBall (proj1_sig e) c d) -> (StepFSupBall (proj1_sig e) (f c) (f d)))-> StepFSupBall (X:=StepFSup X) (proj1_sig e) a b -> StepFSupBall (X:=X) (proj1_sig e) (StFBind00 a f) (StFBind00 b f))). Proof. intros e a. unfold ball_ex. induction a. simpl. induction b. intros. simpl. apply H. assumption. intros f Hf H. simpl in H. unfold StepFSupBall in H. pose proof (GlueAp (constStepF (ballS (StepFSup X) (proj1_sig e)) <@^ x) o b1 b2). rewrite H0 in H. clear H0. rewrite -> StepFfoldPropglue_rew in H. destruct H as [H H1]. simpl. unfold StepFSupBall. rewrite -> GlueAp. rewrite -> StepFfoldPropglue_rew. split. pose (HH:=IHb1 (compose1 (SplitLS (msp_as_RSetoid X) o) f)). simpl in HH. simpl in HH. unfold StepFSupBall in HH. unfold compose0 in HH. assert (rew:(ballS X (proj1_sig e) ^@> SplitLS0 o (f x)) == (SplitL (ballS X (proj1_sig e) ^@> f x) o)). unfold SplitLS0. rewrite SplitLMap;reflexivity. rewrite <-rew. clear rew. apply HH; auto with *. intros. unfold SplitLS0. rewrite <- SplitLMap. rewrite <- SplitLAp. apply StepFfoldPropSplitL. apply (Hf c d H0). (* right *) pose (HH:=IHb2 (compose1 (SplitRS (msp_as_RSetoid X) o) f)). simpl in HH. unfold StepFSupBall in HH. unfold compose0 in HH. assert (rew:(ballS X (proj1_sig e) ^@> SplitRS0 o (f x)) == (SplitR (ballS X (proj1_sig e) ^@> f x) o)). unfold SplitRS0. rewrite SplitRMap;reflexivity. rewrite <-rew. clear rew. apply HH; auto with *. intros. unfold SplitRS0. rewrite <- SplitRMap. rewrite <- SplitRAp. apply StepFfoldPropSplitR. apply (Hf c d H0). intros b f Hf H. simpl. unfold StepFSupBall. simpl. rewrite MapGlue. rewrite ApGlue. rewrite -> StepFfoldPropglue_rew. split. clear IHa2. pose (HH:=IHa1 (SplitL b o) (compose1 (SplitLS (msp_as_RSetoid X) o) f)). simpl in HH. unfold compose0 in HH. unfold StepFSupBall in HH. rewrite -> SplitLBind. apply HH; clear HH. intros. unfold SplitLS0. rewrite <- SplitLMap. rewrite <- SplitLAp. apply StepFfoldPropSplitL. apply (Hf c d H0). pose (HH:=StepFfoldPropSplitL _ o H). rewrite -> SplitLAp in HH. rewrite SplitLMap in HH. assert (StepF_eq (ballS (StepFSup X) (proj1_sig e) ^@> a1 <@> SplitL b o) (ballS (StepFSup X) (proj1_sig e) ^@> SplitL (glue o a1 a2) o <@> SplitL b o)). { rewrite SplitLGlue. reflexivity. } rewrite (StepFfoldProp_mor _ _ H0). exact HH. clear IHa1. pose (HH:=IHa2 (SplitR b o) (compose1 (SplitRS (msp_as_RSetoid X) o) f)). simpl in HH. unfold compose0 in HH. unfold StepFSupBall in HH. rewrite -> SplitRBind. apply HH; clear HH. intros. unfold SplitRS0. rewrite <- SplitRMap. rewrite <- SplitRAp. apply StepFfoldPropSplitR. apply (Hf c d H0). pose (HH:=StepFfoldPropSplitR _ o H). rewrite -> SplitRAp in HH. rewrite SplitRMap in HH. assert (StepF_eq (ballS (StepFSup X) (proj1_sig e) ^@> a2 <@> SplitR b o) (ballS (StepFSup X) (proj1_sig e) ^@> SplitR (glue o a1 a2) o <@> SplitR b o)). { rewrite SplitRGlue. reflexivity. } rewrite H0. exact HH. Qed. Local Open Scope uc_scope. Section UniformlyContinuousFunctions. Variable X Y : MetricSpace. (** Various functions with step functions are uniformly continuous with this metric. *) Definition StFJoinSup :(StepFSup (StepFSup X)) --> (StepFSup X). Proof. simpl. apply (@Build_UniformlyContinuousFunction (StepFSup (StepFSup X)) _ (@StFJoin (msp_as_RSetoid X)) (fun e:Qpos=>e)). abstract (unfold is_UniformlyContinuousFunction; simpl; intros; apply StepFSupBallBind; [auto with * | assumption]). Defined. Definition StFReturn_uc : X --> (StepFSup X). Proof. simpl. exists (StFReturn (msp_as_RSetoid X)) (fun x:Qpos=> x:QposInf). abstract (intros e a b H ; apply H). Defined. Lemma uc_stdFun(X0 Y0:MetricSpace): (UniformlyContinuousFunction X0 Y0) -> (extSetoid (msp_as_RSetoid X0) (msp_as_RSetoid Y0)). Proof. intros f. exists (ucFun f). abstract (intros; apply uc_wd; assumption). Defined. (* Why doesn't this work? Coercion uc_stdFun: (UniformlyContinuousFunction X Y)>-> (extSetoid X Y). *) Definition Map_uc (f:X-->Y):(StepFSup X)-->(StepFSup Y). Proof. intros. exists (Map f) (mu f). intros e a b. simpl. unfold StepFSupBall. case_eq (mu f e). Focus 2. intros. set (bal:=(ballS Y (proj1_sig e))). unfold ball_ex in H. cut (StepFfoldProp ((flip (compose (flip (compose bal (uc_stdFun f))) (uc_stdFun f))) ^@> a <@> b)). evalStepF. auto with *. apply StepFfoldPropForall_Map2. intros. simpl. apply uc_prf. rewrite H. simpl. auto. intros q eq. apply: StepF_imp_imp. unfold StepF_imp. set (bal:=(ballS Y (proj1_sig e))). set (F:=(((flip (compose (flip (compose bal (uc_stdFun f))) (uc_stdFun f)))))). set (IMP:=(ap (compose (@ap _ _ _) (compose (compose imp) (ballS X (proj1_sig q)))) F)). cut (StepFfoldProp (IMP ^@> a <@> b)). unfold IMP, F; evalStepF. tauto. apply StepFfoldPropForall_Map2. intros a0 b0. simpl. unfold compose0. intro. apply uc_prf. rewrite eq. apply H. Defined. Definition glue_uc0 (o:OpenUnit): StepFSup X -> StepFSup X --> StepFSup X. Proof. intros x. exists (fun y=>(glue o x y)) (fun x:Qpos=> x). abstract( intros e a b; simpl; rewrite -> StepFSupBallGlueGlue; intuition; apply StepFSupBall_refl; apply Qpos_nonneg). Defined. Definition glue_uc (o:OpenUnit): StepFSup X --> StepFSup X --> StepFSup X. Proof. exists (fun y=>(glue_uc0 o y)) (fun x:Qpos=> x). intros e a b H. split. apply Qpos_nonneg. intros. simpl. rewrite -> StepFSupBallGlueGlue. intuition. apply StepFSupBall_refl. apply Qpos_nonneg. Defined. (** There is an injection from X to StepFSup X. *) Lemma constStepF_uc_prf : is_UniformlyContinuousFunction (@constStepF (msp_as_RSetoid X):X -> StepFSup X) Qpos2QposInf. Proof. intros e x y H. simpl in *. assumption. Qed. Definition constStepF_uc : X --> StepFSup X := Build_UniformlyContinuousFunction (constStepF_uc_prf). End UniformlyContinuousFunctions. Arguments constStepF_uc {X}. corn-8.20.0/model/metric2/Qmetric.v000066400000000000000000000353001473720167500170170ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.metric2.Metric. Require Import CoRN.metric2.Prelength. Require Import CoRN.metric2.Classification. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Qabs. Require Import CoRN.metric2.UniformContinuity. Require Import MathClasses.implementations.stdlib_rationals. Set Implicit Arguments. Local Open Scope Q_scope. Opaque Qabs. Definition QAbsSmall (e x : Q) : Prop := -e <= x /\ x <= e. Lemma QAbsSmall_opp : forall x y : Q, QAbsSmall x y -> QAbsSmall x (-y). Proof. intros x y H. split. apply Qopp_le_compat. apply H. rewrite <- (Qopp_involutive x). apply Qopp_le_compat. apply H. Qed. (** ** Example of a Metric: *) Definition Qball (e : Q) (a b : Q) := QAbsSmall e (a - b). Lemma AbsSmall_Qabs : forall x y, (Qabs y <= x)%Q <-> QAbsSmall x y. Proof. cut (forall x y, (0 <= y)%Q -> ((Qabs y <= x)%Q <-> QAbsSmall x y)). intros H x y. generalize (H x y) (H x (-y)%Q). clear H. rewrite -> Qabs_opp. apply Qabs_case; intros H H1 H2. auto. assert (X:QAbsSmall x y <-> QAbsSmall x (- y)%Q). split. apply QAbsSmall_opp. intros X. unfold QAbsSmall. rewrite <- (Qopp_involutive y). apply QAbsSmall_opp. assumption. rewrite -> X. apply H2. rewrite -> Qle_minus_iff in H. ring_simplify in H. ring_simplify. apply H. intros x y H. rewrite -> Qabs_pos;[|assumption]. split. intros H0. split. 2 : exact H0. refine (Qle_trans _ 0 _ _ H). apply (Qopp_le_compat 0 x). exact (Qle_trans _ _ _ H H0). intros [_ H0]. assumption. Qed. Lemma Qball_Qabs : forall e a b, Qball e a b <-> Qabs (a - b) <= e. Proof. split; apply AbsSmall_Qabs. Qed. Lemma Qle_closed : (forall e x, (forall d : Qpos, x <= e+ proj1_sig d) -> x <= e). Proof. intros. apply Qnot_lt_le. intro abs. assert (0 < (x - e) * (1#2)) as H0. { apply (Qle_lt_trans _ (0*(1#2))). discriminate. apply Qmult_lt_r. reflexivity. rewrite <- (Qplus_opp_r e). apply Qplus_lt_l. exact abs. } specialize (H (exist _ _ H0)). simpl in H. apply (Qplus_le_l _ _ (-x*(1#2))) in H. ring_simplify in H. apply Qmult_le_l in H. exact (Qle_not_lt _ _ H abs). reflexivity. Qed. (* Useful to interact with QArith lemmas. ball_wd uses the metric setoid instead. *) Add Parametric Morphism : Qball with signature Qeq ==> Qeq ==> Qeq ==> iff as Qball_wd. Proof. intros. unfold Qball, QAbsSmall. rewrite H, H0, H1. reflexivity. Qed. #[global] Instance Qball_Reflexive e: 0 <= e -> Reflexive (Qball e). Proof. intros epos x. unfold Qball. unfold QAbsSmall, Qminus. rewrite Qplus_opp_r. split. apply (Qopp_le_compat 0). exact epos. exact epos. Qed. #[global] Instance Qball_symmetric e: Symmetric (Qball e). Proof. intros x y. unfold Qball. intros. apply QAbsSmall_opp in H. unfold QAbsSmall. destruct H. split. apply (Qle_trans _ _ _ H). ring_simplify. apply Qle_refl. refine (Qle_trans _ _ _ _ H0). ring_simplify. apply Qle_refl. Qed. Lemma Q_is_MetricSpace : is_MetricSpace Qball. Proof. split; auto with typeclass_instances. - (* triangle inequality *) intros e1 e2 a b c H1 H2. unfold Qball. unfold QAbsSmall. simpl. assert (Qeq (a-c) ((a-b)+(b-c))) by ring. rewrite H. clear H. split. apply (Qle_trans _ (-e1 + -e2)). ring_simplify. apply Qle_refl. apply Qplus_le_compat. apply H1. apply H2. apply Qplus_le_compat. apply H1. apply H2. - (* distance closed *) intros e a b H. split. apply Qle_closed. intros [d dpos]. simpl. specialize (H d dpos). destruct H. apply (Qplus_le_l _ _ (-d)). ring_simplify. simpl in H. ring_simplify in H. exact H. apply Qle_closed. intros. apply H. apply Qpos_ispos. - intros. destruct H. apply (Qle_trans _ _ _ H) in H0. apply (Qplus_le_l _ _ e) in H0. ring_simplify in H0. rewrite <- (Qmult_0_r (2#1)) in H0. apply Qmult_le_l in H0. exact H0. reflexivity. - intros. split. + apply Qnot_lt_le. intro abs. contradict H; intros [H _]. exact (Qlt_not_le _ _ abs H). + apply Qnot_lt_le. intro abs. contradict H; intros [_ H]. exact (Qlt_not_le _ _ abs H). Qed. (* begin hide *) Lemma Qball_e_wd : forall (e1 e2:Q) x y, e1 == e2 -> (Qball e1 x y <-> Qball e2 x y). Proof. intros. unfold Qball, QAbsSmall. rewrite -> H. reflexivity. Qed. (* end hide *) Definition Q_as_MetricSpace : MetricSpace := @Build_MetricSpace Q _ Qball_e_wd Q_is_MetricSpace. Canonical Structure Q_as_MetricSpace. Lemma QPrelengthSpace_help : forall (e d1 d2:Qpos), proj1_sig e < proj1_sig d1+ proj1_sig d2 -> forall (a b c:Q), ball (proj1_sig e) a b -> (c == (a*proj1_sig d2 + b*proj1_sig d1)/proj1_sig (d1+d2)%Qpos) -> ball (proj1_sig d1) a c. Proof with auto with *. intros e d1 d2 He a b c Hab Hc. simpl. unfold Qball. unfold QAbsSmall. rewrite Hc. clear Hc c. assert (0 < proj1_sig (d1 + d2)%Qpos). { apply (Qlt_trans _ (proj1_sig e)). destruct e. exact q. exact He. } split. - apply (Qmult_le_r _ _ (proj1_sig (d1+d2)%Qpos)). exact H. simpl. field_simplify. apply (Qle_trans _ (proj1_sig d1 * (-proj1_sig (d1 + d2)%Qpos))). simpl. field_simplify. apply Qle_refl. apply (Qle_trans _ (proj1_sig d1 * (a - b))). apply Qmult_le_l. destruct d1. exact q. destruct Hab. apply (Qle_trans _ (-proj1_sig e)). apply Qopp_le_compat, Qlt_le_weak, He. exact H0. field_simplify. apply Qle_refl. intro abs. destruct d1, d2. simpl in abs. simpl in H. rewrite abs in H. exact (Qlt_irrefl _ H). - apply (Qmult_le_r _ _ (proj1_sig (d1+d2)%Qpos)). exact H. simpl. field_simplify. apply (Qle_trans _ (proj1_sig d1 * (a-b))). field_simplify. apply Qle_refl. apply (Qle_trans _ (proj1_sig (d1 * (d1 + d2))%Qpos)). apply Qmult_le_l. destruct d1. exact q. destruct Hab. apply (Qle_trans _ (proj1_sig e)). exact H1. apply Qlt_le_weak, He. simpl. field_simplify. apply Qle_refl. intro abs. destruct d1,d2. simpl in H, abs. rewrite abs in H. exact (Qlt_irrefl _ H). Qed. (** Q is a prelength space *) Lemma QPrelengthSpace : PrelengthSpace Q_as_MetricSpace. Proof. intros a b e d1 d2 He Hab. pose ((a * proj1_sig d2 + b * proj1_sig d1) / proj1_sig (d1 + d2)%Qpos) as c. exists c. apply (@QPrelengthSpace_help e d1 d2 He a b c); try assumption. reflexivity. apply ball_sym. eapply QPrelengthSpace_help. rewrite -> Qplus_comm. apply He. apply ball_sym. apply Hab. unfold c. unfold Qdiv. apply Qmult_comp. ring. apply Qinv_comp. simpl. ring. Qed. (** Q is a decideable metric, and hence located and stable. *) Lemma Qmetric_dec : decidableMetric Q_as_MetricSpace. Proof. intros e a b. simpl. simpl. unfold Qball, QAbsSmall. set (c:=-e). set (d:=(a-b)). destruct (Qlt_le_dec_fast d c) as [Hdc|Hdc]. right. abstract( intros [H1 H2]; apply (Qlt_not_le _ _ Hdc H1) ). destruct (Qlt_le_dec_fast e d) as [Hed|Hed]. right. abstract( intros [H1 H2]; apply (Qlt_not_le _ _ Hed H2) ). left. abstract auto. Defined. #[global] Hint Resolve Qmetric_dec : metricQ. Lemma locatedQ : locatedMetric Q_as_MetricSpace. Proof. apply decidable_located. auto with *. Defined. #[global] Hint Resolve locatedQ : metricQ. Lemma in_Qball (r: Q) (x y: Q) : (x - r <= y <= x + r) <-> Qball r x y. Proof. now rewrite Qball_Qabs, Q.Qabs_diff_Qle. Qed. Lemma in_centered_Qball (w: Q) (m x: Q): m <= x <= m + w -> Qball ((1#2) * w) (m + (1#2) * w) x. Proof. intros [??]. apply in_Qball. split; simpl; ring_simplify; assumption. Qed. Lemma nonneg_in_Qball_0 (x : Q) (Eq : 0 <= x) (ε : Q) : x <= ε <-> ball ε x 0. Proof. rewrite <-in_Qball. split. - intros ?. split. apply (Q.Qplus_le_r ε). now ring_simplify. apply (Qle_trans _ (x+0)). rewrite Qplus_0_r. exact Eq. apply Qplus_le_r. exact (Qle_trans _ _ _ Eq H). - intros [? ?]. apply (Q.Qplus_le_r (- ε)). rewrite Qplus_comm. now ring_simplify. Qed. Section Qball_Qmult. Variables (d : Qpos) (z x y: Q) (B: Qball (proj1_sig d / (Qabs z)) x y). Lemma Qball_Qmult_Q_r : Qball (proj1_sig d) (x * z) (y * z). Proof. destruct (Qeq_dec z 0) as [E|E]. rewrite E, Qmult_0_r, Qmult_0_r. apply Qball_Reflexive. apply Qpos_nonneg. apply Qball_Qabs. apply Qball_Qabs in B. assert (Qeq (x * z - y * z) ((x - y) * z)) by (simpl; ring). rewrite H. clear H. rewrite Qabs_Qmult. assert (0 < Qabs z). { apply Qabs_case. intros. apply Qle_lteq in H. destruct H. exact H. contradict E. symmetry. exact H. intros. apply Qle_lteq in H. destruct H. apply (Qplus_lt_l _ _ z). ring_simplify. exact H. contradict E. exact H. } simpl in B. apply (Qmult_le_l _ _ (/(Qabs z))). apply Qinv_lt_0_compat, H. rewrite Qmult_comm, <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. rewrite Qmult_comm. exact B. intro abs. rewrite abs in H. exact (Qlt_irrefl _ H). Qed. Lemma Qball_Qmult_Q_l : Qball (proj1_sig d) (z * x) (z * y). Proof. intros. do 2 rewrite (Qmult_comm z). apply Qball_Qmult_Q_r. Qed. End Qball_Qmult. Section more_Qball_Qmult. Variables (d z : Qpos) (x y: Q) (B: Qball (proj1_sig d / proj1_sig z) x y). Lemma Qball_Qmult_r: Qball (proj1_sig d) (x * proj1_sig z) (y * proj1_sig z). Proof. apply Qball_Qmult_Q_r. destruct z, x0, Qnum; simpl. exfalso. apply (Qlt_not_le _ _ q). simpl. apply (Qle_refl 0). exact B. exfalso. inversion q. Qed. Lemma Qball_Qmult_l: Qball (proj1_sig d) (proj1_sig z * x) (proj1_sig z * y). Proof. apply Qball_Qmult_Q_l. destruct z, x0, Qnum; simpl. exfalso. apply (Qlt_not_le _ _ q). simpl. apply (Qle_refl 0). exact B. exfalso. inversion q. Qed. End more_Qball_Qmult. Lemma Qball_plus (e d: Q) (x x' y y': Q): Qball e x x' -> Qball d y y' -> Qball (e + d) (x + y) (x' + y'). Proof with auto. intros. apply ball_triangle with (x' + y); apply Qball_Qabs. assert (Qeq (x + y - (x' + y)) (x - x')) by (simpl; ring). rewrite H1. clear H1. apply Qball_Qabs... assert (Qeq (x' + y - (x' + y')) (y - y')) by (simpl; ring). rewrite H1. apply Qball_Qabs... Qed. Lemma Qmult_AbsSmall : forall x y X Y : Q, QAbsSmall X x -> QAbsSmall Y y -> QAbsSmall (X*Y) (x*y). Proof. intros. apply AbsSmall_Qabs. rewrite Qabs_Qmult. apply (Qle_trans _ (X * Qabs y)). apply Qmult_le_compat_r. apply AbsSmall_Qabs in H. exact H. apply Qabs_nonneg. rewrite Qmult_comm, (Qmult_comm X). apply Qmult_le_compat_r. apply AbsSmall_Qabs in H0. exact H0. destruct H. apply (Qle_trans _ _ _ H) in H1. apply (Qplus_le_l _ _ X) in H1. ring_simplify in H1. apply (Qmult_le_l _ _ (2#1)). reflexivity. rewrite Qmult_0_r. exact H1. Qed. Lemma QAbsSmall_plus : forall e1 e2 x1 x2 : Q, QAbsSmall e1 x1 -> QAbsSmall e2 x2 -> QAbsSmall (e1+e2) (x1+x2). Proof. intros. pose proof (@Qball_plus e1 e2 x1 0 x2 0). unfold Qball, QAbsSmall, Qminus in H1. do 4 rewrite Qplus_0_r in H1. apply H1. exact H. exact H0. Qed. Lemma Qball_plus_r (e: Q) (x y y': Q): Qball e y y' -> Qball e (x + y) (x + y'). Proof with auto. intros B. apply Qball_Qabs. apply Qball_Qabs in B. assert (Qeq (x + y - (x + y')) (y - y')) by (simpl; ring). rewrite H. exact B. Qed. Lemma Qball_0_r (e: Qpos) : Qball (proj1_sig e) (proj1_sig e) 0. Proof with auto with qarith. apply Qball_Qabs. unfold Qminus. rewrite Qplus_0_r. rewrite Qabs_pos... Qed. Lemma Qball_0_l (e: Qpos) : Qball (proj1_sig e) 0 (proj1_sig e). Proof with auto with qarith. apply ball_sym. apply Qball_0_r. Qed. Lemma Qball_Qdiv_inv (d z: Qpos) (x y: Q): Qball (proj1_sig d / proj1_sig z) (x / proj1_sig z) (y / proj1_sig z) -> Qball (proj1_sig d) x y. Proof. intros. rewrite <- (Qmult_1_r x), <- (Qmult_1_r y), <- (Qmult_inv_r (proj1_sig z)), (Qmult_comm (proj1_sig z)), Qmult_assoc, Qmult_assoc... apply Qball_Qmult_r... auto. intro abs. destruct z. simpl in abs. clear H. rewrite abs in q. exact (Qlt_irrefl _ q). Qed. Lemma Qball_opp (e : Q) (x x' : Q): Qball e x x' -> Qball e (-x) (-x'). Proof with auto. intros. apply Qball_Qabs. unfold Qminus. rewrite Qopp_involutive. rewrite Qplus_comm. apply Qball_Qabs. apply ball_sym... Qed. From Coq Require Import Qround. Lemma Qfloor_ball q: Qball (1#2) ((Qfloor q # 1) + (1#2)) q. Proof with auto with *. intros. apply Qball_Qabs. simpl. apply Qabs_case; intros. apply Q.Qplus_le_l with ((-1#2)%Q + q). ring_simplify. apply Qfloor_le. pose proof (Qlt_floor q). apply (Qplus_le_l _ _ ((1#2) + (Qfloor q # 1))). ring_simplify. apply Qlt_le_weak. rewrite inject_Z_plus in H0. apply H0. Qed. (** A boolean version of Qball. *) Definition Qball_ex_bool (e:QposInf) (a b:Q) : bool := match ball_ex_dec _ Qmetric_dec e a b with left _ => true | right _ => false end. #[global] Instance: Proper (QposInfEq ==> @msp_eq _ ==> @msp_eq _ ==> eq) Qball_ex_bool. Proof. intros [ε1|] [ε2|] E1 x1 x2 E2 y1 y2 E3; try easy. unfold Qball_ex_bool. case (ball_ex_dec _ Qmetric_dec ε1 x1 y1); case (ball_ex_dec _ Qmetric_dec ε2 x2 y2); intros E4 E5; try easy. destruct E4. now eapply ball_wd; eauto; symmetry. destruct E5. now eapply ball_wd; eauto; symmetry. Qed. Lemma Qball_ex_bool_correct (ε : Qpos) x y : Is_true (Qball_ex_bool ε x y) <-> Qball (proj1_sig ε) x y. Proof. split; intros E. apply Is_true_eq_true in E. unfold Qball_ex_bool in E. destruct (ball_ex_dec Q_as_MetricSpace Qmetric_dec ε x y). apply b. discriminate. apply Is_true_eq_left. unfold Qball_ex_bool. destruct (ball_ex_dec Q_as_MetricSpace Qmetric_dec ε x y). reflexivity. contradiction. Qed. Lemma gball_Qabs (e a b : Q) : ball e a b <-> (Qabs (a - b) <= e). Proof. simpl. unfold Qball. rewrite <- AbsSmall_Qabs. reflexivity. Qed. Lemma Qball_0 : forall a b : Q, Qball 0 a b <-> Qeq a b. Proof. intros. split. - intros. apply Qle_antisym. + apply (Qplus_le_l _ _ (-b)). rewrite Qplus_opp_r. apply H. + rewrite Qle_minus_iff. apply H. - intros. rewrite H. apply Qball_Reflexive. discriminate. Qed. corn-8.20.0/model/monoids/000077500000000000000000000000001473720167500153265ustar00rootroot00000000000000corn-8.20.0/model/monoids/CRmonoid.v000066400000000000000000000043561473720167500172370ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRGroupOps. Require Export CoRN.model.semigroups.CRsemigroup. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.tactics.CornTac. Local Open Scope uc_scope. (** ** Examples of monoids: $\langle$#⟨#[CR],[+]$\rangle$#⟩# *** $\langle$#⟨#[CR],[+]$\rangle$#⟩# We use the addition [' 0] as the unit of monoid: *) Lemma CRisCMonoid : is_CMonoid CRasCSemiGroup 0%CR. Proof. split; intros x. change (x+0==x)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[+](CRasCauchy_IR 0%CR)); [| now apply: CR_plus_as_Cauchy_IR_plus]. stepl ((CRasCauchy_IR x)[+][0]); [| now apply: plus_resp_eq; apply: CR_inject_Q_as_Cauchy_IR_inject_Q]. apply cm_rht_unit. change (0+x==x)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR 0%CR)[+](CRasCauchy_IR x)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepl ([0][+](CRasCauchy_IR x)); [| now apply bin_op_is_wd_un_op_lft; apply: CR_inject_Q_as_Cauchy_IR_inject_Q]. apply cm_lft_unit. Qed. Definition CRasCMonoid : CMonoid := Build_CMonoid _ _ CRisCMonoid. Canonical Structure CRasCMonoid. corn-8.20.0/model/monoids/Nm_to_cycm.v000066400000000000000000000050631473720167500176100ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Import Lia. Require Export CoRN.algebra.CMonoids. Require Export CoRN.model.monoids.Nmonoid. Section p71E1. (** ** A function from the natural numbers to a cyclic monoid %\begin{convention}% Let [M:CMonoid], [c:M] and [is_generated_by: forall(m:M),{n:nat | (power_CMonoid c n)[=]m}]. %\end{convention}% *) Variable M:CMonoid. Variable c:M. Definition power_CMonoid_CSetoid: M-> nat_as_CSetoid -> M. Proof. simpl. exact (@power_CMonoid M). Defined. Variable is_generated_by: forall(m:M),{n:nat | (power_CMonoid c n)[=]m}. Let f:= fun (H:forall(m:M),{n:nat | (power_CMonoid c n)[=]m})=> fun (n:nat_as_CMonoid)=> power_CMonoid c n. Lemma f_strext: (fun_strext (f is_generated_by)). Proof. unfold fun_strext; simpl. induction x; destruct y. - intros ? ?. pose proof (ax_ap_irreflexive M (@cs_eq M) (@cs_ap M)) as H_irreflexive. unfold irreflexive, Not in H_irreflexive. elim H_irreflexive with (cm_unit M); auto using CSetoid_is_CSetoid. - firstorder lia. - firstorder lia. - unfold f. simpl. elim (@csg_op M). simpl. intros op op_strext H1. pose proof (op_strext c c (power_CMonoid c _) (power_CMonoid c _) H1) as [ H3 | ]. + destruct (ap_irreflexive_unfolded M c H3). + firstorder. Qed. Definition f_as_CSetoid_fun:= (Build_CSetoid_fun nat_as_CMonoid M (f is_generated_by) f_strext). Lemma surjective_f: (surjective f_as_CSetoid_fun). Proof. unfold surjective. simpl. intro b. elim (is_generated_by b). intros m H. exists m. unfold f. exact H. Qed. End p71E1. corn-8.20.0/model/monoids/Nm_to_freem.v000066400000000000000000000055451473720167500177600ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Import Lia. Require Export CoRN.algebra.CMonoids. Require Export CoRN.model.monoids.Nmonoid. Require Export CoRN.model.setoids.Nfinsetoid. Section p70text. (** ** A morphism from the natural numbers to the free setoid with one element *) Let A:= (CSetoid_of_less 1). (* begin hide *) Let ZerolessOne: 0<1. Proof. intuition. Qed. (* end hide *) Fixpoint to_word (n:nat):(list (F 1)):= match n with |0 => (@nil (F 1)) |(S m)=> (cons (Build_F 1 0 ZerolessOne)(to_word m)) end. Definition to_word_: nat_as_CMonoid -> (free_monoid_as_CMonoid A). Proof. simpl. unfold Astar. unfold A. intro n. unfold CSetoid_of_less. simpl. apply to_word. exact n. Defined. Hint Extern 10 => lia : core. Lemma to_word_strext: (fun_strext to_word_). Proof. unfold fun_strext; simpl. induction x; destruct y; firstorder with bool. Qed. Definition to_word_as_CSetoid_fun:= (Build_CSetoid_fun nat_as_CSetoid (free_csetoid_as_csetoid A) to_word_ to_word_strext). Lemma to_word_bijective: (bijective to_word_as_CSetoid_fun). Proof. unfold bijective. split. unfold injective. simpl. intros a0. induction a0. intro a1. case a1. unfold ap_nat. intuition. simpl. intuition. intro a1. case a1. simpl. intuition. intros n H. unfold ap_nat in H. simpl. right. apply IHa0. unfold ap_nat. intro H1. rewrite H1 in H. apply H. reflexivity. unfold surjective. simpl. unfold Astar. unfold A. intro b. induction b. exists 0. simpl. exact I. elim IHb. intros c H. exists (S c). split. simpl in a. elim a. simpl. intuition. exact H. Qed. Lemma pres_plus_to_word: forall (n m: nat_as_CMonoid),(to_word_ n)[+](to_word_ m)[=](to_word_ (n[+]m)). Proof. simpl. intros n m. induction n. simpl. apply eq_fm_reflexive. simpl. intuition. Qed. End p70text. corn-8.20.0/model/monoids/Nmonoid.v000066400000000000000000000044301473720167500171210ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.semigroups.Nsemigroup. Require Import CoRN.algebra.CMonoids. (** ** Example of a monoid: $\langle$#⟨#[nat],[[+]]$\rangle$#⟩# Zero is an unit for the addition. *) Lemma O_as_rht_unit : is_rht_unit (S:=nat_as_CSetoid) plus_is_bin_fun 0. Proof. red in |- *. simpl in |- *. intro x. symmetry in |- *. apply plus_n_O. Qed. Lemma O_as_lft_unit : is_lft_unit (S:=nat_as_CSetoid) plus_is_bin_fun 0. Proof. red in |- *. simpl in |- *. intro x. reflexivity. Qed. Definition nat_is_CMonoid := Build_is_CMonoid nat_as_CSemiGroup _ O_as_rht_unit O_as_lft_unit. (** Whence we can define ##%\emph{%the monoid of natural numbers%}%##: *) Definition nat_as_CMonoid := Build_CMonoid nat_as_CSemiGroup _ nat_is_CMonoid. Canonical Structure nat_as_CMonoid. Lemma SO_as_rht_unit : is_rht_unit (S:=nat_as_CSetoid) mult_as_bin_fun 1. Proof. red in |- *. simpl. auto with arith. Qed. Lemma SO_as_lft_unit : is_lft_unit (S:=nat_as_CSetoid) mult_as_bin_fun 1. Proof. red in |- *. simpl. auto with arith. Qed. Definition Nmult_is_CMonoid := Build_is_CMonoid Nmult_as_CSemiGroup _ SO_as_rht_unit SO_as_lft_unit. Definition Nmult_as_CMonoid := Build_CMonoid Nmult_as_CSemiGroup _ Nmult_is_CMonoid. corn-8.20.0/model/monoids/Nposmonoid.v000066400000000000000000000037531473720167500176520ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.semigroups.Npossemigroup. Require Import CoRN.algebra.CMonoids. (** ** Example of a monoid: $\langle$#⟨#[Npos],[[*]]$\rangle$#⟩# One is the right unit as well as the left unit of the multiplication on the positive natural numbers. *) Lemma rhtunitNpos : is_rht_unit Npos_mult ONEpos. Proof. unfold is_rht_unit in |- *. unfold Npos_mult in |- *. intro x. case x. simpl in |- *. intros scs_elem H. auto with arith. Qed. Lemma lftunitNpos : is_lft_unit Npos_mult ONEpos. Proof. unfold is_rht_unit in |- *. unfold Npos_mult in |- *. intro x. case x. simpl in |- *. intros scs_elem H. auto with arith. Qed. (** So, the positive natural numbers with multiplication form a CMonoid. *) Definition Nposmult_is_CMonoid := Build_is_CMonoid Nposmult_as_CSemiGroup ONEpos rhtunitNpos lftunitNpos. Definition Nposmult_as_CMonoid := Build_CMonoid Nposmult_as_CSemiGroup ONEpos Nposmult_is_CMonoid. corn-8.20.0/model/monoids/QSposmonoid.v000066400000000000000000000036761473720167500200040ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.semigroups.QSpossemigroup. Require Import CoRN.algebra.CMonoids. (** ** Example of a monoid: $\langle$#⟨#[Qpos],$(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2#$\rangle$#⟩# Two is the unit of the operation $(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2# on the positive rationals. So we have another monoid structure on the positive rational numbers. *) Lemma QTWOpos_is_rht_unit : is_rht_unit multdiv2 (2%positive:Qpos). Proof. intros x. simpl. autorewrite with QposElim. field. Qed. Lemma QTWOpos_is_lft_unit : is_lft_unit multdiv2 (2%positive:Qpos). Proof. intros x. simpl. autorewrite with QposElim. field. Qed. Definition Qpos_multdiv2_is_CMonoid := Build_is_CMonoid Qpos_multdiv2_as_CSemiGroup _ QTWOpos_is_rht_unit QTWOpos_is_lft_unit. Definition Qpos_multdiv2_as_CMonoid := Build_CMonoid Qpos_multdiv2_as_CSemiGroup _ Qpos_multdiv2_is_CMonoid. corn-8.20.0/model/monoids/Qmonoid.v000066400000000000000000000046321473720167500171300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.semigroups.Qsemigroup. Require Import CoRN.algebra.CMonoids. Local Open Scope Q_scope. (** ** Examples of a monoid: $\langle$#⟨#[Q],[[+]]$\rangle$#⟩# and $\langle$#⟨#[Q],[[*]]$\rangle$#⟩# *** $\langle$#⟨#[Q],[[+]]$\rangle$#⟩# The rational numbers form with addition a CMonoid. [QZERO] is the unit. *) Lemma ZEROQ_as_rht_unit3 : is_rht_unit (S:=Q_as_CSetoid) Qplus_is_bin_fun 0. Proof. repeat intro. apply Qplus_0_r. Qed. Lemma ZEROQ_as_lft_unit3 : is_lft_unit (S:=Q_as_CSetoid) Qplus_is_bin_fun 0. Proof. repeat intro. apply Qplus_0_l. Qed. Definition Q_is_CMonoid := Build_is_CMonoid Q_as_CSemiGroup _ ZEROQ_as_rht_unit3 ZEROQ_as_lft_unit3. Definition Q_as_CMonoid := Build_CMonoid Q_as_CSemiGroup _ Q_is_CMonoid. Canonical Structure Q_as_CMonoid. (** *** $\langle$#⟨#[Q],[[*]]$\rangle$#⟩# Also with multiplication Q forms a CMonoid. Here, the unit is [QONE]. *) Lemma ONEQ_as_rht_unit : is_rht_unit (S:=Q_as_CSetoid) Qmult_is_bin_fun 1. Proof. repeat intro. apply Qmult_1_r. Qed. Lemma ONEQ_as_lft_unit : is_lft_unit (S:=Q_as_CSetoid) Qmult_is_bin_fun 1. Proof. repeat intro. apply Qmult_1_l. Qed. Definition Q_mul_is_CMonoid := Build_is_CMonoid Q_mul_as_CSemiGroup _ ONEQ_as_rht_unit ONEQ_as_lft_unit. Definition Q_mul_as_CMonoid := Build_CMonoid Q_mul_as_CSemiGroup _ Q_mul_is_CMonoid. corn-8.20.0/model/monoids/Qposmonoid.v000066400000000000000000000035031473720167500176460ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.semigroups.Qpossemigroup. Require Import CoRN.algebra.CMonoids. (** ** Example of a monoid: $\langle$#⟨#[Qpos],[[*]]$\rangle$#⟩# One is the unit for multiplication on positive integers. Therefore the positive rational numbers together with the multiplication are a CMonoid. *) Lemma QONEpos_is_rht_unit : is_rht_unit Qpos_mult_is_bin_fun (1%positive:Qpos). Proof. intros x. simpl. ring. Qed. Lemma QONEpos_is_lft_unit : is_lft_unit Qpos_mult_is_bin_fun (1%positive:Qpos). Proof. intros x. simpl. ring. Qed. Definition Qpos_mult_is_CMonoid := Build_is_CMonoid Qpos_mult_as_CSemiGroup _ QONEpos_is_rht_unit QONEpos_is_lft_unit. Definition Qpos_mult_as_CMonoid := Build_CMonoid Qpos_mult_as_CSemiGroup _ Qpos_mult_is_CMonoid. corn-8.20.0/model/monoids/Zmonoid.v000066400000000000000000000055561473720167500171470ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.semigroups.Zsemigroup. Require Export CoRN.algebra.CMonoids. (** ** Examples of monoids: $\langle$#⟨#[Z],[[+]]$\rangle$#⟩# and $\langle$#⟨#[Z],[[*]]$\rangle$#⟩# *** $\langle$#⟨#[Z],[[+]]$\rangle$#⟩# We use the addition [ZERO] (defined in the standard library) as the unit of monoid: *) Lemma ZERO_as_rht_unit : is_rht_unit (S:=Z_as_CSetoid) Zplus_is_bin_fun 0%Z. Proof. red in |- *. simpl in |- *. intro x. apply Zplus_0_r. Qed. Lemma ZERO_as_lft_unit : is_lft_unit (S:=Z_as_CSetoid) Zplus_is_bin_fun 0%Z. Proof. red in |- *. simpl in |- *. reflexivity. Qed. Lemma is_unit_Z_0 :(is_unit Z_as_CSemiGroup 0%Z). Proof. unfold is_unit. intro a. simpl. split. reflexivity. intuition. Qed. Definition Z_is_CMonoid := Build_is_CMonoid Z_as_CSemiGroup _ ZERO_as_rht_unit ZERO_as_lft_unit. Definition Z_as_CMonoid := Build_CMonoid Z_as_CSemiGroup _ Z_is_CMonoid. Canonical Structure Z_as_CMonoid. (** The term [Z_as_CMonoid] is of type [CMonoid]. Hence we have proven that [Z] is a constructive monoid. *** $\langle$#⟨#[Z],[[*]]$\rangle$#⟩# As the multiplicative unit we should use [`1`], which is [(POS xH)] in the representation we have for integers. *) Lemma ONE_as_rht_unit : is_rht_unit (S:=Z_as_CSetoid) Zmult_is_bin_fun 1%Z. Proof. red in |- *. simpl in |- *. intro. apply Zmult_1_r. Qed. Lemma ONE_as_lft_unit : is_lft_unit (S:=Z_as_CSetoid) Zmult_is_bin_fun 1%Z. Proof. red in |- *. intro. eapply eq_transitive_unfolded. apply Zmult_is_commut. apply ONE_as_rht_unit. Qed. Definition Z_mul_is_CMonoid := Build_is_CMonoid Z_mul_as_CSemiGroup _ ONE_as_rht_unit ONE_as_lft_unit. Definition Z_mul_as_CMonoid := Build_CMonoid Z_mul_as_CSemiGroup _ Z_mul_is_CMonoid. (** The term [Z_mul_as_CMonoid] is another term of type [CMonoid]. *) corn-8.20.0/model/monoids/freem_to_Nm.v000066400000000000000000000040061473720167500177470ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CMonoids. Require Export CoRN.model.monoids.Nmonoid. Section p71E2. (** ** A morphism from a free monoid to the natural numbers %\begin{convention}% Let [A:CSetoid]. %\end{convention}% *) Variable A:CSetoid. Let L: (free_monoid_as_CMonoid A)-> nat_as_CMonoid. Proof. simpl. unfold Astar. intros l. exact (length l). Defined. Lemma L_strext: (fun_strext L). Proof. simpl. unfold fun_strext. simpl. unfold Astar. intros x. induction x. intro y. case y. simpl. unfold ap_nat. intuition. simpl. intuition. intro y. case y. simpl. intuition. simpl. intros c l H. right. apply IHx. unfold ap_nat in H |- *. intuition. Qed. Definition L_as_CSetoid_fun:= (Build_CSetoid_fun _ _ L L_strext). Lemma L_is_morphism: (morphism _ _ L_as_CSetoid_fun). Proof. unfold morphism. simpl. split. reflexivity. unfold Astar. intros a. induction a. simpl. reflexivity. simpl. intuition. Qed. End p71E2. corn-8.20.0/model/ordfields/000077500000000000000000000000001473720167500156315ustar00rootroot00000000000000corn-8.20.0/model/ordfields/CRordfield.v000066400000000000000000000074041473720167500200420ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRFieldOps. Require Export CoRN.model.fields.CRfield. Require Export CoRN.algebra.COrdFields. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.tactics.CornTac. Local Open Scope uc_scope. Lemma CRlt_strext : Crel_strext CRasCField CRltT. Proof. intros x1 x2 y1 y2 H. destruct (Ccsr_strext _ _ _ (CRasCauchy_IR x2) _ (CRasCauchy_IR y2) (CR_lt_as_Cauchy_IR_lt_1 _ _ H)) as[H0|H0]. left. apply CR_lt_as_Cauchy_IR_lt_2. assumption. right. destruct H0;[left|right]; apply CR_ap_as_Cauchy_IR_ap_2; assumption. Qed. Definition CRltasCCsetoidRelation : CCSetoid_relation CRasCField := Build_CCSetoid_relation _ _ CRlt_strext. Lemma CRisCOrdField : is_COrdField CRasCField CRltasCCsetoidRelation CRle (default_greater _ CRltasCCsetoidRelation) (default_grEq CRasCField CRle). Proof. split. split. intros x y z H0 H1. apply CR_lt_as_Cauchy_IR_lt_2. apply less_transitive_unfolded with (CRasCauchy_IR y); apply CR_lt_as_Cauchy_IR_lt_1; assumption. intros x y H0 H1. apply (less_antisymmetric_unfolded _ (CRasCauchy_IR x) (CRasCauchy_IR y)); apply CR_lt_as_Cauchy_IR_lt_1; assumption. intros x y H z. change (x+z < y + z)%CR. apply CR_lt_as_Cauchy_IR_lt_2. stepl ((CRasCauchy_IR x)[+](CRasCauchy_IR z)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepr ((CRasCauchy_IR y)[+](CRasCauchy_IR z)); [| now apply CR_plus_as_Cauchy_IR_plus]. apply plus_resp_less_rht. apply CR_lt_as_Cauchy_IR_lt_1. assumption. intros x y Hx Hy. change (0 < x*y)%CR. apply CR_lt_as_Cauchy_IR_lt_2. stepr ((CRasCauchy_IR x)[*](CRasCauchy_IR y)); [| now apply CR_mult_as_Cauchy_IR_mult]. eapply less_wdl;[|apply (CR_inject_Q_as_Cauchy_IR_inject_Q 0)]. apply mult_resp_pos;( eapply less_wdl;[|apply eq_symmetric;apply (CR_inject_Q_as_Cauchy_IR_inject_Q 0)]; apply CR_lt_as_Cauchy_IR_lt_1;assumption). intros x y. split. intros H. destruct (ap_imp_less _ _ _ (CR_ap_as_Cauchy_IR_ap_1 _ _ H));[left|right]; apply CR_lt_as_Cauchy_IR_lt_2; assumption. intros [H|H]; apply CR_ap_as_Cauchy_IR_ap_2; [apply less_imp_ap|apply Greater_imp_ap]; apply CR_lt_as_Cauchy_IR_lt_1;assumption. intros x y. rewrite <- CR_le_as_Cauchy_IR_le. split. intros H0 H1. apply H0. apply CR_lt_as_Cauchy_IR_lt_1. assumption. intros H0 H1. apply H0. apply CR_lt_as_Cauchy_IR_lt_2. assumption. intros x y. split; intros; assumption. reflexivity. Qed. Definition CRasCOrdField : COrdField := Build_COrdField _ _ _ _ _ CRisCOrdField. Canonical Structure CRasCOrdField. corn-8.20.0/model/ordfields/Qordfield.v000066400000000000000000000041041473720167500177300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.fields.Qfield. Require Import CoRN.algebra.COrdFields. Require Import CoRN.stdlib_omissions.Q. (** ** Example of an ordered field: $\langle$#⟨#[Q],[[+]],[[*]],[[<]]$\rangle$#⟩# [Q] is an archemaedian ordered field. *) Definition Qlt_is_strict_order := Build_strictorder Qlt_trans Qlt_is_antisymmetric_unfolded. Definition Q_is_COrdField := Build_is_COrdField Q_as_CField Qlt_is_CSetoid_relation Qle (default_greater Q_as_CField Qlt_is_CSetoid_relation) (default_grEq Q_as_CField Qle) Qlt_is_strict_order (fun x y E z => proj2 (Qplus_lt_l x y z) E) Qmult_lt_0_compat Qlt_gives_apartness Qle_is_not_lt Qgt_is_lt Qge_is_not_gt. Definition Q_as_COrdField := Build_COrdField _ _ _ _ _ Q_is_COrdField. Canonical Structure Q_as_COrdField. Theorem Q_is_archemaedian : forall x : Q_as_COrdField, {n : nat | x [<] nring n}. Proof. intros x. destruct (Q_is_archemaedian0 x) as [n Pn]. exists (nat_of_P n). simpl in *. rewrite nring_Q. rewrite <-Zpos_eq_Z_of_nat_o_nat_of_P. assumption. Qed. corn-8.20.0/model/partialorder/000077500000000000000000000000001473720167500163465ustar00rootroot00000000000000corn-8.20.0/model/partialorder/CRpartialorder.v000066400000000000000000000031071473720167500214530ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRGroupOps. Require Import CoRN.order.PartialOrder. (** ** Example of a Partial Order: *) Set Implicit Arguments. Definition CRmonotone := Default.monotone CRle. Definition CRantitone := Default.antitone CRle. Definition CRPartialOrder : PartialOrder := makePartialOrder (@msp_eq CR) CRle CRmonotone CRantitone CRle_antisym CRle_refl CRle_trans (Default.monotone_def _) (Default.antitone_def _). corn-8.20.0/model/reals/000077500000000000000000000000001473720167500147645ustar00rootroot00000000000000corn-8.20.0/model/reals/CRreal.v000066400000000000000000000165621473720167500163350ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.reals.fast.CRFieldOps. Require Export CoRN.model.ordfields.CRordfield. Require Export CoRN.reals.CReals. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.tactics.CornTac. Opaque CR. Local Open Scope uc_scope. (** ** Example of a real number structure: $\langle$#⟨#[CR]$\rangle$#⟩# *) Lemma CRAbsSmall_ball : forall (x y:CR) (e:Q), AbsSmall (R:=CRasCOrdField) (inject_Q_CR e) ((x:CRasCOrdField)[-]y) <-> ball e x y. Proof. intros x y e. split. - intros [H1 H2]. rewrite <- (doubleSpeed_Eq x). rewrite <- (doubleSpeed_Eq (doubleSpeed x)). rewrite <- (doubleSpeed_Eq y). rewrite <- (doubleSpeed_Eq (doubleSpeed y)). apply: regFunBall_e. intros d. assert (H1':=H1 d). assert (H2':=H2 d). clear H1 H2. simpl. set (x':=approximate x ((1#2)*((1#2)*d))%Qpos). set (y':=approximate y ((1#2)*((1#2)*d))%Qpos). change (-proj1_sig d <= x' - y' + - - e) in H1'. change (-proj1_sig d <= e + - (x' - y')) in H2'. rewrite -> Qle_minus_iff in *. apply: ball_weak. apply Qpos_nonneg. split; simpl; rewrite -> Qle_minus_iff. rewrite Qopp_involutive. do 2 rewrite Qopp_involutive in H1'. rewrite (Qplus_comm (proj1_sig d)). rewrite Qplus_assoc. exact H1'. rewrite <- Qplus_assoc, Qplus_comm. rewrite Qopp_involutive in H2'. exact H2'. - intros H. rewrite <- (doubleSpeed_Eq x) in H. rewrite <- (doubleSpeed_Eq y) in H. split; intros d; destruct (H ((1#2)*d)%Qpos ((1#2)*d)%Qpos) as [H1 H2]; clear H; set (x':=(approximate (doubleSpeed x) ((1 # 2) * d)%Qpos)) in *; set (y':=(approximate (doubleSpeed y) ((1 # 2) * d)%Qpos)) in *. autorewrite with QposElim in H1. change (- ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)<=x' - y') in H1. change (-proj1_sig d <= x' - y' + - - e). rewrite -> Qle_minus_iff. rewrite -> Qle_minus_iff in H1. replace RHS with (x' - y' + - - ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)) by ring. assumption. autorewrite with QposElim in H2. change (x' - y'<=((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)) in H2. change (-proj1_sig d <= e + - (x' - y')). rewrite -> Qle_minus_iff. rewrite -> Qle_minus_iff in H2. replace RHS with ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d + - (x' - y')) by ring. assumption. Qed. Lemma CRlt_Qlt : forall a b, (a < b)%Q -> ((' a%Q) < (' b))%CR. Proof. intros a b H. destruct (Qpos_sub _ _ H) as [c Hc]. exists c. intros d. change (-proj1_sig d <= b + - a + - proj1_sig c). rewrite -> Hc. rewrite -> Qle_minus_iff. ring_simplify. apply Qpos_nonneg. Qed. Definition CRlim (s:CauchySeq CRasCOrdField) : CR. Proof. revert s. intros [f Hf]. apply (ucFun (@Cjoin Q_as_MetricSpace)). exists (fun e:QposInf => match e with | QposInfinity => 0%CR | Qpos2QposInf e => let (n,_) := Hf (inject_Q_CR (proj1_sig e)) (CRlt_Qlt _ _ (Qpos_ispos e)) in f n end). abstract ( intros e1 e2; destruct (Hf (inject_Q_CR (proj1_sig e1)) (CRlt_Qlt _ _ (Qpos_ispos e1))) as [n1 Hn1]; destruct (Hf (inject_Q_CR (proj1_sig e2)) (CRlt_Qlt _ _ (Qpos_ispos e2))) as [n2 Hn2]; eapply ball_triangle;[apply ball_sym|];rewrite <- CRAbsSmall_ball; [apply Hn1;apply Nat.le_max_l| apply Hn2;apply Nat.le_max_r]) using Rlim_subproof0. Defined. Lemma CRisCReals : is_CReals CRasCOrdField CRlim. Proof. split. intros [f Hf] e [d Hed]. destruct (Hf _ (CRlt_Qlt _ _ (Qpos_ispos ((1#2)*d)%Qpos))) as [n Hn]. exists n. intros m Hm. apply AbsSmall_leEq_trans with (inject_Q_CR (proj1_sig d)); [rstepr (e[-][0]);assumption|]. rewrite -> CRAbsSmall_ball. change (nat -> Complete Q_as_MetricSpace) in f. change (ball (proj1_sig d) (f m) (CRlim (Build_CauchySeq CRasCOrdField f Hf))). rewrite <- (MonadLaw5 (f m)). change (ball (proj1_sig d) (Cjoin (Cunit (f m))) (CRlim (Build_CauchySeq CRasCOrdField f Hf))). unfold CRlim. apply uc_prf. change (ball (proj1_sig d) (Cunit (f m)) (Build_RegularFunction (Rlim_subproof0 f Hf))). intros e1 e2. simpl. destruct (Hf (' proj1_sig e2)%CR (CRlt_Qlt _ _ (Qpos_ispos e2))) as [a Ha]. change (ball (proj1_sig (e1+d+e2)%Qpos) (f m) (f a)). destruct (le_ge_dec a m). rewrite <- CRAbsSmall_ball. eapply AbsSmall_leEq_trans;[|apply Ha;assumption]. intros x. autorewrite with QposElim. change (-proj1_sig x <= proj1_sig e1 + proj1_sig d + proj1_sig e2 - proj1_sig e2). rewrite -> Qle_minus_iff. ring_simplify. change (0<= proj1_sig (e1+d+x)%Qpos). apply Qpos_nonneg. apply ball_weak_le with (proj1_sig ((1#2)*d+(1#2)*d)%Qpos). rewrite -> Qle_minus_iff. simpl. ring_simplify. change (0<= proj1_sig (e1+e2)%Qpos). apply Qpos_nonneg. apply ball_triangle with (f n);[|apply ball_sym]; rewrite <- CRAbsSmall_ball; apply Hn. auto. apply Nat.le_trans with m; auto. (*Archimedean*) intros x. assert (X:=(CR_b_upperBound (1#1) x)). destruct (CR_b (1 # 1) x) as [[n d] qpos]. destruct n as [|n|n]. inversion qpos. 2: inversion qpos. rewrite (anti_convert_pred_convert n) in X. exists (nat_of_P n)%nat. eapply leEq_transitive. apply X. clear X. intros z. simpl. unfold Cap_raw. simpl. apply Qle_trans with 0. rewrite -> Qle_minus_iff. ring_simplify. apply Qpos_nonneg. destruct (ZL4 n) as [a Ha]. rewrite Ha. clear Ha. simpl. unfold Cap_raw. simpl. rewrite <- Qle_minus_iff. remember ((1 # 2) * ((1 # 2) * z))%Qpos as q. simpl in Heqq. rewrite <- Heqq. clear Heqq. revert q. induction a; intro q. simpl. ring_simplify. unfold Qle. simpl. apply Zle_1_POS. simpl. unfold Cap_raw. simpl. rewrite -> Qle_minus_iff. rewrite <- Qplus_assoc. setoid_replace (1 + - (Pos.succ (Pos.of_succ_nat a) # d)) with (-((Pos.succ (Pos.of_succ_nat a) # d) - 1)) by ring. rewrite<- Qle_minus_iff. apply (Qle_trans _ (Pos.of_succ_nat a # d)). 2: apply IHa. generalize (P_of_succ_nat a). intros p. rewrite -> Qle_minus_iff. autorewrite with QposElim. replace RHS with (((p#d) + 1) + - (Pos.succ p # d)) by ring. rewrite <- Qle_minus_iff. unfold Qle. simpl. repeat rewrite Pmult_1_r. rewrite Pplus_one_succ_r. repeat rewrite Zpos_mult_morphism. apply Zmult_lt_0_le_compat_r. auto with *. repeat rewrite Zpos_plus_distr. auto with *. Qed. Definition CRasCReals : CReals := Build_CReals _ _ CRisCReals. Canonical Structure CRasCReals. corn-8.20.0/model/reals/Cauchy_IR.v000066400000000000000000000030011473720167500167530ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.ordfields.Qordfield. Require Export CoRN.reals.Cauchy_CReals. (** * Cauchy Real Numbers Earlier we defined a construction of a real number structure from an arbitrary archimedian ordered field. Plugging in [Q] we get the model of the real numbers as Cauchy sequences of rationals. *) Definition Cauchy_IR : CReals := R_as_CReals _ Q_is_archemaedian. (** The term [Cauchy_IR] is of type [CReals]. *) Close Scope Q_scope. corn-8.20.0/model/rings/000077500000000000000000000000001473720167500150005ustar00rootroot00000000000000corn-8.20.0/model/rings/CRring.v000066400000000000000000000112751473720167500163610ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRFieldOps. Require Export CoRN.model.abgroups.CRabgroup. Require Export CoRN.algebra.CRings. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.tactics.Rational. Require Import CoRN.tactics.CornTac. (** ** Example of a ring: $\langle$#⟨#[CR],[+],[*]$\rangle$#⟩# *) Local Open Scope uc_scope. Lemma CRmult_strext : bin_op_strext CRasCSetoid CRmult. Proof. intros x1 x2 y1 y2 H. simpl in *. autorewrite with CRtoCauchy_IR in H. assert (X:(CRasCauchy_IR x1[*]CRasCauchy_IR y1)[#](CRasCauchy_IR x2[*]CRasCauchy_IR y2)). stepl (CRasCauchy_IR (x1*y1)%CR); [| now apply eq_symmetric; apply CR_mult_as_Cauchy_IR_mult]. stepr (CRasCauchy_IR (x2*y2)%CR); [| now apply eq_symmetric; apply CR_mult_as_Cauchy_IR_mult]. apply CR_ap_as_Cauchy_IR_ap_1. assumption. destruct (bin_op_strext_unfolded _ _ _ _ _ _ X);[left|right]; apply CR_ap_as_Cauchy_IR_ap_2; assumption. Qed. Definition CRmultasBinOp : CSetoid_bin_op CRasCSetoid := Build_CSetoid_bin_fun _ _ _ _ CRmult_strext. Lemma CRmultAssoc : associative CRmultasBinOp. Proof. intros x y z. change (x*(y*z)==(x*y)*z)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[*](CRasCauchy_IR (y*z)%CR)); [| now apply CR_mult_as_Cauchy_IR_mult]. stepl ((CRasCauchy_IR x)[*]((CRasCauchy_IR y)[*](CRasCauchy_IR z))); [| now apply bin_op_is_wd_un_op_rht; apply CR_mult_as_Cauchy_IR_mult]. stepr ((CRasCauchy_IR (x*y)%CR)[*](CRasCauchy_IR z)); [| now apply CR_mult_as_Cauchy_IR_mult]. stepr (((CRasCauchy_IR x)[*](CRasCauchy_IR y))[*](CRasCauchy_IR z)); [| now apply bin_op_is_wd_un_op_lft; apply CR_mult_as_Cauchy_IR_mult]. apply mult_assoc_unfolded. Qed. Lemma CRisCRing : is_CRing CRasCAbGroup 1%CR CRmultasBinOp. Proof. apply Build_is_CRing with CRmultAssoc. split. intros x. change (x*1==x)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[*](CRasCauchy_IR (inject_Q_CR 1))); [| now apply CR_mult_as_Cauchy_IR_mult]. stepl ((CRasCauchy_IR x)[*][1]). rational. apply bin_op_is_wd_un_op_rht; apply: CR_inject_Q_as_Cauchy_IR_inject_Q. (* is_lft_unit csg_op 1%CR*) intros x. change ((inject_Q_CR 1%Q)*x==x)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR (inject_Q_CR 1))[*](CRasCauchy_IR x)); [| now apply CR_mult_as_Cauchy_IR_mult]. stepl ([1][*](CRasCauchy_IR x)); [| now apply bin_op_is_wd_un_op_lft; apply: CR_inject_Q_as_Cauchy_IR_inject_Q]. rational. intros x y. change (x*y==y*x)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[*](CRasCauchy_IR y)); [| now apply CR_mult_as_Cauchy_IR_mult]. stepr ((CRasCauchy_IR y)[*](CRasCauchy_IR x)); [| now apply CR_mult_as_Cauchy_IR_mult]. rational. intros x y z. change (x*(y+z)==x*y+x*z)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[*](CRasCauchy_IR (y+z)%CR)); [| now apply CR_mult_as_Cauchy_IR_mult]. stepl ((CRasCauchy_IR x)[*]((CRasCauchy_IR y)[+](CRasCauchy_IR z))); [| now apply bin_op_is_wd_un_op_rht; apply CR_plus_as_Cauchy_IR_plus]. stepr ((CRasCauchy_IR (x*y)%CR)[+](CRasCauchy_IR (x*z)%CR)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepr (((CRasCauchy_IR x)[*](CRasCauchy_IR y))[+]((CRasCauchy_IR x)[*](CRasCauchy_IR z))). apply dist. apply cs_bin_op_wd; apply CR_mult_as_Cauchy_IR_mult. change (CRapartT 1 0)%CR. apply CR_ap_as_Cauchy_IR_ap_2. eapply ap_wd. apply one_ap_zero. apply: CR_inject_Q_as_Cauchy_IR_inject_Q. apply: CR_inject_Q_as_Cauchy_IR_inject_Q. Qed. Definition CRasCRing : CRing := Build_CRing _ _ _ CRisCRing. Canonical Structure CRasCRing. corn-8.20.0/model/rings/Qring.v000066400000000000000000000070051473720167500162510ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.abgroups.Qabgroup. Require Import CoRN.algebra.CRings. Require Import CoRN.model.rings.Zring. Local Open Scope Q_scope. (** ** Example of a ring: $\langle$#⟨#[Q],[[+]],[[*]]$\rangle$#⟩# Because [Q] forms an abelian group with addition, a monoid with multiplication and it satisfies the distributive law, it is a ring. *) Lemma Q_mult_plus_is_dist : distributive Qmult_is_bin_fun Qplus_is_bin_fun. Proof. red in |- *. simpl in |- *. exact Qmult_plus_distr_r. Qed. Definition Q_is_CRing : is_CRing Q_as_CAbGroup 1 Qmult_is_bin_fun. Proof. apply Build_is_CRing with Qmult_is_assoc. apply Q_mul_is_CMonoid. apply Qmult_is_commut. apply Q_mult_plus_is_dist. apply Q_apart_0_1. Defined. Definition Q_as_CRing := Build_CRing _ _ _ Q_is_CRing. Canonical Structure Q_as_CRing. (** The following lemmas are used in the proof that [Q] is Archimeadian. *) Lemma injz_Nring : forall n, nring (R:=Q_as_CRing) n[=]inject_Z (nring (R:=Z_as_CRing) n). Proof. intro n. induction n as [| n Hrecn]. change (([0]:Q_as_CRing)[=][0]) in |- *. apply eq_reflexive_unfolded. change (nring (R:=Q_as_CRing) n[+][1][=]inject_Z (nring (R:=Z_as_CRing) n[+][1])) in |- *. Step_final ((inject_Z (nring (R:=Z_as_CRing) n):Q_as_CRing)[+][1]). astepl ((inject_Z (nring (R:=Z_as_CRing) n):Q_as_CRing)[+] inject_Z ([1]:Z_as_CRing)). apply eq_symmetric_unfolded. apply injz_plus. Qed. Lemma injZ_eq : forall x y : Z, x = y -> (inject_Z x:Q_as_CRing)[=]inject_Z y. Proof. intros. unfold inject_Z in |- *. simpl in |- *. red in |- *. simpl in |- *. rewrite H; trivial. Qed. Lemma nring_Q : forall n : nat, nring (R:=Q_as_CRing) n[=]inject_Z n. Proof. intro n. induction n as [| n Hrecn]. change (Qmake 0%Z 1%positive==Qmake 0%Z 1%positive) in |- *. change ([0][=]([0]:Q_as_CRing)) in |- *. apply eq_reflexive_unfolded. change (nring (R:=Q_as_CRing) n[+][1][=]inject_Z (S n)) in |- *. Step_final ((inject_Z n:Q_as_CRing)[+][1]). astepl ((inject_Z n:Q_as_CRing)[+]inject_Z 1). simpl in |- *. red in |- *. unfold Qplus in |- *. simpl in |- *. rewrite Zpos_mult_morphism in |- *. rewrite succ_nat in |- *. ring. Qed. Lemma zring_Q : forall z, zring (R:=Q_as_CRing) z[=]inject_Z z. Proof. destruct z; simpl; try reflexivity. rewrite -> pring_convert. rewrite -> nring_Q. now rewrite convert_is_POS. rewrite -> pring_convert. rewrite -> nring_Q. unfold Qeq. simpl. ring_simplify. rewrite min_convert_is_NEG. now rewrite Pmult_comm. Qed. corn-8.20.0/model/rings/Zring.v000066400000000000000000000034061473720167500162630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.abgroups.Zabgroup. Require Import CoRN.algebra.CRings. (** ** Example of a ring: $\langle$#⟨#[Z],[[+]],[[*]]$\rangle$#⟩# The multiplication and the addition are distributive. *) Lemma Z_mult_plus_is_dist : distributive Zmult_is_bin_fun Zplus_is_bin_fun. Proof. red in |- *. simpl in |- *. intros x y z. apply Zmult_plus_distr_r. Qed. Definition Z_is_CRing := Build_is_CRing Z_as_CAbGroup _ _ Zmult_is_assoc Z_mul_is_CMonoid Zmult_is_commut Z_mult_plus_is_dist ONE_neq_O. Definition Z_as_CRing := Build_CRing _ _ _ Z_is_CRing. (** The term [Z_as_CRing] is of type [CRing]. Hence we have proven that [Z] is a constructive ring. *) Canonical Structure Z_as_CRing. corn-8.20.0/model/semigroups/000077500000000000000000000000001473720167500160535ustar00rootroot00000000000000corn-8.20.0/model/semigroups/CRsemigroup.v000066400000000000000000000056011473720167500205030ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRGroupOps. Require Export CoRN.model.setoids.CRsetoid. Require Export CoRN.algebra.CGroups. Require Import CoRN.reals.fast.CRcorrect. Require Import CoRN.tactics.CornTac. (** ** Examples of semi-groups: $\langle$#⟨#[CR],[+]$\rangle$#⟩# *** $\langle$#⟨#[CR],[+]$\rangle$#⟩# *) Local Open Scope uc_scope. Lemma CRplus_strext : bin_op_strext CRasCSetoid (ucFun2 CRplus_uc). Proof. intros x1 x2 y1 y2 H. simpl in *. assert (X:(CRasCauchy_IR x1[+]CRasCauchy_IR y1)[#](CRasCauchy_IR x2[+]CRasCauchy_IR y2)). stepl (CRasCauchy_IR (x1+y1)%CR); [| apply eq_symmetric; apply CR_plus_as_Cauchy_IR_plus]. stepr (CRasCauchy_IR (x2+y2)%CR); [| now apply eq_symmetric; apply CR_plus_as_Cauchy_IR_plus]. apply CR_ap_as_Cauchy_IR_ap_1. assumption. destruct (bin_op_strext_unfolded _ _ _ _ _ _ X);[left|right]; apply CR_ap_as_Cauchy_IR_ap_2; assumption. Qed. Definition CRplusasBinOp : CSetoid_bin_op CRasCSetoid := Build_CSetoid_bin_fun _ _ _ _ CRplus_strext. Lemma CRisCSemiGroup : is_CSemiGroup _ CRplusasBinOp. Proof. intros x y z. change (x + (y+z)==(x+y)+z)%CR. rewrite <- CR_eq_as_Cauchy_IR_eq. stepl ((CRasCauchy_IR x)[+](CRasCauchy_IR (y+z)%CR)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepl ((CRasCauchy_IR x)[+]((CRasCauchy_IR y)[+](CRasCauchy_IR z))); [| now apply plus_resp_eq; apply CR_plus_as_Cauchy_IR_plus]. stepr ((CRasCauchy_IR (x+y)%CR)[+](CRasCauchy_IR z)); [| now apply CR_plus_as_Cauchy_IR_plus]. stepr (((CRasCauchy_IR x)[+](CRasCauchy_IR y))[+](CRasCauchy_IR z)); [| now apply bin_op_is_wd_un_op_lft; apply CR_plus_as_Cauchy_IR_plus]. apply plus_assoc_unfolded. Qed. Definition CRasCSemiGroup : CSemiGroup := Build_CSemiGroup _ _ CRisCSemiGroup. Canonical Structure CRasCSemiGroup. corn-8.20.0/model/semigroups/Npossemigroup.v000066400000000000000000000041301473720167500211120ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CSemiGroups. Require Import CoRN.model.semigroups.Nsemigroup. Require Export CoRN.model.setoids.Npossetoid. (** ** Examples of semi-groups: $\langle$#⟨#[Npos],[[+]]$\rangle$#⟩# and $\langle$#⟨#[Npos],[[*]]$\rangle$#⟩# *** $\langle$#⟨#[Npos],[[+]]$\rangle$#⟩# The positive natural numbers form together with addition a subsemigroup of the semigroup of the natural numbers with addition. *) Definition Npos_as_CSemiGroup := Build_SubCSemiGroup nat_as_CSemiGroup NposP plus_resp_Npos. (** *** $\langle$#⟨#[Npos],[[*]]$\rangle$#⟩# Also together with multiplication, the positive numbers form a semigroup. *) Lemma Nposmult_is_CSemiGroup : is_CSemiGroup Npos Npos_mult. Proof. unfold is_CSemiGroup in |- *. unfold associative in |- *. unfold Npos_mult in |- *. simpl in |- *. intros x y z. case x. case y. case z. simpl in |- *. intros a pa b pb c pc. auto with arith. Qed. Definition Nposmult_as_CSemiGroup := Build_CSemiGroup Npos Npos_mult Nposmult_is_CSemiGroup. corn-8.20.0/model/semigroups/Nsemigroup.v000066400000000000000000000033561473720167500204010ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Nsetoid. Require Import CoRN.algebra.CSemiGroups. (** ** Example of a semi-group: $\langle$#⟨#[nat],[[+]]$\rangle$#⟩# *) (** Because addition is associative, the natural numbers form a CSemiGroup. *) Definition nat_as_CSemiGroup := Build_CSemiGroup _ plus_is_bin_fun plus_is_assoc. Canonical Structure nat_as_CSemiGroup. Lemma Nmult_is_CSemiGroup : is_CSemiGroup nat_as_CSetoid mult_as_bin_fun. Proof. unfold is_CSemiGroup in |- *. unfold associative in |- *. unfold mult_as_bin_fun in |- *. simpl in |- *. auto with arith. Qed. Definition Nmult_as_CSemiGroup := Build_CSemiGroup nat_as_CSetoid mult_as_bin_fun Nmult_is_CSemiGroup. corn-8.20.0/model/semigroups/QSpossemigroup.v000066400000000000000000000027211473720167500212440ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Qpossetoid. Require Import CoRN.algebra.CSemiGroups. (** ** Example of a semi-group: $\langle$#⟨#[Qpos],$(x,y) \mapsto xy/2$#(x,y) ↦ xy/2#$\rangle$#⟩# The positive rationals form with the operation $(x,y) \mapsto xy/2$#(x,y) ↦ xy/2# a CSemiGroup. *) Definition Qpos_multdiv2_as_CSemiGroup := Build_CSemiGroup _ multdiv2 associative_multdiv2. corn-8.20.0/model/semigroups/Qpossemigroup.v000066400000000000000000000026371473720167500211270ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Qpossetoid. Require Export CoRN.algebra.CSemiGroups. (** ** Example of a semi-group: $\langle$#⟨#[Qpos],[[*]]$\rangle$#⟩# The positive rationals form with the multiplication a CSemiGroup. *) Definition Qpos_mult_as_CSemiGroup := Build_CSemiGroup Qpos_as_CSetoid Qpos_mult_is_bin_fun associative_Qpos_mult. corn-8.20.0/model/semigroups/Qsemigroup.v000066400000000000000000000031121473720167500203720ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Qsetoid. Require Import CoRN.algebra.CSemiGroups. (** ** Examples of semi-groups: $\langle$#⟨#[Q],[[+]]$\rangle$#⟩# and $\langle$#⟨#[Q],[[*]]$\rangle$#⟩# *** $\langle$#⟨#[Q],[[+]]$\rangle$#⟩# *) Definition Q_as_CSemiGroup := Build_CSemiGroup _ Qplus_is_bin_fun Qplus_is_assoc. Canonical Structure Q_as_CSemiGroup. (** *** $\langle$#⟨#[Q],[[*]]$\rangle$#⟩# *) Definition Q_mul_as_CSemiGroup := Build_CSemiGroup _ Qmult_is_bin_fun Qmult_is_assoc. corn-8.20.0/model/semigroups/Zsemigroup.v000066400000000000000000000037201473720167500204100ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Zsetoid. Require Export CoRN.algebra.CSemiGroups. (** ** Examples of semi-groups: $\langle$#⟨#[Z],[[+]]$\rangle$#⟩# and $\langle$#⟨#[Z],[[*]]$\rangle$#⟩# *** $\langle$#⟨#[Z],[[+]]$\rangle$#⟩# *) Lemma Zplus_is_CSemiGroup: (is_CSemiGroup Z_as_CSetoid Zplus_is_bin_fun). Proof. unfold is_CSemiGroup. exact Zplus_is_assoc. Qed. Definition Z_as_CSemiGroup := Build_CSemiGroup _ Zplus_is_bin_fun Zplus_is_assoc. Canonical Structure Z_as_CSemiGroup. (** The term [Z_as_CSemiGroup] is of type [CSemiGroup]. Hence we have proven that [Z] is a constructive semi-group. *) (** *** $\langle$#⟨#[Z],[[*]]$\rangle$#⟩# *) Lemma Zmult_is_CSemiGroup: (is_CSemiGroup Z_as_CSetoid Zmult_is_bin_fun). Proof. unfold is_CSemiGroup. exact Zmult_is_assoc. Qed. Definition Z_mul_as_CSemiGroup := Build_CSemiGroup _ Zmult_is_bin_fun Zmult_is_assoc. corn-8.20.0/model/setoids/000077500000000000000000000000001473720167500153305ustar00rootroot00000000000000corn-8.20.0/model/setoids/CRsetoid.v000066400000000000000000000044671473720167500172460ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.fast.CRcorrect. Require Export CoRN.model.metric2.CRmetric. Require Export CoRN.algebra.CSetoids. Require Import CoRN.tactics.CornTac. #[global] Instance CR_default : @DefaultRelation CR (@msp_eq CR) | 2 := {}. (** ** Example of a setoid: [CR] *** [CR] *) Lemma CRisCSetoid : is_CSetoid CR (@msp_eq CR) CRapartT. Proof. split;simpl. intros x H. eapply ap_irreflexive. apply CR_ap_as_Cauchy_IR_ap_1. apply H. intros x y H. apply CR_ap_as_Cauchy_IR_ap_2. eapply ap_symmetric. apply CR_ap_as_Cauchy_IR_ap_1. apply H. intros x y H1 z. destruct (ap_cotransitive _ _ _ (CR_ap_as_Cauchy_IR_ap_1 _ _ H1) (CRasCauchy_IR z));[left|right]; apply CR_ap_as_Cauchy_IR_ap_2; assumption. intros x y. change (Not (CRapartT x y)<->(x==y)%CR). rewrite <- CR_eq_as_Cauchy_IR_eq. destruct (ap_tight _ (CRasCauchy_IR x) (CRasCauchy_IR y)) as [A B]. split. intros H. apply A. intros X. apply H. apply CR_ap_as_Cauchy_IR_ap_2. assumption. intros H X. apply (B H). apply CR_ap_as_Cauchy_IR_ap_1. apply X. Qed. Definition CRasCSetoid : CSetoid := makeCSetoid (msp_as_RSetoid CR) _ CRisCSetoid. Canonical Structure CRasCSetoid. corn-8.20.0/model/setoids/Nfinsetoid.v000066400000000000000000000052551473720167500176300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Import CoRN.algebra.CSetoids. (** ** Setoids of the first [n] natural numbers *) Record F (n:nat):Set:= {F_crr:> nat ; F_prf: F_crr F n -> Prop. Proof. intros a b. case a. case b. intros x H x0 H0. exact (x = x0). Defined. Definition Fap (n : nat) : F n -> F n -> CProp. Proof. intros a b. case a. case b. intros x H x0 H0. exact (x <> x0). Defined. Lemma Fap_irreflexive : forall n : nat, irreflexive (Fap n). Proof. unfold irreflexive in |- *. unfold Fap in |- *. intros n x. case x. intuition. red in |- *. intuition. Qed. Lemma Fap_symmetric : forall n : nat, Csymmetric (Fap n). Proof. intro n. unfold Csymmetric in |- *. unfold Fap in |- *. intros x y. case x. case y. intuition. Qed. Lemma Fap_cotransitive : forall n : nat, cotransitive (Fap n). Proof. intro n. unfold cotransitive in |- *. unfold Fap in |- *. intros x y. case x. case y. intros x0 H0 x1 H1 H2 z. case z. intros x2 H. set (H5 := eq_nat_dec x2 x1) in *. elim H5. clear H5. intro H5. right. rewrite H5. exact H2. clear H5. intro H5. left. exact H5. Qed. Lemma Fap_tight : forall n : nat, tight_apart (Feq n) (Fap n). Proof. unfold tight_apart in |- *. unfold Fap in |- *. unfold Feq in |- *. intros n x y. case x. case y. intros x0 H0 x1 H1. red in |- *. unfold not in |- *. unfold Not in |- *. intuition. Qed. Definition less (n : nat) := Build_is_CSetoid (F n) (Feq n) (Fap n) (Fap_irreflexive n) (Fap_symmetric n) (Fap_cotransitive n) (Fap_tight n). Definition CSetoid_of_less (n : nat) : CSetoid := Build_CSetoid (F n) (Feq n) (Fap n) (less n). corn-8.20.0/model/setoids/Npossetoid.v000066400000000000000000000056041473720167500176530ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Nsetoid. Require Export CoRN.model.structures.Npossec. Require Import CoRN.algebra.CSetoidFun. From Coq Require Import Lia. (** ** Example of a setoid: [Npos] *** Setoid The positive natural numbers [Npos] will be defined as a subsetoid of the natural numbers. *) Definition Npos := Build_SubCSetoid nat_as_CSetoid (fun n : nat => n <> 0). Definition NposP := (fun n : nat_as_CSetoid => n <> 0). (** One and two are elements of it. *) Definition ONEpos := Build_subcsetoid_crr _ NposP 1 (S_O 0). Definition TWOpos := Build_subcsetoid_crr _ NposP 2 (S_O 1). (** *** Addition and multiplication Because addition and multiplication preserve positivity, we can define them on this subsetoid. *) Lemma plus_resp_Npos : bin_op_pres_pred _ NposP plus_is_bin_fun. Proof. unfold bin_op_pres_pred in |- *. simpl in |- *. apply plus_resp_Npos0. Qed. Definition Npos_plus := Build_SubCSetoid_bin_op _ _ plus_is_bin_fun plus_resp_Npos. Lemma mult_resp_Npos : bin_op_pres_pred _ NposP mult_as_bin_fun. Proof. intros x y H H0. unfold mult_as_bin_fun, NposP in |- *. apply mult_resp_Npos0; auto. Qed. Definition Npos_mult := Build_SubCSetoid_bin_op _ _ mult_as_bin_fun mult_resp_Npos. (** The addition has no right unit on this set. *) Lemma no_rht_unit_Npos1 : forall y : Npos, ~ (forall x : Npos, Npos_plus x y[=]x). Proof. intro y. case y. intros scs_elem scs_prf. cut ((1+scs_elem) <> 1). intros H. red in |- *. intros H0. apply H. unfold not in H. generalize (H0 (Build_subcsetoid_crr nat_as_CSetoid NposP 1 (S_O 0))). simpl in |- *. intuition. auto. Qed. (** And the multiplication doesn't have an inverse, because there can't be an inverse for 2. *) Lemma no_inverse_Nposmult1 : forall n : Npos, ~ (Npos_mult TWOpos n[=]ONEpos). Proof. intro n. case n. simpl in |- *. intros. lia. Qed. corn-8.20.0/model/setoids/Nsetoid.v000066400000000000000000000127211473720167500171270ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.structures.Nsec. Require Import CoRN.algebra.CSetoidFun. (** ** Example of a setoid: [nat] We will show that the natural numbers form a CSetoid. *) Lemma ap_nat_irreflexive : irreflexive (A:=nat) ap_nat. Proof. red in |- *. apply ap_nat_irreflexive0. Qed. Lemma ap_nat_symmetric : Csymmetric ap_nat. Proof. red in |- *. apply ap_nat_symmetric0. Qed. Lemma ap_nat_cotransitive : cotransitive (A:=nat) ap_nat. Proof. red in |- *. apply ap_nat_cotransitive0. Qed. Lemma ap_nat_tight : tight_apart (A:=nat) (eq (A:=nat)) ap_nat. Proof. red in |- *. apply ap_nat_tight0. Qed. Definition ap_nat_is_apartness := Build_is_CSetoid nat (eq (A:=nat)) ap_nat ap_nat_irreflexive ap_nat_symmetric ap_nat_cotransitive ap_nat_tight. Definition nat_as_CSetoid := Build_CSetoid _ _ _ ap_nat_is_apartness. Canonical Structure nat_as_CSetoid. (** *** Addition *) Lemma plus_wd : bin_fun_wd nat_as_CSetoid nat_as_CSetoid nat_as_CSetoid plus. Proof. red in |- *. simpl in |- *. auto. Qed. Lemma plus_strext : bin_fun_strext nat_as_CSetoid nat_as_CSetoid nat_as_CSetoid plus. Proof. red in |- *. simpl in |- *. apply plus_strext0. Qed. Definition plus_is_bin_fun := Build_CSetoid_bin_fun _ _ _ _ plus_strext. Canonical Structure plus_is_bin_fun. (** It is associative and commutative. *) Lemma plus_is_assoc : associative plus_is_bin_fun. Proof. red in |- *. intros x y z. simpl in |- *. apply Nat.add_assoc. Qed. Lemma plus_is_commut : commutes plus_is_bin_fun. Proof. red in |- *. simpl in |- *. intros x y. exact (Nat.add_comm x y). Qed. (** *** Multiplication *) Lemma mult_strext : bin_fun_strext nat_as_CSetoid nat_as_CSetoid nat_as_CSetoid mult. Proof. red in |- *. simpl in |- *. apply mult_strext0. Qed. Definition mult_as_bin_fun := Build_CSetoid_bin_fun _ _ _ _ mult_strext. Canonical Structure mult_as_bin_fun. (** *** Ternary addition *) Definition plus1 (n:nat)(m:nat): (n_ary_operation 1 nat_as_CSetoid). Proof. simpl. apply (projected_bin_fun _ _ _ plus_is_bin_fun (plus_is_bin_fun n m)). Defined. Lemma to_plus1_strext:forall (n:nat), fun_strext (S1:=nat_as_CSetoid) (S2:=FS_as_CSetoid nat_as_CSetoid nat_as_CSetoid) (fun m : nat => plus1 n m). Proof. intro n. unfold plus1. unfold fun_strext. simpl. intros x y H. unfold ap_fun in H. simpl in H. elim H. clear H. intros a H. set (H1:= plus_strext). unfold bin_fun_strext in H1. cut ((n+x{#N}n + y) or (a{#N}a)). intro H2. elim H2. intro H3. cut ((n{#N}n) or (x{#N}y)). intro H4. elim H4. set (H5:=(ap_nat_irreflexive n)). intro H6. set (H7:= (H5 H6)). contradiction. intro H5. exact H5. apply H1. exact H3. intro H3. set (H5:=(ap_nat_irreflexive a)). set (H7:= (H5 H3)). contradiction. apply H1. exact H. Qed. Definition plus2 (n:nat): (n_ary_operation 2 nat_as_CSetoid). Proof. simpl. apply Build_CSetoid_fun with (fun m => (plus1 n m)). apply to_plus1_strext. Defined. Lemma to_plus2_strext:fun_strext (S1:=nat_as_CSetoid) (S2:=FS_as_CSetoid nat_as_CSetoid (FS_as_CSetoid nat_as_CSetoid nat_as_CSetoid)) (fun m : nat => plus2 m). Proof. unfold fun_strext. intros x y. simpl. unfold ap_fun. simpl. intro H. elim H. clear H. unfold ap_fun. intros a H. elim H. clear H. intros a0 H. unfold plus1 in H. simpl in H. set (H1:= (plus_strext)). unfold bin_fun_strext in H1. cut (((x+a){#N}(y+a)) or (a0 {#N} a0)). intro H2. elim H2. clear H2. intro H2. set (H3:=(H1 x y a a H2)). simpl in H3. elim H3. clear H3. intro H3. exact H3. clear H3. intro H3. set (H5:=(ap_nat_irreflexive a)). set (H7:= (H5 H3)). contradiction. set (H5:=(ap_nat_irreflexive a0)). intro H6. set (H7:= (H5 H6)). contradiction. apply H1. exact H. Qed. Definition plus3 :(n_ary_operation 3 nat_as_CSetoid). Proof. simpl. apply Build_CSetoid_fun with (fun m => (plus2 m )). apply to_plus2_strext. Defined. Definition on: nat_as_CSetoid -> nat_as_CSetoid -> nat_as_CSetoid -> (n_ary_operation 3 nat_as_CSetoid)-> nat_as_CSetoid. Proof. intros n m k p. unfold n_ary_operation in p. simpl in p. elim p. clear p. intros pfun0 prf0. set (pfun1 := (pfun0 n)). elim pfun1. clear pfun1. intros pfun1 prf1. set (pfun2:= (pfun1 m)). elim pfun2. clear pfun2. intros pfun2 prf2. set (pfun3:= (pfun2 k)). exact pfun3. Defined. #[local] Lemma ex_3_ary: (on 3 5 7 plus3)[=] 3+5+7. Proof. simpl. reflexivity. Qed. corn-8.20.0/model/setoids/Qpossetoid.v000066400000000000000000000102661473720167500176560ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.setoids.Qsetoid. Require Import CoRN.algebra.CSetoidFun. Require Export CoRN.model.structures.Qpossec. (** ** Example of a setoid: [Qpos] *** Setoid We will examine the subsetoid of positive rationals of the setoid of rational numbers. *) Lemma ap_Qpos_irreflexive1 : irreflexive (A:=Qpos) Qap. Proof. red in |- *. firstorder using ap_Q_irreflexive0. Qed. Lemma ap_Qpos_symmetric1 : Csymmetric (A:=Qpos) Qap. Proof. red in |- *. firstorder using ap_Q_symmetric0. Qed. Lemma ap_Qpos_cotransitive1 : cotransitive (A:=Qpos) Qap. Proof. red in |- *. intros; apply ap_Q_cotransitive0; auto. Qed. Lemma ap_Qpos_tight1 : tight_apart (A:=Qpos) Qeq Qap. Proof. red in |- *. firstorder using ap_Q_tight0. Qed. Definition ap_Qpos_is_apartness := Build_is_CSetoid _ _ _ ap_Qpos_irreflexive1 ap_Qpos_symmetric1 ap_Qpos_cotransitive1 ap_Qpos_tight1. Definition Qpos_as_CSetoid := Build_CSetoid _ _ _ ap_Qpos_is_apartness. Canonical Structure Qpos_as_CSetoid. Canonical Structure Qpos_as_Setoid := (cs_crr Qpos_as_CSetoid). Lemma Qpos_plus_strext : bin_fun_strext Qpos_as_CSetoid Qpos_as_CSetoid Qpos_as_CSetoid Qpos_plus. Proof. red in |- *. simpl in |- *. intros x1 x2 y1 y2 H. destruct (Qeq_dec x1 x2)as [A|A];[|tauto]. right. autorewrite with QposElim in H. intros B. apply H. rewrite -> A. rewrite -> B. reflexivity. Qed. Definition Qpos_plus_is_bin_fun := Build_CSetoid_bin_fun _ _ _ _ Qpos_plus_strext. Canonical Structure Qpos_plus_is_bin_fun. Lemma associative_Qpos_plus : associative Qpos_plus. Proof. unfold associative in |- *. intros x y z. simpl. autorewrite with QposElim. apply Qplus_is_assoc. Qed. (** *** Multiplication *) Lemma Qpos_mult_strext : bin_op_strext Qpos_as_CSetoid Qpos_mult. Proof. red in |- *. intros x1 x2 y1 y2 H. simpl in *. destruct (Qeq_dec x1 x2)as [A|A];[|tauto]. right. autorewrite with QposElim in H. intros B. apply H. rewrite -> A. rewrite -> B. reflexivity. Qed. Definition Qpos_mult_is_bin_fun : CSetoid_bin_op Qpos_as_CSetoid := Build_CSetoid_bin_fun _ _ _ _ Qpos_mult_strext. Canonical Structure Qpos_mult_is_bin_fun. Lemma associative_Qpos_mult : associative Qpos_mult. Proof. unfold associative in |- *. intros x y z. simpl. autorewrite with QposElim. apply Qmult_is_assoc. Qed. (** *** Inverse *) Lemma Qpos_inv_strext : fun_strext Qpos_inv. Proof. unfold fun_strext in |- *. firstorder using Qpos_inv_wd. Qed. Definition Qpos_inv_op := Build_CSetoid_un_op _ _ Qpos_inv_strext. Canonical Structure Qpos_inv_op. (** *** Special multiplication and inverse We define [multdiv2]: $(x,y) \mapsto xy/2$ #(x,y) ↦ xy/2#. *) Definition Qpos_div2 := projected_bin_fun _ _ _ Qpos_mult_is_bin_fun (Qpos_inv_op (2%positive : Qpos)). Definition multdiv2 := compose_CSetoid_un_bin_fun _ _ _ Qpos_mult_is_bin_fun Qpos_div2. Lemma associative_multdiv2 : associative multdiv2. Proof. unfold associative in |- *. intros x y z. simpl. QposRing. Qed. (** And its inverse [multdiv4]: $x \mapsto 4/x$ #x ↦ 4/x#. *) Definition mult4 := projected_bin_fun _ _ _ Qpos_mult_is_bin_fun (4%positive:Qpos). Definition divmult4 := compose_CSetoid_fun _ _ _ Qpos_inv_op mult4. corn-8.20.0/model/setoids/Qsetoid.v000066400000000000000000000072601473720167500171340ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.structures.Qsec. Require Import CoRN.algebra.CSetoidFun. (** ** Example of a setoid: [Q] *** Setoid *) Lemma ap_Q_irreflexive1 : irreflexive (A:=Q) Qap. Proof. red in |- *. apply ap_Q_irreflexive0. Qed. Lemma ap_Q_symmetric1 : Csymmetric Qap. Proof. red in |- *. apply ap_Q_symmetric0. Qed. Lemma ap_Q_cotransitive1 : cotransitive (A:=Q) Qap. Proof. red in |- *. apply ap_Q_cotransitive0. Qed. Lemma ap_Q_tight1 : tight_apart (A:=Q) Qeq Qap. Proof. red in |- *. apply ap_Q_tight0. Qed. Definition ap_Q_is_apartness := Build_is_CSetoid Q Qeq Qap ap_Q_irreflexive1 ap_Q_symmetric1 ap_Q_cotransitive1 ap_Q_tight1. Definition Q_as_CSetoid := Build_CSetoid _ _ _ ap_Q_is_apartness. Canonical Structure Q_as_CSetoid. Canonical Structure Q_is_Setoid := (cs_crr Q_as_CSetoid). (** *** Addition *) Lemma Qplus_wd : bin_fun_wd Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qplus. Proof. repeat intro. apply Qplus_comp; trivial. Qed. Lemma Qplus_strext1 : bin_fun_strext Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qplus. Proof. repeat intro. apply Qplus_strext0; trivial. Qed. Definition Qplus_is_bin_fun := Build_CSetoid_bin_fun _ _ _ _ Qplus_strext1. (* Canonical Structure Qplus_is_bin_fun. *) (** It is associative and commutative. *) Lemma Qplus_is_assoc : associative Qplus_is_bin_fun. Proof Qplus_assoc. Lemma Qplus_is_commut1 : commutes Qplus_is_bin_fun. Proof Qplus_comm. (** *** Opposite *) Lemma Qopp_wd : fun_wd (S1:=Q_as_CSetoid) (S2:=Q_as_CSetoid) Qopp. Proof. repeat intro. apply Qopp_comp; trivial. Qed. Lemma Qopp_strext : fun_strext (S1:=Q_as_CSetoid) (S2:=Q_as_CSetoid) Qopp. Proof. firstorder using Qopp_comp. Qed. Definition Qopp_is_fun := Build_CSetoid_fun _ _ _ Qopp_strext. (* Canonical Structure Qopp_is_fun. *) (** *** Multiplication *) Lemma Qmult_wd : bin_fun_wd Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qmult. Proof. repeat intro. apply Qmult_comp; trivial. Qed. Lemma Qmult_strext1 : bin_fun_strext Q_as_CSetoid Q_as_CSetoid Q_as_CSetoid Qmult. Proof. repeat intro. apply Qmult_strext0; trivial. Qed. Definition Qmult_is_bin_fun := Build_CSetoid_bin_fun _ _ _ _ Qmult_strext1. (* Canonical Structure Qmult_is_bin_fun. *) (** It is associative and commutative. *) Lemma Qmult_is_assoc : associative Qmult_is_bin_fun. Proof. repeat intro. apply Qmult_assoc. Qed. Lemma Qmult_is_commut : commutes Qmult_is_bin_fun. Proof. repeat intro. apply Qmult_comm. Qed. (** *** Less-than *) Lemma Qlt_strext : Crel_strext Q_as_CSetoid Qlt. Proof. red in |- *. apply Qlt_strext_unfolded. Qed. Definition Qlt_is_CSetoid_relation := Build_CCSetoid_relation _ _ Qlt_strext. Canonical Structure Qlt_is_CSetoid_relation. corn-8.20.0/model/setoids/Zfinsetoid.v000066400000000000000000000054371473720167500176460ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) From Coq Require Export ZArith. Require Import CoRN.algebra.CSetoids. (** ** Setoids of the integers between 0 and [z] *) Record ZF (n:Z):Set:= {ZF_crr:> Z ; ZF_prf0: (Z.lt ZF_crr n); ZF_prf1: (Z.le 0 ZF_crr) }. Definition ZFeq (n : Z) : ZF n -> ZF n -> Prop. Proof. intros a b. case a. case b. intros x H H' x0 H0 H0'. exact (x = x0). Defined. Definition ZFap (n : Z) : ZF n -> ZF n -> CProp. Proof. intros a b. case a. case b. intros x H H' x0 H0 H0'. exact (x <> x0). Defined. Lemma ZFap_irreflexive : forall n : Z, irreflexive (ZFap n). Proof. unfold irreflexive in |- *. unfold ZFap in |- *. intros n x. case x. intuition. red in |- *. intuition. Qed. Lemma ZFap_symmetric : forall n : Z, Csymmetric (ZFap n). Proof. intro n. unfold Csymmetric in |- *. unfold ZFap in |- *. intros x y. case x. case y. intuition. Qed. Lemma ZFap_cotransitive : forall n : Z, cotransitive (ZFap n). Proof. intro n. unfold cotransitive in |- *. unfold ZFap in |- *. intros x y. case x. case y. intros x0 H0 H0' x1 H1 H1' H2 z. case z. intros x2 H H'. set (H5 := Z.eq_dec x2 x1) in *. elim H5. clear H5. intro H5. right. rewrite H5. exact H2. clear H5. intro H5. left. exact H5. Qed. Lemma ZFap_tight : forall n : Z, tight_apart (ZFeq n) (ZFap n). Proof. unfold tight_apart in |- *. unfold ZFap in |- *. unfold ZFeq in |- *. intros n x y. case x. case y. intros x0 H0 H0'x1 H1 H1'. red in |- *. unfold not in |- *. unfold Not in |- *. intuition. Qed. Definition Zless (n : Z) := Build_is_CSetoid (ZF n) (ZFeq n) (ZFap n) (ZFap_irreflexive n) (ZFap_symmetric n) (ZFap_cotransitive n) (ZFap_tight n). Definition ZCSetoid_of_less (n : Z) : CSetoid := Build_CSetoid (ZF n) (ZFeq n) (ZFap n) (Zless n). corn-8.20.0/model/setoids/Zsetoid.v000066400000000000000000000105021473720167500171360ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.model.structures.Zsec. Require Export CoRN.algebra.CSetoidFun. (** ** Example of a setoid: [Z] *** [Z] *) Lemma ap_Z_irreflexive : irreflexive (A:=Z) ap_Z. Proof. red in |- *. apply ap_Z_irreflexive0. Qed. Lemma ap_Z_symmetric : Csymmetric ap_Z. Proof. red in |- *. apply ap_Z_symmetric0. Qed. Lemma ap_Z_cotransitive : cotransitive (A:=Z) ap_Z. Proof. red in |- *. apply ap_Z_cotransitive0. Qed. Lemma ap_Z_tight : tight_apart (A:=Z) (eq (A:=Z)) ap_Z. Proof. red in |- *. apply ap_Z_tight0. Qed. Definition ap_Z_is_apartness := Build_is_CSetoid Z (eq (A:=Z)) ap_Z ap_Z_irreflexive ap_Z_symmetric ap_Z_cotransitive ap_Z_tight. Definition Z_as_CSetoid := Build_CSetoid _ _ _ ap_Z_is_apartness. Canonical Structure Z_as_CSetoid. (** The term [Z_as_CSetoid] is of type [CSetoid]. Hence we have proven that [Z] is a constructive setoid. *** Addition We will prove now that the addition on the integers is a setoid function. *) Lemma Zplus_wd : bin_fun_wd Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zplus. Proof. red in |- *. simpl in |- *. apply Zplus_wd0. Qed. Lemma Zplus_strext : bin_fun_strext Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zplus. Proof. red in |- *. simpl in |- *. apply Zplus_strext0. Qed. Definition Zplus_is_bin_fun := Build_CSetoid_bin_fun Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zplus Zplus_strext. Canonical Structure Zplus_is_bin_fun. (** What's more: the addition is also associative and commutative. *) Lemma Zplus_is_assoc : associative Zplus_is_bin_fun. Proof. red in |- *. intros x y z. simpl in |- *. apply Zplus_assoc. Qed. Lemma Zplus_is_commut : commutes Zplus_is_bin_fun. Proof. red in |- *. simpl in |- *. intros x y. apply Zplus_comm. Qed. (** *** Opposite Taking the opposite of an integer is a setoid function. *) Lemma Zopp_wd : fun_wd (S1:=Z_as_CSetoid) (S2:=Z_as_CSetoid) Z.opp. Proof. red in |- *. simpl in |- *. intros x y H. apply (f_equal Z.opp H). Qed. Lemma Zopp_strext : fun_strext (S1:=Z_as_CSetoid) (S2:=Z_as_CSetoid) Z.opp. Proof. red in |- *. simpl in |- *. unfold ap_Z in |- *. intros x y H. intro H0. apply H. exact (f_equal Z.opp H0). Qed. Definition Zopp_is_fun := Build_CSetoid_fun Z_as_CSetoid Z_as_CSetoid Z.opp Zopp_strext. Canonical Structure Zopp_is_fun. (** *** Multiplication Finally the multiplication is a setoid function and is associative and commutative. *) Lemma Zmult_wd : bin_fun_wd Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zmult. Proof. red in |- *. simpl in |- *. intros x1 x2 y1 y2 H H0. apply (f_equal2 Zmult (x1:=x1) (y1:=x2) (x2:=y1) (y2:=y2)). assumption. assumption. Qed. Lemma Zmult_strext : bin_fun_strext Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zmult. Proof. red in |- *. simpl in |- *. apply Zmult_strext0. Qed. Definition Zmult_is_bin_fun := Build_CSetoid_bin_fun Z_as_CSetoid Z_as_CSetoid Z_as_CSetoid Zmult Zmult_strext. Canonical Structure Zmult_is_bin_fun. Lemma Zmult_is_assoc : associative Zmult_is_bin_fun. Proof. red in |- *. intros x y z. simpl in |- *. apply Zmult_assoc. Qed. Lemma Zmult_is_commut : commutes Zmult_is_bin_fun. Proof. red in |- *. simpl in |- *. intros x y. apply Zmult_comm. Qed. (** *** Zero *) Lemma is_nullary_operation_Z_0 : (is_nullary_operation Z_as_CSetoid 0%Z). Proof. unfold is_nullary_operation. intuition. Qed. corn-8.20.0/model/setoids/decsetoid.v000066400000000000000000000053701473720167500174670ustar00rootroot00000000000000(* Standard Coq Setoids with decidable equality yield CSetoids with apartness defined as negation of equivalence. Also, morphisms on these setoids yield fun_strext/bin_fun_strext/Crel_strext. *) Set Implicit Arguments. Require Import CoRN.algebra.CSetoids. From Coq Require Import SetoidDec Morphisms SetoidClass. Class Apartness `{SetoidClass.Setoid} (ap: Crelation A): Type := { ap_irreflexive: irreflexive ap ; ap_symmetric: Csymmetric ap ; ap_cotransitive: cotransitive ap ; ap_tight: tight_apart equiv ap }. Class CSetoid_class `(Setoid): Type := { apart: Crelation A ; csetoid_apart :: Apartness apart }. Definition is_CSetoid_from_class `{Apartness}: is_CSetoid _ equiv ap0. destruct H0. apply Build_is_CSetoid; assumption. Defined. Definition CSetoid_from_class `{CSetoid_class}: CSetoid. Proof. intros. apply (Build_CSetoid A equiv apart is_CSetoid_from_class). Defined. Section contents. Context {T: Type} {S: Setoid T} {eq_dec: EqDec S}. Let ap (a b: T): Prop := ~ (a == b). Instance ap_apart: Apartness ap. Proof with auto. apply Build_Apartness. do 2 intro. intuition. do 4 intro. intuition. intros x y H z. destruct (eq_dec x z)... destruct (eq_dec z y)... exfalso. apply H. transitivity z... red. unfold ap, Not. split... destruct (eq_dec x y)... intuition. Qed. Global Instance dec_CSetoid: CSetoid_class S := { apart := ap; csetoid_apart := ap_apart }. Definition is_CSetoid: is_CSetoid T equiv ap := is_CSetoid_from_class. Definition CSetoid: CSetoid := CSetoid_from_class. Lemma fun_strext (S': CSetoids.CSetoid) (f: T -> S'): Proper (equiv ==> @st_eq _) f -> @fun_strext CSetoid S' f. Proof with auto. red. simpl. repeat intro. apply <- (ax_ap_tight _ _ _ (cs_proof S') (f x) (f y))... Qed. Lemma Crel_strext (R: relation T): Proper (equiv ==> equiv ==> iff) R -> Crel_strext CSetoid R. Proof with auto. red. simpl. intros. destruct (eq_dec x1 x2)... destruct (eq_dec y1 y2)... left. rewrite <- e, <- e0... Qed. End contents. Module test. (* If we now have an equality-decidable setoid, we can immediately refer to apartness without any explicit invocation. *) Definition test `{eq_dec: EqDec} := fun x y =>apart x y. End test. Section binary. Context {T T': Type} {S: Setoid T} {S': Setoid T'} {eq_dec: EqDec S} {eq_dec': EqDec S'}. Lemma bin_fun_strext (S'': CSetoids.CSetoid) (f: T -> T' -> S''): Proper (equiv ==> equiv ==> @st_eq _) f -> bin_fun_strext CSetoid CSetoid S'' f. Proof with auto. red. simpl. intros. destruct (eq_dec x1 x2)... destruct (eq_dec' y1 y2)... exfalso. apply <- (ax_ap_tight _ _ _ (cs_proof S'') (f x1 y1) (f x2 y2))... rewrite -> e, e0. reflexivity. Qed. End binary. corn-8.20.0/model/structures/000077500000000000000000000000001473720167500161015ustar00rootroot00000000000000corn-8.20.0/model/structures/NNUpperR.v000066400000000000000000000366161473720167500177550ustar00rootroot00000000000000(* This module is designed to *not* be Import'ed, only Require'd. *) From Coq Require Import Qabs. Require Import CoRN.model.ordfields.Qordfield CoRN.model.structures.Qpossec. From Coq Require Import Qminmax Ring Program. Require CoRN.model.structures.QnonNeg. Import QnonNeg.notations QnonNeg.coercions. Local Hint Resolve Qle_refl. Local Open Scope Q_scope. (* Some generic utilities: *) Definition pred_eq {X} (p q: X -> Prop): Prop := forall x, p x <-> q x. #[global] Instance: forall X, Equivalence (@pred_eq X) := {}. (* Some facts about Q: *) Lemma Qplus_wiggle (x y z : Q): 0 <= x -> 0 <= y -> x + y < z -> exists e: Qpos, x + e + y < z. Proof with auto. intros ?? E. destruct (Qpos_lt_plus E) as [e F]. exists ((1#2) * e)%Qpos. rewrite F. simpl. ring_simplify. apply Qplus_lt_l. do 2 rewrite (Qplus_comm x). apply Qplus_lt_l. rewrite <- (Qmult_1_l e) at 2. apply Qmult_lt_compat_r... reflexivity. Qed. Lemma Qmult_wiggle (x y z : Q): 0 <= x -> 0 <= y -> x * y < z -> exists e : Qpos, (x + e) * y < z. Proof with auto with *. intros xnn ynn xyz. destruct (Qdec_sign y) as [[A|B]|C]. exfalso. apply Qle_not_lt with 0 y... destruct (Qpos_lt_plus xyz) as [e E]. exists (e / ((2#1) * exist (Qlt 0) y B))%Qpos. rewrite E. rewrite Qmult_plus_distr_l. do 2 rewrite (Qplus_comm (x * y)). apply Qplus_lt_l. simpl. setoid_replace (e * / ((2 # 1) * y) * y) with (/ (2 # 1) * e) by (simpl; field)... rewrite <- (Qmult_1_l e) at 2. apply Qmult_lt_compat_r... exists (1#1)%Qpos. revert xyz. rewrite C, Qmult_0_r, Qmult_0_r... Qed. Lemma Qmid (x y: Q): x < y -> let mid := (1#2)%Qpos*(x+y) in x < mid /\ mid < y. Proof with auto; try reflexivity. intros. subst mid. split. setoid_replace x with (x * (1#2) + x * (1#2)) at 1 by (simpl; ring). setoid_replace ((1 # 2) * (x + y)) with (y * (1 # 2) + x * (1 # 2)) by (simpl; ring). apply Qplus_lt_l. apply Qmult_lt_compat_r... setoid_replace y with (y * (1#2) + y * (1#2)) at 2 by (simpl; ring). setoid_replace ((1 # 2) * (x + y)) with (x * (1 # 2) + y * (1 # 2)) by (simpl; ring). apply Qplus_lt_l. apply Qmult_lt_compat_r... Qed. Lemma QnonNeg_mid (x y: QnonNeg): ` x < ` y -> let mid := ((1#2) * (x + y))%Qnn in ` x < ` mid /\ ` mid < ` y. Proof. intros. subst mid. simpl. apply Qmid. assumption. Qed. Lemma Qmult_le_compat: forall x y x' y' : Q, 0 <= x <= x' -> 0 <= y <= y' -> x * y <= x' * y'. Proof. intros. apply Qle_trans with (x * y'). do 2 rewrite (Qmult_comm x). apply Qmult_le_compat_r; intuition. apply Qmult_le_compat_r. intuition. apply Qle_trans with y; intuition. Qed. Local Hint Resolve Qlt_le_weak. (* Next up, the actual data type for non-negative upper cuts: *) Record T := make { is_bound: QnonNeg -> Prop ; bound: QnonNeg ; closed_le: forall q q', `q <= `q' -> is_bound q -> is_bound q' ; bound_is_bound: is_bound bound }. (* Note that we don't enforce closedness or openness of the cut in this definition. Instead, we write le and eq so that they only depend on non-lowest upper bounds. *) (* The bound and bound_is_bound fields are just there to rule out an empty cut. A weaker way to accomplish this is by replacing the two with a field of type ~ forall q, ~ is_bound q Maybe this is better. A preliminary experiment did reveal a complication in the proof of mult_0_l, because it uses the bound. Possible solutions there include (1) requiring is_bound stability so that the negated forall above can be classically flipped to an exists, or (2) using a separate inductively defined cut predicate for multiplication which has an additional constructor for the multiplication-by-0 case. *) #[global] Hint Immediate bound_is_bound. #[global] Instance is_bound_Proper: forall (x: T), Proper (QnonNeg.eq ==> iff) (is_bound x). Proof with auto. unfold QnonNeg.eq. intros x y z E. split; intro. apply closed_le with y... rewrite E... apply closed_le with z... rewrite E... Qed. Definition le (x y: T): Prop := forall q, is_bound y q -> forall r, `q < `r -> is_bound x r. Local Infix "<=" := le. Lemma le_refl (x: T): x <= x. Proof. repeat intro. apply closed_le with q; auto. Qed. Lemma le_trans (x y z: T): x <= y -> y <= z -> x <= z. Proof with auto. intros xley ylez q zq r qr. destruct (QnonNeg_mid q r qr). apply (xley ((1#2)*(q+r))%Qnn)... apply (ylez q)... Qed. Definition eq (x y: T): Prop := x <= y /\ y <= x. Local Infix "==" := eq. Global Instance: Proper (eq ==> eq ==> iff) le. Proof with intuition. unfold eq. intros x y ? a b ?. split; intro. apply le_trans with x... apply le_trans with a... apply le_trans with y... apply le_trans with b... Qed. Global Instance: Equivalence eq. Proof with intuition. unfold eq. split; repeat intro... apply le_refl. apply le_refl. apply le_trans with y... apply le_trans with y... Qed. Module Export coercions. Global Program Coercion inject_Qnn (q: QnonNeg): T := make (Qle q) q _ _. Next Obligation. apply Qle_trans with (q0); assumption. Qed. Global Instance: Proper (QnonNeg.eq ==> eq) inject_Qnn. Proof with auto. unfold eq, le. intros ?? H. unfold QnonNeg.eq in H. split; simpl; intros. rewrite H. apply Qle_trans with (`q)... rewrite <- H. apply Qle_trans with (`q)... Qed. End coercions. Definition bound_doesnt_matter (q: QnonNeg) b H H' U U': make (fun x => Qle (proj1_sig q) (proj1_sig x)) b H U == make (fun x => Qlt (proj1_sig q) (proj1_sig x)) b H' U'. Proof with auto. unfold eq, le in *. simpl. split; intros e ???. apply Qle_trans with (`e)... apply Qle_lt_trans with (`e)... Qed. Section binop. (* used for addition and multiplication *) Variables (o: Q -> Q -> Q) (u: Q) (u_ok: (0 <= u)%Q) (o_ok: (forall x y, 0 <= x -> 0 <= y -> 0 <= o x y)%Q) (o_comm: (forall x y, o x y == o y x)%Q) (o_assoc: (forall x y z, o x (o y z) == o (o x y) z)%Q) (o_le_compat: (forall x y x' y', 0 <= x <= x' -> 0 <= y <= y' -> o x y <= o x' y')%Q) (o_u_left: (forall x, o u x == x)%Q) (o_sneaky: (forall (x y z: Q), 0 <= x -> 0 <= y -> o x y < z -> exists e: Qpos, o (x + e) y < z)%Q). (* todo: use monoid or something *) Definition u_nn: QnonNeg := exist _ _ u_ok. Definition o_nn := QnonNeg.binop o o_ok. Inductive BinopBound (x y: QnonNeg -> Prop): (QnonNeg -> Prop) := is_binop_bound (q q': QnonNeg): x q -> y q' -> forall (r: QnonNeg), (o (` q) (` q') <= ` r)%Q -> BinopBound x y r. (* using <= instead of == makes closed_le automatic. using ==/<= at all makes wd automatic. *) Lemma BinopBound_le x y a b: (`a <= `b)%Q -> BinopBound x y a -> BinopBound x y b. Proof with auto. intros E B. revert B E. intros [v w xv yw r F] E. apply (is_binop_bound x y v w)... apply Qle_trans with (`r)... Qed. Instance BinopBound_Proper: Proper (pred_eq ==> pred_eq ==> QnonNeg.eq ==> iff) BinopBound. Proof with auto. unfold Proper, respectful. cut (forall x y x0 y0 x1 y1, pred_eq x y -> pred_eq x0 y0 -> (`x1 == `y1)%Q -> BinopBound x x0 x1 -> BinopBound y y0 y1). split; apply H; auto; symmetry... intros ?????? U V A B. revert B A. intros [v w xv yw r F] E. apply (is_binop_bound _ _ v w). apply U... apply V... apply Qle_trans with (`r)... rewrite E... Qed. Lemma BinopBound_sym x y: pred_eq (BinopBound x y) (BinopBound y x). Proof with auto. split; intros [a b xa yb r E]. apply (is_binop_bound y x b a yb xa). rewrite o_comm... apply (is_binop_bound x y b a yb xa). rewrite o_comm... Qed. Lemma BinopBound_assoc (n m p: T) (q: QnonNeg): BinopBound (is_bound n) (BinopBound (is_bound m) (is_bound p)) q -> BinopBound (BinopBound (is_bound n) (is_bound m)) (is_bound p) q. Proof with auto. intros [a b na [v w z x y E] c F]. apply BinopBound_le with (o_nn (o_nn a v) w). simpl. apply Qle_trans with (o (`a) (`y))... rewrite <- o_assoc. apply o_le_compat; split... apply is_binop_bound with (o_nn a v) w... apply is_binop_bound with a v... Qed. Program Definition binop (x y: T): T := make (BinopBound (is_bound x) (is_bound y)) (o_nn (bound x) (bound y)) _ _. Next Obligation. (* closed_le *) apply BinopBound_le with (exist _ q H2); auto. Qed. Next Obligation. (* bound_is_bound *) apply (is_binop_bound (is_bound x) (is_bound y) (bound x) (bound y)); auto. Qed. Lemma binop_comm (x y: T): binop x y == binop y x. Proof with auto. cut (forall a b, binop a b <= binop b a). intro H. split; apply H. unfold eq, le. simpl. intros. inversion H. subst. clear H. apply BinopBound_sym. apply is_binop_bound with q0 q'... apply Qle_trans with (`q)... Qed. Lemma binop_le_compat_l (x y z: T): x <= y -> binop x z <= binop y z. Proof with auto. unfold le. simpl. intros H q [v w yv zw r E] s rs. specialize (H _ yv). assert (o (`v) (`w) < `s) as os. apply Qle_lt_trans with (`r)... destruct (o_sneaky _ _ _ (proj2_sig _) (proj2_sig _) os). apply (is_binop_bound (is_bound x) (is_bound z)) with (v + from_Qpos x0)%Qnn w... apply H. simpl. rewrite Qplus_comm. rewrite <- Qplus_0_l at 1. apply Qplus_lt_l... Qed. Lemma binop_le_compat (x y: T) (v w: T): x <= y -> v <= w -> binop x v <= binop y w. Proof. intros. apply le_trans with (binop x w); [do 2 rewrite (binop_comm x) |]; apply binop_le_compat_l; auto. Qed. Global Instance binop_Proper: Proper (eq ==> eq ==> eq) binop. Proof. unfold eq. repeat intro. split; apply binop_le_compat; intuition. Qed. Lemma binop_assoc (n m p: T): binop n (binop m p) == binop (binop n m) p. Proof with auto. unfold eq, le. simpl. split; intros. apply BinopBound_sym. apply BinopBound_assoc. apply BinopBound_sym. apply BinopBound_assoc. apply BinopBound_sym... apply BinopBound_le with q... apply BinopBound_assoc. apply BinopBound_le with q... Qed. Lemma binop_unit_left (x: T): binop u_nn x == x. Proof with auto. unfold eq, le. simpl. split. intros. apply (is_binop_bound) with u_nn q... simpl. rewrite o_u_left... intros q [q0 q' H1 H2 v H3] r vr. apply closed_le with q'... apply Qle_trans with (`v)... rewrite <- (o_u_left (`q')). apply Qle_trans with (o (`q0) (`q'))... Qed. End binop. Definition plus := binop Qplus QnonNeg.Qplus_nonneg. Definition mult := binop Qmult Qmult_le_0_compat. Local Infix "+" := plus. Local Infix "*" := mult. #[global] Instance: Proper (eq ==> eq ==> eq) plus. Proof binop_Proper Qplus QnonNeg.Qplus_nonneg Qplus_comm Qplus_wiggle. #[global] Instance: Proper (eq ==> eq ==> eq) mult. Proof binop_Proper Qmult Qmult_le_0_compat Qmult_comm Qmult_wiggle. Lemma plus_0_l: forall x, 0%Qnn + x == x. Proof. refine (binop_unit_left Qplus 0 (Qle_refl _) QnonNeg.Qplus_nonneg _ Qplus_0_l). intros. apply Qplus_le_compat; intuition. Qed. Lemma plus_comm: forall x y, x + y == y + x. Proof binop_comm Qplus QnonNeg.Qplus_nonneg Qplus_comm. Lemma plus_assoc: forall n m p, n + (m + p) == (n + m) + p. Proof. apply (binop_assoc Qplus QnonNeg.Qplus_nonneg Qplus_comm Qplus_assoc). intros. apply Qplus_le_compat; intuition. Qed. Lemma plus_le_compat: forall x y a b, x <= y -> a <= b -> x + a <= y + b. Proof binop_le_compat Qplus QnonNeg.Qplus_nonneg Qplus_comm Qplus_wiggle. Lemma Qle_0_1: (0 <= 1)%Q. Proof. discriminate. Qed. Lemma mult_1_l: forall x, 1%Qnn * x == x. Proof binop_unit_left Qmult 1 Qle_0_1 Qmult_le_0_compat Qmult_le_compat Qmult_1_l. Lemma mult_comm: forall x y, x * y == y * x. Proof binop_comm Qmult Qmult_le_0_compat Qmult_comm. Lemma mult_assoc: forall n m p, n * (m * p) == (n * m) * p. Proof binop_assoc Qmult Qmult_le_0_compat Qmult_comm Qmult_assoc Qmult_le_compat. Lemma mult_plus_distr n m p: (n + m) * p == n * p + m * p. Proof with auto; simpl. unfold eq. split. intros _ [_ _ [e d ?? b ?][g f ?? c ?]a ?] r ? ... apply BinopBound_le with (e * d + g * f)%Qnn... apply Qle_trans with (`b + `c)%Q... apply Qplus_le_compat... apply Qle_trans with (`a)... apply is_binop_bound with (e + g)%Qnn (QnonNeg.min d f)... apply is_binop_bound with e g... apply QnonNeg.min_case... apply (is_bound_Proper p)... rewrite Qmult_plus_distr_l. apply Qplus_le_compat... do 2 rewrite (Qmult_comm (`e)). apply Qmult_le_compat_r... apply Q.le_min_l. do 2 rewrite (Qmult_comm (`g)). apply Qmult_le_compat_r... apply Q.le_min_r. intros q [a b [c d ?? e ?] ? r1 ?] r E... apply BinopBound_le with ((c + d) * b)%Qnn... apply Qle_trans with (`e * `b)%Q... apply Qmult_le_compat_r... apply Qle_trans with (`r1)... apply is_binop_bound with (c * b)%Qnn (d * b)%Qnn. apply is_binop_bound with c b... apply is_binop_bound with d b... simpl. ring_simplify... Qed. Lemma le_closed (e x: T): (forall d: Qpos, x <= e + from_Qpos d) -> x <= e. Proof with auto. unfold le. simpl. intros H q H0 r qr. destruct (Qpos_lt_plus qr) as [d E]. apply (H ((1#2)*d)%Qpos (q + (2#3)*from_Qpos d)%Qnn). apply (is_binop_bound Qplus) with q ((1#2)*from_Qpos d)%Qnn... simpl. apply Qplus_le_compat... apply Qmult_le_compat_r... discriminate. simpl. rewrite E. do 2 rewrite (Qplus_comm (`q)). apply Qplus_lt_l. simpl. rewrite <- (Qmult_1_l d). apply Qmult_lt_compat_r... reflexivity. Qed. Lemma le_0 x: 0%Qnn <= x. Proof. unfold le. simpl. auto. Qed. #[global] Hint Immediate le_0. Lemma le_0_eq x: x <= 0%Qnn -> x == 0%Qnn. Proof. split. assumption. apply le_0. Qed. Lemma mult_0_l (x: T): 0%Qnn * x == 0%Qnn. Proof with auto. split... unfold le. simpl. intros. apply (is_binop_bound) with 0%Qnn (bound x)... simpl. rewrite Qmult_0_l... Qed. Lemma plus_homo (x y: QnonNeg): (x + y)%Qnn == x + y. Proof with auto. unfold eq, le. simpl. split; intros. inversion H. subst. clear H. apply Qle_trans with (`q)... apply Qle_trans with (`q0 + `q')%Q... apply Qplus_le_compat... apply (is_binop_bound Qplus) with x y... apply Qle_trans with (`q)... Qed. Lemma semi_ring: semi_ring_theory (R:=T) 0%Qnn 1%Qnn plus mult eq. Proof. constructor. apply plus_0_l. apply plus_comm. apply plus_assoc. apply mult_1_l. apply mult_0_l. apply mult_comm. apply mult_assoc. apply mult_plus_distr. Qed. Add Ring cut_ring: semi_ring. Module notations. Delimit Scope NNUpperR_scope with Rnnu. Global Infix "<=" := le: NNUpperR_scope. Global Infix "==" := eq: NNUpperR_scope. Global Infix "+" := plus: NNUpperR_scope. Global Infix "*" := mult: NNUpperR_scope. Global Notation NNUpperR := T. End notations. (* To show concretely that we've actually gotten beyond mere rationals, here's the square of two: *) Program Definition sqrt2: T := make (fun x => (2#1) <= x*x)%Q (2#1)%Qnn _ _. Next Obligation. Proof with auto. simpl in *. apply Qle_trans with (q * q)%Q... apply Qmult_le_compat... Qed. (* For its correctness, I assume (because I'm lazy and couldn't find this in the stdlib) that square roots can be over-approximated to arbitrary precision: *) Lemma sqrt2_correct (Qsqrt_overapprox: forall (x: QnonNeg) (e: Qpos), { r: QnonNeg | ` x <= ` r * ` r /\ ` r * ` r < ` x + e }%Q): sqrt2 * sqrt2 == (2#1)%Qnn. Proof with auto. unfold eq, le. simpl. split; intros. destruct (Qpos_lt_plus H0). destruct (Qsqrt_overapprox (2#1)%Qnn x). destruct a. apply (is_binop_bound Qmult) with x0 x0... rewrite q0. apply Qle_trans with ((2 # 1)%Q + x)%Q... apply Qplus_le_compat... inversion_clear H. destruct (Qlt_le_dec (`q0) (`q')). apply Qle_trans with (`q0*`q0)%Q... apply Qle_trans with (`q0*`q')%Q... apply Qmult_le_compat... apply Qle_trans with (`q)... apply Qle_trans with (`q'*`q')%Q... apply Qle_trans with (`q0*`q')%Q... apply Qmult_le_compat... apply Qle_trans with (`q)... Qed. corn-8.20.0/model/structures/Npossec.v000066400000000000000000000044501473720167500177050ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Npos $\mathbb{N}^{+}$ #N+# *) Require Export CoRN.model.structures.Nsec. From Coq Require Import Arith Lia. (** ** [Npos] The positive natural numbers have some nice properties. Addition as well as multiplication preserve the feature of being positive. *) Lemma plus_resp_Npos0 : forall x y : nat, x <> 0 -> y <> 0 -> (x+y) <> 0. Proof. intros x y H H0. unfold not in |- *. intros H1. unfold not in H. apply H. lia. Qed. Lemma Npos_is_suc : forall y : nat, y <> 0 -> exists m : nat, y = S m. Proof. intros y H. exists (pred y). unfold pred in |- *. induction y as [| y Hrecy]. intuition. intuition. Qed. Lemma mult_resp_Npos0 : forall x y : nat, x <> 0 -> y <> 0 -> (x*y) <> 0. Proof. intros x y H H0. destruct (Npos_is_suc y H0) as [y0 H2]. rewrite H2 in H0. rewrite H2. generalize y0. clear H0 H2 y0 y. intro y0. induction y0 as [| y0 Hrecy0]. rewrite Nat.mul_comm. rewrite Nat.mul_1_l. exact H. rewrite <- mult_n_Sm. cut (0 <> (x*S y0+x) -> (x*S y0+x) <> 0). intro H3. apply H3. apply Nat.neq_sym. apply Nat.neq_0_lt_0. cut ((x*S y0+x) > 0). unfold gt in |- *. intuition. apply Nat.lt_trans with (x*S y0). apply Nat.lt_le_trans with (x*S y0+0). lia. lia. lia. lia. Qed. corn-8.20.0/model/structures/Nsec.v000066400000000000000000000110621473720167500171600ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing {#N} $\ensuremath{\mathrel\#_{\mathbb N}}$ *) From Coq Require Export Peano_dec. From Coq Require Export Relations. Require Import CoRN.logic.CLogic. From Coq Require Import Lia. (** * [nat] ** About [nat] We prove some basic lemmas of the natural numbers. A variant of [0_S] from the standard library *) Lemma S_O : forall n : nat, S n <> 0. Proof. intro n. red in |- *. intro H. generalize O_S. intro H0. red in H0. apply H0 with n. apply sym_eq. exact H. Qed. (** *** Apartness *) Definition ap_nat (x y : nat) := ~ (x = y :>nat). Infix "{#N}" := ap_nat (no associativity, at level 90). Lemma ap_nat_irreflexive0 : forall x : nat, Not (x{#N}x). Proof. red in |- *. unfold ap_nat in |- *. intros x X. apply X. auto. Qed. Lemma ap_nat_symmetric0 : forall x y : nat, (x{#N}y) -> y{#N}x. Proof. intros x y. unfold ap_nat in |- *. intros X. intro Y. apply X. auto. Qed. Lemma ap_nat_cotransitive0 : forall x y : nat, (x{#N}y) -> forall z : nat, (x{#N}z) or (z{#N}y). Proof. intros x y X z. unfold ap_nat in |- *. case (eq_nat_dec x z). intro e. right. rewrite <- e. assumption. intro. left. intro. elim n. assumption. Qed. Lemma ap_nat_tight0 : forall x y : nat, Not (x{#N}y) <-> x = y. Proof. intros x y. red in |- *. split. unfold ap_nat in |- *. intro H. case (eq_nat_dec x y). intro e. assumption. intro n. elim H. intro H0. elim n. assumption. intro H. unfold ap_nat in |- *. intro H0. elim H0. assumption. Qed. (** *** Addition *) Lemma plus_strext0 : forall x1 x2 y1 y2 : nat, (x1+y1{#N}x2+y2) -> (x1{#N}x2) or (y1{#N}y2). Proof. intros x1 x2 y1 y2 H. unfold ap_nat in |- *. unfold ap_nat in H. case (eq_nat_dec x1 x2). intro e. right. red in |- *. intro H0. apply H. auto. intro n. left. intro H0. elim n. assumption. Qed. (** There is no inverse for addition, because every candidate will fail for 2 *) Lemma no_inverse0 : forall f : nat -> nat, ~ ((2+f 2) = 0 /\ (f 2+2) = 0). Proof. intro f. simpl in |- *. red in |- *. intro H. elim H. intros H1 H2. set (H3 := O_S (S (f 2))) in *. generalize H3. unfold not in |- *. intro H4. apply H4. lia. Qed. (** *** Multiplication *) Lemma mult_strext0 : forall x1 x2 y1 y2 : nat, (x1*y1{#N}x2*y2) -> (x1{#N}x2) or (y1{#N}y2). Proof. unfold ap_nat in |- *. intros x1 x2 y1 y2 H. cut ({x1 = x2} + {x1 <> x2}). intro H1. elim H1. intro e. right. red in |- *. intro H0. apply H. exact (f_equal2 mult e H0). intro X. auto. apply eq_nat_dec. Qed. (** *** Decidability *) Lemma not_or:(forall (p q:nat), (p<>q)-> p k=0. Proof. intros k i l H. unfold Not in H. set (H1:=(lt_eq_lt_dec 0 k)). elim H1. clear H1. intro H1. elim H1. clear H1. intuition. intuition. intuition. Qed. Lemma lexi_dec:(forall (k i l:nat), Cdecidable (0 Q; OpenUnitprf:0 Qlt_minus_iff in H1;assumption. Qed. Lemma OpenUnit_Dual_lt_1 : forall (a:OpenUnit), 1-a < 1. Proof. intros [a [H0 H1]]. simpl. rewrite -> Qlt_minus_iff. replace RHS with a by simpl; ring. assumption. Qed. (* begin hide *) #[global] Hint Resolve OpenUnit_0_lt OpenUnit_lt_1 OpenUnit_0_lt_Dual OpenUnit_Dual_lt_1 : ouarith. (* end hide *) (** Multiplication *) Definition OpenUnitMult (a b:OpenUnit):OpenUnit. Proof. exists (a * b). abstract(destruct a as [a [Ha0 Ha1]]; destruct b as [b [Hb0 Hb1]]; split; simpl; [apply: mult_resp_pos; assumption |change (1:Q) with (1*1); apply: mult_resp_less_both;auto with *]). Defined. Notation "x * y":=(OpenUnitMult x y) : ou_scope. (** Division *) Definition OpenUnitDiv (a b:OpenUnit):(aOpenUnit. Proof. intros p. exists (a/b). abstract (destruct a as [a [Ha0 Ha1]]; destruct b as [b [Hb0 Hb1]]; split; simpl;[ apply Qlt_shift_div_l; auto; ring_simplify; auto| apply Qlt_shift_div_r; auto; ring_simplify; auto]). Defined. (** The dual of a is 1-a *) Definition OpenUnitDual (a:OpenUnit):OpenUnit. Proof. exists (1-a). abstract (destruct a as [a [Ha0 Ha1]]; simpl; split; rewrite -> Qlt_minus_iff in *;[ (replace RHS with (1+-a) by simpl; ring); auto| (replace RHS with (a+-0) by simpl; ring); auto]). Defined. (** The dual of multipliation: 1 - (1-a)*(1-b) or a + b - a*b *) Definition OpenUnitDualMult (a b:OpenUnit):OpenUnit. Proof. exists (a + b - a * b). abstract ( split; [(replace RHS with (OpenUnitDual ((OpenUnitDual a)*(OpenUnitDual b)):Q) by simpl; ring); auto with * |(replace LHS with (OpenUnitDual ((OpenUnitDual a)*(OpenUnitDual b)):Q) by simpl; ring); auto with *]). Defined. (** The dual of division: 1 - (1-b)/(1-a) or (b-a)/(1-a) *) Definition OpenUnitDualDiv (b a:OpenUnit):(aOpenUnit. Proof. intros p. exists ((b-a)/(1-a)). abstract ( assert (X:OpenUnitDual b < OpenUnitDual a); [rewrite -> Qlt_minus_iff in *; simpl; (replace RHS with (b + - a) by simpl; ring); assumption |split; [(replace RHS with (OpenUnitDual (OpenUnitDiv _ _ X):Q) by simpl; field; auto with * ); auto with * |(replace LHS with (OpenUnitDual (OpenUnitDiv _ _ X):Q) by simpl; field; auto with * ); auto with *]]). Defined. (** *** Equality *) Definition ou_eq (x y:OpenUnit) := Qeq x y. Lemma ou_eq_refl : forall x, ou_eq x x. Proof. intros; apply Qeq_refl. Qed. Lemma ou_eq_sym : forall x y, ou_eq x y -> ou_eq y x. Proof. intros; apply Qeq_sym; auto. Qed. Lemma ou_eq_trans : forall x y z, ou_eq x y -> ou_eq y z -> ou_eq x z. Proof. intros; apply (Qeq_trans x y); auto. Qed. Add Relation OpenUnit ou_eq reflexivity proved by ou_eq_refl symmetry proved by ou_eq_sym transitivity proved by ou_eq_trans as ou_st. (** One cheif use of OpenUnit is to make strict affine combinations. *) Definition affineCombo (o:OpenUnit) (a b:Q) := o*a + (1-o)*b. Add Morphism affineCombo with signature ou_eq ==> Qeq ==> Qeq ==> Qeq as affineCombo_wd. Proof. intros x1 x2 Hx y1 y2 Hy z1 z2 Hz. unfold affineCombo. unfold ou_eq in Hx. rewrite -> Hx, Hy, Hz; reflexivity. Qed. (** Properties of an affine combination. *) Lemma affineCombo_gt : forall o a b (H:a < b), a < affineCombo o a b. Proof. intros o a b H. unfold affineCombo. rewrite -> Qlt_minus_iff in *. replace RHS with ((1-o)*(b-a)) by simpl; ring. apply: mult_resp_pos; simpl; auto with *. Qed. Lemma affineCombo_lt : forall o a b (H:a < b), affineCombo o a b < b. Proof. intros o a b H. unfold affineCombo. rewrite -> Qlt_minus_iff in *. replace RHS with (o*(b-a)) by simpl; ring. apply: mult_resp_pos; simpl; auto with *. Qed. (* begin hide *) #[global] Hint Resolve affineCombo_lt affineCombo_gt : ouarith. (* end hide *) Lemma affineAffine_l : forall a b o1 o2, (affineCombo o1 a (affineCombo o2 a b)==affineCombo (OpenUnitDualMult o1 o2) a b)%Q. Proof. intros a b o1 o2. unfold affineCombo. simpl. ring. Qed. Lemma affineAffine_r : forall a b o1 o2, (affineCombo o1 (affineCombo o2 a b) b==affineCombo (o1*o2) a b)%Q. Proof. intros a b o1 o2. unfold affineCombo. simpl. ring. Qed. corn-8.20.0/model/structures/Qinf.v000066400000000000000000000046601473720167500171730ustar00rootroot00000000000000Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Setoid Arith. Require Import CoRN.model.rings.Qring CoRN.model.structures.QposInf CoRN.stdlib_omissions.Q MathClasses.interfaces.abstract_algebra MathClasses.implementations.stdlib_rationals MathClasses.theory.setoids. Inductive T: Set := finite (q: Q) | infinite. (* (This is positive infinity.) *) #[global] Instance eq: Equiv T := λ x y, match x, y with | infinite, infinite => True | finite a, finite b => a = b | _, _ => False end. #[global] Instance finite_Proper: Proper (=) finite. Proof. repeat intro. assumption. Qed. #[global] Instance setoid: Setoid T. Proof with intuition. constructor. intros []... intros [] [] ?... intros [x|] [y|] [z|] ??... change (x = z). transitivity y... Qed. Definition le (x y: T): Prop := match x, y with | _, infinite => True | infinite, finite _ => False | finite a, finite b => Qle a b end. #[global] Instance: Proper (=) le. Proof. intros [|] [|] E [|] [|] F; intuition; simpl; try reflexivity. unfold equiv in * |-. simpl in *. now rewrite E, F. Qed. Definition lt (x y : T) : Prop := match x, y with | finite a, finite b => Qlt a b | finite _, infinite => True | infinite, _ => False end. #[global] Instance: Proper (=) lt. Proof. intros [x1 |] [x2 |] A1 [y1 |] [y2 |] A2; revert A1 A2; unfold eq, Q_eq, equiv; simpl; intros A1 A2; try contradiction; try reflexivity. rewrite A1, A2; reflexivity. Qed. #[global] Instance: Zero T := finite 0%Q. #[global] Instance plus: Plus T := λ x y, match x, y with | finite a, finite b => finite (a + b) | _, _ => infinite end. Module Export coercions. Coercion finite: Q >-> T. Coercion from_QposInf (q: QposInf): T := match q with | QposInfinity => infinite | Qpos2QposInf u => proj1_sig u end. End coercions. Lemma QposInf_le_QinfLe (x y: QposInf): QposInf_le x y → le x y. Proof. destruct x, y; auto. Qed. Lemma le_0_plus_compat (x y: T): le 0 x → le 0 y → le 0 (x + y). Proof with auto. destruct x, y... simpl. intros. apply Qplus_nonneg... Qed. #[global] Hint Resolve le_0_plus_compat. Lemma le_0_Qpos (x: Qpos): le 0 x. Proof. destruct x. simpl. apply Qlt_le_weak, q. Qed. #[global] Hint Immediate le_0_Qpos. Module notations. Delimit Scope Qinf_scope with Qinf. Global Infix "==" := eq: Qinf_scope. Global Infix "<=" := le: Qinf_scope. Global Infix "+" := plus: Qinf_scope. Global Notation Qinf := T. End notations. corn-8.20.0/model/structures/QnnInf.v000066400000000000000000000056411473720167500174670ustar00rootroot00000000000000 Require CoRN.model.structures.QnonNeg. Import QnonNeg.notations QnonNeg.coercions. Require Import CoRN.model.structures.QposInf. Inductive T: Set := Infinite | Finite (q: QnonNeg). Definition eq (x y: T): Prop := match x, y with | Finite x', Finite y' => (x' == y')%Qnn | Infinite, Infinite => True | _, _ => False end. Global Instance: Equivalence eq. Proof with intuition. unfold eq. split; repeat intro. destruct x... destruct x, y... destruct x, y, z... transitivity q0... Qed. Local Infix "==" := eq. Definition bind (x: T) (f: QnonNeg -> T): T := match x with | Finite x' => f x' | Infinite => Infinite end. Section liftM2. Context (f: QnonNeg -> QnonNeg -> QnonNeg) {p: Proper (QnonNeg.eq ==> QnonNeg.eq ==> QnonNeg.eq) f}. Definition liftM2 (x y: T): T := bind x (fun x' => bind y (fun y' => Finite (f x' y'))). Global Instance liftM2_Proper: Proper (eq ==> eq ==> eq) liftM2. Proof with intuition. intros [] [] ? [] [] ?... simpl. apply p... Qed. Lemma assoc: (forall x y z, f x (f y z) == f (f x y) z)%Qnn -> (forall x y z, liftM2 x (liftM2 y z) == liftM2 (liftM2 x y) z). Proof. intros H [] [] []; simpl; auto. Qed. Lemma comm: (forall x y, f x y == f y x)%Qnn -> (forall x y, liftM2 x y == liftM2 y x). Proof. intros H [] []; simpl; auto. Qed. End liftM2. Definition mult := liftM2 QnonNeg.mult. Definition plus := liftM2 QnonNeg.plus. Local Infix "+" := plus. Local Infix "*" := mult. Lemma plus_comm: forall x y, x + y == y + x. Proof comm QnonNeg.plus QnonNeg.plus_comm. Lemma mult_comm: forall x y, x * y == y * x. Proof comm QnonNeg.mult QnonNeg.mult_comm. Lemma plus_assoc: forall x y z, x + (y + z) == (x + y) + z. Proof assoc QnonNeg.plus QnonNeg.plus_assoc. Lemma mult_assoc: forall x y z, x * (y * z) == (x * y) * z. Proof assoc QnonNeg.mult QnonNeg.mult_assoc. Global Instance: Proper (eq ==> eq ==> eq) plus. Proof liftM2_Proper _. Global Instance: Proper (eq ==> eq ==> eq) mult. Proof liftM2_Proper _. Definition le (x y: T): Prop := match y with | Infinite => True | Finite y' => match x with | Infinite => False | Finite x' => (proj1_sig x' <= proj1_sig y') end end. Global Instance: Proper (eq ==> eq ==> iff) le. Proof with intuition. unfold eq, QnonNeg.eq, le. repeat intro. destruct x0, y0, y, x... rewrite <- H. rewrite <- H0... rewrite H. rewrite H0... Qed. Module Export coercions. Definition from_QposInf (q: QposInf): T := match q with | Qpos2QposInf q' => Finite (from_Qpos q') | QposInfinity => Infinite end. Global Instance Finite_Proper: Proper (QnonNeg.eq ==> eq) Finite. Proof. repeat intro. assumption. Qed. End coercions. Module notations. Delimit Scope QnnInf_scope with QnnInf. Global Infix "==" := eq: QnnInf_scope. Global Infix "<=" := le: QnnInf_scope. Global Infix "+" := plus: QnnInf_scope. Global Infix "*" := mult: QnnInf_scope. Global Notation QnnInf := T. End notations. corn-8.20.0/model/structures/QnonNeg.v000066400000000000000000000152731473720167500176450ustar00rootroot00000000000000(* This module is designed to *not* be Import'ed, only Require'd. *) From Coq Require Import ZArith. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Program. Require Import CoRN.model.structures.QposInf. From Coq Require Import Qminmax. (* The data type and simple relations/constants: *) Definition T := sig (Qle 0). Program Definition eq: T -> T -> Prop := Qeq. Program Definition zero: T := 0. Program Definition one: T := 1. (*Program Definition le: T -> T -> Prop := Qle. Program Definition lt: T -> T -> Prop := Qlt.*) (* Not really needed because we can just use Qle/Qlt directly. This is not practical for eq because we want rewriting and Propers and so on. *) Local Infix "==" := eq. Local Notation "0" := zero. Local Notation "1" := one. Global Instance: Equivalence eq. Proof. split; repeat intro; firstorder auto with crelations. unfold eq. etransitivity; eauto. Qed. (* For addition, multiplication, and min/max (and their properties), we factor out the common bits: *) Section binop. Variables (o: Q -> Q -> Q) (o_ok: forall x y, 0 <= x -> 0 <= y -> 0 <= o x y) (o_proper: Proper (Qeq ==> Qeq ==> Qeq) o) (o_comm: (forall x y, o x y == o y x)%Q) (o_assoc: (forall x y z, o x (o y z) == o (o x y) z)%Q). Program Definition binop: T -> T -> T := o. Lemma binop_comm (x y: T): binop x y == binop y x. Proof. unfold eq. simpl. apply o_comm. Qed. Lemma binop_assoc (x y z: T): binop x (binop y z) == binop (binop x y) z. Proof. unfold eq. simpl. apply o_assoc. Qed. Global Instance binop_proper: Proper (eq ==> eq ==> eq) binop. Proof. unfold eq. intros ?? H ??. exact (o_proper _ _ H _ _). Qed. End binop. (* ... which we now instantiate: *) Lemma Qplus_nonneg (x y: Q): 0 <= x -> 0 <= y -> 0 <= x + y. Proof. apply (Qplus_le_compat 0 x 0); assumption. Qed. Lemma Qmin_nonneg (x y: Q): 0 <= x -> 0 <= y -> 0 <= Qmin x y. Proof. apply Q.min_glb; assumption. Qed. Lemma Qmax_nonneg (x y: Q): 0 <= x -> 0 <= y -> 0 <= Qmax x y. Proof. intros. apply Qle_trans with x. assumption. apply Q.le_max_l. Qed. Definition plus := binop Qplus Qplus_nonneg. Definition mult := binop Qmult Qmult_le_0_compat. Definition min := binop Qmin Qmin_nonneg. Definition max := binop Qmax Qmax_nonneg. Local Infix "+" := plus. Local Infix "*" := mult. Lemma plus_comm: forall x y, x + y == y + x. Proof. intros. destruct x,y. unfold eq. simpl. ring. Qed. Lemma mult_comm: forall x y, x * y == y * x. Proof. intros. destruct x,y. unfold eq. simpl. ring. Qed. Lemma min_comm: forall x y, min x y == min y x. Proof. intros. destruct x,y. unfold eq. simpl. apply Q.min_comm. Qed. Lemma max_comm: forall x y, max x y == max y x. Proof binop_comm _ _ Q.max_comm. Lemma plus_assoc: forall x y z, x + (y + z) == (x + y) + z. Proof binop_assoc _ _ Qplus_assoc. Lemma mult_assoc: forall x y z, x * (y * z) == (x * y) * z. Proof binop_assoc _ _ Qmult_assoc. Lemma max_assoc: forall x y z, max x (max y z) == max (max x y) z. Proof binop_assoc _ _ Q.max_assoc. Lemma min_assoc: forall x y z, min x (min y z) == min (min x y) z. Proof binop_assoc _ _ Q.min_assoc. Global Instance: Proper (eq ==> eq ==> eq) plus. Proof. unfold plus. apply _. Qed. Global Instance: Proper (eq ==> eq ==> eq) mult. Proof. unfold mult. apply _. Qed. (* Some additional properties: *) Lemma plus_0_l x: 0 + x == x. Proof. unfold eq. simpl. apply Qplus_0_l. Qed. Lemma plus_0_r x: x + 0 == x. Proof. unfold eq. simpl. apply Qplus_0_r. Qed. Lemma mult_1_l x: 1 * x == x. Proof. unfold eq. simpl. apply Qmult_1_l. Qed. Lemma mult_1_r x: x * 1 == x. Proof. unfold eq. simpl. apply Qmult_1_r. Qed. Lemma mult_0_l q: 0 * q == 0. Proof. unfold eq. simpl. apply Qmult_0_l. Qed. Lemma mult_0_r q: q * 0 == 0. Proof. unfold eq. simpl. apply Qmult_0_r. Qed. (* Inverses: *) Program Definition inv: T -> T := Qinv. Next Obligation. destruct x as [[[] ?] ?]; auto. Qed. Global Instance: Proper (eq ==> eq) inv. Proof. unfold eq. repeat intro. simpl. apply Qinv_comp. assumption. Qed. (* Coercions: *) Module Export coercions. Definition from_Qpos (q: Qpos): T := exist _ (proj1_sig q) (Qpos_nonneg q). Lemma from_Qpos_plus_homo (x y: Qpos) : from_Qpos (Qpos_plus x y) == from_Qpos x + from_Qpos y. Proof. reflexivity. Qed. Global Instance from_Qpos_Proper: Proper (QposEq ==> eq) from_Qpos. Proof. repeat intro. assumption. Qed. Definition from_nat (n: nat): T. Proof. exists (Z.of_nat n#1). unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. Defined. (* Definition to_Q: T -> Q := @proj1_sig Q (Qle 0). Global Coercion to_Q: T >-> Q. Global Instance: Proper (eq ==> Qeq) to_Q. Proof. repeat intro. assumption. Qed. *) End coercions. (* Misc: *) Program Definition hash (num: nat) (den: positive): T := Qmake (Z_of_nat num) den. Next Obligation. unfold Qle. simpl. rewrite Zmult_1_r. apply Zle_0_nat. Qed. Lemma min_case (P: T -> Type): (forall x y: T, x == y -> P x -> P y) -> forall n m, P n -> P m -> P (min n m). Proof with auto. intros. unfold min, binop. generalize (binop_obligation_1 Qmin Qmin_nonneg n m). apply Q.min_case; intros. pose proof q. rewrite <- H in H0. apply X with (exist (Qle 0) x H0)... apply X with n... reflexivity. apply X with m... reflexivity. Qed. Lemma proj1_sig_nonNeg (q: T): 0 <= `q. Proof. apply proj2_sig. Qed. #[global] Hint Immediate proj1_sig_nonNeg. Lemma rect (P: T -> Type) (P0: forall (d: positive) H, P (exist (Qle 0) (0#d) H)) (Pp: forall (n d: positive) H, P (exist (Qle 0) (Zpos n#d) H)): forall q, P q. Proof. intros [[qn qd] E]. destruct qn. apply P0. apply Pp. exfalso. apply E. reflexivity. Defined. Lemma Qpos_ind (P: T -> Prop) (Pwd: Proper (eq ==> iff) P) (P0: P 0) (Pp: forall q: Qpos, P (from_Qpos q)) : forall q, P q. Proof with auto. intro. apply rect; intros. apply (Pwd 0)... reflexivity. assert (0 < (Z.pos n # d)). reflexivity. apply (Pwd (from_Qpos (exist _ _ H0))). reflexivity. apply Pp. Qed. (* Note: We can't make something as nice as Qpos_positive_numerator_rect for QnonNeg because whereas Qpos contains a Qlt which contains a Zlt which is an equality between "comparison"'s, proofs of which are unique because comparison is decidable, QnonNeg contains a Qle which contains a Zle which is a negation of an equality between comparisons, proofs of which we cannot prove uniqueness of. *) (* Notations to be imported by clients: *) Module notations. Delimit Scope Qnn_scope with Qnn. Global Infix "==" := eq: Qnn_scope. Global Infix "<=" := le: Qnn_scope. Global Infix "<" := lt: Qnn_scope. Global Infix "+" := plus: Qnn_scope. Global Infix "*" := mult: Qnn_scope. Global Infix "#" := hash: Qnn_scope. Global Notation "0" := zero: Qnn_scope. Global Notation "1" := one: Qnn_scope. Global Notation QnonNeg := T. End notations. corn-8.20.0/model/structures/QposInf.v000066400000000000000000000115761473720167500176610ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Export QArith. Require Import CoRN.model.totalorder.QposMinMax. (** printing QposInf $\mathbb{Q}^{+}_{\infty}$ #Q+∞# *) (** printing QposInfinity $\infty$ #∞# *) (** The type of positive rational numbers, including positive infinity. *) Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope Qpos_scope. (** * [Qpos] We choose to define [QposInf] as the disjoint union of [Qpos] and an Infinity token. *) Inductive QposInf : Set := | Qpos2QposInf : Qpos -> QposInf | QposInfinity : QposInf. Bind Scope QposInf_scope with QposInf. Delimit Scope QposInf_scope with QposInf. (** Qpos2QposInf is an injection from [Qpos] to [QposInf] that we declare as a coercion. *) Coercion Qpos2QposInf : Qpos >-> QposInf. (** This bind operation is useful for lifting operations to work on [QposInf]. It will map [QposInfinity] to [QposInfinity]. *) Definition QposInf_bind (f : Qpos -> QposInf) (x:QposInf) := match x with | Qpos2QposInf x' => f x' | QposInfinity => QposInfinity end. Lemma QposInf_bind_id : forall x, QposInf_bind (fun e => e) x = x. Proof. intros [x|]; reflexivity. Qed. (** Equality *) Definition QposInfEq (a b:QposInf) := match a, b with | Qpos2QposInf x, Qpos2QposInf y => Qeq (proj1_sig x) (proj1_sig y) | QposInfinity, QposInfinity => True | _, _ => False end. Lemma QposInfEq_refl x : QposInfEq x x. Proof. destruct x as [x|]. apply Qeq_refl. simpl. trivial. Qed. Lemma QposInfEq_sym x y : QposInfEq x y -> QposInfEq y x. Proof. destruct x as [x|], y as [y|]; simpl; trivial. apply Qeq_sym. Qed. Lemma QposInfEq_trans x y z : QposInfEq x y -> QposInfEq y z -> QposInfEq x z. Proof. destruct x as [x|], y as [y|], z as [z|]; simpl; try tauto. apply Qeq_trans. Qed. Add Relation QposInf QposInfEq reflexivity proved by QposInfEq_refl symmetry proved by QposInfEq_sym transitivity proved by QposInfEq_trans as QposInfSetoid. #[global] Instance: Proper (QposEq ==> QposInfEq) Qpos2QposInf. Proof. intros x y H. exact H. Qed. #[global] Instance QposInf_bind_wd (f : Qpos -> QposInf) {f_wd : Proper (QposEq ==> QposInfEq) f} : Proper (QposInfEq ==> QposInfEq) (QposInf_bind f). Proof. intros [x|] [y|] E; simpl; auto. destruct E. destruct E. Qed. (** Addition *) Definition QposInf_plus (x y : QposInf) : QposInf := QposInf_bind (fun x' => QposInf_bind (fun y' => Qpos_plus x' y') y) x. #[global] Instance: Proper (QposInfEq ==> QposInfEq ==> QposInfEq) QposInf_plus. Proof with auto. intros [x1|] [y1|] E1 [x2|] [y2|] E2; simpl... apply Qplus_comp... Qed. (** Multiplication *) Definition QposInf_mult (x y : QposInf) : QposInf := QposInf_bind (fun x' => QposInf_bind (fun y' => Qpos_mult x' y') y) x. #[global] Instance: Proper (QposInfEq ==> QposInfEq ==> QposInfEq) QposInf_mult. Proof with auto. intros [x1|] [y1|] E1 [x2|] [y2|] E2; simpl... apply Qmult_comp... Qed. (** Order *) Definition QposInf_le (x y: QposInf) : Prop := match y with | QposInfinity => True | Qpos2QposInf y' => match x with | QposInfinity => False | Qpos2QposInf x' => proj1_sig x' <= proj1_sig y' end end. (** Minimum *) Definition QposInf_min (x y : QposInf) : QposInf := match x with | QposInfinity => y | Qpos2QposInf x' => match y with | QposInfinity => x' | Qpos2QposInf y' => Qpos2QposInf (Qpos_min x' y') end end. #[global] Instance: Proper (QposInfEq ==> QposInfEq ==> QposInfEq) QposInf_min. Proof with intuition. intros [x1|] [y1|] E1 [x2|] [y2|] E2; simpl in *... apply Qpos_min_compat_Proper... Qed. Lemma QposInf_min_lb_l : forall x y, QposInf_le (QposInf_min x y) x. Proof. intros [x|] [y|]; simpl; try auto. apply Qpos_min_lb_l. apply Qle_refl. Qed. Lemma QposInf_min_lb_r : forall x y, QposInf_le (QposInf_min x y) y. Proof. intros [x|] [y|]; simpl; try auto. apply Qpos_min_lb_r. apply Qle_refl. Qed. Infix "+" := QposInf_plus : QposInf_scope. Infix "*" := QposInf_mult : QposInf_scope. corn-8.20.0/model/structures/Qpossec.v000066400000000000000000000252271473720167500177150ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Qpos $\mathbb{Q}^{+}$ #Q+# *) From Coq Require Export QArith. From Coq Require Import Qpower. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.algebra.COrdFields2. From Coq Require Import Eqdep_dec. Require Import CoRN.tactics.CornTac. From Coq Require Import Qround. From Coq Require Import Qabs. Require Import CoRN.stdlib_omissions.Q. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Local Open Scope Q_scope. (** * [Qpos] *) Definition Qpos: Set := sig (Qlt 0). Program Definition QposMake (num den: positive): Qpos := num # den. Next Obligation. auto with *. Qed. Notation "a # b" := (QposMake a b) (at level 55, no associativity) : Qpos_scope. Bind Scope Qpos_scope with Qpos. Delimit Scope Qpos_scope with Qpos. Program Definition integral_Qpos (p: positive): Qpos := (p:Q). Coercion integral_Qpos: positive >-> Qpos. (** There is an injection from [Qpos] to [Q] that we make into a coercion. *) Definition QposAsQ: Qpos -> Q := @proj1_sig _ _. Coercion QposAsQ : Qpos >-> Q. (** Basic properties about [Qpos] *) Definition Qpos_prf : forall a:Qpos, 0 < a := @proj2_sig _ _. #[global] Hint Immediate Qpos_prf. Lemma Qpos_nonzero : forall x:Qpos, (x:Q)[#]0. Proof. intros ?. apply: pos_ap_zero. apply Qpos_prf. Qed. Lemma Qpos_nonzero' (q: Qpos): ~ q == 0. (* simpler variant that actually shows up as proof obligations *) Proof. apply Qpos_nonzero. Qed. #[global] Hint Immediate Qpos_nonzero'. Lemma Qpos_nonneg : forall a:Qpos, 0 <= a. Proof. intros [??]. auto with *. Qed. #[global] Hint Immediate Qpos_nonneg. Lemma Qopp_Qpos_neg (x: Qpos): -x < 0. Proof. apply Qopp_Qlt_0_r. auto. Qed. #[global] Hint Immediate Qopp_Qpos_neg. (** Any positive rational number can be transformed into a [Qpos]. *) Definition mkQpos: forall (a:Q) (p:0 < a), Qpos := @exist Q (Qlt 0). (* begin hide *) Arguments mkQpos [a]. (* end hide *) Lemma QposAsmkQpos : forall (a:Q) (p:0 sig (fun p: positive => Zpos p = z). destruct z; intros. intros. elim (Z.lt_irrefl _ H). exists p. reflexivity. exfalso. apply (Zlt_asym _ _ H). auto with *. Defined. (* todo: move this Qlt_uniq stuff elsewhere *) From Coq Require Eqdep_dec. Definition comparison_eq_dec (a b: comparison): { a = b } + { a <> b}. destruct a, b; try (left; reflexivity); try (right; discriminate). Defined. Lemma Zlt_uniq (a b: Z) (p q: (a < b)%Z): p = q. Proof. unfold Z.lt in *. destruct p. intros. apply (Eqdep_dec.K_dec_set comparison_eq_dec). reflexivity. Qed. Lemma Qlt_uniq (a b: Q) (p q: a < b): p = q. Proof. intros. apply Zlt_uniq. Qed. Program Definition Qpos_as_positive_ratio (q: Qpos): sig (fun ps: positive * positive => q = QposMake (fst ps) (snd ps)) := (positive_Z (Qnum q) _, Qden q). Next Obligation. destruct q as [[??] ?]. unfold Qlt in *. simpl in *. auto with *. Qed. Next Obligation. destruct q as [[??] ?]. simpl. destruct positive_Z. simpl. subst. unfold QposMake. f_equal. apply Qlt_uniq. Qed. Lemma Qpos_positive_numerator_rect (P: Qpos -> Type): (forall (a b: positive), P (a # b)%Qpos) -> forall q, P q. Proof. intros H q. destruct (Qpos_as_positive_ratio q). subst. apply H. Defined. Lemma QposAsQposMake : forall a b, (QposAsQ (QposMake a b)) = (Zpos a)#b. Proof. trivial. Qed. (* begin hide *) #[global] Hint Rewrite QposAsmkQpos QposAsQposMake : QposElim. (* end hide *) (** *** Equality *) Definition QposEq (a b:Qpos) := Qeq a b. #[global] Instance Qpos_default : @DefaultRelation Qpos QposEq | 2 := {}. Add Relation Qpos QposEq reflexivity proved by (fun (x:Qpos) => Qeq_refl x) symmetry proved by (fun (x y:Qpos) => Qeq_sym x y) transitivity proved by (fun (x y z:Qpos) => Qeq_trans x y z) as QposSetoid. Definition QposAp (a b:Qpos) := Qap a b. Definition Qpos_PI (a b: Qpos): (a: Q) = b -> a = b. Proof. destruct a, b. simpl. intros. subst. f_equal. apply Qlt_uniq. Qed. (** *** Addition *) Program Definition Qpos_plus (x y:Qpos) : Qpos := Qplus x y. Next Obligation. apply: plus_resp_pos; apply Qpos_prf. Qed. Infix "+" := Qpos_plus : Qpos_scope. (* begin hide *) Add Morphism Qpos_plus : Qpos_plus_wd. Proof. intros x1 x2 Hx y1 y2 Hy. unfold QposEq in *. unfold Qpos_plus. simpl. apply Qplus_comp; assumption. Qed. (* end hide *) Lemma Q_Qpos_plus : forall (x y:Qpos), ((x + y)%Qpos:Q)=(x:Q)+(y:Q). Proof. trivial. Qed. (* begin hide *) #[global] Hint Rewrite Q_Qpos_plus : QposElim. (* end hide *) (** *** One *) Program Definition Qpos_one : Qpos := 1. Next Obligation. auto with qarith. Qed. Notation "1" := Qpos_one : Qpos_scope. Lemma Q_Qpos_one : (1%Qpos:Q)=(1:Q). Proof. trivial. Qed. (* begin hide *) #[global] Hint Rewrite Q_Qpos_one : QposElim. (* end hide *) (** *** Multiplication *) Program Definition Qpos_mult (x y:Qpos) : Qpos := Qmult x y. Infix "*" := Qpos_mult : Qpos_scope. (* begin hide *) Add Morphism Qpos_mult : Qpos_mult_wd. Proof. intros x1 x2 Hx y1 y2 Hy. unfold QposEq in *. unfold Qpos_mult. simpl. apply Qmult_comp; assumption. Qed. (* end hide *) Lemma Q_Qpos_mult : forall (x y:Qpos), ((x * y)%Qpos:Q)=(x:Q)*(y:Q). Proof. trivial. Qed. (* begin hide *) #[global] Hint Rewrite Q_Qpos_mult : QposElim. (* end hide *) (** *** Inverse *) Program Definition Qpos_inv (x:Qpos): Qpos := / x. Next Obligation. apply Qinv_lt_0_compat. destruct x. assumption. Qed. (* begin hide *) Add Morphism Qpos_inv : Qpos_inv_wd. Proof. intros [x P] [y Q] E. unfold QposEq in *. simpl in *. rewrite E. reflexivity. Qed. (* end hide *) Lemma Q_Qpos_inv : forall (x:Qpos), Qpos_inv x = / x :> Q. Proof. trivial. Qed. #[global] Hint Rewrite Q_Qpos_inv : QposElim. Notation "a / b" := (Qpos_mult a (Qpos_inv b)) : Qpos_scope. (** *** Tactics These tactics solve Ring and Field equations over [Qpos] by converting them to problems over [Q]. *) Ltac QposRing := unfold canonical_names.equiv, QposEq; autorewrite with QposElim; ring. Ltac QposField := unfold canonical_names.equiv, QposEq; autorewrite with QposElim; field. (** This is a standard way of decomposing a rational b that is greater than a into a plus a positive value c. *) Lemma Qpos_lt_plus : forall (a b:Q), a< b -> {c:Qpos | b==(a+c)}. Proof. intros. assert (0 Qinv_power. symmetry; assumption. Qed. Definition Qpos_power (x:Qpos) (z:Z) : Qpos. Proof. apply mkQpos with (x^z). apply Qpos_power_pos. Defined. Infix "^" := Qpos_power : Qpos_scope. (* begin hide *) #[global] Instance Qpos_power_wd: Proper (QposEq ==> @eq Z ==> QposEq) Qpos_power. Proof. intros x1 x2 Hx y1 y2 Hy. unfold QposEq in *. unfold Qpos_power. autorewrite with QposElim. simpl. now rewrite Hx, Hy. Qed. (* end hide *) Lemma Q_Qpos_power : forall (x:Qpos) z, ((x^z)%Qpos:Q)==(x:Q)^z. Proof. intros. unfold Qpos_power. autorewrite with QposElim. reflexivity. Qed. #[global] Hint Rewrite Q_Qpos_power : QposElim. (** *** Summing lists *) Definition QposSum (l:list Qpos) : Q := fold_right (fun (x:Qpos) (y:Q) => x+y) ([0]:Q) l. Lemma QposSumNonNeg : forall l, 0 <= QposSum l. Proof. induction l. apply: leEq_reflexive. simpl. apply: plus_resp_nonneg. apply: less_leEq. apply Qpos_prf. assumption. Qed. (** A version of [Qred] for [Qpos]. *) Lemma QposRed_prf : forall (a:Q), (0 < a) -> (0 < Qred a). Proof. intros a Ha. rewrite -> Qred_correct. assumption. Qed. Definition QposRed (a:Qpos) : Qpos := mkQpos (QposRed_prf a (Qpos_prf a)). #[global] Instance QposRed_complete: Proper (QposEq ==> eq) QposRed. Proof. intros p q H. unfold QposRed. generalize (QposRed_prf p (Qpos_prf p)). generalize (QposRed_prf q (Qpos_prf q)). rewrite (Qred_complete p q H). unfold Qlt, Z.lt. intros A B. assert (X:forall x y : comparison, x = y \/ x <> y). decide equality. rewrite (eq_proofs_unicity X A B). reflexivity. Qed. Lemma QposRed_correct : forall p, QposRed p == p. Proof. unfold QposRed. intros p. simpl. apply Qred_correct. Qed. (* For a Qpos we know its ceiling is positive: *) Definition QposCeiling (q: Qpos): positive := match Qceiling q with | Zpos p => p | _ => 1%positive (* impossible *) end. Lemma QposCeiling_Qceiling (q: Qpos): (QposCeiling q: Z) = Qceiling q. Proof with auto with *. unfold QposCeiling. pose proof Qle_ceiling q. destruct (Qceiling q); try reflexivity; exfalso; destruct q; simpl in *. apply (Qlt_not_le 0 x q)... apply (Qlt_irrefl 0). apply Qlt_le_trans with x... apply Qle_trans with (Zneg p)... Qed. (* This function is only defined for non zero elements, so in case of 0, we yield a dummy *) Definition QabsQpos (x : Q) : Qpos := match x with | 0 # _ => (1%Qpos) | (Zpos an) # ad => (an # ad)%Qpos | (Zneg an) # ad => (an # ad)%Qpos end. Lemma QabsQpos_correct x : ~x == 0 -> QabsQpos x == Qabs x. Proof with auto with qarith. intros E. destruct x as [n d]. simpl. destruct n... destruct E... Qed. Lemma QabsQpos_Qpos (x : Qpos) : QposEq (QabsQpos x) x. Proof with auto with qarith. unfold QposEq. rewrite QabsQpos_correct... apply Qabs_pos... Qed. corn-8.20.0/model/structures/Qsec.v000066400000000000000000000210701473720167500171630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Q %\ensuremath{\mathbb{Q}}% *) (** printing QZERO %\ensuremath{0_\mathbb{Q}}% #0Q# *) (** printing QONE %\ensuremath{1_\mathbb{Q}}% #1Q# *) (** printing QTWO %\ensuremath{2_\mathbb{Q}}% #2Q# *) (** printing QFOUR %\ensuremath{4_\mathbb{Q}}% #4Q# *) Require Export CoRN.logic.CLogic. From Coq Require Import Arith. From Coq Require Import Peano_dec. Require Import CoRN.model.structures.Zsec. From Coq Require Export QArith. Require Import CoRN.stdlib_omissions.Q. Close Scope Q_scope. Local Open Scope Q_scope. (** * [Q] ** About [Q] We define the structure of rational numbers as follows. First of all, it consists of the set of rational numbers, defined as the set of pairs $\langle a,n\rangle$#⟨a,n⟩# with [a:Z] and [n:positive]. Intuitively, $\langle a,n\rangle$#⟨a,n⟩# represents the rational number [a[/]n]. Then there is the equality on [Q]: $\langle a,m\rangle=\langle b,n\rangle$#⟨a,m⟩=⟨b,n⟩# iff [an [=] bm]. We also define apartness, order, addition, multiplication, opposite, inverse an de constants 0 and 1. *) #[global] Instance Q_default : @DefaultRelation Q Qeq | 2 := {}. Definition Qap (x y : Q) := ~(Qeq x y). Infix "/=" := Qap (no associativity, at level 70) : Q_scope. Definition Qinv_dep (x : Q) (x_ : Qap x 0) := Qinv x. (** *** Apartness *) Lemma Q_non_zero : forall x : Q, (x/=0) -> Qnum x <> 0%Z. Proof. firstorder auto with qarith zarith. Qed. Lemma ap_Q_irreflexive0 : forall x : Q, Not (x/=x). Proof. firstorder. Qed. Lemma ap_Q_symmetric0 : forall x y : Q, (x/=y) -> y/=x. Proof. firstorder auto with crelations. Qed. Lemma ap_Q_cotransitive0 : forall x y : Q, (x/=y) -> forall z : Q, (x/=z) or (z/=y). Proof. intros x y X z. unfold Qap in |- *. case (Qeq_dec x z). intro e. right. red in |- *. intro H0. apply X. exact (Qeq_trans x z y e H0). intros n. left. intro H. elim n. auto. Qed. Lemma ap_Q_tight0 : forall x y : Q, Not (x/=y) <-> x==y. Proof. intros x y. red in |- *. split. unfold Qap in |- *. intro. case (Qeq_dec x y). intro e. assumption. intro n. elim H. intro H0. elim n. assumption. intro H. unfold Qap in |- *. red in |- *. intro H0. elim H0. assumption. Qed. (** *** Addition *) Lemma Qplus_strext0 : forall x1 x2 y1 y2 : Q, (x1+y1/=x2+y2) -> (x1/=x2) or (y1/=y2). Proof. unfold Qap in |- *. intros x1 x2 y1 y2 X. case (Qeq_dec x1 x2). intro e. right. red in |- *. intro H0. apply X. apply Qplus_comp; auto. tauto. Qed. (** *** Multiplication *) Lemma Qmult_strext0 : forall x1 x2 y1 y2 : Q, (x1*y1/=x2*y2) -> (x1/=x2) or (y1/=y2). Proof. intros x1 x2 y1 y2 X. case (Qeq_dec x1 x2). right. intros ?. apply X. apply Qmult_comp; auto. tauto. Qed. Lemma nonZero : forall x : Q, ~(x==0) -> ~(Qmake (Z.sgn (Qnum x) * Qden x)%Z (posZ (Qnum x))==0). Proof. intro x. unfold Qeq in |- *. unfold Qnum at 2 6 in |- *. repeat rewrite Zmult_0_l. unfold Qden at 1 3 in |- *. repeat rewrite Zplus_0_l. repeat rewrite Zmult_1_r. simpl in |- *. intro H. cut (Z.sgn (Qnum x) <> 0%Z). intro H0. cut (Zpos (Qden x) <> 0%Z). intro H1. intro H2. elim H0. exact (Zmult_integral_l (Qden x) (Z.sgn (Qnum x)) H1 H2). apply Zgt_not_eq. auto with zarith. apply Zsgn_3. intro; elim H; auto. Qed. (** *** Inverse *) Lemma Qinv_strext : forall (x y : Q) x_ y_, ~(Qinv_dep x x_==Qinv_dep y y_) -> ~(x==y). Proof. firstorder using Qinv_comp. Qed. Lemma Qinv_is_inv : forall (x : Q) (Hx : x/=0), (x*Qinv_dep x Hx==1) /\ (Qinv_dep x Hx*x==1). Proof. intros x Hx. split. now apply (Qmult_inv_r x). rewrite -> Qmult_comm. now apply (Qmult_inv_r x). Qed. (** *** Less-than *) Program Definition Zdec_sign (z: Z): (z < Z0)%Z + (Z0 < z)%Z + (z = Z0) := match z with | Zneg p => inl _ (inl _ _) | Zpos p => inl _ (inr _ _) | Z0 => inr _ _ end. Next Obligation. reflexivity. Qed. Next Obligation. reflexivity. Qed. Program Definition Qdec_sign (q: Q): (q < 0) + (0 < q) + (q == 0) := match Zdec_sign (Qnum q) with | inl (inr H) => inl _ (inr _ _) | inl (inl _) => inl _ (inl _ _) | inr _ => inr _ _ end. Next Obligation. unfold Qlt. simpl. rewrite Zmult_1_r. assumption. Qed. Next Obligation. unfold Qlt. simpl. rewrite Zmult_1_r. assumption. Qed. Next Obligation. unfold Qeq. simpl. rewrite Zmult_1_r. assumption. Qed. Lemma Qlt_strext_unfolded : forall x1 x2 y1 y2 : Q, (x1 (x2 Not (y-> Q. Lemma injz_plus : forall m n : Z, (inject_Z (m + n):Q)==(inject_Z m:Q)+inject_Z n. Proof. intros m n. unfold inject_Z in |- *. simpl in |- *. unfold Qeq in |- *. unfold Qnum at 1 in |- *. unfold Qden at 2 in |- *. replace ((m + n) * 1)%Z with (m + n)%Z. replace (Qnum (Qmake m 1+Qmake n 1)%Q * 1)%Z with (Qnum (Qmake m 1+Qmake n 1)). unfold Qplus in |- *. simpl in |- *. ring. ring. ring. Qed. Lemma injZ_One : (inject_Z 1:Q)==1. Proof. reflexivity. Qed. (** We can always find a natural Qnumber that is bigger than a given rational Qnumber. *) Theorem Q_is_archemaedian0 : forall x : Q, {n : positive | x ~ y < x. Proof. firstorder using Qle_not_lt, Qnot_lt_le. Qed. Lemma Qge_is_not_gt : forall x y : Q, x >= y <-> y <= x. Proof. firstorder. Qed. Lemma Qgt_is_lt : forall x y : Q, x > y IFF y < x. Proof. firstorder. Qed. Lemma QNoDup_CNoDup_Qap(l: list Q): QNoDup l IFF CNoDup Qap l. Proof with auto. induction l; simpl; split; intro... apply NoDup_nil. split. apply IHl. inversion_clear H... apply (CForall_prop _). intros ? A. inversion_clear H. intro E. apply H0. rewrite E. apply in_map... apply NoDup_cons. 2: firstorder. intro. destruct (proj1 (in_map_iff _ _ _) H) as [x [H0 H1]]. destruct X. apply (snd (@CForall_prop Q (Qap a) l) c0 x)... rewrite <- (Qred_correct x). rewrite H0. symmetry. apply Qred_correct. Qed. corn-8.20.0/model/structures/StepQsec.v000066400000000000000000000234011473720167500200170ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.model.metric2.Qmetric. From Coq Require Export QArith. Require Export CoRN.metric2.StepFunctionSetoid. From Coq Require Import Qabs. From Coq Require Import Bool. Require Import CoRN.tactics.CornTac. Require Import CoRN.logic.CornBasics. Require Import CoRN.algebra.RSetoid. Set Implicit Arguments. Local Open Scope setoid_scope. Local Open Scope sfstscope. Section QS. Definition QS : RSetoid := Build_RSetoid Q_Setoid. Definition QabsS : QS-->QS. Proof. exists Qabs. abstract( simpl; intros x1 x2 Hx; rewrite -> Hx; reflexivity). Defined. Definition Qplus0 : QS -> QS --> QS. Proof. intros q. exists (Qplus q). abstract ( simpl; intros x1 x2 Hx; rewrite -> Hx; reflexivity). Defined. Definition QplusS : QS --> QS --> QS. Proof. exists (Qplus0). abstract ( intros x1 x2 Hx y; simpl in *; rewrite -> Hx; reflexivity). Defined. Definition QoppS : QS --> QS. Proof. exists (Qopp). abstract ( simpl; intros x1 x2 Hx; simpl in *; rewrite -> Hx; reflexivity). Defined. Definition Qminus0 : QS -> QS --> QS. Proof. intros q. exists (Qminus q). abstract ( simpl; intros x1 x2 Hx; rewrite -> Hx; reflexivity). Defined. Definition QminusS : QS --> QS --> QS. Proof. exists (Qminus0). abstract ( intros x1 x2 Hx y; simpl in *; rewrite -> Hx; reflexivity). Defined. Definition QscaleS : QS -> QS --> QS. Proof. intros q. exists (Qmult q). abstract ( intros x1 x2 Hx; simpl in *; rewrite -> Hx; reflexivity). Defined. Definition QmultS : QS --> QS --> QS. Proof. exists (QscaleS). abstract ( intros x1 x2 Hx y; simpl in *; rewrite -> Hx; reflexivity). Defined. Definition Qle0 : QS -> QS --> iffSetoid. Proof. intros q. exists (Qle q). abstract ( simpl; intros x1 x2 Hx; rewrite -> Hx; reflexivity). Defined. Definition QleS : QS --> QS --> iffSetoid. Proof. exists (Qle0). abstract ( intros x1 x2 Hx y; simpl in *; rewrite -> Hx; reflexivity). Defined. End QS. Notation "'StepQ'" := (StepF QS) : StepQ_scope. #[global] Instance StepQ_default : @DefaultRelation (StepF QS) (@StepF_eq QS) | 2 := {}. Delimit Scope StepQ_scope with SQ. Bind Scope StepQ_scope with StepF. Local Open Scope StepQ_scope. Definition StepQplus (s t:StepQ) : StepQ := QplusS ^@> s <@> t. Definition StepQopp (s:StepQ) : StepQ := QoppS ^@> s. Definition StepQminus (s t:StepQ) : StepQ := QminusS ^@> s <@> t. Definition StepQmult (s t:StepQ) : StepQ := QmultS ^@> s <@> t. Notation "x + y" := (StepQplus x y) : StepQ_scope. Notation "- x" := (StepQopp x) : StepQ_scope. Notation "x - y" := (StepQminus x y) : StepQ_scope. Notation "x * y" := (StepQmult x y) : StepQ_scope. Add Morphism StepQplus with signature (@StepF_eq QS) ==> (@StepF_eq QS) ==> (@StepF_eq QS) as StepQplus_wd. Proof. intros. unfold StepQplus. rewrite -> H. rewrite -> H0. reflexivity. Qed. Add Morphism StepQopp with signature (@StepF_eq QS) ==> (@StepF_eq QS) as StepQopp_wd. Proof. intros. unfold StepQopp. rewrite -> H. reflexivity. Qed. Add Morphism StepQminus with signature (@StepF_eq QS) ==> (@StepF_eq QS) ==> (@StepF_eq QS) as StepQminus_wd. Proof. intros. unfold StepQminus. rewrite -> H. rewrite -> H0. reflexivity. Qed. Add Morphism StepQmult with signature (@StepF_eq QS) ==> (@StepF_eq QS) ==> (@StepF_eq QS) as StepQmult_wd. Proof. intros. unfold StepQmult. rewrite -> H. rewrite -> H0. reflexivity. Qed. Definition StepQsrt : (@ring_theory (StepQ) (constStepF (0:QS)) (constStepF (1:QS)) StepQplus StepQmult StepQminus StepQopp (@StepF_eq QS)). Proof. constructor; intros; unfold StepF_eq, StepQplus, StepQminus, StepQopp, StepQmult; rewriteStepF; set (g:=@st_eqS QS). set (z:=QplusS 0). set (f:=(join (compose g z))). cut (StepFfoldProp (f ^@> x)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map. intros a. unfold f; simpl; ring. set (f:=ap (compose (@ap _ _ _) (compose (compose g) QplusS)) (flip (QplusS))). cut (StepFfoldProp (f ^@> x <@> y)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map2. intros a b. change (a + b == b + a)%Q. ring. set (f:=ap (compose (@ap _ _ _) (compose (compose (compose (compose (@ap _ _ _)) (@compose _ _ _) g)) (compose (flip (@compose _ _ _) QplusS) (compose (@compose _ _ _) QplusS)))) (compose (compose QplusS) QplusS)). cut (StepFfoldProp (f ^@> x <@> y <@> z)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map3. intros a b c. change (a + (b + c) == a + b + c)%Q. ring. set (z:=(QmultS 1)). set (f:=(join (compose g z))). cut (StepFfoldProp (f ^@> x)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map. intros a. unfold f; simpl; ring. set (f:=ap (compose (@ap _ _ _) (compose (compose g) QmultS)) (flip (QmultS))). cut (StepFfoldProp (f ^@> x <@> y)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map2. intros a b. change (a * b == b * a)%Q. ring. set (f:=ap (compose (@ap _ _ _) (compose (compose (compose (compose (@ap _ _ _)) (@compose _ _ _) g)) (compose (flip (@compose _ _ _) QmultS) (compose (@compose _ _ _) QmultS)))) (compose (compose QmultS) QmultS)). cut (StepFfoldProp (f ^@> x <@> y <@> z)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map3. intros a b c. change (a * (b * c) == a * b * c)%Q. ring. set (f:= ap (compose (@ap _ _ _) (compose (compose (compose (@ap _ _ _) (compose (compose g) QmultS))) QplusS)) (compose (flip (@compose _ _ _) QmultS) (compose (@ap _ _ _) (compose (compose QplusS) QmultS)))). cut (StepFfoldProp (f ^@> x <@> y <@> z)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map3. intros a b c. change ((a + b) * c == a*c + b*c)%Q. ring. set (f:= ap (compose (@ap _ _ _) (compose (compose g) QminusS)) (compose (flip (@compose _ _ _) QoppS) QplusS)). cut (StepFfoldProp (f ^@> x <@> y)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map2. intros a b. change (a - b == a + - b)%Q. ring. set (z:=(0:QS)). set (f:= compose (flip g z) (ap QplusS QoppS)). cut (StepFfoldProp (f ^@> x)). unfold f; evalStepF; tauto. apply StepFfoldPropForall_Map. intros a. change (a + - a == 0)%Q. ring. Qed. Definition StepQisZero:(StepQ)->bool:=(StepFfold (fun (x:QS) => Qeq_bool x 0) (fun _ x y => x && y)). Definition StepQeq_bool (x y:StepQ) : bool := StepQisZero (x-y). Lemma StepQeq_bool_correct : forall x y, StepQeq_bool x y = true -> x == y. Proof. intros x y H. destruct StepQsrt. rewrite <- (Radd_0_l x). rewrite <- (Ropp_def y). transitivity (y + (constStepF (0:QS))). set (z:=constStepF (X:=QS) 0). rewrite <- (Radd_assoc). apply StepQplus_wd. reflexivity. rewrite -> Radd_comm. rewrite <- Rsub_def. unfold StepF_eq. revert H. unfold StepQeq_bool. generalize (x-y). intros s H. induction s. apply: Qeq_bool_eq;assumption. symmetry in H. destruct (andb_true_eq _ _ H) as [H1 H2]. split. apply IHs1; symmetry; assumption. apply IHs2; symmetry; assumption. rewrite -> Radd_comm. apply Radd_0_l. Qed. Lemma StepQRing_Morphism : ring_eq_ext StepQplus StepQmult StepQopp (@StepF_eq QS). Proof. split. apply: StepQplus_wd. apply: StepQmult_wd. apply: StepQopp_wd. Qed. Ltac isStepQcst t := match t with | constStepF ?q => isQcst q | glue ?o ?l ?r => match isStepQcst l with |true => match isStepQcst r with |true => isQcst o |false => false end |false => false end | _ => false end. Ltac StepQcst t := match isStepQcst t with true => t | _ => NotConstant end. Add Ring StepQRing : StepQsrt (decidable StepQeq_bool_correct, setoid (StepF_Sth QS) StepQRing_Morphism, constants [StepQcst]). Definition StepQabs (s:StepQ) : StepQ := QabsS ^@> s. Add Morphism StepQabs with signature (@StepF_eq QS) ==> (@StepF_eq QS) as StepQabs_wd. Proof. intros. unfold StepQabs. rewrite -> H. reflexivity. Qed. (** ** A Partial Order on Step Functions. *) Definition StepQ_le x y := (StepFfoldProp (QleS ^@> x <@> y)). (* begin hide *) Add Morphism StepQ_le with signature (@StepF_eq QS) ==> (@StepF_eq QS) ==> iff as StepQ_le_wd. Proof. unfold StepQ_le. intros x1 x2 Hx y1 y2 Hy. rewrite -> Hx. rewrite -> Hy. reflexivity. Qed. (* end hide *) Notation "x <= y" := (StepQ_le x y) (at level 70) : sfstscope. Lemma StepQ_le_refl:forall x, (x <= x). Proof. intros x. unfold StepQ_le. cut (StepFfoldProp (join QleS ^@> x)). evalStepF. tauto. apply StepFfoldPropForall_Map. intros. simpl. auto with *. Qed. Lemma StepQ_le_trans:forall x y z, (x <= y)-> (y <= z) ->(x <= z). Proof. intros x y z. unfold StepQ_le. intros H. apply StepF_imp_imp. revert H. apply StepF_imp_imp. unfold StepF_imp. pose (f:= ap (compose (@ap _ _ _) (compose (compose (compose (@compose _ _ _) imp)) QleS)) (compose (flip (compose (@ap _ _ _) (compose (compose imp) QleS))) QleS)). cut (StepFfoldProp (f ^@> x <@> y <@> z)). unfold f. evalStepF. tauto. apply StepFfoldPropForall_Map3. intros a b c Hab Hbc. clear f. simpl in *. eauto with qarith. Qed. Lemma StepQabsOpp : forall x, StepQabs (-x) == StepQabs (x). Proof. intros x. unfold StepF_eq. set (g:=(@st_eqS QS)). set (f:=(ap (compose g (compose QabsS QoppS)) QabsS)). cut (StepFfoldProp (f ^@> x)). unfold f. evalStepF. tauto. apply StepFfoldPropForall_Map. intros a. apply: Qabs_opp. Qed. Lemma StepQabs_triangle : forall x y, StepQabs (x+y) <= StepQabs x + StepQabs y. Proof. intros x y. set (f:=(ap (compose ap (compose (compose (compose QleS QabsS)) QplusS)) (compose (flip (@compose _ _ _) QabsS) (compose QplusS QabsS)))). cut (StepFfoldProp (f ^@> x <@> y)). unfold f. evalStepF. tauto. apply StepFfoldPropForall_Map2. intros a b. apply: Qabs_triangle. Qed. corn-8.20.0/model/structures/Zsec.v000066400000000000000000000216741473720167500172060ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing {#Z} %\ensuremath{\mathrel\#_{\mathbb Z}}% *) From Coq Require Export ZArith. Require Import CoRN.logic.CLogic. From Coq Require Import Setoid. #[global] Instance Z_default : @DefaultRelation Z (@eq Z) | 2 := {}. (** * [Z] ** About [Z] We consider the implementation of integers as signed binary sequences (the datatype [Z] as defined in [ZArith], in the standard library). *** Apartness We define the apartness as the negation of the Leibniz equality: *) Definition ap_Z (x y : Z) := ~ (x = y). Infix "{#Z}" := ap_Z (no associativity, at level 90). (** Some properties of apartness: *) Lemma ap_Z_irreflexive0 : forall x : Z, Not (x{#Z}x). Proof. intro x. unfold ap_Z in |- *. red in |- *. intro H. elim H. reflexivity. Qed. Lemma ap_Z_symmetric0 : forall x y : Z, (x{#Z}y) -> y{#Z}x. Proof. intros x y H. unfold ap_Z in |- *. red in |- *. intro H0. apply H. auto. Qed. Lemma ap_Z_cotransitive0 : forall x y : Z, (x{#Z}y) -> forall z : Z, (x{#Z}z) or (z{#Z}y). Proof. intros x y X z. unfold ap_Z in |- *. case (Z.eq_dec x z). intro e. right. rewrite <- e. assumption. intro n. left. assumption. Qed. Lemma ap_Z_tight0 : forall x y : Z, Not (x{#Z}y) <-> x = y. Proof. intros x y. red in |- *. split. unfold ap_Z in |- *. intro H. case (Z.eq_dec x y). intro e. assumption. contradiction. unfold ap_Z, Not. contradiction. Qed. Lemma ONE_neq_O : 1{#Z}0. Proof. apply ap_Z_symmetric0. red in |- *. apply Zorder.Zlt_not_eq. apply Z.gt_lt. exact (Zorder.Zgt_pos_0 1). Qed. (** *** Addition Some properties of the addition. [Zplus] is also defined in the standard library. *) Lemma Zplus_wd0 : forall x1 x2 y1 y2 : Z, x1 = x2 -> y1 = y2 -> (x1 + y1)%Z = (x2 + y2)%Z. Proof. intros x1 x2 y1 y2 H H0. rewrite H. rewrite H0. auto. Qed. Lemma Zplus_strext0 : forall x1 x2 y1 y2 : Z, (x1 + y1{#Z}x2 + y2) -> (x1{#Z}x2) or (y1{#Z}y2). Proof. intros x1 x2 y1 y2 H. unfold ap_Z in |- *. unfold ap_Z in H. case (Z.eq_dec x1 x2). intro e. right. red in |- *. intro H0. apply H. exact (f_equal2 Zplus e H0). auto. Qed. (** *** Multiplication The multiplication is extensional: *) Lemma Zmult_strext0 : forall x1 x2 y1 y2 : Z, (x1 * y1{#Z}x2 * y2) -> (x1{#Z}x2) or (y1{#Z}y2). Proof. unfold ap_Z in |- *. intros x1 x2 y1 y2 H. case (Z.eq_dec x1 x2). intro e. right. red in |- *. intro H0. apply H. exact (f_equal2 Zmult e H0). auto. Qed. (** *** Miscellaneous *) Definition posZ (x : Z) : positive := match x with | Z0 => 1%positive | Zpos p => p | Zneg p => p end. Lemma a_very_specific_lemma1 : forall a b c d e f : Z, c <> 0%Z -> (a * b)%Z = (c * d)%Z -> (c * e)%Z = (f * b)%Z -> (a * e)%Z = (f * d)%Z. Proof. intros. cut ((a * (c * e))%Z = (a * (f * b))%Z). intro. cut ((f * (a * b))%Z = (f * (c * d))%Z). intro. cut ((a * (f * b))%Z = (f * (a * b))%Z). intro. cut ((a * (c * e))%Z = (f * (a * b))%Z). intro. cut ((a * (c * e))%Z = (f * (c * d))%Z). intro. cut ((a * (c * e))%Z = (c * (a * e))%Z). intro. cut ((f * (c * d))%Z = (c * (f * d))%Z). intro. cut ((c * (a * e))%Z = (a * (c * e))%Z). intro. cut ((c * (a * e))%Z = (f * (c * d))%Z). intro. cut ((c * (a * e))%Z = (c * (f * d))%Z). intro. exact (Zmult_absorb c (a * e) (f * d) H H11). cut ((f * (c * d))%Z = (c * (f * d))%Z). intro. exact (trans_eq H10 H11). exact (Zmult_permute f c d). exact (trans_eq H9 H6). exact (Zmult_permute c a e). exact (Zmult_permute f c d). exact (Zmult_permute a c e). exact (trans_eq H5 H3). exact (trans_eq H2 H4). exact (Zmult_permute a f b). cut (f = f). intro. exact (f_equal2 Zmult H3 H0). trivial. cut (a = a). intro. exact (f_equal2 Zmult H2 H1). trivial. Qed. Lemma a_very_specific_lemma2 : forall a b c d s r t u : Z, (a * r)%Z = (b * s)%Z -> (c * u)%Z = (d * t)%Z -> ((a * t + c * s) * (r * u))%Z = ((b * u + d * r) * (s * t))%Z. Proof. intros. replace ((a * t + c * s) * (r * u))%Z with (a * r * t * u + c * u * s * r)%Z by ring. rewrite H in |- *; rewrite H0 in |- *; ring. Qed. Lemma a_very_specific_lemma3 : forall (a b c d : Z) (s r t u : positive), (a * r)%Z = (b * s)%Z -> (c * u)%Z = (d * t)%Z -> ((a * t + c * s) * (r * u)%positive)%Z = ((b * u + d * r) * (s * t)%positive)%Z. Proof. intros a b c d s r t u. intros. change (((a * t + c * s) * (r * u))%Z = ((b * u + d * r) * (s * t))%Z) in |- *. apply a_very_specific_lemma2; trivial. Qed. Lemma a_very_specific_lemma4 : forall a b c m n p : Z, ((a * (n * p) + (b * p + c * n) * m) * (m * n * p))%Z = (((a * n + b * m) * p + c * (m * n)) * (m * (n * p)))%Z. Proof. intros. ring. Qed. Lemma a_very_specific_lemma5 : forall (a b c : Z) (m n p : positive), ((a * (n * p)%positive + (b * p + c * n) * m) * (m * n * p)%positive)%Z = (((a * n + b * m) * p + c * (m * n)%positive) * (m * (n * p))%positive)%Z. Proof. intros. change (((a * (n * p) + (b * p + c * n) * m) * (m * n * p))%Z = (((a * n + b * m) * p + c * (m * n)) * (m * (n * p)))%Z) in |- *. apply a_very_specific_lemma4. Qed. Lemma posZ_pos : forall x : Z, (x > 0)%Z -> posZ x = x :>Z. Proof. simple induction x; intros; reflexivity || inversion H. Qed. Lemma posZ_neg : forall x : Z, (x < 0)%Z -> posZ x = (- x)%Z :>Z. Proof. simple induction x; intros; reflexivity || inversion H. Qed. Lemma posZ_Zsgn : forall x : Z, x <> 0%Z -> (Z.sgn x * posZ x)%Z = x. Proof. simple induction x; intros; reflexivity. Qed. Lemma posZ_Zsgn2 : forall x : Z, x <> 0%Z -> (Z.sgn x * x)%Z = posZ x. Proof. simple induction x; intros; [ elim H | simpl in |- * | simpl in |- * ]; reflexivity. Qed. Lemma a_very_specific_lemma5' : forall (m n p : positive) (a b c : Z), (a * n < b * m)%Z -> (b * p)%Z = (c * n)%Z -> (a * p < c * m)%Z. Proof. intros. case (dec_eq b 0). intro. rewrite H1 in H0. simpl in H0. cut (c = 0%Z). intro. rewrite H2. rewrite H1 in H. simpl in H. simpl in |- *. apply Z.gt_lt. cut (a * 0 > a * p)%Z. intro. rewrite Zmult_0_r in H3. assumption. apply Zlt_conv_mult_l. apply Z.gt_lt. cut (- (0) > - - a)%Z. simpl in |- *. rewrite Z.opp_involutive. trivial. apply Zlt_opp. apply Zmult_gt_0_lt_0_reg_r with (n := n). auto with zarith. rewrite Zopp_mult_distr_l_reverse. cut (- (a * n) > - (0))%Z. simpl in |- *. intro. apply Z.gt_lt. trivial. apply Zlt_opp. assumption. apply Z.gt_lt. auto with zarith. apply Zmult_integral_l with (n := n). apply Zgt_not_eq. auto with zarith. apply sym_eq. assumption. intro. case (not_Zeq b 0 H1). (* y:0 *) intro. cut (b * p < 0)%Z. intro. cut (b * p * (a * n) > b * p * (b * m))%Z. intro. cut (b * p * (a * n) > c * n * (b * m))%Z. intro. apply Z.gt_lt. apply Zgt_mult_reg_absorb_l with (a := n). auto with zarith. apply Z.lt_gt. apply Zgt_mult_conv_absorb_l with (a := b). assumption. replace (b * (n * (a * p)))%Z with (b * p * (a * n))%Z by ring. replace (b * (n * (c * m)))%Z with (c * n * (b * m))%Z by ring; auto. rewrite <- H0. auto. apply Zlt_conv_mult_l;trivial. apply Z.gt_lt. replace 0%Z with (b * 0)%Z by ring. apply Zlt_conv_mult_l; trivial. apply Z.gt_lt. auto with zarith. (* y>0 *) intro. cut (b * p > 0)%Z. intro. cut (b * p * (a * n) < b * p * (b * m))%Z. intro. cut (b * p * (a * n) < c * n * (b * m))%Z. intro. apply Z.gt_lt. apply Zgt_mult_reg_absorb_l with (a := n). auto with zarith. apply Zgt_mult_reg_absorb_l with (a := b). apply Z.lt_gt. assumption. apply Z.lt_gt. replace (b * (n * (a * p)))%Z with (b * p * (a * n))%Z by ring. replace (b * (n * (c * m)))%Z with (c * n * (b * m))%Z by ring; auto. rewrite <- H0. auto. apply Zlt_reg_mult_l; auto. apply Zmult_gt_0_compat; auto with zarith. Qed. corn-8.20.0/model/totalorder/000077500000000000000000000000001473720167500160355ustar00rootroot00000000000000corn-8.20.0/model/totalorder/QMinMax.v000066400000000000000000000245211473720167500175420ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import QArith_base. Require Import CoRN.order.TotalOrder. (** ** Example of a Total Order: *) Definition Qlt_le_dec_fast x y : {x < y} + {y <= x}. Proof. change ({x ?= y = Lt}+{y<=x}). cut (x ?= y <> Lt -> y <= x). destruct (x?=y); intros H; (right; abstract(apply H; discriminate)) || (left; reflexivity). refine (Qnot_lt_le _ _). Defined. Definition Qle_total x y : {x <= y} + {y <= x} := match Qlt_le_dec_fast x y with | left p => left _ (Qlt_le_weak _ _ p) | right p => right _ p end. Lemma Qeq_le_def : forall x y, x == y <-> x <= y /\ y <= x. Proof. intros. split. intros H; rewrite -> H. firstorder using Qle_refl. firstorder using Qle_antisym. Qed. Definition Qmonotone : (Q -> Q) -> Prop := Default.monotone Qle. Definition Qantitone : (Q -> Q) -> Prop := Default.antitone Qle. Definition Qmin : Q -> Q -> Q := Default.min Q Qle Qle_total. Definition Qmax : Q -> Q -> Q := Default.max Q Qle Qle_total. Definition Qmin_case : forall x y (P : Q -> Type), (Qle x y -> P x) -> (Qle y x -> P y) -> P (Qmin x y) := Default.min_case Q Qle Qle_total. Definition Qmax_case : forall x y (P : Q -> Type), (Qle y x -> P x) -> (Qle x y -> P y) -> P (Qmax x y) := Default.max_case Q Qle Qle_total. Definition QTotalOrder : TotalOrder. apply makeTotalOrder with Q Qeq Qle Qmonotone Qantitone Qmin Qmax. Proof. apply Qeq_le_def. apply Qle_refl. apply Qle_trans. apply Qle_total. firstorder using PartialOrder.Default.monotone_def. firstorder using PartialOrder.Default.antitone_def. apply (TotalOrder.Default.min_def1 Q Qeq Qle Qeq_le_def Qle_total). apply (TotalOrder.Default.min_def2 Q Qeq Qle Qeq_le_def Qle_total). apply (TotalOrder.Default.max_def1 Q Qeq Qle Qeq_le_def Qle_total). apply (TotalOrder.Default.max_def2 Q Qeq Qle Qeq_le_def Qle_total). Defined. (* begin hide *) Add Morphism Qmin : Qmin_compat. Proof. exact (@meet_compat QTotalOrder). Qed. Add Morphism Qmax : Qmax_compat. Proof. exact (@join_compat QTotalOrder). Qed. (* end hide *) Section QTotalOrder. Let Qto := QTotalOrder. Definition Qmin_lb_l : forall x y : Q, Qmin x y <= x := @meet_lb_l Qto. Definition Qmin_lb_r : forall x y : Q, Qmin x y <= y := @meet_lb_r Qto. Definition Qmin_glb : forall x y z : Q, z <= x -> z <= y -> z <= (Qmin x y) := @meet_glb Qto. Definition Qmin_comm : forall x y : Q, Qmin x y == Qmin y x := @meet_comm Qto. Definition Qmin_assoc : forall x y z : Q, Qmin x (Qmin y z) == Qmin (Qmin x y) z:= @meet_assoc Qto. Definition Qmin_idem : forall x : Q, Qmin x x == x := @meet_idem Qto. Definition Qle_min_l : forall x y : Q, x <= y <-> Qmin x y == x := @le_meet_l Qto. Definition Qle_min_r : forall x y : Q, y <= x <-> Qmin x y == y := @le_meet_r Qto. Definition Qmin_irred : forall x y: Q, {Qmin x y == x} + {Qmin x y == y} := @meet_irred Qto. Definition Qmin_monotone_r : forall a : Q, Qmonotone (Qmin a) := @meet_monotone_r Qto. Definition Qmin_monotone_l : forall a : Q, Qmonotone (fun x => Qmin x a) := @meet_monotone_l Qto. Definition Qmin_le_compat : forall w x y z : Q, w <= y -> x <= z -> Qmin w x <= Qmin y z := @meet_le_compat Qto. Definition Qmax_ub_l : forall x y : Q, x <= Qmax x y := @join_ub_l Qto. Definition Qmax_ub_r : forall x y : Q, y <= Qmax x y := @join_ub_r Qto. Definition Qmax_lub : forall x y z : Q, x <= z -> y <= z -> (Qmax x y) <= z := @join_lub Qto. Definition Qmax_comm : forall x y : Q, Qmax x y == Qmax y x := @join_comm Qto. Definition Qmax_assoc : forall x y z : Q, Qmax x (Qmax y z) == Qmax (Qmax x y) z:= @join_assoc Qto. Definition Qmax_idem : forall x : Q, Qmax x x == x := @join_idem Qto. Definition Qle_max_l : forall x y : Q, y <= x <-> Qmax x y == x := @le_join_l Qto. Definition Qle_max_r : forall x y : Q, x <= y <-> Qmax x y == y := @le_join_r Qto. Definition Qmax_irred : forall x y: Q, {Qmax x y == x} + {Qmax x y == y} := @join_irred Qto. Definition Qmax_monotone_r : forall a : Q, Qmonotone (Qmax a) := @join_monotone_r Qto. Definition Qmax_monotone_l : forall a : Q, Qmonotone (fun x => Qmax x a) := @join_monotone_l Qto. Definition Qmax_le_compat : forall w x y z : Q, w<=y -> x<=z -> Qmax w x <= Qmax y z := @join_le_compat Qto. Definition Qmin_max_absorb_l_l : forall x y : Q, Qmin x (Qmax x y) == x := @meet_join_absorb_l_l Qto. Definition Qmax_min_absorb_l_l : forall x y : Q, Qmax x (Qmin x y) == x := @join_meet_absorb_l_l Qto. Definition Qmin_max_absorb_l_r : forall x y : Q, Qmin x (Qmax y x) == x := @meet_join_absorb_l_r Qto. Definition Qmax_min_absorb_l_r : forall x y : Q, Qmax x (Qmin y x) == x := @join_meet_absorb_l_r Qto. Definition Qmin_max_absorb_r_l : forall x y : Q, Qmin (Qmax x y) x == x := @meet_join_absorb_r_l Qto. Definition Qmax_min_absorb_r_l : forall x y : Q, Qmax (Qmin x y) x == x := @join_meet_absorb_r_l Qto. Definition Qmin_max_absorb_r_r : forall x y : Q, Qmin (Qmax y x) x == x := @meet_join_absorb_r_r Qto. Definition Qmax_min_absorb_r_r : forall x y : Q, Qmax (Qmin y x) x == x := @join_meet_absorb_r_r Qto. Definition Qmin_max_eq : forall x y : Q, Qmin x y == Qmax x y -> x == y := @meet_join_eq Qto. Definition Qmax_min_distr_r : forall x y z : Q, Qmax x (Qmin y z) == Qmin (Qmax x y) (Qmax x z) := @join_meet_distr_r Qto. Definition Qmax_min_distr_l : forall x y z : Q, Qmax (Qmin y z) x == Qmin (Qmax y x) (Qmax z x) := @join_meet_distr_l Qto. Definition Qmin_max_distr_r : forall x y z : Q, Qmin x (Qmax y z) == Qmax (Qmin x y) (Qmin x z) := @meet_join_distr_r Qto. Definition Qmin_max_distr_l : forall x y z : Q, Qmin (Qmax y z) x == Qmax (Qmin y x) (Qmin z x) := @meet_join_distr_l Qto. (*I don't know who wants modularity laws, but here they are *) Definition Qmax_min_modular_r : forall x y z : Q, Qmax x (Qmin y (Qmax x z)) == Qmin (Qmax x y) (Qmax x z) := @join_meet_modular_r Qto. Definition Qmax_min_modular_l : forall x y z : Q, Qmax (Qmin (Qmax x z) y) z == Qmin (Qmax x z) (Qmax y z) := @join_meet_modular_l Qto. Definition Qmin_max_modular_r : forall x y z : Q, Qmin x (Qmax y (Qmin x z)) == Qmax (Qmin x y) (Qmin x z) := @meet_join_modular_r Qto. Definition Qmin_max_modular_l : forall x y z : Q, Qmin (Qmax (Qmin x z) y) z == Qmax (Qmin x z) (Qmin y z) := @meet_join_modular_l Qto. Definition Qmin_max_disassoc : forall x y z : Q, Qmin (Qmax x y) z <= Qmax x (Qmin y z) := @meet_join_disassoc Qto. Lemma Qplus_monotone_r : forall a, Qmonotone (Qplus a). Proof. do 2 red. intros. now apply Qplus_le_r. Qed. Lemma Qplus_monotone_l : forall a, Qmonotone (fun x => Qplus x a). Proof. do 2 red. intros. now apply Qplus_le_l. Qed. Definition Qmin_plus_distr_r : forall x y z : Q, x + Qmin y z == Qmin (x+y) (x+z) := fun a => @monotone_meet_distr Qto _ (Qplus_monotone_r a). Definition Qmin_plus_distr_l : forall x y z : Q, Qmin y z + x == Qmin (y+x) (z+x) := fun a => @monotone_meet_distr Qto _ (Qplus_monotone_l a). Definition Qmax_plus_distr_r : forall x y z : Q, x + Qmax y z == Qmax (x+y) (x+z) := fun a => @monotone_join_distr Qto _ (Qplus_monotone_r a). Definition Qmax_plus_distr_l : forall x y z : Q, Qmax y z + x == Qmax (y+x) (z+x) := fun a => @monotone_join_distr Qto _ (Qplus_monotone_l a). Definition Qmin_minus_distr_l : forall x y z : Q, Qmin y z - x == Qmin (y-x) (z-x) := (fun x => Qmin_plus_distr_l (-x)). Definition Qmax_minus_distr_l : forall x y z : Q, Qmax y z - x == Qmax (y-x) (z-x) := (fun x => Qmax_plus_distr_l (-x)). Definition Qmin_max_de_morgan : forall x y : Q, -(Qmin x y) == Qmax (-x) (-y) := @antitone_meet_join_distr Qto _ Qopp_le_compat. Definition Qmax_min_de_morgan : forall x y : Q, -(Qmax x y) == Qmin (-x) (-y) := @antitone_join_meet_distr Qto _ Qopp_le_compat. Lemma Qminus_antitone : forall a : Q, Qantitone (fun x => a - x). Proof. change (forall a x y : Q, x <= y -> a + - y <= a + - x). intros. apply Qplus_le_compat; firstorder using Qle_refl, Qopp_le_compat. Qed. Definition Qminus_min_max_antidistr_r : forall x y z : Q, x - Qmin y z == Qmax (x-y) (x-z) := fun a => @antitone_meet_join_distr Qto _ (Qminus_antitone a). Definition Qminus_max_min_antidistr_r : forall x y z : Q, x - Qmax y z == Qmin (x-y) (x-z) := fun a => @antitone_join_meet_distr Qto _ (Qminus_antitone a). Lemma Qmult_pos_monotone_r : forall a, (0 <= a) -> Qmonotone (Qmult a). Proof. intros a Ha b c H. do 2 rewrite -> (Qmult_comm a). apply Qmult_le_compat_r; auto with *. Qed. Lemma Qmult_pos_monotone_l : forall a, (0 <= a) -> Qmonotone (fun x => x*a). Proof. intros a Ha b c H. apply Qmult_le_compat_r; auto with *. Qed. Definition Qmin_mult_pos_distr_r : forall x y z : Q, 0 <= x -> x * Qmin y z == Qmin (x*y) (x*z) := fun x y z H => @monotone_meet_distr Qto _ (Qmult_pos_monotone_r _ H) y z. Definition Qmin_mult_pos_distr_l : forall x y z : Q, 0 <= x -> Qmin y z * x == Qmin (y*x) (z*x) := fun x y z H => @monotone_meet_distr Qto _ (Qmult_pos_monotone_l x H) y z. Definition Qmax_mult_pos_distr_r : forall x y z : Q, 0 <= x -> x * Qmax y z == Qmax (x*y) (x*z) := fun x y z H => @monotone_join_distr Qto _ (Qmult_pos_monotone_r x H) y z. Definition Qmax_mult_pos_distr_l : forall x y z : Q, 0 <= x -> Qmax y z * x == Qmax (y*x) (z*x) := fun x y z H => @monotone_join_distr Qto _ (Qmult_pos_monotone_l x H) y z. End QTotalOrder. (* begin hide *) #[global] Hint Resolve Qmin_lb_l: qarith. #[global] Hint Resolve Qmin_lb_r: qarith. #[global] Hint Resolve Qmin_glb: qarith. #[global] Hint Resolve Qmax_ub_l: qarith. #[global] Hint Resolve Qmax_ub_r: qarith. #[global] Hint Resolve Qmax_lub: qarith. (* end hide *) corn-8.20.0/model/totalorder/QposMinMax.v000066400000000000000000000416771473720167500202770ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import Eqdep_dec. From Coq Require Import QArith Qabs Qpower Qround. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.order.TotalOrder. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". (** Positive rational numbers *) Definition Qpos: Set := sig (Qlt 0). Definition QposEq (a b:Qpos) := Qeq (proj1_sig a) (proj1_sig b). Lemma QposEq_refl : forall a : Qpos, QposEq a a. Proof. reflexivity. Qed. Lemma Qpos_ispos : forall a:Qpos, 0 < proj1_sig a. Proof. intros. destruct a; exact q. Qed. Lemma Qpos_nonneg : forall a:Qpos, 0 <= proj1_sig a. Proof. intros. apply Qlt_le_weak. destruct a; exact q. Qed. Lemma Qpos_nonzero : forall a:Qpos, ~(proj1_sig a == 0). Proof. intros. intro abs. destruct a. simpl in abs. rewrite abs in q. exact (Qlt_irrefl 0 q). Qed. Definition Qpos_plus (x y:Qpos) : Qpos. Proof. exists (proj1_sig x + proj1_sig y). apply (Qle_lt_trans _ (0+0) _ (Qle_refl _)). apply Qplus_lt_le_compat. destruct x; assumption. apply Qlt_le_weak; destruct y; assumption. Defined. Definition Qpos_mult (x y:Qpos) : Qpos. Proof. exists (proj1_sig x * proj1_sig y). apply (Qle_lt_trans _ (proj1_sig x * 0)). rewrite Qmult_0_r. apply Qle_refl. apply Qmult_lt_l. destruct x; assumption. destruct y; assumption. Defined. Bind Scope Qpos_scope with Qpos. Delimit Scope Qpos_scope with Qpos. Notation "a # b" := (exist (Qlt 0) (Qmake (Z.pos a) b) eq_refl) (at level 55, no associativity) : Qpos_scope. Infix "+" := Qpos_plus : Qpos_scope. Infix "*" := Qpos_mult : Qpos_scope. Definition comparison_eq_dec (a b: comparison): { a = b } + { a <> b}. destruct a, b; try (left; reflexivity); try (right; discriminate). Defined. Lemma Zlt_hprop (a b: Z) (p q: (a < b)%Z): p = q. Proof. unfold Z.lt in *. destruct p. intros. apply (Eqdep_dec.K_dec_set comparison_eq_dec). reflexivity. Qed. Lemma Qpos_hprop (a b: Qpos) : proj1_sig a = proj1_sig b -> a = b. Proof. destruct a, b. intros H. simpl in H. subst x0. f_equal. exact (Zlt_hprop _ _ q q0). Qed. Lemma Qpos_red_ispos : forall a:Qpos, 0 < Qred (proj1_sig a). Proof. destruct a. simpl. rewrite -> Qred_correct. exact q. Qed. Definition Qpos_red (a:Qpos) : Qpos := exist _ (Qred (proj1_sig a)) (Qpos_red_ispos a). (* By reducing, we get true equality *) Lemma Qpos_red_eq : forall (a b : Qpos), QposEq a b -> Qpos_red a = Qpos_red b. Proof. intros p q H. apply Qpos_hprop. simpl. apply Qred_complete. exact H. Qed. Definition Qpos_sum (l:list Qpos) : Q := List.fold_right (fun (x:Qpos) (y:Q) => proj1_sig x + y) 0%Q l. Lemma Qpos_sum_nonneg : forall l, 0 <= Qpos_sum l. Proof. induction l. apply Qle_refl. simpl. apply (Qle_trans _ (0+0) _ (Qle_refl _)). apply Qplus_le_compat. destruct a. apply Qlt_le_weak, q. exact IHl. Qed. Definition Qpos_sub (a b : Q) : a < b -> {c : Qpos | b == a + proj1_sig c}. Proof. intro H. assert (0 < b - a). { apply (Qplus_lt_l _ _ a). destruct a,b. simpl. ring_simplify. exact H. } exists (exist _ _ H0). destruct a,b; unfold QposEq; simpl. ring_simplify. reflexivity. Defined. Definition QabsQpos (x : Q) : Qpos := match x with | 0 # _ => exist (Qlt 0) (1#1) eq_refl | (Zpos an) # ad => exist (Qlt 0) (Z.pos an # ad) eq_refl | (Zneg an) # ad => exist (Qlt 0) (Z.pos an # ad) eq_refl end. Definition Qpos_inv (x : Qpos) : Qpos. Proof. exists (/ proj1_sig x). destruct x. apply Qinv_lt_0_compat, q. Defined. Lemma Qpos_power_ispos : forall (x:Qpos) (z : Z), 0 < proj1_sig x^z. Proof. intros x z. assert (0 < proj1_sig x) as xpos by (destruct x; exact q). destruct (Qle_lt_or_eq _ _ (Qpower_pos (proj1_sig x) z (Qlt_le_weak _ _ xpos)));[assumption|]. destruct z. discriminate H. elim (Qpower_not_0_positive (proj1_sig x) p). destruct x. intro abs. simpl in abs. clear H xpos. rewrite abs in q. exact (Qlt_irrefl 0 q). symmetry; assumption. elim (Qpower_not_0_positive (/proj1_sig x) p). change (~proj1_sig (Qpos_inv x) == 0). destruct (Qpos_inv x). intro abs. simpl in abs. clear H xpos. rewrite abs in q. exact (Qlt_irrefl 0 q). change ((/proj1_sig x)^Z.pos p==0). rewrite -> Qinv_power. symmetry; assumption. Qed. Definition Qpos_power (x:Qpos) (z:Z) : Qpos := exist _ _ (Qpos_power_ispos x z). Definition Qpos_ceiling (q: Qpos): positive := match Qceiling (proj1_sig q) with | Zpos p => p | _ => 1%positive (* impossible *) end. Lemma Qpos_mult_le_compat : forall (a b : Qpos) (c d : Q), proj1_sig a <= c -> proj1_sig b <= d -> proj1_sig a * proj1_sig b <= c * d. Proof. intros. apply (Qle_trans _ (c * proj1_sig b)). apply Qmult_le_compat_r. exact H. apply Qpos_nonneg. rewrite Qmult_comm. rewrite (Qmult_comm c). apply Qmult_le_compat_r. exact H0. apply (Qle_trans _ (proj1_sig a)). apply Qpos_nonneg. exact H. Qed. (** ** Example of a Total Order: *) Definition Qpos_le_total (x y : Qpos) : {proj1_sig x <= proj1_sig y} + {proj1_sig y <= proj1_sig x} := match Qlt_le_dec_fast (proj1_sig x) (proj1_sig y) with | left p => left _ (Qlt_le_weak _ _ p) | right p => right _ p end. Lemma Qpos_eq_le_def : forall (x y: Qpos), proj1_sig x == proj1_sig y <-> proj1_sig x <= proj1_sig y /\ proj1_sig y <= proj1_sig x. Proof. intros. split. intros H; rewrite -> H. firstorder using Qle_refl. firstorder using Qle_antisym. Qed. Definition Qpos_monotone : (Qpos -> Qpos) -> Prop := Default.monotone (fun (x y:Qpos) => proj1_sig x <= proj1_sig y). Definition Qpos_antitone : (Qpos -> Qpos) -> Prop := Default.antitone (fun (x y:Qpos) => proj1_sig x <= proj1_sig y). Definition Qpos_min : Qpos -> Qpos -> Qpos := Default.min _ _ Qpos_le_total. Definition Qpos_max : Qpos -> Qpos -> Qpos := Default.max _ _ Qpos_le_total. Definition Qpos_min_case : forall (x y:Qpos) (P : Qpos -> Type), (proj1_sig x <= proj1_sig y -> P x) -> (proj1_sig y <= proj1_sig x -> P y) -> P (Qpos_min x y) := Default.min_case _ _ Qpos_le_total. Definition Qpos_max_case : forall (x y:Qpos) (P : Qpos -> Type), (proj1_sig y <= proj1_sig x -> P x) -> (proj1_sig x <= proj1_sig y -> P y) -> P (Qpos_max x y) := Default.max_case _ _ Qpos_le_total. Definition QposTotalOrder : TotalOrder. Proof. apply makeTotalOrder with Qpos QposEq (fun (x y:Qpos) => proj1_sig x <= proj1_sig y) Qpos_monotone Qpos_antitone Qpos_min Qpos_max. exact Qpos_eq_le_def. intros; apply Qle_refl. intros x y z; apply Qle_trans. exact Qpos_le_total. firstorder using PartialOrder.Default.monotone_def. firstorder using PartialOrder.Default.antitone_def. apply (TotalOrder.Default.min_def1 _ _ _ Qpos_eq_le_def Qpos_le_total). apply (TotalOrder.Default.min_def2 _ _ _ Qpos_eq_le_def Qpos_le_total). apply (TotalOrder.Default.max_def1 _ _ _ Qpos_eq_le_def Qpos_le_total). apply (TotalOrder.Default.max_def2 _ _ _ Qpos_eq_le_def Qpos_le_total). Defined. (* begin hide *) Add Morphism Qpos_min with signature QposEq ==> QposEq ==> QposEq as Qpos_min_compat. Proof. exact (@meet_compat QposTotalOrder). Qed. Add Morphism Qpos_max with signature QposEq ==> QposEq ==> QposEq as Qpos_max_compat. Proof. exact (@join_compat QposTotalOrder). Qed. (* end hide *) Section QTotalOrder. Let Qto := QposTotalOrder. Definition Qpos_min_lb_l : forall x y : Qpos, proj1_sig (Qpos_min x y) <= proj1_sig x := @meet_lb_l Qto. Definition Qpos_min_lb_r : forall x y : Qpos, proj1_sig (Qpos_min x y) <= proj1_sig y := @meet_lb_r Qto. Definition Qpos_min_glb : forall x y z : Qpos, proj1_sig z <= proj1_sig x -> proj1_sig z <= proj1_sig y -> proj1_sig z <= proj1_sig (Qpos_min x y) := @meet_glb Qto. Definition Qpos_min_comm : forall x y : Qpos, QposEq (Qpos_min x y) (Qpos_min y x) := @meet_comm Qto. Definition Qpos_min_assoc : forall x y z : Qpos, QposEq (Qpos_min x (Qpos_min y z)) (Qpos_min (Qpos_min x y) z) := @meet_assoc Qto. Definition Qpos_min_idem : forall x : Qpos, QposEq (Qpos_min x x) x := @meet_idem Qto. Definition Qpos_le_min_l : forall x y : Qpos, proj1_sig x <= proj1_sig y <-> QposEq (Qpos_min x y) x := @le_meet_l Qto. Definition Qpos_le_min_r : forall x y : Qpos, proj1_sig y <= proj1_sig x <-> QposEq (Qpos_min x y) y := @le_meet_r Qto. Definition Qpos_min_irred : forall x y: Qpos, {QposEq (Qpos_min x y) x} + {QposEq (Qpos_min x y) y} := @meet_irred Qto. Definition Qpos_min_monotone_r : forall a : Qpos, Qpos_monotone (Qpos_min a) := @meet_monotone_r Qto. Definition Qpos_min_monotone_l : forall a : Qpos, Qpos_monotone (fun x => Qpos_min x a) := @meet_monotone_l Qto. Definition Qpos_min_le_compat : forall w x y z : Qpos, proj1_sig w <= proj1_sig y -> proj1_sig x <= proj1_sig z -> proj1_sig (Qpos_min w x) <= proj1_sig (Qpos_min y z) := @meet_le_compat Qto. Definition Qpos_max_ub_l : forall x y : Qpos, proj1_sig x <= proj1_sig (Qpos_max x y) := @join_ub_l Qto. Definition Qpos_max_ub_r : forall x y : Qpos, proj1_sig y <= proj1_sig (Qpos_max x y) := @join_ub_r Qto. Definition Qpos_max_glb : forall x y z : Qpos, proj1_sig x <= proj1_sig z -> proj1_sig y <= proj1_sig z -> proj1_sig (Qpos_max x y) <= proj1_sig z := @join_lub Qto. Definition Qpos_max_comm : forall x y : Qpos, QposEq (Qpos_max x y) (Qpos_max y x) := @join_comm Qto. Definition Qpos_max_assoc : forall x y z : Qpos, QposEq (Qpos_max x (Qpos_max y z)) (Qpos_max (Qpos_max x y) z) := @join_assoc Qto. Definition Qpos_max_idem : forall x : Qpos, QposEq (Qpos_max x x) x := @join_idem Qto. Definition Qpos_le_max_l : forall x y : Qpos, proj1_sig y <= proj1_sig x <-> QposEq (Qpos_max x y) x := @le_join_l Qto. Definition Qpos_le_max_r : forall x y : Qpos, proj1_sig x <= proj1_sig y <-> QposEq (Qpos_max x y) y := @le_join_r Qto. Definition Qpos_max_irred : forall x y: Qpos, {QposEq (Qpos_max x y) x} + {QposEq (Qpos_max x y) y} := @join_irred Qto. Definition Qpos_max_monotone_r : forall a : Qpos, Qpos_monotone (Qpos_max a) := @join_monotone_r Qto. Definition Qpos_max_monotone_l : forall a : Qpos, Qpos_monotone (fun x => Qpos_max x a) := @join_monotone_l Qto. Definition Qpos_max_le_compat : forall w x y z : Qpos, proj1_sig w<=proj1_sig y -> proj1_sig x<=proj1_sig z -> proj1_sig (Qpos_max w x) <= proj1_sig (Qpos_max y z) := @join_le_compat Qto. Definition Qpos_min_max_absorb_l_l : forall x y : Qpos, QposEq (Qpos_min x (Qpos_max x y)) x := @meet_join_absorb_l_l Qto. Definition Qpos_max_min_absorb_l_l : forall x y : Qpos, QposEq (Qpos_max x (Qpos_min x y)) x := @join_meet_absorb_l_l Qto. Definition Qpos_min_max_absorb_l_r : forall x y : Qpos, QposEq (Qpos_min x (Qpos_max y x)) x := @meet_join_absorb_l_r Qto. Definition Qpos_max_min_absorb_l_r : forall x y : Qpos, QposEq (Qpos_max x (Qpos_min y x)) x := @join_meet_absorb_l_r Qto. Definition Qpos_min_max_absorb_r_l : forall x y : Qpos, QposEq (Qpos_min (Qpos_max x y) x) x := @meet_join_absorb_r_l Qto. Definition Qpos_max_min_absorb_r_l : forall x y : Qpos, QposEq (Qpos_max (Qpos_min x y) x) x := @join_meet_absorb_r_l Qto. Definition Qpos_min_max_absorb_r_r : forall x y : Qpos, QposEq (Qpos_min (Qpos_max y x) x) x := @meet_join_absorb_r_r Qto. Definition Qpos_max_min_absorb_r_r : forall x y : Qpos, QposEq (Qpos_max (Qpos_min y x) x) x := @join_meet_absorb_r_r Qto. Definition Qpos_min_max_eq : forall x y : Qpos, QposEq (Qpos_min x y) (Qpos_max x y) -> QposEq x y := @meet_join_eq Qto. Definition Qpos_max_min_distr_r : forall x y z : Qpos, QposEq (Qpos_max x (Qpos_min y z)) (Qpos_min (Qpos_max x y) (Qpos_max x z)) := @join_meet_distr_r Qto. Definition Qpos_max_min_distr_l : forall x y z : Qpos, QposEq (Qpos_max (Qpos_min y z) x) (Qpos_min (Qpos_max y x) (Qpos_max z x)) := @join_meet_distr_l Qto. Definition Qpos_min_max_distr_r : forall x y z : Qpos, QposEq (Qpos_min x (Qpos_max y z)) (Qpos_max (Qpos_min x y) (Qpos_min x z)) := @meet_join_distr_r Qto. Definition Qpos_min_max_distr_l : forall x y z : Qpos, QposEq (Qpos_min (Qpos_max y z) x) (Qpos_max (Qpos_min y x) (Qpos_min z x)) := @meet_join_distr_l Qto. (*I don't know who wants modularity laws, but here they are *) Definition Qpos_max_min_modular_r : forall x y z : Qpos, QposEq (Qpos_max x (Qpos_min y (Qpos_max x z))) (Qpos_min (Qpos_max x y) (Qpos_max x z)) := @join_meet_modular_r Qto. Definition Qpos_max_min_modular_l : forall x y z : Qpos, QposEq (Qpos_max (Qpos_min (Qpos_max x z) y) z) (Qpos_min (Qpos_max x z) (Qpos_max y z)) := @join_meet_modular_l Qto. Definition Qpos_min_max_modular_r : forall x y z : Qpos, QposEq (Qpos_min x (Qpos_max y (Qpos_min x z))) (Qpos_max (Qpos_min x y) (Qpos_min x z)) := @meet_join_modular_r Qto. Definition Qpos_min_max_modular_l : forall x y z : Qpos, QposEq (Qpos_min (Qpos_max (Qpos_min x z) y) z) (Qpos_max (Qpos_min x z) (Qpos_min y z)) := @meet_join_modular_l Qto. Definition Qpos_min_max_disassoc : forall x y z : Qpos, proj1_sig (Qpos_min (Qpos_max x y) z) <= proj1_sig (Qpos_max x (Qpos_min y z)) := @meet_join_disassoc Qto. Lemma Qplus_monotone_r : forall a, Qpos_monotone (Qpos_plus a). Proof. intros a x y Hxy. repeat rewrite -> Q_Qpos_plus. apply Qplus_le_compat. apply Qle_refl. assumption. Qed. Lemma Qplus_monotone_l : forall a, Qpos_monotone (fun x => Qpos_plus x a). Proof. intros a x y Hxy. repeat rewrite Q_Qpos_plus. apply Qplus_le_compat. assumption. apply Qle_refl. Qed. Local Open Scope Qpos_scope. Definition Qpos_min_plus_distr_r : forall x y z : Qpos, QposEq (Qpos_plus x (Qpos_min y z)) (Qpos_min (Qpos_plus x y) (Qpos_plus x z)) := fun a => @monotone_meet_distr Qto _ (Qplus_monotone_r a). Definition Qpos_min_plus_distr_l : forall x y z : Qpos, QposEq (Qpos_plus (Qpos_min y z) x) (Qpos_min (Qpos_plus y x) (Qpos_plus z x)) := fun a => @monotone_meet_distr Qto _ (Qplus_monotone_l a). Definition Qpos_max_plus_distr_r : forall x y z : Qpos, QposEq (Qpos_plus x (Qpos_max y z)) (Qpos_max (Qpos_plus x y) (Qpos_plus x z)) := fun a => @monotone_join_distr Qto _ (Qplus_monotone_r a). Definition Qpos_max_plus_distr_l : forall x y z : Qpos, QposEq (Qpos_plus (Qpos_max y z) x) (Qpos_max (Qpos_plus y x) (Qpos_plus z x)) := fun a => @monotone_join_distr Qto _ (Qplus_monotone_l a). End QTotalOrder. Lemma Q_Qpos_min : forall (x y:Qpos), proj1_sig (Qpos_min x y) == Qmin (proj1_sig x) (proj1_sig y). Proof. intros x y. unfold Qpos_min. unfold Qmin. unfold Default.min. destruct (Qpos_le_total x y) as [H|H]; destruct (Qle_total (proj1_sig x) (proj1_sig y)) as [H0|H0]; try reflexivity; apply Qle_antisym; auto. Qed. (* begin hide *) #[global] Hint Rewrite Q_Qpos_min : QposElim. (* end hide *) Lemma Q_Qpos_max : forall (x y:Qpos), proj1_sig (Qpos_max x y) == Qmax (proj1_sig x) (proj1_sig y). Proof. intros x y. unfold Qpos_max. unfold Qmax. unfold Default.max. destruct (Qpos_le_total y x) as [H|H]; destruct (Qle_total (proj1_sig y) (proj1_sig x)) as [H0|H0]; try reflexivity; apply Qle_antisym; auto. Qed. (* begin hide *) #[global] Hint Rewrite Q_Qpos_max : QposElim. (* end hide *) Lemma Qpos_min_mult_distr_r : forall x y z : Qpos, QposEq (Qpos_mult x (Qpos_min y z)) (Qpos_min (Qpos_mult x y) (Qpos_mult x z)). Proof. intros x y z. unfold QposEq. rewrite Q_Qpos_min. simpl. rewrite Q_Qpos_min. apply Qmin_mult_pos_distr_r. apply Qlt_le_weak. destruct x. exact q. Qed. Lemma Qpos_min_mult_distr_l : forall x y z : Qpos, QposEq (Qpos_mult (Qpos_min y z) x) (Qpos_min (Qpos_mult y x) (Qpos_mult z x)). Proof. intros x y z. unfold QposEq. rewrite Q_Qpos_min. simpl. rewrite Q_Qpos_min. apply Qmin_mult_pos_distr_l. apply Qlt_le_weak. destruct x. exact q. Qed. Lemma Qpos_max_mult_distr_r : forall x y z : Qpos, QposEq (Qpos_mult x (Qpos_max y z)) (Qpos_max (Qpos_mult x y) (Qpos_mult x z)). Proof. intros x y z. unfold QposEq. rewrite Q_Qpos_max. simpl. rewrite Q_Qpos_max. apply Qmax_mult_pos_distr_r. apply Qlt_le_weak. destruct x. exact q. Qed. Lemma Qpos_max_mult_distr_l : forall x y z : Qpos, QposEq (Qpos_mult (Qpos_max y z) x) (Qpos_max (Qpos_mult y x) (Qpos_mult z x)). Proof. intros x y z. unfold QposEq. rewrite Q_Qpos_max. simpl. rewrite Q_Qpos_max. apply Qmax_mult_pos_distr_l. apply Qlt_le_weak. destruct x. exact q. Qed. corn-8.20.0/model/totalorder/ZMinMax.v000066400000000000000000000220161473720167500175500ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Export Zmin. From Coq Require Export Zmax. From Coq Require Import ZArith. Require Import CoRN.order.TotalOrder. Opaque Z_lt_le_dec. (** ** Example of a Total Order: *) Section ZTotalOrder. Local Open Scope Z_scope. Definition Zle_total x y : {x <= y} + {y <= x} := match Z_lt_le_dec x y with | left p => left _ (Zlt_le_weak _ _ p) | right p => right _ p end. Lemma Zeq_le_def : forall x y, x = y <-> x <= y /\ y <= x. Proof. intros. split. intros H; rewrite H. firstorder using Z.le_refl. firstorder using Zle_antisym. Qed. Definition Zmonotone : (Z -> Z) -> Prop := Default.monotone Z.le. Definition Zantitone : (Z -> Z) -> Prop := Default.antitone Z.le. Definition ZTotalOrder : TotalOrder. apply makeTotalOrder with Z (@eq Z) Z.le Zmonotone Zantitone Z.min Z.max. 1-3, 5-6: solve [auto with *]. Proof. apply Zle_total. intros. apply Z.min_case_strong; auto with *. intros. apply Z.min_case_strong; auto with *. intros. apply Z.max_case_strong; auto with *. intros. apply Z.max_case_strong; auto with *. Defined. Let Zto := ZTotalOrder. Definition Zmin_lb_l : forall x y : Z, Z.min x y <= x := @meet_lb_l Zto. Definition Zmin_lb_r : forall x y : Z, Z.min x y <= y := @meet_lb_r Zto. Definition Zmin_glb : forall x y z : Z, z <= x -> z <= y -> z <= (Z.min x y) := @meet_glb Zto. Definition Zmin_comm : forall x y : Z, Z.min x y = Z.min y x := @meet_comm Zto. Definition Zmin_assoc : forall x y z : Z, Z.min x (Z.min y z) = Z.min (Z.min x y) z:= @meet_assoc Zto. Definition Zmin_idem : forall x : Z, Z.min x x = x := @meet_idem Zto. Definition Zle_min_l : forall x y : Z, x <= y <-> Z.min x y = x := @le_meet_l Zto. Definition Zle_min_r : forall x y : Z, y <= x <-> Z.min x y = y := @le_meet_r Zto. Definition Zmin_irred : forall x y: Z, {Z.min x y = x} + {Z.min x y = y} := @meet_irred Zto. Definition Zmin_monotone_r : forall a : Z, Zmonotone (Z.min a) := @meet_monotone_r Zto. Definition Zmin_monotone_l : forall a : Z, Zmonotone (fun x => Z.min x a) := @meet_monotone_l Zto. Definition Zmin_le_compat : forall w x y z : Z, w <= y -> x <= z -> Z.min w x <= Z.min y z := @meet_le_compat Zto. Definition Zmax_ub_l : forall x y : Z, x <= Z.max x y := @join_ub_l Zto. Definition Zmax_ub_r : forall x y : Z, y <= Z.max x y := @join_ub_r Zto. Definition Zmax_glb : forall x y z : Z, x <= z -> y <= z -> (Z.max x y) <= z := @join_lub Zto. Definition Zmax_comm : forall x y : Z, Z.max x y = Z.max y x := @join_comm Zto. Definition Zmax_assoc : forall x y z : Z, Z.max x (Z.max y z) = Z.max (Z.max x y) z:= @join_assoc Zto. Definition Zmax_idem : forall x : Z, Z.max x x = x := @join_idem Zto. Definition Zle_max_l : forall x y : Z, y <= x <-> Z.max x y = x := @le_join_l Zto. Definition Zle_max_r : forall x y : Z, x <= y <-> Z.max x y = y := @le_join_r Zto. Definition Zmax_irred : forall x y: Z, {Z.max x y = x} + {Z.max x y = y} := @join_irred Zto. Definition Zmax_monotone_r : forall a : Z, Zmonotone (Z.max a) := @join_monotone_r Zto. Definition Zmax_monotone_l : forall a : Z, Zmonotone (fun x => Z.max x a) := @join_monotone_l Zto. Definition Zmax_le_compat : forall w x y z : Z, w <= y -> x <= z -> Z.max w x <= Z.max y z := @join_le_compat Zto. Definition Zmin_max_absorb_l_l : forall x y : Z, Z.min x (Z.max x y) = x := @meet_join_absorb_l_l Zto. Definition Zmax_min_absorb_l_l : forall x y : Z, Z.max x (Z.min x y) = x := @join_meet_absorb_l_l Zto. Definition Zmin_max_absorb_l_r : forall x y : Z, Z.min x (Z.max y x) = x := @meet_join_absorb_l_r Zto. Definition Zmax_min_absorb_l_r : forall x y : Z, Z.max x (Z.min y x) = x := @join_meet_absorb_l_r Zto. Definition Zmin_max_absorb_r_l : forall x y : Z, Z.min (Z.max x y) x = x := @meet_join_absorb_r_l Zto. Definition Zmax_min_absorb_r_l : forall x y : Z, Z.max (Z.min x y) x = x := @join_meet_absorb_r_l Zto. Definition Zmin_max_absorb_r_r : forall x y : Z, Z.min (Z.max y x) x = x := @meet_join_absorb_r_r Zto. Definition Zmax_min_absorb_r_r : forall x y : Z, Z.max (Z.min y x) x = x := @join_meet_absorb_r_r Zto. Definition Zmax_min_distr_r : forall x y z : Z, Z.max x (Z.min y z) = Z.min (Z.max x y) (Z.max x z) := @join_meet_distr_r Zto. Definition Zmax_min_distr_l : forall x y z : Z, Z.max (Z.min y z) x = Z.min (Z.max y x) (Z.max z x) := @join_meet_distr_l Zto. Definition Zmin_max_distr_r : forall x y z : Z, Z.min x (Z.max y z) = Z.max (Z.min x y) (Z.min x z) := @meet_join_distr_r Zto. Definition Zmin_max_distr_l : forall x y z : Z, Z.min (Z.max y z) x = Z.max (Z.min y x) (Z.min z x) := @meet_join_distr_l Zto. (*I don't know who wants modularity laws, but here they are *) Definition Zmax_min_modular_r : forall x y z : Z, Z.max x (Z.min y (Z.max x z)) = Z.min (Z.max x y) (Z.max x z) := @join_meet_modular_r Zto. Definition Zmax_min_modular_l : forall x y z : Z, Z.max (Z.min (Z.max x z) y) z = Z.min (Z.max x z) (Z.max y z) := @join_meet_modular_l Zto. Definition Zmin_max_modular_r : forall x y z : Z, Z.min x (Z.max y (Z.min x z)) = Z.max (Z.min x y) (Z.min x z) := @meet_join_modular_r Zto. Definition Zmin_max_modular_l : forall x y z : Z, Z.min (Z.max (Z.min x z) y) z = Z.max (Z.min x z) (Z.min y z) := @meet_join_modular_l Zto. Definition Zmin_max_disassoc : forall x y z : Z, Z.min (Z.max x y) z <= Z.max x (Z.min y z) := @meet_join_disassoc Zto. Lemma Zsucc_monotone : Zmonotone Z.succ. Proof. unfold Zmonotone, Default.monotone. auto with *. Qed. Definition Zsucc_min_distr : forall x y : Z, Z.succ (Z.min x y) = Z.min (Z.succ x ) (Z.succ y) := @monotone_meet_distr Zto _ Zsucc_monotone. Definition Zsucc_max_distr : forall x y : Z, Z.succ (Z.max x y) = Z.max (Z.succ x ) (Z.succ y) := @monotone_join_distr Zto _ Zsucc_monotone. Lemma Zpred_monotone : Zmonotone Z.pred. Proof. unfold Zmonotone, Default.monotone. intros x y H. rewrite (Zsucc_pred x) in H. rewrite (Zsucc_pred y) in H. auto with zarith. Qed. Definition Zpred_min_distr : forall x y : Z, Z.pred (Z.min x y) = Z.min (Z.pred x ) (Z.pred y) := @monotone_meet_distr Zto _ Zpred_monotone. Definition Zpred_max_distr : forall x y : Z, Z.pred (Z.max x y) = Z.max (Z.pred x ) (Z.pred y) := @monotone_join_distr Zto _ Zpred_monotone. Lemma Zplus_monotone_r : forall a, Zmonotone (Zplus a). Proof. do 2 red. auto with zarith. Qed. Lemma Zplus_monotone_l : forall a, Zmonotone (fun x => Zplus x a). Proof. unfold Zmonotone, Default.monotone. auto with *. Qed. Definition Zmin_plus_distr_r : forall x y z : Z, x + Z.min y z = Z.min (x+y) (x+z) := fun a => @monotone_meet_distr Zto _ (Zplus_monotone_r a). Definition Zmin_plus_distr_l : forall x y z : Z, Z.min y z + x = Z.min (y+x) (z+x) := fun a => @monotone_meet_distr Zto _ (Zplus_monotone_l a). Definition Zmax_plus_distr_r : forall x y z : Z, x + Z.max y z = Z.max (x+y) (x+z) := fun a => @monotone_join_distr Zto _ (Zplus_monotone_r a). Definition Zmax_plus_distr_l : forall x y z : Z, Z.max y z + x = Z.max (y+x) (z+x) := fun a => @monotone_join_distr Zto _ (Zplus_monotone_l a). Definition Zmin_minus_distr_l : forall x y z : Z, Z.min y z - x = Z.min (y-x) (z-x) := (fun x => Zmin_plus_distr_l (-x)). Definition Zmax_minus_distr_l : forall x y z : Z, Z.max y z - x = Z.max (y-x) (z-x) := (fun x => Zmax_plus_distr_l (-x)). Lemma Zopp_le_compat : forall x y : Z, x <= y -> -y <= -x. Proof. auto with *. Qed. Definition Zmin_max_de_morgan : forall x y : Z, -(Z.min x y) = Z.max (-x) (-y) := @antitone_meet_join_distr Zto _ Zopp_le_compat. Definition Zmax_min_de_morgan : forall x y : Z, -(Z.max x y) = Z.min (-x) (-y) := @antitone_join_meet_distr Zto _ Zopp_le_compat. Lemma Zminus_antitone : forall a : Z, Zantitone (fun x => a - x). Proof. change (forall a x y : Z, x <= y -> a + - y <= a + - x). intros. apply Zplus_le_compat; firstorder using Z.le_refl, Zopp_le_compat. Qed. Definition Zminus_min_max_antidistr_r : forall x y z : Z, x - Z.min y z = Z.max (x-y) (x-z) := fun a => @antitone_meet_join_distr Zto _ (Zminus_antitone a). Definition Zminus_max_min_antidistr_r : forall x y z : Z, x - Z.max y z = Z.min (x-y) (x-z) := fun a => @antitone_join_meet_distr Zto _ (Zminus_antitone a). End ZTotalOrder. Transparent Z_lt_le_dec. corn-8.20.0/ode/000077500000000000000000000000001473720167500133255ustar00rootroot00000000000000corn-8.20.0/ode/AbstractIntegration.v000066400000000000000000001573061473720167500174770ustar00rootroot00000000000000(** An abstract interface for integrable uniformly continuous functions from Q to CR, with a proof that integrals satisfying this interface are unique. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.reals.CRreal. From Coq Require Import Utf8 Program. Require Import CoRN.reals.fast.CRArith CoRN.reals.fast.CRabs CoRN.tactics.Qauto. From Coq Require Import Qround. Require Import CoRN.model.metric2.Qmetric CoRN.stdlib_omissions.P CoRN.stdlib_omissions.Z CoRN.stdlib_omissions.Q CoRN.stdlib_omissions.N. Require Import CoRN.ode.metric CoRN.ode.FromMetric2 CoRN.ode.SimpleIntegration. Require CoRN.model.structures.Qinf CoRN.model.structures.QnonNeg CoRN.model.structures.QnnInf CoRN.reals.fast.CRball. Import Qinf.notations QnonNeg.notations QnnInf.notations CRball.notations Qabs (*canonical_names*). Require CoRN.reals.fast.CRtrans CoRN.reals.faster.ARtrans. (* This is almost all CoRN *) Import Qinf.coercions QnonNeg.coercions QnnInf.coercions CoRN.stdlib_omissions.Q. Ltac done := trivial; hnf; intros; solve [ repeat (first [solve [trivial | apply: sym_equal; trivial] | discriminate | contradiction | split]) (* | case not_locked_false_eq_true; assumption*) | match goal with H : ~ _ |- _ => solve [case H; trivial] end ]. Local Open Scope Q_scope. Local Open Scope CR_scope. (* [SearchAbout ((Cmap _ _) (Cunit _)).] does not find anything, but it should find metric2.Prelength.fast_MonadLaw3 *) (** Any nonnegative width can be split up into an integral number of equal-sized pieces no bigger than a given bound: *) Add Field Qfield : Qsft (decidable Qeq_bool_eq, completeness Qeq_eq_bool, constants [Qcst], power_tac Qpower_theory [Qpow_tac]). (* To be added to stdlib.omissions.Q *) Section QFacts. Open Scope Q_scope. Lemma Qmult_inv_l (x : Q) : ~ x == 0 -> / x * x == 1. Proof. intros; rewrite Qmult_comm; apply Qmult_inv_r; trivial. Qed. Lemma Qinv_0 (x : Q) : / x == 0 <-> x == 0. Proof. split; intro H; [| now rewrite H]. destruct x as [m n]; destruct m as [| p | p]; unfold Qinv in *; simpl in *; [reflexivity | |]; unfold Qeq in H; simpl in H; rewrite Pos.mul_1_r in H; discriminate H. Qed. Lemma Qinv_not_0 (x : Q) : ~ / x == 0 <-> ~ x == 0. Proof. now rewrite Qinv_0. Qed. Lemma Qdiv_l (x y z : Q) : ~ x == 0 -> (x * y == z <-> y == z / x). Proof. intro H1. rewrite <- (Qmult_injective_l x H1 y (z / x)). unfold Qdiv. now rewrite <- Qmult_assoc, (Qmult_inv_l x H1), Qmult_1_r, Qmult_comm. Qed. Lemma Qdiv_r (x y z : Q) : ~ y == 0 -> (x * y == z <-> x == z / y). Proof. rewrite Qmult_comm; apply Qdiv_l. Qed. Lemma Q_of_nat_inj (m n : nat) : m == n <-> m = n. Proof. split; intro H; [| now rewrite H]. rewrite QArith_base.inject_Z_injective in H. now apply Nat2Z.inj in H. Qed. End QFacts. Definition split (w: QnonNeg) (bound: QposInf): { x: nat * QnonNeg | (from_nat (fst x) * snd x == w)%Qnn /\ (QnnInf.Finite (snd x) <= from_QposInf bound)%QnnInf }. Proof with simpl; auto with *. unfold QnonNeg.eq. simpl. destruct bound; simpl. Focus 2. exists (1%nat, w). simpl. split... ring. induction w using QnonNeg.rect. exists (0%nat, 0%Qnn)... set (p := SimpleIntegration.QposCeiling (proj1_sig ((n#d) * Qpos_inv q)%Qpos)). exists (nat_of_P p, from_Qpos (((n#d) * Qpos_inv (p#1))%Qpos))... split. rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. change (p * ((n#d) * / p) == (n#d))%Q. field. discriminate. subst p. apply Qle_shift_div_r. reflexivity. rewrite SimpleIntegration.QposCeiling_Qceiling. simpl. setoid_replace (n#d:Q) with (proj1_sig q * ((n#d) * / proj1_sig q))%Q at 1 by (simpl; field)... apply Qmult_le_l. apply Qpos_ispos. apply Qle_ceiling. Qed. (** Riemann sums will play an important role in the theory about integrals, so let's define very simple summation and a key property thereof: *) Definition cmΣ {M: CMonoid} (n: nat) (f: nat -> M) : M := cm_Sum (map f (enum n)). (*Lemma cmΣ_sum {M: CMonoid} (n : nat) (f g : nat -> M) : cmΣ n M := cm_Sum (map f (enum n)). SearchAbout cm_Sum.*) (** If the elementwise distance between two summations over the same domain is bounded, then so is the distance between the summations: *) (* Lemma CRΣ_gball_ex (f g: nat -> CR) (e: QnnInf) (n: nat): (forall m, (m < n)%nat -> gball_ex e (f m) (g m)) -> (gball_ex (n * e)%QnnInf (cmΣ n f) (cmΣ n g)). Proof with simpl; auto. destruct e... induction n. reflexivity. intros. change (gball (inject_Z (S n) * `q) (cmΣ (S n) f) (cmΣ (S n) g)). rewrite Q.S_Qplus. setoid_replace ((n+1) * q)%Q with (q + n * q)%Q by (simpl; ring). unfold cmΣ. simpl @cm_Sum. apply CRgball_plus... Qed. *) Lemma cmΣ_0 (f : nat -> CR) (n : nat) : (forall m, (m < n)%nat -> f m == 0) -> @cmΣ CRasCMonoid n f == 0. Proof. induction n as [| n IH]; intro H; [reflexivity |]. unfold cmΣ. simpl @cm_Sum. rewrite H by apply Nat.lt_succ_diag_r. rewrite IH; [apply CRplus_0_l |]. intros m H1; apply H. now apply Nat.lt_lt_succ_r. Qed. Lemma CRΣ_gball (f g: nat -> CR) (e : Q) (n : nat): (forall m, (m < n)%nat -> ball e (f m) (g m)) -> (ball (n * e) (@cmΣ CRasCMonoid n f) (@cmΣ CRasCMonoid n g)). Proof. induction n. - intros. apply ball_refl. rewrite Qmult_0_l. apply Qle_refl. - intros. rewrite Q.S_Qplus. setoid_replace ((n + 1) * e)%Q with (e + n * e)%Q by ring. unfold cmΣ. simpl @cm_Sum. apply CRgball_plus; auto. Qed. (*Instance cmΣ_proper : Proper (eq ==> @ext_equiv nat _ CR _ ==> @st_eq CR) cmΣ. Proof. intros n1 n2 E1 f1 f2 E2. rewrite E1. change (gball 0 (cmΣ n2 f1) (cmΣ n2 f2)). setoid_replace 0%Q with (n2 * 0)%Q by ring. apply CRΣ_gball. now intros m _; apply E2. Qed.*) #[global] Hint Immediate ball_refl Qle_refl. (** Next up, the actual interface for integrable functions. *) Bind Scope Q_scope with Q. (*Arguments integral_additive {f} {_} {_} a b c _ _.*) Section integral_approximation. Context (f: Q → CR) `{Int: Integrable f}. (** The additive property implies that zero width intervals have zero surface: *) Lemma zero_width_integral q: ∫ f q 0%Qnn == 0. Proof with auto. apply CRplus_eq_l with (∫ f q 0%Qnn). generalize (integral_additive q 0%Qnn 0%Qnn). rewrite Qplus_0_r, QnonNeg.plus_0_l, CRplus_0_l... Qed. (** Iterating the additive property yields: *) Lemma integral_repeated_additive (a: Q) (b: QnonNeg) (n: nat): @cmΣ CRasCMonoid n (fun i: nat => ∫ f (a + i * ` b) b) == ∫ f a (from_nat n * b)%Qnn. Proof. unfold cmΣ. induction n; simpl @cm_Sum. assert (QnonNeg.eq (from_nat 0 * b)%Qnn 0%Qnn) by reflexivity. rewrite H. clear H. rewrite zero_width_integral. reflexivity. rewrite IHn. rewrite CRplus_comm. assert (QnonNeg.eq (from_nat (S n) * b)%Qnn (from_nat n * b + b)%Qnn). { change (S n * proj1_sig b == n * proj1_sig b + proj1_sig b)%Q. rewrite S_Qplus. ring. } rewrite H. clear H. apply integral_additive. Qed. (** As promised, we now move toward the aforementioned generalizations of the boundedness property. We start by generalizing mid to CR: *) Lemma bounded_with_real_mid (from: Q) (width: Qpos) (mid: CR) (r: Qpos): (forall x, from <= x <= from+proj1_sig width -> ball (proj1_sig r) (f x) mid) -> ball (proj1_sig (width * r)%Qpos) (∫ f from (from_Qpos width)) (scale (proj1_sig width) mid). Proof with auto. intros H d1 d2. simpl approximate. destruct (Qscale_modulus_pos width d2) as [P E]. rewrite E. simpl. set (v := (exist (Qlt 0) (/ (proj1_sig width) * proj1_sig d2)%Q P)). assert (QposEq (d1 + width * r + d2)%Qpos (d1 + width * (r + v))%Qpos). { unfold QposEq; simpl; field. apply Qpos_nonzero. } unfold QposEq in H0. rewrite H0. clear H0. apply regFunBall_Cunit. apply integral_bounded_prim. intros. apply ball_triangle with mid... apply ball_approx_r. Qed. (** Next, we generalize r to QnonNeg: *) Lemma bounded_with_nonneg_radius (from: Q) (width: Qpos) (mid: CR) (r: QnonNeg): (forall (x: Q), (from <= x <= from+ proj1_sig width) -> ball (proj1_sig r) (f x) mid) -> ball (proj1_sig width * proj1_sig r) (∫ f from (from_Qpos width)) (scale (proj1_sig width) mid). Proof with auto. pattern r. apply QnonNeg.Qpos_ind. - intros ?? E. split. intros H ?. rewrite <- E. apply H. intros. rewrite E... intros H ?. rewrite E. apply H. intros. rewrite <- E... - rewrite Qmult_0_r. intros. apply ball_eq. intros e epos. setoid_replace e with (proj1_sig (width * (exist _ _ epos * Qpos_inv width))%Qpos) by (simpl; field; apply Qpos_nonzero). apply bounded_with_real_mid. intros q ?. setoid_replace (f q) with mid... apply ball_refl. apply Qpos_nonneg. apply H, H0. - intros. apply bounded_with_real_mid. intros. apply H, H0. Qed. (** Next, we generalize r to a full CR: *) Lemma bounded_with_real_radius (from: Q) (width: Qpos) (mid: CR) (r: CR) (rnn: CRnonNeg r): (forall (x: Q), from <= x <= from+` width -> CRball r mid (f x)) -> CRball (scale (proj1_sig width) r) (∫ f from (from_Qpos width)) (scale (proj1_sig width) mid). Proof with auto. intro A. unfold CRball. intros. unfold CRball in A. setoid_replace q with (proj1_sig width * (q / proj1_sig width))%Q by (simpl; field; auto). assert (r <= ' (q / proj1_sig width)). { apply (mult_cancel_leEq CRasCOrdField) with (' (proj1_sig width)). simpl. apply CRlt_Qlt... rewrite mult_commutes. change (' (proj1_sig width) * r <= ' (q / proj1_sig width) * ' (proj1_sig width)). rewrite CRmult_Qmult. unfold Qdiv. rewrite <- Qmult_assoc. rewrite (Qmult_comm (/ proj1_sig width)). rewrite Qmult_inv_r... rewrite Qmult_1_r. rewrite CRmult_scale... } assert (0 <= (q / proj1_sig width))%Q as E. apply CRle_Qle. apply CRle_trans with r... apply -> CRnonNeg_le_0... apply (bounded_with_nonneg_radius from width mid (exist _ _ E)). intros. apply ball_sym... Qed. (** Finally, we generalize to nonnegative width: *) Lemma integral_bounded (from: Q) (width: QnonNeg) (mid: CR) (r: CR) (rnn: CRnonNeg r) (A: forall (x: Q), (from <= x <= from+` width) -> CRball r mid (f x)): CRball (scale (proj1_sig width) r) (∫ f from width) (scale (proj1_sig width) mid). Proof with auto. revert A. pattern width. apply QnonNeg.Qpos_ind; intros. intros ?? E. assert (forall z, scale (`x) z == scale (`y) z) as scale_wd. { intro z. apply Cmap_wd. rewrite E. reflexivity. reflexivity. } split; intro; intros. rewrite <- scale_wd, <- scale_wd, <- E. apply H. intros. apply A. rewrite <- E... rewrite scale_wd, scale_wd, E. apply H. intros. apply A. rewrite E... rewrite zero_width_integral, scale_0, scale_0. apply CRball.reflexive, CRnonNeg_0. apply (bounded_with_real_radius from q mid r rnn)... Qed. (** In some context a lower-bound-upper-bound formulation is more convenient than the the ball-based formulation: *) Lemma integral_lower_upper_bounded (from: Q) (width: QnonNeg) (lo hi: CR): (forall (x: Q), (from <= x <= from+` width)%Q -> lo <= f x /\ f x <= hi) -> scale (` width) lo <= ∫ f from width /\ ∫ f from width <= scale (` width) hi. Proof with auto with *. intro A. assert (from <= from <= from + `width) as B. split... rewrite <- (Qplus_0_r from) at 1. apply Qplus_le_compat... assert (lo <= hi) as lohi by (destruct (A _ B); now apply CRle_trans with (f from)). set (r := ' (1#2) * (hi - lo)). set (mid := ' (1#2) * (lo + hi)). assert (mid - r == lo) as loE by (subst mid r; ring). assert (mid + r == hi) as hiE by (subst mid r; ring). rewrite <- loE, <- hiE. rewrite scale_CRplus, scale_CRplus, scale_CRopp, CRdistance_CRle, CRdistance_comm. apply CRball.as_distance_bound. apply integral_bounded. subst r. apply CRnonNeg_le_0. apply mult_resp_nonneg. simpl. apply CRle_Qle... rewrite <- (CRplus_opp lo). apply (CRplus_le_r lo hi (-lo))... intros. apply CRball.as_distance_bound. apply -> CRdistance_CRle. rewrite loE, hiE... Qed. (** We now work towards unicity, for which we use that implementations must agree with Riemann approximations. But since those are only valid for locally uniformly continuous functions, our proof of unicity only works for such functions. Todo: There should really be a proof that does not depend on continuity. *) Context `{L : @IsLocallyUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f lmu}. (* Lemma gball_integral (e: Qpos) (a a': Q) (ww: Qpos) (w: QnonNeg): (w <= @uc_mu _ _ _ (@luc_mu Q _ CR f _ (a, ww)) e)%QnnInf -> gball ww a a' -> gball_ex (w * e)%QnnInf (' w * f a') (∫ f a' w). Proof with auto. intros ??. simpl QnnInf.mult. apply in_CRgball. simpl. rewrite <- CRmult_Qmult. CRring_replace (' w * f a' - ' w * ' e) (' w * (f a' - ' e)). CRring_replace (' w * f a' + ' w * ' e) (' w * (f a' + ' e)). repeat rewrite CRmult_scale. apply (integral_lower_upper_bounded a' w (f a' - ' e) (f a' + ' e)). intros x [lo hi]. apply in_CRball. apply (locallyUniformlyContinuous f a ww e). apply ball_gball... set (luc_mu f a ww e) in *. destruct q... apply in_Qball. split. unfold Qminus. rewrite <- (Qplus_0_r x). apply Qplus_le_compat... change (-q <= -0)%Q. apply Qopp_le_compat... apply Qle_trans with (a' + `w)%Q... apply Qplus_le_compat... Qed. *) (** Iterating this result shows that Riemann sums are arbitrarily good approximations: *) Open Scope Q_scope. Lemma luc_gball (a w delta eps x y : Q) : 0 < eps -> (delta <= lmu a w eps)%Qinf -> @ball Q_as_MetricSpace w a x -> @ball Q_as_MetricSpace w a y -> @ball Q_as_MetricSpace delta x y -> ball eps (f x) (f y). Proof. intros A A1 A2 A3 A4. destruct (@luc_prf Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f lmu L a w) as [_ H]. change (f x) with (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR f a w (exist _ _ A2)). change (f y) with (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR f a w (exist _ _ A3)). apply H; [apply A |]. destruct (lmu a w eps) as [q |] eqn:A5; [| easy]. apply (@mspc_monotone _ _ (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (@mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) w a) ) delta). apply A1. apply A4. Qed. Lemma Riemann_sums_approximate_integral (a: Q) (w: QnonNeg) (e: Qpos) (iw: Q) (n: nat): (S n * iw == proj1_sig w)%Q -> (iw <= lmu a (proj1_sig w) (proj1_sig e))%Qinf -> ball (proj1_sig e * proj1_sig w) (@cmΣ CRasCMonoid (S n) (fun i => 'iw * f (a + i * iw))%CR) (∫ f a w). Proof. intros A B. assert (ne_sn_0 : ~ S n == 0) by (change 0 with (inject_Z (Z.of_nat 0)); rewrite Q_of_nat_inj; apply S_O). assert (iw_nn : 0 <= iw) by (apply Qdiv_l in A; [| assumption]; rewrite A; apply Qmult_le_0_compat; [now auto|]; apply Qinv_le_0_compat, Qle_nat). (* This should be automated *) set (iw' := exist _ iw iw_nn : QnonNeg ). change iw with (proj1_sig iw'). change (from_nat (S n) * iw' == w)%Qnn in A. rewrite <- A at 2. rewrite <- integral_repeated_additive. setoid_replace (proj1_sig e * proj1_sig w)%Q with (S n * (iw * proj1_sig e))%Q by (unfold QnonNeg.eq in A; simpl in A; rewrite Qmult_assoc; rewrite A; apply Qmult_comm). apply CRΣ_gball. intros m H. rewrite CRmult_scale. apply ball_sym. apply CRball.rational. setoid_replace (' (iw * proj1_sig e)) with (scale (proj1_sig iw') (' ` e)) by now rewrite <- scale_Qmult. apply integral_bounded; [apply CRnonNegQpos |]. intros x [A1 A2]. apply CRball.rational. apply (luc_gball a (proj1_sig w) (`iw')); trivial. + apply gball_Qabs. setoid_replace (a - (a + m * proj1_sig iw')) with (- (m * proj1_sig iw')) by ring. rewrite Qabs_opp. apply Qabs_le_nonneg; [Qauto_nonneg |]. apply Qle_trans with (y := (S n * proj1_sig iw')). apply Qmult_le_compat_r. apply Qlt_le_weak. rewrite <- Zlt_Qlt. now apply inj_lt. apply (proj2_sig iw'). change (S n * proj1_sig iw' == proj1_sig w) in A. rewrite <- A; reflexivity. + apply gball_Qabs, Qabs_Qle_condition. split. apply Qplus_le_l with (z := x), Qplus_le_l with (z := proj1_sig w). setoid_replace (- proj1_sig w + x + proj1_sig w) with x by ring. setoid_replace (a - x + x + proj1_sig w) with (a + proj1_sig w) by ring. apply Qle_trans with (y := (a + m * ` iw' + ` iw')); [easy |]. setoid_rewrite <- (Qmult_1_l (` iw')) at 2. change 1%Q with (inject_Z (Z.of_nat 1)). rewrite <- Qplus_assoc, <- Qmult_plus_distr_l, <- Zplus_Qplus, <- Nat2Z.inj_add. apply Qplus_le_r. change (S n * proj1_sig iw' == proj1_sig w) in A. rewrite <- A. apply Qmult_le_compat_r. rewrite <- Zle_Qle. apply inj_le. rewrite Nat.add_comm. now apply Nat.le_succ_l. apply (proj2_sig iw'). apply Qplus_le_l with (z := x), Qplus_le_l with (z := - proj1_sig w). setoid_replace (a - x + x + - proj1_sig w) with (a - proj1_sig w) by ring. setoid_replace (proj1_sig w + x + - proj1_sig w) with x by ring. apply Qle_trans with (y := a). rewrite <- (Qplus_0_r a) at 2. apply Qplus_le_r. change 0 with (-0). apply Qopp_le_compat, (proj2_sig w). apply Qle_trans with (y := a + m * ` iw'); [| easy]. rewrite <- (Qplus_0_r a) at 1. apply Qplus_le_r, Qmult_le_0_compat; [apply Qle_nat | apply (proj2_sig iw')]. + apply gball_Qabs, Qabs_Qle_condition; split. apply (Qplus_le_r (x + `iw')). setoid_replace (x + `iw' + - `iw') with x by ring. setoid_replace (x + (proj1_sig iw') + (a + m * proj1_sig iw' - x)) with (a + m * proj1_sig iw' + proj1_sig iw') by ring. apply A2. apply (Qplus_le_r (x - `iw')). setoid_replace (x - proj1_sig iw' + (a + m * proj1_sig iw' - x)) with (a + m * proj1_sig iw' - proj1_sig iw') by ring. setoid_replace (x - `iw' + `iw') with x by ring. apply Qle_trans with (y := a + m * proj1_sig iw'); [| easy]. apply Qminus_less. apply (proj2_sig iw'). Qed. Definition step (w : Q) (n : positive) : Q := w * (1 # n). Lemma step_nonneg (w : Q) (n : positive) : 0 <= w -> 0 <= step w n. Proof. intros w_nn; unfold step; Qauto_nonneg. Qed. Lemma step_0 (n : positive) : step 0 n == 0. Proof. unfold step; now rewrite Qmult_0_l. Qed. Lemma step_mult (w : Q) (n : positive) : (inject_Z n : Q) * step w n == w. Proof. unfold step. rewrite Qmake_Qdiv. unfold Qdiv. rewrite Qmult_1_l, (Qmult_comm w), Qmult_assoc. rewrite Qmult_inv_r, Qmult_1_l; [reflexivity | auto with qarith]. Qed. Definition riemann_sum (a w : Q) (n : positive) := let iw := step w n in @cmΣ CRasCMonoid (Pos.to_nat n) (fun i => 'iw * f (a + i * iw))%CR. (*Instance : Proper (Qeq ==> Qeq ==> eq ==> @st_eq CR) riemann_sum. Proof. intros a1 a2 Ea w1 w2 Ew n1 n2 En. apply cmΣ_proper; [now rewrite En |]. intros i1 i2 Ei.*) Lemma riemann_sum_0 (a : Q) (n : positive) : riemann_sum a 0 n [=] 0%CR. Proof. unfold riemann_sum. apply cmΣ_0. intros m _. generalize (f(a+m*step 0 n)). intros. rewrite (step_0 n). ring. Qed. Lemma Riemann_sums_approximate_integral' (a : Q) (w : QnonNeg) (e : Qpos) (n : positive) : (step (proj1_sig w) n <= lmu a (proj1_sig w) (proj1_sig e))%Qinf -> ball (proj1_sig e * proj1_sig w) (riemann_sum a (proj1_sig w) n) (∫ f a w). Proof. intro A; unfold riemann_sum. destruct (Pos2Nat.is_succ n) as [m M]. rewrite M. apply Riemann_sums_approximate_integral; [rewrite <- M | easy]. unfold step. change (Pos.to_nat n * (proj1_sig w * (1 # n)) == proj1_sig w). rewrite positive_nat_Z. unfold inject_Z. rewrite Qmult_comm, <- Qmult_assoc. setoid_replace ((1 # n) * (n # 1)) with (1#1) by reflexivity. ring. Qed. Lemma integral_approximation (a : Q) (w : QnonNeg) (e : Qpos) : exists N : positive, forall n : positive, (N <= n)%positive -> mspc_ball e (riemann_sum a (proj1_sig w) n) (∫ f a w). Proof. destruct (Qlt_le_dec 1 (proj1_sig w)) as [A1 | A1]. * assert (0 < proj1_sig w) by (apply (Qlt_trans _ 1); auto with qarith). set (N := Z.to_pos (Qceiling (comp_inf (λ x, proj1_sig w / x) (lmu a (proj1_sig w)) 0 (proj1_sig e / proj1_sig w)))). exists N; intros n A2. assert (Qinf.eq (proj1_sig e) (proj1_sig e / proj1_sig w * proj1_sig w)). { simpl. unfold canonical_names.equiv. unfold stdlib_rationals.Q_eq. field. intro abs. rewrite abs in H. exact (Qlt_irrefl 0 H). } rewrite H0. clear H0. (* [apply Riemann_sums_approximate_integral'] does not unify because in this lemma, the radius is [(QposAsQ e) * (QnonNeg.proj1_sig w)], and in the goal the radius is [(QposAsQ e) / (QnonNeg.proj1_sig w) * (QnonNeg.proj1_sig w)]. *) assert (P : 0 < proj1_sig e / proj1_sig w). { (apply Qmult_lt_0_compat; [| apply Qinv_lt_0_compat]; auto). } change (proj1_sig e / proj1_sig w) with (proj1_sig (exist _ _ P)). apply (Riemann_sums_approximate_integral' a w ((exist (Qlt 0) (proj1_sig e / proj1_sig w) P))). change (` (exist (Qlt 0) (` e / proj1_sig w) P)) with (proj1_sig e / proj1_sig w). destruct (lmu a (proj1_sig w) (proj1_sig e / proj1_sig w)) as [mu |] eqn:A3; [| easy]. subst N; unfold comp_inf in A2; rewrite A3 in A2. change (step (proj1_sig w) n <= mu); unfold step. setoid_replace (1#n) with (/(n#1)) by reflexivity. assert (0 < mu) as A4. change (Qinf.lt 0 mu). rewrite <- A3. apply (@uc_pos _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (@mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig w) a)) CR (msp_mspc_ball CR) (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR f a (proj1_sig w)) (lmu a (proj1_sig w))). trivial. trivial. apply Qle_div_l; auto. reflexivity. now apply Z.Ple_Zle_to_pos, Q.Zle_Qle_Qceiling in A2. * set (N := Z.to_pos (Qceiling (comp_inf (λ x, 1 / x) (lmu a (proj1_sig w)) 0 (proj1_sig e)))). exists N; intros n A2. apply (mspc_monotone (proj1_sig e * proj1_sig w)). + change (proj1_sig e * proj1_sig w <= proj1_sig e). rewrite <- (Qmult_1_r (proj1_sig e)) at 2. apply Qmult_le_compat_l; auto. apply Qpos_nonneg. + apply Riemann_sums_approximate_integral'. destruct (lmu a (proj1_sig w) (proj1_sig e)) as [mu |] eqn:A3; [| easy]. subst N; unfold comp_inf in A2; rewrite A3 in A2. change (step (proj1_sig w) n <= mu); unfold step. setoid_replace (1#n) with (/(n#1)) by reflexivity. assert (0 < mu) as A4. change (Qinf.lt 0 mu). rewrite <- A3. apply (@uc_pos _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (@mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig w) a)) CR (msp_mspc_ball CR) (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR f a (proj1_sig w)) (lmu a (proj1_sig w))). trivial. apply (proj2_sig e). apply Qle_div_l; auto. reflexivity. apply Z.Ple_Zle_to_pos, Q.Zle_Qle_Qceiling in A2. apply (Qle_trans _ (1 / mu)); trivial. apply Qmult_le_compat_r; trivial. now apply Qinv_le_0_compat, Qlt_le_weak. Qed. (** Unicity itself will of course have to be stated w.r.t. *two* integrals: *) (* Lemma unique `{!LocallyUniformlyContinuous_mu f} `{!LocallyUniformlyContinuous f} (c1: Integral f) (c2: Integral f) (P1: @Integrable c1) (P2: @Integrable c2): forall (a: Q) (w: QnonNeg), @integrate f c1 a w == @integrate f c2 a w. Proof with auto. intros. apply ball_eq. intros. revert w. apply QnonNeg.Qpos_ind. intros ?? E. rewrite E. reflexivity. do 2 rewrite zero_width_integral... intro x. destruct (split x (@uc_mu _ _ _ (@luc_mu Q _ CR f _ (a, x)) ((1 # 2) * e * Qpos_inv x)))%Qpos as [[n t] [H H0]]. simpl in H. simpl @snd in H0. setoid_replace e with (((1 # 2) * e / x) * x + ((1 # 2) * e / x) * x)%Qpos by (unfold QposEq; simpl; field)... apply ball_triangle with (cmΣ n (fun i: nat => (' `t * f (a + i * `t)%Q))). apply ball_sym. apply ball_gball. apply (Riemann_sums_approximate_integral a x ((1 # 2) * e / x)%Qpos t n H H0). apply ball_gball. apply (Riemann_sums_approximate_integral a x ((1 # 2) * e / x)%Qpos t n H H0). Qed. *) End integral_approximation. (** If f==g, then an integral for f is an integral for g. *) Lemma Integrable_proper_l (f g: Q → CR) {fint: Integral f}: canonical_names.equiv f g → Integrable f → @Integrable g fint. Proof with auto. constructor. replace (@integrate g) with (@integrate f) by reflexivity. intros. apply integral_additive. replace (@integrate g) with (@integrate f) by reflexivity. intros. apply integral_bounded_prim... intros. assert (msp_eq (f x) (g x)). { apply H. reflexivity. } rewrite H3... replace (@integrate g) with (@integrate f) by reflexivity. apply integral_wd... Qed. Import canonical_names abstract_algebra. Local Open Scope mc_scope. Add Ring CR : (rings.stdlib_ring_theory CR). Lemma mult_comm `{SemiRing R} : Commutative (.*.). Proof. apply commonoid_commutative with (Aunit := one), _. Qed. Lemma mult_assoc `{SemiRing R} (x y z : R) : x * (y * z) = x * y * z. Proof. apply sg_ass, _. Qed. (* Should this lemma be used to CoRN.reals.fast.CRabs? That file does not use type class notations from canonical_names like ≤ *) Lemma CRabs_nonneg (x : CR) : 0 ≤ abs x. Proof. apply -> CRabs_cases; [| apply _ | apply _]. split; [trivial | apply (proj1 (rings.flip_nonpos_negate x))]. Qed. Lemma cmΣ_empty {M : CMonoid} (f : nat -> M) : cmΣ 0 f = [0]. Proof. reflexivity. Qed. Lemma cmΣ_succ {M : CMonoid} (n : nat) (f : nat -> M) : cmΣ (S n) f = f n [+] cmΣ n f. Proof. reflexivity. Qed. Lemma cmΣ_plus (n : nat) (f g : nat -> CR) : @cmΣ CRasCMonoid n (f + g) == @cmΣ CRasCMonoid n f + @cmΣ CRasCMonoid n g. Proof. induction n as [| n IH]. + symmetry. apply (@cm_rht_unit CRasCMonoid (@cmΣ CRasCMonoid 0 (f + g))). + rewrite cmΣ_succ. transitivity ((f + g)%mc n + (@cmΣ CRasCMonoid n f + @cmΣ CRasCMonoid n g))%CR. apply ucFun2_wd. reflexivity. exact IH. clear IH. rewrite cmΣ_succ. transitivity (f n + @cmΣ CRasCMonoid n f + (g n + @cmΣ CRasCMonoid n g))%CR. 2: reflexivity. do 2 rewrite CRplus_assoc. apply CRplus_eq_l. rewrite <- CRplus_assoc. rewrite <- (CRplus_comm (g n)), CRplus_assoc. apply CRplus_eq_r. reflexivity. Qed. Lemma cmΣ_negate (n : nat) (f : nat -> CR) : @cmΣ CRasCMonoid n (- f) = - @cmΣ CRasCMonoid n f. Proof. induction n as [| n IH]. - apply CRopp_0. - rewrite cmΣ_succ. transitivity ( (- f)%mc n + - @cmΣ CRasCMonoid n f)%CR. apply ucFun2_wd. reflexivity. exact IH. clear IH. change (- @cmΣ CRasCMonoid (S n) f) with (-(f n + @cmΣ CRasCMonoid n f))%CR. rewrite CRopp_plus_distr. reflexivity. Qed. Lemma cmΣ_const (n : nat) (m : CR) : @cmΣ CRasCMonoid n (λ _, m) = m * '(n : Q). Proof. induction n as [| n IH]. - rewrite cmΣ_empty. simpl. rewrite CRmult_0_r. reflexivity. - rewrite cmΣ_succ. transitivity (m + (m*'n))%CR. apply ucFun2_wd. reflexivity. exact IH. clear IH. rewrite S_Qplus, <- CRplus_Qplus. rewrite CRmult_plus_distr_l. rewrite CRplus_comm. apply ucFun2_wd. reflexivity. rewrite CRmult_1_r. reflexivity. Qed. Lemma riemann_sum_const (a : Q) (w : Q) (m : CR) (n : positive) : riemann_sum (λ _, m) a w n = 'w * m. Proof. unfold riemann_sum. rewrite cmΣ_const, positive_nat_Z. change ('step w n * m * '(n : Q) = 'w * m). rewrite (mult_comm _ ('(inject_Z n : Q))), mult_assoc, CRmult_Qmult, step_mult; reflexivity. Qed. Lemma riemann_sum_plus (f g : Q -> CR) (a w : Q) (n : positive) : riemann_sum (f + g) a w n = riemann_sum f a w n + riemann_sum g a w n. Proof. unfold riemann_sum. rewrite <- cmΣ_plus. apply (@cm_Sum_eq CRasCMonoid). intro k. unfold plus, ext_plus. apply CRmult_plus_distr_l. Qed. Lemma riemann_sum_negate (f : Q -> CR) (a w : Q) (n : positive) : riemann_sum (- f) a w n = - riemann_sum f a w n. Proof. unfold riemann_sum. rewrite <- cmΣ_negate. apply (@cm_Sum_eq CRasCMonoid). intro k. unfold negate, ext_negate. symmetry. apply CRopp_mult_distr_r. Qed. Section RiemannSumBounds. Context (f : Q -> CR). Global Instance Qle_nat (n : nat) : PropHolds (0 ≤ (n : Q)). Proof. apply Qle_nat. Qed. Instance step_nonneg' (w : Q) (n : positive) : PropHolds (0 ≤ w) -> PropHolds (0 ≤ step w n). Proof. apply step_nonneg. Qed. Lemma index_inside_l (a w : Q) (k : nat) (n : positive) : 0 ≤ w -> k < Pos.to_nat n -> a ≤ a + (k : Q) * step w n. Proof. intros; apply semirings.nonneg_plus_le_compat_r; solve_propholds. Qed. Lemma index_inside_r (a w : Q) (k : nat) (n : positive) : 0 ≤ w -> k < Pos.to_nat n -> a + (k : Q) * step w n ≤ a + w. Proof. intros A1 A2. apply (orders.order_preserving (a +)). mc_setoid_replace w with ((inject_Z n : Q) * (step w n)) at 2 by (symmetry; apply step_mult). apply (orders.order_preserving (.* step w n)). rewrite <- Zle_Qle, <- positive_nat_Z. apply inj_le. change (k ≤ Pos.to_nat n). solve_propholds. Qed. Lemma riemann_sum_bounds (a w : Q) (m : CR) (e : Q) (n : positive) : 0 ≤ w -> (forall (x : Q), (a ≤ x ≤ a + w) -> ball e (f x) m) -> ball (w * e) (riemann_sum f a w n) ('w * m). Proof. intros w_nn A. pose proof (riemann_sum_const a w m n). rewrite <- H. clear H. unfold riemann_sum. rewrite <- (step_mult w n), <- (Qmult_assoc (inject_Z n) _ e), <- (positive_nat_Z n). apply CRΣ_gball. intros k A1. apply CRball.gball_CRmult_Q_nonneg; [now apply step_nonneg |]. apply A. split; [apply index_inside_l | apply index_inside_r]; trivial. Qed. End RiemannSumBounds. Section IntegralBound. Context (f : Q -> CR) `{Integrable f}. Lemma scale_0_r (x : Q) : scale x 0 == 0. Proof. rewrite <- CRmult_scale. apply CRmult_0_r. Qed. Require Import MathClasses.misc.propholds. Lemma integral_abs_bound (from : Q) (width : QnonNeg) (M : Q) : (forall (x : Q), (from ≤ x ≤ from + proj1_sig width) -> CRabs (f x) ≤ 'M) -> CRabs (∫ f from width) ≤ '(`width * M). Proof. intro A. rewrite <- (CRplus_0_r (∫ f from width)), <- CRopp_0. apply CRball.as_distance_bound. rewrite <- (scale_0_r (proj1_sig width)). rewrite <- CRmult_Qmult, CRmult_scale. apply integral_bounded; trivial. + apply CRnonNeg_le_0. apply CRle_trans with (y := CRabs (f from)); [apply CRabs_nonneg |]. apply A. split; [reflexivity |]. apply semirings.nonneg_plus_le_compat_r; change (0 <= proj1_sig width)%Q; Qauto_nonneg. + intros x A2. apply CRball.as_distance_bound. rewrite CRdistance_comm. change (CRabs (f x - 0) ≤ 'M). rewrite rings.minus_0_r; now apply A. Qed. (*apply CRball.as_distance_bound, CRball.rational. rewrite <- (scale_0_r width). assert (A1 : 0 ≤ M). + apply CRle_Qle. apply CRle_trans with (y := CRabs (f from)); [apply CRabs_nonneg |]. apply A. split; [reflexivity |]. apply semirings.nonneg_plus_le_compat_r; change (0 <= width)%Q; Qauto_nonneg. + change M with (QnonNeg.proj1_sig (exist _ M A1)). apply bounded_with_nonneg_radius; [easy |]. intros x A2. apply CRball.gball_CRabs. change (f x - 0%mc)%CR with (f x - 0). rewrite rings.minus_0_r; now apply A. Qed.*) End IntegralBound. (* Section IntegralOfSum. Context (f g : Q -> CR) `{!IsLocallyUniformlyContinuous f f_mu, !IsLocallyUniformlyContinuous g g_mu} `{Integral f, !Integrable f, Integral g, !Integrable g}. Global Instance integrate_sum : Integral (f + g) := λ a w, integrate f a w + integrate g a w. Global Instance integrate_negate : Integral (- f) := λ a w, - integrate f a w. Lemma integral_sum_additive (a : Q) (b c : QnonNeg) : ∫ (f + g) a b + ∫ (f + g) (a + ` b) c = ∫ (f + g) a (b + c)%Qnn. Proof. unfold integrate, integrate_sum. rewrite <- !integral_additive; trivial. change ( ∫ f a b + ∫ g a b + (∫ f (a + ` b) c + ∫ g (a + ` b) c) = (∫ f a b + ∫ f (a + ` b) c) + (∫ g a b + ∫ g (a + ` b) c)). ring. Qed. Lemma integral_negate_additive (a : Q) (b c : QnonNeg) : ∫ (- f) a b + ∫ (- f) (a + ` b) c = ∫ (- f) a (b + c)%Qnn. Proof. unfold integrate, integrate_negate. rewrite <- rings.negate_plus_distr. apply CRopp_wd_Proper. (* Where is it defined? *) now apply integral_additive. Qed. (* When the last argument of ball is ('(width * mid)), typechecking diverges *) Lemma integral_sum_integrable (from : Q) (width : Qpos) (mid : Q) (r : Qpos) : (∀ x : Q, from ≤ x ≤ from + width → ball r (f x + g x) ('mid)) → ball (width * r) (∫ (f + g) from width) ('((width : Q) * mid)). Proof. intros A. apply ball_gball; simpl. apply gball_closed. intros e e_pos. setoid_replace (width * r + e)%Q with (e + width * r)%Q by apply Qplus_comm. destruct (Riemann_sums_approximate_integral'' f from width ((1#2) * mkQpos e_pos)%Qpos) as [Nf F]. destruct (Riemann_sums_approximate_integral'' g from width ((1#2) * mkQpos e_pos)%Qpos) as [Ng G]. set (n := Pos.max Nf Ng). assert (le_Nf_n : (Nf <= n)%positive) by apply Pos.le_max_l. assert (le_Ng_n : (Ng <= n)%positive) by apply Pos.le_max_r. specialize (F n le_Nf_n). specialize (G n le_Ng_n). apply gball_triangle with (b := riemann_sum (f + g) from width n). + rewrite riemann_sum_plus. setoid_replace e with ((1#2) * e + (1#2) * e)%Q by ring. apply CRgball_plus; apply gball_sym; trivial. + (* apply riemann_sum_bounds. diverges *) rewrite <- CRmult_Qmult. apply riemann_sum_bounds; [solve_propholds |]. intros. apply ball_gball. apply A; trivial. Qed. (*Lemma integral_negate_integrable (from : Q) (width : Qpos) (mid : Q) (r : Qpos) : (∀ x : Q, from ≤ x ≤ from + width → ball r ((- f) x) ('mid)) → ball (width * r) (∫ (- f) from width) ('((width : Q) * mid)). Proof. intros A. unfold integrate, integrate_negate. SearchAbout gball CRopp. SearchAbout (gball _ (CRopp _) (CRopp _)).*) Global Instance : Integrable (f + g). constructor. + apply integral_sum_additive. + apply integral_sum_integrable. + intros a1 a2 A1 w1 w2 A2. unfold integrate, integrate_sum. rewrite A1, A2; reflexivity. Qed. End IntegralOfSum. *) Add Field Q : (dec_fields.stdlib_field_theory Q). (* In theory.rings, we have [rings.plus_assoc : ... Associative plus] and [rings.plus_comm : ... Commutative plus]. One difference is that [Commutative] is defined directly while [Associative] is defined through [HeteroAssociative]. For this or some other reason, rewriting [rings.plus_comm] works while rewriting [rings.plus_assoc] does not. Interestingly, all arguments before x y z in [rings.plus_assoc] are implicit, and when we make [R] explicit, rewriting works. However, in this case [rewrite] leaves a goal [SemiRing R], which is not solved by [trivial], [auto] or [easy], but only by [apply _]. If [rings.plus_assoc] is formulated as [x + (y + z) = (x + y) + z] instead of [Associative plus], then rewriting works; however, then it cannot be an instance (of [Associative]). Make this change in theory.rings? *) Lemma plus_assoc `{SemiRing R} : forall (x y z : R), x + (y + z) = (x + y) + z. Proof. exact simple_associativity. Qed. Section RingFacts. Context `{Ring R}. Lemma plus_left_cancel (z x y : R) : z + x = z + y <-> x = y. Proof. split. (* [apply (left_cancellation (+)).] leaves the goal [LeftCancellation plus z], which is solved by [apply _]. Why is it left? *) + apply (left_cancellation (+) z). + intro A; now rewrite A. Qed. Lemma plus_right_cancel (z x y : R) : x + z = y + z <-> x = y. Proof. rewrite (rings.plus_comm x z), (rings.plus_comm y z); apply plus_left_cancel. Qed. Lemma plus_eq_minus (x y z : R) : x + y = z <-> x = z - y. Proof. split; intro A. + apply (right_cancellation (+) y). now rewrite <- plus_assoc, rings.plus_negate_l, rings.plus_0_r. + apply (right_cancellation (+) (-y)). now rewrite <- plus_assoc, rings.plus_negate_r, rings.plus_0_r. Qed. Lemma minus_eq_plus (x y z : R) : x - y = z <-> x = z + y. Proof. now rewrite plus_eq_minus, rings.negate_involutive. Qed. Lemma negate_inj (x y : R) : -x = -y <-> x = y. Proof. now rewrite rings.flip_negate, rings.negate_involutive. Qed. End RingFacts. Import interfaces.orders orders.minmax theory.rings. Lemma join_comm `{JoinSemiLatticeOrder L} : Commutative join. Proof. intros x y. apply antisymmetry with (R := (≤)); [apply _ | |]; (apply join_lub; [apply join_ub_r | apply join_ub_l]). (* why is [apply _] needed? *) Qed. Lemma meet_comm `{MeetSemiLatticeOrder L} : Commutative meet. Proof. intros x y. apply antisymmetry with (R := (≤)); [apply _ | |]; (apply meet_glb; [apply meet_lb_r | apply meet_lb_l]). Qed. Definition Range (T : Type) := prod T T. #[global] Instance contains_Q : Contains Q (Range Q) := λ x s, (fst s ⊓ snd s ≤ x ≤ fst s ⊔ snd s). Lemma Qrange_comm (a b x : Q) : x ∈ (a, b) <-> x ∈ (b, a). Proof. unfold contains, contains_Q; simpl. rewrite join_comm, meet_comm; reflexivity. Qed. Lemma range_le (a b : Q) : a ≤ b -> forall x, a ≤ x ≤ b <-> x ∈ (a, b). Proof. intros A x; unfold contains, contains_Q; simpl. mc_setoid_replace (meet a b) with a by now apply lattices.meet_l. mc_setoid_replace (join a b) with b by now apply lattices.join_r. reflexivity. Qed. Lemma CRabs_negate (x : CR) : abs (-x) = abs x. Proof. change (abs (-x)) with (CRabs (-x)). rewrite CRabs_opp; reflexivity. Qed. Lemma mspc_ball_Qle (r a x : Q) : @mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) r a x <-> a - r ≤ x ≤ a + r. Proof. rewrite mspc_ball_Qabs; apply Qabs_diff_Qle. Qed. Lemma mspc_ball_convex (x1 x2 r a x : Q) : @mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) r a x1 -> @mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) r a x2 -> x ∈ (x1, x2) -> @mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) r a x. Proof. intros A1 A2 A3. rewrite mspc_ball_Qle in A1, A2. apply mspc_ball_Qle. destruct A1 as [A1' A1'']; destruct A2 as [A2' A2'']; destruct A3 as [A3' A3'']. split. + now transitivity (meet x1 x2); [apply meet_glb |]. + now transitivity (join x1 x2); [| apply join_lub]. Qed. Section IntegralTotal. Context (f : Q -> CR) `{Integrable f}. Program Definition int (from to : Q) := if (decide (from ≤ to)) then integrate f from (to - from) else -integrate f to (from - to). Next Obligation. change (0 ≤ to - from). (* without [change], the following [apply] does not work *) now apply rings.flip_nonneg_minus. Qed. Next Obligation. change (0 ≤ from - to). (* [apply rings.flip_nonneg_minus, orders.le_flip] does not work *) apply rings.flip_nonneg_minus; now apply orders.le_flip. Qed. Lemma integral_additive' (a b : Q) (u v w : QnonNeg) : a + `u = b -> `u + `v = `w -> ∫ f a u + ∫ f b v = ∫ f a w. Proof. intros A1 A2. assert (QnonNeg.eq (u+v)%Qnn w) as H0 by apply A2. assert (Qeq (a+`u) b) as H1 by apply A1. transitivity ( ∫ f a u + ∫ f (a+`u) v). apply ucFun2_wd. reflexivity. rewrite <- A1. reflexivity. rewrite <- H0. apply integral_additive. Qed. Lemma int_add (a b c : Q) : int a b + int b c = int a c. Proof. unfold int. destruct (decide (a ≤ b)) as [AB | AB]; destruct (decide (b ≤ c)) as [BC | BC]; destruct (decide (a ≤ c)) as [AC | AC]. + apply integral_additive'; simpl; ring. + assert (A : a ≤ c) by (now transitivity b); elim (AC A). + apply minus_eq_plus. symmetry. pose proof (integral_additive' a c ((c - a) ↾ int_obligation_1 a c AC) ((b - c) ↾ int_obligation_2 b c BC) ((b - a) ↾ int_obligation_1 a b AB) ). apply H0. clear H0. simpl. ring. simpl. ring. + apply minus_eq_plus. rewrite (rings.plus_comm (-integrate _ _ _)), <- plus_eq_minus, (rings.plus_comm (integrate _ _ _)). pose proof (integral_additive' c a ((a - c) ↾ int_obligation_2 a c AC) ((b - a) ↾ int_obligation_1 a b AB) ((b - c) ↾ int_obligation_2 b c BC) ). apply H0. clear H0. simpl. ring. simpl. ring. + rewrite (rings.plus_comm (-integrate _ _ _)). apply minus_eq_plus. rewrite (rings.plus_comm (integrate _ _ _)). symmetry. pose proof (integral_additive' b a ((a - b) ↾ int_obligation_2 a b AB) ((c - a) ↾ int_obligation_1 a c AC) ((c - b) ↾ int_obligation_1 b c BC) ). apply H0. clear H0. simpl. ring. simpl. ring. + rewrite (rings.plus_comm (-integrate _ _ _)). apply minus_eq_plus. rewrite (rings.plus_comm (-integrate _ _ _)), <- plus_eq_minus. pose proof (integral_additive' b c ((c - b) ↾ int_obligation_1 b c BC) ((a - c) ↾ int_obligation_2 a c AC) ((a - b) ↾ int_obligation_2 a b AB) ). apply H0. clear H0. simpl. ring. simpl. ring. + assert (b ≤ a) by (now apply orders.le_flip); assert (B : b ≤ c) by (now transitivity a); elim (BC B). + rewrite <- rings.negate_plus_distr. apply negate_inj. rewrite (rings.plus_comm (integrate _ _ _)). pose proof (integral_additive' c b ((b - c) ↾ int_obligation_2 b c BC) ((a - b) ↾ int_obligation_2 a b AB) ((a - c) ↾ int_obligation_2 a c AC) ). apply H0. clear H0. simpl. ring. simpl. ring. Qed. Lemma int_diff (a b c : Q) : int a b - int a c = int c b. Proof. apply minus_eq_plus. symmetry. rewrite (rings.plus_comm (int c b) (int a c)). pose proof (int_add a c b). apply H0. Qed. Lemma int_zero_width (a : Q) : int a a = 0. Proof. apply (plus_right_cancel (int a a)). rewrite rings.plus_0_l. pose proof (int_add a a a). exact H0. Qed. Lemma int_opposite (a b : Q) : int a b = - int b a. Proof. apply (CRplus_eq_r (int b a)). rewrite CRplus_opp. pose proof (int_add b a b). rewrite H0. pose proof (int_zero_width b). exact H1. Qed. Lemma int_abs_bound (a b M : Q) : (forall x : Q, x ∈ (a, b) -> abs (f x) ≤ 'M) -> abs (int a b) ≤ '(abs (b - a) * M). Proof. intros A. unfold int. assert (0 <= (' M))%CR as Mpos. { apply (@CRle_trans _ (abs (f a))). apply CRabs_nonneg. apply (A a). split. apply meet_lb_l. apply join_ub_l. } destruct (decide (a ≤ b)) as [AB | AB]. - assert (∀ x : Q, a ≤ x ≤ a + ` ((b - a) ↾ int_obligation_1 a b AB) → CRabs (f x) ≤ ' M). { intros. apply A. split; simpl. apply (Qle_trans _ a). apply meet_lb_l. apply H0. simpl in H0. apply (Qle_trans _ b). destruct H0. ring_simplify in H1. exact H1. apply join_ub_r. } apply (CRle_trans (integral_abs_bound f a ((b - a) ↾ int_obligation_1 a b AB) M H0)). simpl. rewrite Qmult_comm, <- (Qmult_comm M). rewrite <- CRmult_Qmult, <- CRmult_Qmult. apply CRmult_le_compat_l. exact Mpos. apply CRle_Qle. apply Qle_Qabs. - unfold abs, abs_sig, CR_abs, proj1_sig. rewrite CRabs_opp. assert (∀ x : Q, b ≤ x ≤ b + ` ((a - b) ↾ int_obligation_2 a b AB) → CRabs (f x) ≤ ' M). { intros. apply A. split; simpl. apply (Qle_trans _ b). apply meet_lb_r. apply H0. simpl in H0. apply (Qle_trans _ a). destruct H0. ring_simplify in H1. exact H1. apply join_ub_l. } apply (CRle_trans (integral_abs_bound f b ((a - b) ↾ int_obligation_2 a b AB) M H0)). unfold proj1_sig, stdlib_rationals.Abs_instance_0. rewrite Qmult_comm, <- (Qmult_comm M). rewrite <- CRmult_Qmult, <- CRmult_Qmult. apply CRmult_le_compat_l. exact Mpos. apply CRle_Qle. rewrite (Qabs_Qminus b a). apply Qle_Qabs. Qed. End IntegralTotal. (*Lemma int_plus (f g : Q -> CR) `{Integrable f, Integrable g} `{!IsLocallyUniformlyContinuous f f_mu, !IsLocallyUniformlyContinuous f f_mu} (a b : Q) : int f a b + int g a b = int (f + g) a b. Proof. unfold int. destruct (decide (a ≤ b)); [reflexivity |]. symmetry; unfold integrate at 1, integrate_sum. apply rings.negate_plus_distr. (* does not work without unfold *) Qed.*) Lemma integrate_plus (f g : Q -> CR) `{@IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f f_mu, @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) g g_mu} (a : Q) (w : QnonNeg) : @integrate (f + g) (@Integral_instance_0 (f+g) _ (@uc_ulc _ _ _ _ _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) f g _ _ _ _))) a w = ∫ f a w + ∫ g a w. Proof. apply ball_closed. intros e e_pos. mc_setoid_replace (0 + e) with e by ring. assert (he_pos : 0 < e / 2) by solve_propholds. assert (qe_pos : 0 < e / 4) by solve_propholds. destruct (integral_approximation f a w (exist _ _ qe_pos)) as [Nf F]. destruct (integral_approximation g a w (exist _ _ qe_pos)) as [Ng G]. destruct (@integral_approximation (f + g) (@Integral_instance_0 (f+g) _ (@uc_ulc _ _ _ _ _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) f g _ _ _ _))) _ _ (@uc_ulc _ _ _ _ _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) f g _ _ _ _)) a w (exist _ _ he_pos)) as [Ns S]. (* [Le positive] is not yet defined *) set (n := Pos.max (Pos.max Nf Ng) Ns). assert (Nf <= n)%positive by (transitivity (Pos.max Nf Ng); apply Pos.le_max_l). assert (Ng <= n)%positive by (transitivity (Pos.max Nf Ng); [apply Pos.le_max_r | apply Pos.le_max_l]). assert (Ns <= n)%positive by apply Pos.le_max_r. setoid_replace e with (e/2+e/2)%Q. apply ball_triangle with (b:= riemann_sum (f + g) a (proj1_sig w) n). - apply ball_sym, S; assumption. - rewrite riemann_sum_plus. mc_setoid_replace (e / 2) with (e / 4 + e / 4) by (field; split; discriminate). now apply mspc_ball_CRplus; [apply F | apply G]. - unfold Qdiv. rewrite <- Qmult_plus_distr_r. setoid_replace (/ 2 + / 2)%Q with 1%Q by reflexivity. rewrite Qmult_1_r. reflexivity. Qed. Lemma integrate_negate (f : Q -> CR) `{!IsUniformlyContinuous f f_mu} (a : Q) (w : QnonNeg) : ∫ (- f) a w = - ∫ f a w. Proof. apply ball_closed. intros e e_pos. mc_setoid_replace (0 + e) with e by ring. assert (he_pos : 0 < e / 2) by solve_propholds. destruct (integral_approximation (- f) a w (exist _ _ he_pos)) as [N1 F1]. destruct (integral_approximation f a w (exist _ _ he_pos)) as [N2 F2]. set (n := Pos.max N1 N2). assert (N1 <= n)%positive by apply Pos.le_max_l. assert (N2 <= n)%positive by apply Pos.le_max_r. setoid_replace e with (e/2+e/2)%Q. apply ball_triangle with (b:=riemann_sum (- f) a (proj1_sig w) n). - apply ball_sym, F1, H. - rewrite riemann_sum_negate. now apply mspc_ball_CRnegate, F2. - unfold Qdiv. rewrite <- Qmult_plus_distr_r. setoid_replace (/ 2 + / 2)%Q with 1%Q by reflexivity. rewrite Qmult_1_r. reflexivity. Qed. Lemma int_plus (f g : Q -> CR) `{@IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f f_mu, @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) g g_mu} (a b : Q) : @int (f + g) (@Integral_instance_0 (f+g) _ (@uc_ulc _ _ _ _ _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) f g _ _ _ _))) a b = int f a b + int g a b. Proof. unfold int; destruct (decide (a ≤ b)). rewrite integrate_plus. reflexivity. pose proof (integrate_plus f g b ((a - b) ↾ int_obligation_2 a b n)). rewrite H1. clear H1. apply rings.negate_plus_distr. Qed. Lemma int_negate (f : Q -> CR) `{!IsUniformlyContinuous f f_mu} (a b : Q) : int (- f) a b = - int f a b. Proof. unfold int; destruct (decide (a ≤ b)). rewrite integrate_negate. reflexivity. pose proof (integrate_negate f b ((a - b) ↾ int_obligation_2 a b n)). rewrite H. reflexivity. Qed. Lemma int_minus (f g : Q -> CR) `{@IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f f_mu, @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) g g_mu} (a b : Q) : @int (f - g) (@Integral_instance_0 (f-g) _ (@uc_ulc _ _ _ _ _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) f (-g) _ _ _ _))) a b = int f a b - int g a b. Proof. rewrite int_plus. pose proof (int_negate g a b). transitivity (int f a b + - int g a b). apply ucFun2_wd. reflexivity. exact H1. reflexivity. Qed. Lemma abs_int_minus (f g : Q -> CR) `{@IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f f_mu, @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) g g_mu} (a b : Q) : abs (@int (f - g) (@Integral_instance_0 (f-g) _ (@uc_ulc _ _ _ _ _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) f (-g) _ _ _ _))) a b) == abs (int f a b - int g a b). Proof. apply CRabs_wd, int_minus. Qed. Import interfaces.orders orders.semirings. Definition Qupper_bound (x : CR) := approximate x (Qpos2QposInf (1#1)) + 1. (* To be proved by lifting from Q. Lemma CRabs_triang (x y z : CR) : x = y + z -> abs x ≤ abs y + abs z. *) (* The section IntegralLipschitz is not used in the ODE solver through Picard iterations. Instead of assuming the function that is being integrated to be Lipschitz, the development assumes that it is uniformly continuous and bounded. Then integral is Lispchitz, but it is only proved that it is uniformly continuous. *) Section IntegralLipschitz. Notation ball := mspc_ball. Context (f : Q -> CR) (x0 : Q) `{!@IsLocallyLipschitz Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f L} `{Integral f, !Integrable f}. Let F (x : Q) := int f x0 x. Section IntegralLipschitzBall. Variables (a r x1 x2 : Q). Hypotheses (I1 : @ball Q (msp_mspc_ball Q_as_MetricSpace) r a x1) (I2 : @ball Q (msp_mspc_ball Q_as_MetricSpace) r a x2) (r_nonneg : 0 ≤ r). Let La := L a r. Lemma int_lip (e M : Q) : (∀ x, @ball Q (msp_mspc_ball Q_as_MetricSpace) r a x -> abs (f x) ≤ 'M) -> @ball Q (msp_mspc_ball Q_as_MetricSpace) e x1 x2 -> @ball CR (msp_mspc_ball CR) (M * e) (F x1) (F x2). Proof. intros A1 A2. apply CRball.gball_CRabs. subst F; cbv beta. change (int f x0 x1 - int f x0 x2)%CR with (int f x0 x1 - int f x0 x2). pose proof (int_diff f x0 x1 x2). rewrite H1. change (abs (int f x2 x1) ≤ '(M * e)). transitivity ('(M * abs (x1 - x2))). + rewrite mult_comm. apply int_abs_bound; trivial. intros x A3; apply A1, (mspc_ball_convex x2 x1); easy. + apply CRle_Qle. assert (0 ≤ M). - apply CRle_Qle. transitivity (abs (f a)); [apply CRabs_nonneg | apply A1, @mspc_refl]. exact (msp_mspc_ball_ext Q_as_MetricSpace). easy. - change (M * abs (x1 - x2) ≤ M * e). apply (orders.order_preserving (M *.)). apply gball_Qabs, A2. Qed. End IntegralLipschitzBall. Lemma lipschitz_bounded (a r M x : Q) : abs (f a) ≤ 'M -> @ball Q (msp_mspc_ball Q_as_MetricSpace) r a x -> abs (f x) ≤ '(M + L a r * r). Proof. intros A1 A2. assert (f x = f x - 0) as H1. { rewrite rings.minus_0_r. reflexivity. } pose proof (CRabs_wd _ _ H1). rewrite H2. clear H2 H1. apply mspc_ball_CRabs, mspc_symm. apply (mspc_triangle _ _ _ (f a)). - apply mspc_ball_CRabs. assert (0 - f a = - f a) as H1. { rewrite rings.plus_0_l. reflexivity. } pose proof (CRabs_wd _ _ H1). rewrite H2. clear H2 H1. pose proof (CRabs_negate (f a)). now rewrite H1. - apply (@llip _ _ _ _ (msp_mspc_ball_ext Q_as_MetricSpace) f _ H). 2: exact A2. 2: exact A2. apply mspc_refl. apply (@radius_nonneg _ _ (msp_mspc_ball_ext Q_as_MetricSpace) a x). exact A2. Qed. Global Instance integral_lipschitz : @IsLocallyLipschitz Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) F (λ a r, Qupper_bound (abs (f a)) + L a r * r). Proof. intros a r r_nonneg. constructor. + apply nonneg_plus_compat. - apply CRle_Qle. transitivity (abs (f a)); [apply CRabs_nonneg | apply upper_CRapproximation]. - apply nonneg_mult_compat. 2: exact r_nonneg. apply (@lip_nonneg _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball r a)) CR _ (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR f a r)). apply llip_prf. exact H. exact r_nonneg. (* Not good to provide [(restrict f a r)]. [IsLipschitz (restrict f a r) (L a r)] is generated *) + intros x1 x2 d A. destruct x1 as [x1 A1]; destruct x2 as [x2 A2]. change (ball ((Qupper_bound (abs (f a)) + L a r * r) * d) (F x1) (F x2)). apply (int_lip a r); trivial. intros x B. now apply lipschitz_bounded; [apply upper_CRapproximation |]. Qed. End IntegralLipschitz. Import minmax (*Coq.Program.*)Basics. (*Global Instance Qball_decidable (r : Qinf) (a x : Q) : Decision (mspc_ball r a x). destruct r as [r |]; [| now left]. apply (decision_proper (Qabs (a - x) <= r)%Q); [symmetry; apply gball_Qabs | apply _]. Defined.*) Section AbsFacts. Context `{Ring R} `{!FullPseudoSemiRingOrder Rle Rlt} `{!Abs R}. (* Should this be made a Class? It seems particular and complicated *) Definition abs_cases_statement (P : R -> Prop) := Proper (equiv ==> iff) P -> (forall x, Stable (P x)) -> forall x : R, (0 ≤ x -> P x) /\ (x ≤ 0 -> P (- x)) -> P (abs x). Context `(abs_cases : forall P : R -> Prop, abs_cases_statement P) `{le_stable : forall x y : R, Stable (x ≤ y)}. Lemma abs_nonneg' (x : R) : 0 ≤ abs x. Proof. apply abs_cases. + intros y1 y2 E; now rewrite E. + apply _. + split; [trivial |]. intros ?; now apply rings.flip_nonpos_negate. Qed. End AbsFacts. Lemma Qabs_cases : forall P : Q -> Prop, abs_cases_statement P. Proof. intros P Pp Ps x [? ?]. destruct (decide (0 ≤ x)) as [A | A]; [rewrite abs.abs_nonneg | apply le_flip in A; rewrite abs.abs_nonpos]; auto. (* [easy] instead of [auto] does not work *) Qed. Lemma Qabs_nonneg (x : Q) : 0 ≤ abs x. Proof. apply abs_nonneg'; [apply Qabs_cases | apply _]. Qed. (* Lemma integrate_proper (f g: Q → CR) `{!LocallyUniformlyContinuous_mu g} `{!LocallyUniformlyContinuous g} {fint: Integral f} {gint: Integral g} `{!@Integrable f fint} `{!@Integrable g gint}: canonical_names.equiv f g → ∀ (a: Q) (w: QnonNeg), @integrate f fint a w == @integrate g gint a w. (* This requires continuity for g only because [unique] does. *) Proof with try assumption. intros. apply (unique g)... apply (Integrable_proper_l f)... Qed. *) corn-8.20.0/ode/BanachFixpoint.v000066400000000000000000000206521473720167500164160ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import QArith. Require Import MathClasses.implementations.stdlib_rationals CoRN.model.structures.Qinf CoRN.model.structures.Qpossec CoRN.model.structures.QposInf CoRN.model.structures.QnonNeg MathClasses.interfaces.abstract_algebra MathClasses.implementations.QType_rationals MathClasses.interfaces.additional_operations. Require Import CoRN.tactics.Qauto. From Coq Require Import QOrderedType. Require Import MathClasses.theory.rings MathClasses.theory.dec_fields MathClasses.orders.rings MathClasses.orders.dec_fields MathClasses.theory.nat_pow. Require Import MathClasses.interfaces.naturals MathClasses.interfaces.orders. Import peano_naturals. Require Import CoRN.reals.fast.CRGeometricSum. Import Qround Qpower. Require Import CoRN.ode.metric. Local Notation ball := mspc_ball. Local Notation "x ²" := (x * x) (at level 30) : mc_scope. Section BanachFixpoint. Add Field Q : (stdlib_field_theory Q). Context `{MetricSpaceClass X} {Xlim : Limit X} {Xcms : CompleteMetricSpaceClass X}. Context (f : X -> X) `{!IsContraction f q} (x0 : X). Let x n := Nat.iter n f x0. Arguments x n%mc. Lemma x_Sn : forall n, x (1 + n) = f (x n). Proof. reflexivity. Qed. Let d := msd (x 0) (x 1). Instance : PropHolds (0 ≤ d). Proof. apply msd_nonneg. Qed. Instance : PropHolds (0 ≤ q). Proof. apply (lip_nonneg f q). (* [apply (lip_nonneg f)] leaves a goal [IsLipschitz f q], which [apply _] solves *) Qed. Instance : PropHolds (q < 1). Proof. apply (contr_lt_1 f q). Qed. Instance : PropHolds (0 < 1 - q). Proof. assert (A := contr_lt_1 f q). rewrite <- flip_lt_negate in A. apply (strictly_order_preserving (1 +)) in A. now rewrite plus_negate_r in A. Qed. Global Instance : forall q : Q, PropHolds (0 < q) -> PropHolds (q ≠ 0). Proof. apply lt_ne_flip. Qed. Lemma dist_xn_xSn : forall n : nat, ball (d * q^n) (x n) (x (1 + n)). Proof. induction n using nat_induction. + rewrite nat_pow_0, right_identity; subst d; apply mspc_distance. + rewrite nat_pow_S. mc_setoid_replace (d * (q * q ^ n)) with (q * (d * q^n)) by ring. change (x (1 + n)) with (f (x n)); change (x (1 + (1 + n))) with (f (x (1 + n))). now apply contr_prf. Qed. Lemma dist_xm_xn : forall m n : nat, ball (d * q^m * (1 - q^n) / (1 - q)) (x m) (x (m + n)). Proof. intro m; induction n as [| n IH] using nat_induction. + rewrite right_identity; apply mspc_refl. now rewrite nat_pow_0, plus_negate_r, right_absorb, left_absorb. + apply (mspc_triangle' (d * q^m * (1 - q^n) / (1 - q))%mc (d * q^(m + n))%mc (x (m + n))); trivial. - rewrite nat_pow_S, nat_pow_exp_plus. field; solve_propholds. - mc_setoid_replace (m + (1 + n)) with (1 + (m + n)) by ring. apply dist_xn_xSn. Qed. Lemma dist_xm_xn' : forall m n : nat, ball (d * q^m / (1 - q)) (x m) (x (m + n)). Proof. intros m n. apply (mspc_monotone (d * q^m * (1 - q^n) / (1 - q))%mc); [| apply dist_xm_xn]. apply (order_preserving (.* /(1 - q))). rewrite <- associativity. apply (order_preserving (d *.)). rewrite <- (mult_1_r (q^m)) at 2. apply (order_preserving (q^m *.)). rewrite <- (plus_0_r 1) at 2. apply (order_preserving (1 +)). rewrite <- negate_0. apply flip_le_negate. solve_propholds. Qed. Lemma Qpower_mc_power (e : Q) (n : nat) : (e ^ n)%Q = (e ^ n)%mc. Proof. induction n as [| n IH] using nat_induction. + now rewrite nat_pow_0. + rewrite Nat2Z.inj_add, Qpower_plus'. - now rewrite nat_pow_S, IH. - rewrite <- Nat2Z.inj_add; change 0%Z with (Z.of_nat 0); rewrite Nat2Z.inj_iff; apply not_eq_sym, O_S. (* SearchPattern (?x ≢ ?y -> ?y ≢ ?x). Anomaly: Signature and its instance do not match. Please report. *) Qed. Lemma Qstepl : forall (x y z : Q), x ≤ y -> x = z -> z ≤ y. Proof. intros ? ? ? ? A2; now rewrite <- A2. Qed. Lemma Qstepr : forall (x y z : Q), x ≤ y -> y = z -> x ≤ z. Proof. intros ? ? ? ? A2; now rewrite <- A2. Qed. Declare Left Step Qstepl. Declare Right Step Qstepr. Lemma binom_ineq (a : Q) (n : nat) : -1 ≤ a -> 1 + (inject_Z n) * a ≤ (1 + a)^n. Proof. intro A. assert (A1 : 0 ≤ 1 + a) by (now apply (order_preserving (1 +)) in A; rewrite plus_negate_r in A). induction n as [| n IH] using nat_induction. + rewrite nat_pow_0; change (1 + 0 * a ≤ 1); now rewrite mult_0_l, plus_0_r. + rewrite nat_pow_S. transitivity ((1 + a) * (1 + (inject_Z n) * a)). - rewrite Nat2Z.inj_add, inject_Z_plus. stepr (1 + (1 + (inject_Z n)) * a + (inject_Z n) * a²) by ring. (* [apply nonneg_plus_le_compat_r, nonneg_mult_compat. does not work *) apply nonneg_plus_le_compat_r. apply nonneg_mult_compat; [solve_propholds | apply square_nonneg]. - now apply (order_preserving ((1 + a) *.)) in IH. Qed. Lemma nat_pow_recip `{DecField A} `{Naturals B} `{!NatPowSpec A B pw} : (∀ x y : A, Decision (x = y)) -> forall (a : A) (n : B), (/a) ^ n = /(a ^ n). Proof. intros D a. apply naturals.induction. + intros n1 n2 E; now rewrite E. + rewrite !nat_pow_0; symmetry; apply dec_recip_1. + intros n IH. now rewrite !nat_pow_S, dec_recip_distr, IH. Qed. (* Lemma power_tends_to_zero (e : Q) (n : nat) : 0 < e -> Z.to_nat (Qceiling (q * (1 - e) / (e * (1 - q)))%mc) ≤ n -> q ^ n ≤ e. Proof. intros e_pos n_big. assert (A : /e ≤ (/q)^n). + mc_setoid_replace (/ q) with (1 + (/ q - 1)) by ring. transitivity (1 + (n : Q) * (/ q - 1)). - apply Qle_Qceiling_nat in n_big. set (m := (n : Q)) in *. let T := type of n_big in match T with (Qle ?l ?r) => change (l ≤ r) in n_big end. apply (order_reflecting (-1 +)). rewrite plus_assoc, plus_negate_l, plus_0_l. apply (order_preserving (.* (/q - 1))) in n_big. apply (po_proper' n_big); [| easy]. field. (* When [plus_assoc : Associative (+)], the last rewrite does not work *) cut (forall x y z : Q, x + (y + z) = (x + y) + z). intro ass. rewrite ass. rewrite plus_assoc. - apply binom_ineq. rewrite <- (plus_0_l (-1)) at 1. apply (order_preserving (+ (-1))); solve_propholds. + rewrite nat_pow_recip in A; [| apply _]. apply flip_le_dec_recip in A; [| solve_propholds]. now rewrite !dec_recip_involutive in A. Qed. SearchAbout (/ (/ _) )%mc. flip_le_dec_recip *) Lemma power_tends_to_zero (e : Q) (n : nat) : 0 < e -> Z.to_nat (Qceiling (/(e * (1 - q)))%mc) ≤ n -> q ^ n ≤ e. Proof. intros A1 A2. assert (A3 : 0 < n). + let T := type of A2 in match T with (?lhs ≤ _) => apply lt_le_trans with (y := lhs) end; [| trivial]. apply Q.Qlt_lt_of_nat_inject_Z; change (0 < / (e * (1 - q))); solve_propholds. + destruct n as [| n]; [elim (Nat.lt_irrefl _ A3) |]. rewrite <- Qpower_mc_power. apply GeometricCovergenceLemma with (e := e ↾ A1); [solve_propholds .. |]. apply (Q.le_Qle_Qceiling_to_nat _ (S n)), A2. Qed. Lemma const_x (N : Q -> nat) : d = 0 -> cauchy x N. Proof. intro eq_d_0. assert (A := mspc_distance (x 0) (x 1)). subst d; rewrite eq_d_0 in A. assert (C : forall n, x n = x 0). + induction n as [| n IH] using nat_induction; [easy |]. change (x (1 + n)) with (f (x n)). rewrite IH. symmetry; apply A. + intros e e_pos m n _ _. rewrite (C m), (C n). (* second "rewrite C" does not work *) apply mspc_refl. solve_propholds. Qed. Lemma cauchy_x : cauchy x (λ e, Z.to_nat (Qceiling (d / (e * (1 - q)²))%mc)). Proof. assert (d_nonneg : 0 ≤ d) by solve_propholds. assert (d_pos_0 : 0 = d \/ 0 < d) by now apply le_equiv_lt. destruct d_pos_0 as [d_0 | d_pos]; [now apply const_x |]. intros e e_pos. (* without loss of generality, m ≤ n *) match goal with |- forall m n, @?G m n => intros m n; assert (A : forall m n, m ≤ n -> G m n) end. + clear m n; intros m n le_m_n A _. rewrite <- (cut_minus_le n m); trivial. rewrite plus_comm. apply (mspc_monotone (d * q^m / (1 - q))%mc); [| apply dist_xm_xn']. cut (q ^ m ≤ e * (1 - q) / d). - intro A1. apply (order_preserving (d *.)), (order_preserving (.* /(1 - q))) in A1. apply (po_proper' A1); [easy | field; split; solve_propholds]. - apply power_tends_to_zero; [solve_propholds |]. apply (po_proper' A); [| easy]. apply f_equal, Qceiling_comp. match goal with |- (Qeq ?l ?r) => change (l = r) end. field; repeat split; solve_propholds. + assert (A1 : TotalRelation (A := nat) (≤)) by apply _; destruct (A1 m n). - now apply A. - intros; apply mspc_symm; now apply A. Qed. Definition fp := lim (reg_fun x _ cauchy_x). Lemma banach_fixpoint : f fp = fp. Proof. assert (C := cauchy_x). (* [Check seq_lim_lim (A := C)] says "Wrong argument name: A", but [About seq_lim_lim] shows A *) eapply (iter_fixpoint f x); [easy | apply seq_lim_lim]. Qed. End BanachFixpoint. corn-8.20.0/ode/FromMetric2.v000066400000000000000000000232251473720167500156510ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.metric2.Complete CoRN.metric2.Metric CoRN.ode.metric. Require Import CoRN.model.totalorder.QposMinMax MathClasses.interfaces.abstract_algebra MathClasses.interfaces.rationals MathClasses.implementations.stdlib_rationals MathClasses.orders.orders MathClasses.orders.semirings MathClasses.orders.rings MathClasses.theory.rings. Import Qinf.notations Qinf.coercions. Section QField. Add Field Q : (dec_fields.stdlib_field_theory Q). Section FromMetricSpace. Variable X : MetricSpace. Global Instance msp_mspc_ball : MetricSpaceBall X := λ (e : Qinf) (x y : X), match e with | Qinf.finite e' => ball e' x y | Qinf.infinite => True end. Instance : Proper ((=) ==> (≡) ==> (≡) ==> iff) mspc_ball. Proof. intros e1 e2 E1 x1 x2 E2 y1 y2 E3. destruct e1 as [e1 |]; destruct e2 as [e2 |]; try (unfold equiv, Qinf.eq in *; contradiction); try reflexivity. unfold mspc_ball, msp_mspc_ball. change (e1 = e2) in E1. now rewrite E1, E2, E3. Qed. Global Instance msp_mspc_ball_ext : ExtMetricSpaceClass X. Proof. constructor. + apply _. + intros; apply I. + intros. intro abs. apply (Qlt_not_le _ _ H). apply (msp_nonneg (msp X) e x y abs). + intros. intro x. apply ball_refl, H. + intros [e |]. intros x y H. apply ball_sym. exact H. easy. + apply ball_triangle. + apply ball_closed. Qed. Definition conv_reg (f : RegularFunction X) : Complete.RegularFunction (@ball X). refine (@mkRegularFunction _ (f 0) (λ e : Qpos, let (e', _) := e in f e') _). intros [e1 e1_pos] [e2 e2_pos]. apply (rf_proof f); assumption. Defined. End FromMetricSpace. Arguments conv_reg {X} _. Set Printing Coercions. Section FromCompleteMetricSpace. Variable X : MetricSpace. Global Instance limit_complete : Limit (Complete X) := λ f : RegularFunction (Complete X), Cjoin_fun (conv_reg f). Global Instance : CompleteMetricSpaceClass (Complete X). Proof. constructor; [| apply _]. apply ext_equiv_r; [intros x y E; apply E |]. intros f e1 e2 e1_pos e2_pos. pose proof (CunitCjoin (conv_reg f) (e1 ↾ e1_pos) (e2 ↾ e2_pos)). rewrite Qplus_0_r in H. apply H. Qed. Lemma gball_complete (r : Q) (x y : Complete X) : ball r x y <-> forall e1 e2 : Qpos, ball (proj1_sig e1 + r + proj1_sig e2)%mc (approximate x e1) (approximate y e2). Proof. destruct (Qsec.Qdec_sign r) as [[r_neg | r_pos] | r_zero]. + split; intro H; [exfalso | exact H]. apply (Qlt_not_le _ _ r_neg). assert (H1 : 0 < -(r / 3)) by (apply Q.Qopp_Qlt_0_l, Q.Qmult_neg_pos; auto with qarith). specialize (H (exist _ _ H1) (exist _ _ H1)); simpl in H. mc_setoid_replace (- (r / 3) + r + - (r / 3)) with (r / 3) in H by (field; discriminate). apply (msp_nonneg (msp X)) in H. apply (Qmult_le_r _ _ (1#3)). reflexivity. rewrite Qmult_0_l. exact H. + simpl; unfold regFunBall. split; intros H e1 e2. - specialize (H e1 e2). apply H. - apply H. + rewrite r_zero. simpl; unfold regFunEq. split; intros H e1 e2; specialize (H e1 e2). - rewrite r_zero, Qplus_0_r. rewrite Qplus_0_r in H. exact H. - rewrite Qplus_0_r. rewrite r_zero, Qplus_0_r in H. exact H. Qed. End FromCompleteMetricSpace. Require Import CoRN.model.metric2.CRmetric. Import metric. Section CompleteSegment. Context {X : MetricSpace} (r : Q) (a : Complete X). Global Program Instance : Limit (sig (mspc_ball r a)) := λ f, exist _ (lim (Build_RegularFunction (@proj1_sig _ _ ∘ f) _)) _. Next Obligation. apply f. Qed. Next Obligation. apply gball_complete; intros e1 e2. unfold lim, limit_complete, Cjoin_fun, Cjoin_raw; simpl. assert (H : mspc_ball r a ((@proj1_sig _ _ ∘ f) ((1 # 2) * proj1_sig e2)%Q)) by apply (proj2_sig (f ((1 # 2) * proj1_sig e2))). unfold mspc_ball, msp_mspc_ball in H. apply ball_weak_le with (proj1_sig e1 + r + (proj1_sig ((1 # 2) * e2)%Qpos)). + apply Qplus_le_r. apply Q.Qle_half. apply Qpos_nonneg. + apply gball_complete, H. Qed. Global Instance CompleteMetricSpaceClass_instance_1: CompleteMetricSpaceClass (sig (mspc_ball r a)). Proof. constructor; [| apply _]. apply ext_equiv_r; [intros x y E; apply E |]. intros f e1 e2 e1_pos e2_pos; unfold Datatypes.id. assert (C : CompleteMetricSpaceClass (Complete X)) by apply _. destruct C as [C _]. assert (R : IsRegularFunction (@proj1_sig _ _ ∘ f)) by apply f. specialize (C (Build_RegularFunction _ R) (Build_RegularFunction _ R)). now apply C. Qed. End CompleteSegment. Require Import CoRN.model.setoids.Qsetoid CoRN.model.metric2.Qmetric CoRN.reals.fast.CRArith CoRN.reals.fast.CRball CoRN.reals.fast.CRabs MathClasses.theory.abs MathClasses.orders.minmax. Import canonical_names. Add Ring CR : (stdlib_ring_theory CR). Close Scope CR_scope. Unset Printing Coercions. Section CRQBallProperties. Local Notation ball := mspc_ball. (* The following has to be generalized from Q and CR to a metric space where [ball r x y] is defined as [abs (x - y) ≤ r], probably a normed vector space *) Lemma mspc_ball_Qabs (r x y : Q) : @ball _ (msp_mspc_ball Q_as_MetricSpace) r x y ↔ abs (x - y) ≤ r. Proof. apply gball_Qabs. Qed. Lemma mspc_ball_Qabs_flip (r x y : Q) : @ball _ (msp_mspc_ball Q_as_MetricSpace) r x y ↔ abs (y - x) ≤ r. Proof. rewrite <- abs.abs_negate, <- rings.negate_swap_r. apply gball_Qabs. Qed. Lemma mspc_ball_CRabs (r : Q) (x y : CR) : ball r x y ↔ abs (x - y) ≤ 'r. Proof. apply CRball.gball_CRabs. Qed. (*Lemma mspc_ball_CRabs_flip (r : Q) (x y : CR) : ball r x y ↔ abs (y - x) ≤ 'r. Proof. rewrite <- abs.abs_negate, <- rings.negate_swap_r. apply gball_Qabs. Qed.*) Lemma mspc_ball_Qplus_l (e x y y' : Q) : @ball _ (msp_mspc_ball Q_as_MetricSpace) e y y' -> @ball _ (msp_mspc_ball Q_as_MetricSpace) e (x + y) (x + y'). Proof. intro A. assert (A1 := radius_nonneg _ _ _ A). destruct (orders.le_equiv_lt _ _ A1) as [e_zero | e_pos]. - unfold ball. simpl. rewrite <- e_zero. unfold ball in A. simpl in A. rewrite <- e_zero in A. apply Qball_plus_r. apply A. - now apply Qball_plus_r. Qed. (* This is a copy of [CRgball_plus] formulated in terms of [mspc_ball] instead of [gball]. Applying [CRgball_plus] introduces [gball] into the goal, and then applying some theorems about [mspc_ball] may not work. This is because [mspc_ball] reduces to [gball] but not the other way around. *) Lemma mspc_ball_CRplus (e1 e2 : Q) (x x' y y' : CR) : ball e1 x x' -> ball e2 y y' -> ball (e1 + e2) (x + y) (x' + y'). Proof. apply CRgball_plus. Qed. Lemma mspc_ball_CRplus_l (e : Q) (x y y' : CR) : ball e y y' -> ball e (x + y) (x + y'). Proof. intro A. rewrite <- (rings.plus_0_l e). apply mspc_ball_CRplus; [| easy]. now apply mspc_refl. Qed. Lemma mspc_ball_CRnegate (e : Q) (x y : CR) : mspc_ball e x y -> mspc_ball e (-x) (-y). Proof. intro A. intros a b. apply Qball_opp. apply A. Qed. Lemma nested_balls (x1 x2 : Q) {y1 y2 : Q} {e : Qinf} : @ball _ (msp_mspc_ball Q_as_MetricSpace) e x1 x2 -> x1 ≤ y1 -> y1 ≤ y2 -> y2 ≤ x2 -> @ball _ (msp_mspc_ball Q_as_MetricSpace) e y1 y2. Proof. intros B A1 A2 A3. destruct e as [e |]; [| apply mspc_inf]. apply mspc_ball_Qabs_flip in B. apply mspc_ball_Qabs_flip. assert (x1 ≤ x2). now apply (PreOrder_Transitive _ y1); [|apply (PreOrder_Transitive _ y2)]. rewrite abs.abs_nonneg by now apply rings.flip_nonneg_minus. rewrite abs.abs_nonneg in B by now apply rings.flip_nonneg_minus. apply rings.flip_le_minus_l. apply rings.flip_le_minus_l in B. apply (PreOrder_Transitive _ x2); [easy|]. apply (PreOrder_Transitive _ (e + x1)); [easy|]. apply (orders.order_preserving (e +)); easy. Qed. (* Too long? *) End CRQBallProperties. Global Instance sum_llip `{MetricSpaceBall X} (f g : X -> CR) `{!IsLocallyLipschitz f Lf} `{!IsLocallyLipschitz g Lg} : IsLocallyLipschitz (f + g) (λ x r, Lf x r + Lg x r). Proof. constructor. + pose proof (lip_nonneg (restrict f x r) (Lf x r)). pose proof (lip_nonneg (restrict g x r) (Lg x r)). solve_propholds. + intros x1 x2 e A. rewrite plus_mult_distr_r. apply CRgball_plus; [now apply: (lip_prf (restrict f x r) _) | now apply: (lip_prf (restrict g x r) _)]. Qed. (* Global Instance sum_lip `{MetricSpaceBall X} (f g : X -> CR) `{!IsLipschitz f Lf} `{!IsLipschitz g Lg} : IsLipschitz (f +1 g) (Lf + Lg). Proof. constructor. + pose proof (lip_nonneg f Lf); pose proof (lip_nonneg g Lg); change (0 ≤ Lf + Lg); solve_propholds. + intros x1 x2 e A. change (Lf + Lg)%Q with (Lf + Lg). rewrite plus_mult_distr_r. apply CRgball_plus; [now apply: (lip_prf f Lf) | now apply: (lip_prf g Lg)]. Qed. *) Import metric. (* Needed to be able to state the property that the integral of the sum is the sum of integrals *) Global Instance sum_uc `{ExtMetricSpaceClass X} (f g : X -> CR) `{!IsUniformlyContinuous f mu_f} `{!IsUniformlyContinuous g mu_g} : IsUniformlyContinuous (f + g) (λ e, min (mu_f (e / 2)) (mu_g (e / 2))). Proof. constructor. * intros e e_pos. apply lt_min; [apply (uc_pos f mu_f) | apply (uc_pos g mu_g)]; solve_propholds. * intros e x1 x2 e_pos A. mc_setoid_replace e with (e / 2 + e / 2) by (field; discriminate). apply CRgball_plus. + apply: (uc_prf f mu_f); [solve_propholds |]. apply (mspc_monotone' (min (mu_f (e / 2)) (mu_g (e / 2)))); [| assumption]. change ((mu_f (e / 2)) ⊓ (mu_g (e / 2)) ≤ mu_f (e / 2)). apply orders.meet_lb_l. (* does not work without [change] *) + apply: (uc_prf g mu_g); [solve_propholds |]. apply (mspc_monotone' (min (mu_f (e / 2)) (mu_g (e / 2)))); [| assumption]. change ((mu_f (e / 2)) ⊓ (mu_g (e / 2)) ≤ mu_g (e / 2)). apply orders.meet_lb_r. Qed. Global Instance negate_uc `{MetricSpaceBall X} (f : X -> CR) `{!IsUniformlyContinuous f mu_f} : IsUniformlyContinuous (- f) mu_f. Proof. constructor. * apply (uc_pos f _). * intros e x1 x2 e_pos A. apply mspc_ball_CRnegate, (uc_prf f mu_f); easy. Qed. End QField. corn-8.20.0/ode/Picard.v000066400000000000000000001047541473720167500147310ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.reals.CRreal. From Coq Require Import Utf8 Program. Require Import CoRN.reals.fast.CRArith CoRN.reals.fast.CRabs CoRN.tactics.Qauto. From Coq Require Import Qround. Require Import CoRN.model.metric2.Qmetric (*stdlib_omissions.P stdlib_omissions.Z stdlib_omissions.Q stdlib_omissions.N*). Require Qinf QnonNeg QnnInf CRball. Import QnonNeg Qinf.notations QnonNeg.notations QnnInf.notations CRball.notations Qinf.coercions Qabs propholds. Require Import CoRN.ode.metric CoRN.ode.FromMetric2 CoRN.ode.AbstractIntegration CoRN.ode.SimpleIntegration CoRN.ode.BanachFixpoint. Require Import MathClasses.interfaces.canonical_names MathClasses.misc.decision MathClasses.misc.setoid_tactics MathClasses.misc.util. Require Import MathClasses.implementations.stdlib_rationals MathClasses.theory.rationals. Close Scope uc_scope. (* There is a leak in some module *) Open Scope signature_scope. (* To interpret "==>" *) Bind Scope mc_scope with Q. Local Notation ball := mspc_ball. Lemma Qinf_lt_le (x y : Qinf) : x < y → x ≤ y. Proof. destruct x as [x |]; destruct y as [y |]; [| easy..]. change (x < y -> x ≤ y). intros; solve_propholds. Qed. #[global] Instance Q_nonneg (rx : QnonNeg) : PropHolds (@le Q _ 0 (proj1_sig rx)). Proof. intros. apply (proj2_sig rx). Qed. #[global] Instance Q_nonempty : NonEmpty Q := inhabits 0. #[global] Program Instance sig_nonempty `{ExtMetricSpaceClass X} (r : QnonNeg) (x : X) : NonEmpty (sig (ball (proj1_sig r) x)) := inhabits x. Next Obligation. apply mspc_refl; solve_propholds. Qed. #[global] Instance prod_nonempty `{NonEmpty X, NonEmpty Y} : NonEmpty (X * Y). Proof. (* In order not to refer to the name of the variable that has type NonEmpty X *) match goal with H : NonEmpty X |- _ => destruct H as [x] end. match goal with H : NonEmpty Y |- _ => destruct H as [y] end. exact (inhabits (x, y)). Qed. (* The following instances are needed to show that Lipschitz functions are uniformly continuous: metric.lip_uc *) Global Instance Qmsd : MetricSpaceDistance Q := λ x y, abs (x - y). Global Instance Qmsc : @MetricSpaceClass Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) Qmsd. Proof. intros x1 x2; apply gball_Qabs; reflexivity. Qed. (*Instance Q_nonempty : NonEmpty Q := inhabits 0%Q.*) Section Extend. Context `{ExtMetricSpaceClass Y} (a : Q) (r : QnonNeg). (* Sould [r] be [Q] or [QnonNeg]? If [r : Q], then [extend] below is not necessarily continuous. This may be OK because we could add the premise [0 ≤ r] to the lemma that says that [extend] is Lipschitz. However, the definition below is not well-typed because if [r < 0], then [ball r a (a - r)] is false, so we can't apply [f] to [a - r]. So we assume [r : QnonNeg]. *) Lemma mspc_ball_edge_l : @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a (a - `r). Proof. destruct r as [e ?]; simpl. apply gball_Qabs. mc_setoid_replace (a - (a - e)) with e by ring. change (abs e ≤ e). rewrite abs.abs_nonneg; [reflexivity | trivial]. Qed. Lemma mspc_ball_edge_r : @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a (a + `r). Proof. destruct r as [e ?]; simpl. apply Qmetric.gball_Qabs. mc_setoid_replace (a - (a + e)) with (-e) by ring. change (abs (-e) ≤ e). rewrite abs.abs_negate, abs.abs_nonneg; [reflexivity | trivial]. Qed. Context (f : sig (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a) -> Y). (* Since the following is a Program Definition, we could write [f (a - r)] and prove the obligation [mspc_ball r a (a - r)]. However, this obligation would depend on x and [H1 : x ≤ a - r] even though they are not used in the proof. So, if [H1 : x1 ≤ a - r] and [H2 : x2 ≤ a - r], then [extend x1] would reduce to [f ((a - r) ↾ extend_obligation_1 x1 H1)] and [extend x2] would reduce to [f ((a - r) ↾ extend_obligation_1 x2 H2)]. To apply mspc_refl (see [extend_uc] below), we would need to prove that these applications of f are equal, i.e., f is a morphism that does not depend on the second component of the pair. So instead we prove mspc_ball_edge_l and mspc_ball_edge_r, which don't depend on x. *) Program Definition extend : Q -> Y := λ x, if (decide (x < a - (proj1_sig r))) then f ((a - (r : Q)) ↾ mspc_ball_edge_l) else if (decide (a + r < x)) then f ((a + r) ↾ mspc_ball_edge_r) else f (x ↾ _). Next Obligation. apply mspc_ball_Qle. repeat match goal with [ H : ¬ _ < _ |- _ ] => apply orders.not_lt_le_flip in H end. now split. Qed. (* Global Instance extend_lip `{!IsLipschitz f L} : IsLipschitz extend L. Proof with (assumption || (apply orders.le_flip; assumption) || reflexivity). constructor; [apply (lip_nonneg f L) |]. intros x1 x2 e A. assert (0 ≤ e) by now apply (radius_nonneg x1 x2). assert (0 ≤ L) by apply (lip_nonneg f L). assert (a - proj1_sig r ≤ a + proj1_sig r) by (destruct r; simpl; transitivity a; [apply rings.nonneg_minus_compat | apply semirings.plus_le_compat_r]; (easy || reflexivity)). unfold extend. destruct (decide (x1 ≤ a - proj1_sig r)); destruct (decide (x2 ≤ a - proj1_sig r)). * apply mspc_refl; solve_propholds. * destruct (decide (a + proj1_sig r ≤ x2)); apply (lip_prf f L). + apply (nested_balls A)... + apply (nested_balls A)... * destruct (decide (a + proj1_sig r ≤ x1)); apply (lip_prf f L). + apply mspc_symm; apply mspc_symm in A. apply (nested_balls A)... + apply mspc_symm; apply mspc_symm in A. apply (nested_balls A)... * destruct (decide (a + proj1_sig r ≤ x1)); destruct (decide (a + proj1_sig r ≤ x2)); apply (lip_prf f L). + apply mspc_refl; solve_propholds. + apply mspc_symm; apply mspc_symm in A. apply (nested_balls A)... + apply (nested_balls A)... + apply A. Qed. *) Global Instance extend_uc : ∀ mu_f : Q → Qinf, @IsUniformlyContinuous _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f → @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) Y H extend mu_f. Proof with (solve_propholds || (apply orders.not_lt_le_flip; assumption) || reflexivity). intros. constructor. apply (@uc_pos _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f). exact H1. intros e x1 x2 e_pos A. assert (a - proj1_sig r ≤ a + proj1_sig r) by (destruct r; simpl; transitivity a; [apply rings.nonneg_minus_compat | apply semirings.plus_le_compat_r]; (easy || reflexivity)). unfold extend. destruct (decide (x1 < a - proj1_sig r)); destruct (decide (x2 < a - proj1_sig r)). * apply mspc_refl... * destruct (decide (a + proj1_sig r < x2)); apply (@uc_prf _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f); trivial. + apply (nested_balls _ _ A)... + apply (nested_balls _ _ A)... * destruct (decide (a + proj1_sig r < x1)); apply (@uc_prf _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f); trivial. + apply @mspc_symm. exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig r) a)). apply @mspc_symm in A. apply (nested_balls _ _ A)... exact (msp_mspc_ball_ext Q_as_MetricSpace). + apply @mspc_symm. exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig r) a)). apply @mspc_symm in A. apply (nested_balls _ _ A)... exact (msp_mspc_ball_ext Q_as_MetricSpace). * destruct (decide (a + proj1_sig r < x1)); destruct (decide (a + proj1_sig r < x2)); apply (@uc_prf _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f); trivial. + apply @mspc_refl'. exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig r) a)). apply Qinf_lt_le. apply (@uc_pos _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig r) a)) Y H f mu_f). assumption. assumption. + apply @mspc_symm. exact (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig r) a)). apply @mspc_symm in A. apply (nested_balls _ _ A)... exact (msp_mspc_ball_ext Q_as_MetricSpace). + apply (nested_balls _ _ A)... Qed. End Extend. Lemma extend_inside : ∀ {Y : CProp} {H : MetricSpaceBall Y} { _ : @ExtMetricSpaceClass Y H }, ∀ (a x : Q) (r : QnonNeg), @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x → ∃ p : @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x, ∀ f : sig (fun x : Q => @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x) → Y, @extend Y a r f x = f (x ↾ p). Proof. intros Y H H0 a x r A. apply mspc_ball_Qle in A. destruct A as [A1 A2]. unfold extend. destruct (decide (x < a - proj1_sig r)) as [H1 | H1]. (* [proj1_sig] is needed because otherwise [Negate QnonNeg] is unsatisfied. Backtick [`] is not enough because the goal is not simplified. *) * apply orders.lt_not_le_flip in H1; elim (H1 A1). * destruct (decide (a + proj1_sig r < x)) as [H2 | H2]. + apply orders.lt_not_le_flip in H2; elim (H2 A2). + eexists; intro f; reflexivity. Qed. Section Bounded. Class Bounded {X : Type} (f : X -> CR) (M : Q) := bounded : forall x, abs (f x) ≤ 'M. Global Instance comp_bounded {X Y : Type} (f : X -> Y) (g : Y -> CR) `{!Bounded g M} : Bounded (g ∘ f) M. Proof. intro x; unfold Basics.compose; apply bounded. Qed. Global Instance extend_bounded {a : Q} {r : QnonNeg} (f : {x | @ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig r) a x} -> CR) `{!Bounded f M} : Bounded (extend a r f) M. Proof. intro x. unfold extend. destruct (decide (x < a - proj1_sig r)); [| destruct (decide (a + proj1_sig r < x))]; apply bounded. Qed. Lemma bounded_nonneg {X : Type} (f : X -> CR) `{!Bounded f M} `{NonEmpty X} : (*PropHolds*) (0 ≤ M). Proof. match goal with H : NonEmpty X |- _ => destruct H as [x] end. apply CRle_Qle. change (@zero CR _ ≤ 'M). transitivity (abs (f x)). + apply CRabs_nonneg. + apply bounded. Qed. End Bounded. Global Instance bounded_int_uc {f : Q -> CR} {M : Q} `{!Bounded f M} `{!@IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) f mu_f} (x0 : Q) : @IsUniformlyContinuous Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) (λ x, int f x0 x) (lip_modulus M). Proof. constructor. + intros. apply lip_modulus_pos; [apply (bounded_nonneg f) | easy]. + intros e x1 x2 e_pos A. apply mspc_ball_CRabs. pose proof (CRabs_wd _ _ (int_diff f x0 x1 x2)). rewrite H0. clear H0. transitivity ('(abs (x1 - x2) * M)). - apply int_abs_bound; [apply _ |]. intros x _; apply bounded. - apply CRle_Qle. change (abs (x1 - x2) * M ≤ e). unfold lip_modulus in A. destruct (decide (M = 0)) as [E | E]. rewrite E, rings.mult_0_r. now apply orders.lt_le. (* why does [solve_propholds] not work? *) apply mspc_ball_Qabs in A. assert (0 ≤ M) by apply (bounded_nonneg f). apply (orders.order_preserving (.* M)) in A. now mc_setoid_replace (e / M * M) with e in A by (field; solve_propholds). Qed. Section Picard. Context (x0 : Q) (y0 : CR) (rx ry : QnonNeg). Notation sx := (sig (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0)). Notation sy := (sig (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)). Context (v : sx * sy -> CR) `{!Bounded v M} `{!@IsUniformlyContinuous _ (@Linf_product_metric_space_ball _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball r a)) _ (@sig_mspc_ball CR (msp_mspc_ball CR) (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)) ) CR (msp_mspc_ball CR) v mu_v} (L : Q). Hypothesis v_lip : forall x : sx, IsLipschitz (λ y, v (x, y)) L. Hypothesis L_rx : L * (proj1_sig rx) < 1. Context {rx_M : PropHolds (`rx * M ≤ proj1_sig ry)}. Instance L_nonneg : PropHolds (0 ≤ L). Proof. assert (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0 x0) as B. { apply @mspc_refl. exact (msp_mspc_ball_ext Q_as_MetricSpace). solve_propholds. } apply (lip_nonneg (λ y, v ((x0 ↾ B), y)) L). Qed. (* Needed to apply Banach fixpoint theorem, which requires a finite distance between any two points *) Global Instance uc_msd : MetricSpaceDistance (@UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0))) := λ f1 f2, 2 * proj1_sig ry. Global Instance uc_msc : @MetricSpaceClass _ _ (@Linf_func_metric_space_class sx sy _ _ (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) rx x0) _ _) uc_msd. Proof. intros f1 f2. unfold msd, uc_msd. intro x. apply (@mspc_triangle' CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) (proj1_sig ry) (proj1_sig ry) y0). + change (proj1_sig ry + proj1_sig ry = 2 * (proj1_sig ry)). ring. + apply mspc_symm; apply (proj2_sig (func f1 x)). + apply (proj2_sig (func f2 x)). Qed. (*Check _ : MetricSpaceClass sx. Check _ : IsUniformlyContinuous v _. Context (f : sx -> sy) `{!IsUniformlyContinuous f mu_f}. Check _ : IsUniformlyContinuous ((@Datatypes.id sx) ∘ (@Datatypes.id sx)) _. Check _ : IsUniformlyContinuous (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _. Check _ : IsLocallyUniformlyContinuous (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _*) Definition picard' (f : sx -> sy) `{!@IsUniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) f mu_f} : Q -> CR := λ x, y0 + @int (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) (@Integral_instance_0 (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _ (@uc_ulc Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _ (@extend_uc CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) x0 rx _ _ (@compose_uc sx (sx and sx) CR (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@Linf_product_metric_space_ball sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))) (@Linf_product_metric_space_class sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0))) (msp_mspc_ball CR) (@diag sx) (v ∘ @together sx sx sx sy (@Datatypes.id sx) f) (lip_modulus 1) (@comp_inf Q Qinf (λ e : Q, @minmax.min Qinf Qinf_le metric.Decision_instance_0 (lip_modulus 1 e) (mu_f e)) mu_v Qinf.infinite) (@lip_uc sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (sx and sx) (@Linf_product_metric_space_ball sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_msd Q (ball (proj1_sig rx) x0) Qmsd) (@sig_mspc_distance Q_as_MetricSpace (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0) Qmsd Qmsc) (@Linf_product_metric_space_class sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0))) (@diag sx) 1 (@diag_lip sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)))) (@compose_uc (sx and sx) (sx and sy) CR (@Linf_product_metric_space_ball sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0))) (@Linf_product_metric_space_ball sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))) (@Linf_product_metric_space_class sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) (@sig_mspc CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) (ball (proj1_sig ry) y0))) (msp_mspc_ball CR) (@together sx sx sx sy (@Datatypes.id sx) f) v (λ e : Q, @minmax.min Qinf Qinf_le metric.Decision_instance_0 (lip_modulus 1 e) (mu_f e)) mu_v (@together_uc sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) (@sig_mspc CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) (ball (proj1_sig ry) y0)) (@Datatypes.id sx) f (lip_modulus 1) (@lip_uc sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_msd Q (ball (proj1_sig rx) x0) Qmsd) (@sig_mspc_distance Q_as_MetricSpace (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0) Qmsd Qmsc) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@Datatypes.id sx) 1 (@id_lip sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) (@sig_mspc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (ball (proj1_sig rx) x0)))) mu_f _) _))))) x0 x. (* Variable f : UniformlyContinuous sx sy. Check _ : IsUniformlyContinuous f _. Check _ : IsLocallyLipschitz (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) _. Check _ : Integral (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)). Check _ : Integrable (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)). Check _ : IsLocallyLipschitz (λ x : Q, int (extend x0 rx (v ∘ (together Datatypes.id f) ∘ diag)) x0 x) _. Check _ : IsLocallyLipschitz (picard' f) _. Goal True. assert (0 ≤ proj1_sig rx). apply (proj2_sig rx). Check _ : PropHolds (0 ≤ proj1_sig rx). Check _ : IsLipschitz (restrict (picard' f) x0 rx) _. *) Definition picard'' (f : @UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) ) : @UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR (msp_mspc_ball CR). Proof. apply (@Build_UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR (msp_mspc_ball CR) (@restrict Q (msp_mspc_ball Q_as_MetricSpace) CR (picard' f) x0 (proj1_sig rx)) ((λ _ _ e : Q, @minmax.min Qinf Qinf_le metric.Decision_instance_0 (lip_modulus 0 (e / 2)) (lip_modulus M (e / 2))) x0 (proj1_sig rx)) (@luc_prf Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) _ _ (@uc_ulc Q (msp_mspc_ball Q_as_MetricSpace) CR (msp_mspc_ball CR) _ _ (@sum_uc Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) (λ _ : Q, y0) _ _ _ _ _)) x0 (proj1_sig rx))). Defined. (* Needed below to be able to apply (order_preserving (.* M)) *) Instance M_nonneg : PropHolds (0 ≤ M) := @bounded_nonneg (sx and sy) v M Bounded0 (@prod_nonempty sx (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) rx x0) sy (@sig_nonempty CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) ry y0)). Lemma picard_sy (f : UniformlyContinuous sx sy) (x : sx) : ball (proj1_sig ry) y0 (picard'' f x). Proof. destruct x as [x x_sx]. unfold picard''; simpl. unfold restrict, Basics.compose; simpl. unfold picard'. apply mspc_ball_CRabs. assert (forall b, CRabs (y0 - (y0 + b)) == abs b)%CR. { intro b. pose proof (CRabs_negate b). rewrite <- H0. apply CRabs_wd. transitivity (y0 + (-y0-b)). apply ucFun2_wd. reflexivity. exact (CRopp_plus_distr y0 b). rewrite plus_assoc. rewrite rings.plus_negate_r, rings.plus_0_l. reflexivity. } unfold abs, abs_sig, proj1_sig, CR_abs. unfold negate, plus. rewrite H0. clear H0. transitivity ('(abs (x - x0) * M)). + apply int_abs_bound; [apply _ |]. (* Should not be required *) intros t A. assert (@mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0 t) as A1. apply (mspc_ball_convex x0 x). apply (@mspc_refl Q). exact (msp_mspc_ball_ext Q_as_MetricSpace). apply (proj2_sig rx). trivial. trivial. apply (extend_inside (Y:=CR)) in A1. destruct A1 as [p A1]. specialize (A1 (v ∘ together Datatypes.id f ∘ diag)). pose proof (CRabs_wd _ _ A1). rewrite H0. clear H0. apply bounded. + apply CRle_Qle. change (abs (x - x0) * M ≤ proj1_sig ry). transitivity (`rx * M). - now apply (orders.order_preserving (.* M)), mspc_ball_Qabs_flip. - apply rx_M. Qed. (*Require Import Integration.*) Definition picard (f : @UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))) : @UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)). Proof. set (g := picard'' f). set (h x := exist _ (g x) (picard_sy f x)). assert (@IsUniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) h (@uc_mu sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR (msp_mspc_ball CR) g)) as C. { constructor. + exact (@uc_pos sx _ CR (msp_mspc_ball CR) g _ (@uc_proof sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR (msp_mspc_ball CR) g)). + intros e x1 x2 e_pos A. exact (@uc_prf sx _ CR (msp_mspc_ball CR) g _ (@uc_proof sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) CR (msp_mspc_ball CR) g) e x1 x2 e_pos A). } exact (Build_UniformlyContinuous _ _ C). Defined. Global Instance picard_contraction : IsContraction picard (L * proj1_sig rx). Proof. constructor; [| exact L_rx]. constructor; [solve_propholds |]. intros f1 f2 e A [x ?]. change (ball (L * proj1_sig rx * e) (picard' f1 x) (picard' f2 x)). unfold picard'. apply mspc_ball_CRplus_l, mspc_ball_CRabs. rewrite <- abs_int_minus. transitivity ('(abs (x - x0) * (L * e))). + apply int_abs_bound; [apply _ |]. (* remove [apply _] *) intros x' B. assert (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0 x') as B1. { apply (mspc_ball_convex x0 x). apply (@mspc_refl Q). exact (msp_mspc_ball_ext Q_as_MetricSpace). solve_propholds. trivial. trivial. } unfold plus, negate, ext_plus, ext_negate. apply (extend_inside (Y:=CR)) in B1. destruct B1 as [p B1]. assert (forall i j k l : CR, i = j -> k = l -> CRabs (i-k) == CRabs (j-l))%CR. { intros. apply CRabs_wd. transitivity (i-l). apply ucFun2_wd. reflexivity. rewrite H1. reflexivity. rewrite H0. reflexivity. } unfold negate,plus. unfold abs, abs_sig, CR_abs, proj1_sig. rewrite (H0 _ _ _ _ (B1 _) (B1 _)). clear H0. apply CRabs_ball. unfold diag, together, Datatypes.id, Basics.compose; simpl. specialize (v_lip (x' ↾ p)). pose proof (lip_prf (λ y, v (_, y)) L). apply H0, A. + apply CRle_Qle. mc_setoid_replace (L * proj1_sig rx * e) with ((proj1_sig rx) * (L * e)) by ring. assert (0 ≤ e). { apply (@radius_nonneg _ _ (@Linf_func_metric_space_class sx sy _ _ (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) rx x0) _ _ ) f1 f2 e A). } change ((abs (x - x0) * (L * e)) ≤ ((proj1_sig rx) * (L * e))). apply (orders.order_preserving (.* (L * e))). now apply mspc_ball_Qabs_flip. Qed. Program Definition f0 : @UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) := Build_UniformlyContinuous (λ x, y0) (λ e, Qinf.infinite) _. Next Obligation. eapply (mspc_refl (X:=CR)). solve_propholds. Qed. Next Obligation. constructor. + intros; easy. + intros e x1 x2 e_pos B. change (ball e y0 y0). apply mspc_refl; solve_propholds. Qed. Lemma ode_solution : let f := @fp _ _ _ uc_msd uc_msc _ picard (L * proj1_sig rx) picard_contraction f0 in picard f = f. Proof. apply banach_fixpoint. Qed. End Picard. Import theory.rings orders.rings. Section Computation. Definition x0 : Q := 0. Definition y0 : CR := 1. Definition rx : QnonNeg := (1 # 2)%Qnn. Definition ry : QnonNeg := 1. Notation sx := (sig (@ball Q (msp_mspc_ball Q_as_MetricSpace) (proj1_sig rx) x0)). (* Why does Coq still print {x | ball rx x0 x} in full? *) Notation sy := (sig (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)). Definition v (z : sx * sy) : CR := ` (snd z). Definition M : Q := 2. Definition mu_v (e : Q) : Qinf := e. Definition L : Q := 1. Instance : Bounded v M. Proof. intros [x [y H]]. unfold v; simpl. unfold M, ry, y0 in *. apply mspc_ball_CRabs in H. pose proof (CRdistance_CRle 1 1 y) as [_ H1]. specialize (H1 H). destruct H1 as [H1 H2]. change (1 - 1 ≤ y) in H1. change (y ≤ 1 + 1) in H2. change (abs y ≤ 2). rewrite plus_negate_r in H1. apply CRabs_AbsSmall. split; [| assumption]. change (-2 ≤ y). transitivity (0%mc : CR); [| easy]. rewrite <- negate_0. apply flip_le_negate. apply (CRle_trans H1 H2). Qed. Instance : forall {r a}, @IsUniformlyContinuous _ (@Linf_product_metric_space_ball _ (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball r a)) _ (@sig_mspc_ball CR (msp_mspc_ball CR) (@ball CR (msp_mspc_ball CR) (proj1_sig ry) y0)) ) CR (msp_mspc_ball CR) v mu_v. Proof. constructor. * now intros. * unfold mu_v. intros e z1 z2 e_pos H. now destruct H. Qed. Instance v_lip (x : sx) : IsLipschitz (λ y : sy, v (x, y)) L. Proof. constructor. * unfold L. solve_propholds. * intros y1 y2 e H. unfold L; rewrite mult_1_l. apply H. Qed. Lemma L_rx : L * proj1_sig rx < 1. Proof. unfold L, rx; simpl. rewrite mult_1_l. change (1 # 2 < 1)%Q. auto with qarith. Qed. Instance rx_M : PropHolds (proj1_sig rx * M ≤ proj1_sig ry). Proof. unfold rx, ry, M; simpl. rewrite Qmake_Qdiv. change (1 * / 2 * 2 <= 1)%Q. rewrite <- Qmult_assoc, Qmult_inv_l; [auto with qarith | discriminate]. Qed. (*Notation ucf := (UniformlyContinuous sx sy). Check _ : MetricSpaceBall ucf. Check _ : ExtMetricSpaceClass ucf. (* Why two colons? *) Check _ : MetricSpaceDistance ucf. Check _ : MetricSpaceClass ucf. Check _ : Limit ucf.*) (* [Check _ : IsContraction (picard x0 y0 rx ry v rx_M) (L * rx)] At this point this does not work *) (* The following is bad because it creates a proof different from picard_contraction. Therefore, ode_solution cannot be applied. *) (* Instance : IsContraction (picard x0 y0 rx ry v rx_M) (L * rx). Proof. apply picard_contraction. apply v_lip. (* Is this needed because there is an explicit argument before IsLipschitz in picard_contraction? *) apply L_rx. Qed. Check _ : IsContraction (picard x0 y0 rx ry v rx_M) (L * rx).*) Let f : @UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) := @fp _ _ (@Linf_func_metric_space_class sx sy (@UniformlyContinuous sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))) (@uniformly_continuous_func sx (@sig_mspc_ball Q (msp_mspc_ball Q_as_MetricSpace) (ball (proj1_sig rx) x0)) sy (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0))) (@sig_nonempty Q (msp_mspc_ball Q_as_MetricSpace) (msp_mspc_ball_ext Q_as_MetricSpace) rx x0) (@sig_mspc_ball CR (msp_mspc_ball CR) (ball (proj1_sig ry) y0)) (@sig_mspc CR (msp_mspc_ball CR) (msp_mspc_ball_ext CR) (ball (proj1_sig ry) y0))) (uc_msd x0 y0 rx ry) (uc_msc x0 y0 rx ry) _ (@picard x0 y0 rx ry v M Bounded_instance_0 0 0 mu_v IsUniformlyContinuous_instance_0 rx_M) _ (@picard_contraction x0 y0 rx ry v M Bounded_instance_0 _ _ mu_v IsUniformlyContinuous_instance_0 L v_lip L_rx rx_M) (f0 x0 y0 rx ry). (* L_rx should also be declared implicit using Context and omitted from the list of arguments *) (* When [IsContraction (picard x0 y0 rx ry v rx_M) (L * rx)] did not work, the error message was 'Error: Cannot infer the implicit parameter H of fp. Could not find an instance for [MetricSpaceBall (UniformlyContinuous sx sy)]'. In fact, [MetricSpaceBall (UniformlyContinuous sx sy)] worked fine. *) (* f is indeed the fixpoint *) Theorem f_fixpoint : @picard x0 y0 rx ry v M Bounded_instance_0 0 0 mu_v IsUniformlyContinuous_instance_0 rx_M f = f. Proof. apply ode_solution. Qed. Definition picard_iter (n : nat) := iter_nat n _ (@picard x0 y0 rx ry v M Bounded_instance_0 0 0 mu_v IsUniformlyContinuous_instance_0 rx_M) (f0 x0 y0 rx ry). (* (* This takes too long to compile. *) Definition answer (n : positive) (r : CR) : Z := let m := (iter_pos n (Pmult 10) 1%positive) in let (a,b) := (approximate r (1#m)%Qpos)*m in Zdiv a b. Program Definition half : sx := 1 # 2. Next Obligation. apply mspc_ball_Qabs_flip. unfold x0. rewrite negate_0, plus_0_r. rewrite abs.abs_nonneg; [reflexivity |]. change (0 <= 1 # 2)%Q. auto with qarith. Qed. (* Time Compute answer 2 (` (picard_iter 3 half)). (* 10 minutes *) Time Compute answer 1 (` (f half)). (* Too long *) *) *) End Computation. corn-8.20.0/ode/SimpleIntegration.v000066400000000000000000000767041473720167500171670ustar00rootroot00000000000000(** A straightforward implementation of the abstract integration interface in AbstractionIntegration using Riemann sums. The sole product of this module are the Integrate and Integrable type class instances. Do not prove any additional properties about this implementation; all we care about is that it implements the abstract integration interface! This implementation works for any uniformly continuous function, which makes it relatively generic, but it also means that it is fairly inefficient. *) Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.reals.CRreal. Require Import CoRN.stdlib_omissions.List. From Coq Require Import Utf8 QArith Qabs. Require Import CoRN.model.totalorder.QposMinMax CoRN.util.Qsums CoRN.model.metric2.Qmetric CoRN.model.setoids.Qsetoid (* Needs imported for Q_is_Setoid to be a canonical structure *) CoRN.reals.fast.CRArith (*AbstractIntegration*) QnonNeg CoRN.util.Qgcd. From Coq Require Import Program. Require Import CoRN.reals.fast.uneven_CRplus CoRN.stdlib_omissions.P CoRN.stdlib_omissions.Z CoRN.stdlib_omissions.Q CoRN.tactics.Qauto CoRN.ode.metric CoRN.ode.FromMetric2 MathClasses.implementations.stdlib_rationals. Import QnonNeg.notations QnonNeg.coercions Qinf.coercions. Bind Scope Q_scope with Q. Local Open Scope Q_scope. Lemma gball_mspc_ball {X : MetricSpace} (r : Q) (x y : X) : ball r x y <-> mspc_ball r x y. Proof. reflexivity. Qed. Lemma ball_mspc_ball {X : MetricSpace} (r : Qpos) (x y : X) : ball (proj1_sig r) x y <-> mspc_ball r x y. Proof. reflexivity. Qed. Class Integral (f: Q → CR) := integrate: forall (from: Q) (w: QnonNeg), CR. Arguments integrate f {Integral}. Notation "∫" := integrate. Section integral_interface. Open Scope CR_scope. (*Context (f: Q → CR).*) Class Integrable `{!Integral f}: Prop := { integral_additive: forall (a: Q) b c, ∫ f a b + ∫ f (a+` b) c == ∫ f a (b+c)%Qnn ; integral_bounded_prim: forall (from: Q) (width: Qpos) (mid: Q) (r: Qpos), (forall x, from <= x <= from+ proj1_sig width -> ball (proj1_sig r) (f x) ('mid)) -> ball (proj1_sig (width * r)%Qpos) (∫ f from (from_Qpos width)) (' (proj1_sig width * mid)%Q) ; integral_wd:: Proper (Qeq ==> QnonNeg.eq ==> @msp_eq _) (∫ f) }. (* Todo: Show that the sign function is integrable while not locally uniformly continuous. *) (** This closely resembles the axiomatization given in Bridger's "Real Analysis: A Constructive Approach", Ch. 5. *) (** The boundedness property is stated very primitively here, in that r is a Qpos instead of a CR, w is a Qpos instead of a QnonNeg, and mid is a Q instead of a CR. This means that it's easy to show that particular implementations satisfy this interface, but hard to use this property directly. Hence, we will show in a moment that the property as stated actually implies its generalization with r and mid in CR and w in QnonNeg. *) (** Note: Another way to state the property still more primitively (and thus more easily provable) might be to make the inequalities in "from <= x <= from+width" strict. *) End integral_interface. Arguments Integrable f {_}. (** We offer a smart constructor for implementations that would need to recognize and treat the zero-width case specially anyway (which is the case for the implementation with Riemann sums, because there, a positive width is needed to divide the error by). *) Section extension_to_nn_width. Open Scope CR_scope. Context (f: Q → CR) (pre_integral: Q → Qpos → CR) (* Note the Qpos instead of QnonNeg. *) (* The three properties limited to pre_integral: *) (pre_additive: forall (a: Q) (b c: Qpos), pre_integral a b + pre_integral (a + `b)%Q c == pre_integral a (b + c)%Qpos) (pre_bounded: forall (from: Q) (width: Qpos) (mid: Q) (r: Qpos), (forall x: Q, from <= x <= from + proj1_sig width -> ball (proj1_sig r) (f x) (' mid)) -> ball (proj1_sig (width * r)%Qpos) (pre_integral from width) (' (proj1_sig width * mid)%Q)) {pre_wd: Proper (Qeq ==> QposEq ==> @msp_eq _) pre_integral}. Instance integral_extended_to_nn_width: Integral f := fun from => QnonNeg.rect (fun _ => CR) (fun _ _ => '0%Q) (fun n d _ => pre_integral from (exist (Qlt 0) (n # d) eq_refl)). Lemma integral_proper: Proper (Qeq ==> QnonNeg.eq ==> @msp_eq _) (∫ f). Proof with auto. intros ?????. induction x0 using QnonNeg.rect; induction y0 using QnonNeg.rect. reflexivity. discriminate. discriminate. intros. apply pre_wd... Qed. Let bounded (from: Q) (width: Qpos) (mid: Q) (r: Qpos): (forall x, from <= x <= from + proj1_sig width -> ball (proj1_sig r) (f x) (' mid)) -> ball (proj1_sig (width * r)%Qpos) (∫ f from (from_Qpos width)) (' (proj1_sig width * mid)%Q). Proof. destruct width as [[n d] wpos]. destruct n as [|n|n]. inversion wpos. 2: inversion wpos. apply (pre_bounded from (n#d) mid r). Qed. Let additive (a: Q) (b c: QnonNeg): ∫ f a b + ∫ f (a + `b)%Q c == ∫ f a (b + c)%Qnn. Proof. unfold integrate. induction b using QnonNeg.rect; induction c using QnonNeg.rect; simpl integral_extended_to_nn_width; intros. ring. rewrite CRplus_0_l. apply pre_wd; unfold QposEq, Qeq; simpl; repeat rewrite Zpos_mult_morphism; ring. rewrite CRplus_0_r. apply pre_wd; unfold QposEq, Qeq; simpl; repeat rewrite Zpos_mult_morphism; ring. rewrite (pre_additive a (exist (Qlt 0) (n#d) eq_refl) (exist (Qlt 0) (n0#d0) eq_refl)). apply pre_wd; reflexivity. Qed. Lemma integral_extended_to_nn_width_correct: Integrable f. Proof. constructor; auto. apply integral_proper. Qed. End extension_to_nn_width. Open Scope uc_scope. #[global] Hint Resolve Qpos_nonzero. #[global] Hint Immediate Q.Qle_nat. #[global] Hint Resolve Qmult_le_0_compat. #[global] Hint Resolve QnonNeg.Qplus_nonneg. Lemma half_Qpos (q: Qpos): proj1_sig q * (1#2) <= proj1_sig q. Proof. intros. rewrite <- (Qmult_1_r (proj1_sig q)) at 2. apply Q.Qmult_le_compat_l. discriminate. apply Qpos_nonneg. Qed. #[global] Hint Immediate half_Qpos. Lemma Qball_ex_plus_r e (x y y' : Q): @ball_ex Q_as_MetricSpace e y y' -> @ball_ex Q_as_MetricSpace e (x + y) (x + y'). Proof. destruct e. apply Qball_plus_r. intuition. Qed. Definition plus_half_times (x y: Q): Q := x * y + (1#2)*y. Lemma ball_ex_symm (X : MetricSpace) (e : QposInf) (x y : X) : ball_ex e x y -> ball_ex e y x. Proof. destruct e as [e |]; [apply ball_sym | trivial]. Qed. Lemma Pos2Nat_nonneg : forall p:positive, Pos.to_nat p <> O. Proof. intros p abs. pose proof (Pos2Nat.is_pos p). rewrite abs in H. inversion H. Qed. Section definition. Add Field Qfield : Qsft (decidable Qeq_bool_eq, completeness Qeq_eq_bool, constants [Qcst], power_tac Qpower_theory [Qpow_tac]). Context (f: Q -> CR) `{UC : !IsLocallyUniformlyContinuous f lmu}. Instance luc_proper_st_eq : Proper (Qeq ==> @msp_eq CR) f. Proof. intros x y exy a b. rewrite Qplus_0_r. apply Qball_0 in exy. pose proof (luc_proper f x y exy a b). rewrite Qplus_0_r in H. exact H. Qed. (** Note that in what follows we don't specialize for [0,1] or [0,w] ranges first. While this would make the definition marginally cleaner, the resulting definition is harder to prove correct. Part of the reason for this is that key primitives (such as mu and approximate) don't come with Proper proofs, which means that common sense reasoning about those operations with their arguments transformed doesn't work well. *) (* Reimplementation of Qpossec.QposCeiling that takes a Q instead of a Qpos *) Definition QposCeiling (q : Q) : positive := match Qround.Qceiling q with | Zpos p => p | _ => 1%positive end. Lemma QposCeiling_Qceiling (q : Qpos) : Z.pos (QposCeiling (proj1_sig q)) = Qround.Qceiling (proj1_sig q). Proof with auto with qarith. unfold QposCeiling. destruct q as [q qpos]. simpl. pose proof Qround.Qle_ceiling q. destruct (Qround.Qceiling q); try reflexivity; exfalso; destruct q; simpl in *. exact (Qlt_not_le _ _ qpos H). apply (Qlt_not_le _ _ qpos). apply Qle_trans with (Zneg p)... Qed. Definition intervals (from: Q) (w: Qpos) (error: Qpos): positive := match lmu from (proj1_sig w) (proj1_sig error / proj1_sig w) with (* Todo: This is nice and simple, but suboptimal. Better would be to take the luc_mu around the midpoint and with radius (w/2). *) | Qinf.infinite => 1%positive | Qinf.finite x => QposCeiling ((1#2) * proj1_sig w / x) end. Definition approx (from: Q) (w: Qpos) (e: Qpos): Q := let halferror := (e * (1#2))%Qpos in let ints := intervals from w halferror in let iw := (proj1_sig w / ints) in let halfiw := ((1#2) * iw) in fastΣ (nat_of_P ints) (fun i => approximate (f (from + (i * iw + halfiw))) (Qpos2QposInf (halferror * Qpos_inv w))) * iw. (** In several places in the correctness proof, we will be comparing different Riemann sums over the same range divided into different numbers of intervals. For these cases, the following lemma is very useful. *) Hint Resolve Qinv_le_0_compat Qmult_le_0_compat. Hint Immediate Zle_0_POS Zlt_0_POS. Lemma sampling_over_subdivision (fr: Q) (i: nat) (t: positive) (he wb: Qpos) : (i < Pos.to_nat (intervals fr wb he * t))%nat -> ball (proj1_sig (he * Qpos_inv wb)%Qpos) (f (fr + plus_half_times (i / Pos.to_nat t)%nat (proj1_sig wb * / Zpos (intervals fr wb he)))) (f (fr + i * / Zpos (intervals fr wb he * t) * proj1_sig wb)). Proof with auto. intro ile. unfold plus_half_times. apply ball_sym. assert (A1 : Qball (proj1_sig wb) fr (fr + i * / Zpos (intervals fr wb he * t) * proj1_sig wb)). { rewrite <- (Qplus_0_r fr) at 1. apply Qball_plus_r. apply in_Qball. split. apply Qle_trans with 0... unfold Qminus. rewrite Qplus_0_l. apply (Qopp_le_compat 0). apply Qpos_nonneg. apply Qmult_le_0_compat. auto. apply Qpos_nonneg. rewrite Qplus_0_l. apply (Qle_trans _ (1 * `wb)). apply Qmult_le_compat_r. 2: apply Qpos_nonneg. 2: rewrite Qmult_1_l; apply Qle_refl. apply Qmult_le_r with (Zpos (intervals fr wb he * t))... rewrite <- Qmult_assoc. rewrite Qmult_inv_r. rewrite Qmult_1_r. rewrite Qmult_1_l. rewrite <- Zle_Qle. rewrite <- ZL9. apply inj_le; auto with arith. intro. assert (0 < / (intervals fr wb he * t)%positive). apply Qinv_lt_0_compat... revert H0. rewrite H. apply (Qlt_irrefl 0). } assert (A2 : mspc_ball (lmu fr (proj1_sig wb) (proj1_sig he / proj1_sig wb)) (fr + i / ((intervals fr wb he * t) #1) * proj1_sig wb) (fr + ((i / Pos.to_nat t)%nat * (proj1_sig wb / ((intervals fr wb he)#1)) + (1 # 2) * (proj1_sig wb / ((intervals fr wb he)#1))))). unfold intervals. destruct (lmu fr (proj1_sig wb) (proj1_sig he / proj1_sig wb)) as [q |] eqn:L; [| apply mspc_inf]. (* apply gball_mspc_ball. does not change the goal *) unfold mspc_ball, msp_mspc_ball. assert (q_pos : 0 < q). { change (Qinf.lt 0 q). rewrite <- L. apply (uc_pos (restrict f fr (proj1_sig wb))). apply UC. apply (Qpos_ispos (he * Qpos_inv wb)). } set (q' := exist _ q q_pos : Qpos). change q with (proj1_sig q'). apply ball_sym, Qball_plus_r. change ((1 # 2) * proj1_sig wb / proj1_sig q')%Q with (proj1_sig ((1 # 2) * wb * Qpos_inv q')%Qpos). set (mym := QposCeiling (proj1_sig ((1 # 2) * wb * Qpos_inv q')%Qpos)). apply ball_weak_le with (proj1_sig (wb * (1#2) * Qpos_inv (mym#1))%Qpos). simpl. rewrite (Qmult_comm (proj1_sig wb)). subst mym. rewrite QposCeiling_Qceiling. apply Qle_shift_div_r... apply Qlt_le_trans with (proj1_sig ((1#2) * wb * Qpos_inv q')%Qpos)... apply Qround.Qle_ceiling. setoid_replace ((1#2) * proj1_sig wb) with (proj1_sig (q' * ((1#2) * wb * Qpos_inv q'))%Qpos). apply Qmult_le_l. exact q_pos. apply Qround.Qle_ceiling. simpl. field. intro abs. clear q'. rewrite abs in q_pos. exact (Qlt_irrefl 0 q_pos). apply Qball_Qdiv_inv with (Qpos_inv (mym#1) * wb)%Qpos. simpl. field_simplify... unfold Qdiv. rewrite Qmult_plus_distr_l. field_simplify... try rewrite Qdiv_1_r. setoid_replace (proj1_sig wb * (1 # 2) * / (mym#1) * / (/ (mym#1) * proj1_sig wb))%Q with (1#2). Focus 2. simpl. field. split; try discriminate... rewrite Nat2Z.inj_div... rewrite Q.Zdiv_Qdiv. setoid_replace ((mym # 1) * i / ((mym * t)%positive # 1)) with (i / t). rewrite positive_nat_Z. apply (Qfloor_ball (i/t)). unfold Qeq; simpl. destruct i. reflexivity. simpl. do 2 rewrite Pos.mul_1_r. rewrite Pos.mul_assoc. rewrite (Pos.mul_comm mym). reflexivity. discriminate. split. discriminate. split. 2: apply Qpos_nonzero. unfold Qeq; discriminate. split. discriminate. apply Qpos_nonzero. assert (A3 : Qball (proj1_sig wb) fr (fr + ((i / Pos.to_nat t)%nat * (proj1_sig wb * / Zpos (intervals fr wb he)) + (1 # 2) * (proj1_sig wb * / Zpos (intervals fr wb he))))). { set (n := intervals fr wb he). rewrite <- (Qplus_0_r fr) at 1. apply Qball_plus_r. apply in_Qball; unfold Qminus; rewrite !Qplus_0_l; split. apply Qle_trans with (y := 0). apply (Qopp_le_compat 0), Qpos_nonneg. Qauto_nonneg. rewrite <- Qmult_plus_distr_l, (Qmult_comm (proj1_sig wb)), Qmult_assoc. apply (Qle_trans _ (1 * proj1_sig wb)). 2: simpl; rewrite Qmult_1_l; apply Qle_refl. apply Qmult_le_compat_r; [| auto]. apply Qdiv_le_1. split. Qauto_nonneg. rewrite <- (positive_nat_Z n). apply Qlt_le_weak. apply Q.nat_lt_Qlt. apply Nat.div_lt_upper_bound. apply Pos2Nat_nonneg. rewrite <- (Pos2Nat.inj_mul t n). rewrite (Pos.mul_comm t n). apply ile. apply Qpos_nonneg. } apply ball_mspc_ball. eapply luc with (a := fr) (r := proj1_sig wb); [apply UC | | | |]. (* Why is [apply UC] not done automatically? *) apply Qpos_ispos. apply A1. apply A3. apply A2. Qed. (** To construct a CR, we'll need to prove that approx is a regular function. However, that property is essentially a specialization of a more general well-definedness property that we'll need anyway, so we prove that one first. *) Lemma wd (from1 from2: Q) (w: bool -> Qpos) (e: bool -> Qpos) (fE: from1 == from2) (wE: QposEq (w true) (w false)): @ball Q_as_MetricSpace (proj1_sig (e true + e false)%Qpos) (approx from1 (w true) (e true)) (approx from2 (w false) (e false)). Proof with auto. set (halfe b := (e b * (1 # 2))%Qpos). set (m (b : bool) := intervals (if b then from1 else from2) (w b) (halfe b)). intros. unfold approx. simpl. do 2 rewrite fastΣ_correct. assert ((e true * (1#2))%Qpos = halfe true) by reflexivity. simpl in H. rewrite H. clear H. assert ((e false * (1#2))%Qpos = halfe false) by reflexivity. simpl in H. rewrite H. clear H. replace (intervals from1 (w true) (halfe true)) with (m true) by reflexivity. replace (intervals from2 (w false) (halfe false)) with (m false) by reflexivity. do 2 rewrite Σ_mult. apply Qball_hetero_Σ. unfold Basics.compose, Qdiv. intros. rewrite (Qmult_assoc (/m false)). rewrite (Qmult_assoc (/m true)). setoid_replace (/ m false * (proj1_sig (w true) * / m true)) with (/ m true * (proj1_sig (w false) * / m false)) by (unfold QposEq in wE; rewrite wE; change (Qeq (/ m false * (proj1_sig (w false) * / m true)) (/ m true * (proj1_sig (w false) * / m false))); ring). replace ((/ m true * (proj1_sig (w false) * / m false))%Q) with (proj1_sig (Qpos_inv (m true #1) * (w false * Qpos_inv (m false #1)))%Qpos) by reflexivity. apply (Qball_Qmult_l (((e true) + (e false)) * (1 # m true * m false))%Qpos). assert (QposEq (((e true + e false) * (1 # m true * m false) * Qpos_inv (Qpos_inv (m true #1) * (w false * Qpos_inv (m false #1))))%Qpos) (halfe true * Qpos_inv (w true) + (halfe true * Qpos_inv (w true) + halfe false * Qpos_inv (w false)) + halfe false * Qpos_inv (w false))%Qpos). { unfold QposEq, Qpos_inv; simpl. setoid_replace (1 # m true * m false) with ((1 # m true) * (1# m false)) by reflexivity. setoid_replace (/ (m true#1)) with (1# m true) by reflexivity. setoid_replace (/ (m false#1)) with (1# m false) by reflexivity. unfold QposEq in wE. rewrite wE. field. split. apply Qpos_nonzero. split; discriminate. } unfold QposEq in H0. rewrite H0. clear H0. repeat split; try discriminate... unfold intervals in m. apply (ball_triangle CR (proj1_sig (halfe true * Qpos_inv (w true))%Qpos) (proj1_sig (halfe false * Qpos_inv (w false))%Qpos) _ (f (from2 + i * / (m true * m false)%positive * proj1_sig (w false))) _). rewrite <- fE. unfold QposEq in wE. rewrite <- wE. apply (sampling_over_subdivision from1 i (m false) (halfe true) (w true))... apply ball_sym. rewrite Pmult_comm. apply sampling_over_subdivision. rewrite Pmult_comm... unfold intervals in m. apply (ball_triangle CR (proj1_sig (halfe true * Qpos_inv (w true))%Qpos) (proj1_sig (halfe false * Qpos_inv (w false))%Qpos) _ (f (from2 + i * / (m true * m false)%positive * proj1_sig (w false))) _). rewrite <- fE. unfold QposEq in wE. rewrite <- wE. apply (sampling_over_subdivision from1 i (m false) (halfe true) (w true))... apply ball_sym. rewrite Pmult_comm. apply sampling_over_subdivision. rewrite Pmult_comm... Qed. Lemma regular fr w: is_RegularFunction_noInf Q_as_MetricSpace (approx fr w). Proof. repeat intro. apply (wd fr fr (fun _ => w) (fun b => if b then e1 else e2)); reflexivity. Qed. Definition pre_result fr w: CR := mkRegularFunction (0:Q_as_MetricSpace) (regular fr w). Global Instance (*integrate*): Integral f := @integral_extended_to_nn_width f pre_result. Global Instance: Proper (Qeq ==> QposEq ==> @msp_eq _) pre_result. Proof. repeat intro. simpl. rewrite Qplus_0_r. apply (wd x y (fun b => if b then x0 else y0) (fun b => if b then d1 else d2)); assumption. Qed. End definition. Arguments intervals lmu from w error : clear implicits. (** Next, we prove that this implements the abstract interface. *) Section implements_abstract_interface. Add Field Qfield' : Qsft (decidable Qeq_bool_eq, completeness Qeq_eq_bool, constants [Qcst], power_tac Qpower_theory [Qpow_tac]). Context (f: Q → CR) `{!IsLocallyUniformlyContinuous f lmu}. Instance luc_proper_st_eq_2 : Proper (Qeq ==> @msp_eq CR) f. Proof. intros x y exy a b. apply Qball_0 in exy. pose proof (luc_proper f x y exy a b). exact H. Qed. Section additivity. Variables (a: Q) (ww: bool -> Qpos). Let totalw := (ww true + ww false)%Qpos. Section with_epsilon. Variable e: Qpos. Let ec b := (e * (ww b * Qpos_inv totalw))%Qpos. Let wbints (b : bool) := intervals lmu (if b then a else a+ proj1_sig (ww true)) (ww b) (ec b * (1 # 2)). Let w01ints := intervals lmu a totalw (e * (1 # 2)). Let approx0 (i: nat) := approximate (f (a + plus_half_times i (proj1_sig (ww true) / ((wbints true) #1)))) (ec true * (1 # 2) * Qpos_inv (ww true))%Qpos. Let approx1 (i: nat) := approximate (f (a + proj1_sig (ww true) + plus_half_times i (proj1_sig (ww false) / Zpos (wbints false)))) (ec false * (1 # 2) * Qpos_inv (ww false))%Qpos. Let approx01 (i: nat) := approximate (f (a + plus_half_times i (proj1_sig totalw / Zpos w01ints))) (e * (1 # 2) * Qpos_inv totalw)%Qpos. (*Let hint := luc_Proper f.*) Lemma added_summations: Qball (proj1_sig e + proj1_sig e) (Σ (Pos.to_nat (wbints true)) approx0 * (proj1_sig (ww true) / Zpos (wbints true)) + Σ (Pos.to_nat (wbints false)) approx1 * (proj1_sig (ww false) / Zpos (wbints false))) (Σ (Pos.to_nat w01ints) approx01 * (proj1_sig totalw / Zpos w01ints)). Proof with auto with *. destruct (Qpos_gcd3 (ww true * (1# wbints true)) (ww false * (1# wbints false)) (totalw * (1# w01ints))) as [x [i [E [j [F [k G]]]]]]. rewrite <- E, <- F, <- G. repeat rewrite Qmult_assoc. rewrite <- Qmult_plus_distr_l. apply (Qball_Qmult_r (e+e)). rewrite <- (inject_nat_convert i), <- (inject_nat_convert j), <- (inject_nat_convert k). do 3 rewrite Qmult_Σ. replace (Pos.to_nat k * Pos.to_nat w01ints)%nat with (Pos.to_nat i * Pos.to_nat (wbints true) + Pos.to_nat j * Pos.to_nat (wbints false))%nat. Focus 2. apply surj_eq. (* lift equality to Z *) rewrite <- Q.Qeq_Zeq. (* lift equality to Q *) apply (Q.Qmult_injective_l (proj1_sig x)). apply Qpos_nonzero. rewrite inj_plus, inj_mult, inj_mult, inj_mult. repeat rewrite inject_nat_convert. rewrite Q.Zplus_Qplus. repeat rewrite Q.Zmult_Qmult. rewrite Qmult_plus_distr_l. rewrite (Qmult_comm i). rewrite (Qmult_comm j). rewrite (Qmult_comm k). repeat rewrite <- Qmult_assoc. rewrite E, F, G. simpl. setoid_replace (wbints true #1) with (/ (1#wbints true)) by reflexivity. setoid_replace (wbints false #1) with (/ (1#wbints false)) by reflexivity. setoid_replace (w01ints #1) with (/ (1#w01ints)) by reflexivity. field. repeat split; discriminate. do 2 rewrite <- nat_of_P_mult_morphism. rewrite Nat.add_comm. rewrite Σ_plus_bound. setoid_replace (proj1_sig (e + e)%Qpos / proj1_sig x) with (proj1_sig ((ec true + ec true) * Qpos_inv x + (ec false + ec false) * Qpos_inv x)%Qpos). Focus 2. unfold ec, QposEq. simpl. field. split... apply (Qpos_nonzero (ww true + ww false)). subst approx0 approx1 approx01. unfold flip, Basics.compose. assert (~ proj1_sig (ww true) + proj1_sig (ww false) == 0). apply (Qpos_nonzero (ww true + ww false)). assert (Zpos i == (proj1_sig (ww true) / wbints true / proj1_sig x)) as iE. apply (Qmult_injective_l (proj1_sig x)). apply Qpos_nonzero. rewrite E. simpl. setoid_replace (wbints true #1) with (/ (1#wbints true)) by reflexivity. field. split. discriminate. apply Qpos_nonzero. assert (Zpos j == (proj1_sig (ww false) / wbints false / proj1_sig x)) as jE. { apply (Qmult_injective_l (proj1_sig x)). apply Qpos_nonzero. rewrite F. simpl. setoid_replace (wbints false #1) with (/ (1#wbints false)) by reflexivity. field. split. discriminate. apply Qpos_nonzero. } assert (Zpos k == (proj1_sig totalw / w01ints / proj1_sig x)) as kE. { apply (Qmult_injective_l (proj1_sig x)). apply Qpos_nonzero. rewrite G. simpl. setoid_replace (w01ints #1) with (/ (1#w01ints)) by reflexivity. field. split. discriminate. apply Qpos_nonzero. } apply Qball_plus. (* left case: *) apply Σ_Qball_pos_bounds. intros i0 i0E. set (ebit (b : bool) := if b then (ec true * (1 # 2) * Qpos_inv (ww true))%Qpos else (e * (1 # 2) * Qpos_inv totalw)%Qpos). setoid_replace (proj1_sig ((ec true + ec true) * Qpos_inv x)%Qpos * (1# i * wbints true)%positive) with (proj1_sig (ebit true + (ebit true + ebit false) + ebit false)%Qpos). Focus 2. unfold QposEq. simpl. assert (proj1_sig x == (proj1_sig (ww true) / Zpos (wbints true) / Zpos i)) as xE. apply Q.Qmult_injective_r with i... rewrite <- E. simpl. field... rewrite xE. unfold Qpos_mult. simpl. setoid_replace (1 # i * wbints true) with ((/i) * / wbints true) by reflexivity. field. split. apply (Qpos_nonzero (ww true + ww false)). split. apply Qpos_nonzero. split; discriminate. (* end Focus 2 *) subst ec. simpl in ebit. apply (ball_triangle CR (proj1_sig (ebit true)) (proj1_sig (ebit false)) (f _) (f (a + i0 * (proj1_sig totalw / (Zpos w01ints * Zpos k)))) (f _))... setoid_replace (proj1_sig (ebit true)) with (proj1_sig (ebit false)) by (simpl; field; auto). unfold ebit. setoid_replace (proj1_sig totalw / (w01ints * k))%Q with ((/ (Zpos (wbints true) * Zpos i) * proj1_sig (ww true))) by (unfold Q_eq; rewrite kE, iE; simpl; field; auto). setoid_replace (proj1_sig (e * (1 # 2) * Qpos_inv totalw)%Qpos) with (proj1_sig (e * (ww true * Qpos_inv totalw) * (1 # 2) * Qpos_inv (ww true))%Qpos) by (simpl; field; auto). rewrite <- Pmult_Qmult. rewrite Qmult_assoc. apply sampling_over_subdivision... rewrite Pmult_comm... apply ball_sym. unfold ebit. setoid_replace (i0 * (proj1_sig totalw / (Zpos w01ints * Zpos k))) with (i0 * / Zpos (w01ints * k) * proj1_sig totalw). apply sampling_over_subdivision... rewrite Pmult_comm. apply Nat.lt_trans with (Pos.to_nat (i * wbints true))... apply inj_lt_iff. rewrite Zlt_Qlt. do 2 rewrite ZL9. do 2 rewrite Pmult_Qmult. fold w01ints. rewrite iE. rewrite kE. simpl. field_simplify... apply Qmult_lt_compat_r... apply Qinv_lt_0_compat... rewrite <- Qplus_0_r at 1. apply Qplus_lt_r... rewrite Pmult_Qmult. unfold Qdiv. unfold Q_eq. ring. (* right case: *) apply Σ_Qball_pos_bounds. intros i0 i0E. set (ebit (b : bool) := if b then (ec false * (1 # 2) * Qpos_inv (ww false))%Qpos else (e * (1 # 2) * Qpos_inv totalw)%Qpos). assert (QposEq ((ec false + ec false) * Qpos_inv x * (1# j * wbints false)%positive)%Qpos (ebit true + (ebit true + ebit false) + ebit false)%Qpos). { unfold QposEq. simpl. setoid_replace (1 # j * wbints false) with ((/j) * / wbints false) by reflexivity. rewrite jE. simpl. field. split. apply (Qpos_nonzero (ww true + ww false)). split. apply Qpos_nonzero. split. discriminate. apply Qpos_nonzero. } unfold QposEq in H0. rewrite H0. clear H0. apply (ball_triangle CR (proj1_sig (ebit true)) (proj1_sig (ebit false)) _ (f (a + proj1_sig (ww true) + i0 * (proj1_sig totalw / (Zpos w01ints * Zpos k)))) _)... setoid_replace (proj1_sig (ebit true)) with (proj1_sig (ebit false)) by (simpl; field; auto). unfold ebit. setoid_replace (proj1_sig totalw / (Zpos w01ints * Zpos k)) with ((/ (Zpos (wbints false) * Zpos j) * proj1_sig (ww false))) by (rewrite kE, jE; unfold Q_eq; simpl; field; auto). assert (QposEq (e * (1 # 2) * Qpos_inv totalw)%Qpos (e * (ww false * Qpos_inv totalw) * (1 # 2) * Qpos_inv (ww false))%Qpos) by (unfold QposEq; simpl; field; auto). unfold QposEq in H0. rewrite H0. clear H0. rewrite <- Pmult_Qmult. rewrite Qmult_assoc. apply sampling_over_subdivision... rewrite Pmult_comm... apply ball_sym. setoid_replace (a + proj1_sig (ww true) + i0 * (proj1_sig totalw / (Zpos w01ints * Zpos k))) with (a + (i * wbints true + i0) * (proj1_sig totalw / (Zpos w01ints * Zpos k))) by (rewrite iE, kE; unfold Q_eq; simpl; field; auto). rewrite <- Pmult_Qmult. setoid_replace ((Zpos (i * wbints true) + i0) * (proj1_sig totalw / (Zpos w01ints * Zpos k))) with ((Pos.to_nat (i * wbints true) + i0)%nat * / Zpos (intervals lmu a totalw (e * (1#2)) * k) * proj1_sig totalw). apply (sampling_over_subdivision f a (Pos.to_nat (i * wbints true) + i0) k (e*(1#2)) totalw). fold w01ints. apply Nat.lt_le_trans with (Pos.to_nat (i * wbints true) + Pos.to_nat (j * wbints false)%positive)%nat... apply inj_le_iff. rewrite Zle_Qle. rewrite inj_plus. rewrite Zplus_Qplus. do 3 rewrite ZL9. do 3 rewrite Pmult_Qmult. rewrite iE, jE, kE. simpl. field_simplify... unfold Qdiv. rewrite (Qmult_comm (proj1_sig totalw)). rewrite inj_plus, Zplus_Qplus. rewrite <- Pmult_Qmult. rewrite Qmult_assoc. rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. reflexivity. Qed. (* Todo: Still too long. *) End with_epsilon. Lemma pre_additive: (pre_result f a (ww true) + pre_result f (a+proj1_sig (ww true)) (ww false) == pre_result f a totalw)%CR. Proof with auto with *. intros. rewrite <- (uneven_CRplus_correct (ww true) (ww false)). simpl. apply regFunEq_equiv, regFunEq_e. intro e. simpl. unfold uneven_CRplus_approx. simpl. unfold approx. do 3 rewrite fastΣ_correct. apply added_summations. Qed. End additivity. Lemma data_points_in_range (from: Q) (width: Qpos) (ints: positive) (i : nat) (Ilt: (i < Pos.to_nat ints)%nat): from <= (from + (i * (`width / Zpos ints) + (1 # 2) * (`width / Zpos ints))) <= from + `width. Proof with auto with qarith. split. rewrite <- (Qplus_0_r from) at 1. apply Qplus_le_compat... change (0 <= i * ` (width * (1#ints))%Qpos + (1#2) * ` (width * (1#ints))%Qpos)... apply Qplus_le_compat... unfold Qdiv. setoid_replace (i * (`width * / Zpos ints) + (1 # 2) * (`width * / Zpos ints)) with (((i+(1#2)) * / Zpos ints) * `width) by (unfold Q_eq; ring). rewrite <- (Qmult_1_l (`width)) at 2. apply Qmult_le_compat_r... apply Qdiv_le_1. split... apply Qlt_le_weak. rewrite (Zpos_eq_Z_of_nat_o_nat_of_P ints). apply nat_lt_Qlt... Qed. Let bounded (from: Q) (width: Qpos) (mid: Q) (r: Qpos): (forall x, from <= x <= from + proj1_sig width -> ball (proj1_sig r) (f x) ('mid)%CR) -> ball (proj1_sig (width * r)%Qpos) (pre_result f from width) (' (proj1_sig width * mid)%Q)%CR. Proof with auto with qarith. intros. apply (@regFunBall_Cunit Q_as_MetricSpace). intro. unfold pre_result. simpl approximate. unfold approx. rewrite fastΣ_correct. set (ints := intervals lmu from width (d * (1 # 2))). apply (@ball_weak_le Q_as_MetricSpace (proj1_sig (d*(1#2) + width * r)%Qpos) (` d + ` (width * r)%Qpos)). simpl. apply Qplus_le_compat... rewrite Σ_mult. setoid_replace (`width * mid) with (Pos.to_nat ints * (`width / ints * mid)). Focus 2. simpl. rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. unfold Q_eq. field... rewrite <- Σ_const. apply Σ_Qball_pos_bounds. intros. unfold Basics.compose. apply (@Qball_Qmult_l ((d*(1#2)+width*r)*(1#ints)) (width * (1# ints))%Qpos). assert (QposEq ((d*(1#2) + width * r) * (1# ints) * Qpos_inv (width * (1# ints)))%Qpos (d*(1#2) * Qpos_inv width + r)%Qpos). { unfold QposEq. simpl. field. split. apply Qpos_nonzero. discriminate. } unfold QposEq in H1. rewrite H1. clear H1. apply regFunBall_Cunit, H, data_points_in_range... Qed. Global Instance correct: Integrable f. Proof. apply integral_extended_to_nn_width_correct. intros. apply (@pre_additive a (fun t => if t then b else c)). assumption. apply _. Qed. End implements_abstract_interface. corn-8.20.0/ode/metric.v000066400000000000000000001125021473720167500150000ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import QArith. Require Import MathClasses.theory.setoids (* Equiv Prop *) MathClasses.theory.products MathClasses.implementations.stdlib_rationals (*Qinf*) (*Qpossec QposInf QnonNeg*) MathClasses.interfaces.abstract_algebra MathClasses.implementations.QType_rationals MathClasses.interfaces.additional_operations. Require CoRN.model.structures.Qinf. (*Import (*QnonNeg.notations*) QArith.*) Require Import CoRN.tactics.Qauto. From Coq Require Import QOrderedType. (*Require Import orders.*) Require Import MathClasses.theory.rings MathClasses.theory.dec_fields MathClasses.orders.rings MathClasses.orders.dec_fields MathClasses.theory.nat_pow. Require Import MathClasses.interfaces.naturals MathClasses.interfaces.orders. Import peano_naturals. Require Import CoRN.reals.fast.CRGeometricSum. Import Qround Qpower Qinf.notations Qinf.coercions. (* Set Printing Coercions.*) Definition ext_plus {A} `{Plus B} : Plus (A -> B) := λ f g x, f x + g x. #[global] Hint Extern 10 (Plus (_ -> _)) => apply @ext_plus : typeclass_instances. Definition ext_negate {A} `{Negate B} : Negate (A -> B) := λ f x, - (f x). #[global] Hint Extern 10 (Negate (_ -> _)) => apply @ext_negate : typeclass_instances. (* The definitions above replace the following. Notation "f +1 g" := (λ x, f x + g x) (at level 50, left associativity).*) Definition comp_inf {X Z : Type} (g : Q -> Z) (f : X -> Qinf) (inf : Z) (x : X) := match (f x) with | Qinf.finite y => g y | Qinf.infinite => inf end. (* [po_proper'] is useful for proving [a2 ≤ b2] from [H : a1 ≤ b1] when [a1 = a2] and [b1 = b2]. Then [apply (po_proper' H)] generates [a1 = a2] and [b1 = b2]. Should it be moved to MathClasses? *) Lemma po_proper' `{PartialOrder A} {x1 x2 y1 y2 : A} : x1 ≤ y1 -> x1 = x2 -> y1 = y2 -> x2 ≤ y2. Proof. intros A1 A2 A3; now apply (po_proper _ _ A2 _ _ A3). Qed. (* This is a special case of lt_ne_flip. Do we need it? *) (*Instance pos_ne_0 : forall `{StrictSetoidOrder A} `{Zero A} (x : A), PropHolds (0 < x) -> PropHolds (x ≠ 0). Proof. intros; now apply lt_ne_flip. Qed.*) Definition ext_equiv' `{Equiv A} `{Equiv B} : Equiv (A → B) := λ f g, ∀ x : A, f x = g x. Infix "=1" := ext_equiv' (at level 70, no associativity) : type_scope. Lemma ext_equiv_l `{Setoid A, Setoid B} (f g : A -> B) : Proper ((=) ==> (=)) f -> f =1 g -> f = g. Proof. intros P eq1_f_g x y eq_x_y; rewrite eq_x_y; apply eq1_f_g. Qed. Lemma ext_equiv_r `{Setoid A, Setoid B} (f g : A -> B) : Proper ((=) ==> (=)) g -> f =1 g -> f = g. Proof. intros P eq1_f_g x y eq_x_y; rewrite <- eq_x_y; apply eq1_f_g. Qed. (*Ltac MCQconst t := match t with (*| @zero Q _ _ => constr:(Qmake Z0 xH) | @one Q _ _ => constr:(Qmake (Zpos xH) xH)*) | _ => Qcst t end. Add Field Q : (stdlib_field_theory Q) (decidable Qeq_bool_eq, completeness Qeq_eq_bool, constants [MCQconst]). Goal forall x y : Q, (1#1)%Q * x = x. intros x y. ring.*) (* Local Notation Qnn := QnonNeg.T. Instance Qnn_eq : Equiv Qnn := eq. Instance Qnn_zero : Zero Qnn := QnonNeg.zero. Instance Qnn_one : One Qnn := QnonNeg.one. Instance Qnn_plus : Plus Qnn := QnonNeg.plus. Instance Qnn_mult : Mult Qnn := QnonNeg.mult. Instance Qnn_inv : DecRecip Qnn := QnonNeg.inv. Instance Qpos_eq : Equiv Qpos := Qpossec.QposEq. Instance Qpos_one : One Qpos := Qpossec.Qpos_one. Instance Qpos_plus : Plus Qpos := Qpossec.Qpos_plus. Instance Qpos_mult : Mult Qpos := Qpossec.Qpos_mult. Instance Qpos_inv : DecRecip Qpos := Qpossec.Qpos_inv. Instance Qinf_one : One Qinf := 1%Q. *) #[global] Instance Qinf_le : Le Qinf := Qinf.le. #[global] Instance Qinf_lt : Lt Qinf := Qinf.lt. (* Ltac mc_simpl := unfold equiv, zero, one, plus, negate, mult, dec_recip, le, lt. Ltac Qsimpl' := unfold Qnn_eq, Qnn_zero, Qnn_one, Qnn_plus, Qnn_mult, Qnn_inv, QnonNeg.eq, QnonNeg.zero, QnonNeg.one, QnonNeg.plus, QnonNeg.mult, QnonNeg.inv, Qpos_eq, Qpos_one, Qpos_plus, Qpos_mult, Qpos_inv, Qpossec.QposEq, Qpossec.Qpos_one, Qpossec.Qpos_plus, Qpossec.Qpos_mult, Qpossec.Qpos_inv, Qinf.eq, Qinf.lt, Qinf_lt, Qinf_one, Zero_instance_0 (* Zero Qinf *), Q_eq, Q_lt, Q_le, Q_0, Q_1, Q_opp, Q_plus, Q_mult, Q_recip; mc_simpl; unfold to_Q, QposAsQ; simpl. Ltac nat_simpl := unfold nat_equiv, nat_0, nat_1, nat_plus, nat_plus, nat_mult, nat_le, nat_lt; mc_simpl; simpl. Tactic Notation "Qsimpl" hyp_list(A) := revert A; Qsimpl'; intros A. *) Bind Scope mc_scope with Q. (*Section QField.*) Add Field Q : (stdlib_field_theory Q). Class MetricSpaceBall (X : Type) : Type := mspc_ball: Qinf → relation X. Local Notation ball := mspc_ball. (* In the proof of Banach fixpoint theorem we have to use arithmetic expressions such as q^n / (1 - q) when 0 <= q < 1 as the ball radius. If the radius is in Qnn (ie., QnonNeg.T), then we have to prove that 1 - q : Qnn. It seems more convenient to have the radius live in Q and have the axiom that no points are separated by a negative distance. *) Class ExtMetricSpaceClass (X : Type) `{MetricSpaceBall X} : Prop := { mspc_radius_proper : Proper ((=) ==> (≡) ==> (≡) ==> iff) ball; mspc_inf: ∀ x y, ball Qinf.infinite x y; mspc_negative: ∀ (e: Q), e < 0 → ∀ x y, ~ ball e x y; mspc_refl:: ∀ e : Q, 0 ≤ e → Reflexive (ball e); mspc_symm:: ∀ e, Symmetric (ball e); mspc_triangle: ∀ (e1 e2: Q) (a b c: X), ball e1 a b → ball e2 b c → ball (e1 + e2) a c; mspc_closed: ∀ (e: Q) (a b: X), (∀ d: Q, 0 < d -> ball (e + d) a b) → ball e a b }. Class MetricSpaceDistance (X : Type) := msd : X -> X -> Q. Class MetricSpaceClass (X : Type) `{ExtMetricSpaceClass X} `{MetricSpaceDistance X} : Prop := mspc_distance : forall x1 x2 : X, ball (msd x1 x2) x1 x2. Section ExtMetricSpace. Context `{ExtMetricSpaceClass X}. Global Instance mspc_equiv : Equiv X := λ x1 x2, ball 0%Q x1 x2. Global Instance mspc_setoid : Setoid X. Proof. constructor. + now apply mspc_refl. + apply mspc_symm. + intros x1 x2 x3 eq12 eq23. unfold mspc_equiv, equiv; change 0%Q with (0%Q + 0%Q); now apply mspc_triangle with (b := x2). Qed. Global Instance mspc_proper : Proper ((=) ==> (=) ==> (=) ==> iff) ball. Proof. assert (A := @mspc_radius_proper X _ _). intros e1 e2 Ee1e2 x1 x2 Ex1x2 y1 y2 Ey1y2; destruct e1 as [e1 |]; destruct e2 as [e2 |]; split; intro B; try apply mspc_inf; try (unfold Qinf.eq, equiv in *; contradiction). + mc_setoid_replace e2 with (0 + (e2 + 0)) by ring. apply mspc_triangle with (b := x1); [apply mspc_symm, Ex1x2 |]. now apply mspc_triangle with (b := y1); [rewrite <- Ee1e2 |]. + mc_setoid_replace e1 with (0 + (e1 + 0)) by ring. apply mspc_triangle with (b := x2); [apply Ex1x2 |]. now apply mspc_triangle with (b := y2); [rewrite Ee1e2 | apply mspc_symm]. Qed. Lemma mspc_refl' (e : Qinf) : 0 ≤ e → Reflexive (ball e). Proof. intros E. destruct e as [e |]. + apply mspc_refl, E. + intro x; apply mspc_inf. Qed. Lemma mspc_triangle' : ∀ (q1 q2 : Q) (x2 x1 x3 : X) (q : Q), q1 + q2 = q → ball q1 x1 x2 → ball q2 x2 x3 → ball q x1 x3. Proof. intros q1 q2 x2 x1 x3 q A1 A2 A3. rewrite <- A1. eapply mspc_triangle; eauto. Qed. Lemma mspc_monotone : ∀ q1 q2 : Q, q1 ≤ q2 -> ∀ x y : X, ball q1 x y → ball q2 x y. Proof. intros q1 q2 A1 x y A2. apply (mspc_triangle' q1 (q2 - q1) y); [ring | trivial |]. apply mspc_refl. apply (order_preserving (+ (-q1))) in A1. now rewrite plus_negate_r in A1. Qed. Lemma mspc_monotone' : ∀ q1 q2 : Qinf, q1 ≤ q2 -> ∀ x y : X, ball q1 x y → ball q2 x y. Proof. intros [q1 |] [q2 |] A1 x y A2; try apply mspc_inf. + apply (mspc_monotone q1); trivial. + elim A1. Qed. Lemma mspc_eq : ∀ x y : X, (∀ e : Q, 0 < e -> ball e x y) ↔ x = y. Proof. intros x y; split; intro A. + apply mspc_closed; intro d. change 0%Q with (@zero Q _); rewrite plus_0_l; apply A. + intros e e_pos. apply (mspc_monotone 0); trivial; solve_propholds. Qed. Lemma radius_nonneg (x y : X) (e : Q) : ball e x y -> 0 ≤ e. Proof. intro A. destruct (le_or_lt 0 e) as [A1 | A1]; [trivial |]. contradict A; now apply mspc_negative. Qed. End ExtMetricSpace. Section MetricSpace. Context `{MetricSpaceClass X}. Lemma msd_nonneg (x1 x2 : X) : 0 ≤ msd x1 x2. Proof. apply (radius_nonneg x1 x2), mspc_distance. Qed. End MetricSpace. Section SubMetricSpace. Context `{ExtMetricSpaceClass X} (P : X -> Prop). Global Instance sig_mspc_ball : MetricSpaceBall (sig P) := λ e x y, ball e (`x) (`y). Global Instance sig_mspc : ExtMetricSpaceClass (sig P). Proof. constructor. + repeat intro; rapply mspc_radius_proper; congruence. + repeat intro; rapply mspc_inf. + intros; now rapply mspc_negative. + repeat intro; now rapply mspc_refl. + repeat intro; now rapply mspc_symm. + repeat intro; rapply mspc_triangle; eauto. + repeat intro; now rapply mspc_closed. Qed. Context {d : MetricSpaceDistance X} {MSC : MetricSpaceClass X}. Global Instance sig_msd : MetricSpaceDistance (sig P) := λ x y, msd (`x) (`y). Global Instance sig_mspc_distance : MetricSpaceClass (sig P). Proof. intros x1 x2; apply: mspc_distance. Qed. End SubMetricSpace. Section ProductMetricSpace. Context `{ExtMetricSpaceClass X, ExtMetricSpaceClass Y}. Global Instance Linf_product_metric_space_ball : MetricSpaceBall (X * Y) := λ e a b, ball e (fst a) (fst b) /\ ball e (snd a) (snd b). Lemma product_ball_proper : Proper ((=) ==> (≡) ==> (≡) ==> iff) ball. Proof. intros e1 e2 A1 a1 a2 A2 b1 b2 A3. unfold mspc_ball, Linf_product_metric_space_ball. rewrite A1, A2, A3; reflexivity. Qed. Global Instance Linf_product_metric_space_class : ExtMetricSpaceClass (X * Y). Proof. constructor. + apply product_ball_proper. + intros x y; split; apply mspc_inf. + intros e e_neg x y [A _]. eapply (@mspc_negative X); eauto. + intros e e_nonneg x; split; apply mspc_refl; trivial. + intros e a b [A1 A2]; split; apply mspc_symm; trivial. + intros e1 e2 a b c [A1 A2] [B1 B2]; split; eapply mspc_triangle; eauto. + intros e a b A; split; apply mspc_closed; firstorder. Qed. Context {dx : MetricSpaceDistance X} {dy : MetricSpaceDistance Y} {MSCx : MetricSpaceClass X} {MSCy : MetricSpaceClass Y}. (* Need consistent names of instances for sig, product and func *) Global Instance Linf_product_msd : MetricSpaceDistance (X * Y) := λ a b, join (msd (fst a) (fst b)) (msd (snd a) (snd b)). Global Instance Linf_product_mspc_distance : MetricSpaceClass (X * Y). Proof. intros z1 z2; split. (* Without unfolding Linf_product_msd, the following [apply join_ub_l] fails *) + apply (mspc_monotone (msd (fst z1) (fst z2))); [unfold msd, Linf_product_msd; apply join_ub_l | apply mspc_distance]. + apply (mspc_monotone (msd (snd z1) (snd z2))); [unfold msd, Linf_product_msd; apply join_ub_r | apply mspc_distance]. Qed. End ProductMetricSpace. (** We define [Func T X Y] if there is a coercion func from T to (X -> Y), i.e., T is a type of functions. It can be instatiated with (locally) uniformly continuous function, (locally) Lipschitz functions, contractions and so on. For instances T of [Func] we can define supremum metric ball (i.e., L∞ metric) and prove that T is a metric space. [Func T X Y] is similar to [Cast T (X -> Y)], but [cast] has types as explicit arguments, so for [f : T] one would have to write [cast _ _ f x] instead of [func f x]. *) Class Func (T X Y : Type) := func : T -> X -> Y. Section FunctionMetricSpace. Context {X Y T : Type} `{Func T X Y, NonEmpty X, ExtMetricSpaceClass Y}. (* For any type that is convertible to functions we want to define the supremum metric. This would give rise to an equality and a setoid ([mspc_equiv] and [mspc_setoid]). Thus, when Coq needs equality on any type T at all, it may try to prove that T is a metric space by showing that T is convertible to functions, i.e., there is an in instance of [Func T X Y] for some types X, Y. This is why we make [Func T X Y] the first assumption above. This way, if there is no instance of this class, the search for [MetricSpaceBall T] fails quickly and Coq starts looking for an equality on T using other means. If we make, for example, [ExtMetricSpaceClass Y] the first assumption, Coq may eneter in an infinite loop: To find [MetricSpaceBall T] it will look for [ExtMetricSpaceClass Y] for some uninstantiated Y, for this in needs [MetricSpaceBall Y] and so on. This is all because Coq proves assumptions (i.e., searches instances of classes) in the order of the assumptions. *) Global Instance Linf_func_metric_space_ball : MetricSpaceBall T := λ e f g, forall x, ball e (func f x) (func g x). Lemma func_ball_proper : Proper ((=) ==> (≡) ==> (≡) ==> iff) (ball (X := T)). Proof. intros q1 q2 A1 f1 f2 A2 g1 g2 A3; rewrite A2, A3. split; intros A4 x; [rewrite <- A1 | rewrite A1]; apply A4. Qed. Lemma Linf_func_metric_space_class : ExtMetricSpaceClass T. Proof. match goal with | H : NonEmpty X |- _ => destruct H as [x0] end. constructor. + apply func_ball_proper. + intros f g x; apply mspc_inf. + intros e e_neg f g A. specialize (A x0). eapply mspc_negative; eauto. + intros e e_nonneg f x; now apply mspc_refl. + intros e f g A x; now apply mspc_symm. + intros e1 e2 f g h A1 A2 x. now apply mspc_triangle with (b := func g x). + intros e f g A x. apply mspc_closed; intros d A1. now apply A. Qed. End FunctionMetricSpace. Section UniformContinuity. Context `{MetricSpaceBall X, MetricSpaceBall Y}. Class IsUniformlyContinuous (f : X -> Y) (mu : Q -> Qinf) := { uc_pos : forall e : Q, 0 < e -> (0 < mu e); uc_prf : ∀ (e : Q) (x1 x2: X), 0 < e -> ball (mu e) x1 x2 → ball e (f x1) (f x2) }. Global Arguments uc_pos f mu {_} e _. Global Arguments uc_prf f mu {_} e x1 x2 _ _. Record UniformlyContinuous := { uc_func :> X -> Y; uc_mu : Q -> Qinf; uc_proof : IsUniformlyContinuous uc_func uc_mu }. (* We will prove next that IsUniformlyContinuous is a subclass of Proper, i.e., uniformly continuous functions are morphisms. But if we have [f : UniformlyContinuous], in order for uc_func f to be considered a morphism, we need to declare uc_proof an instance. *) Global Existing Instance uc_proof. Global Instance uc_proper {H1 : ExtMetricSpaceClass X} {H2 : ExtMetricSpaceClass Y} {f : X → Y} {mu : Q → Qinf} {_ : IsUniformlyContinuous f mu} : Proper ((=) ==> (=)) f. Proof. intros x1 x2 A. apply -> mspc_eq. intros e e_pos. apply (uc_prf f mu); trivial. pose proof (uc_pos f mu e e_pos) as ?. destruct (mu e); [apply mspc_eq; trivial | apply mspc_inf]. Qed. End UniformContinuity. Global Arguments UniformlyContinuous X {_} Y {_}. (* In [compose_uc] below, if we don't explicitly specify [Z] as an argument, then [`{MetricSpaceBall Z}] does not generalize [Z] but rather interprets it as integers. For symmetry we specify [X] and [Y] as well. *) Global Instance compose_uc {X Y Z : Type} `{MetricSpaceBall X, ExtMetricSpaceClass Y, MetricSpaceBall Z} (f : X -> Y) (g : Y -> Z) (f_mu g_mu : Q -> Qinf) `{!IsUniformlyContinuous f f_mu, !IsUniformlyContinuous g g_mu} : IsUniformlyContinuous (g ∘ f) (comp_inf f_mu g_mu Qinf.infinite). Proof. constructor. + intros e e_pos. assert (0 < g_mu e) by (apply (uc_pos g); trivial). unfold comp_inf. destruct (g_mu e); [apply (uc_pos f) |]; trivial. + intros e x1 x2 e_pos A. unfold compose. apply (uc_prf g g_mu); trivial. assert (0 < g_mu e) by (apply (uc_pos g); trivial). unfold comp_inf in A. destruct (g_mu e) as [e' |]; [| apply mspc_inf]. apply (uc_prf f f_mu); trivial. Qed. Global Instance uniformly_continuous_func `{MetricSpaceBall X, MetricSpaceBall Y} : Func (UniformlyContinuous X Y) X Y := λ f, f. #[global] Hint Extern 10 (ExtMetricSpaceClass (UniformlyContinuous _ _)) => apply @Linf_func_metric_space_class : typeclass_instances. Section LocalUniformContinuity. Context `{MetricSpaceBall X, MetricSpaceBall Y}. Definition restrict (f : X -> Y) (x : X) (r : Q) : sig (ball r x) -> Y := f ∘ @proj1_sig _ _. (* See the remark about llip_prf below about the loop between IsUniformlyContinuous and IsLocallyUniformlyContinuous *) Class IsLocallyUniformlyContinuous (f : X -> Y) (lmu : X -> Q -> Q -> Qinf) := luc_prf :: forall (x : X) (r : Q), IsUniformlyContinuous (restrict f x r) (lmu x r). Global Arguments luc_prf f lmu {_} x r. Global Instance uc_ulc (f : X -> Y) {mu : Q → Qinf} {_ : IsUniformlyContinuous f mu} : IsLocallyUniformlyContinuous f (λ _ _, mu). Proof. intros x r. constructor; [now apply (uc_pos f) |]. intros e [x1 A1] [x2 A2] e_pos A. now apply (uc_prf f mu). Qed. Global Instance luc_proper {_ : ExtMetricSpaceClass X} {_ : ExtMetricSpaceClass Y} (f : X -> Y) `{!IsLocallyUniformlyContinuous f lmu} : Proper ((=) ==> (=)) f. Proof. intros x1 x2 A. apply -> mspc_eq. intros e e_pos. assert (A1 : ball 1%Q x1 x1) by (apply mspc_refl; Qauto_nonneg). assert (A2 : ball 1%Q x1 x2) by (rewrite A; apply mspc_refl; Qauto_nonneg). change (ball e (restrict f x1 1 (exist _ x1 A1)) (restrict f x1 1 (exist _ x2 A2))). unfold IsLocallyUniformlyContinuous in *. apply (uc_prf _ (lmu x1 1)); [easy |]. change (ball (lmu x1 1 e) x1 x2). rewrite <- A. assert (0 < lmu x1 1 e) by now apply (uc_pos (restrict f x1 1)). destruct (lmu x1 1 e) as [q |]; [apply mspc_refl; solve_propholds | apply mspc_inf]. Qed. Lemma luc (f : X -> Y) `{IsLocallyUniformlyContinuous f lmu} (r e : Q) (a x y : X) : 0 < e -> ball r a x -> ball r a y -> ball (lmu a r e) x y -> ball e (f x) (f y). Proof. intros e_pos A1 A2 A3. change (f x) with (restrict f a r (exist _ x A1)). change (f y) with (restrict f a r (exist _ y A2)). apply uc_prf with (mu := lmu a r); trivial. (* The predicate symbol of the goal is IsUniformlyContinuous, which is a type class. Yet, without [trivial] above, instead of solving it by [apply H3], Coq gives it as a subgoal. *) Qed. End LocalUniformContinuity. Section Lipschitz. Context `{MetricSpaceBall X, MetricSpaceBall Y}. Class IsLipschitz (f : X -> Y) (L : Q) := { lip_nonneg : 0 ≤ L; lip_prf : forall (x1 x2 : X) (e : Q), ball e x1 x2 -> ball (L * e) (f x1) (f x2) }. Global Arguments lip_nonneg f L {_} _. Global Arguments lip_prf f L {_} _ _ _ _. Record Lipschitz := { lip_func :> X -> Y; lip_const : Q; lip_proof : IsLipschitz lip_func lip_const }. Definition lip_modulus (L e : Q) : Qinf := if (decide (L = 0)) then Qinf.infinite else e / L. Lemma lip_modulus_pos (L e : Q) : 0 ≤ L -> 0 < e -> 0 < lip_modulus L e. Proof. intros L_nonneg e_pos. unfold lip_modulus. destruct (decide (L = 0)) as [A1 | A1]; [apply I |]. apply not_symmetry in A1. change (0 < e / L). (* Changes from Qinf, which is not declared as ordered ring, to Q *) assert (0 < L) by now apply QOrder.le_neq_lt. Qauto_pos. Qed. (* It is nice to declare only [MetricSpaceBall X] above because this is all we need to know about X to define [IsLipschitz]. But for the following theorem we also need [ExtMetricSpaceClass X], [MetricSpaceDistance X] and [MetricSpaceClass X]. How to add these assumptions? Saying [`{MetricSpaceClass X}] would add a second copy of [MetricSpaceBall X]. We write the names EM and m below because "Anonymous variables not allowed in contexts" *) Context {EM : ExtMetricSpaceClass X} {m : MetricSpaceDistance X}. Global Instance lip_uc {_ : MetricSpaceClass X} {_ : ExtMetricSpaceClass Y} (f : X -> Y) `{!IsLipschitz f L} : IsUniformlyContinuous f (lip_modulus L). Proof. constructor. + intros. apply lip_modulus_pos; [| assumption]. now apply (lip_nonneg f L). + unfold lip_modulus. intros e x1 x2 A1 A2. destruct (decide (L = 0)) as [A | A]. - apply mspc_eq; [| easy]. unfold canonical_names.equiv, mspc_equiv. rewrite <- (Qmult_0_l (msd x1 x2)), <- A. now apply lip_prf; [| apply mspc_distance]. - mc_setoid_replace e with (L * (e / L)) by now field. now apply lip_prf. Qed. End Lipschitz. (* To be able to say [Lipschitz X Y] instead of [@Lipschitz X _ Y _] *) Global Arguments Lipschitz X {_} Y {_}. (* Allows concluding [IsLipschitz f _] from [f : Lipschitz] *) Global Existing Instance lip_proof. (* We need [ExtMetricSpaceClass Z] because we rewrite the ball radius, so [mspc_radius_proper] is required. See comment before [compose_uc] for why [{X Y Z : Type}] is necessary. *) Global Instance compose_lip {X Y Z : Type} `{MetricSpaceBall X, MetricSpaceBall Y, ExtMetricSpaceClass Z} (f : X -> Y) (g : Y -> Z) (Lf Lg : Q) `{!IsLipschitz f Lf, !IsLipschitz g Lg} : IsLipschitz (g ∘ f) (Lg * Lf). Proof. constructor. + apply nonneg_mult_compat; [apply (lip_nonneg g), _ | apply (lip_nonneg f), _]. + intros x1 x2 e A. (* [rewrite <- mult_assoc] does not work *) mc_setoid_replace (Lg * Lf * e) with (Lg * (Lf * e)) by (symmetry; apply simple_associativity). now apply (lip_prf g Lg), (lip_prf f Lf). Qed. (* [ExtMetricSpaceClass X] is needed for rewriting *) Global Instance id_lip `{ExtMetricSpaceClass X} : IsLipschitz Datatypes.id 1. Proof. constructor; [solve_propholds |]. intros; now rewrite mult_1_l. Qed. Section LocallyLipschitz. Context `{MetricSpaceBall X, MetricSpaceBall Y}. (* Delaring llip_prf below an instance introduces a loop between [IsLipschitz] and [IsLocallyLipschitz]. But if we are searching for a proof of [IsLipschitz f _] for a specific term [f], then Coq should not enter an infinite loop because that would require unifying [f] with [restrict _ _ _]. We need this instance to apply [lip_nonneg (restrict f x r) _] in order to prove [0 ≤ Lf x r] when [IsLocallyLipschitz f Lf]. *) (* We make an assumption [0 ≤ r] in llip_prf below to make proving that functions are locally Lipschitz easier. As a part of such proof, one needs to show that [0 ≤ L x r] ([lip_nonneg]). Proving this under the assumption [0 ≤ r] may allow having simpler definitions of the uniform [L]. In particular, integral_lipschitz in AbstractIntegration.v defines [L] as [λ a r, abs (f a) + L' a r * r]. *) Class IsLocallyLipschitz (f : X -> Y) (L : X -> Q -> Q) := llip_prf :: forall (x : X) (r : Q), PropHolds (0 ≤ r) -> IsLipschitz (restrict f x r) (L x r). Global Arguments llip_prf f L {_} x r _. Global Instance lip_llip (f : X -> Y) `{!IsLipschitz f L} : IsLocallyLipschitz f (λ _ _, L). Proof. intros x r. constructor; [now apply (lip_nonneg f) |]. intros [x1 x1b] [x2 x2b] e A. change (ball (L * e) (f x1) (f x2)). now apply lip_prf. Qed. Lemma llip `{!ExtMetricSpaceClass X} (f : X -> Y) `{IsLocallyLipschitz f L} (r e : Q) (a x y : X) : ball r a x -> ball r a y -> ball e x y -> ball (L a r * e) (f x) (f y). Proof. intros A1 A2 A3. change (f x) with (restrict f a r (exist _ x A1)). change (f y) with (restrict f a r (exist _ y A2)). assert (0 ≤ r) by now apply (radius_nonneg a x). apply (lip_prf _ (L a r)); trivial. Qed. Record LocallyLipschitz := { llip_func :> X -> Y; llip_const : X -> Q -> Q; llip_proof : IsLocallyLipschitz llip_func llip_const }. End LocallyLipschitz. Global Arguments LocallyLipschitz X {_} Y {_}. #[global] Instance locally_lipschitz_func `{MetricSpaceBall X, MetricSpaceBall Y} : Func (LocallyLipschitz X Y) X Y := λ f, f. #[global] Hint Extern 10 (ExtMetricSpaceClass (LocallyLipschitz _ _)) => apply @Linf_func_metric_space_class : typeclass_instances. Notation "X LL-> Y" := (LocallyLipschitz X Y) (at level 55, right associativity). Section Contractions. Context `{MetricSpaceBall X, MetricSpaceBall Y}. Class IsContraction (f : X -> Y) (q : Q) := { contr_prf :: IsLipschitz f q; contr_lt_1 : q < 1 }. Global Arguments contr_lt_1 f q {_}. Global Arguments contr_prf f q {_}. Record Contraction := { contr_func : X -> Y; contr_const : Q; contr_proof : IsContraction contr_func contr_const }. Global Instance const_contr `{!ExtMetricSpaceClass Y} (c : Y) : IsContraction (λ x : X, c) 0. Proof. constructor. + constructor. - reflexivity. - intros; apply mspc_refl. rewrite mult_0_l; reflexivity. + solve_propholds. Qed. (* Do we need the following? Global Instance contr_to_uc `(IsContraction f q) : IsUniformlyContinuous f (λ e, if (decide (q = 0)) then Qinf.infinite else (e / q)). Proof. apply _. Qed.*) End Contractions. Global Arguments Contraction X {_} Y {_}. Global Instance : PreOrder Qinf.le. Proof. constructor. + intros [x |]; [apply Qle_refl | easy]. + intros [x |] [y |] [z |]; solve [intros [] | intros _ [] | easy | apply Qle_trans]. Qed. Global Instance : AntiSymmetric Qinf.le. Proof. intros [x |] [y |] A B; [apply Qle_antisym | elim B | elim A |]; easy. Qed. Global Instance : PartialOrder Qinf.le. Proof. constructor; apply _. Qed. Global Instance : TotalRelation Qinf.le. Proof. intros [x |] [y |]; [change (x ≤ y \/ y ≤ x); apply total, _ | left | right | left]; easy. Qed. Global Instance : TotalOrder Qinf.le. Proof. constructor; apply _. Qed. Global Instance : ∀ x y : Qinf, Decision (x ≤ y). intros [x |] [y |]; [change (Decision (x ≤ y)); apply _ | left | right | left]; easy. Defined. Import minmax. (* Instances above allow using min and max for Qinf *) Section TotalOrderLattice. Context `{TotalOrder A} `{Lt A} `{∀ x y: A, Decision (x ≤ y)}. Lemma min_ind (P : A -> Prop) (x y : A) : P x → P y → P (min x y). Proof. unfold min, sort. destruct (decide_rel _ x y); auto. Qed. Lemma lt_min (x y z : A) : z < x -> z < y -> z < min x y. Proof. apply min_ind. Qed. End TotalOrderLattice. Section ProductSpaceFunctions. Definition diag {X : Type} (x : X) : X * X := (x, x). Global Instance diag_lip `{ExtMetricSpaceClass X} : IsLipschitz (@diag X) 1. Proof. constructor. + solve_propholds. + intros x1 x2 e A. rewrite mult_1_l. now split. Qed. Definition together {X1 Y1 X2 Y2 : Type} (f1 : X1 -> Y1) (f2 : X2 -> Y2) : X1 * X2 -> Y1 * Y2 := λ p, (f1 (fst p), f2 (snd p)). (*Global Instance together_lip `{ExtMetricSpaceClass X1, ExtMetricSpaceClass Y1, ExtMetricSpaceClass X2, ExtMetricSpaceClass Y2} (f1 : X1 -> Y1) (f2 : X2 -> Y2) `{!IsLipschitz f1 L1, !IsLipschitz f2 L2} : IsLipschitz (together f1 f2) (join L1 L2). (* What if we define the Lipschitz constant for [together f1 f2] to be [max L1 L2], where [max] is the name of an instance of [Join A] in orders.minmax? In fact, [Check _ : Join Q] returns [max]. I.e., [join x y] for [x y : Q] reduces to [max x y]. However, it is difficult to apply [lattices.join_le_compat_r] to the goal [0 ≤ max L1 L2]. Simple [apply] does not work (probably because the theorem has to be reduced to match the goal). As for [apply:] and [rapply], they invoke [refine (@join_le_compat_r _ _ ...)]. Some of the _ are implicit arguments and type classes (e.g., [Equiv] [Le]), and they are instantiated with the instances found first, which happen to be for [Qinf]. Apparently, unification does not try other instances. So, [apply:] with type classes is problematic. [apply: (@lattices.join_le_compat_r Q)] gives "Anomaly: Evd.define: cannot define an evar twice" *) Proof. constructor. + apply lattices.join_le_compat_r, (lip_nonneg f1 L1). + intros z1 z2 e [A1 A2]. (* Below we prove [0 ≤ e] using [radius_nonneg], which requires [ExtMetricSpaceClass]. Another way is to add the assymption [0 ≤ e] to [lip_prf], similar to [uc_prf]. *) assert (0 ≤ e) by now apply (radius_nonneg (fst z1) (fst z2)). split; simpl. - apply (mspc_monotone (L1 * e)); [apply (order_preserving (.* e)); apply join_ub_l |]. (* [apply (order_preserving (.* e)), join_ub_l.] does not work *) apply lip_prf; trivial. - apply (mspc_monotone (L2 * e)); [apply (order_preserving (.* e)); apply join_ub_r |]. apply lip_prf; trivial.*) Global Instance together_uc `{ExtMetricSpaceClass X1, ExtMetricSpaceClass Y1, ExtMetricSpaceClass X2, ExtMetricSpaceClass Y2} (f1 : X1 -> Y1) (f2 : X2 -> Y2) `{!IsUniformlyContinuous f1 mu1, !IsUniformlyContinuous f2 mu2} : IsUniformlyContinuous (together f1 f2) (λ e, min (mu1 e) (mu2 e)). Proof. constructor. + intros e e_pos. (* [apply min_ind] does not work if the goal has [meet] instead of [min] *) apply lt_min; [apply (uc_pos f1) | apply (uc_pos f2)]; trivial. (* [trivial] solves, in particular, [IsUniformlyContinuous f1 mu1], which should have been solved automatically *) + intros e z z' e_pos [A1 A2]. split; simpl. - apply (uc_prf f1 mu1); trivial. apply (mspc_monotone' (min (mu1 e) (mu2 e))); [apply: meet_lb_l | trivial]. - apply (uc_prf f2 mu2); trivial. apply (mspc_monotone' (min (mu1 e) (mu2 e))); [apply: meet_lb_r | trivial]. Qed. End ProductSpaceFunctions. Section CompleteMetricSpace. Context `{MetricSpaceBall X}. Class IsRegularFunction (f : Q -> X) : Prop := rf_prf : forall e1 e2 : Q, 0 < e1 -> 0 < e2 -> ball (e1 + e2) (f e1) (f e2). Record RegularFunction := { rf_func :> Q -> X; rf_proof : IsRegularFunction rf_func }. Arguments Build_RegularFunction {_} _. Global Existing Instance rf_proof. Global Instance rf_eq : Equiv RegularFunction := λ f1 f2, forall e1 e2 : Q, 0 < e1 -> 0 < e2 -> ball (e1 + e2) (f1 e1) (f2 e2). Context {EM : ExtMetricSpaceClass X}. Global Instance rf_setoid : Setoid RegularFunction. Proof. constructor. + intros f e1 e2; apply rf_prf. + intros f1 f2 A e1 e2 A1 A2. rewrite plus_comm. now apply mspc_symm, A. + intros f1 f2 f3 A1 A2 e1 e3 A3 A4. apply mspc_closed. intros d A5. mc_setoid_replace (e1 + e3 + d) with ((e1 + d / 2) + (e3 + d / 2)) by (field; change ((2 : Q) ≠ 0); solve_propholds). apply mspc_triangle with (b := f2 (d / 2)); [apply A1 | rewrite plus_comm; apply A2]; try solve_propholds. Qed. Instance rf_msb : MetricSpaceBall RegularFunction := λ e f1 f2, forall e1 e2 : Q, 0 < e1 -> 0 < e2 -> ball (e + e1 + e2) (f1 e1) (f2 e2). Lemma unit_reg (x : X) : IsRegularFunction (λ _, x). Proof. intros e1 e2 A1 A2; apply mspc_refl; solve_propholds. Qed. Definition reg_unit (x : X) := Build_RegularFunction (unit_reg x). Global Instance : Setoid_Morphism reg_unit. Proof. constructor; [apply _ .. |]. intros x y eq_x_y e1 e2 e1_pos e2_pos. apply mspc_eq; solve_propholds. Qed. Class Limit := lim : RegularFunction -> X. Class CompleteMetricSpaceClass `{Limit} := cmspc :: Surjective reg_unit (inv := lim). Definition tends_to (f : RegularFunction) (l : X) := forall e : Q, 0 < e -> ball e (f e) l. Lemma limit_def `{CompleteMetricSpaceClass} (f : RegularFunction) : forall e : Q, 0 < e -> ball e (f e) (lim f). Proof. intros e2 A2. apply mspc_symm; apply mspc_closed. (* [apply mspc_symm, mspc_closed.] does not work *) intros e1 A1. change (lim f) with (reg_unit (lim f) e1). rewrite plus_comm. rapply (surjective reg_unit (inv := lim)); trivial; reflexivity. Qed. End CompleteMetricSpace. Global Arguments RegularFunction X {_}. Global Arguments Limit X {_}. Global Arguments CompleteMetricSpaceClass X {_ _ _}. (* The exclamation mark before Limit avoids introducing a second assumption MetricSpaceBall X *) Lemma completeness_criterion `{ExtMetricSpaceClass X, !Limit X} : CompleteMetricSpaceClass X <-> forall f : RegularFunction X, tends_to f (lim f). Proof. split; intro A. + intros f e2 A2. apply mspc_symm, mspc_closed. intros e1 A1. change (lim f) with (reg_unit (lim f) e1). rewrite plus_comm. rapply (surjective reg_unit (A := X) (inv := lim)); trivial; reflexivity. + constructor; [| apply _]. apply ext_equiv_r; [apply _|]. intros f e1 e2 e1_pos e2_pos. apply (mspc_monotone e2); [apply nonneg_plus_le_compat_l; solve_propholds |]. now apply mspc_symm, A. Qed. Section UCFComplete. Context `{NonEmpty X, ExtMetricSpaceClass X, CompleteMetricSpaceClass Y}. Program Definition pointwise_regular (F : RegularFunction (UniformlyContinuous X Y)) (x : X) : RegularFunction Y := Build_RegularFunction (λ e, F e x) _. Next Obligation. intros e1 e2 e1_pos e2_pos; now apply F. Qed. Global Program Instance ucf_limit : Limit (UniformlyContinuous X Y) := λ F, Build_UniformlyContinuous (λ x, lim (pointwise_regular F x)) (λ e, uc_mu (F (e/3)) (e/3)) _. Next Obligation. constructor. * intros e e_pos. destruct (F (e/3)) as [g ? ?]; simpl; apply uc_pos with (f := g); trivial. apply Q.Qmult_lt_0_compat; auto with qarith. * intros e x1 x2 e_pos A. apply (mspc_triangle' (e/3) (e/3 + e/3) (F (e/3) x1)); [field; discriminate | |]. + apply mspc_symm. change ((F (e / 3)) x1) with (pointwise_regular F x1 (e/3)). (* without [change], neither [apply limit_def] nor [rapply limit_def] work *) apply completeness_criterion, Q.Qmult_lt_0_compat; auto with qarith. + apply mspc_triangle with (b := F (e / 3) x2). - destruct (F (e/3)); eapply uc_prf; eauto. apply Q.Qmult_lt_0_compat; auto with qarith. - change ((F (e / 3)) x2) with (pointwise_regular F x2 (e/3)). apply completeness_criterion, Q.Qmult_lt_0_compat; auto with qarith. Qed. Global Instance : CompleteMetricSpaceClass (UniformlyContinuous X Y). Proof. apply completeness_criterion. intros F e e_pos x. change (func (lim F) x) with (lim (pointwise_regular F x)). change (func (F e) x) with (pointwise_regular F x e). now apply completeness_criterion. Qed. End UCFComplete. Definition seq A := nat -> A. #[global] Hint Unfold seq : typeclass_instances. (* This unfolds [seq X] as [nat -> X] and allows ext_equiv to find an instance of [Equiv (seq X)] *) Section SequenceLimits. Context `{ExtMetricSpaceClass X}. Definition seq_lim (x : seq X) (a : X) (N : Q -> nat) := forall e : Q, 0 < e -> forall n : nat, N e ≤ n -> ball e (x n) a. (*Global Instance : Proper (((=) ==> (=)) ==> (=) ==> ((=) ==> (=)) ==> iff) seq_lim. Proof. intros x1 x2 A1 a1 a2 A2 N1 N2 A3; split; intros A e e_pos n A4. + mc_setoid_replace (x2 n) with (x1 n) by (symmetry; now apply A1). rewrite <- A2. mc_setoid_replace (N2 e) with (N1 e) in A4 by (symmetry; now apply A3). now apply A. + mc_setoid_replace (x1 n) with (x2 n) by now apply A1. rewrite A2. mc_setoid_replace (N1 e) with (N2 e) in A4 by now apply A3. now apply A. Qed.*) (* The following instance uses Leibniz equality for the third argument of seq_lim, i.e., the modulus of type [Q -> nat]. This is because extensional equality = is not reflexive on functions: [f = f] iff [f] is a morphism. And we need reflexivity when we replace the first argument of seq_lim and leave the third one unchanged. Do we need the previous instance with extensional equality for the third argument? *) Global Instance : Proper (((=) ==> (=)) ==> (=) ==> (≡) ==> iff) seq_lim. Proof. intros x1 x2 A1 a1 a2 A2 N1 N2 A3; split; intros A e e_pos n A4. + mc_setoid_replace (x2 n) with (x1 n) by (symmetry; now apply A1). rewrite <- A2. rewrite <- A3 in A4. now apply A. + mc_setoid_replace (x1 n) with (x2 n) by now apply A1. rewrite A2. rewrite A3 in A4. now apply A. Qed. Lemma seq_lim_unique : ∀ (x : seq X) (a1 a2 : X) N1 N2, seq_lim x a1 N1 → seq_lim x a2 N2 → a1 = a2. Proof. intros x a1 a2 N1 N2 A1 A2. apply -> mspc_eq; intros q A. assert (A3 : 0 < q / 2) by solve_propholds. specialize (A1 (q / 2) A3); specialize (A2 (q / 2) A3). set (M := Peano.max (N1 (q / 2)) (N2 (q / 2))). assert (A4 : N1 (q / 2) ≤ M) by apply Nat.le_max_l. assert (A5 : N2 (q / 2) ≤ M) by apply Nat.le_max_r. specialize (A1 M A4); specialize (A2 M A5). apply mspc_symm in A1. apply (mspc_triangle' (q / 2) (q / 2) (x M)); trivial. field; change ((2 : Q) ≠ 0); solve_propholds. Qed. Lemma seq_lim_S (x : seq X) (a : X) N : seq_lim x a N -> seq_lim (x ∘ S) a N. Proof. intros A e A1 n A2. apply A; trivial. apply le_S, A2. Qed. Lemma seq_lim_S' (x : seq X) (a : X) N : seq_lim (x ∘ S) a N -> seq_lim x a (S ∘ N). Proof. intros A e A1 n A2. destruct n as [| n]. + contradict A2; apply Nat.nle_succ_0. + apply A; trivial. apply le_S_n, A2. Qed. End SequenceLimits. Theorem seq_lim_cont `{ExtMetricSpaceClass X, ExtMetricSpaceClass Y} (f : X -> Y) {mu : Q -> Qinf} {_ : IsUniformlyContinuous f mu} (x : seq X) (a : X) (N : Q -> nat) : seq_lim x a N → seq_lim (f ∘ x) (f a) (comp_inf N mu 0). Proof. intros A e e_pos n A1. apply (uc_prf f mu); trivial. unfold comp_inf in A1; assert (A2 := uc_pos f mu e e_pos). now destruct (mu e); [apply A | apply mspc_inf]. Qed. Theorem seq_lim_contr `{MetricSpaceClass X, ExtMetricSpaceClass Y} (f : X -> Y) `{!IsContraction f q} (x : seq X) (a : X) (N : Q -> nat) : seq_lim x a N → seq_lim (f ∘ x) (f a) (comp_inf N (lip_modulus q) 0). Proof. intro A; apply seq_lim_cont; [apply _ | apply A]. Qed. Lemma iter_fixpoint `{ExtMetricSpaceClass X, ExtMetricSpaceClass Y} (f : X -> X) {mu : Q -> Qinf} {_ : IsUniformlyContinuous f mu} (x : seq X) (a : X) (N : Q -> nat) : (forall n : nat, x (S n) = f (x n)) -> seq_lim x a N -> f a = a. Proof. intros A1 A2; generalize A2; intro A3. apply seq_lim_S in A2. apply (seq_lim_cont f) in A3. setoid_replace (x ∘ S) with (f ∘ x) in A2 by (intros ? ? eqmn; rewrite eqmn; apply A1). eapply seq_lim_unique; eauto. Qed. Section CompleteSpaceSequenceLimits. Context `{CompleteMetricSpaceClass X}. Definition cauchy (x : seq X) (N : Q -> nat) := forall e : Q, 0 < e -> forall m n : nat, N e ≤ m -> N e ≤ n -> ball e (x m) (x n). Definition reg_fun (x : seq X) (N : Q -> nat) (A : cauchy x N) : RegularFunction X. refine (Build_RegularFunction (x ∘ N) _). (* without loss of generality, N e1 ≤ N e2 *) assert (A3 : forall e1 e2, 0 < e1 -> 0 < e2 -> N e1 ≤ N e2 -> ball (e1 + e2) ((x ∘ N) e1) ((x ∘ N) e2)). + intros e1 e2 A1 A2 A3. apply (mspc_monotone e1). - apply (strictly_order_preserving (e1 +)) in A2; rewrite plus_0_r in A2; solve_propholds. - apply A; trivial; reflexivity. + intros e1 e2 A1 A2. assert (A4 : TotalRelation (A := nat) (≤)) by apply _; destruct (A4 (N e1) (N e2)). - now apply A3. - rewrite plus_comm; now apply mspc_symm, A3. Defined. Arguments reg_fun {_} {_} _. Lemma seq_lim_lim (x : seq X) (N : Q -> nat) (A : cauchy x N) : seq_lim x (lim (reg_fun A)) (λ e, N (e / 2)). Proof. set (f := reg_fun A). intros e A1 n A2. apply (mspc_triangle' (e / 2) (e / 2) (x (N (e / 2)))). + field; change ((2 : Q) ≠ 0); solve_propholds. + now apply mspc_symm, A; [solve_propholds | reflexivity |]. + change (x (N (e / 2))) with (f (e / 2)). apply completeness_criterion; solve_propholds. Qed. End CompleteSpaceSequenceLimits. (*End QField.*) corn-8.20.0/old/000077500000000000000000000000001473720167500133345ustar00rootroot00000000000000corn-8.20.0/old/Transparent_algebra.v000066400000000000000000000027361473720167500175110ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Transparent cs_crr. Transparent csg_crr. Transparent cm_crr. Transparent cg_crr. Transparent cr_crr. Transparent cf_crr. Transparent csf_fun. Transparent csbf_fun. Transparent csr_rel. Transparent cs_eq. Transparent cs_neq. Transparent cs_ap. Transparent cm_unit. Transparent csg_op. Transparent cg_inv. Transparent cg_minus. Transparent cr_one. Transparent cr_mult. Transparent nexp_op. Transparent cf_div. corn-8.20.0/opaque/000077500000000000000000000000001473720167500140505ustar00rootroot00000000000000corn-8.20.0/opaque/Opaque_algebra.v000066400000000000000000000026001473720167500171440ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* Opaque cs_crr. *) Opaque csg_crr. Opaque cm_crr. Opaque cg_crr. Opaque cr_crr. Opaque cf_crr. Opaque csf_fun. Opaque csbf_fun. Opaque csr_rel. Opaque cs_eq. Opaque cs_neq. Opaque cs_ap. Opaque cm_unit. Opaque csg_op. Opaque cg_inv. Opaque cg_minus. Opaque cr_one. Opaque cr_mult. Opaque nexp_op. Opaque cf_div. corn-8.20.0/order/000077500000000000000000000000001473720167500136715ustar00rootroot00000000000000corn-8.20.0/order/Lattice.v000066400000000000000000000114151473720167500154470ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import Coq.Setoids.Setoid. Require Export CoRN.order.SemiLattice. Local Open Scope po_scope. (** * Lattice A lattice is a semilattice with a join operation such that it forms a semilattice with in the dual partial order. *) Record Lattice : Type := { sl :> SemiLattice ; join : sl -> sl -> sl ; l_proof : is_SemiLattice (Dual sl) join }. (* begin hide *) Arguments join [l]. (* end hide*) Section Join. Variable X : Lattice. Definition makeLattice (po:PartialOrder) (meet join : po -> po -> po) p1 p2 p3 p4 p5 p6 := @Build_Lattice (@makeSemiLattice po meet p1 p2 p3) join (@Build_is_SemiLattice (Dual po) join p4 p5 p6). (** The axioms of a join lattice. *) Lemma join_ub_l : forall x y : X, x <= join x y. Proof (sl_meet_lb_l _ _ (l_proof X)). Lemma join_ub_r : forall x y : X, y <= join x y. Proof (sl_meet_lb_r _ _ (l_proof X)). Lemma join_lub : forall x y z : X, x <= z -> y <= z -> join x y <= z. Proof (sl_meet_glb _ _ (l_proof X)). (** ** Dual Latice The dual of a lattice is a lattice. *) Definition Dual : Lattice := @makeLattice (Dual X) (@join X) (@meet X) join_ub_l join_ub_r join_lub (@meet_lb_l X) (@meet_lb_r X) (@meet_glb X). (** All the lemmas about meet semilattices hold for join. *) Lemma join_comm : forall x y:X, join x y == join y x. Proof meet_comm Dual. Lemma join_assoc : forall x y z:X, join x (join y z) == join (join x y) z. Proof meet_assoc Dual. Lemma join_idem : forall x:X, join x x == x. Proof meet_idem Dual. Lemma le_join_l : forall x y : X, y <= x <-> join x y == x. Proof le_meet_l Dual. Lemma le_join_r : forall x y : X, x <= y <-> join x y == y. Proof le_meet_r Dual. Lemma join_monotone_r : forall a : X, monotone X (join a). Proof meet_monotone_r Dual. Lemma join_monotone_l : forall a : X, monotone X (fun x => join x a). Proof meet_monotone_l Dual. Lemma join_le_compat : forall w x y z : X, w<=y -> x<=z -> join w x <= join y z. Proof fun w x y z => meet_le_compat Dual y z w x. End Join. (* begin hide *) Add Parametric Morphism X : (@join X) with signature (@st_eq (sl X)) ==> (@st_eq X) ==> (@st_eq X) as join_compat. Proof. exact (meet_compat (Dual X)). Qed. (* end hide *) Section MeetJoin. Variable X : Lattice. (** Lemma about how meet and join interact. *) Lemma meet_join_absorb_l_l : forall x y:X, meet x (join x y) == x. Proof. intros. apply le_antisym. apply meet_lb_l. apply meet_glb. apply le_refl. apply join_ub_l. Qed. Lemma meet_join_absorb_l_r : forall x y:X, meet x (join y x) == x. Proof. intros. rewrite -> (join_comm X). apply meet_join_absorb_l_l. Qed. Lemma meet_join_absorb_r_l : forall x y:X, meet (join x y) x == x. Proof. intros. rewrite -> (meet_comm X). apply meet_join_absorb_l_l. Qed. Lemma meet_join_absorb_r_r : forall x y:X, meet (join y x) x == x. Proof. intros. rewrite -> (join_comm X). apply meet_join_absorb_r_l. Qed. Lemma meet_join_eq : forall x y : X, meet x y == join x y -> x == y. Proof. intros. rewrite <- (meet_join_absorb_l_l y x). rewrite -> (join_comm X y x). rewrite <- H. rewrite -> (meet_comm X x y). rewrite -> (meet_assoc X). rewrite -> (meet_idem X). set (RHS := meet y x). rewrite <- (meet_join_absorb_l_l x y). rewrite <- H. rewrite -> (meet_assoc X). rewrite -> (meet_idem X). rewrite -> (meet_comm X). reflexivity. Qed. End MeetJoin. Section JoinMeet. Variable X : Lattice. (** The dual of the previous laws holds. *) Lemma join_meet_absorb_l_l : forall x y:X, join x (meet x y) == x. Proof meet_join_absorb_l_l (Dual X). Lemma join_meet_absorb_l_r : forall x y:X, join x (meet y x) == x. Proof meet_join_absorb_l_r (Dual X). Lemma join_meet_absorb_r_l : forall x y:X, join (meet x y) x == x. Proof meet_join_absorb_r_l (Dual X). Lemma join_meet_absorb_r_r : forall x y:X, join (meet y x) x == x. Proof meet_join_absorb_r_r (Dual X). End JoinMeet. corn-8.20.0/order/PartialOrder.v000066400000000000000000000121411473720167500164470ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Set Firstorder Depth 5. Require Export CoRN.algebra.RSetoid. Set Implicit Arguments. (** * Partial Order A partial order is a relfexive, transitive, antisymetric ordering relation. *) (* Perhaps adding monotone and antitone to the signature is going too far *) Record is_PartialOrder (car : Type) (eq : car -> car -> Prop) (le : car -> car -> Prop) (monotone : (car -> car) -> Prop) (antitone : (car -> car) -> Prop) : Prop := { po_equiv_le_def : forall x y, eq x y <-> (le x y /\ le y x) ; po_le_refl : forall x, le x x ; po_le_trans : forall x y z, le x y -> le y z -> le x z ; po_monotone_def : forall f, monotone f <-> (forall x y, le x y -> le (f x) (f y)) ; po_antitone_def : forall f, antitone f <-> (forall x y, le x y -> le (f y) (f x)) }. (* This ought to decend from RSetoid *) Record PartialOrder : Type := { po_car :> RSetoid ; le : po_car -> po_car -> Prop ; monotone : (po_car -> po_car) -> Prop ; antitone : (po_car -> po_car) -> Prop ; po_proof : is_PartialOrder (@st_eq po_car) le monotone antitone }. Notation "x == y" := (st_eq x y) (at level 70, no associativity) : po_scope. Notation "x <= y" := (le _ x y) : po_scope. Local Open Scope po_scope. Lemma po_st : forall X eq le mnt ant, @is_PartialOrder X eq le mnt ant -> Setoid_Theory X eq. Proof with trivial. intros X eq le0 mnt ant H. split. firstorder. intros x y E. apply (po_equiv_le_def H), and_comm, (po_equiv_le_def H)... intros x y z. repeat rewrite ->(po_equiv_le_def H). firstorder. Qed. (* begin hide *) Add Parametric Morphism (p:PartialOrder) : (le p) with signature (@st_eq p) ==> (@st_eq p) ==> iff as le_compat. Proof. assert (forall x1 x2 : p, x1 == x2 -> forall x3 x4 : p, x3 == x4 -> (x1 <= x3 -> x2 <= x4)). intros. rewrite -> (po_equiv_le_def (po_proof p)) in *|-. destruct (po_proof p). clear - H H0 H1 po_le_trans0. firstorder. intros x y Hxy x0 y0 Hx0y0. assert (y==x). symmetry; assumption. assert (y0==x0). symmetry; assumption. firstorder. Qed. (* end hide *) Section PartialOrder. Variable X : PartialOrder. Definition makePartialOrder car eq le monotone antitone p1 p2 p3 p4 p5 := let p := (@Build_is_PartialOrder car eq le monotone antitone p1 p2 p3 p4 p5) in @Build_PartialOrder (Build_RSetoid (po_st p)) le monotone antitone p. (** The axioms and basic properties of a partial order *) Lemma equiv_le_def : forall x y:X, x == y <-> (x <= y /\ y <= x). Proof (po_equiv_le_def (po_proof X)). Lemma le_refl : forall x:X, x <= x. Proof (po_le_refl (po_proof X)). Lemma le_trans : forall x y z : X, x <= y -> y <= z -> x <= z. Proof (po_le_trans (po_proof X)). Lemma monotone_def : forall f, monotone X f <-> (forall x y, x <= y -> (f x) <= (f y)). Proof (po_monotone_def (po_proof X)). Lemma antitone_def : forall f, antitone X f <-> (forall x y, x <= y -> (f y) <= (f x)). Proof (po_antitone_def (po_proof X)). Lemma le_equiv_refl : forall x y:X, x == y -> x <= y. Proof. firstorder using equiv_le_def. Qed. Lemma le_antisym : forall x y:X, x <= y -> y <= x -> x == y. Proof. firstorder using equiv_le_def. Qed. (** ** Dual Order The dual of a partial order is made by fliping the order relation. *) Definition Dual : PartialOrder. Proof. eapply makePartialOrder with (eq := @st_eq X) (le:= (fun x y => le X y x)) (monotone := @monotone X) (antitone := @antitone X). firstorder using equiv_le_def. firstorder using le_refl. firstorder using le_trans. firstorder using monotone_def. (* Notice the use of <-> in monotone_def here *) firstorder using antitone_def. Defined. End PartialOrder. Module Default. (** ** Default Monotone and Antitone These provide default implemenations of Monotone and Antitone. *) Section MonotoneAntitone. Variable A : Type. Variable le : A -> A -> Prop. Definition monotone (f: A -> A) := forall x y, le x y -> le (f x) (f y). Lemma monotone_def : forall f, monotone f <-> (forall x y, le x y -> le (f x) (f y)). Proof. firstorder. Qed. Definition antitone (f: A -> A) := forall x y, le x y -> le (f y) (f x). Lemma antitone_def : forall f, antitone f <-> (forall x y, le x y -> le (f y) (f x)). Proof. firstorder. Qed. End MonotoneAntitone. End Default. corn-8.20.0/order/SemiLattice.v000066400000000000000000000110741473720167500162660ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Set Firstorder Depth 5. Require Export CoRN.order.PartialOrder. Local Open Scope po_scope. (** * SemiLattice A (meet) semi lattice augments a partial order with a greatest lower bound operator. *) (*Should I take a PartialOrder parameter, or just a type and an inequality relation? *) Record is_SemiLattice (po : PartialOrder) (meet : po -> po -> po) : Prop := { sl_meet_lb_l : forall x y, meet x y <= x (*left lower bound*) ; sl_meet_lb_r : forall x y, meet x y <= y (*right lower bound*) ; sl_meet_glb : forall x y z, z <= x -> z <= y -> z <= meet x y (*greatest lower bound *) }. Record SemiLattice : Type := { po :> PartialOrder ; meet : po -> po -> po ; sl_proof : is_SemiLattice po meet }. (* begin hide *) Arguments meet [s]. Add Parametric Morphism (X:SemiLattice) : (@meet X) with signature (@st_eq X) ==> (@st_eq X) ==> (@st_eq X) as meet_compat. Proof. assert (forall x1 x2 : X, x1 == x2 -> forall x3 x4 : X, x3 == x4 -> meet x1 x3 <= meet x2 x4). intros. revert H H0; do 2 rewrite -> equiv_le_def; intros. pose (le_trans X). destruct (sl_proof X). apply sl_meet_glb0; firstorder. intros. pose (Seq_sym X _ (po_st (po_proof X))). apply le_antisym; firstorder. Qed. (* end hide *) Section Meet. Variable X : SemiLattice. Definition makeSemiLattice po meet p1 p2 p3 := @Build_SemiLattice po meet (@Build_is_SemiLattice po meet p1 p2 p3). (** The axioms and basic properties of a semi lattice *) Lemma meet_lb_l : forall x y : X, meet x y <= x. Proof (sl_meet_lb_l _ _ (sl_proof X)). Lemma meet_lb_r : forall x y : X, meet x y <= y. Proof (sl_meet_lb_r _ _ (sl_proof X)). Lemma meet_glb : forall x y z : X, z <= x -> z <= y -> z <= meet x y. Proof (sl_meet_glb _ _ (sl_proof X)). (** commutativity of meet *) Lemma meet_comm : forall x y:X, meet x y == meet y x. Proof. assert (forall x y : X, meet x y <= meet y x). intros. destruct X. simpl in *. firstorder. intros; apply le_antisym; firstorder. Qed. (** associativity of meet *) Lemma meet_assoc : forall x y z:X, meet x (meet y z) == meet (meet x y) z. Proof. assert (forall x y z : X, meet x (meet y z) <= meet (meet x y) z). intros. apply meet_glb; [apply meet_glb|]; firstorder using meet_lb_l, meet_lb_r, le_trans. intros. apply le_antisym. apply H. rewrite -> meet_comm. rewrite -> (meet_comm x (meet y z)). rewrite -> (meet_comm x y). rewrite -> (meet_comm y z). apply H. Qed. (** idempotency of meet *) Lemma meet_idem : forall x:X, meet x x == x. Proof. intros. apply le_antisym; firstorder using meet_lb_l, meet_glb, le_refl. Qed. Lemma le_meet_l : forall x y : X, x <= y <-> meet x y == x. Proof. intros. split; intros. apply le_antisym. apply meet_lb_l. apply meet_glb. apply le_refl. assumption. rewrite <- H. apply meet_lb_r. Qed. Lemma le_meet_r : forall x y : X, y <= x <-> meet x y == y. Proof. intros. rewrite -> meet_comm. apply le_meet_l. Qed. (** monotonicity of meet *) Lemma meet_monotone_r : forall a : X, monotone X (meet a). Proof. intros. rewrite -> monotone_def. intros. revert H;rewrite -> le_meet_l, meet_comm; intro. rewrite <- H. rewrite -> meet_assoc. apply meet_lb_l. Qed. Lemma meet_monotone_l : forall a : X, monotone X (fun x => meet x a). Proof. intros. assert (A:=meet_monotone_r a). revert A; do 2 rewrite -> monotone_def;intros. rewrite -> (meet_comm x), (meet_comm y);auto. Qed. Lemma meet_le_compat : forall w x y z : X, w<=y -> x<=z -> meet w x <= meet y z. Proof. intros. apply le_trans with (y:=meet y x). firstorder using meet_monotone_l, monotone_def. firstorder using meet_monotone_r, monotone_def. Qed. End Meet. corn-8.20.0/order/TotalOrder.v000066400000000000000000000231021473720167500161350ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Set Firstorder Depth 5. Require Import Coq.Setoids.Setoid. Require Export CoRN.order.Lattice. Local Open Scope po_scope. (** * Total Order A total order is a lattice were x <= y or y <= x. *) Record TotalOrder : Type := { L :> Lattice ; le_total : forall x y:L, {x <= y}+{y <= x} }. Section MinMax. Variable X : TotalOrder. (** meet x y is either x or y. *) Definition meet_irred : forall x y : X, {meet x y == x} + {meet x y == y}. Proof. intros. destruct (le_total _ x y) as [H|H]. left. firstorder using le_meet_l. right. firstorder using le_meet_r. Defined. Section Monotone. Variable f : X -> X. Hypothesis Hf : monotone X f. Add Morphism f with signature (@st_eq X) ==> (@st_eq X) as monotone_compat. Proof. revert Hf;rewrite -> monotone_def;intros Hf ??. do 2 rewrite -> equiv_le_def. firstorder. Qed. (** meet distributes over any monotone function. *) Lemma monotone_meet_distr : forall x y : X, f (meet x y) == meet (f x) (f y). Proof. set (Hf':=Hf). (* The section hypothesis is used in monotone_compat and hence cannot be changed. *) rewrite -> monotone_def in Hf'. assert (forall x y : X, x <= y -> f (meet x y) == meet (f x) (f y)). intros x y Hxy. assert (Hfxfy:=Hf' _ _ Hxy). rewrite -> le_meet_l in Hxy. rewrite -> le_meet_l in Hfxfy. rewrite -> Hfxfy. rewrite -> Hxy. reflexivity. intros. destruct (le_total _ x y). auto. rewrite -> (meet_comm X). rewrite -> (meet_comm _ (f x)). auto. Qed. End Monotone. (** join distributes over meet *) Lemma join_meet_distr_r : forall x y z:X, (join x (meet y z))==(meet (join x y) (join x z)). Proof (fun a => monotone_meet_distr _ (join_monotone_r X a)). Lemma join_meet_distr_l : forall x y z:X, (join (meet y z) x)==(meet (join y x) (join z x)). Proof (fun a => monotone_meet_distr _ (join_monotone_l X a)). Section Antitone. Variable f : X -> X. Hypothesis Hf : antitone X f. (* begin hide *) Add Parametric Morphism: f with signature (@st_eq X) ==> (@st_eq X) as antitone_compat. Proof. revert Hf; rewrite -> antitone_def; intros. rewrite -> equiv_le_def in *. firstorder. Qed. (* end hide *) (* meet transforms into join for antitone functions *) Lemma antitone_meet_join_distr : forall x y : X, f (meet x y) == join (f x) (f y). Proof. pose (Hf':=Hf). rewrite antitone_def in Hf'. assert (forall x y : X, x <= y -> f (meet x y) == join (f x) (f y)). intros x y Hxy. assert (Hfxfy:=Hf' _ _ Hxy). rewrite -> le_meet_l in Hxy. rewrite -> le_join_l in Hfxfy. rewrite -> Hfxfy. clear Hfxfy. apply antitone_compat. rewrite -> Hxy. reflexivity. intros. destruct (le_total _ x y). auto. rewrite -> (meet_comm X). rewrite -> (join_comm X). auto. Qed. End Antitone. (** Lemmas of distributive lattices *) Lemma join_meet_modular_r : forall x y z : X, join x (meet y (join x z)) == meet (join x y) (join x z). Proof. intros. rewrite -> join_meet_distr_r. rewrite -> (join_assoc X). rewrite -> (join_idem X). reflexivity. Qed. Lemma join_meet_modular_l : forall x y z : X, join (meet (join x z) y) z == meet (join x z) (join y z). Proof. intros. rewrite -> (join_comm X (meet (join x z) y) z). rewrite -> (meet_comm X (join x z) y). rewrite -> (meet_comm X (join x z) (join y z)). rewrite -> (join_comm X x z). rewrite -> (join_comm X y z). apply join_meet_modular_r. Qed. Lemma meet_join_disassoc : forall x y z : X, meet (join x y) z <= join x (meet y z). Proof. intros. rewrite -> join_meet_distr_r. apply meet_le_compat. apply le_refl. apply join_ub_r. Qed. End MinMax. Section MaxMin. Variable X : TotalOrder. (** ** Dual Total Order The dual of a total order is a total order. *) Definition Dual : TotalOrder. eapply Build_TotalOrder with (L:= Dual X). Proof. intros. destruct (le_total _ x y); auto. Defined. (** The duals of the previous lemmas hold. *) Definition join_irred : forall x y : X, {join x y == x} + {join x y == y} := meet_irred Dual. Lemma monotone_join_distr : forall f, monotone X f -> forall x y : X, f (join x y) == join (f x) (f y). Proof monotone_meet_distr Dual. Lemma meet_join_distr_r : forall x y z:X, (meet x (join y z))==(join (meet x y) (meet x z)). Proof join_meet_distr_r Dual. Lemma meet_join_distr_l : forall x y z:X, (meet (join y z) x)==(join (meet y x) (meet z x)). Proof join_meet_distr_l Dual. Lemma antitone_join_meet_distr : forall f, antitone X f -> forall x y : X, f (join x y) == meet (f x) (f y). Proof antitone_meet_join_distr Dual. Lemma meet_join_modular_r : forall x y z : X, meet x (join y (meet x z)) == join (meet x y) (meet x z). Proof join_meet_modular_r Dual. Lemma meet_join_modular_l : forall x y z : X, meet (join (meet x z) y) z == join (meet x z) (meet y z). Proof join_meet_modular_l Dual. End MaxMin. Section TotalOrderMinDef. Variable X : PartialOrder. (** Given a total order, meet and join can be characterized in terms of the order.*) Variable min : X -> X -> X. Hypothesis le_total : forall x y:X, {x <= y}+{y <= x}. Hypothesis min_def1 : forall x y:X, x <= y -> min x y == x. Hypothesis min_def2 : forall x y:X, y <= x -> min x y == y. Lemma min_lb_l : forall x y:X, min x y <= x. Proof. intros. destruct (le_total x y). rewrite -> min_def1; auto. apply le_refl. rewrite -> min_def2; auto. Qed. Lemma min_lb_r : forall x y:X, min x y <= y. Proof. intros. destruct (le_total x y). rewrite -> min_def1; auto. rewrite -> min_def2; auto. apply le_refl. Qed. Lemma min_glb : forall x y z, z <= x -> z <= y -> z <= min x y. Proof. intros. destruct (le_total x y). rewrite -> min_def1; assumption. rewrite -> min_def2; assumption. Qed. End TotalOrderMinDef. (** With a total order has a new characterization. *) Definition makeTotalOrder : forall (A : Type) (equiv : A -> A -> Prop) (le : A -> A -> Prop) (monotone antitone : (A -> A) -> Prop) (meet join : A -> A -> A), (forall x y : A, equiv x y <-> (le x y /\ le y x)) -> (forall x : A, le x x) -> (forall x y z : A, le x y -> le y z -> le x z) -> (forall x y : A, {le x y} + {le y x}) -> (forall f, monotone f <-> (forall x y, le x y -> le (f x) (f y))) -> (forall f, antitone f <-> (forall x y, le x y -> le (f y) (f x))) -> (forall x y : A, le x y -> equiv (meet x y) x) -> (forall x y : A, le y x -> equiv (meet x y) y) -> (forall x y : A, le y x -> equiv (join x y) x) -> (forall x y : A, le x y -> equiv (join x y) y) -> TotalOrder. Proof. intros A0 eq0 le0 monotone0 antitone0 min max eq0_def refl trans total monotone0_def antitone0_def min_def1 min_def2 max_def1 max_def2. pose (PO:=makePartialOrder eq0 le0 monotone0 antitone0 eq0_def refl trans monotone0_def antitone0_def). pose (DPO := (PartialOrder.Dual PO)). pose (flip_total := fun x y => total y x). pose (L0:=makeLattice PO min max (min_lb_l PO min total min_def1 min_def2) (min_lb_r PO min total min_def1 min_def2) (min_glb PO min total min_def1 min_def2) (min_lb_l DPO max flip_total max_def1 max_def2) (min_lb_r DPO max flip_total max_def1 max_def2) (min_glb DPO max flip_total max_def1 max_def2)). exact (Build_TotalOrder L0 total). Defined. Module Default. (** ** Default meet and join. *) Section MinDefault. Variable A : Type. Variable equiv: A -> A -> Prop. Variable le : A -> A -> Prop. Hypothesis equiv_le_def : forall x y : A, equiv x y <-> (le x y /\ le y x). Hypothesis le_total : forall x y:A, {le x y}+{le y x}. (** Given a total order, meet and join have a default implemenation. *) Definition min (x y:A) := if (le_total x y) then x else y. Definition min_case x y (P:A -> Type) (Hx : le x y -> P x) (Hy : le y x -> P y) : P (min x y) := match (le_total x y) as s return P (if s then x else y) with | left p => Hx p | right p => Hy p end. Lemma min_def1 : forall x y, le x y -> equiv (min x y) x. Proof. intros. apply min_case; firstorder auto. Qed. Lemma min_def2 : forall x y, le y x -> equiv (min x y) y. Proof. intros. apply min_case; firstorder auto. Qed. End MinDefault. Section MaxDefault. Variable A : Type. Variable equiv: A -> A -> Prop. Variable le : A -> A -> Prop. Hypothesis equiv_le_def : forall x y : A, equiv x y <-> (le x y /\ le y x). Hypothesis le_total : forall x y:A, {le x y}+{le y x}. Definition max (x y:A) := if le_total y x then x else y. Let flip_le x y := le y x. Let flip_le_total x y := le_total y x. Definition max_case : forall x y (P : A -> Type), (le y x -> P x) -> (le x y -> P y) -> P (max x y) := min_case A flip_le flip_le_total. Lemma max_def1 : forall x y, le y x -> equiv (max x y) x. Proof. refine (min_def1 A equiv flip_le _ flip_le_total). firstorder auto. Qed. Lemma max_def2 : forall x y, le x y -> equiv (max x y) y. Proof. refine (min_def2 A equiv flip_le _ flip_le_total). firstorder auto. Qed. End MaxDefault. End Default. corn-8.20.0/raster/000077500000000000000000000000001473720167500140565ustar00rootroot00000000000000corn-8.20.0/raster/Raster.v000066400000000000000000000151721473720167500155130ustar00rootroot00000000000000Require Coq.Vectors.Vector. Export Vector.VectorNotations. Require Export CoRN.stdlib_omissions.List. From Coq Require Import Arith BinPos. Set Implicit Arguments. (** * Rasters An n by m raster is a matrix of booleans. Do not use Vector, which stores a slow nat on each cons. *) Variant raster (columns lines : positive) : Set := | raster_data : list (list bool) -> raster columns lines. (* TODO directly list (list bool), length of first line then all lines same length. *) Definition raster_well_formed {columns lines : positive} (r : raster columns lines) : Prop := match r with raster_data _ _ d => length d = Pos.to_nat lines /\ Forall (fun line : list bool => length line = Pos.to_nat columns) d end. (** A series of notation allows rasters to be rendered (and to a certain extent parsed) in Coq *) Notation "'⎥' a b" := (List.cons a b) (format "'[v' '⎥' a '/' b ']'", at level 0, a, b at level 0) : raster. Notation "'⎥' a" := (List.cons a List.nil) (format "'⎥' a", at level 0, a at level 0) : raster. (* Notation "☙" := (Vnil (vector bool _)) (at level 0, right associativity) : raster. *) Notation "█ a" := (List.cons true a) (at level 0, right associativity) : raster. Notation "⎢" := (@List.nil bool) (at level 0, right associativity) : raster. Notation "' ' a" := (List.cons false a) (at level 0, right associativity) : raster. Notation "░ a" := (List.cons false a) (at level 0, right associativity, only parsing) : raster_parsing. (** Standard rasters. *) Definition emptyRaster n m : raster n m := raster_data n m (List.repeat (List.repeat false (Pos.to_nat n)) (Pos.to_nat m)). Lemma emptyRaster_wf : forall n m, raster_well_formed (emptyRaster n m). Proof. split. - apply repeat_length. - apply Forall_forall. intros. apply repeat_spec in H. subst x. apply repeat_length. Qed. (** Indexing into a raster *) Definition RasterIndex {n m} (r:raster n m) i j : bool := let (d) := r in nth j (nth i d nil) false. Lemma nth_repeat : forall A n (x:A) k d, nth n (List.repeat x k) d = if le_lt_dec k n then d else x. Proof. intros. destruct (le_lt_dec k n). - apply nth_overflow. rewrite repeat_length. exact l. - apply (repeat_spec k x). apply nth_In. rewrite repeat_length. exact l. Qed. (** Indexing into an empty raster is alway empty *) Lemma emptyRasterEmpty : forall n m i j, RasterIndex (emptyRaster n m) i j = false. Proof. intros n m i j. simpl. rewrite (nth_repeat i (repeat false (Pos.to_nat n)) (Pos.to_nat m) nil). destruct (le_lt_dec (Pos.to_nat m) i). - destruct j; reflexivity. - rewrite (nth_repeat j false (Pos.to_nat n) false). destruct (le_lt_dec (Pos.to_nat n) j); reflexivity. Qed. (** [setRaster] transforms a raster by setting (or reseting) the (i,j)th pixel. *) Fixpoint updateList A (v : list A) (f : A->A) : nat -> list A := match v with | nil => fun _ => nil | cons a' v' => fun i => match i with | 0 => cons (f a') v' | S i' => cons a' (updateList v' f i') end end. Lemma updateList_length : forall A (v:list A) f i, length (updateList v f i) = length v. Proof. induction v. - reflexivity. - intros. simpl. destruct i. reflexivity. simpl. rewrite IHv. reflexivity. Qed. Lemma updateList_correct1 : forall A (v: list A) f i d1 d2, i < length v -> nth i (updateList v f i) d1 = f (nth i v d2). Proof. induction v. intros. absurd (i < 0); auto with *. intros f [|i] d1 d2 H. reflexivity. simpl. apply IHv. auto with *. Qed. Lemma updateList_correct2 : forall A (v: list A) f d1 i j, i <> j -> nth i (updateList v f j) d1 = nth i v d1. Proof. induction v. reflexivity. intros f d1 i [|j] H; destruct i as [|i]; try reflexivity. elim H; auto. simpl. apply IHv. auto. Qed. Lemma updateList_overflow : forall A (v : list A) f i, length v <= i -> updateList v f i = v. Proof. induction v. - reflexivity. - intros. simpl. destruct i. exfalso; inversion H. apply f_equal. rewrite IHv. reflexivity. apply le_S_n, H. Qed. Definition setRaster {n m} (r:raster n m) (x:bool) (i j:nat) : raster n m := let (d) := r in raster_data n m (updateList d (fun row => updateList row (fun _ => x) j) i). Lemma setRaster_wf : forall n m (r:raster n m) x i j, raster_well_formed r -> raster_well_formed (setRaster r x i j). Proof. intros. destruct r. destruct H. split. - rewrite updateList_length. exact H. - apply Forall_forall. intros. apply In_nth with (d:=nil) in H1. destruct H1 as [k [H1 H2]]. subst x0. rewrite Forall_forall in H0. rewrite updateList_length in H1. destruct (Nat.eq_dec k i). + subst i. rewrite updateList_correct1 with (d2:=nil). rewrite updateList_length. apply H0. apply nth_In, H1. exact H1. + rewrite (updateList_correct2 l). 2: exact n0. apply H0. apply nth_In, H1. Qed. Lemma setRaster_correct1 : forall {n m : positive} (r:raster n m) x i j, raster_well_formed r -> (i < Pos.to_nat m) -> (j < Pos.to_nat n) -> RasterIndex (setRaster r x i j) i j = x. Proof. intros n m r x i j rWf Hi Hj. destruct r. simpl. destruct rWf. rewrite updateList_correct1 with (d2:=nil). 2: rewrite H; exact Hi. rewrite updateList_correct1. reflexivity. trivial. rewrite Forall_forall in H0. rewrite (H0 (nth i l nil)). exact Hj. apply nth_In. rewrite H. exact Hi. Qed. Lemma setRaster_overflow : forall {n m} (r:raster n m) x i j, raster_well_formed r -> (Pos.to_nat m <= i) \/ (Pos.to_nat n <= j) -> (setRaster r x i j) = r. Proof. intros. destruct r. unfold setRaster. apply f_equal. destruct H. destruct H0. - apply updateList_overflow. rewrite H. exact H0. - clear H m. rewrite Forall_forall in H1. revert i. induction l. + reflexivity. + intro i. simpl. destruct i. f_equal. apply updateList_overflow. rewrite (H1 a). exact H0. left. reflexivity. f_equal. apply IHl. intros. apply H1. right. exact H. Qed. Lemma setRaster_correct2 : forall n m (r:raster n m) x i j i0 j0, raster_well_formed r -> (i <> i0) \/ (j <> j0) -> RasterIndex (setRaster r x i0 j0) i j = RasterIndex r i j. Proof. intros n m r x i j i0 j0 rWf H. destruct (le_lt_dec (Pos.to_nat m) i0) as [Hm | Hm]. rewrite setRaster_overflow; auto with *. destruct (le_lt_dec (Pos.to_nat n) j0) as [Hn | Hn]. rewrite setRaster_overflow; auto with *. destruct r as [l]. simpl. destruct H. + f_equal. rewrite updateList_correct2. reflexivity. exact H. + destruct rWf. destruct (Nat.eq_dec i i0). subst i0. rewrite updateList_correct1 with (d2:=nil). 2: rewrite H0; exact Hm. rewrite updateList_correct2. reflexivity. exact H. f_equal. rewrite updateList_correct2. reflexivity. exact n0. Qed. corn-8.20.0/reals/000077500000000000000000000000001473720167500136645ustar00rootroot00000000000000corn-8.20.0/reals/Bridges_LUB.v000066400000000000000000001004451473720167500161400ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) (* file : least_upper_bound_principle.v *) (* version : 1.50 - 03/05/2001 *) (* version : 1.00 - 27/02/2001 *) (* author : Milad Niqui *) (* language : coq 7.0beta26feb *) (* dependency : iso_CReals.v , Expon.v *) (* description : proof of the Bridges' least upper bound principle *) Require Export CoRN.reals.iso_CReals. Require Import CoRN.algebra.Expon. Section LUBP. Variable R1 : CReals. (* SUBSECTION ON GENRAL DEFINITIONS *) Section lub_definitions. Variable OF : COrdField. Variable SS : OF -> CProp. Definition member (H : {x : OF | SS x}) := let (N, _) := H in N. Definition Pmember (H : {x : OF | SS x}) := projT2 H. Definition is_upper_bound (b : OF) := forall x : OF, SS x -> forall z : OF, z[<]x -> z[<]b. Definition l_u_b := {b : OF | is_upper_bound b and (forall b' : OF, b'[<]b -> {s : OF | SS s and b'[<]s})}. Definition supremum (H : l_u_b) := let (N, _) := H in N. Definition Psupremum (H : l_u_b) := projT2 H. (* the following definitions are not used in *) (* this file but later we will need them *) Definition is_lower_bound (c : OF) := forall x : OF, SS x -> forall z : OF, z[<]c -> z[<]x. Definition g_l_b := {c : OF | is_lower_bound c and (forall c' : OF, c[<]c' -> {s : OF | SS s and s[<]c'})}. Definition infimum (H : g_l_b) := let (N, _) := H in N. Definition Pinfimum (H : g_l_b) := projT2 H. End lub_definitions. (* MAIN SECTION *) Section upper_bound_sequence. Variable A : R1 -> CProp. Hypothesis is_inhabitted : {x : R1 | A x}. Hypothesis bounded_above : {b : R1 | is_upper_bound R1 A b}. Hypothesis located : forall x y : R1, x[<]y -> is_upper_bound R1 A y or {s : R1 | A s | x[<]s}. Let s := member R1 A is_inhabitted. Let Ps := Pmember R1 A is_inhabitted. Let b0 := let (N, _) := bounded_above in N. Let Pb0 := projT2 bounded_above. Lemma b0_is_upper_bound : is_upper_bound R1 A b0. Proof. exact Pb0. Qed. Lemma s_inhabits_A : A s. Proof. exact Ps. Qed. Let dstart_l := s[-][1]. Let dstart_r := b0[+][1]. Lemma dl_less_dr : dstart_l[<]dstart_r. Proof. apply less_transitive_unfolded with (y := b0). unfold is_upper_bound in bounded_above. cut (forall x : R1, A x -> forall z : R1, z[<]x -> z[<]b0). intro H. cut (forall z : R1, z[<]s -> z[<]b0). intro H0. apply H0. unfold dstart_l in |- *. apply shift_minus_less. apply less_plusOne. intros. apply H with (z := z) (x := s). apply Ps. assumption. exact Pb0. unfold dstart_r in |- *. apply less_plusOne. Qed. Lemma shrink23d : forall r1 r2 : R1, r1[<]r2 -> r1[+](r2[-]r1) [/]ThreeNZ[<]r2[-](r2[-]r1) [/]ThreeNZ. Proof. intros. apply plus_cancel_less with (z := (r2[-]r1) [/]ThreeNZ). rstepl (r2[-](r2[-]r1) [/]ThreeNZ). rstepr r2. apply plus_cancel_less with (z := [--]r2). rstepr ([--]([0]:R1)). rstepl ([--]((r2[-]r1) [/]ThreeNZ)). apply inv_resp_less. apply mult_cancel_less with (z := Three:R1). apply pos_nring_S. rstepl ([0]:R1). rstepr (r2[-]r1). apply shift_zero_less_minus. assumption. Qed. Lemma shrink13d : forall r1 r2 : R1, r1[<]r2 -> r1[<]r2[-](r2[-]r1) [/]ThreeNZ. Proof. intros. apply less_transitive_unfolded with (y := r1[+](r2[-]r1) [/]ThreeNZ). astepl (r1[+][0]). apply plus_resp_less_lft. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. assumption. apply shrink23d. assumption. Qed. Lemma shrink24d : forall r1 r2 : R1, r1[<]r2 -> r1[+](r2[-]r1) [/]ThreeNZ[<]r2. Proof. intros. apply less_transitive_unfolded with (y := r2[-](r2[-]r1) [/]ThreeNZ). apply shrink23d. assumption. astepl (r2[+][--]((r2[-]r1) [/]ThreeNZ)). astepr (r2[+][0]). apply plus_resp_less_lft. apply inv_cancel_less. rstepl ([0]:R1). rstepr ((r2[-]r1) [/]ThreeNZ). apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. assumption. Qed. Definition Real_Interval := Interval R1. Definition dcotrans_analyze : forall r1 r2 : R1, r1[<]r2 -> R1. Proof. intros. case (located (r1[+](r2[-]r1) [/]ThreeNZ) (r2[-](r2[-]r1) [/]ThreeNZ)). apply shrink23d. assumption. intro. exact (r2[-](r2[-]r1) [/]ThreeNZ). intro. exact (r1[+](r2[-]r1) [/]ThreeNZ). Defined. Lemma dcotrans_analyze_strong : forall (r1 r2 : R1) (H : r1[<]r2), {s : R1 | A s | r1[+](r2[-]r1) [/]ThreeNZ[<]s} and dcotrans_analyze r1 r2 H[=]r1[+](r2[-]r1) [/]ThreeNZ or is_upper_bound R1 A (r2[-](r2[-]r1) [/]ThreeNZ) and dcotrans_analyze r1 r2 H[=]r2[-](r2[-]r1) [/]ThreeNZ. Proof. intros. unfold dcotrans_analyze in |- *. elim (located (r1[+](r2[-]r1) [/]ThreeNZ) (r2[-](r2[-]r1) [/]ThreeNZ) (shrink23d _ _ H)). intro. right. split. assumption. apply eq_reflexive_unfolded. intro. left. split. assumption. apply eq_reflexive_unfolded. Qed. Notation "( p , q )" := (pairT p q). Definition dif_cotrans : forall I1 : Real_Interval, Real_Interval. Proof. intros. case I1. intros i pi. elim (dcotrans_analyze_strong (fstT i) (sndT i) pi). intro. exact (Build_Interval _ (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ, sndT i) (shrink24d (fstT i) (sndT i) pi)). intro. exact (Build_Interval _ (fstT i, sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) (shrink13d (fstT i) (sndT i) pi)). Defined. Lemma dif_cotrans_strong : forall I1 : Real_Interval, {s : R1 | A s | fstT I1[+](sndT I1[-]fstT I1) [/]ThreeNZ[<]s} and dif_cotrans I1 = Build_Interval _ (fstT I1[+](sndT I1[-]fstT I1) [/]ThreeNZ, sndT I1) (shrink24d (fstT I1) (sndT I1) (is_interval _ I1)) or is_upper_bound R1 A (sndT I1[-](sndT I1[-]fstT I1) [/]ThreeNZ) and dif_cotrans I1 = Build_Interval _ (fstT I1, sndT I1[-](sndT I1[-]fstT I1) [/]ThreeNZ) (shrink13d (fstT I1) (sndT I1) (is_interval _ I1)). Proof. intros. case I1. intros i pi. elim (dcotrans_analyze_strong _ _ pi). intro y. left. elim y. intros H H0. split. exact H. cut (dif_cotrans (Build_Interval _ i pi) = Build_Interval _ (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ, sndT i) (shrink24d (fstT i) (sndT i) pi)). intro H1. rewrite H1. simpl in |- *. apply refl_equal. unfold dif_cotrans in |- *. apply not_r_cor_rect. apply or_not_and. right. apply ap_imp_neq. astepl (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ). apply less_imp_ap. apply shrink23d. assumption. intro y. elim y. intros H H0. right. split. exact H. cut (dif_cotrans (Build_Interval R1 i pi) = Build_Interval R1 (fstT i, sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) (shrink13d (fstT i) (sndT i) pi)). intro. rewrite H1. simpl in |- *. reflexivity. unfold dif_cotrans in |- *. apply not_l_cor_rect. apply or_not_and. right. apply ap_imp_neq. astepl (sndT i[-](sndT i[-]fstT i) [/]ThreeNZ). apply Greater_imp_ap. apply shrink23d. assumption. Qed. Fixpoint dIntrvl (n : nat) : Real_Interval := match n with | O => Build_Interval _ (dstart_l, dstart_r) dl_less_dr | S p => dif_cotrans (dIntrvl p) end. Let U (n : nat) := (fstT (dIntrvl n)[+]sndT (dIntrvl n)) [/]TwoNZ. Let V (n : nat) := fstT (dIntrvl n). Let W (n : nat) := sndT (dIntrvl n). Lemma delta_dIntrvl : forall n : nat, Length _ (dIntrvl (S n))[=]Two [/]ThreeNZ[*]Length _ (dIntrvl n). Proof. intros. case (dif_cotrans_strong (dIntrvl n)). intro a. elim a. intros H H0. simpl in |- *. rewrite H0. unfold Length in |- *. simpl in |- *. rational. intro a. elim a. intros H H0. simpl in |- *. rewrite H0. unfold Length in |- *. simpl in |- *. rational. Qed. Lemma Length_dIntrvl : forall n : nat, Length _ (dIntrvl n)[=](Two [/]ThreeNZ)[^]n[*](dstart_r[-]dstart_l). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) unfold Length in |- *. simpl in |- *. rational. (* n=(S n0) & induction hypothesis *) astepr (Two [/]ThreeNZ[*]((Two [/]ThreeNZ)[^]n[*](dstart_r[-]dstart_l))). astepr (Two [/]ThreeNZ[*]Length _ (dIntrvl n)). apply delta_dIntrvl. astepr ((Two [/]ThreeNZ)[^]n[*]Two [/]ThreeNZ[*](dstart_r[-]dstart_l)). rational. Qed. Lemma dIntrvl_inside_l_n : forall m n : nat, m <= n -> fstT (dIntrvl m)[<=]fstT (dIntrvl n). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) cut (m = 0). intro. rewrite H0. simpl in |- *. apply leEq_reflexive. apply Nat.le_0_r. assumption. (* n=(S n0) *) cut ({m = S n} + {m <= n}). intro H0. case H0. intro H1. rewrite H1. apply leEq_reflexive. intro H2. apply leEq_transitive with (y := fstT (dIntrvl n)). apply Hrecn. assumption. case (dif_cotrans_strong (dIntrvl n)). intro a. elim a. intros H3 H4. change (fstT (dIntrvl n)[<=]fstT (dif_cotrans (dIntrvl n))) in |- *. rewrite H4. simpl in |- *. astepl (fstT (dIntrvl n)[+][0]). apply plus_resp_leEq_both with (b := (sndT (dIntrvl n)[-]fstT (dIntrvl n)) [/]ThreeNZ). apply leEq_reflexive. apply less_leEq. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. apply is_interval. intro a. elim a. intros H3 H4. change (fstT (dIntrvl n)[<=]fstT (dif_cotrans (dIntrvl n))) in |- *. rewrite H4. simpl in |- *. apply leEq_reflexive. case (le_lt_eq_dec m (S n) H). intro. right. apply Nat.lt_succ_r. assumption. intro. left. assumption. Qed. Lemma dIntrvl_inside_r_n : forall m n : nat, m <= n -> sndT (dIntrvl n)[<=]sndT (dIntrvl m). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) cut (m = 0). intro H0. rewrite H0. simpl in |- *. apply leEq_reflexive. apply Nat.le_0_r. assumption. (* n=(S n0) *) cut ({m = S n} + {m <= n}). intro H0. case H0. intro H1. rewrite H1. apply leEq_reflexive. intro H2. apply leEq_transitive with (y := sndT (dIntrvl n)). case (dif_cotrans_strong (dIntrvl n)). intro a. elim a. intros H3 H4. change (sndT (dif_cotrans (dIntrvl n))[<=]sndT (dIntrvl n)) in |- *. rewrite H4. simpl in |- *. apply leEq_reflexive. intro a. elim a. intros H3 H4. change (sndT (dif_cotrans (dIntrvl n))[<=]sndT (dIntrvl n)) in |- *. rewrite H4. simpl in |- *. astepr (sndT (dIntrvl n)[+][0]). astepl (sndT (dIntrvl n)[+][--]((sndT (dIntrvl n)[-]fstT (dIntrvl n)) [/]ThreeNZ)). apply plus_resp_leEq_both. apply leEq_reflexive. apply inv_cancel_leEq. astepl ([0]:R1). astepr ((sndT (dIntrvl n)[-]fstT (dIntrvl n)) [/]ThreeNZ). apply less_leEq. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. apply is_interval. apply Hrecn. assumption. case (le_lt_eq_dec m (S n) H). intro. right. apply Nat.lt_succ_r. assumption. intro. left. assumption. Qed. Lemma V_increase : forall m n : nat, m <= n -> V m[<=]V n. Proof. intros. unfold V in |- *. apply dIntrvl_inside_l_n. assumption. Qed. Lemma W_decrease : forall m n : nat, m <= n -> W n[<=]W m. Proof. intros. unfold W in |- *. apply dIntrvl_inside_r_n. assumption. Qed. Lemma U_m_n_V : forall m n : nat, m <= n -> V m[<]U n. Proof. intros. unfold U in |- *. apply leEq_less_trans with (y := V n). apply V_increase. assumption. unfold V in |- *. apply Smallest_less_Average. apply is_interval. Qed. Lemma U_m_n_W : forall m n : nat, m <= n -> U n[<]W m. Proof. intros. unfold U in |- *. apply less_leEq_trans with (y := W n). unfold W in |- *. apply Average_less_Greatest. apply is_interval. apply W_decrease. assumption. Qed. (* These lemma are *very* similar to those in *) (* Cauchy_rationals_approach_reals.v *) Lemma a_familiar_simple_inequality : forall m : nat, 4 <= m -> (Two [/]ThreeNZ)[^]m[<](([1]:R1)[/] nring (S m)[//]nringS_ap_zero _ m). Proof. intros. induction m as [| m Hrecm]. apply False_rect. generalize H. change (~ 4 <= 0) in |- *. apply Nat.nle_succ_0. case (le_lt_eq_dec 4 (S m) H). intro. apply less_transitive_unfolded with (y := Two [/]ThreeNZ[*](([1]:R1)[/] nring (S m)[//]nringS_ap_zero _ m)). astepl (((Two:R1) [/]ThreeNZ)[^]m[*]Two [/]ThreeNZ). astepl ((Two:R1) [/]ThreeNZ[*](Two [/]ThreeNZ)[^]m). apply mult_resp_less_lft. apply Hrecm. apply Nat.lt_succ_r. assumption. apply div_resp_pos. apply pos_three. apply pos_two. apply mult_cancel_less with (z := (Three:R1)[*]nring (S m)[*]nring (S (S m))). apply mult_resp_pos. apply mult_resp_pos. apply pos_three. apply pos_nring_S. apply pos_nring_S. rstepl ((Two:R1)[*]nring (S (S m))). rstepr ((Three:R1)[*]nring (S m)). astepl ((Two:R1)[*](nring m[+]Two)). astepr ((Three:R1)[*](nring m[+][1])). apply plus_cancel_less with (z := [--]((Two:R1)[*]nring m[+]Three)). rstepl ([1]:R1). rstepr (nring (R:=R1) m). astepl (nring (R:=R1) 1). apply nring_less. apply Nat.lt_trans with (m := 3). constructor. constructor. apply Nat.succ_lt_mono. assumption. simpl in |- *. algebra. apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. simpl in |- *. rational. intro H0. rewrite <- H0. apply mult_cancel_less with (z := nring (R:=R1) 5[*]Three[^]4). apply mult_resp_pos. apply pos_nring_S. rstepr (Three[^]2[*](Three[^]2:R1)). apply mult_resp_pos. apply pos_square. apply nringS_ap_zero. apply pos_square. apply nringS_ap_zero. rstepl (Two[^]4[*]nring (R:=R1) 5). rstepr (Three[^]4:R1). rstepl (nring (R:=R1) 80). rstepr (nring (R:=R1) 81). apply nring_less. constructor. Qed. Lemma U_conversion_rate2 : forall m n : nat, 4 <= m -> m <= n -> AbsSmall (dstart_r[-]dstart_l[/] nring (S m)[//]nringS_ap_zero _ m) (U m[-]U n). Proof. intros. apply AbsSmall_leEq_trans with (e1 := Length _ (dIntrvl m)). apply less_leEq. astepl ((Two [/]ThreeNZ)[^]m[*](dstart_r[-]dstart_l)). rstepr (([1][/] nring (S m)[//]nringS_ap_zero _ m)[*](dstart_r[-]dstart_l)). apply mult_resp_less. apply a_familiar_simple_inequality. assumption. apply shift_zero_less_minus. apply dl_less_dr. apply eq_symmetric_unfolded. apply Length_dIntrvl. unfold Length in |- *. apply AbsSmall_subinterval; apply less_leEq. change (V m[<]U m) in |- *. apply U_m_n_V. constructor. change (V m[<]U n) in |- *. apply U_m_n_V. assumption. change (U m[<]W m) in |- *. apply U_m_n_W. constructor. change (U n[<]W m) in |- *. apply U_m_n_W. assumption. Qed. Lemma CS_seq_U : Cauchy_prop (fun m : nat => U m). Proof. intros. unfold Cauchy_prop in |- *. intros e H. cut {n : nat | (dstart_r[-]dstart_l[/] e[//]Greater_imp_ap _ e [0] H)[<]nring n}. intro H0. case H0. intro N. intro. exists (S (N + 3)). intros. apply AbsSmall_minus. apply AbsSmall_leEq_trans with (e1 := dstart_r[-]dstart_l[/] nring (S (S (N + 3)))[//] nringS_ap_zero R1 (S (N + 3))). apply less_leEq. apply swap_div with (z_ := Greater_imp_ap _ e [0] H). apply pos_nring_S. assumption. apply less_transitive_unfolded with (y := nring (R:=R1) N). assumption. apply nring_less. apply Nat.lt_succ_r. constructor. apply Nat.le_add_r. apply U_conversion_rate2 with (m := S (N + 3)). apply le_n_S. rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply Archimedes'. (* Note the use of Archimedean Property of R1 *) Qed. Definition U_as_CauchySeq := Build_CauchySeq R1 (fun m : nat => U m) CS_seq_U. Let B := Lim U_as_CauchySeq. Lemma U_minus_V : forall n : nat, U n[-]V n[=]Length _ (dIntrvl n) [/]TwoNZ. Proof. intros. unfold U in |- *. unfold V in |- *. unfold Length in |- *. rational. Qed. Lemma U_minus_W : forall n : nat, W n[-]U n[=]Length _ (dIntrvl n) [/]TwoNZ. Proof. intros. unfold U in |- *. unfold W in |- *. unfold Length in |- *. rational. Qed. Lemma U_V_upper : forall n : nat, U n[-]V n[<](Two [/]ThreeNZ)[^]n[*](dstart_r[-]dstart_l). Proof. intro. apply less_wdr with (y := Length _ (dIntrvl n)). apply less_wdl with (x := Length _ (dIntrvl n) [/]TwoNZ). apply plus_cancel_less with (z := [--](Length R1 (dIntrvl n) [/]TwoNZ)). rstepl ([0]:R1). rstepr (Length R1 (dIntrvl n) [/]TwoNZ). apply pos_div_two. unfold Length in |- *. apply shift_zero_less_minus. apply is_interval. apply eq_symmetric_unfolded. apply U_minus_V. apply Length_dIntrvl. Qed. Lemma U_W_lower : forall n : nat, W n[-]U n[<](Two [/]ThreeNZ)[^]n[*](dstart_r[-]dstart_l). Proof. intro. apply less_wdr with (y := Length _ (dIntrvl n)). apply less_wdl with (x := Length _ (dIntrvl n) [/]TwoNZ). apply plus_cancel_less with (z := [--](Length R1 (dIntrvl n) [/]TwoNZ)). rstepl ([0]:R1). rstepr (Length R1 (dIntrvl n) [/]TwoNZ). apply pos_div_two. unfold Length in |- *. apply shift_zero_less_minus. apply is_interval. apply eq_symmetric_unfolded. apply U_minus_W. apply Length_dIntrvl. Qed. Lemma AbsSmall_U_V : forall n : nat, AbsSmall ((Two [/]ThreeNZ)[^]n[*](dstart_r[-]dstart_l)) (U n[-]V n). Proof. intros. split; apply less_leEq. apply less_wdr with (y := Length R1 (dIntrvl n) [/]TwoNZ). apply less_wdl with (x := [--](Length R1 (dIntrvl n))). apply plus_cancel_less with (z := Length R1 (dIntrvl n)). rstepl ([0]:R1). apply plus_resp_pos. apply pos_div_two. unfold Length in |- *. apply shift_zero_less_minus. apply is_interval. unfold Length in |- *. apply shift_zero_less_minus. apply is_interval. apply un_op_wd_unfolded. apply Length_dIntrvl. apply eq_symmetric_unfolded. apply U_minus_V. apply U_V_upper. Qed. Lemma AbsSmall_U_W : forall n : nat, AbsSmall ((Two [/]ThreeNZ)[^]n[*](dstart_r[-]dstart_l)) (W n[-]U n). Proof. intro. split; apply less_leEq. apply less_wdr with (y := Length R1 (dIntrvl n) [/]TwoNZ). apply less_wdl with (x := [--](Length R1 (dIntrvl n))). apply plus_cancel_less with (z := Length R1 (dIntrvl n)). rstepl ([0]:R1). apply plus_resp_pos. apply pos_div_two. unfold Length in |- *. apply shift_zero_less_minus. apply is_interval. unfold Length in |- *. apply shift_zero_less_minus. apply is_interval. apply un_op_wd_unfolded. apply Length_dIntrvl. apply eq_symmetric_unfolded. apply U_minus_W. apply U_W_lower. Qed. (* Two properties of exponentiation in COrdFields *) Lemma nexp_resp_great_One : forall (OF : COrdField) (x : OF), [1][<]x -> forall n : nat, [1][<=]x[^]n. Proof. intros. change (x[^]0[<=]x[^]n) in |- *. apply great_nexp_resp_le. apply less_leEq; assumption. apply Nat.le_0_l. Qed. Lemma very_weak_binomial : forall (OF : COrdField) (x : OF) (n : nat), [0][<]x -> 1 < n -> [1][+]nring n[*]x[<](x[+][1])[^]n. Proof. do 3 intro. intros H H0. induction n as [| n Hrecn]. apply False_rect. apply (Nat.nlt_0_r 0). apply Nat.lt_trans with (m := 1). apply Nat.lt_0_succ. assumption. case (le_lt_eq_dec 2 (S n) (proj1 (Nat.le_succ_l 1 (S n)) H0)). intro. cut ([1][+]nring n[*]x[<](x[+][1])[^]n). intro. apply less_wdr with (y := (x[+][1])[^]n[*](x[+][1])). apply less_transitive_unfolded with (y := [1][+]nring (S n)[*]x[+]nring n[*]x[^]2). apply plus_cancel_less with (z := [--]([1][+]nring (S n)[*]x)). rstepl ([0]:OF). rstepr (nring n[*]x[^]2). apply mult_resp_pos. change (nring (R:=OF) 0[<]nring n) in |- *. apply nring_less. apply Nat.succ_lt_mono. assumption. apply pos_square. apply Greater_imp_ap. assumption. apply less_wdl with (x := ([1][+]nring n[*]x)[*](x[+][1])). apply mult_resp_less. assumption. apply less_transitive_unfolded with (y := x). assumption. apply less_plusOne. simpl in |- *. rational. simpl in |- *. apply eq_reflexive_unfolded. apply Hrecn. apply Nat.succ_lt_mono. assumption. intro H1. rewrite <- H1. apply less_wdr with (y := [1][+]Two[*]x[+]x[^]2). apply plus_cancel_less with (z := [--]([1][+]Two[*]x)). astepl ([0]:OF). apply less_wdr with (y := x[^]2). apply pos_square. apply Greater_imp_ap. assumption. rational. simpl in |- *. rational. Qed. (* A consequence of Archimedean property - *) (* the every basis of definition of e=lim(1+1/n)^n *) Lemma nexp_resp_Two : forall x : R1, [1][<]x -> {M : nat | Two[<]x[^]M}. Proof. intros. cut (x[-][1][#][0]). intro H0. cut {N : nat | ([1][/] x[-][1][//]H0)[<]nring N}. intro H1. case H1. intro N. intro. exists (S N). apply less_transitive_unfolded with (y := (([1][/] nring (S N)[//]nringS_ap_zero _ N)[+]([1]:R1))[^]S N). apply less_wdl with (x := ([1]:R1)[+] nring (S N)[*]([1][/] nring (S N)[//]nringS_ap_zero _ N)). apply very_weak_binomial. apply recip_resp_pos. apply pos_nring_S. apply -> Nat.succ_lt_mono. apply Nat.neq_0_lt_0. apply Nat.neq_sym. apply (nring_ap_zero_imp R1). apply Greater_imp_ap. apply less_transitive_unfolded with (y := [1][/] x[-][1][//]H0). apply recip_resp_pos. apply shift_zero_less_minus. assumption. assumption. rational. apply nexp_resp_less. apply le_n_S. apply Nat.le_0_l. apply less_leEq. apply less_transitive_unfolded with (y := [1]:R1). apply pos_one. apply plus_cancel_less with (z := [--]([1]:R1)). astepl ([0]:R1). rstepr (([1]:R1)[/] nring (S N)[//]nringS_ap_zero R1 N). apply recip_resp_pos. apply pos_nring_S. apply plus_cancel_less with (z := [--]([1]:R1)). rstepl ([1][/] nring (S N)[//]nringS_ap_zero R1 N). astepr (x[-][1]). apply swap_div with (z_ := H0). apply pos_nring_S. apply shift_zero_less_minus. assumption. apply less_transitive_unfolded with (y := nring (R:=R1) N). assumption. apply nring_less_succ. apply Archimedes'. (* Note the use of Archimedean property *) apply Greater_imp_ap. apply shift_zero_less_minus. assumption. Qed. Lemma twisted_archimedean : forall (n : nat) (x : R1), [1][<]x -> {M : nat | nring n[<]x[^]M}. Proof. intros n x H. induction n as [| n Hrecn]. exists 0. simpl in |- *. apply pos_one. case Hrecn. intro M1. intros. case (nexp_resp_Two x H). intro M2. intros. exists (M1 + M2). apply less_transitive_unfolded with (y := x[^]M1[+][1]). simpl in |- *. apply plus_resp_less_leEq. assumption. apply leEq_reflexive. apply less_wdr with (y := x[^]M1[*]x[^]M2). apply plus_cancel_less with (z := [--](x[^]M1)). apply less_wdl with (x := [1]:R1). apply less_wdr with (y := x[^]M1[*](x[^]M2[-][1])). apply leEq_less_trans with (y := x[^]M1[*][1]). astepr (x[^]M1). apply nexp_resp_great_One. assumption. apply mult_resp_less_lft. apply shift_less_minus. rstepl (Two:R1). assumption. apply leEq_less_trans with (y := nring (R:=R1) n). change (nring (R:=R1) 0[<=]nring n) in |- *. apply nring_leEq. apply Nat.le_0_l. assumption. rational. rational. apply nexp_plus. Qed. Lemma B_limit_V : forall e : R1, [0][<]e -> {N : nat | forall m : nat, N <= m -> AbsSmall e (V m[-]B)}. Proof. intros e H. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (V m[-]U m)}. intro H0. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (U m[-]B)}. intro H1. case H0. intro N1. intro H2. case H1. intro N2. intro H3. exists (N1 + N2). intros. rstepr (V m[-]U m[+](U m[-]B)). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply H2. apply Nat.le_trans with (m := N1 + N2). apply Nat.le_add_r. assumption. apply H3. apply Nat.le_trans with (m := N1 + N2). rewrite Nat.add_comm; apply Nat.le_add_r. assumption. unfold B in |- *. cut (SeqLimit U_as_CauchySeq (Lim U_as_CauchySeq)). intro H1. red in H1. apply H1. apply pos_div_two. assumption. apply Lim_Cauchy. (* The Core of the Proof *) cut {n : nat | (Two[*](dstart_r[-]dstart_l)[/] e[//]Greater_imp_ap _ e [0] H)[<]nring n}. intro H0. case H0. intro N. intros. case (twisted_archimedean N (Three [/]TwoNZ)). apply mult_cancel_less with (z := Two:R1). apply pos_two. astepl (Two:R1). rstepr (Three:R1). apply two_less_three. intro M. intros. exists M. intros. apply AbsSmall_leEq_trans with (e1 := (Two [/]ThreeNZ)[^]m[*](dstart_r[-]dstart_l)). apply less_leEq. apply mult_cancel_less with (z := ((Three:R1) [/]TwoNZ)[^]m). apply less_leEq_trans with (y := ((Three:R1) [/]TwoNZ)[^]0). simpl in |- *. apply pos_one. apply great_nexp_resp_le. apply less_leEq. apply mult_cancel_less with (z := Two:R1). apply pos_two. rstepl (Two:R1). rstepr (Three:R1). apply two_less_three. apply Nat.le_0_l. apply less_wdl with (x := (Two[^]m[/] Three[^]m[//]nexp_resp_ap_zero m (three_ap_zero R1))[*] (dstart_r[-]dstart_l)[*] (Three[^]m[/] Two[^]m[//]nexp_resp_ap_zero m (two_ap_zero R1))). rstepl (dstart_r[-]dstart_l). apply mult_cancel_less with (z := Two[/] e[//]Greater_imp_ap _ e [0] H). apply div_resp_pos. assumption. apply pos_two. apply less_wdl with (x := Two[*](dstart_r[-]dstart_l)[/] e[//]Greater_imp_ap _ e [0] H). rstepr (((Three:R1) [/]TwoNZ)[^]m). apply less_transitive_unfolded with (y := nring (R:=R1) N). assumption. apply less_leEq_trans with (y := ((Three:R1) [/]TwoNZ)[^]M). assumption. apply great_nexp_resp_le. apply less_leEq. apply mult_cancel_less with (z := Two:R1). apply pos_two. rstepl (Two:R1). astepr (Three:R1). apply two_less_three. assumption. rational. apply bin_op_wd_unfolded. apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply nexp_distr_div'. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply nexp_distr_div'. apply AbsSmall_minus. apply AbsSmall_U_V. apply Archimedes'. Qed. Lemma B_limit_W : forall e : R1, [0][<]e -> {N : nat | forall m : nat, N <= m -> AbsSmall e (W m[-]B)}. Proof. intros e H. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (W m[-]U m)}. intro H0. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (U m[-]B)}. intro H1. case H0. intro N1. intros. case H1. intro N2. intros. exists (N1 + N2). intros. rstepr (W m[-]U m[+](U m[-]B)). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply a. apply Nat.le_trans with (m := N1 + N2). apply Nat.le_add_r. assumption. apply a0. apply Nat.le_trans with (m := N1 + N2). rewrite Nat.add_comm; apply Nat.le_add_r. assumption. unfold B in |- *. cut (SeqLimit U_as_CauchySeq (Lim U_as_CauchySeq)). intro H1. red in H1. apply H1. apply pos_div_two. assumption. apply Lim_Cauchy. (* The Core of the Proof *) cut {n : nat | (Two[*](dstart_r[-]dstart_l)[/] e[//]Greater_imp_ap _ e [0] H)[<]nring n}. intro H0. case H0. intro N. intros. case (twisted_archimedean N (Three [/]TwoNZ)). apply mult_cancel_less with (z := Two:R1). apply pos_two. astepl (Two:R1). rstepr (Three:R1). apply two_less_three. intro M. intros. exists M. intros. apply AbsSmall_leEq_trans with (e1 := (Two [/]ThreeNZ)[^]m[*](dstart_r[-]dstart_l)). apply less_leEq. apply mult_cancel_less with (z := ((Three:R1) [/]TwoNZ)[^]m). apply less_leEq_trans with (y := ((Three:R1) [/]TwoNZ)[^]0). simpl in |- *. apply pos_one. apply great_nexp_resp_le. apply less_leEq. apply mult_cancel_less with (z := Two:R1). apply pos_two. rstepl (Two:R1). rstepr (Three:R1). apply two_less_three. apply Nat.le_0_l. apply less_wdl with (x := (Two[^]m[/] Three[^]m[//]nexp_resp_ap_zero m (three_ap_zero R1))[*] (dstart_r[-]dstart_l)[*] (Three[^]m[/] Two[^]m[//]nexp_resp_ap_zero m (two_ap_zero R1))). rstepl (dstart_r[-]dstart_l). apply mult_cancel_less with (z := Two[/] e[//]Greater_imp_ap _ e [0] H). apply div_resp_pos. assumption. apply pos_two. apply less_wdl with (x := Two[*](dstart_r[-]dstart_l)[/] e[//]Greater_imp_ap _ e [0] H). rstepr (((Three:R1) [/]TwoNZ)[^]m). apply less_transitive_unfolded with (y := nring (R:=R1) N). assumption. apply less_leEq_trans with (y := ((Three:R1) [/]TwoNZ)[^]M). assumption. apply great_nexp_resp_le. apply less_leEq. apply mult_cancel_less with (z := Two:R1). apply pos_two. rstepl (Two:R1). astepr (Three:R1). apply two_less_three. assumption. rational. apply bin_op_wd_unfolded. apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply nexp_distr_div'. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply nexp_distr_div'. apply AbsSmall_U_W. apply Archimedes'. Qed. Lemma W_n_is_upper : forall n : nat, is_upper_bound R1 A (W n). Proof. intros. induction n as [| n Hrecn]. (* n=O *) unfold W in |- *. simpl in |- *. unfold dstart_r in |- *. red in |- *. intros x H z H0. cut (is_upper_bound R1 A b0). intros H1. red in H1. apply less_transitive_unfolded with (y := b0). apply (H1 x H z). assumption. apply less_plusOne. exact Pb0. (* n=(S n0) *) case (dif_cotrans_strong (dIntrvl n)). intro a. elim a. intros H H0. unfold W in |- *. simpl in |- *. rewrite H0. simpl in |- *. exact Hrecn. intro a. elim a. intros. unfold W in |- *. simpl in |- *. rewrite b. simpl in |- *. exact a0. Qed. Lemma A_bounds_V_n : forall n : nat, {s' : R1 | A s' | V n[<]s'}. Proof. intro. induction n as [| n Hrecn]. (* n=0 *) unfold V in |- *. simpl in |- *. exists s. apply s_inhabits_A. unfold dstart_l in |- *. apply shift_minus_less. apply less_plusOne. (* n=(S n0) *) case (dif_cotrans_strong (dIntrvl n)). intro a. elim a. intros H H0. unfold V in |- *. simpl in |- *. rewrite H0. simpl in |- *. exact H. intro a. elim a. intros H H0. unfold V in |- *. simpl in |- *. rewrite H0. simpl in |- *. exact Hrecn. Qed. Theorem cauchy_gives_lub : l_u_b R1 A. Proof. intros. unfold l_u_b in |- *. exists B. split. (* to prove the first condition of l.u.b *) red in |- *. intros t At. intros. case (B_limit_W ((t[-]z) [/]TwoNZ)). apply pos_div_two. apply shift_zero_less_minus. assumption. intro N. intro H0. cut (AbsSmall ((t[-]z) [/]TwoNZ) (W N[-]B)). intro H1. apply plus_cancel_less with (z := (t[-]z) [/]TwoNZ). apply less_leEq_trans with (y := W N). rstepl (t[-](t[-]z) [/]TwoNZ). cut (is_upper_bound R1 A (W N)). intro H2. red in H2. apply (H2 t At). apply plus_cancel_less with (z := (t[-]z) [/]TwoNZ[-]t). rstepl ([0]:R1). rstepr ((t[-]z) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. apply W_n_is_upper. apply plus_cancel_leEq_rht with (z := [--]B). astepl (W N[-]B). rstepr ((t[-]z) [/]TwoNZ). elim H1. intros H2 H3. assumption. apply H0. constructor. (* to prove the second condition of a l.u.b. *) intros b' H. case (B_limit_V ((B[-]b') [/]TwoNZ)). apply pos_div_two. apply shift_zero_less_minus. assumption. intro N. intro H0. cut (AbsSmall ((B[-]b') [/]TwoNZ) (V N[-]B)). intros. case (A_bounds_V_n N). intro s'. set (H2 := True) in *. (* dummy *) intros. exists s'. split. assumption. apply less_transitive_unfolded with (y := V N). apply less_leEq_trans with (y := B[-](B[-]b') [/]TwoNZ). apply plus_cancel_less with (z := [--]b'). astepl ([0]:R1). rstepr ((B[-]b') [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. apply plus_cancel_leEq_rht with (z := [--]B). astepr (V N[-]B). rstepl ([--]((B[-]b') [/]TwoNZ)). elim H1. intros. assumption. assumption. apply H0. constructor. Qed. End upper_bound_sequence. End LUBP. (* end hide *) corn-8.20.0/reals/Bridges_iso.v000066400000000000000000001117151473720167500163120ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) (* file : bridges_gives_our.v *) (* version : 1.50 - 09/05/2001 *) (* version : 1.00 - 09/03/2001 *) (* author : Milad Niqui *) (* language : coq7.0bet26feb *) (* dependency : least_upper_bound_principle *) (* description : Bridges' proof of Cauchy completeness in TCS-219 *) Require Import CoRN.reals.Bridges_LUB. (* This lemma comes from lemmas.v of Martijn Oostdijk *) Lemma le_witness_informative : forall m n : nat, m <= n -> {k : nat | n = m + k}. Proof. intros. induction n as [| n Hrecn]. exists 0. rewrite <- (plus_n_O m). symmetry in |- *. apply Nat.le_0_r. assumption. case (le_lt_eq_dec m (S n)). assumption. intro. case Hrecn. apply Nat.lt_succ_r. assumption. intro k. intros. exists (S k). rewrite <- (Nat.add_succ_comm m k). simpl in |- *. apply eq_S. assumption. intro. exists 0. rewrite <- (plus_n_O m). symmetry in |- *. assumption. Qed. Section bridges_axioms_imply_ours. Variable OF : COrdField. Hypothesis lubp : forall X : OF -> CProp, {x : OF | X x} -> {b : OF | is_upper_bound OF X b} -> (forall x y : OF, x[<]y -> is_upper_bound OF X y or {s : OF | X s | x[<]s}) -> l_u_b OF X. Hypothesis is_Archimedes : forall x : OF, {n : nat | x[<=]nring n}. Lemma is_Archimedes' : forall x : OF, {n : nat | x[<]nring n}. Proof. intro x. elim (is_Archimedes (x[+][1])); intros n Hn. exists n. apply less_leEq_trans with (x[+][1]). apply less_plusOne. auto. Qed. Section proofs_in_TCS. Lemma leEq_geEq : forall x y : OF, (forall t : OF, t[<]x -> t[<]y) -> forall z : OF, y[<]z -> x[<]z. Proof. intros x y H z H0. apply plus_cancel_less with (z := [--](z[-]y)). rstepr y. apply H. apply shift_plus_less. apply plus_cancel_less with (z := [--]x). rstepr (z[-]y). astepl ([0]:OF). apply shift_zero_less_minus. assumption. Qed. Theorem glbp : forall X : OF -> CProp, {x : OF | X x} -> {l : OF | is_lower_bound OF X l} -> (forall x y : OF, x[=]y -> X x -> X y) -> (forall x y : OF, x[<]y -> is_lower_bound OF X x or {s : OF | X s | s[<]y}) -> g_l_b OF X. Proof. intros X H H0 strong_extensionality_of_X. intros. red in |- *. cut (l_u_b OF (fun x : OF => X [--]x)). intro H2. red in H2. case H2. intro b. intros a. exists ([--]b). elim a. intros H3 H4. split. red in |- *. intros x H5 z H6. red in H3. case (less_cotransitive_unfolded OF z [--]b H6 x). trivial. intro. exfalso. apply (less_irreflexive_unfolded _ b). apply H3 with (x := [--]x) (z := b). apply (strong_extensionality_of_X x [--][--]x). algebra. assumption. apply inv_cancel_less. astepl x. assumption. intros. case (H4 [--]c'). apply inv_cancel_less. astepr c'. assumption. intro s. intros H6. elim H6. intros. exists ([--]s). split. assumption. apply inv_cancel_less. astepr s. assumption. (* * * * * * * *) apply (lubp (fun x : OF => X [--]x)). case H. intro x. intro. exists ([--]x). apply (strong_extensionality_of_X x [--][--]x). algebra. assumption. case H0. intro l. intros. exists ([--]l). red in |- *. red in i. intros. apply inv_cancel_less. astepl l. apply (leEq_geEq l [--]x). intros. apply i with (x := [--]x). assumption. assumption. apply inv_resp_less. assumption. rename X0 into H1. intros x y H2. case (H1 [--]y [--]x). apply inv_resp_less. assumption. intro. left. red in |- *. red in i. intros. apply inv_cancel_less. apply (leEq_geEq [--]y [--]x0). intros. apply i with (x := [--]x0). assumption. assumption. apply inv_resp_less. assumption. intro e. right. case e. intro s. intros. exists ([--]s). apply (strong_extensionality_of_X s [--][--]s). algebra. assumption. apply inv_cancel_less. rstepl s. assumption. Qed. Section supremum. Variable P : OF -> CProp. Lemma inequality1 : forall x : OF, x[<]x[^]2[-]x[+]Two. Proof. intros. apply plus_cancel_less with (z := [--]x). astepl ([0]:OF). simpl in |- *. rstepr ((x[-][1])[*](x[-][1])[+][1]). apply less_wdr with (y := (x[-][1])[^]2[+]([1]:OF)). apply less_leEq_trans with (y := [1]:OF). apply pos_one. apply plus_cancel_leEq_rht with (z := [--]([1]:OF)). astepl ([0]:OF). rstepr ((x[-]([1]:OF))[^]2). apply sqr_nonneg. simpl in |- *. rational. Qed. Lemma inequality2 : forall x : OF, ([0]:OF)[<]x[^]2[-]x[+]Two. Proof. intros. apply less_wdr with (y := (x[-][1] [/]TwoNZ)[^]2[+](Three [/]FourNZ[+][1])). apply less_leEq_trans with (y := Three [/]FourNZ[+]([1]:OF)). apply plus_resp_pos. apply div_resp_pos. apply pos_four. apply pos_three. apply pos_one. apply plus_cancel_leEq_rht with (z := [--](Three [/]FourNZ[+]([1]:OF))). astepl ([0]:OF). rstepr ((x[-]([1]:OF) [/]TwoNZ)[^]2). apply sqr_nonneg. simpl in |- *. rational. Qed. Lemma inequality3 : forall x : OF, [--](x[^]2)[-]x[-]Two[<]x. Proof. intros. apply inv_cancel_less. apply plus_cancel_less with (z := x). simpl in |- *. rstepr ((x[+][1])[*](x[+][1])[+][1]). astepl ([0]:OF). apply less_wdr with (y := (x[+][1])[^]2[+]([1]:OF)). apply less_leEq_trans with (y := [1]:OF). apply pos_one. apply plus_cancel_leEq_rht with (z := [--]([1]:OF)). astepl ([0]:OF). rstepr ((x[+]([1]:OF))[^]2). apply sqr_nonneg. simpl in |- *. rational. Qed. Lemma inequality4 : forall x : OF, [--](x[^]2)[-]x[-]Two[<]([0]:OF). Proof. intros. apply inv_cancel_less. astepl ([0]:OF). apply less_wdr with (y := (x[+][1] [/]TwoNZ)[^]2[+](Three [/]FourNZ[+][1])). apply less_leEq_trans with (y := Three [/]FourNZ[+]([1]:OF)). apply plus_resp_pos. apply div_resp_pos. apply pos_four. apply pos_three. apply pos_one. apply plus_cancel_leEq_rht with (z := [--](Three [/]FourNZ[+]([1]:OF))). astepl ([0]:OF). rstepr ((x[+]([1]:OF) [/]TwoNZ)[^]2). apply sqr_nonneg. simpl in |- *. rational. Qed. Fixpoint Hum (r : nat -> OF) (n : nat) {struct n} : OF := match n with | O => r 0 | S p => r (S p)[+]Hum r p end. Lemma bound_tk1 : forall (n : nat) (g : nat -> OF), (forall m : nat, m <= n -> ([0]:OF)[<]g m) -> ([0]:OF)[<]Hum g n. Proof. intros n g H. induction n as [| n Hrecn]. simpl in |- *. apply H. constructor. (* n=(S n0) *) simpl in |- *. apply plus_resp_pos. apply H. apply le_n. apply Hrecn. intros. apply H. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. Qed. Lemma bound_tk2 : forall (n : nat) (g : nat -> OF), (forall m : nat, m <= n -> g m[<]([0]:OF)) -> Hum g n[<][0]. Proof. intros n g H. induction n as [| n Hrecn]. simpl in |- *. apply H. constructor. (* n=(S n0) *) simpl in |- *. astepr ([0][+]([0]:OF)). apply plus_resp_less_both. apply H. apply le_n. apply Hrecn. intros. apply H. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. Qed. Lemma trick : forall (n : nat) (r g : nat -> OF), (forall m : nat, m <= n -> ([0]:OF)[<]g m) -> (forall m : nat, m <= n -> r m[<]g m) -> forall m : nat, m <= n -> r m[<]Hum g n. Proof. intros n r g H H0 m H1. induction n as [| n Hrecn]. (* n=O *) simpl in |- *. rewrite <- (proj1 (Nat.le_0_r m) H1). apply H0. apply H1. (* n=(S n0) *) simpl in |- *. case (le_lt_eq_dec m (S n)). assumption. intro. cut (m <= n). intro. astepl (([0]:OF)[+]r m). apply plus_resp_less_both. apply H. apply le_n. apply Hrecn. intros. apply H. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. intros. apply H0. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. assumption. apply Nat.lt_succ_r. assumption. intros. rewrite e. astepl (r (S n)[+]([0]:OF)). apply plus_resp_less_both. apply H0. apply le_n. apply bound_tk1. intros. apply H. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. Qed. Lemma trick' : forall (n : nat) (r g : nat -> OF), (forall m : nat, m <= n -> g m[<][0]) -> (forall m : nat, m <= n -> g m[<]r m) -> forall m : nat, m <= n -> Hum g n[<]r m. Proof. intros n r g H H0 m H1. induction n as [| n Hrecn]. (* n=O *) simpl in |- *. rewrite <- (proj1 (Nat.le_0_r m) H1). apply H0. apply H1. (* n=(S n0) *) simpl in |- *. case (le_lt_eq_dec m (S n)). assumption. intro. cut (m <= n). intro. astepr (([0]:OF)[+]r m). apply plus_resp_less_both. apply H. apply le_n. apply Hrecn. intros. apply H. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. intros. apply H0. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. assumption. apply Nat.lt_succ_r. assumption. intro H2. rewrite H2. astepr (r (S n)[+]([0]:OF)). apply plus_resp_less_both. apply H0. apply le_n. apply bound_tk2. intros. apply H. apply Nat.le_trans with (m := n). assumption. apply Nat.le_succ_diag_r. Qed. Theorem up_bound_for_n_element : forall (n : nat) (r : nat -> OF), {b : OF | forall m : nat, m <= n -> r m[<]b}. Proof. intros. exists (Hum (fun p : nat => r p[^]2[-]r p[+]Two) n). intros. apply trick. intros. apply inequality2. intros. apply inequality1. assumption. Qed. Lemma low_bound_for_n_element : forall (n : nat) (r : nat -> OF), {l : OF | forall m : nat, m <= n -> l[<]r m}. Proof. intros. exists (Hum (fun p : nat => [--](r p[^]2)[-]r p[-]Two) n). intros. apply trick'. intros. apply inequality4. intros. apply inequality3. assumption. Qed. Definition saghf (r : nat -> OF) (n : nat) := let (N, _) := up_bound_for_n_element n r in N. Lemma Psaghf : forall (r : nat -> OF) (n m : nat), m <= n -> r m[<]saghf r n. Proof. intros r n. unfold saghf in |- *. elim up_bound_for_n_element; auto. Qed. Definition kaf (r : nat -> OF) (n : nat) := let (N, _) := low_bound_for_n_element n r in N. Lemma Pkaf : forall (r : nat -> OF) (n m : nat), m <= n -> kaf r n[<]r m. Proof. intros r n. unfold kaf in |- *. elim low_bound_for_n_element; auto. Qed. Hypothesis is_finite_P : {n : nat | {r : nat -> OF | forall y : OF, P y -> {m : nat | m <= n | r m[=]y}}}. Definition card := let (N, _) := is_finite_P in N. Lemma Pcard1 : {r : nat -> OF | forall y : OF, P y -> {m : nat | m <= card | r m[=]y}}. Proof. intros. unfold card in |- *. elim is_finite_P; auto. Defined. Definition seq := let (N, _) := Pcard1 in N. Definition Pseq1 := projT2 Pcard1. Lemma Pseq1_unfolded : forall y : OF, P y -> {m : nat | m <= card | seq m[=]y}. Proof. exact Pseq1. Qed. Definition indeks (y : OF) (H : P y) := let (N, _, _) := Pseq1_unfolded y H in N. Lemma Pindeks : forall (y : OF) (H : P y), indeks y H <= card /\ seq (indeks y H)[=]y. Proof. intros. unfold indeks in |- *. elim Pseq1_unfolded; auto. Qed. Hypothesis is_onto_seq_P : forall t : nat, t <= card -> P (seq t). Lemma P_is_inhabited : {x : OF | P x}. Proof. intros. exists (seq 0). apply is_onto_seq_P. apply Nat.le_0_l. Qed. (* Lemma bounded_quantifier:(N:nat;phi,psi:nat->Prop) ((m:nat)(le m N)->(phi m)\/(psi m))-> ((m:nat)(le m N)->(phi m))\/(Ex [j:nat](le j N)/\(psi j)). Proof. Intros. Induction N. Cut (phi O)\/(psi O). Intro. Case H0. Intros. Left. Intros. Rewrite <- (Nat.le_0_r m H2). Assumption. Intro. Right. Exists O. Split. Constructor. Assumption. Apply H. Constructor.*) (* n=(S n0) *) (* Case HrecN. Intros. Apply H. Apply Nat.le_trans with m:=N. Assumption. Apply Nat.le_succ_diag_r. Intro. Case (H (S N)). Apply le_n. Intros. Left. Intros. Case (le_lt_eq_dec m (S N)). Assumption. Intros. Apply H0. Apply (lt_n_Sm_le m N). Assumption. Intro. Rewrite e. Assumption. Intro. Right. Exists (S N). Split. Apply le_n. Assumption. Intro. Right. Case H0. Intro j. Intros. Exists j. Elim H1. Intros. Split. Apply Nat.le_trans with m:=N. Assumption. Apply Nat.le_succ_diag_r. Assumption. Qed. *) Lemma bounded_quantifier_informative : forall (N : nat) (phi psi : nat -> CProp), (forall m : nat, m <= N -> phi m or psi m) -> (forall m : nat, m <= N -> phi m) or {j : nat | Cle j N | psi j}. Proof. do 3 intro. intro H. induction N as [| N HrecN]. cut (phi 0 or psi 0). intro H0. case H0. intros. left. intros. rewrite (proj1 (Nat.le_0_r m) H1). assumption. intro. right. exists 0. constructor. assumption. apply H. constructor. (* n=(S n0) *) case HrecN. intros. apply H. apply Nat.le_trans with (m := N). assumption. apply Nat.le_succ_diag_r. intro. case (H (S N)). apply le_n. intros. left. intros. case (le_lt_eq_dec m (S N)). assumption. intros. apply p. apply (Nat.lt_succ_r m N). assumption. intro. rewrite e. assumption. intro. right. exists (S N). apply toCle. apply le_n. assumption. intro. right. case s. intro j. intros. exists j. apply toCle. apply Nat.le_trans with (m := N). apply Cle_to. assumption. apply Nat.le_succ_diag_r. assumption. Qed. Lemma bridges_lemma1a : l_u_b OF P. Proof. apply (lubp P P_is_inhabited). case is_finite_P. intro N. intros. case s. intro r. intro. exists (saghf r N). red in |- *. intros x H z H0. apply less_transitive_unfolded with (y := x). assumption. case (s0 x H). intro m. intros H1 H2. apply less_wdl with (x := r m). apply Psaghf. assumption. assumption. (* Start of Bridges' 3-line proof *) intros. cut ((forall k : nat, k <= card -> seq k[<]y) or {j : nat | P (seq j) | x[<]seq j}). intro H0. case H0. intro c. left. red in |- *. intros x0 H1 z H2. apply less_transitive_unfolded with (y := x0). assumption. elim (Pindeks x0 H1). intros. apply less_wdl with (x := seq (indeks x0 H1)). apply c. assumption. assumption. intro e. right. case e. intro j. intros H2 H3. exists (seq j). assumption. assumption. (* proof of the claim that we cut above *) case (bounded_quantifier_informative card) with (phi := fun k : nat => seq k[<]y) (psi := fun k : nat => x[<]seq k). intros. cut (x[<]seq m or seq m[<]y). intro H1. case H1. intro. right. assumption. intro. left. assumption. apply less_cotransitive_unfolded. assumption. intros. left. assumption. intro e. right. case e. intro j. intros. exists j. apply is_onto_seq_P. apply Cle_to. assumption. assumption. Qed. Hypothesis P_is_strongly_extensional : forall x y : OF, x[=]y -> P x -> P y. Lemma bridges_lemma1b : g_l_b OF P. Proof. intros. red in |- *. cut (l_u_b OF (fun x : OF => P [--]x)). intro H. red in H. case H. intro b. intros p. elim p. intros H0 H1. exists ([--]b). split. red in |- *. red in H0. intros x H2 z H3. case (less_cotransitive_unfolded OF z [--]b H3 x). trivial. intro. elim (less_irreflexive_unfolded _ b). apply H0 with (x := [--]x) (z := b). apply (P_is_strongly_extensional x [--][--]x). algebra. assumption. apply inv_cancel_less. astepl x. assumption. intros. case (H1 [--]c'). apply inv_cancel_less. astepr c'. assumption. intro s. intros H3. elim H3. intros. exists ([--]s). split. assumption. apply inv_cancel_less. astepr s. assumption. (* * * * * * * * *) apply (lubp (fun x : OF => P [--]x)). case P_is_inhabited. intro x. intro. exists ([--]x). apply (P_is_strongly_extensional x [--][--]x). algebra. assumption. case is_finite_P. intro N. intros. case s. intro r. intro. exists (saghf (fun n : nat => [--](r n)) N). red in |- *. intros x H z H0. apply less_transitive_unfolded with (y := x). assumption. case (s0 [--]x H). intro m. intros H1 H2. apply less_wdl with (x := [--](r m)). apply (Psaghf (fun m : nat => [--](r m))). assumption. rstepl (([0]:OF)[-]r m). rstepr (([0]:OF)[-][--]x). apply cg_minus_wd. apply eq_reflexive_unfolded. assumption. (* Start of Bridges' 3-line proof *) intros x y H. cut ((forall k : nat, k <= card -> [--](seq k)[<]y) or {j : nat | P (seq j) | x[<][--](seq j)}). intro H0. case H0. intro c. left. red in |- *. intros x0 H1 z H2. apply less_transitive_unfolded with (y := x0). assumption. elim (Pindeks [--]x0 H1). intros. apply less_wdl with (x := [--](seq (indeks [--]x0 H1))). apply c. assumption. rstepl (([0]:OF)[-]seq (indeks [--]x0 H1)). rstepr (([0]:OF)[-][--]x0). apply cg_minus_wd. apply eq_reflexive_unfolded. assumption. intro e. right. case e. intro j. intros H2 H3. exists ([--](seq j)). apply (P_is_strongly_extensional (seq j) [--][--](seq j)). algebra. assumption. assumption. (* proof of the claim that we cut above *) case (bounded_quantifier_informative card) with (phi := fun k : nat => [--](seq k)[<]y) (psi := fun k : nat => x[<][--](seq k)). intros. cut (x[<][--](seq m) or [--](seq m)[<]y). intro H1. case H1. intro. right. assumption. intro. left. assumption. apply less_cotransitive_unfolded. assumption. intros. left. assumption. intro e. right. case e. intro j. intros. exists j. apply is_onto_seq_P. apply Cle_to. assumption. assumption. Qed. End supremum. (*---------------------------------*) (*---------------------------------*) (*---------------------------------*) (*---------------------------------*) Section Every_Cauchy_Sequence_is_bounded. Definition seq2set (g : CauchySeq OF) (x : OF) : CProp := {n : nat | x[=]CS_seq _ g n}. Variable g : CauchySeq OF. Let g_ := CS_seq _ g. Let pg := CS_proof _ g. Let P (BOUND : nat) (x : OF) := {n : nat | n <= BOUND | x[=]g_ n}. Lemma fin_is_fin : forall BOUND : nat, {n : nat | {r : nat -> OF | forall y : OF, P BOUND y -> {m : nat | m <= n | r m[=]y}}}. Proof. intros. exists BOUND. exists g_. intros y H. red in H. case H. intro n. intros. exists n. assumption. apply eq_symmetric_unfolded. assumption. Defined. Lemma card_fin : forall BOUND : nat, card (P BOUND) (fin_is_fin BOUND) = BOUND. Proof. unfold card in |- *. unfold fin_is_fin in |- *. reflexivity. Qed. Lemma finite_seq : forall BOUND t : nat, seq (P BOUND) (fin_is_fin BOUND) t[=]g_ t. Proof. intros. unfold seq in |- *. unfold fin_is_fin in |- *. unfold Pcard1 in |- *. unfold Pcard1 in |- *. change (g_ t[=]g_ t) in |- *. apply eq_reflexive_unfolded. Qed. Lemma bridges_lemma2a : l_u_b OF (seq2set g). Proof. intros. apply (lubp (seq2set g)). (* it is inhabited *) exists (g_ 0). red in |- *. exists 0. apply eq_reflexive_unfolded. (* it is bounded above *) cut {N : nat | forall m : nat, N <= m -> AbsSmall [1] (g_ m[-]g_ N)}. intro H. case H. intro N. intro. exists (saghf g_ N[+][1]). red in |- *. intros x H0 y H1. red in H0. case H0. intro n. intro c. apply less_transitive_unfolded with (y := x). assumption. apply less_wdl with (x := g_ n). case (le_ge_dec N n). intro H2. apply leEq_less_trans with (y := g_ N[+][1]). apply shift_leEq_plus'. cut (AbsSmall [1] (g_ n[-]g_ N)). intro. elim H3. intros H4 H5. assumption. apply a. assumption. apply plus_resp_less_rht. apply Psaghf. apply le_n. intro H2. apply less_transitive_unfolded with (y := saghf g_ N). apply Psaghf. assumption. apply less_plusOne. apply eq_symmetric_unfolded. exact c. apply (pg [1]). apply pos_one. (* This is the proof of Proposition 1 of Bridges *) intros a b. intro. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((b[-]a) [/]TwoNZ) (g_ m[-]g_ N)}. intro H0. case H0. intro N. intros. cut (l_u_b OF (fun x : OF => {n : nat | n <= N | x[=]g_ n})). intro H1. red in H1. case H1. intro sigma. intros p. elim p. intros. cut (a[<](a[+]b) [/]TwoNZ). intro H2. case (less_cotransitive_unfolded _ a ((a[+]b) [/]TwoNZ) H2 sigma). intro c. right. case (b0 a c). intro xj. intro H5. exists xj. elim H5. intros H6 H7. case H6. intro j. intros H9 H10. red in |- *. exists j. simpl in |- *. assumption. elim H5. intros. assumption. intro. left. red in |- *. intros x H3 z H4. red in H3. case H3. intro n. intros. case (le_ge_dec N n). intro H7. rstepr (a[+](b[-]a)). apply less_transitive_unfolded with (y := sigma[+](b[-]a) [/]TwoNZ). apply shift_less_plus. apply (a1 (g_ N)). exists N. apply le_n. apply eq_reflexive_unfolded. apply shift_minus_less. apply less_leEq_trans with (y := x). assumption. apply leEq_wdl with (x := g_ n). apply shift_leEq_plus'. cut (AbsSmall ((b[-]a) [/]TwoNZ) (g_ n[-]g_ N)). intro H8. elim H8. intros H9 H10. assumption. apply a0. assumption. apply eq_symmetric_unfolded. assumption. apply shift_plus_less. rstepr ((a[+]b) [/]TwoNZ). assumption. intro. rstepr (a[+](b[-]a)). apply less_transitive_unfolded with (y := sigma[+](b[-]a) [/]TwoNZ). apply shift_less_plus. apply (a1 x). exists n. assumption. assumption. apply shift_minus_less. apply less_transitive_unfolded with (y := x). assumption. apply shift_less_plus'. astepl ([0]:OF). apply pos_div_two. apply shift_zero_less_minus. assumption. apply shift_plus_less. rstepr ((a[+]b) [/]TwoNZ). assumption. apply plus_cancel_less with (z := [--]a). rstepl ([0]:OF). rstepr ((b[-]a) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. apply bridges_lemma1a with (P := P N) (is_finite_P := fin_is_fin N). intros. unfold P in |- *. exists t. rewrite <- (card_fin N). assumption. apply (finite_seq N). apply (pg ((b[-]a) [/]TwoNZ)). apply pos_div_two. apply shift_zero_less_minus. assumption. Qed. Definition sup := let (N, _) := bridges_lemma2a in N. Definition Psup := projT2 bridges_lemma2a. Lemma Psup_proj1 : is_upper_bound OF (seq2set g) sup. Proof. unfold sup in |- *. elim Psup. auto. Qed. Lemma Psup_unfolded1 : forall x : OF, seq2set g x -> forall z : OF, z[<]x -> z[<]sup. Proof. change (is_upper_bound OF (seq2set g) sup) in |- *. exact Psup_proj1. Qed. Lemma Psup_unfolded2 : forall b' : OF, b'[<]sup -> {s : OF | seq2set g s | b'[<]s}. Proof. unfold sup in |- *. elim Psup. simpl in |- *. intros. rename X into H. elim (b b' H); intros x p; elim p; exists x; auto. Qed. Lemma bridges_lemma2b : g_l_b OF (seq2set g). Proof. intros. apply (glbp (seq2set g)). (* it is inhabited *) exists (g_ 0). red in |- *. exists 0. apply eq_reflexive_unfolded. (* it is bounded below *) cut {N : nat | forall m : nat, N <= m -> AbsSmall [1] (g_ m[-]g_ N)}. intro H. case H. intro N. intros. exists (kaf g_ N[-][1]). red in |- *. intros x H0 z H1. case H0. intro n. intros c. apply less_wdr with (y := g_ n). case (le_ge_dec N n). intro. apply less_leEq_trans with (y := g_ N[-][1]). apply less_transitive_unfolded with (y := kaf g_ N[-][1]). assumption. apply minus_resp_less. apply Pkaf. apply le_n. apply plus_cancel_leEq_rht with (z := [--](g_ N)). rstepl ([--]([1]:OF)). astepr (g_ n[-]g_ N). cut (AbsSmall [1] (g_ n[-]g_ N)). intro. elim H2. intros. assumption. apply a. assumption. intro. apply less_transitive_unfolded with (y := kaf g_ N[-][1]). assumption. apply less_transitive_unfolded with (y := kaf g_ N). apply plus_cancel_less with (z := [1]:OF). astepl (kaf g_ N). apply less_plusOne. apply Pkaf. assumption. apply eq_symmetric_unfolded. exact c. (* Here we are using ex_informative *) apply (pg [1]). apply pos_one. (* it is strongly extensional *) intros x y H H0. red in |- *. red in H0. case H0. intro n. intros. exists n. apply eq_transitive_unfolded with (y := x). apply eq_symmetric_unfolded. assumption. assumption. (* This is the proof of Proposition 1 of Bridges for infimum *) intros a b. intro. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((b[-]a) [/]TwoNZ) (g_ m[-]g_ N)}. intro H0. case H0. intro N. intros. cut (g_l_b OF (fun x : OF => {n : nat | n <= N | x[=]g_ n})). intro H1. red in H1. case H1. intro tau. intros p. elim p. intros. cut ((a[+]b) [/]TwoNZ[<]b). intro H2. case (less_cotransitive_unfolded _ ((a[+]b) [/]TwoNZ) b H2 tau). intro. left. red in |- *. intros x H3 z H4. red in H3. case H3. intro n. intros H7. case (le_ge_dec N n). intro. red in a1. apply less_wdr with (y := g_ n). apply less_leEq_trans with (y := g_ N[-](b[-]a) [/]TwoNZ). apply shift_less_minus. apply (a1 (g_ N)). exists N. apply le_n. apply eq_reflexive_unfolded. apply less_transitive_unfolded with (y := (a[+]b) [/]TwoNZ). apply shift_plus_less. rstepr a. assumption. assumption. cut (AbsSmall ((b[-]a) [/]TwoNZ) (g_ n[-]g_ N)). intro H8. elim H8. intros H9 H10. apply shift_minus_leEq. apply shift_leEq_plus'. apply inv_cancel_leEq. rstepr (g_ n[-]g_ N). assumption. apply a0. assumption. apply eq_symmetric_unfolded. assumption. intro. apply less_transitive_unfolded with (y := z[+](b[-]a) [/]TwoNZ). apply plus_cancel_less with (z := [--]z). rstepl ([0]:OF). rstepr ((b[-]a) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. apply (a1 x). exists n. assumption. assumption. apply less_transitive_unfolded with (y := (a[+]b) [/]TwoNZ). apply shift_plus_less. rstepr a. assumption. assumption. right. case (b0 b c). intro xj. intro p0. exists xj. elim p0. intros H6 H7. case H6. intro j. intros H9 H10. red in |- *. exists j. simpl in |- *. assumption. elim p0. intros. assumption. apply plus_cancel_less with (z := [--]((a[+]b) [/]TwoNZ)). rstepl ([0]:OF). rstepr ((b[-]a) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. apply bridges_lemma1b with (P := P N) (is_finite_P := fin_is_fin N). intros. unfold P in |- *. exists t. rewrite <- (card_fin N). assumption. apply (finite_seq N). unfold P in |- *. intros x H1 z H2. case H2. intro n. intros. exists n. intros. assumption. apply eq_transitive_unfolded with (y := x). apply eq_symmetric_unfolded. assumption. assumption. apply (pg ((b[-]a) [/]TwoNZ)). apply pos_div_two. apply shift_zero_less_minus. assumption. Qed. Definition inf := let (N, _) := bridges_lemma2b in N. Definition Pinf := ProjT2 bridges_lemma2b. Lemma Pinf_proj1 : is_lower_bound OF (seq2set g) inf. Proof. unfold inf in |- *. elim Pinf. auto. Qed. Lemma Pinf_unfolded1 : forall x : OF, seq2set g x -> forall z : OF, z[<]inf -> z[<]x. Proof. change (is_lower_bound OF (seq2set g) inf) in |- *. exact Pinf_proj1. Qed. Lemma Pinf_unfolded2 : forall c' : OF, inf[<]c' -> {s : OF | seq2set g s | s[<]c'}. Proof. unfold inf in |- *. elim Pinf. simpl in |- *. intros. rename X into H. elim (b c' H); intros x p; elim p; exists x; auto. Qed. (* I tried very much not to mention this lemma! *) Lemma sup_leEq : forall n : nat, g_ n[<=]sup. Proof. intros. rewrite -> leEq_def; intro. apply (less_irreflexive_unfolded _ sup). apply (Psup_unfolded1 (g_ n)). red in |- *. exists n. apply eq_reflexive_unfolded. assumption. Qed. Lemma inf_geEq : forall n : nat, inf[<=]g_ n. Proof. intros. rewrite -> leEq_def; intro. apply (less_irreflexive_unfolded _ (g_ n)). apply (Pinf_unfolded1 (g_ n)). red in |- *. exists n. apply eq_reflexive_unfolded. assumption. Qed. Lemma tail_is_Cauchy : forall n : nat, Cauchy_prop (fun m : nat => g_ (n + m)). Proof. intros. red in |- *. intros. case (pg (e [/]TwoNZ)). apply pos_div_two. assumption. intro N. intros. exists N. intros. rstepr (g_ (n + m)[-]g_ N[+](g_ N[-]g_ (n + N))). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply a. apply Nat.le_trans with (m := m). assumption. rewrite Nat.add_comm; apply Nat.le_add_r. apply AbsSmall_minus. apply a. rewrite Nat.add_comm; apply Nat.le_add_r. Qed. Definition tail_seq (n : nat) := Build_CauchySeq OF (fun m : nat => g_ (n + m)) (tail_is_Cauchy n). End Every_Cauchy_Sequence_is_bounded. Variable g : CauchySeq OF. Let g_ := CS_seq _ g. Let pg := CS_proof _ g. Let sup_tail (n : nat) := sup (tail_seq g n). Lemma sup_tail_leEq : forall N m : nat, N <= m -> g_ m[<=]sup_tail N. Proof. intros. unfold sup_tail in |- *. case (le_witness_informative N m H). intro k. intro. apply leEq_wdl with (x := tail_seq g N k). apply sup_leEq. simpl in |- *. rewrite e. apply eq_reflexive_unfolded. Qed. Lemma sup_tail_is_Cauchy : Cauchy_prop (fun m : nat => sup_tail m). Proof. red in |- *. intros. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (g_ m[-]g_ N)}. intros H0. case H0. intro N. intros. exists N. intros. split. (* I *) apply inv_cancel_leEq. rstepl (sup_tail N[-]sup_tail m). rstepr e. rewrite -> leEq_def; intro. apply (less_irreflexive_unfolded _ e). case (Psup_unfolded2 (tail_seq g N) (sup_tail m[+]e)). change (sup_tail m[+]e[<]sup_tail N) in |- *. apply shift_plus_less'. assumption. intro xj. intros H4 H5. red in H4. case H4. intro j. intros. apply less_leEq_trans with (y := g_ (N + j)[-]g_ m). apply shift_less_minus. apply shift_plus_less'. apply leEq_less_trans with (y := sup_tail m). apply sup_tail_leEq. apply le_n. apply shift_less_minus. apply less_wdr with (y := xj). assumption. assumption. cut (AbsSmall e (g_ (N + j)[-]g_ m)). intro H7. elim H7. intros H8 H9. assumption. rstepr (g_ (N + j)[-]g_ N[+](g_ N[-]g_ m)). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply a. apply Nat.le_add_r. apply AbsSmall_minus. apply a. assumption. (* II *) apply less_leEq. apply leEq_less_trans with (y := e [/]TwoNZ). rewrite -> leEq_def. intro. apply (less_irreflexive_unfolded _ (e [/]TwoNZ)). case (Psup_unfolded2 (tail_seq g m) (sup_tail N[+]e [/]TwoNZ)). change (sup_tail N[+]e [/]TwoNZ[<]sup_tail m) in |- *. apply shift_plus_less'. assumption. intro xj. intros H4 H5. red in H4. case H4. intro j. intros. apply less_leEq_trans with (y := g_ (m + j)[-]g_ N). apply shift_less_minus. apply shift_plus_less'. apply leEq_less_trans with (y := sup_tail N). apply sup_tail_leEq. apply le_n. apply shift_less_minus. apply less_wdr with (y := xj). assumption. assumption. cut (AbsSmall (e [/]TwoNZ) (g_ (m + j)[-]g_ N)). intro H7. elim H7. intros. assumption. apply a. apply Nat.le_trans with (m := m). assumption. apply Nat.le_add_r. apply pos_div_two'. assumption. apply pg. apply pos_div_two. assumption. Qed. Definition sup_tail_as_Cauchy := Build_CauchySeq OF (fun m : nat => sup_tail m) sup_tail_is_Cauchy. Let L := inf sup_tail_as_Cauchy. Lemma sup_tail_decrease : forall m n : nat, m <= n -> sup_tail n[<=]sup_tail m. Proof. intros. rewrite -> leEq_def; intro. case (Psup_unfolded2 (tail_seq g n) (sup_tail m)). assumption. intro xj. intros H2 H3. red in H2. case H2. intro j. intros. apply (less_irreflexive_unfolded _ xj). apply leEq_less_trans with (y := sup_tail m). apply leEq_wdl with (x := CS_seq OF (tail_seq g n) j). simpl in |- *. apply sup_tail_leEq. apply Nat.le_trans with (m := n). assumption. apply Nat.le_add_r. apply eq_symmetric_unfolded. assumption. assumption. Qed. Lemma L_less_sup_n : forall n : nat, L[<=]sup_tail n. Proof. intros. unfold L in |- *. change (inf sup_tail_as_Cauchy[<=]CS_seq OF sup_tail_as_Cauchy n) in |- *. apply inf_geEq. Qed. Lemma Psup_unfolded2_informative : forall (h : CauchySeq OF) (b' : OF), b'[<]sup h -> {s : OF | seq2set h s | b'[<]s}. Proof. intros. apply Psup_unfolded2. assumption. Qed. Lemma Pinf_unfolded2_informative : forall (h : CauchySeq OF) (c' : OF), inf h[<]c' -> {s : OF | seq2set h s | s[<]c'}. Proof. intros. apply Pinf_unfolded2. assumption. Qed. Lemma convergent_subseq : forall k : nat, {N_k : nat | k <= N_k | AbsSmall (one_div_succ k) (g_ N_k[-]L)}. Proof. intros. case (Pinf_unfolded2_informative sup_tail_as_Cauchy (L[+]one_div_succ k)). change (L[<]L[+]one_div_succ k) in |- *. apply shift_less_plus'. rstepl ([0]:OF). apply one_div_succ_pos. intro sN. intros. red in s. case s. intro N. intros c0. case (Psup_unfolded2_informative (tail_seq g (k + N)) (L[-]one_div_succ k)). apply less_leEq_trans with (y := L). apply shift_minus_less. apply shift_less_plus'. rstepl ([0]:OF). apply one_div_succ_pos. change (L[<=]sup_tail (k + N)) in |- *. apply L_less_sup_n. intro xj. intros. case s0. intro j. intros. exists (k + N + j). apply Nat.le_trans with (m := k + N). apply Nat.le_add_r. apply Nat.le_add_r. split. apply shift_leEq_minus. rstepl (L[-]one_div_succ k). apply leEq_wdr with (y := xj). apply less_leEq; assumption. assumption. apply shift_minus_leEq. apply leEq_transitive with (y := sN). change (CS_seq OF (tail_seq g (k + N)) j[<=]sN) in |- *. apply leEq_transitive with (y := sup (tail_seq g (k + N))). apply sup_leEq. apply leEq_wdr with (y := sup (tail_seq g N)). change (sup_tail (k + N)[<=]sup_tail N) in |- *. apply sup_tail_decrease. rewrite Nat.add_comm; apply Nat.le_add_r. apply eq_symmetric_unfolded. assumption. apply less_leEq. astepr (L[+]one_div_succ k); auto. Qed. (* very elegant proof almost as short as text version! *) Theorem lubp_gives_Cauchy : SeqLimit g L. Proof. red in |- *. intros e H. case (is_Archimedes' ((Two[/] e[//]Greater_imp_ap _ e [0] H)[-][1])). intro k. intros. case (pg (e [/]FourNZ)). apply div_resp_pos. apply pos_four. assumption. intro N1. intros. case (convergent_subseq (N1 + k)). intro Nk. intros. elim a0. intros. exists Nk. intros. change (AbsSmall e (g_ m[-]L)) in |- *. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). rstepr (g_ m[-]g_ Nk[+](g_ Nk[-]L)). apply AbsSmall_plus. rstepl (e [/]FourNZ[+]e [/]FourNZ). rstepr (g_ m[-]g_ N1[+](g_ N1[-]g_ Nk)). apply AbsSmall_plus. apply a. apply Nat.le_trans with (m := Nk). apply Nat.le_trans with (m := N1 + k). apply Nat.le_add_r. assumption. assumption. apply AbsSmall_minus. apply a. apply Nat.le_trans with (m := N1 + k). apply Nat.le_add_r. assumption. apply AbsSmall_leEq_trans with (e1 := one_div_succ (R:=OF) (N1 + k)). unfold one_div_succ in |- *. unfold Snring in |- *. apply shift_div_leEq. apply pos_nring_S. cut (e [/]TwoNZ[#][0]). intro H3. apply shift_leEq_mult' with H3. apply pos_div_two. assumption. rstepl (Two[/] e[//]Greater_imp_ap _ e [0] H). change ((Two[/] e[//]Greater_imp_ap OF e [0] H)[<=]nring (N1 + k)[+][1]) in |- *. apply shift_leEq_plus. apply leEq_transitive with (y := nring (R:=OF) k). apply less_leEq; assumption. apply nring_leEq. rewrite Nat.add_comm; apply Nat.le_add_r. apply Greater_imp_ap. apply pos_div_two. assumption. assumption. Qed. End proofs_in_TCS. Definition Bridges_R_is_CReals := Build_is_CReals OF (fun g : CauchySeq OF => inf (sup_tail_as_Cauchy g)) lubp_gives_Cauchy is_Archimedes. Definition Bridges_R_as_CReals := Build_CReals OF (fun g : CauchySeq OF => inf (sup_tail_as_Cauchy g)) Bridges_R_is_CReals. End bridges_axioms_imply_ours. (* end hide *) (** remove printing Q *) corn-8.20.0/reals/CMetricFields.v000066400000000000000000000111061473720167500165270ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.CReals1. Set Nested Proofs Allowed. Section CMetric_Fields. (** * Metric Fields *) Record is_CMetricField (F : CField) (abs : CSetoid_fun F IR) : Prop := {ax_abs_gt_zero : forall x : F, [0] [<=] abs x; ax_abs_resp_mult : forall x y : F, abs (x[*]y) [=] abs x[*]abs y; ax_abs_triangle : forall x y : F, abs (x[+]y) [<=] abs x[+]abs y}. Record CMetricField : Type := {cmf_crr :> CField; cmf_abs : CSetoid_fun cmf_crr IR; cmf_proof : is_CMetricField cmf_crr cmf_abs}. End CMetric_Fields. Notation MAbs := (cmf_abs _). Section basics. Lemma MAbs_one : forall F : CMetricField, {MAbs ([1]:F) [=] [0]} + {MAbs ([1]:F) [=] [1]}. Proof. intro F. apply square_id. astepl (cmf_abs F [1][*]cmf_abs F [1]). astepl (cmf_abs F ([1][*][1])). astepl (cmf_abs F [1]). apply eq_reflexive. apply ax_abs_resp_mult. apply cmf_proof. Qed. Lemma MAbs_one_recip_one : forall F : CMetricField, MAbs ([1]:F) [=] MAbs ( [--][1]:F). Proof. intro F. cut ({cmf_abs F ([1]:F) [=] [0]} + {cmf_abs F ([1]:F) [=] [1]}). intro H. elim H. intro H2. astepl ZeroR. astepr (cmf_abs F ( [--][1][*][1])). astepr (cmf_abs F [--][1][*]cmf_abs F [1]). astepr (cmf_abs F [--][1][*][0]). astepr ZeroR. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply ax_abs_resp_mult. apply cmf_proof. intro H1. cut (cmf_abs F [--][1] [=] cmf_abs F [1] or cmf_abs F [--][1] [=] [--] (cmf_abs F [1])). intro H2. elim H2. intro H3. apply eq_symmetric_unfolded. exact H3. intro H3. (* begin hide *) Lemma Hulp : forall F : CMetricField, cmf_abs F [1] [=] [1] -> cmf_abs F [--][1] [=] [--] (cmf_abs F [1]) -> False. intros F G H. set (H0 := ax_abs_gt_zero) in *. generalize H0. intro H1. set (H2 := H1 F (cmf_abs F) (cmf_proof F) [--] ([1]:F)) in *. rewrite -> leEq_def in H2. apply H2. astepl ( [--] (cmf_abs F [1])). astepl ( [--]OneR). apply plus_cancel_less with OneR. astepl ZeroR. astepr OneR. apply pos_one. Qed. (* begin hide *) simpl in |- *. Proof. set (H4 := Hulp F H1 H3) in *. intuition. apply cond_square_eq. apply ap_symmetric_unfolded. apply less_imp_ap. apply pos_two. astepl OneR. algebra. astepl (cmf_abs F [--][1][*]cmf_abs F [--][1]). astepl (cmf_abs F ( [--][1][*][--][1])). 2: apply ax_abs_resp_mult. 2: apply cmf_proof. astepl (cmf_abs F [1]). 2: apply csf_wd. 2: astepl ( [--] (([1]:F) [*][--][1])). 2: astepl ( [--] ( [--] ([1]:F) [*][1])). 2: astepl ( [--][--] (([1]:F) [*][1])). 2: astepl (([1]:F) [*][1]). 2: algebra. astepl (cmf_abs F ([1][*][1])). astepl (cmf_abs F [1][*]cmf_abs F [1]). 2: apply eq_symmetric_unfolded. 2: apply ax_abs_resp_mult. 2: apply cmf_proof. astepr (cmf_abs F [1][*]cmf_abs F [1]). apply eq_reflexive_unfolded. rational. apply MAbs_one. Qed. (* end hide *) End basics. Section CMetric_Field_Cauchy. Variable F : CMetricField. (** %\begin{convention}% Let [F:CMetricField]. %\end{convention}% *) Definition MCauchy_prop (g : nat -> F) : CProp := forall e : IR, [0] [<] e -> {N : nat | forall m, N <= m -> MAbs (g m[-]g N) [<=] e}. Record MCauchySeq : Type := {MCS_seq :> nat -> F; MCS_proof : MCauchy_prop MCS_seq}. Definition MseqLimit (seq : nat -> F) (lim : F) : CProp := forall e : IR, [0] [<] e -> {N : nat | forall m, N <= m -> MAbs (seq m[-]lim) [<=] e}. Definition is_MCauchyCompl (lim : MCauchySeq -> F) : CProp := forall (s : MCauchySeq), MseqLimit s (lim s). End CMetric_Field_Cauchy. Arguments MseqLimit [F]. corn-8.20.0/reals/CPoly_Contin.v000066400000000000000000000104621473720167500164160ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** * Continuity of polynomials *) Require Export CoRN.reals.RealFuncts. Lemma plus_op_contin : forall f g h : CSetoid_un_op IR, contin f -> contin g -> (forall x, f x[+]g x [=] h x) -> contin h. Proof. intros f g h f_contin g_contin f_g_h. unfold contin in f_contin. unfold continAt in f_contin. unfold funLim in f_contin. unfold contin in g_contin. unfold continAt in g_contin. unfold funLim in g_contin. unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *. intros x e H. elim (plus_contin _ (f x) (g x) e H). intro b. intros H0 H1. elim H1. clear H1. intro c. intros H1 H2. elim (f_contin x b H0). clear f_contin. intro d'. intros H3 H4. elim (g_contin x c H1). clear g_contin. intro d''. intros H5 H6. exists (Min d' d''). apply less_Min; auto. intro x'. intros H10. astepr (f x[+]g x[-](f x'[+]g x')). apply H2. apply H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft. apply H6. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht. Qed. Lemma mult_op_contin : forall f g h : CSetoid_un_op IR, contin f -> contin g -> (forall x, f x[*]g x [=] h x) -> contin h. Proof. intros f g h f_contin g_contin f_g_h. unfold contin in f_contin. unfold continAt in f_contin. unfold funLim in f_contin. unfold contin in g_contin. unfold continAt in g_contin. unfold funLim in g_contin. unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *. intros x e H. elim (mult_contin _ (f x) (g x) e H). intro b. intros H0 H1. elim H1. clear H1. intro c. intros H1 H2. elim (f_contin x b H0). clear f_contin. intro d'. intros H3 H4. elim (g_contin x c H1). clear g_contin. intro d''. intros H5 H6. exists (Min d' d''). apply less_Min; auto. intro x'. intros. astepr (f x[*]g x[-]f x'[*]g x'). apply H2. apply H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft. apply H6. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht. Qed. Lemma linear_op_contin : forall (f g : CSetoid_un_op IR) a, contin f -> (forall x, x[*]f x[+]a [=] g x) -> contin g. Proof. intros f g a f_contin f_g. unfold contin in f_contin. unfold continAt in f_contin. unfold funLim in f_contin. unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *. intros. elim (mult_contin _ x (f x) e). intro d'. intros H0 H1. elim H1. clear H1. intro c. intros H1 H2. elim (f_contin x c). clear f_contin. intro d''. intros H3 H4. exists (Min d' d''). apply less_Min; auto. intro x'. intros H8. astepr (x[*]f x[+]a[-](x'[*]f x'[+]a)). rstepr (x[*]f x[-]x'[*]f x'). apply H2. clear H2. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_lft. apply H4. clear H4. apply AbsSmall_leEq_trans with (Min d' d''); auto. apply Min_leEq_rht. auto. auto. Qed. Lemma cpoly_op_contin : forall g : cpoly IR, contin (cpoly_csetoid_op _ g). Proof. intro g. elim g. unfold contin in |- *. unfold continAt in |- *. unfold funLim in |- *. intros. exists OneR. apply pos_one. intros. simpl in |- *. unfold AbsSmall in |- *. split; apply less_leEq. rstepr ([--]ZeroR). apply inv_resp_less. auto. astepl ZeroR. auto. intros a f. intros. apply linear_op_contin with (cpoly_csetoid_op _ f) a. auto. intros. simpl in |- *. rational. Qed. corn-8.20.0/reals/CReals.v000066400000000000000000000037671473720167500152410ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Lim %\ensuremath{\lim}% *) Require Export CoRN.algebra.COrdCauchy. (** * Definition of the notion of reals The reals are defined as a Cauchy-closed Archimedean constructive ordered field in which we have a maximum function. The maximum function is definable, using countable choice, but in a rather tricky way. Cauchy completeness is stated by assuming a function [lim] that returns a real number for every Cauchy sequence together with a proof that this number is the limit. *) (* Begin_SpecReals *) Record is_CReals (R : COrdField) (lim : CauchySeq R -> R) : CProp := {ax_Lim : forall s : CauchySeq R, SeqLimit s (lim s); ax_Arch : forall x : R, {n : nat | x [<=] nring n}}. Record CReals : Type := {crl_crr :> COrdField; crl_lim : CauchySeq crl_crr -> crl_crr; crl_proof : is_CReals crl_crr crl_lim}. (* End_SpecReals *) Definition Lim : forall IR : CReals, CauchySeq IR -> IR := crl_lim. Arguments Lim [IR]. corn-8.20.0/reals/CReals1.v000066400000000000000000000360141473720167500153110ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.Max_AbsIR. Require Export CoRN.algebra.Expon. Require Export CoRN.algebra.CPoly_ApZero. Section More_Cauchy_Props. (** ** Miscellaneous *** More properties of Cauchy sequences We will now define some special Cauchy sequences and prove some more useful properties about them. The sequence defined by $x_n=\frac2{n+1}$#x(n)=2/(n+1)#. *) Lemma twice_inv_seq_Lim : SeqLimit (R:=IR) (fun n => Two[*]one_div_succ n) [0]. red in |- *; fold (Cauchy_Lim_prop2 (fun n : nat => Two[*]one_div_succ n) [0]) in |- *. Proof. apply Cauchy_Lim_prop3_prop2. red in |- *; intro. exists (2 * S k); intros. astepr ((Two:IR) [*]one_div_succ m). apply AbsIR_imp_AbsSmall. apply leEq_wdl with ((Two:IR) [*]one_div_succ m). 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. astepl (one_div_succ (R:=IR) m[*]Two). unfold one_div_succ in |- *; simpl in |- *; fold (Two:IR) in |- *. apply shift_mult_leEq with (two_ap_zero IR). apply pos_two. unfold Snring in |- *. rstepr ([1][/] nring (S k) [*]Two[//] mult_resp_ap_zero _ _ _ (nring_ap_zero _ (S k) (sym_not_eq (O_S k))) (two_ap_zero IR)). apply recip_resp_leEq. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive. apply pos_nring_S. apply pos_two. astepl ((Two:IR) [*]nring (S k)). apply leEq_transitive with (nring (R:=IR) m). apply leEq_wdl with (nring (R:=IR) (2 * S k)). apply nring_leEq. assumption. apply nring_comm_mult. simpl in |- *; astepl (nring (R:=IR) m[+][0]); apply plus_resp_leEq_lft; apply less_leEq; apply pos_one. astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive. apply less_leEq; apply pos_two. apply less_leEq; apply one_div_succ_pos. Qed. Definition twice_inv_seq : CauchySeq IR. Proof. apply Build_CauchySeq with (fun n : nat => Two[*]one_div_succ (R:=IR) n). apply Cauchy_prop2_prop. red in |- *; exists ZeroR. red in |- *; fold (SeqLimit (fun n : nat => Two[*]one_div_succ (R:=IR) n) [0]) in |- *. apply twice_inv_seq_Lim. Defined. (** Next, we prove that the sequence of absolute values of a Cauchy sequence is also Cauchy. *) Lemma Cauchy_Lim_abs : forall seq y, Cauchy_Lim_prop2 seq y -> Cauchy_Lim_prop2 (fun n => AbsIR (seq n)) (AbsIR y). Proof. intros seq y H. red in |- *; red in H. intros eps He. elim (H eps He); clear H. intros N HN. exists N; intros. apply AbsIR_imp_AbsSmall. cut (AbsIR (seq m[-]y) [<=] eps). intro. 2: apply AbsSmall_imp_AbsIR; apply HN; assumption. cut (seq m[-]y [<=] eps). 2: eapply leEq_transitive; [ apply leEq_AbsIR | apply H0 ]. intro. cut (y[-]seq m [<=] eps). 2: eapply leEq_transitive; [ apply leEq_AbsIR | eapply leEq_wdl; [ apply H0 | apply AbsIR_minus ] ]. intro. simpl in |- *; unfold ABSIR in |- *. apply Max_leEq. apply shift_minus_leEq. apply Max_leEq. apply shift_leEq_plus'. apply leEq_transitive with y. apply shift_minus_leEq; apply shift_leEq_plus'; assumption. apply lft_leEq_Max. apply shift_leEq_plus'. apply leEq_transitive with ( [--]y). apply shift_minus_leEq; apply shift_leEq_plus'. rstepl (y[-]seq m). assumption. apply rht_leEq_Max. astepr ( [--][--]eps); apply inv_resp_leEq. apply shift_leEq_minus; apply shift_plus_leEq'. apply leEq_wdr with (Max (seq m) [--] (seq m) [+]eps). apply Max_leEq. apply leEq_transitive with (seq m[+]eps). apply shift_leEq_plus'; assumption. apply plus_resp_leEq. apply lft_leEq_Max. apply leEq_transitive with ( [--] (seq m) [+]eps). apply shift_leEq_plus'; rstepl (seq m[-]y); assumption. apply plus_resp_leEq. apply rht_leEq_Max. unfold cg_minus in |- *. algebra. Qed. Lemma Cauchy_abs : forall seq : CauchySeq IR, Cauchy_prop (fun n => AbsIR (seq n)). Proof. intro. apply Cauchy_prop2_prop. exists (AbsIR (Lim seq)). apply Cauchy_Lim_abs. apply Cauchy_complete. Qed. Lemma Lim_abs : forall seq : CauchySeq IR, Lim (Build_CauchySeq _ _ (Cauchy_abs seq)) [=] AbsIR (Lim seq). Proof. intros. apply eq_symmetric_unfolded; apply Limits_unique. simpl in |- *; apply Cauchy_Lim_abs. apply Cauchy_complete. Qed. Lemma CS_seq_bounded' : forall seq : CauchySeqR, {K : IR | [0] [<] K | forall m : nat, AbsSmall K (seq m)}. Proof. unfold CauchySeqR in |- *. intros. assert (X0 : {K : IR | [0] [<] K | {N : nat | forall m, N <= m -> AbsSmall K (seq m)}}). apply CS_seq_bounded; auto. apply (CS_proof _ seq). destruct X0 as [K1 K1_pos H1]. destruct H1 as [N H1]. exists (Max K1 (SeqBound0 seq N)). apply less_leEq_trans with K1; auto. apply lft_leEq_MAX. intros. elim (Nat.le_gt_cases N m). intros. assert (AbsSmall (R:=IR) K1 (seq m)). apply H1. auto. apply AbsSmall_leEq_trans with K1; auto. apply lft_leEq_MAX. intros. apply AbsSmall_leEq_trans with (SeqBound0 seq N). apply rht_leEq_MAX. apply AbsSmall_leEq_trans with (AbsIR (seq m)). apply SeqBound0_greater; auto. apply AbsIR_imp_AbsSmall. apply leEq_reflexive. Qed. End More_Cauchy_Props. Section Subsequences. (** *** Subsequences We will now examine (although without formalizing it) the concept of subsequence and some of its properties. %\begin{convention}% Let [seq1,seq2:nat->IR]. %\end{convention}% In order for [seq1] to be a subsequence of [seq2], there must be an increasing function [f] growing to infinity such that [forall (n :nat), (seq1 n) [=] (seq2 (f n))]. We assume [f] to be such a function. Finally, for some of our results it is important to assume that [seq2] is monotonous. *) Variables seq1 seq2 : nat -> IR. Variable f : nat -> nat. Hypothesis monF : forall m n : nat, m <= n -> f m <= f n. Hypothesis crescF : forall n : nat, {m : nat | n < m /\ f n < f m}. Hypothesis subseq : forall n : nat, seq1 n [=] seq2 (f n). Hypothesis mon_seq2 : (forall m n, m <= n -> seq2 m [<=] seq2 n) \/ (forall m n, m <= n -> seq2 n [<=] seq2 m). Lemma unbnd_f : forall m, {n : nat | m < f n}. Proof. simple induction m. elim (crescF 0). intros n Hn. exists n. inversion_clear Hn. apply Nat.le_lt_trans with (f 0); auto with arith. intros n H. elim H; clear H; intros n' Hn'. elim (crescF n'). intros i Hi; elim Hi; clear Hi; intros Hi Hi'. exists i. apply Nat.le_lt_trans with (f n'); auto. Qed. (* begin hide *) Let mon_F' : forall m n : nat, f m < f n -> m < n. Proof. intros. cut (~ n <= m). intro; apply not_ge; auto. intro. cut (f n <= f m). apply Nat.lt_nge; auto. apply monF; assumption. Qed. (* end hide *) Lemma conv_subseq_imp_conv_seq : Cauchy_prop seq1 -> Cauchy_prop seq2. Proof. intro H. red in |- *; red in H. intros e H0. elim (H e H0). intros N HN. exists (f N). intros. elim (unbnd_f m); intros i Hi. apply AbsIR_imp_AbsSmall. apply leEq_transitive with (AbsIR (seq2 (f i) [-]seq2 (f N))). elim mon_seq2; intro. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (seq2 (f N)); apply H2; assumption. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (seq2 (f N)); apply H2; apply Nat.le_trans with m; auto with arith. apply minus_resp_leEq. apply H2; auto with arith. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_inv_x. 2: apply shift_minus_leEq; astepr (seq2 (f N)); auto. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_inv_x. 2: apply shift_minus_leEq; astepr (seq2 (f N)); apply H2; apply Nat.le_trans with m; auto with arith. apply inv_resp_leEq; apply minus_resp_leEq. apply H2; auto with arith. apply leEq_wdl with (AbsIR (seq1 i[-]seq1 N)). apply AbsSmall_imp_AbsIR; apply HN. apply Nat.lt_le_incl. apply mon_F'; apply Nat.le_lt_trans with m; auto. apply AbsIR_wd; algebra. Qed. Lemma Cprop2_seq_imp_Cprop2_subseq : forall a, Cauchy_Lim_prop2 seq2 a -> Cauchy_Lim_prop2 seq1 a. Proof. intros a H. red in |- *; red in H. intros eps H0. elim (H _ H0). intros N HN. elim (unbnd_f N); intros i Hi. exists i. intros. astepr (seq2 (f m) [-]a). apply HN. cut (f i <= f m). intros; apply Nat.le_trans with (f i); auto with arith. apply monF; assumption. Qed. Lemma conv_seq_imp_conv_subseq : Cauchy_prop seq2 -> Cauchy_prop seq1. Proof. intro H. apply Cauchy_prop2_prop. cut (Cauchy_prop2 (Build_CauchySeq _ _ H)). intro H0. elim H0; intros a Ha; exists a. apply Cprop2_seq_imp_Cprop2_subseq. assumption. exists (Lim (Build_CauchySeq _ _ H)). apply Lim_Cauchy. Qed. Lemma Cprop2_subseq_imp_Cprop2_seq : forall a, Cauchy_Lim_prop2 seq1 a -> Cauchy_Lim_prop2 seq2 a. Proof. intros. cut (Cauchy_prop seq1); intros. 2: apply Cauchy_prop2_prop. 2: exists a; assumption. cut (Cauchy_prop seq2); intros H1. 2: apply conv_subseq_imp_conv_seq; assumption. cut (Cauchy_Lim_prop2 (Build_CauchySeq _ _ H1) (Lim (Build_CauchySeq _ _ H1))); intros. 2: apply Cauchy_complete. cut (Cauchy_Lim_prop2 seq1 (Lim (Build_CauchySeq _ _ H1))); intros. 2: apply Cprop2_seq_imp_Cprop2_subseq; assumption. cut (Lim (Build_CauchySeq _ _ H1) [=] a). intro H4. eapply Lim_wd. apply H4. assumption. apply Lim_unique with seq1; assumption. Qed. End Subsequences. Section Cauchy_Subsequences. Variables seq1 seq2 : CauchySeq IR. Variable f : nat -> nat. Hypothesis monF : forall m n : nat, m <= n -> f m <= f n. Hypothesis crescF : forall n : nat, {m : nat | n < m /\ f n < f m}. Hypothesis subseq : forall n : nat, seq1 n [=] seq2 (f n). Hypothesis mon_seq2 : (forall m n, m <= n -> seq2 m [<=] seq2 n) \/ (forall m n, m <= n -> seq2 n [<=] seq2 m). Lemma Lim_seq_eq_Lim_subseq : Lim seq1 [=] Lim seq2. Proof. cut (Cauchy_Lim_prop2 seq1 (Lim seq2)). 2: apply Cprop2_seq_imp_Cprop2_subseq with (CS_seq _ seq2) f; auto; apply Cauchy_complete. intro. apply eq_symmetric_unfolded. apply Limits_unique; assumption. Qed. Lemma Lim_subseq_eq_Lim_seq : Lim seq1 [=] Lim seq2. Proof. cut (Cauchy_Lim_prop2 seq2 (Lim seq1)). 2: exact (Cprop2_subseq_imp_Cprop2_seq seq1 seq2 f monF crescF subseq mon_seq2 _ (Cauchy_complete seq1)). intro. apply Limits_unique; assumption. Qed. End Cauchy_Subsequences. Section Properties_of_Exponentiation. (** *** More properties of Exponentiation Finally, we prove that [x[^]n] grows to infinity if [x [>] [1]]. *) Lemma power_big' : forall (R : COrdField) (x : R) n, [0] [<=] x -> [1][+]nring n[*]x [<=] ([1][+]x) [^]n. Proof. intros. induction n as [| n Hrecn]; intros. rstepl ([1]:R). astepr ([1]:R). apply leEq_reflexive. simpl in |- *. apply leEq_transitive with (([1][+]nring n[*]x) [*] ([1][+]x)). rstepr ([1][+] (nring n[+][1]) [*]x[+]nring n[*]x[^]2). astepl ([1][+] (nring n[+][1]) [*]x[+][0]). apply plus_resp_leEq_lft. apply mult_resp_nonneg. astepl (nring 0:R). apply nring_leEq. auto with arith. apply sqr_nonneg. apply mult_resp_leEq_rht. auto. apply less_leEq. astepl (([0]:R) [+][0]). apply plus_resp_less_leEq. apply pos_one. auto. Qed. Lemma power_big : forall x y : IR, [0] [<=] x -> [1] [<] y -> {N : nat | x [<=] y[^]N}. Proof. intros. cut ([0] [<] y[-][1]). intro. cut (y[-][1] [#] [0]). intro H2. elim (Archimedes (x[-][1][/] y[-][1][//]H2)). intro N. intros. exists N. apply leEq_transitive with ([1][+]nring N[*] (y[-][1])). apply shift_leEq_plus'. astepr ((y[-][1]) [*]nring N). apply shift_leEq_mult' with H2. auto. auto. apply leEq_wdr with (([1][+] (y[-][1])) [^]N). apply power_big'. apply less_leEq. auto. apply un_op_wd_unfolded. rational. apply Greater_imp_ap. auto. apply shift_less_minus. astepl OneR. auto. Qed. Lemma qi_yields_zero : forall q : IR, [0] [<=] q -> q [<] [1] -> forall e, [0] [<] e -> {N : nat | q[^]N [<=] e}. Proof. intros. cut ([0] [<] ([1][+]q) [/]TwoNZ). intro Haux. cut (([1][+]q) [/]TwoNZ [#] [0]). intro H2. cut (e [#] [0]). intro H3. elim (power_big ([1][/] e[//]H3) ([1][/] _[//]H2)). intro N. intros H4. exists N. cut ([0] [<] (([1][+]q) [/]TwoNZ) [^]N). intro H5. apply leEq_transitive with ((([1][+]q) [/]TwoNZ) [^]N). apply nexp_resp_leEq. auto. apply shift_leEq_div. apply pos_two. apply shift_leEq_plus. rstepl q. apply less_leEq. auto. astepl ([1][*] (([1][+]q) [/]TwoNZ) [^]N). set (H6 := pos_ap_zero _ _ H5) in *. apply shift_mult_leEq with H6. auto. rstepr (e[*] ([1][/] _[//]H6)). apply shift_leEq_mult' with H3. auto. astepr ([1][^]N[/] _[//]H6). astepr (([1][/] _[//]H2) [^]N). auto. apply nexp_resp_pos. apply pos_div_two. astepl ([0][+]ZeroR). apply plus_resp_less_leEq. apply pos_one. auto. apply less_leEq. apply recip_resp_pos. auto. apply shift_less_div. apply pos_div_two. astepl ([0][+]ZeroR). apply plus_resp_less_leEq. apply pos_one. auto. astepl (([1][+]q) [/]TwoNZ). apply shift_div_less. apply pos_two. rstepr ([1][+]OneR). apply plus_resp_less_lft. auto. apply Greater_imp_ap. auto. apply Greater_imp_ap. auto. apply pos_div_two. astepl ([0][+]ZeroR). apply plus_resp_less_leEq. apply pos_one. auto. Qed. Lemma qi_lim_zero : forall q : IR, [0] [<=] q -> q [<] [1] -> SeqLimit (fun i => q[^]i) [0]. Proof. intros q H H0. unfold SeqLimit in |- *. unfold AbsSmall in |- *. intros. elim (qi_yields_zero q H H0 e); auto. intro N. intros. exists (S N). intros. split. apply less_leEq. apply less_leEq_trans with ZeroR. astepr ( [--]ZeroR). apply inv_resp_less. auto. astepr (q[^]m). apply nexp_resp_nonneg. auto. astepl (q[^]m). replace m with (N + (m - N)). astepl (q[^]N[*]q[^] (m - N)). astepr (e[*][1]). apply mult_resp_leEq_both. apply nexp_resp_nonneg. auto. apply nexp_resp_nonneg. auto. auto. astepr (OneR[^] (m - N)). apply nexp_resp_leEq. auto. apply less_leEq. auto. auto with arith. Qed. End Properties_of_Exponentiation. (** *** [IR] has characteristic zero *) Lemma char0_IR : Char0 IR. Proof. apply char0_OrdField. Qed. Lemma poly_apzero_IR : forall f : cpoly_cring IR, f [#] [0] -> {c : IR | f ! c [#] [0]}. Proof. intros. apply poly_apzero. exact char0_IR. auto. Qed. Lemma poly_IR_extensional : forall p q : cpoly_cring IR, (forall x, p ! x [=] q ! x) -> p [=] q. Proof. intros. apply poly_extensional. exact char0_IR. auto. Qed. corn-8.20.0/reals/CSumsReals.v000066400000000000000000000134531473720167500161020ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.CReals1. (** * Sums over Reals %\begin{convention}% Let [c] be a real. %\end{convention}% Here we prove that $\Sigma_{m\leq i \leq n}~c^i = \frac{c^{n+1}-c^m}{c-1}.$ #sum_(m≤ i ≤ n) c^k = frac (c^(n+1) -c^m) (c-1)# *) Section Sums_over_Reals. Variable c : IR. Lemma Sum0_c_exp : forall H m, Sum0 m (fun i => c[^]i) [=] (c[^]m[-][1][/] c[-][1][//]H). Proof. intros. elim m. simpl in |- *. rational. simpl in |- *. intros. astepl ((nexp IR n c[-][1][/] c[-][1][//]H) [+]nexp IR n c). rational. Qed. Hint Resolve Sum0_c_exp. Lemma Sum_c_exp : forall H m n, Sum m n (fun i => c[^]i) [=] (c[^]S n[-]c[^]m[/] c[-][1][//]H). Proof. intros. unfold Sum in |- *. unfold Sum1 in |- *. astepl ((c[^]S n[-][1][/] c[-][1][//]H) [-] (c[^]m[-][1][/] c[-][1][//]H)). rational. Qed. Hint Resolve Sum_c_exp. (** The following formulation is often more useful if [c [<] 1]. *) Lemma Sum_c_exp' : forall H m n, Sum m n (fun i => c[^]i) [=] (c[^]m[-]c[^]S n[/] [1][-]c[//]H). Proof. intros. cut (c[-][1] [#] [0]). intro H0. astepl (c[^]S n[-]c[^]m[/] c[-][1][//]H0). rational. rstepl ( [--] ([1][-]c)). apply inv_resp_ap_zero. assumption. Qed. Hint Resolve Sum_c_exp'. End Sums_over_Reals. #[global] Hint Resolve Sum0_c_exp Sum_c_exp Sum_c_exp': algebra. Lemma diff_is_Sum0 : forall (s : nat -> IR) n, s n[-]s 0 [=] Sum0 n (fun i => s (S i) [-]s i). Proof. intros s. simple induction n. simpl in |- *. algebra. intros. simpl in |- *. apply eq_transitive_unfolded with (s (S n0) [-]s n0[+] (s n0[-]s 0)). rational. apply eq_transitive_unfolded with (s (S n0) [-]s n0[+]Sum0 n0 (fun i : nat => s (S i) [-]s i)). exact (plus_resp_eq _ _ _ _ H). rational. Qed. Lemma diff_is_sum : forall (s : nat -> IR) N m, N < m -> s m[-]s N [=] Sum N (pred m) (fun i => s (S i) [-]s i). Proof. intros s N m ltNm. unfold Sum in |- *. unfold Sum1 in |- *. generalize (Nat.lt_succ_pred N m ltNm). intro H. symmetry in H. rewrite <- H. generalize (diff_is_Sum0 s N). intro HsN. generalize (diff_is_Sum0 s m). intro Hsm. apply eq_transitive_unfolded with (s m[-]s 0[-] (s N[-]s 0)). rational. apply (cg_minus_wd IR). assumption. assumption. Qed. Lemma Sum0_pres_less : forall s t : nat -> IR, (forall i, s i [<] t i) -> forall n, Sum0 n s [<=] Sum0 n t. Proof. intros s t H. simple induction n. simpl in |- *. exact (leEq_reflexive _ _). intros. simpl in |- *. apply leEq_transitive with (Sum0 n0 t[+]s n0). apply plus_resp_leEq. assumption. apply plus_resp_leEq_lft. apply less_leEq; exact (H _). Qed. Lemma Sum_pres_less : forall s t : nat -> IR, (forall i, s i [<] t i) -> forall N m, N <= m -> Sum N m s [<=] Sum N m t. Proof. intros. apply less_leEq. apply Sum_resp_less; auto. Qed. Lemma Sum_pres_leEq : forall s t : nat -> IR, (forall i, s i [<=] t i) -> forall N m, N <= m -> Sum N m s [<=] Sum N m t. Proof. intros. apply Sum_resp_leEq; auto. Qed. Lemma Sum0_comm_scal : forall (s : nat -> IR) a m, Sum0 m (fun i => s i[*]a) [=] Sum0 m s [*]a. Proof. intros. induction m as [| m Hrecm]; intros. simpl in |- *. algebra. simpl in |- *. Step_final (Sum0 m s [*]a[+]s m[*]a). Qed. #[global] Hint Resolve Sum0_comm_scal: algebra. Lemma Sum_comm_scal : forall (s : nat -> IR) a N m, Sum N m (fun i => s i[*]a) [=] Sum N m s [*]a. Proof. unfold Sum in |- *. unfold Sum1 in |- *. intros. Step_final (Sum0 (S m) s [*]a[-]Sum0 N s [*]a). Qed. Lemma Sum0_comm_scal' : forall (s : nat -> IR) a m, Sum0 m (fun i => a[*]s i) [=] a[*]Sum0 m s. Proof. intros. apply eq_transitive_unfolded with (Sum0 m s[*]a). 2: astepr (Sum0 m s[*]a); apply mult_wdl. 2: apply Sum0_wd; algebra. eapply eq_transitive_unfolded. 2: apply Sum0_comm_scal. apply Sum0_wd; algebra. Qed. Lemma Sum_comm_scal' : forall (s : nat -> IR) a m n, Sum m n (fun i => a[*]s i) [=] a[*]Sum m n s. Proof. intros. unfold Sum, Sum1 in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply dist_2a. apply cg_minus_wd; apply Sum0_comm_scal'. Qed. Lemma Sumx_comm_scal' : forall n (a : IR) (f : forall i, i < n -> IR), Sumx (fun i H => a[*]f i H) [=] a[*]Sumx f. Proof. simple induction n. intros; simpl in |- *; algebra. clear n; intros; simpl in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply ring_dist_unfolded. apply bin_op_wd_unfolded. apply H with (f := fun i l => f i (Nat.lt_lt_succ_r _ _ l)). algebra. Qed. Lemma Sum2_comm_scal' : forall a m n (f: forall i, m <= i -> i <= n -> IR), m <= S n -> Sum2 (fun i Hm Hn => a[*]f i Hm Hn) [=] a[*]Sum2 f. Proof. intros; unfold Sum2 in |- *. eapply eq_transitive_unfolded. 2: apply Sum_comm_scal'. apply Sum_wd'. assumption. intros. elim (le_lt_dec m i); intros; simpl in |- *. elim (le_lt_dec i n); intros; simpl in |- *; algebra. algebra. Qed. corn-8.20.0/reals/CauchySeq.v000066400000000000000000000665151473720167500157550ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing IR %\ensuremath{\mathbb R}% *) (** printing PartIR %\ensuremath{\mathbb R\!\not\rightarrow\!\mathbb R}% *) (** printing [0]R %\ensuremath{\mathbf0}% #0# *) (** printing OneR %\ensuremath{\mathbf1}% #1# *) (** printing AbsIR %\ensuremath{|\cdot|_{\mathbb R}}% *) Require Export CoRN.reals.CReals. Require CoRN.model.reals.Cauchy_IR. From Coq Require Import Lia. (** * Real Number Structures %\begin{convention}% Let [IR] be a structure for real numbers. %\end{convention}% *) Definition IR : CReals. Proof. exact Cauchy_IR.Cauchy_IR. Qed. (* Defining IR directly with := and then setting [Global Opaque] keeps it semi-transparent, so we really need [Qed] to get full opacity. *) #[global] Instance IR_default : @DefaultRelation IR (@st_eq IR) | 2 := {}. Notation PartIR := (PartFunct IR). Notation ProjIR1 := (prj1 IR _ _ _). Notation ProjIR2 := (prj2 IR _ _ _). Load "Transparent_algebra". (* begin hide *) Notation ZeroR := ([0]:IR). Notation OneR := ([1]:IR). (* end hide *) Section CReals_axioms. (** ** [CReals] axioms *) Lemma CReals_is_CReals : is_CReals IR (Lim (IR:=IR)). Proof. unfold Lim in |- *. elim IR; intros. exact crl_proof. Qed. (** First properties which follow trivially from the axioms. *) Lemma Lim_Cauchy : forall s : CauchySeq IR, SeqLimit s (Lim s). Proof. elim CReals_is_CReals; auto. Qed. Lemma Archimedes : forall x : IR, {n : nat | x [<=] nring n}. Proof. elim CReals_is_CReals; auto. Qed. Lemma Archimedes' : forall x : IR, {n : nat | x [<] nring n}. Proof. intro x. elim (Archimedes (x[+][1])); intros n Hn. exists n. apply less_leEq_trans with (x[+][1]); auto. apply less_plusOne. Qed. (** A stronger version, which often comes in useful. *) Lemma str_Archimedes : forall x : IR, [0] [<=] x -> {n : nat | x [<=] nring n /\ (2 <= n -> nring n[-]Two [<=] x)}. Proof. intros. elim (Archimedes x); intros n Hn. induction n as [| n Hrecn]. exists 0; split; auto. intro; exfalso; lia. clear Hrecn. induction n as [| n Hrecn]. exists 1. split; intros; [ assumption | eapply leEq_transitive ]. 2: apply H. simpl in |- *. rstepl ([--]OneR); astepr ([--]ZeroR); apply less_leEq; apply inv_resp_less; apply pos_one. cut (nring (R:=IR) n [<] nring (S n)). intros H0. cut (nring n [<] x or x [<] nring (S n)). intros H1. elim H1; intros. exists (S (S n)). split. assumption. intros. simpl in |- *; rstepl (nring (R:=IR) n); apply less_leEq; assumption. apply Hrecn; apply less_leEq; assumption. apply less_cotransitive_unfolded; assumption. simpl in |- *; apply less_plusOne. Qed. Definition CauchySeqR := CauchySeq IR. End CReals_axioms. Section Cauchy_Defs. (** ** Cauchy sequences *** Alternative definitions This section gives several definitions of Cauchy sequences. There are no lemmas in this section. The current definition of Cauchy ([Cauchy_prop]) is: %\[\forall \epsilon>0. \exists N. \forall m\geq N. |seq_m - seq_N|\leq\varepsilon\]% #for all e>0 there exists N such that for all m≥ N |seqm-seqN|≤ e# Variant 1 of Cauchy ([Cauchy_prop1]) is: %\[\forall k. \exists N. \forall m \geq N. |seq_m - seq_N|\leq1/(k+1)\]% #for all k there exists N such that for all m ≥ N |seqm-seqN| ≤ 1/(k+1)# In all of the following variants the limit occurs in the definition. Therefore it is useful to define an auxiliary predicate [Cauchy_Lim_prop?], in terms of which [Cauchy_prop?] is defined. Variant 2 of Cauchy ([Cauchy_prop2]) is [exists y, (Cauchy_Lim_prop2 seq y)] where [[ Cauchy_Lim_prop2 seq y := forall eps [>] [0], exists N, forall m >= N, (AbsIR seq m - y) [<=] eps ]] Note that [Cauchy_Lim_prop2] equals [seqLimit]. Variant 3 of Cauchy ([Cauchy_prop3]) reads [exists y, (Cauchy_Lim_prop3 seq y)] where [[ Cauchy_Lim_prop3 seq y := forall k, exists N, forall m >= N, (AbsIR seq m - y) [<=] [1][/] (k[+]1) ]] The following variant is more restricted. Variant 4 of Cauchy ([Cauchy_prop4]): [exists y, (Cauchy_Lim_prop4 seq y)] where [[ Cauchy_Lim_prop4 seq y := forall k, (AbsIR seq m - y) [<=] [1][/] (k[+]1) ]] So [[ Cauchy_prop4 -> Cauchy_prop3 Iff Cauchy_prop2 Iff Cauchy_prop1 Iff Cauchy_prop ]] Note: we don't know which formulations are useful. The inequalities are stated with [[<=]] rather than with [<] for the following reason: both formulations are equivalent, as is well known; and [[<=]] being a negative statement, this makes proofs sometimes easier and program extraction much more efficient. *) Definition Cauchy_prop1 (seq : nat -> IR) := forall k, {N : nat | forall m, N <= m -> AbsSmall (one_div_succ k) (seq m[-]seq N)}. Definition Cauchy_Lim_prop2 (seq : nat -> IR) (y : IR) := forall eps, [0] [<] eps -> {N : nat | forall m, N <= m -> AbsSmall eps (seq m[-]y)}. Definition Cauchy_prop2 (seq : nat -> IR) := {y : IR | Cauchy_Lim_prop2 seq y}. Definition Cauchy_Lim_prop3 (seq : nat -> IR) (y : IR) := forall k, {N : nat | forall m, N <= m -> AbsSmall (one_div_succ k) (seq m[-]y)}. Definition Cauchy_prop3 (seq : nat -> IR) := {y : IR | Cauchy_Lim_prop3 seq y}. Definition Cauchy_Lim_prop4 (seq : nat -> IR) (y : IR) := forall m, AbsSmall (one_div_succ m) (seq m[-]y). Definition Cauchy_prop4 (seq : nat -> IR) := {y : IR | Cauchy_Lim_prop4 seq y}. End Cauchy_Defs. Section Inequalities. (** *** Inequalities of Limits The next lemma is equal to lemma [Lim_Cauchy]. *) Lemma Cauchy_complete : forall seq : CauchySeq IR, Cauchy_Lim_prop2 seq (Lim seq). Proof. exact Lim_Cauchy. Qed. Lemma less_Lim_so_less_seq : forall (seq : CauchySeq IR) y, y [<] Lim seq -> {N : nat | forall m, N <= m -> y [<] seq m}. Proof. intros seq y H. elim (Cauchy_complete seq ((Lim seq[-]y) [/]TwoNZ)). intro N. intros H0. split with N. intros m H1. generalize (H0 _ H1). intro H2. unfold AbsSmall in H2. elim H2. intros. apply plus_cancel_less with ([--] (Lim seq)). rstepl ([--] (Lim seq[-]y)). rstepr (seq m[-]Lim seq). eapply less_leEq_trans. 2: apply H3. apply inv_resp_less; apply pos_div_two'. apply shift_less_minus; astepl y; auto. apply pos_div_two. apply shift_less_minus; astepl y; auto. Qed. Lemma Lim_less_so_seq_less : forall (seq : CauchySeq IR) y, Lim seq [<] y -> {N : nat | forall m, N <= m -> seq m [<] y}. Proof. intros. elim (Cauchy_complete seq ((y[-]Lim seq) [/]TwoNZ)). intro N. intros H0. split with N. intros m H1. generalize (H0 _ H1); intro H2. unfold AbsSmall in H2. elim H2. intros H3 H4. apply plus_cancel_less with ([--] (Lim seq)). eapply leEq_less_trans. apply H4. apply pos_div_two'. apply shift_less_plus; rstepl (Lim seq); auto. apply pos_div_two. apply shift_less_minus; astepl (Lim seq); auto. Qed. Lemma Lim_less_Lim_so_seq_less_seq : forall seq1 seq2 : CauchySeq IR, Lim seq1 [<] Lim seq2 -> {N : nat | forall m, N <= m -> seq1 m [<] seq2 m}. Proof. intros. set (Av := (Lim seq1[+]Lim seq2) [/]TwoNZ) in |- *. cut (Lim seq1 [<] Av); try intro H0. cut (Av [<] Lim seq2); try intro H1. generalize (Lim_less_so_seq_less _ _ H0); intro H2. generalize (less_Lim_so_less_seq _ _ H1); intro H3. elim H2; intro N1; intro H4. elim H3; intro N2; intro H5. exists (Nat.max N1 N2); intros. apply less_leEq_trans with Av. apply H4. apply Nat.le_trans with (Nat.max N1 N2). apply Nat.le_max_l. assumption. apply less_leEq. apply H5. apply Nat.le_trans with (Nat.max N1 N2). apply Nat.le_max_r. assumption. unfold Av in |- *. apply Average_less_Greatest. assumption. unfold Av in |- *. apply Smallest_less_Average. assumption. Qed. (** The next lemma follows from [less_Lim_so_less_seq] with [y := (y[+] (Lim seq)) [/]TwoNZ]. *) Lemma less_Lim_so : forall (seq : CauchySeq IR) y, y [<] Lim seq -> {eps : IR | [0] [<] eps | {N : nat | forall m, N <= m -> y[+]eps [<] seq m}}. Proof. intros. elim (less_Lim_so_less_seq seq ((y[+]Lim seq) [/]TwoNZ)). intros x H0. exists ((Lim seq[-]y) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. exists x. intros. rstepl ((y[+]Lim seq) [/]TwoNZ). apply H0. assumption. apply Average_less_Greatest. assumption. Qed. Lemma Lim_less_so : forall (seq : CauchySeq IR) y, Lim seq [<] y -> {eps : IR | [0] [<] eps | {N : nat | forall m, N <= m -> seq m[+]eps [<] y}}. Proof. intros. elim (Lim_less_so_seq_less seq ((Lim seq[+]y) [/]TwoNZ)). intros x H0. exists ((y[-]Lim seq) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. exists x. intros. apply shift_plus_less. rstepr ((Lim seq[+]y) [/]TwoNZ). apply H0. assumption. apply Smallest_less_Average. assumption. Qed. Lemma leEq_seq_so_leEq_Lim : forall (seq : CauchySeqR) y, (forall i, y [<=] seq i) -> y [<=] Lim seq. Proof. intros. rewrite -> leEq_def in |- *. intro H0. generalize (Lim_less_so_seq_less _ _ H0); intro H1. elim H1; intros N H2. pose (c:=H N). rewrite -> leEq_def in c. apply c. apply H2. auto with arith. Qed. Lemma str_leEq_seq_so_leEq_Lim : forall (seq : CauchySeq IR) y, (exists N : nat, (forall i, N <= i -> y [<=] seq i)) -> y [<=] Lim seq. Proof. intros. rewrite -> leEq_def; intro H0. generalize (Lim_less_so_seq_less _ _ H0). elim H; intros N HN. intro H1. elim H1; intros M HM. cut (y [<] y). apply less_irreflexive_unfolded. apply leEq_less_trans with (seq (Nat.max N M)). apply HN; apply Nat.le_max_l. apply HM; apply Nat.le_max_r. Qed. Lemma Lim_leEq_Lim : forall seq1 seq2 : CauchySeqR, (forall i, seq1 i [<=] seq2 i) -> Lim seq1 [<=] Lim seq2. Proof. intros. rewrite -> leEq_def in |- *. intro H0. generalize (Lim_less_Lim_so_seq_less_seq _ _ H0); intro H1. elim H1; intros N H2. pose (c:=H N). rewrite -> leEq_def in c. apply c. apply H2. auto with arith. Qed. Lemma seq_leEq_so_Lim_leEq : forall (seq : CauchySeqR) y, (forall i, seq i [<=] y) -> Lim seq [<=] y. Proof. intros. rewrite -> leEq_def in |- *. intro H0. generalize (less_Lim_so_less_seq _ _ H0); intro H1. elim H1; intros N H2. pose (c:=H N). rewrite -> leEq_def in c. apply c. apply H2. auto with arith. Qed. Lemma str_seq_leEq_so_Lim_leEq : forall (seq : CauchySeq IR) y, (exists N : nat, (forall i, N <= i -> seq i [<=] y)) -> Lim seq [<=] y. Proof. intros. rewrite -> leEq_def; intro H0. generalize (less_Lim_so_less_seq _ _ H0). elim H; intros N HN. intro H1. elim H1; intros M HM. cut (y [<] y). apply less_irreflexive_unfolded. apply less_leEq_trans with (seq (Nat.max N M)). apply HM; apply Nat.le_max_r. apply HN; apply Nat.le_max_l. Qed. Lemma Limits_unique : forall (seq : CauchySeq IR) y, Cauchy_Lim_prop2 seq y -> y [=] Lim seq. Proof. intros seq y H. apply not_ap_imp_eq. unfold not in |- *; intro H0. generalize (ap_imp_less _ _ _ H0); intro H1. elim H1; intro H2. elim (less_Lim_so _ _ H2); intro eps; intros H4 H5. elim H5; intro N; intro H6. unfold Cauchy_Lim_prop2 in H. elim (H _ H4); intro N'; intro H7. generalize (Nat.le_max_l N N'); intro H8. generalize (Nat.le_max_r N N'); intro H9. generalize (H6 _ H8); intro H10. generalize (H7 _ H9); intro H11. elim H11; intros H12 H13. apply (less_irreflexive_unfolded _ (y[+]eps)). eapply less_leEq_trans. apply H10. apply plus_cancel_leEq_rht with ([--]y). rstepr eps. exact H13. (* Second case similar to first case *) elim (Lim_less_so _ _ H2); intro eps; intros H4 H5. elim H5; intro N; intros H6. unfold Cauchy_Lim_prop2 in H. elim (H _ H4); intro N'; intros H7. generalize (Nat.le_max_l N N'); intro H8. generalize (Nat.le_max_r N N'); intro H9. generalize (H6 _ H8); intro H10. generalize (H7 _ H9); intro H11. elim H11; intros H12 H13. apply (less_irreflexive_unfolded _ y). eapply leEq_less_trans. 2: apply H10. apply plus_cancel_leEq_rht with ([--]y[-]eps). rstepl ([--]eps). rstepr (seq (Nat.max N N') [-]y). assumption. Qed. Lemma Lim_wd : forall (seq : nat -> IR) x y, x [=] y -> Cauchy_Lim_prop2 seq x -> Cauchy_Lim_prop2 seq y. Proof. intros seq x y H H0. red in |- *; red in H0. intros eps H1. elim (H0 _ H1). intros N HN. exists N. intros. astepr (seq m[-]x). apply HN; assumption. Qed. Lemma Lim_strext : forall seq1 seq2 : CauchySeq IR, Lim seq1 [#] Lim seq2 -> {n : nat | seq1 n [#] seq2 n}. Proof. intros seq1 seq2 H. cut ({n : nat | seq1 n [<] seq2 n} or {n : nat | seq2 n [<] seq1 n}). intro H0; inversion_clear H0; rename X into H1; elim H1; intros n Hn. exists n; apply less_imp_ap; assumption. exists n; apply Greater_imp_ap; assumption. cut (Lim seq1 [<] Lim seq2 or Lim seq2 [<] Lim seq1). intros H0. 2: apply ap_imp_less; assumption. inversion_clear H0; [ left | right ]. cut {n : nat | forall m : nat, n <= m -> seq1 m [<] seq2 m}. 2: apply Lim_less_Lim_so_seq_less_seq; assumption. intro H0; elim H0; intros N HN. exists N; apply HN; auto with arith. cut {n : nat | forall m : nat, n <= m -> seq2 m [<] seq1 m}. 2: apply Lim_less_Lim_so_seq_less_seq; assumption. intro H0; elim H0; intros N HN. exists N; apply HN; auto with arith. Qed. Lemma Lim_ap_imp_seq_ap : forall seq1 seq2 : CauchySeq IR, Lim seq1 [#] Lim seq2 -> {N : nat | forall m, N <= m -> seq1 m [#] seq2 m}. Proof. intros seq1 seq2 H. elim (ap_imp_less _ _ _ H); intro. elim (Lim_less_Lim_so_seq_less_seq _ _ a); intros N HN. exists N; intros. apply less_imp_ap; apply HN; assumption. elim (Lim_less_Lim_so_seq_less_seq _ _ b); intros N HN. exists N; intros. apply Greater_imp_ap; apply HN; assumption. Qed. Lemma Lim_ap_imp_seq_ap' : forall seq1 seq2 : CauchySeq IR, Lim seq1 [#] Lim seq2 -> {N : nat | seq1 N [#] seq2 N}. Proof. intros seq1 seq2 H. elim (Lim_ap_imp_seq_ap _ _ H); intros N HN. exists N; apply HN. apply le_n. Qed. End Inequalities. Section Equiv_Cauchy. (** *** Equivalence of formulations of Cauchy *) Lemma Cauchy_prop1_prop : forall seq, Cauchy_prop1 seq -> Cauchy_prop seq. Proof. intros seq H. unfold Cauchy_prop1 in H. unfold Cauchy_prop in |- *. intros. cut (e [#] [0]). intro eNZ. elim (Archimedes ([1][/] e[//]eNZ)). intros x H1. elim (H x). intros x0 H2. split with x0. intros m H3. generalize (H2 _ H3). intro. apply AbsSmall_leEq_trans with (one_div_succ (R:=IR) x). unfold one_div_succ in |- *. unfold Snring in |- *. apply shift_div_leEq'. apply nring_pos. auto with arith. astepr (e[*]nring (S x)). apply leEq_transitive with (e[*]nring x). apply shift_leEq_mult' with eNZ. assumption. assumption. apply less_leEq. apply mult_resp_less_lft. apply nring_less. auto. assumption. assumption. apply pos_ap_zero. assumption. Qed. Lemma Cauchy_prop2_prop : forall seq, Cauchy_prop2 seq -> Cauchy_prop seq. Proof. intros seq H. unfold Cauchy_prop in |- *. intros e H0. unfold Cauchy_prop2 in H. elim H. intro y; intros H1. unfold Cauchy_Lim_prop2 in H1. elim (H1 (e [/]TwoNZ)). intro N. intros H2. exists N. intros m H3. generalize (H2 _ H3); intro H4. generalize (le_n N); intro H5. generalize (H2 _ H5); intro H6. generalize (AbsSmall_minus _ _ _ _ H6); intro H7. generalize (AbsSmall_plus _ _ _ _ _ H4 H7); intro H8. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). rstepr (seq m[-]y[+] (y[-]seq N)). assumption. apply pos_div_two. assumption. Qed. Lemma Cauchy_Lim_prop3_prop2 : forall seq y, Cauchy_Lim_prop3 seq y -> Cauchy_Lim_prop2 seq y. Proof. intros seq y H. unfold Cauchy_Lim_prop2 in |- *. intros eps H0. unfold Cauchy_Lim_prop3 in H. generalize (pos_ap_zero _ _ H0); intro Heps. elim (Archimedes ([1][/] eps[//]Heps)). intro K; intros H1. elim (H K). intro N; intros H2. exists N. intros m H3. generalize (H2 _ H3); intro H4. apply AbsSmall_leEq_trans with (one_div_succ (R:=IR) K); try assumption. unfold one_div_succ in |- *. unfold Snring in |- *. apply shift_div_leEq'. apply nring_pos. auto with arith. apply leEq_transitive with (eps[*]nring K). apply shift_leEq_mult' with Heps; assumption. astepl (nring K[*]eps). apply less_leEq. apply mult_resp_less; try assumption. apply nring_less. auto with arith. Qed. Lemma Cauchy_prop3_prop2 : forall seq, Cauchy_prop3 seq -> Cauchy_prop2 seq. Proof. unfold Cauchy_prop2 in |- *. unfold Cauchy_prop3 in |- *. intros seq H. elim H; intros x H0. exists x. apply Cauchy_Lim_prop3_prop2. assumption. Qed. Lemma Cauchy_prop3_prop : forall seq, Cauchy_prop3 seq -> Cauchy_prop seq. Proof. intros. apply Cauchy_prop2_prop. apply Cauchy_prop3_prop2. assumption. Qed. Definition Build_CauchySeq1 : forall seq, Cauchy_prop1 seq -> CauchySeqR. Proof. intros. unfold CauchySeqR in |- *. apply Build_CauchySeq with seq. apply Cauchy_prop1_prop. assumption. Defined. Lemma Cauchy_Lim_prop4_prop3 : forall seq y, Cauchy_Lim_prop4 seq y -> Cauchy_Lim_prop3 seq y. Proof. intros. unfold Cauchy_Lim_prop4 in H. unfold Cauchy_Lim_prop3 in |- *. intros. exists k. intros. apply AbsSmall_leEq_trans with (one_div_succ (R:=IR) m). 2: apply H. apply one_div_succ_resp_leEq. assumption. Qed. Lemma Cauchy_Lim_prop4_prop2 : forall seq y, Cauchy_Lim_prop4 seq y -> Cauchy_Lim_prop2 seq y. Proof. intros. apply Cauchy_Lim_prop3_prop2. apply Cauchy_Lim_prop4_prop3. assumption. Qed. Lemma Cauchy_prop4_prop3 : forall seq, Cauchy_prop4 seq -> Cauchy_prop3 seq. Proof. unfold Cauchy_prop4 in |- *. unfold Cauchy_prop3 in |- *. intros seq H. elim H; intros. exists x. apply Cauchy_Lim_prop4_prop3. assumption. Qed. Lemma Cauchy_prop4_prop : forall seq, Cauchy_prop4 seq -> Cauchy_prop seq. Proof. intros. apply Cauchy_prop3_prop. apply Cauchy_prop4_prop3. assumption. Qed. Definition Build_CauchySeq4 : forall seq, Cauchy_prop4 seq -> CauchySeqR. Proof. intros. unfold CauchySeqR in |- *. apply Build_CauchySeq with seq. apply Cauchy_prop4_prop. assumption. Defined. Definition Build_CauchySeq4_y : forall seq y, Cauchy_Lim_prop4 seq y -> CauchySeqR. Proof. intros. apply Build_CauchySeq4 with seq. unfold Cauchy_prop4 in |- *. exists y. assumption. Defined. Lemma Lim_CauchySeq4 : forall seq y H, Lim (Build_CauchySeq4_y seq y H) [=] y. Proof. intros. apply eq_symmetric_unfolded. apply Limits_unique. apply Cauchy_Lim_prop3_prop2. apply Cauchy_Lim_prop4_prop3. unfold Build_CauchySeq4_y in |- *. unfold Build_CauchySeq4 in |- *. unfold CS_seq in |- *. assumption. Qed. Definition Build_CauchySeq2 : forall seq, Cauchy_prop2 seq -> CauchySeqR. Proof. intros. unfold CauchySeqR in |- *. apply Build_CauchySeq with seq. apply Cauchy_prop2_prop. assumption. Defined. Definition Build_CauchySeq2_y : forall seq y, Cauchy_Lim_prop2 seq y -> CauchySeqR. Proof. intros. apply Build_CauchySeq2 with seq. unfold Cauchy_prop2 in |- *. exists y. assumption. Defined. Lemma Lim_CauchySeq2 : forall seq y H, Lim (Build_CauchySeq2_y seq y H) [=] y. Proof. intros. apply eq_symmetric_unfolded. apply Limits_unique. unfold Build_CauchySeq2_y in |- *. unfold Build_CauchySeq2 in |- *. unfold CS_seq in |- *. assumption. Qed. (** Well definedness. *) Lemma Cauchy_prop_wd' : forall seq1 seq2 : nat -> IR, Cauchy_prop seq1 -> {N : nat | forall n, N <= n -> seq1 n [=] seq2 n} -> Cauchy_prop seq2. Proof. intros seq1 seq2 H H0. red in |- *. intros e H1. elim (H (e[/]TwoNZ) (pos_div_two IR e H1)). intros N Hn. destruct H0 as [M H0]. exists (Nat.max M N). intros. astepr (seq1 m[-]seq1 (Nat.max M N)). astepr ((seq1 m[-]seq1 N)[+](seq1 N [-]seq1 (Nat.max M N))). apply AbsSmall_eps_div_two. apply Hn. eauto with arith. apply AbsSmall_minus. apply Hn. eauto with arith. rational. apply cg_minus_wd; apply H0; eauto with arith. Qed. Lemma Cauchy_prop_wd : forall seq1 seq2 : nat -> IR, Cauchy_prop seq1 -> (forall n, seq1 n [=] seq2 n) -> Cauchy_prop seq2. Proof. intros. apply Cauchy_prop_wd' with seq1; auto. exists 0. auto. Qed. Lemma Cauchy_Lim_prop2_wd' : forall seq1 seq2 c, Cauchy_Lim_prop2 seq1 c -> { N : nat | forall n, N <= n -> seq1 n [=] seq2 n} -> Cauchy_Lim_prop2 seq2 c. Proof. intros seq1 seq2 c H1 H2. red in |- *. intros eps H3. elim (H1 eps H3). intros M H4. destruct H2 as [N H2]. exists (Nat.max N M) . intros. assert (N <= m); eauto with arith. assert (M <= m); eauto with arith. astepr (seq1 m[-]c). apply H4; auto. Qed. Lemma Cauchy_Lim_prop2_wd : forall seq1 seq2 c, Cauchy_Lim_prop2 seq1 c -> (forall n, seq1 n [=] seq2 n) -> Cauchy_Lim_prop2 seq2 c. Proof. intros. apply Cauchy_Lim_prop2_wd' with seq1; auto. exists 0. auto. Qed. Lemma Lim_wd'' : forall seq1 seq2 : CauchySeqR, {N : nat | forall n : nat, N <= n -> seq1 n [=] seq2 n} -> Lim seq1 [=] Lim seq2. Proof. intros seq1 seq2 H. destruct H as [N H]. cut (Cauchy_Lim_prop2 seq1 (Lim seq2)). intro. apply eq_symmetric_unfolded. apply Limits_unique; assumption. apply Cauchy_Lim_prop2_wd' with (seq2:nat -> IR). apply Cauchy_complete. exists N. intros; apply eq_symmetric_unfolded. auto. Qed. Lemma Lim_wd' : forall seq1 seq2 : CauchySeqR, (forall n : nat, seq1 n [=] seq2 n) -> Lim seq1 [=] Lim seq2. Proof. intros. apply Lim_wd''; auto. exists 0. auto. Qed. Lemma Lim_unique : forall seq x y, Cauchy_Lim_prop2 seq x -> Cauchy_Lim_prop2 seq y -> x [=] y. Proof. intros. cut (Cauchy_prop seq); [ intro | apply Cauchy_prop2_prop; exists y; auto ]. apply eq_transitive_unfolded with (Lim (Build_CauchySeq _ _ X1)). apply Limits_unique; auto. apply eq_symmetric_unfolded; apply Limits_unique; auto. Qed. End Equiv_Cauchy. Section Cauchy_props. (** *** Properties of Cauchy sequences Some of these lemmas are now obsolete, because they were reproved for arbitrary ordered fields$\ldots$#...# We begin by defining the constant sequence and proving that it is Cauchy with the expected limit. *) Definition Cauchy_const : IR -> CauchySeq IR. Proof. intro x. apply Build_CauchySeq with (fun n : nat => x). intros; exists 0. intros; astepr ZeroR. apply zero_AbsSmall; apply less_leEq; assumption. Defined. Lemma Lim_const : forall x : IR, x [=] Lim (Cauchy_const x). Proof. intros. apply Limits_unique. red in |- *; intro; exists 0. intros; unfold Cauchy_const in |- *; simpl in |- *. astepr ZeroR; apply zero_AbsSmall; apply less_leEq; assumption. Qed. Lemma Cauchy_Lim_plus : forall seq1 seq2 y1 y2, Cauchy_Lim_prop2 seq1 y1 -> Cauchy_Lim_prop2 seq2 y2 -> Cauchy_Lim_prop2 (fun n => seq1 n [+] seq2 n) (y1 [+] y2). Proof. intros seq1 seq2 y1 y2 H H0. unfold Cauchy_Lim_prop2 in |- *. intros eps H1. cut ([0] [<] eps [/]TwoNZ). intro H2. elim (H _ H2); intros x H3. elim (H0 _ H2); intros x0 H4. exists (Nat.max x x0). intros. rstepr (seq1 m[-]y1[+] (seq2 m[-]y2)). apply AbsSmall_eps_div_two. apply H3. apply Nat.le_trans with (Nat.max x x0). apply Nat.le_max_l. assumption. apply H4. apply Nat.le_trans with (Nat.max x x0). apply Nat.le_max_r. assumption. apply pos_div_two. assumption. Qed. Lemma Cauchy_plus : forall seq1 seq2 : CauchySeqR, Cauchy_prop (fun n => seq1 n [+] seq2 n). Proof. intros. apply Cauchy_prop2_prop. unfold Cauchy_prop2 in |- *. exists (Lim seq1[+]Lim seq2). apply Cauchy_Lim_plus. apply Cauchy_complete. apply Cauchy_complete. Qed. Lemma Lim_plus : forall seq1 seq2 : CauchySeqR, Lim (Build_CauchySeq _ _ (Cauchy_plus seq1 seq2)) [=] Lim seq1 [+] Lim seq2. Proof. intros. apply eq_symmetric_unfolded. apply Limits_unique. simpl in |- *. apply Cauchy_Lim_plus. apply Cauchy_complete. apply Cauchy_complete. Qed. Lemma Cauchy_Lim_inv : forall seq y, Cauchy_Lim_prop2 seq y -> Cauchy_Lim_prop2 (fun n => [--] (seq n)) [--]y. Proof. intros seq y H. unfold Cauchy_Lim_prop2 in |- *. intros eps H0. elim (H _ H0); intros x H1. exists x. intros. rstepr ([--] (seq m[-]y)). apply inv_resp_AbsSmall. apply H1. assumption. Qed. Lemma Cauchy_inv : forall seq : CauchySeqR, Cauchy_prop (fun n => [--] (seq n)). Proof. intros. apply Cauchy_prop2_prop. unfold Cauchy_prop2 in |- *. exists ([--] (Lim seq)). apply Cauchy_Lim_inv. apply Cauchy_complete. Qed. Lemma Lim_inv : forall seq : CauchySeqR, Lim (Build_CauchySeq _ _ (Cauchy_inv seq)) [=] [--] (Lim seq). Proof. intros. apply eq_symmetric_unfolded. apply Limits_unique. simpl in |- *. apply Cauchy_Lim_inv. apply Cauchy_complete. Qed. Lemma Cauchy_Lim_minus : forall seq1 seq2 y1 y2, Cauchy_Lim_prop2 seq1 y1 -> Cauchy_Lim_prop2 seq2 y2 -> Cauchy_Lim_prop2 (fun n => seq1 n[-]seq2 n) (y1[-]y2). Proof. intros. unfold cg_minus in |- *. change (Cauchy_Lim_prop2 (fun n : nat => seq1 n[+] (fun m : nat => [--] (seq2 m)) n) (y1[+][--]y2)) in |- *. apply Cauchy_Lim_plus. assumption. apply Cauchy_Lim_inv. assumption. Qed. Lemma Cauchy_minus : forall seq1 seq2 : CauchySeqR, Cauchy_prop (fun n => seq1 n[-]seq2 n). Proof. intros. apply Cauchy_prop2_prop. unfold Cauchy_prop2 in |- *. exists (Lim seq1[-]Lim seq2). apply Cauchy_Lim_minus. apply Cauchy_complete. apply Cauchy_complete. Qed. Lemma Lim_minus : forall seq1 seq2 : CauchySeqR, Lim (Build_CauchySeq _ _ (Cauchy_minus seq1 seq2)) [=] Lim seq1[-]Lim seq2. Proof. intros. apply eq_symmetric_unfolded. apply Limits_unique. simpl in |- *. apply Cauchy_Lim_minus. apply Cauchy_complete. apply Cauchy_complete. Qed. Lemma Cauchy_Lim_mult : forall seq1 seq2 y1 y2, Cauchy_Lim_prop2 seq1 y1 -> Cauchy_Lim_prop2 seq2 y2 -> Cauchy_Lim_prop2 (fun n => seq1 n [*] seq2 n) (y1 [*] y2). Proof. unfold Cauchy_Lim_prop2 in |- *. intros. rename X into H. rename X0 into H0. rename X1 into H1. elim (mult_contin _ y1 y2 eps H1). intro c. intros H2 H3. elim H3. clear H3. intro d. intros H3 H4. elim (H c H2). clear H. intro N1. intros H. elim (H0 d H3). clear H0. intro N2. intros H0. cut {N : nat | N1 <= N /\ N2 <= N}. intro H5. elim H5. clear H5. intro N. intro H5. elim H5. clear H5. intros. exists N. intros. apply AbsSmall_wdr_unfolded with ([--] (y1[*]y2[-]seq1 m[*]seq2 m)). apply inv_resp_AbsSmall. apply H4; clear H4; intros. apply AbsSmall_wdr_unfolded with ([--] (seq1 m[-]y1)). apply inv_resp_AbsSmall. apply H. apply Nat.le_trans with N; auto. rational. apply AbsSmall_wdr_unfolded with ([--] (seq2 m[-]y2)). apply inv_resp_AbsSmall. apply H0. apply Nat.le_trans with N; auto. rational. rational. elim (le_lt_dec N1 N2); intros. exists N2. auto. exists N1. split. auto. auto with arith. Qed. Lemma Cauchy_mult : forall seq1 seq2 : CauchySeqR, Cauchy_prop (fun n => seq1 n [*] seq2 n). Proof. intros. apply Cauchy_prop2_prop. unfold Cauchy_prop2 in |- *. exists (Lim seq1[*]Lim seq2). apply Cauchy_Lim_mult. apply Cauchy_complete. apply Cauchy_complete. Qed. Lemma Lim_mult : forall seq1 seq2 : CauchySeqR, Lim (Build_CauchySeq _ _ (Cauchy_mult seq1 seq2)) [=] Lim seq1 [*] Lim seq2. Proof. intros. apply eq_symmetric_unfolded. apply Limits_unique. simpl in |- *. apply Cauchy_Lim_mult. apply Cauchy_complete. apply Cauchy_complete. Qed. End Cauchy_props. corn-8.20.0/reals/Cauchy_CReals.v000066400000000000000000000666451473720167500165410ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.Cauchy_COF. Require Export CoRN.reals.CReals. Section R_CReals. (** * The Real Number Structure We will now apply our Cauchy sequence construction to an archimedean ordered field in order to obtain a model of the real numbers. ** Injection of [Q] We start by showing how to inject the rational numbers in the field of Cauchy sequences; this embedding preserves the algebraic operations. %\begin{convention}% Let [F] be an ordered field. %\end{convention}% *) Variable F : COrdField. Notation "'R_COrdField''" := (R_COrdField F). Definition inject_Q (x : F) : R_COrdField' := Build_CauchySeq _ _ (CS_seq_const _ x). Lemma ing_eq : forall x y : F, x [=] y -> inject_Q x [=] inject_Q y. Proof. intros. unfold inject_Q in |- *. simpl in |- *; intro H0. elim H0; intro. elim a; intros N HN. elim HN; clear H0 a HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr (x[-]x); astepr (y[-]x); eauto with arith. elim b; intros N HN. elim HN; clear H0 b HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr (x[-]x); astepr (x[-]y); eauto with arith. Qed. Lemma ing_plus : forall x y : F, inject_Q (x[+]y) [=] inject_Q x[+]inject_Q y. Proof. intros. unfold inject_Q in |- *. simpl in |- *; intro H. elim H; intro. elim a; intros N HN. elim HN; clear H a HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr (x[+]y[-] (x[+]y)); eauto with arith. elim b; intros N HN. elim HN; clear H b HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr (x[+]y[-] (x[+]y)); eauto with arith. Qed. Lemma ing_min : forall x : F, inject_Q [--]x [=] [--] (inject_Q x). Proof. intros. unfold inject_Q in |- *. simpl in |- *; intro H. elim H; intro. elim a; intros N HN. elim HN; clear H a HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr ( [--]x[-][--]x); eauto with arith. elim b; intros N HN. elim HN; clear H b HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr ( [--]x[-][--]x); eauto with arith. Qed. Lemma ing_lt : forall x y : F, x [<] y -> inject_Q x [<] inject_Q y. Proof. intros. simpl in |- *. exists 0. exists ((y[-]x) [/]TwoNZ). apply pos_div_two. apply shift_zero_less_minus. assumption. intros. apply less_leEq; apply pos_div_two'. simpl in |- *. apply shift_zero_less_minus; auto. Qed. Lemma ing_ap : forall x y : F, x [#] y -> inject_Q x [#] inject_Q y. intros x y H; elim (ap_imp_less _ _ _ H); intro Hlt; [ left | right ]; apply ing_lt; auto. Qed. Lemma ing_cancel_eq : forall x y : F, inject_Q x [=] inject_Q y -> x [=] y. Proof. intros x y Hxy. apply not_ap_imp_eq; intro Hap. elim (ap_irreflexive_unfolded _ (inject_Q x)). astepr (inject_Q y). apply ing_ap; auto. Qed. Lemma ing_cancel_less : forall x y : F, inject_Q x [<] inject_Q y -> x [<] y. Proof. intros x y H. elim H; intros N HN; elim HN; clear H HN; intros e He HN; simpl in HN. apply less_leEq_trans with (x[+]e). apply shift_less_plus'; astepl ([0]:F); auto. apply shift_plus_leEq'; eauto. Qed. Lemma ing_le : forall x y : F, x [<=] y -> inject_Q x [<=] inject_Q y. Proof. intros. intro. rewrite -> leEq_def in H; apply H. apply ing_cancel_less. auto. Qed. Lemma ing_cancel_leEq : forall x y : F, inject_Q x [<=] inject_Q y -> x [<=] y. Proof. intros. rewrite -> leEq_def; intro. apply H. apply ing_lt. auto. Qed. Lemma ing_cancel_AbsSmall : forall e x y : F, AbsSmall (inject_Q e) (inject_Q x[-]inject_Q y) -> AbsSmall e (x[-]y). Proof. intros. elim H. intros H0 H1. split. apply ing_cancel_leEq. astepl ( [--] (inject_Q e)). astepr (inject_Q x[-]inject_Q y). assumption. astepl (inject_Q x[+][--] (inject_Q y)). apply eq_transitive_unfolded with (inject_Q x[+]inject_Q [--]y). apply plus_resp_eq. apply eq_symmetric_unfolded. apply ing_min. Step_final (inject_Q (x[+][--]y)). apply eq_symmetric_unfolded. apply ing_plus. apply eq_symmetric_unfolded. apply ing_min. apply ing_cancel_leEq. astepl (inject_Q x[-]inject_Q y). assumption. astepl (inject_Q x[+][--] (inject_Q y)). apply eq_transitive_unfolded with (inject_Q x[+]inject_Q [--]y). apply plus_resp_eq. apply eq_symmetric_unfolded. apply ing_min. Step_final (inject_Q (x[+][--]y)). apply eq_symmetric_unfolded. apply ing_plus. Qed. Lemma ing_One : inject_Q ([1]:F) [=] [1]. Proof. apply not_ap_imp_eq; intro H. elim H; intro Hlt; elim Hlt; intros N HN; elim HN; clear H Hlt HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded F [0]). apply less_leEq_trans with e; auto. astepr ([1][-] ([1]:F)); eauto. apply (less_irreflexive_unfolded F [0]). apply less_leEq_trans with e; auto. astepr ([1][-] ([1]:F)); eauto. Qed. Lemma ing_nring' : forall m n : nat, CS_seq _ (nring (R:=R_COrdField') n) m [=] CS_seq _ (inject_Q (nring n)) m. Proof. intros. induction n as [| n Hrecn]; simpl in |- *; algebra. Qed. Lemma ing_nring : forall n : nat, nring n [=] inject_Q (nring n). Proof. intros. apply not_ap_imp_eq; intro Hap. elim Hap; intro Hlt; elim Hlt; intros N HN; elim HN; clear Hap Hlt HN; intros e He HN. apply (less_irreflexive_unfolded F [0]). apply less_leEq_trans with e; auto. eapply leEq_wdr. apply (HN N); auto. apply x_minus_x; apply eq_symmetric_unfolded; apply ing_nring'. apply (less_irreflexive_unfolded F [0]). apply less_leEq_trans with e; auto. eapply leEq_wdr. apply (HN N); auto. apply x_minus_x; apply ing_nring'. Qed. Lemma ing_mult : forall x y : F, inject_Q (x[*]y) [=] inject_Q x[*]inject_Q y. Proof. intros. unfold inject_Q in |- *. simpl in |- *; intro H. elim H; intro. elim a; intros N HN. elim HN; clear H a HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr (x[*]y[-]x[*]y); eauto with arith. elim b; intros N HN. elim HN; clear H b HN; intros e He HN; simpl in HN. apply (less_irreflexive_unfolded _ e). apply leEq_less_trans with ([0]:F); auto. astepr (x[*]y[-]x[*]y); eauto with arith. Qed. Opaque R_COrdField. Lemma ing_div_three : forall x, inject_Q x [/]ThreeNZ [=] inject_Q (x [/]ThreeNZ). Proof. intros. apply mult_cancel_lft with (Three:R_COrdField'). apply pos_ap_zero. apply pos_three. (* JZ: Removed Rational. *) apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (inject_Q (Three:F) [*]inject_Q (x [/]ThreeNZ)). apply mult_wdl. apply ing_nring. apply eq_transitive_unfolded with (inject_Q (Three[*]x [/]ThreeNZ)). apply eq_symmetric_unfolded. apply ing_mult. astepr (inject_Q x). apply ing_eq; algebra. Qed. Transparent R_COrdField. Lemma ing_n : forall x n H1 H2, (inject_Q x[/] nring n[//]H2) [=] inject_Q (x[/] nring n[//]H1). Proof. intros. apply mult_cancel_lft with (inject_Q (nring (R:=F) n)). apply Greater_imp_ap. astepr (nring (R:=R_COrdField') n). apply nring_pos. apply Nat.neq_0_lt_0. apply Nat.neq_sym. apply nring_ap_zero_imp with F. assumption. apply ing_nring. apply eq_transitive_unfolded with (inject_Q x). rstepr (nring n[*] (inject_Q x[/] nring n[//]H2)). apply mult_wdl. apply eq_symmetric_unfolded. apply ing_nring. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (inject_Q (nring n[*] (x[/] nring n[//]H1))). apply eq_symmetric_unfolded. apply ing_mult. apply ing_eq. rational. Qed. Theorem expand_Q_R : forall (x : R_COrdField') e, [0] [<] e -> forall N, (forall m, N <= m -> AbsSmall (e [/]FourNZ) (CS_seq F x m[-]CS_seq F x N)) -> forall m, N <= m -> AbsSmall (inject_Q e) (inject_Q (CS_seq F x m) [-]x). Proof. intros x e H N H0 m H1. split. apply less_leEq. simpl in |- *. unfold Rlt in |- *. exists N. exists (e [/]ThreeNZ). apply pos_div_three. assumption. intros. change (e [/]ThreeNZ [<=] CS_seq F (inject_Q (CS_seq F x m) [-]x) n[-][--]e) in |- *. apply plus_cancel_leEq_rht with (R := F) (z := [--]e). rstepl ( [--] (Two[*]e [/]ThreeNZ)). rstepr (CS_seq F (inject_Q (CS_seq F x m) [-]x) n). cut (AbsSmall (e [/]FourNZ) (CS_seq F x m[-]CS_seq F x N)). intro H3. elim H3. intros H4 H5. cut (AbsSmall (e [/]FourNZ) (CS_seq F x n[-]CS_seq F x N)). intro H6. elim H6. intros H7 H8. change ( [--] (Two[*]e [/]ThreeNZ) [<=] CS_seq F x m[-]CS_seq F x n) in |- *. rstepl ( [--] (e [/]ThreeNZ) [+][--] (e [/]ThreeNZ)). rstepr (CS_seq F x m[-]CS_seq F x N[+] (CS_seq F x N[-]CS_seq F x n)). apply plus_resp_leEq_both. apply leEq_transitive with ( [--] (e [/]FourNZ)); auto. apply inv_resp_leEq. apply mult_cancel_leEq with (nring (R:=F) 12). apply nring_pos. auto with arith. rstepl ([0][+]Three[*]e); rstepr (e[+]Three[*]e). apply plus_resp_leEq; apply less_leEq; auto. apply inv_cancel_leEq. rstepl (CS_seq F x n[-]CS_seq F x N). rstepr (e [/]ThreeNZ). apply leEq_transitive with (e [/]FourNZ); auto. apply mult_cancel_leEq with (nring (R:=F) 12). apply nring_pos. auto with arith. rstepl ([0][+]Three[*]e); rstepr (e[+]Three[*]e). apply plus_resp_leEq; apply less_leEq; auto. apply H0. assumption. apply H0. assumption. apply less_leEq. simpl in |- *. unfold Rlt in |- *. exists N. exists (e [/]ThreeNZ). apply pos_div_three. assumption. intros. change (e [/]ThreeNZ [<=] e[-]CS_seq F (inject_Q (CS_seq F x m) [-]x) n) in |- *. apply plus_cancel_leEq_rht with (R := F) (z := [--]e). rstepl ( [--] (Two[*]e [/]ThreeNZ)). rstepr ( [--] (CS_seq F (inject_Q (CS_seq F x m) [-]x) n)). apply inv_resp_leEq. cut (AbsSmall (e [/]FourNZ) (CS_seq F x m[-]CS_seq F x N)). intro. elim H3. intros H4 H5. cut (AbsSmall (e [/]FourNZ) (CS_seq F x n[-]CS_seq F x N)). intro. elim H6. intros H7 H8. change (CS_seq F x m[-]CS_seq F x n [<=] Two[*]e [/]ThreeNZ) in |- *. rstepr (e [/]ThreeNZ[+]e [/]ThreeNZ). rstepl (CS_seq F x m[-]CS_seq F x N[+] (CS_seq F x N[-]CS_seq F x n)). apply plus_resp_leEq_both. apply leEq_transitive with (e [/]FourNZ); auto. apply mult_cancel_leEq with (nring (R:=F) 12). apply nring_pos. auto with arith. rstepl ([0][+]Three[*]e); rstepr (e[+]Three[*]e). apply plus_resp_leEq; apply less_leEq; auto. apply inv_cancel_leEq. rstepr (CS_seq F x n[-]CS_seq F x N). apply leEq_transitive with ( [--] (e [/]FourNZ)); auto. apply inv_resp_leEq. apply mult_cancel_leEq with (nring (R:=F) 12). apply nring_pos. auto with arith. rstepl ([0][+]Three[*]e); rstepr (e[+]Three[*]e). apply plus_resp_leEq; apply less_leEq; auto. apply H0. assumption. apply H0. assumption. Qed. Lemma conv_modulus : forall (x : R_COrdField') M, {N : nat | forall m, N <= m -> AbsSmall (one_div_succ M) (CS_seq F x m[-]CS_seq F x N)}. Proof. intros. case x. intros x_ px. unfold Cauchy_prop in px. cut {N : nat | forall m : nat, N <= m -> AbsSmall (one_div_succ M) (x_ m[-]x_ N)}. intro H. case H. intros N H1. exists N. intros. apply H1. assumption. apply px. apply one_div_succ_pos. Qed. Let T (x : R_COrdField') (m : nat) := let (N, _) := conv_modulus x m in N. (** We now assume our original field is archimedean and prove that the resulting one is, too. *) Hypothesis F_is_archemaedian : forall x : F, {n : nat | x [<] nring n}. Theorem R_is_archemaedian : forall x : R_COrdField', {n : nat | x [<=] nring n}. Proof. intros. case x. intros x_ px. elim (px [1] (pos_one _)); intros Nx HNx. elim (F_is_archemaedian (x_ Nx)); intros N HN. exists (S N). intro H. elim H; intros K HK; elim HK; clear H HK; intros e He HK; simpl in HK. apply (less_irreflexive_unfolded F [0]). apply less_leEq_trans with e; auto. astepr (x_ (K + Nx) [-]x_ (K + Nx)). eapply leEq_transitive. apply (HK (K + Nx)); eauto with arith. unfold cg_minus in |- *; apply plus_resp_leEq_lft; apply inv_resp_leEq. rstepl (x_ Nx[+] (x_ (K + Nx) [-]x_ Nx)). apply plus_resp_leEq_both. apply leEq_wdr with (CS_seq _ (inject_Q (nring N)) (K + Nx)). simpl in |- *; apply less_leEq; auto. apply eq_symmetric_unfolded; apply ing_nring'. elim (HNx (K + Nx)); auto with arith. Qed. (* begin hide *) Let PT (x : R_COrdField') (M : nat) := proj2_sigT nat (fun N : nat => forall m : nat, N <= m -> AbsSmall (one_div_succ M) (CS_seq F x m[-]CS_seq F x N)) (conv_modulus x M). (* end hide *) Lemma modulus_property : forall x M m0 m1, T x M <= m0 -> T x M <= m1 -> AbsSmall (Two[*]one_div_succ M) (CS_seq F x m0[-]CS_seq F x m1). Proof. intros. rstepl (one_div_succ (R:=F) M[+]one_div_succ M). rstepr (CS_seq F x m0[-]CS_seq F x (T x M) [+] (CS_seq F x (T x M) [-]CS_seq F x m1)). generalize (PT x M). intro. apply AbsSmall_plus. apply H1. assumption. apply AbsSmall_minus. apply H1. assumption. Qed. Lemma modulus_property_2 : forall x M m, T x M <= m -> AbsSmall (one_div_succ M) (CS_seq F x m[-]CS_seq F x (T x M)). Proof. intros. apply (PT x M). assumption. Qed. Lemma expand_Q_R_2 : forall x e N, [0] [<] e -> (forall m, N <= m -> AbsSmall (e [/]FourNZ) (CS_seq F x m[-]CS_seq F x N)) -> AbsSmall (inject_Q e) (inject_Q (CS_seq F x N) [-]x). Proof. intros x e N H H0. apply expand_Q_R with (x := x) (e := e) (N := N). assumption. intros. apply H0. assumption. constructor. Qed. Lemma CS_seq_diagonal : forall a : CauchySeq R_COrdField', Cauchy_prop (fun m => let b := (CS_seq _ a m) in CS_seq F b (T b m)). Proof. intros. unfold Cauchy_prop in |- *. case a. intros a_ pa. intros. simpl in |- *. unfold Cauchy_prop in pa. cut (e [#] [0]). intro H0. cut {n : nat | (Twelve[/] e[//]H0) [-][1] [<] nring n}. intro H1. case H1. intros M H2. cut {N : nat | forall m : nat, N <= m -> AbsSmall (inject_Q e [/]SixNZ) (a_ m[-]a_ N)}. intro H3. case H3. intros N H4. exists (Nat.max N M). intros. apply ing_cancel_AbsSmall. rstepl (inject_Q e [/]ThreeNZ[+]inject_Q e [/]ThreeNZ[+]inject_Q e [/]ThreeNZ). rstepr (inject_Q (CS_seq F (a_ m) (T (a_ m) m)) [-]a_ m[+] (a_ (Nat.max N M) [-] inject_Q (CS_seq F (a_ (Nat.max N M)) (T (a_ (Nat.max N M)) (Nat.max N M)))) [+] (a_ m[-]a_ (Nat.max N M))). apply AbsSmall_plus. apply AbsSmall_plus. astepl (inject_Q (e [/]ThreeNZ)). apply AbsSmall_leEq_trans with (R := R_COrdField') (e1 := inject_Q (Four[*]one_div_succ m)). apply ing_le. apply leEq_transitive with (y := Four[*]one_div_succ (R:=F) M). apply mult_resp_leEq_lft. apply one_div_succ_resp_leEq. eauto with arith. apply less_leEq. apply pos_four. apply mult_cancel_leEq with (R := F) (z := (nring M[+][1]) [*] (Three:F)). apply mult_resp_pos. apply less_transitive_unfolded with (F := F) (y := Twelve[/] e[//]H0). apply mult_cancel_less with (R := F) (z := e). assumption. rstepl ([0]:F). rstepr (Twelve:F). apply nring_pos. apply Nat.lt_0_succ. apply plus_cancel_less with (R := F) (z := [--] ([1]:F)). rstepl ((Twelve[/] e[//]H0) [-][1]). rstepr (nring (R:=F) M). exact H2. apply nring_pos. apply Nat.lt_0_succ. unfold one_div_succ in |- *. unfold Snring in |- *. change (Four[*] ([1][/] nring M[+][1][//]nringS_ap_zero F M) [*] ((nring M[+][1]) [*]Three) [<=] e [/]ThreeNZ[*] ((nring M[+][1]) [*]Three)) in |- *. rstepl (Twelve:F). rstepr (e[*] (nring M[+][1])). apply mult_cancel_leEq with (R := F) (z := [1][/] e[//]H0). apply recip_resp_pos. assumption. rstepr (nring (R:=F) M[+][1]). apply plus_cancel_leEq_rht with (R := F) (z := [--] ([1]:F)). rstepl ((Twelve[/] e[//]H0) [-][1]). rstepr (nring (R:=F) M). apply less_leEq; exact H2. apply expand_Q_R_2 with (x := a_ m) (e := Four[*]one_div_succ (R:=F) m) (N := T (a_ m) m). apply mult_resp_pos. apply pos_four. apply one_div_succ_pos. intros. rstepl (one_div_succ (R:=F) m). apply modulus_property_2. assumption. apply eq_symmetric_unfolded. apply ing_div_three. astepl (inject_Q (e [/]ThreeNZ)). apply AbsSmall_leEq_trans with (R := R_COrdField') (e1 := inject_Q (Four[*]one_div_succ (R:=F) M)). apply less_leEq. apply ing_lt. apply mult_cancel_less with (R := F) (z := (nring M[+][1]) [*] (Three:F)). apply mult_resp_pos. apply less_transitive_unfolded with (F := F) (y := Twelve[/] e[//]H0). apply mult_cancel_less with (R := F) (z := e). assumption. rstepl ([0]:F). rstepr (Twelve:F). apply nring_pos. apply Nat.lt_0_succ. apply plus_cancel_less with (R := F) (z := [--] ([1]:F)). rstepl ((Twelve[/] e[//]H0) [-][1]). rstepr (nring (R:=F) M). exact H2. apply pos_three. unfold one_div_succ in |- *. unfold Snring in |- *. change (Four[*] ([1][/] nring M[+][1][//]nringS_ap_zero F M) [*] ((nring M[+][1]) [*]Three) [<] e [/]ThreeNZ[*] ((nring M[+][1]) [*]Three)) in |- *. rstepl (Twelve:F). rstepr (e[*] (nring M[+][1])). apply mult_cancel_less with (R := F) (z := [1][/] e[//]H0). apply recip_resp_pos. assumption. rstepr (nring (R:=F) M[+][1]). apply plus_cancel_less with (R := F) (z := [--] ([1]:F)). rstepl ((Twelve[/] e[//]H0) [-][1]). rstepr (nring (R:=F) M). exact H2. apply AbsSmall_minus. apply expand_Q_R_2 with (x := a_ (Nat.max N M)) (e := Four[*]one_div_succ (R:=F) M) (N := T (a_ (Nat.max N M)) (Nat.max N M)). apply mult_resp_pos. apply pos_four. apply one_div_succ_pos. intros. rstepl (one_div_succ (R:=F) M). apply AbsSmall_leEq_trans with (R := F) (e1 := one_div_succ (R:=F) (Nat.max N M)). apply one_div_succ_resp_leEq. auto with arith. apply modulus_property_2. assumption. apply eq_symmetric_unfolded. apply ing_div_three. rstepl (inject_Q e [/]SixNZ[+]inject_Q e [/]SixNZ). rstepr (a_ m[-]a_ N[+] (a_ N[-]a_ (Nat.max N M))). apply AbsSmall_plus. apply H4; eauto with arith. apply AbsSmall_minus. apply H4; eauto with arith. apply pa. apply mult_cancel_less with (R := R_COrdField') (z := Six:R_COrdField'). apply pos_six. rstepl ([0]:R_COrdField'). rstepr (inject_Q e). change (inject_Q ([0]:F) [<] inject_Q e) in |- *. apply ing_lt. assumption. apply F_is_archemaedian. apply Greater_imp_ap. assumption. Qed. (** ** Cauchy Completeness We can also define a limit operator. *) Lemma Q_dense_in_R : forall x, [0] [<] x -> {q : F | [0] [<] q | inject_Q q [<] x}. Proof. intros. cut (x [#] [0]). intro H0. cut {n : nat | ([1][/] x[//]H0) [<=] nring n}. intro H1. case H1. intros n H2. cut (nring (R:=F) (S n) [#] [0]). intro H3. exists ([1][/] nring (S n) [//]H3). apply recip_resp_pos. apply ing_cancel_less. change ([0] [<] inject_Q (nring (S n))) in |- *. apply less_leEq_trans with (R := R_COrdField') (y := [1][/] x[//]H0). apply recip_resp_pos. assumption. apply leEq_transitive with (inject_Q (nring n)). astepr (nring (R:=R_COrdField') n). assumption. apply ing_nring. astepl (nring (R:=R_COrdField') n). astepr (nring (R:=R_COrdField') (S n)). apply less_leEq; astepr (nring (R:=R_COrdField') n[+][1]); apply less_plusOne. apply ing_nring. apply ing_nring. cut (nring (R:=R_COrdField') (S n) [#] [0]). intro H4. astepl (inject_Q ([1]:F) [/] nring (S n) [//]H4). apply shift_div_less. apply nring_pos. auto with arith. astepl ([1]:R_COrdField'). apply shift_less_mult' with H0. assumption. eapply leEq_less_trans. apply H2. astepr (nring (R:=R_COrdField') n[+][1]); apply less_plusOne. apply ing_n. apply nringS_ap_zero. apply nringS_ap_zero. apply R_is_archemaedian. apply Greater_imp_ap. assumption. Qed. Definition LimR_CauchySeq (a : CauchySeq R_COrdField') := Build_CauchySeq _ _ (CS_seq_diagonal a). Theorem R_is_complete : forall a : CauchySeq R_COrdField', SeqLimit (R:=R_COrdField') a (LimR_CauchySeq a). Proof. intros. simpl in |- *. red in |- *. case a. intros a_ pa. intros e H. simpl in |- *. set (He := pos_ap_zero _ _ H) in *. elim (Q_dense_in_R (e [/]ThreeNZ)); [ intros q Hq Hinj | apply pos_div_three; auto ]. set (Hq' := pos_ap_zero _ _ Hq) in *. elim (F_is_archemaedian ((Four[/] q[//]Hq') [-][1])); intros M HM. unfold Cauchy_prop in pa. elim (pa (e [/]SixNZ)); [ intros N2 HN2 | apply pos_div_six; auto ]. elim (CS_seq_diagonal (Build_CauchySeq R_COrdField' a_ pa) (q [/]EightNZ)); [ intros N1 HN1 | apply pos_div_eight; auto ]. exists (Nat.max M (Nat.max N1 N2)). intros. rstepl (e [/]ThreeNZ[+]e [/]ThreeNZ[+]e [/]ThreeNZ). rstepr (a_ m[-]a_ (Nat.max M (Nat.max N1 N2)) [+] (a_ (Nat.max M (Nat.max N1 N2)) [-] inject_Q (CS_seq F (LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) (Nat.max M (Nat.max N1 N2)))) [+] (inject_Q (CS_seq F (LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) (Nat.max M (Nat.max N1 N2))) [-] LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa))). apply AbsSmall_plus. apply AbsSmall_plus. rstepl (e [/]SixNZ[+]e [/]SixNZ). rstepr (a_ m[-]a_ N2[+] (a_ N2[-]a_ (Nat.max M (Nat.max N1 N2)))). apply AbsSmall_plus. apply HN2; eauto with arith. apply AbsSmall_minus; apply HN2; eauto with arith. apply AbsSmall_leEq_trans with (R := R_COrdField') (e1 := inject_Q q). apply less_leEq; assumption. apply AbsSmall_minus. simpl in |- *. apply AbsSmall_leEq_trans with (R := R_COrdField') (e1 := Four[*] (one_div_succ (Nat.max M (Nat.max N1 N2)):R_COrdField')). apply less_leEq. apply leEq_less_trans with (R := R_COrdField') (y := Four[*]one_div_succ (R:=R_COrdField') M). apply mult_resp_leEq_lft. apply one_div_succ_resp_leEq. auto with arith. apply less_leEq; apply pos_four. apply mult_cancel_less with (R := R_COrdField') (z := nring M[+][1]:R_COrdField'). apply less_transitive_unfolded with (F := R_COrdField') (y := inject_Q (Four[/] q[//]Hq')). change (inject_Q ([0]:F) [<] inject_Q (Four[/] q[//]Hq')) in |- *. apply ing_lt. apply mult_cancel_less with (R := F) (z := q). assumption. rstepl ([0]:F). rstepr (Four:F). apply pos_four. apply shift_less_plus. astepl (inject_Q ((Four[/] q[//]Hq') [+][--][1])). astepr (inject_Q (nring M)). apply ing_lt. rstepl ((Four[/] q[//]Hq') [-][1]). exact HM. apply eq_symmetric_unfolded. apply ing_nring. unfold cg_minus in |- *. apply eq_transitive_unfolded with (inject_Q (Four[/] q[//]Hq') [+]inject_Q ( [--][1]:F)). apply ing_plus. apply plus_resp_eq. apply eq_transitive_unfolded with ( [--] (inject_Q ([1]:F))). apply ing_min. astepl ([0][-]inject_Q ([1]:F)). Step_final ([0][-] ([1]:R_COrdField')). unfold one_div_succ in |- *. unfold Snring in |- *. change (Four[*] ([1][/] nring M[+][1][//]nringS_ap_zero R_COrdField' M) [*] (nring M[+][1]) [<] inject_Q q[*] (nring M[+][1])) in |- *. rstepl (Four:R_COrdField'). astepr (inject_Q q[*]inject_Q (nring M[+][1])). astepl (inject_Q (Four:F)). astepr (inject_Q (q[*] (nring M[+][1]))). apply ing_lt. apply mult_cancel_less with (R := F) (z := [1][/] q[//]Hq'). apply recip_resp_pos. assumption. rstepl (Four[/] q[//]Hq'). rstepr (nring (R:=F) M[+][1]). apply plus_cancel_less with (R := F) (z := [--] ([1]:F)). rstepl ((Four[/] q[//]Hq') [-][1]). rstepr (nring (R:=F) M). exact HM. apply ing_mult. apply eq_symmetric_unfolded. apply ing_nring. apply mult_wd. apply ing_eq. apply eq_reflexive_unfolded. apply eq_transitive_unfolded with (inject_Q (nring M) [+]inject_Q ([1]:F)). apply ing_plus. astepl (inject_Q (nring M) [+][1]). astepl ([1][+]inject_Q (nring M)). astepr ([1][+]nring (R:=R_COrdField') M). apply plus_resp_eq. apply eq_symmetric_unfolded. apply ing_nring. astepl (inject_Q (Four[*]one_div_succ (R:=F) (Nat.max M (Nat.max N1 N2)))). apply expand_Q_R_2 with (x := a_ (Nat.max M (Nat.max N1 N2))) (e := Four[*]one_div_succ (R:=F) (Nat.max M (Nat.max N1 N2))) (N := T (a_ (Nat.max M (Nat.max N1 N2))) (Nat.max M (Nat.max N1 N2))). apply mult_resp_pos. apply pos_four. apply one_div_succ_pos. intros. rstepl (one_div_succ (R:=F) (Nat.max M (Nat.max N1 N2))). apply modulus_property_2. assumption. apply eq_transitive_unfolded with (inject_Q (Four:F) [*]inject_Q (one_div_succ (Nat.max M (Nat.max N1 N2)))). apply ing_mult. apply eq_transitive_unfolded with (Four[*]inject_Q (one_div_succ (Nat.max M (Nat.max N1 N2)))). apply mult_wd. apply eq_symmetric_unfolded. apply ing_nring. apply eq_reflexive_unfolded. apply mult_wd. apply eq_reflexive_unfolded. unfold one_div_succ in |- *. unfold Snring in |- *. astepl (inject_Q ([1][/] _[//]nringS_ap_zero _ (Nat.max M (Nat.max N1 N2)))). Step_final ([1][/] _[//]nringS_ap_zero R_COrdField' (Nat.max M (Nat.max N1 N2))). apply eq_transitive_unfolded with (inject_Q ([1]:F) [/] _[//]nringS_ap_zero _ (Nat.max M (Nat.max N1 N2))). apply eq_symmetric_unfolded. apply ing_n. apply div_wd. exact ing_One. apply eq_reflexive_unfolded. apply AbsSmall_leEq_trans with (R := R_COrdField') (e1 := inject_Q q). apply less_leEq; assumption. apply expand_Q_R_2 with (x := LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) (e := q) (N := Nat.max M (Nat.max N1 N2)). assumption. intros. rstepl (q [/]EightNZ[+]q [/]EightNZ). rstepr (CS_seq F (LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) m0[-] CS_seq F (LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) N1[+] (CS_seq F (LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) N1[-] CS_seq F (LimR_CauchySeq (Build_CauchySeq R_COrdField' a_ pa)) (Nat.max M (Nat.max N1 N2)))). apply AbsSmall_plus. unfold LimR_CauchySeq in |- *; simpl in |- *; apply HN1; eauto with arith. apply AbsSmall_minus. unfold LimR_CauchySeq in |- *; simpl in |- *; apply HN1; eauto with arith. Qed. Definition R_is_CReals := Build_is_CReals _ LimR_CauchySeq R_is_complete R_is_archemaedian. Definition R_as_CReals := Build_CReals _ _ R_is_CReals. End R_CReals. corn-8.20.0/reals/Cesaro.v000066400000000000000000000164501473720167500152750ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.Series. Require Export CoRN.reals.PosSeq. Section AlgebraBits. Lemma algebraic_transform1 : forall (l : IR) (x : nat->IR) (y : nat->IR) (H2 : seq_pos y) (m : nat), (seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S m)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) [=] ((seq_part_sum (fun k : nat => x k[*]y k) (S m)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)[-]l). Proof. intros. rstepr (((seq_part_sum (fun k : nat => x k[*]y k) (S m))[-] l[*](seq_part_sum y (S m)))[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). apply div_wd. 2: apply eq_reflexive_unfolded. unfold seq_part_sum. unfold cg_minus. astepr (Sum0 (G:=IR) (S m) (fun k : nat => x k[*]y k)[+] Sum0 (G:=IR) (S m) (fun k : nat => [--]l[*]y k)). astepr (Sum0 (G:=IR) (S m) (fun k : nat => x k[*]y k[+][--]l[*]y k)). apply Sum0_wd. intros. rational. apply (Sum0_plus_Sum0 IR (fun k : nat => x k [*] y k) (fun k : nat => [--] l [*] y k) (S m)). apply plus_resp_eq. astepr ([--]l [*] (Sum0 (G:=IR) (S m) y)). apply mult_distr_sum0_lft. Qed. Lemma algebraic_transform2 : forall (l : IR) (x : nat->IR) (y : nat->IR) (H2 : seq_pos y) (m N1: nat), (( seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)[+] Sum (S N1) m (fun k : nat => y k [*] (x k [-] l)) )[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) [=] (seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S m)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). Proof. intros. unfold seq_part_sum. apply div_wd. 2: apply eq_reflexive_unfolded. unfold Sum. unfold Sum1. rational. Qed. Lemma algebraic_transform3: forall (eps: IR) (y : nat->IR) (H2 : seq_pos y) (m N1: nat), (eps[/]TwoNZ [*] (Sum (S N1) m (fun k: nat => y k)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)) [=] (Sum (G:=IR) (S N1) m (fun k : nat => y k[*]eps [/]TwoNZ)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). Proof. intros. astepl ((eps[/]TwoNZ [*] (Sum (S N1) m (fun k: nat => y k)))[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). astepr (Sum (G:=IR) (S N1) m (fun k : nat => eps[/]TwoNZ[*]y k)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). apply div_wd. 2: apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. astepr (eps[/]TwoNZ[*]Sum (G:=IR) (S N1) m y). apply mult_distr_sum_lft. Qed. Lemma algebraic_estimate1 : forall (e l: IR) (H1 : [0] [<] e) (x : nat -> IR) (y : nat->IR) (H2 : seq_pos y) (m N1: nat) (H3 : S N1 <= m) (H4 : forall i, S N1 <= i -> i <= m -> AbsSmall e (x i[-]l)), AbsSmall (Sum (G:=IR) (S N1) m (fun k : nat => y k[*]e)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) (Sum (G:=IR) (S N1) m (fun k : nat => y k[*](x k[-]l))[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). Proof. intros. apply AbsSmall_cancel_mult with (seq_part_sum y (S m)). apply seq_pos_imp_sum_pos; auto. astepl (Sum (G:=IR) (S N1) m (fun k : nat => y k[*]e)). astepr (Sum (G:=IR) (S N1) m (fun k : nat => y k[*](x k[-]l))). apply sum_resp_AbsSmall; auto. intros. apply mult_resp_AbsSmall. apply less_leEq. apply H2. apply H4; auto. Qed. End AlgebraBits. Section Cesaro. Theorem cesaro_transform : forall (l : IR) (x : nat -> IR) (y : nat -> IR) (H1 : Cauchy_Lim_prop2 x l) (H2 : seq_pos y) (H3 : seq_inf_sum y), Cauchy_Lim_prop2 (fun n : nat => seq_part_sum (fun k : nat => x k [*] y k) (S n) [/](seq_part_sum y (S n)) [//] (seq_pos_imp_ap_zero y H2 n)) l. Proof. unfold Cauchy_Lim_prop2. intros. (* Find N such that forall m > N |x - l| < eps / 2*) assert (H4 : [0] [<] eps[/]TwoNZ). apply pos_div_two. auto. assert ({N : nat | forall m, N <= m -> AbsSmall (eps[/]TwoNZ) ((x m) [-] l) }). apply (H1 (eps[/]TwoNZ) H4). destruct X0 as [N1 H5]. (* find N1 such that a the following will be less that eps/2 also *) set (C := seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)); assert (H7 : { N : nat | forall m : nat, N <= m -> AbsSmall (eps[/]TwoNZ) (C [/](seq_part_sum y (S m)) [//] (seq_pos_imp_ap_zero y H2 m))}). apply (seq_inf_sum_imp_div_small y H3 H2 C (eps[/]TwoNZ) H4). destruct H7 as [N2 H7]. (* Now we can choose N as max of N1 and N2 *) exists (S (Nat.max (S N1) N2)). intros. astepr (seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S m)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). 2: apply (algebraic_transform1 l x y H2 m). astepr ((seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)[+] Sum (S N1) m (fun k : nat => y k [*] (x k [-] l)) )[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). 2: apply (algebraic_transform2 l x y H2 m). astepr (((seq_part_sum (fun k : nat => y k [*] (x k [-] l)) (S N1)) [/]seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m) [+] ((Sum (S N1) m (fun k : nat => y k [*] (x k [-] l)))[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)). apply AbsSmall_eps_div_two. (* We are ready for estimates *) apply H7. eauto with arith. apply AbsSmall_leEq_trans with ((Sum (S N1) m (fun k : nat => y k [*] eps [/]TwoNZ))[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). astepl (eps[/]TwoNZ [*] (Sum (S N1) m (fun k: nat => y k)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)). 2: apply algebraic_transform3. astepr (eps[/]TwoNZ[*][1]). apply mult_resp_leEq_lft. cut (AbsSmall [1] (Sum (G:=IR) (S N1) m (fun k : nat => y k)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m)). unfold AbsSmall. tauto. apply seq_inf_sum_ratio_bound. eauto with arith. apply less_leEq; auto. apply algebraic_estimate1; auto. eauto with arith. intros. apply H5. auto with arith. Qed. Theorem cesaro_sum : forall (l : IR) (x : nat -> IR) (H1 : Cauchy_Lim_prop2 x l), Cauchy_Lim_prop2 (fun n : nat => seq_part_sum x (S n) [/]nring (S n)[//](nringS_ap_zero _ n)) l. Proof. intros. set (y := (fun k : nat => [1] : IR)). assert (H2 : seq_pos y). apply One_seq_is_pos. assert (H3 : seq_inf_sum y). apply One_seq_is_inf_sum. apply Cauchy_Lim_prop2_wd' with (fun n : nat => seq_part_sum (fun k : nat => x k[*] y k) (S n) [/]seq_part_sum y (S n)[//]seq_pos_imp_ap_zero y H2 n). apply cesaro_transform; auto. exists 0. intros. apply div_wd. unfold seq_part_sum. apply Sum0_wd. intros. unfold y. algebra. apply One_part_sum. Qed. End Cesaro. corn-8.20.0/reals/IVT.v000066400000000000000000000403051473720167500145170ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.CPoly_Contin. Section Nested_Intervals. (** * Intermediate Value Theorem ** Nested intervals %\begin{convention}% Let [a,b:nat->IR] be sequences such that: - [a] is increasing; - [b] is decreasing; - [forall (i:nat), (a i) [<] (b i)]; - for every positive real number [eps], there is an [i] such that [(b i) [<] (a i) [+]eps]. %\end{convention}% *) Variables a b : nat -> IR. Hypothesis a_mon : forall i : nat, a i [<=] a (S i). Hypothesis b_mon : forall i : nat, b (S i) [<=] b i. Hypothesis a_b : forall i : nat, a i [<] b i. Hypothesis b_a : forall eps : IR, [0] [<] eps -> {i : nat | b i [<=] a i[+]eps}. Lemma a_mon' : forall i j : nat, i <= j -> a i [<=] a j. Proof. intros. apply local_mon'_imp_mon'; auto. Qed. Lemma b_mon' : forall i j : nat, i <= j -> b j [<=] b i. Proof. intros. set (b' := fun i : nat => [--] (b i)) in *. astepl ( [--][--] (b j)). astepr ( [--][--] (b i)). fold (b' i) (b' j) in |- *. apply inv_resp_leEq. apply local_mon'_imp_mon'. unfold b' in |- *; intro; apply inv_resp_leEq; auto. auto. Qed. Lemma a_b' : forall i j : nat, a i [<] b j. Proof. intros. elim (le_lt_dec i j); intro. apply leEq_less_trans with (a j). apply a_mon'. auto. auto. apply less_leEq_trans with (b i). auto. apply b_mon'. auto with arith. Qed. Lemma intervals_cauchy : Cauchy_prop a. Proof. unfold Cauchy_prop in |- *. unfold AbsSmall in |- *. intro eps. intros H. elim (b_a eps H). intro n. intros. exists n. intro i. intros. split; apply less_leEq. apply less_leEq_trans with ZeroR. astepr ( [--]ZeroR). apply inv_resp_less. auto. astepl (a n[-]a n). apply minus_resp_leEq. apply a_mon'. auto. apply shift_minus_less'. apply less_leEq_trans with (b n). apply a_b'. auto. Qed. (* begin hide *) Let a' := Build_CauchySeq _ a intervals_cauchy. (* end hide *) Lemma Cnested_intervals_limit : {z : IR | forall i, a i [<=] z | forall i, z [<=] b i}. Proof. exists (Lim a'). intros. rewrite -> leEq_def in |- *. unfold Not in |- *. intros. elim (Lim_less_so_seq_less a' (a i)). intro n. intros H0. elim (le_lt_dec n i); intro H1. cut (Not (a i [<] a i)). intro H2. unfold Not in H1. elim H2. apply H0. auto. apply less_irreflexive_unfolded. cut (forall i j : nat, i <= j -> a i [<=] a j). intro a_mon''. pose (c:=a_mon'' i n). rewrite -> leEq_def in c. apply c. auto with arith. apply H0. auto. intros. apply a_mon'; auto. auto. intros i. rewrite -> leEq_def. unfold Not. intros H. elim (less_Lim_so_less_seq a' (b i) H). intro n. intros H0. elim (le_lt_dec n i); intro H1. cut (Not (a i [<] b i)). unfold Not in |- *. intro. elim H2. auto. apply less_antisymmetric_unfolded. apply H0. auto. cut (Not (a n [<] b n)). unfold Not in |- *. intro H2. apply H2. auto. apply less_antisymmetric_unfolded. apply leEq_less_trans with (b i). apply b_mon'. auto with arith. apply H0. auto. Qed. (** %\begin{convention}% Let [f] be a continuous real function. %\end{convention}% *) Variable f : CSetoid_un_op IR. Hypothesis f_contin : contin f. Lemma f_contin_pos : forall z : IR, [0] [<] f z -> {eps : IR | [0] [<] eps | forall x, x [<=] z[+]eps -> z [<=] x[+]eps -> [0] [<] f x}. Proof. intros z H. unfold contin in f_contin. unfold continAt in f_contin. unfold funLim in f_contin. unfold AbsSmall in f_contin. elim (f_contin z (f z [/]TwoNZ) (pos_div_two _ _ H)). intro eps. intros H1 H2. exists eps. auto. intros. elim (H2 x). intros H5 H6. astepl (f z[-]f z). apply shift_minus_less. apply shift_less_plus'. apply leEq_less_trans with (f z [/]TwoNZ). auto. apply pos_div_two'. auto. split. apply shift_leEq_minus. rstepl (x[-]eps). apply shift_minus_leEq. auto. apply shift_minus_leEq. astepr (x[+]eps). auto. Qed. Lemma f_contin_neg : forall z : IR, f z [<] [0] -> {eps : IR | [0] [<] eps | forall x, x [<=] z[+]eps -> z [<=] x[+]eps -> f x [<] [0]}. Proof. intros. unfold contin in f_contin. unfold continAt in f_contin. unfold funLim in f_contin. unfold AbsSmall in f_contin. cut ([0] [<] [--] (f z)). intro H0. elim (f_contin z ( [--] (f z) [/]TwoNZ) (pos_div_two _ _ H0)). intro eps. intros H2 H3. exists eps. auto. intros. elim (H3 x). intros H6 H7. rstepr (f z[-][--][--] (f z)). apply shift_less_minus'. apply shift_plus_less. apply less_leEq_trans with (f z [/]TwoNZ). astepl (f z). apply inv_cancel_less. rstepl ( [--] (f z) [/]TwoNZ). apply pos_div_two'. auto. rstepl ( [--] ( [--] (f z) [/]TwoNZ)). auto. split. apply shift_leEq_minus. rstepl (x[-]eps). apply shift_minus_leEq. auto. apply shift_minus_leEq. astepr (x[+]eps). auto. astepl ( [--]ZeroR). apply inv_resp_less. auto. Qed. (** Assume also that [forall i, f (a i) [<=] [0] [<=] f (b i)]. *) Hypothesis f_a : forall i, f (a i) [<=] [0]. Hypothesis f_b : forall i, [0] [<=] f (b i). Lemma Cnested_intervals_zero : {z : IR | a 0 [<=] z /\ z [<=] b 0 /\ f z [=] [0]}. Proof. elim Cnested_intervals_limit. intro z. intros H0 H1. exists z. split. auto. split. auto. apply not_ap_imp_eq. unfold Not in |- *. intros H2. elim (ap_imp_less _ _ _ H2); intros H3. elim (f_contin_neg z H3). intro eps. intros H5 H6. elim (b_a eps). intro i. intros H7. cut (b i [<=] z[+]eps). intro. cut (z [<=] b i[+]eps). intro. pose (c:= f_b i). rewrite -> leEq_def in c. apply c. apply H6. auto. auto. apply leEq_transitive with (b i). auto. astepl (b i[+][0]). apply plus_resp_leEq_lft. apply less_leEq. auto. apply leEq_transitive with (a i[+]eps). auto. apply plus_resp_leEq. auto. auto. elim (f_contin_pos z H3). intro eps. intros H5 H6. elim (b_a eps). intro i. intros H7. cut (a i [<=] z[+]eps). intro. cut (z [<=] a i[+]eps). intro. pose (c:= f_a i). rewrite -> leEq_def in c; apply c. apply H6. auto. auto. apply leEq_transitive with (b i). auto. auto. apply leEq_transitive with z. auto. astepl (z[+][0]). apply less_leEq. apply plus_resp_less_lft. auto. auto. Qed. End Nested_Intervals. Section Bisection. (** ** Bissections *) Variable f : CSetoid_un_op IR. Hypothesis f_apzero_interval : forall a b, a [<] b -> {c : IR | a [<=] c /\ c [<=] b | f c [#] [0]}. Variables a b : IR. Hypothesis a_b : a [<] b. Hypothesis f_a : f a [<=] [0]. Hypothesis f_b : [0] [<=] f b. (** %\begin{convention}% Let [Small] denote [Two[/]ThreeNZ], [lft] be [(Two[*]a[+]b) [/]ThreeNZ] and [rht] be [(a[+]Two[*]b) [/]ThreeNZ]. %\end{convention}% *) (* begin hide *) Let Small : IR := Two [/]ThreeNZ. Let lft := (Two[*]a[+]b) [/]ThreeNZ. Let rht := (a[+]Two[*]b) [/]ThreeNZ. (* end hide *) Lemma a_lft : a [<] lft. Proof. unfold lft in |- *. apply shift_less_div. apply pos_three. rstepl (Two[*]a[+]a). apply plus_resp_less_lft. auto. Qed. Lemma rht_b : rht [<] b. Proof. unfold rht in |- *. apply shift_div_less. apply pos_three. rstepr (b[+]Two[*]b). apply plus_resp_less_rht. auto. Qed. Lemma lft_rht : lft [<] rht. Proof. unfold lft in |- *. unfold rht in |- *. apply div_resp_less_rht. rstepl (a[+]b[+]a). rstepr (a[+]b[+]b). apply plus_resp_less_lft. auto. apply pos_three. Qed. Lemma smaller_lft : rht[-]a [=] Small[*] (b[-]a). Proof. unfold Small in |- *. unfold rht in |- *. rational. Qed. Lemma smaller_rht : b[-]lft [=] Small[*] (b[-]a). Proof. unfold Small in |- *. unfold lft in |- *. rational. Qed. Hint Resolve smaller_lft smaller_rht: algebra. Lemma Cbisect' : {a' : IR | {b' : IR | a' [<] b' | a [<=] a' /\ b' [<=] b /\ b'[-]a' [<=] Small[*] (b[-]a) /\ f a' [<=] [0] /\ [0] [<=] f b'}}. Proof. elim (f_apzero_interval lft rht lft_rht). intro c. intro H. elim H. intros H0 H2 H3. cut ({f c [<=] [0]} + {[0] [<=] f c}). intro H4; inversion_clear H4. exists c. exists b. apply leEq_less_trans with rht. auto. apply rht_b. split. apply leEq_transitive with lft. apply less_leEq. apply a_lft. auto. split. apply leEq_reflexive. split. astepr (b[-]lft). apply minus_resp_leEq_rht. auto. split. auto. auto. exists a. exists c. apply less_leEq_trans with lft. apply a_lft. auto. split. apply leEq_reflexive. split. apply less_leEq. apply leEq_less_trans with rht. auto. apply rht_b. split. astepr (rht[-]a). apply minus_resp_leEq. auto. split. auto. auto. elim (ap_imp_less _ _ _ H3); intros. left. apply less_leEq. auto. right. apply less_leEq. auto. Qed. End Bisection. Section Bisect_Interval. Variable f : CSetoid_un_op IR. Hypothesis C_f_apzero_interval : forall a b, a [<] b -> {c : IR | a [<=] c /\ c [<=] b | f c [#] [0]}. (* begin hide *) Let Small : IR := Two [/]ThreeNZ. (* end hide *) Record bisect_interval : Type := {interval_lft : IR; interval_rht : IR; interval_lft_rht : interval_lft [<] interval_rht; interval_f_lft : f interval_lft [<=] [0]; interval_f_rht : [0] [<=] f interval_rht}. Lemma Cbisect_exists : forall I : bisect_interval, {I' : bisect_interval | interval_rht I'[-]interval_lft I' [<=] Small[*] (interval_rht I[-]interval_lft I) /\ interval_lft I [<=] interval_lft I' /\ interval_rht I' [<=] interval_rht I}. Proof. intros. elim (Cbisect' f C_f_apzero_interval _ _ (interval_lft_rht I) ( interval_f_lft I) (interval_f_rht I)). intro lft. intro H. elim H. intro rht. intros H1 H2. elim H2. intros H3 H4. elim H4. intros H5 H6. elim H6. intros H7 H8. elim H8. intros H9 H10. exists (Build_bisect_interval lft rht H1 H9 H10). simpl in |- *. unfold Small in |- *. split. auto. split. auto. auto. Qed. Definition bisect I : bisect_interval := ProjT1 (Cbisect_exists I). Lemma bisect_prop : forall I : bisect_interval, interval_rht (bisect I) [-]interval_lft (bisect I) [<=] Small[*] (interval_rht I[-]interval_lft I) /\ interval_lft I [<=] interval_lft (bisect I) /\ interval_rht (bisect I) [<=] interval_rht I. Proof. intros. unfold bisect in |- *. apply proj2_sigT. Qed. End Bisect_Interval. Section IVT_Op. (** ** IVT for operations Same conventions as before. *) Variable f : CSetoid_un_op IR. Hypothesis f_contin : contin f. Hypothesis f_apzero_interval : forall a b, a [<] b -> {c : IR | a [<=] c /\ c [<=] b | f c [#] [0]}. Variables a b : IR. Hypothesis a_b : a [<] b. Hypothesis f_a : f a [<=] [0]. Hypothesis f_b : [0] [<=] f b. (* begin hide *) Let Small : IR := Two [/]ThreeNZ. (* end hide *) Fixpoint interval_sequence (n : nat) : bisect_interval f := match n with | O => Build_bisect_interval f a b a_b f_a f_b | S m => bisect f f_apzero_interval (interval_sequence m) end. Let a_ (i : nat) := interval_lft _ (interval_sequence i). Let b_ (i : nat) := interval_rht _ (interval_sequence i). Lemma intervals_smaller : forall i, b_ i[-]a_ i [<=] Small[^]i[*] (b[-]a). Proof. intros. induction i as [| i Hreci]; intros. unfold a_ in |- *. unfold b_ in |- *. simpl in |- *. rstepr (b[-]a). apply leEq_reflexive. apply leEq_transitive with (Small[*] (b_ i[-]a_ i)). elim (bisect_prop f f_apzero_interval (interval_sequence i)). intros H H0. elim H0; intros H1 H2. auto. simpl in |- *. replace (nexp _ i Small) with (Small[^]i). 2: auto. rstepr (Small[*] (Small[^]i[*] (b[-]a))). apply mult_resp_leEq_lft. auto. apply less_leEq. unfold Small in |- *. apply div_resp_pos. apply pos_three. apply pos_two. Qed. Lemma intervals_small'' : forall i : nat, Small[^]i[*]nring i [<=] [1]. Proof. intros. apply mult_cancel_leEq with (Three[^]i:IR). apply nexp_resp_pos. apply pos_three. astepr (Three[^]i:IR). apply leEq_wdl with (nring i[*]Two[^]i:IR). 2: rstepr (nring i[*] (Small[^]i[*]Three[^]i)). 2: astepr (nring i[*] (Small[*]Three) [^]i). 2: cut (Small[*]Three [=] Two); algebra. 2: unfold Small in |- *; rational. induction i as [| i Hreci]. simpl in |- *. astepl ZeroR. apply less_leEq. apply pos_one. elim (zerop i); intro y. rewrite y. simpl in |- *. rstepl (Two:IR). rstepr (Three:IR). apply less_leEq. apply two_less_three. elim (le_lt_eq_dec _ _ (proj1 (Nat.le_succ_l _ _) y)); intros H0. apply mult_cancel_leEq with (nring i:IR). astepl (nring 0:IR). apply nring_less. auto. apply leEq_wdl with (nring (S i) [*]Two[*] (nring i[*]Two[^]i:IR)). 2: simpl in |- *; rational. apply leEq_wdr with (nring i[*]Three[*]Three[^]i:IR). 2: simpl in |- *; rational. apply leEq_transitive with (nring i[*]Three[*] (nring i[*]Two[^]i:IR)). apply mult_resp_leEq_rht. simpl in |- *. rstepl (nring i[*]Two[+] (Two:IR)). rstepr (nring i[*]Two[+] (nring i:IR)). apply plus_resp_leEq_lft. elim (le_lt_eq_dec _ _ (proj1 (Nat.le_succ_l _ _) H0)); intros H1. apply less_leEq. apply nring_less. auto. rewrite <- H1. apply leEq_reflexive. apply less_leEq. apply mult_resp_pos. astepl (nring 0:IR). apply nring_less. auto. apply nexp_resp_pos. apply pos_two. apply mult_resp_leEq_lft. auto. apply less_leEq. apply mult_resp_pos. astepl (nring 0:IR). apply nring_less. auto. apply pos_three. rewrite <- H0. rstepl (nring (R:=IR) 8). rstepr (nring (R:=IR) 9). apply nring_leEq. auto. Qed. Lemma intervals_small' : forall eps, [0] [<] eps -> {i : nat | Small[^]i[*] (b[-]a) [<=] eps}. Proof. intros. cut (eps [#] [0]). intro H0. elim (Archimedes (b[-]a[/] eps[//]H0)). intro i. intros H1. exists i. astepr (eps[*][1]). apply shift_leEq_mult' with H0. auto. apply leEq_transitive with (Small[^]i[*]nring i). astepl (Small[^]i[*] (b[-]a[/] eps[//]H0)). apply mult_resp_leEq_lft. auto. apply nexp_resp_nonneg. apply less_leEq. astepl (ZeroR [/]ThreeNZ). unfold Small in |- *. apply div_resp_less_rht. apply pos_two. apply pos_three. apply intervals_small''. apply Greater_imp_ap. auto. Qed. Lemma intervals_small : forall eps, [0] [<] eps -> {i : nat | b_ i [<=] a_ i[+]eps}. Proof. intros eps H. elim (intervals_small' eps H). intro i. intros. exists i. apply shift_leEq_plus'. apply leEq_transitive with (Small[^]i[*] (b[-]a)). apply intervals_smaller. auto. Qed. Lemma Civt_op : {z : IR | a [<=] z /\ z [<=] b /\ f z [=] [0]}. Proof. cut (forall i : nat, a_ i [<=] a_ (S i)). intro H. cut (forall i : nat, b_ (S i) [<=] b_ i). intro H0. cut (forall i : nat, a_ i [<] b_ i). intro H1. cut (forall i : nat, f (a_ i) [<=] [0]). intro H2. cut (forall i : nat, [0] [<=] f (b_ i)). intro H3. elim (Cnested_intervals_zero a_ b_ H H0 H1 intervals_small f f_contin H2 H3). intro z. intro H4. exists z. exact H4. intros. exact (interval_f_rht _ (interval_sequence i)). intros. exact (interval_f_lft _ (interval_sequence i)). intros. exact (interval_lft_rht _ (interval_sequence i)). intros. elim (bisect_prop f f_apzero_interval (interval_sequence i)). intros H0 H1. elim H1. intros H2 H3. unfold b_ in |- *. simpl in |- *. assumption. intros. elim (bisect_prop f f_apzero_interval (interval_sequence i)). intros H H0. elim H0. intros H1 H2. unfold a_ in |- *. simpl in |- *. auto. Qed. End IVT_Op. Section IVT_Poly. (** ** IVT for polynomials *) Lemma Civt_poly : forall f : cpoly_cring IR, f [#] [0] -> forall a b, a [<] b -> f ! a [<=] [0] -> [0] [<=] f ! b -> {x : IR | a [<=] x /\ x [<=] b /\ f ! x [=] [0]}. Proof. intros. cut ({x : IR | a [<=] x /\ x [<=] b /\ cpoly_csetoid_op _ f x [=] [0]}). intro. auto. apply Civt_op; auto. apply cpoly_op_contin. intros. change {c : IR | a0 [<=] c /\ c [<=] b0 | f ! c [#] [0]} in |- *. apply Cpoly_apzero_interval. auto. auto. Qed. End IVT_Poly. corn-8.20.0/reals/Intervals.v000066400000000000000000001006001473720167500160170ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.algebra.CSetoidInc. Require Export CoRN.reals.RealLists. Section Intervals. (** * Intervals In this section we define (compact) intervals of the real line and some useful functions to work with them. ** Definitions We start by defining the compact interval [[a,b]] as being the set of points less or equal than [b] and greater or equal than [a]. We require [a [<=] b], as we want to work only in nonempty intervals. *) Definition compact (a b : IR) (Hab : a [<=] b) (x : IR) := a [<=] x and x [<=] b. (** %\begin{convention}% Let [a,b : IR] and [Hab : a [<=] b]. %\end{convention}% As expected, both [a] and [b] are members of [[a,b]]. Also they are members of the interval [[Min(a,b),Max(a,b)]]. *) Variables a b : IR. Hypothesis Hab : a [<=] b. Lemma compact_inc_lft : compact a b Hab a. Proof. intros; split; [ apply leEq_reflexive | auto ]. Qed. Lemma compact_inc_rht : compact a b Hab b. Proof. intros; split; [ auto | apply leEq_reflexive ]. Qed. Lemma compact_Min_lft : forall Hab', compact (Min a b) (Max a b) Hab' a. Proof. split; [ apply Min_leEq_lft | apply lft_leEq_Max ]. Qed. Lemma compact_Min_rht : forall Hab', compact (Min a b) (Max a b) Hab' b. Proof. split; [ apply Min_leEq_rht | apply rht_leEq_Max ]. Qed. (** As we will be interested in taking functions with domain in a compact interval, we want this predicate to be well defined. *) Lemma compact_wd : pred_wd IR (compact a b Hab). Proof. intros; red in |- *; intros x y H H0. inversion_clear H; split. apply leEq_wdr with x; assumption. apply leEq_wdl with x; assumption. Qed. (** Also, it will sometimes be necessary to rewrite the endpoints of an interval. *) Lemma compact_wd' : forall (a' b' : IR) Hab' (x : IR), a [=] a' -> b [=] b' -> compact a b Hab x -> compact a' b' Hab' x. Proof. intros a' b' Hab' x H H0 H1. inversion_clear H1; split. apply leEq_wdl with a; auto. apply leEq_wdr with b; auto. Qed. (** As we identify subsets with predicates, inclusion is simply implication. *) (** Finally, we define a restriction operator that takes a function [F] and a well defined predicate [P] included in the domain of [F] and returns the restriction $F|_P$# of F to P#. *) Definition Frestr F P (HP : pred_wd IR P) (H : included P (Dom F)) : PartIR. Proof. intros. apply Build_PartFunct with P (fun (x : IR) (Hx : P x) => Part F x (H x Hx)). assumption. intros. exact (pfstrx _ _ _ _ _ _ X). Defined. End Intervals. Notation Compact := (compact _ _). Arguments Frestr [F P]. Notation FRestr := (Frestr (compact_wd _ _ _)). Section More_Intervals. Lemma included_refl' : forall a b Hab Hab', included (compact a b Hab) (compact a b Hab'). Proof. intros. red in |- *; intros x H. inversion_clear H; split; auto. Qed. (** We prove some inclusions of compact intervals. *) Definition compact_map1 : forall a b Hab Hab', included (compact (Min a b) (Max a b) Hab') (compact a b Hab). Proof. intros. red in |- *; intros x H. red in |- *; red in H. inversion_clear H. split. eapply leEq_wdl; [ apply H0 | apply leEq_imp_Min_is_lft; auto ]. eapply leEq_wdr; [ apply H1 | apply leEq_imp_Max_is_rht; auto ]. Defined. Definition compact_map2 : forall a b Hab Hab', included (compact a b Hab) (compact (Min a b) (Max a b) Hab'). Proof. intros. red in |- *; intros x H. red in |- *; red in H. inversion_clear H. split. eapply leEq_transitive; [ apply Min_leEq_lft | apply H0 ]. eapply leEq_transitive; [ apply H1 | apply rht_leEq_Max ]. Defined. Definition compact_map3 : forall a b e Hab Hab', [0] [<] e -> included (compact a (b[-]e) Hab') (compact a b Hab). Proof. intros; red in |- *. try rename X into H. intros x H0. inversion_clear H0; split. auto. eapply leEq_transitive. apply H2. apply shift_minus_leEq. apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; assumption. Qed. End More_Intervals. #[global] Hint Resolve included_refl' compact_map1 compact_map2 compact_map3 : included. Section Totally_Bounded. (** ** Totally Bounded Totally bounded sets will play an important role in what is to come. The definition (equivalent to the classical one) states that [P] is totally bounded iff %\[\forall_{\varepsilon>0}\exists_{x_1,\ldots,x_n}\forall_{y\in P} \exists_{1\leq i\leq n}|y-x_i|<\varepsilon\]%#∀e>0 ∃x1,...,xn∀y∈P∃ 1≤i≤n.|y-xi|<e#. Notice the use of lists for quantification. *) Definition totally_bounded (P : IR -> CProp) : CProp := {x : IR | P x} and (forall e, [0] [<] e -> {l : list IR | forall x, member x l -> P x | forall x, P x -> {y : IR | member y l | AbsSmall e (x[-]y)}}). (** This definition is classically, but not constructively, equivalent to the definition of compact (if completeness is assumed); the next result, classically equivalent to the Heine-Borel theorem, justifies that we take the definition of totally bounded to be the relevant one and that we defined compacts as we did. *) Lemma compact_is_totally_bounded : forall a b Hab, totally_bounded (compact a b Hab). Proof. intros; split. exists a. apply compact_inc_lft. cut (forall (n : nat) (a b e : IR) (Hab : a [<=] b) (He : [0] [<] e), (b[-]a[/] e[//]pos_ap_zero _ _ He) [<=] nring n -> (2 <= n -> nring n[-]Two [<=] (b[-]a[/] e[//]pos_ap_zero _ _ He)) -> {l : list IR | forall x : IR, member x l -> compact a b Hab x | forall x : IR, compact a b Hab x -> {y : IR | member y l | AbsIR (x[-]y) [<=] e}}). intros H e He. elim (str_Archimedes (b[-]a[/] _[//]pos_ap_zero _ _ (pos_div_two _ _ He))). intros n Hn. inversion_clear Hn. elim (H n a b _ Hab (pos_div_two _ _ He)). intros l Hl' Hl. 2: assumption. 2: assumption. exists l. assumption. intros x Hx; elim (Hl x Hx). intros y Hy Hy'. exists y. assumption. apply AbsIR_imp_AbsSmall. apply leEq_transitive with (e [/]TwoNZ). assumption. apply less_leEq; apply pos_div_two'; assumption. apply shift_leEq_div; [ apply pos_div_two; assumption | apply shift_leEq_minus ]. rstepl a; assumption. clear Hab a b; intro n; induction n as [| n Hrecn]. intros. exists (a::nil). intros x H1. inversion H1 as [H2 | H2]. elim H2. apply compact_wd with a; algebra. apply compact_inc_lft. intros. exists a. right; algebra. apply leEq_wdl with ZeroR. apply less_leEq; auto. astepl (AbsIR [0]). apply AbsIR_wd. apply leEq_imp_eq. try rename X into H1. apply shift_leEq_minus; astepl a; elim H1; auto. apply shift_minus_leEq. apply leEq_transitive with b. try rename X into H1. elim H1; auto. apply shift_leEq_plus. apply mult_cancel_leEq with ([1][/] _[//]pos_ap_zero _ _ He). apply recip_resp_pos; auto. astepr ZeroR. rstepl (b[-]a[/] _[//]pos_ap_zero _ _ He); auto. clear Hrecn; induction n as [| n Hrecn]. intros. exists (a::nil). intros x H1. inversion_clear H1 as [H2|]. elim H2. apply compact_wd with a; [ apply compact_inc_lft | algebra ]. intros x Hx; inversion_clear Hx. exists a. simpl in |- *; right; algebra. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply leEq_transitive with (b[-]a). apply minus_resp_leEq; assumption. rstepr (e[*]nring 1); eapply shift_leEq_mult'; [ assumption | apply H ]. apply shift_leEq_minus; astepl a. assumption. clear Hrecn; induction n as [| n Hrecn]. intros. set (enz := pos_ap_zero _ _ He) in *. exists (cons ((a[+]b) [/]TwoNZ) (@nil IR)). intros x H1. inversion_clear H1 as [H2|]. inversion_clear H2. apply compact_wd with ((a[+]b) [/]TwoNZ); [ split | algebra ]. astepl (a[+][0]); apply shift_plus_leEq'. apply mult_cancel_leEq with (Two:IR). apply pos_two. astepl ZeroR. rstepr (b[-]a). apply shift_leEq_minus; astepl a; auto. astepr (b[+][0]); apply shift_leEq_plus'. apply mult_cancel_leEq with (Two:IR). apply pos_two. astepr ZeroR. rstepl (a[-]b). apply shift_minus_leEq; astepr b; auto. intros. exists ((a[+]b) [/]TwoNZ). right; algebra. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Abs_Max. apply shift_minus_leEq; apply Max_leEq; apply shift_leEq_plus'; apply leEq_Min. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. apply shift_minus_leEq. apply leEq_transitive with b. try rename X into H1. elim H1; auto. apply shift_leEq_plus'. apply mult_cancel_leEq with (Two:IR). apply pos_two. apply shift_leEq_mult' with enz. auto. rstepl (b[-]a[/] e[//]enz); auto. apply leEq_transitive with a. 2: try rename X into H1; elim H1; auto. apply shift_minus_leEq; apply shift_leEq_plus'. apply mult_cancel_leEq with (Two:IR). apply pos_two. apply shift_leEq_mult' with enz. auto. rstepl (b[-]a[/] e[//]enz); auto. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; auto. intros. set (b' := b[-]e) in *. cut (a [<=] b'); intros. elim (Hrecn a b' e H1 He). intros l Hl' Hl. exists (cons b' l). intros. unfold b' in H1; apply compact_map3 with (e := e) (Hab' := H1) (b := b). assumption. try rename X into H2. simpl in H2; inversion_clear H2. apply Hl'; assumption. apply compact_wd with b'; [ apply compact_inc_rht | algebra ]. intros. cut (x [<] b' or b'[-]e [<] x). intros H3. inversion_clear H3. cut (compact a b' H1 x). intros H3. elim (Hl x H3). intros y Hy Hy'. exists y. left; assumption. auto. try rename X into H2. inversion_clear H2; split. assumption. apply less_leEq; auto. exists b'. right; algebra. simpl in |- *; unfold ABSIR in |- *. apply Max_leEq. apply shift_minus_leEq; unfold b' in |- *. rstepr b. try rename X into H2. elim H2; auto. rstepl (b'[-]x); apply shift_minus_leEq; apply shift_leEq_plus'; apply less_leEq; assumption. cut (b'[-]e [<] x or x [<] b'); [ tauto | apply less_cotransitive_unfolded ]. apply shift_minus_less; apply shift_less_plus'; astepl ZeroR; assumption. unfold b' in |- *. rstepl ((b[-]a[/] e[//]pos_ap_zero _ _ He) [-][1]). apply shift_minus_leEq. astepr (nring (R:=IR) (S (S (S n)))); auto. intro. unfold b' in |- *. rstepr ((b[-]a[/] e[//]pos_ap_zero _ _ He) [-][1]). apply shift_leEq_minus. rstepl (nring (R:=IR) (S (S n)) [+][1][-]Two). auto with arith. unfold b' in |- *. apply shift_leEq_minus; apply shift_plus_leEq'. astepl ([1][*]e); apply shift_mult_leEq with (pos_ap_zero _ _ He). auto. apply leEq_transitive with (nring (R:=IR) (S (S (S n))) [-]Two). apply shift_leEq_minus; rstepl (Three:IR); apply nring_leEq; auto with arith. auto with arith. Qed. (** Suprema and infima will be needed throughout; we define them here both for arbitrary subsets of [IR] and for images of functions. *) Definition set_glb_IR (P : IR -> CProp) a : CProp := (forall x, P x -> a [<=] x) and (forall e, [0] [<] e -> {x : IR | P x | x[-]a [<] e}). Definition set_lub_IR (P : IR -> CProp) a : CProp := (forall x, P x -> x [<=] a) and (forall e, [0] [<] e -> {x : IR | P x | a[-]x [<] e}). Definition fun_image F (P : IR -> CProp) x : CProp := {y : IR | P y and Dom F y and (forall Hy, F y Hy [=] x)}. Definition fun_glb_IR F (P : IR -> CProp) a : CProp := set_glb_IR (fun_image F P) a. Definition fun_lub_IR F (P : IR -> CProp) a : CProp := set_lub_IR (fun_image F P) a. (* begin hide *) Let aux_seq_lub (P : IR -> CProp) (H : totally_bounded P) : forall k : nat, Build_SubCSetoid IR (fun x : IR => P x and (forall y : IR, P y -> y[-]x [<=] Two[*]one_div_succ k)). Proof. elim H; clear H; intros non_empty H k. elim (H (one_div_succ k) (one_div_succ_pos IR k)). intros l Hl' Hl; clear H. cut {y : IR | member y l | maxlist l[-]one_div_succ k [<=] y}. intro H; inversion_clear H. 2: apply maxlist_leEq_eps. 2: inversion_clear non_empty. 2: elim (Hl x). 2: intros. 2: exists x0. 2: tauto. 2: assumption. 2: apply one_div_succ_pos. exists x; split. apply Hl'; assumption. intros y Hy. elim (Hl y Hy). intros z Hz Hz'. rstepl (y[-]z[+] (z[-]x)). rstepr (one_div_succ (R:=IR) k[+]one_div_succ k). apply plus_resp_leEq_both. apply leEq_transitive with (AbsIR (y[-]z)). apply leEq_AbsIR. apply AbsSmall_imp_AbsIR; assumption. apply shift_minus_leEq. apply leEq_transitive with (maxlist l). apply maxlist_greater; assumption. apply shift_leEq_plus'. assumption. Qed. Let aux_seq_lub_prop : forall (P : IR -> CProp) (H : totally_bounded P), (forall k : nat, P (scs_elem _ _ (aux_seq_lub P H k))) and (forall (k : nat) (y : IR), P y -> y[-]scs_elem _ _ (aux_seq_lub P H k) [<=] Two[*]one_div_succ k). Proof. intros; cut (forall k : nat, P (scs_elem _ _ (aux_seq_lub P H k)) and (forall y : IR, P y -> y[-]scs_elem _ _ (aux_seq_lub P H k) [<=] Two[*]one_div_succ k)). intro H0. split; intro; elim (H0 k); intros. assumption. apply b; assumption. intro; apply scs_prf. Qed. (* end hide *) (** The following are probably the most important results in this section. *) Lemma totally_bounded_has_lub : forall P, totally_bounded P -> {z : IR | set_lub_IR P z}. Proof. intros P tot_bnd. red in tot_bnd. elim tot_bnd; intros non_empty H. cut {sequence : nat -> IR | forall k : nat, P (sequence k) | forall (k : nat) (x : IR), P x -> x[-]sequence k [<=] Two[*]one_div_succ k}. intros H0. elim H0. intros seq Hseq Hseq'. cut (Cauchy_prop seq). intro H1. set (seq1 := Build_CauchySeq IR seq H1) in *. exists (Lim seq1). split; intros. apply shift_leEq_rht. astepl ( [--]ZeroR); rstepr ( [--] (x[-]Lim seq1)). apply inv_resp_leEq. set (seq2 := Cauchy_const x) in *. apply leEq_wdl with (Lim seq2[-]Lim seq1). 2: apply cg_minus_wd; [ unfold seq2 in |- *; apply eq_symmetric_unfolded; apply Lim_const | algebra ]. apply leEq_wdl with (Lim (Build_CauchySeq IR (fun n : nat => seq2 n[-]seq1 n) (Cauchy_minus seq2 seq1))). apply leEq_transitive with (Lim twice_inv_seq). apply Lim_leEq_Lim; intro; simpl in |- *. apply Hseq'; assumption. apply eq_imp_leEq. apply eq_symmetric_unfolded; apply Limits_unique. red in |- *; fold (SeqLimit twice_inv_seq [0]) in |- *. apply twice_inv_seq_Lim. apply Lim_minus. cut (Cauchy_Lim_prop2 seq (Lim seq1)). intro H4; red in H4. try rename X into H2. elim (H4 (e [/]TwoNZ) (pos_div_two _ _ H2)); clear H4. intros n Hn. exists (seq n). apply Hseq. apply leEq_less_trans with (AbsIR (Lim seq1[-]seq n)). apply leEq_AbsIR. apply leEq_less_trans with (e [/]TwoNZ). apply AbsSmall_imp_AbsIR. apply AbsSmall_minus; simpl in |- *; apply Hn. apply le_n. apply pos_div_two'; auto. cut (Cauchy_Lim_prop2 seq1 (Lim seq1)); intros. try rename X0 into H3. red in |- *; red in H3. intros eps Heps; elim (H3 eps Heps); clear H3; intros. exists x. intros m Hm; elim (p m Hm); clear p. intros. astepr (seq1 m[-]Lim seq1). apply AbsIR_eq_AbsSmall; assumption. red in |- *; fold (SeqLimit seq1 (Lim seq1)) in |- *. apply ax_Lim. apply crl_proof. red in |- *; intros. try rename X into H1. elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ H1)). intros n Hn. exists (S (2 * n)); intros. cut ([0] [<] nring (R:=IR) n); intros. apply AbsIR_eq_AbsSmall. try rename X into H3. apply leEq_transitive with ( [--] ([1][/] nring n[//]pos_ap_zero _ _ H3)). apply inv_resp_leEq. apply shift_div_leEq. assumption. eapply shift_leEq_mult'; [ assumption | apply Hn ]. rstepr ( [--] (seq (S (2 * n)) [-]seq m)); apply inv_resp_leEq. apply leEq_transitive with (Two[*]one_div_succ (R:=IR) m). auto. apply leEq_transitive with (one_div_succ (R:=IR) n). unfold one_div_succ in |- *. unfold Snring in |- *. rstepl ([1][/] nring (S m) [/]TwoNZ[//] div_resp_ap_zero_rev _ _ _ _ (nring_ap_zero IR (S m) (sym_not_eq (O_S m)))). apply recip_resp_leEq. apply pos_nring_S. apply shift_leEq_div. apply pos_two. simpl in |- *; fold (Two:IR) in |- *. rstepl (Two[*]nring (R:=IR) n[+][1][+][1]). apply plus_resp_leEq. apply leEq_wdl with (nring (R:=IR) (S (2 * n))). apply nring_leEq; assumption. Step_final (nring (R:=IR) (2 * n) [+][1]). unfold one_div_succ in |- *; unfold Snring in |- *; apply recip_resp_leEq. assumption. simpl in |- *; apply less_leEq; apply less_plusOne. apply leEq_transitive with (Two[*]one_div_succ (R:=IR) (S (2 * n))). auto. apply less_leEq. try rename X into H3. apply less_leEq_trans with ([1][/] nring n[//]pos_ap_zero _ _ H3). astepl (one_div_succ (R:=IR) (S (2 * n)) [*]Two). unfold one_div_succ in |- *; unfold Snring in |- *. apply shift_mult_less with (two_ap_zero IR). apply pos_two. rstepr ([1][/] Two[*]nring n[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (pos_ap_zero _ _ H3)). apply recip_resp_less. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; [ apply pos_two | assumption ]. apply less_wdr with (Two[*]nring (R:=IR) n[+][1][+][1]). apply less_transitive_unfolded with (Two[*]nring (R:=IR) n[+][1]); apply less_plusOne. astepr (nring (R:=IR) (S (2 * n)) [+][1]). Step_final (nring (R:=IR) (2 * n) [+][1][+][1]). rstepr ([1][/] [1][/] e[//]pos_ap_zero _ _ H1[//] div_resp_ap_zero_rev _ _ _ _ (one_ap_zero IR)). apply recip_resp_leEq; [ apply recip_resp_pos; assumption | assumption ]. eapply less_leEq_trans. 2: apply Hn. apply recip_resp_pos; assumption. elim (aux_seq_lub_prop P tot_bnd). exists (fun k : nat => scs_elem _ _ (aux_seq_lub P tot_bnd k)); auto. Qed. (* begin hide *) Let aux_seq_glb (P : IR -> CProp) (H : totally_bounded P) : forall k : nat, Build_SubCSetoid IR (fun x : IR => P x and (forall y : IR, P y -> x[-]y [<=] Two[*]one_div_succ k)). Proof. elim H; clear H; intros non_empty H k. elim (H (one_div_succ k) (one_div_succ_pos IR k)). intros l Hl' Hl; clear H. cut {y : IR | member y l | y [<=] minlist l[+]one_div_succ k}. intro H; inversion_clear H. 2: apply minlist_leEq_eps. 2: inversion_clear non_empty. 2: elim (Hl x). 2: intros. 2: exists x0. 2: tauto. 2: assumption. 2: apply one_div_succ_pos. exists x; split. apply Hl'; assumption. intros y Hy. elim (Hl y Hy). intros z Hz Hz'. rstepl (x[-]z[+] (z[-]y)). rstepr (one_div_succ (R:=IR) k[+]one_div_succ k). apply plus_resp_leEq_both. apply shift_minus_leEq. apply shift_leEq_plus'. apply leEq_transitive with (minlist l). apply shift_minus_leEq. assumption. apply minlist_smaller; assumption. apply leEq_transitive with (AbsIR (y[-]z)). rstepl ( [--] (y[-]z)); apply inv_leEq_AbsIR. apply AbsSmall_imp_AbsIR; assumption. Qed. Let aux_seq_glb_prop : forall (P : IR -> CProp) (H : totally_bounded P), (forall k : nat, P (scs_elem _ _ (aux_seq_glb P H k))) and (forall (k : nat) (y : IR), P y -> scs_elem _ _ (aux_seq_glb P H k) [-]y [<=] Two[*]one_div_succ k). Proof. intros; cut (forall k : nat, P (scs_elem _ _ (aux_seq_glb P H k)) and (forall y : IR, P y -> scs_elem _ _ (aux_seq_glb P H k) [-]y [<=] Two[*]one_div_succ k)). intro H0. split; intro k; elim (H0 k); intros. assumption. apply b; assumption. intro; apply scs_prf. Qed. (* end hide *) Lemma totally_bounded_has_glb : forall P : IR -> CProp, totally_bounded P -> {z : IR | set_glb_IR P z}. Proof. intros P tot_bnd. red in tot_bnd. elim tot_bnd; intros non_empty H. cut {sequence : nat -> IR | forall k : nat, P (sequence k) | forall (k : nat) (x : IR), P x -> sequence k[-]x [<=] Two[*]one_div_succ k}. intros H0. elim H0. clear H0; intros seq H0 H1. cut (Cauchy_prop seq). intro H2. set (seq1 := Build_CauchySeq IR seq H2) in *. exists (Lim seq1). split; intros. apply shift_leEq_rht. astepl ( [--]ZeroR); rstepr ( [--] (Lim seq1[-]x)). apply inv_resp_leEq. set (seq2 := Cauchy_const x) in *. apply leEq_wdl with (Lim seq1[-]Lim seq2). 2: apply cg_minus_wd; [ algebra | unfold seq2 in |- *; apply eq_symmetric_unfolded; apply Lim_const ]. apply leEq_wdl with (Lim (Build_CauchySeq IR (fun n : nat => seq1 n[-]seq2 n) (Cauchy_minus seq1 seq2))). apply leEq_transitive with (Lim twice_inv_seq). apply Lim_leEq_Lim; intro. simpl in |- *. apply H1; assumption. apply eq_imp_leEq. apply eq_symmetric_unfolded; apply Limits_unique. red in |- *; fold (SeqLimit twice_inv_seq [0]) in |- *. apply twice_inv_seq_Lim. apply Lim_minus. cut (Cauchy_Lim_prop2 seq (Lim seq1)). intro H4; red in H4. try rename X into H3. elim (H4 (e [/]TwoNZ) (pos_div_two _ _ H3)); clear H4. intros n Hn. exists (seq n). apply H0. apply leEq_less_trans with (AbsIR (Lim seq1[-]seq n)). rstepl ( [--] (Lim seq1[-]seq n)). apply inv_leEq_AbsIR. apply leEq_less_trans with (e [/]TwoNZ). apply AbsSmall_imp_AbsIR. apply AbsSmall_minus; simpl in |- *; apply Hn. apply le_n. apply pos_div_two'; auto. cut (Cauchy_Lim_prop2 seq1 (Lim seq1)); intros. try rename X0 into H4. red in |- *; red in H4. intros eps Heps; elim (H4 eps Heps); clear H4; intros. exists x. intros m Hm; elim (p m Hm); clear p. intros. astepr (seq1 m[-]Lim seq1). apply AbsIR_eq_AbsSmall; assumption. red in |- *; fold (SeqLimit seq1 (Lim seq1)) in |- *. apply ax_Lim. apply crl_proof. red in |- *; intros e H2. elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ H2)). intros n Hn. exists (S (2 * n)); intros. cut ([0] [<] nring (R:=IR) n); intros. apply AbsIR_eq_AbsSmall. try rename X into H4. apply leEq_transitive with ( [--] ([1][/] nring n[//]pos_ap_zero _ _ H4)). apply inv_resp_leEq. apply shift_div_leEq. assumption. eapply shift_leEq_mult'; [ assumption | apply Hn ]. apply less_leEq. rstepr ( [--] (seq (S (2 * n)) [-]seq m)); apply inv_resp_less. apply leEq_less_trans with (Two[*]one_div_succ (R:=IR) (S (2 * n))). apply H1; apply H0. astepl (one_div_succ (R:=IR) (S (2 * n)) [*]Two). unfold one_div_succ in |- *; unfold Snring in |- *. apply shift_mult_less with (two_ap_zero IR). apply pos_two. rstepr ([1][/] Two[*]nring n[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (pos_ap_zero _ _ H4)). apply recip_resp_less. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; [ apply pos_two | assumption ]. apply less_wdr with (Two[*]nring (R:=IR) n[+][1][+][1]). apply less_transitive_unfolded with (Two[*]nring (R:=IR) n[+][1]); apply less_plusOne. astepr (nring (R:=IR) (S (2 * n)) [+][1]). Step_final (nring (R:=IR) (2 * n) [+][1][+][1]). apply leEq_transitive with (Two[*]one_div_succ (R:=IR) m). apply H1; apply H0. apply leEq_transitive with (one_div_succ (R:=IR) n). unfold one_div_succ in |- *. unfold Snring in |- *. rstepl ([1][/] nring (R:=IR) (S m) [/]TwoNZ[//] div_resp_ap_zero_rev _ _ _ _ (nring_ap_zero IR (S m) (sym_not_eq (O_S m)))). apply recip_resp_leEq. apply pos_nring_S. apply shift_leEq_div. apply pos_two. simpl in |- *; fold (Two:IR) in |- *. rstepl (Two[*]nring (R:=IR) n[+][1][+][1]). apply plus_resp_leEq. apply leEq_wdl with (nring (R:=IR) (S (2 * n))). apply nring_leEq; assumption. Step_final (nring (R:=IR) (2 * n) [+][1]). unfold one_div_succ in |- *; unfold Snring in |- *. rstepr ([1][/] [1][/] e[//]pos_ap_zero _ _ H2[//] div_resp_ap_zero_rev _ _ _ _ (one_ap_zero IR)). apply recip_resp_leEq. apply recip_resp_pos; assumption. apply leEq_transitive with (nring (R:=IR) n); [ assumption | simpl in |- *; apply less_leEq; apply less_plusOne ]. eapply less_leEq_trans. 2: apply Hn. apply recip_resp_pos; assumption. elim (aux_seq_glb_prop P tot_bnd). exists (fun k : nat => scs_elem _ _ (aux_seq_glb P tot_bnd k)); auto. Qed. End Totally_Bounded. Section Compact. (** ** Compact sets In this section we dwell a bit farther into the definition of compactness and explore some of its properties. The following characterization of inclusion can be very useful: *) Lemma included_compact : forall (a b c d : IR) Hab Hcd, compact a b Hab c -> compact a b Hab d -> included (compact c d Hcd) (compact a b Hab). Proof. intros a b c d Hab Hcd H H0 x H1. inversion_clear H. inversion_clear H0. inversion_clear H1. split. apply leEq_transitive with c; auto. apply leEq_transitive with d; auto. Qed. (** At several points in our future development of a theory we will need to partition a compact interval in subintervals of length smaller than some predefined value [eps]. Although this seems a consequence of every compact interval being totally bounded, it is in fact a stronger property. In this section we perform that construction (requiring the endpoints of the interval to be distinct) and prove some of its good properties. %\begin{convention}% Let [a,b : IR], [Hab : (a [<=] b)] and denote by [I] the compact interval [[a,b]]. Also assume that [a [<] b], and let [e] be a positive real number. %\end{convention}% *) Variables a b : IR. Hypothesis Hab : a [<=] b. (* begin hide *) Let I := compact a b Hab. (* end hide *) Hypothesis Hab' : a [<] b. Variable e : IR. Hypothesis He : [0] [<] e. (** We start by finding a natural number [n] such that [(b[-]a) [/] n [<] e]. *) Definition compact_nat := ProjT1 (Archimedes (b[-]a[/] e[//]pos_ap_zero _ _ He)). (** Obviously such an [n] must be greater than zero.*) Lemma pos_compact_nat : [0] [<] nring (R:=IR) compact_nat. Proof. apply less_leEq_trans with (b[-]a[/] e[//]pos_ap_zero _ _ He). rstepr ((b[-]a) [*] ([1][/] e[//]pos_ap_zero _ _ He)). apply mult_resp_pos. apply shift_less_minus; astepl a; assumption. apply recip_resp_pos; assumption. unfold compact_nat in |- *; apply proj2_sigT. Qed. (** We now define a sequence on [n] points in [[a,b]] by [x_i [=] Min(a,b) [+]i[*] (b[-]a) [/]n] and prove that all of its points are really in that interval. *) Definition compact_part (i : nat) : i <= compact_nat -> IR. Proof. intros. apply (a[+]nring i[*] (b[-]a[/] _[//]pos_ap_zero _ _ pos_compact_nat)). Defined. Lemma compact_part_hyp : forall i Hi, compact a b Hab (compact_part i Hi). Proof. intros; unfold compact_part in |- *. split. astepl (a[+][0]); apply plus_resp_leEq_lft. astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive. apply nring_nonneg. apply shift_leEq_div. apply pos_compact_nat. apply shift_leEq_minus; rstepl a; apply less_leEq; assumption. rstepr (a[+]nring compact_nat[*] (b[-]a[/] _[//]pos_ap_zero _ _ pos_compact_nat)). apply plus_resp_leEq_lft. apply mult_resp_leEq_rht; try apply nring_nonneg. apply nring_leEq; assumption. apply shift_leEq_div. apply pos_compact_nat. apply shift_leEq_minus; rstepl a; apply less_leEq; assumption. Qed. (** This sequence is strictly increasing and each two consecutive points are apart by less than [e].*) Lemma compact_less : forall i Hi HSi, [0] [<] compact_part (S i) HSi[-]compact_part i Hi. Proof. intros i H1 H2. apply shift_less_minus; astepl (compact_part _ H1). unfold compact_part in |- *. apply plus_resp_less_lft. apply mult_resp_less. simpl in |- *; apply less_plusOne. apply div_resp_pos. apply pos_compact_nat. apply shift_less_minus; astepl a; assumption. Qed. Lemma compact_leEq : forall i Hi HSi, compact_part (S i) HSi[-]compact_part i Hi [<=] e. Proof. intros i H1 H2. unfold compact_part in |- *; simpl in |- *. rstepl (b[-]a[/] _[//]pos_ap_zero _ _ pos_compact_nat). apply shift_div_leEq. apply pos_compact_nat. apply shift_leEq_mult' with (pos_ap_zero _ _ He). assumption. exact (ProjT2 (Archimedes _)). Qed. (** When we proceed to integration, this lemma will also be useful: *) Lemma compact_partition_lemma : forall n Hn i, i <= n -> Compact Hab (a[+]nring i[*] (b[-]a[/] _[//]nring_ap_zero' _ n Hn)). Proof. intros n Hn i H; split. apply shift_leEq_plus'. astepl ZeroR. apply mult_resp_nonneg. apply nring_nonneg. apply shift_leEq_div. apply nring_pos; apply Nat.neq_0_lt_0; auto. apply shift_leEq_minus. rstepl a; assumption. apply shift_plus_leEq'. rstepr (nring n[*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hn)). astepl ([0][+]nring i[*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hn)). apply shift_plus_leEq. rstepr ((nring n[-]nring i) [*] (b[-]a[/] _[//]nring_ap_zero' _ _ Hn)). apply mult_resp_nonneg. apply shift_leEq_minus. astepl (nring (R:=IR) i). apply nring_leEq; assumption. apply shift_leEq_div. apply nring_pos; apply Nat.neq_0_lt_0; auto. apply shift_leEq_minus. rstepl a; assumption. Qed. (** The next lemma provides an upper bound for the distance between two points in an interval: *) Lemma compact_elements : forall x y : IR, Compact Hab x -> Compact Hab y -> AbsIR (x[-]y) [<=] AbsIR (b[-]a). Proof. clear Hab' He e. do 2 intro; intros Hx Hy. apply leEq_wdr with (b[-]a). 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl a; auto. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply Abs_Max. inversion_clear Hx. inversion_clear Hy. unfold cg_minus in |- *; apply plus_resp_leEq_both. apply Max_leEq; auto. apply inv_resp_leEq. apply leEq_Min; auto. Qed. Opaque Min Max. (** The following is a variation on the previous lemma: *) Lemma compact_elements' : forall c d Hcd x y, Compact Hab x -> compact c d Hcd y -> AbsIR (x[-]y) [<=] AbsIR (Max b d[-]Min a c). Proof. do 5 intro; intros Hx Hy. eapply leEq_transitive. 2: apply leEq_AbsIR. inversion_clear Hx. inversion_clear Hy. simpl in |- *; unfold ABSIR in |- *; apply Max_leEq. unfold cg_minus in |- *; apply plus_resp_leEq_both. apply leEq_transitive with b; auto; apply lft_leEq_Max. apply inv_resp_leEq; apply leEq_transitive with c; auto; apply Min_leEq_rht. rstepl (y[-]x). unfold cg_minus in |- *; apply plus_resp_leEq_both. apply leEq_transitive with d; auto; apply rht_leEq_Max. apply inv_resp_leEq; apply leEq_transitive with a; auto; apply Min_leEq_lft. Qed. (** The following lemma is a bit more specific: it shows that we can also estimate the distance from the center of a compact interval to any of its points. *) Lemma compact_bnd_AbsIR : forall x y d H, compact (x[-]d) (x[+]d) H y -> AbsIR (x[-]y) [<=] d. Proof. intros x y d H H0. inversion_clear H0. simpl in |- *; unfold ABSIR in |- *. apply Max_leEq. apply shift_minus_leEq; apply shift_leEq_plus'; auto. rstepl (y[-]x). apply shift_minus_leEq. astepr (x[+]d); auto. Qed. (** Finally, two more useful lemmas to prove inclusion of compact intervals. They will be necessary for the definition and proof of the elementary properties of the integral. *) Lemma included2_compact : forall x y Hxy, Compact Hab x -> Compact Hab y -> included (compact (Min x y) (Max x y) Hxy) (Compact Hab). Proof. do 3 intro. intros H H0. inversion_clear H. inversion_clear H0. apply included_compact; split. apply leEq_Min; auto. apply leEq_transitive with y. apply Min_leEq_rht. auto. apply leEq_transitive with y. auto. apply rht_leEq_Max. apply Max_leEq; auto. Qed. Lemma included3_compact : forall x y z Hxyz, Compact Hab x -> Compact Hab y -> Compact Hab z -> included (compact (Min (Min x y) z) (Max (Max x y) z) Hxyz) (Compact Hab). Proof. do 4 intro. intros H H0 H1. inversion_clear H. inversion_clear H0. inversion_clear H1. apply included_compact; split. repeat apply leEq_Min; auto. apply leEq_transitive with z. apply Min_leEq_rht. auto. apply leEq_transitive with z. auto. apply rht_leEq_Max. repeat apply Max_leEq; auto. Qed. End Compact. #[global] Hint Resolve included_compact included2_compact included3_compact : included. corn-8.20.0/reals/Max_AbsIR.v000066400000000000000000001110121473720167500156140ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Max %\ensuremath{\max}% *) (** printing Min %\ensuremath{\min}% *) Require Export CoRN.reals.Q_in_CReals. From Coq Require Import Qabs. Require Export CoRN.reals.CauchySeq. Section Maximum. Section Max_function. (** ** Maximum, Minimum and Absolute Value %\begin{convention}% Let [x] and [y] be reals (we will define the maximum of [x] and [y]). %\end{convention}% *) Variables x y : IR. Definition Max_seq : nat -> IR. Proof. intro i. elim (less_cotransitive_unfolded IR [0] (one_div_succ i)) with (x[-]y). 3: apply one_div_succ_pos. intro H; apply x. intro H; apply y. Defined. Lemma Max_seq_char : forall n, [0] [<] x[-]y and Max_seq n [=] x or x[-]y [<] one_div_succ n and Max_seq n [=] y. Proof. intros. unfold Max_seq in |- *. elim less_cotransitive_unfolded; intro H; simpl in |- *. left; split; algebra. right; split; algebra. Qed. Lemma Cauchy_Max_seq : Cauchy_prop Max_seq. Proof. apply Cauchy_prop1_prop. intro k. exists k; intros m H. unfold Max_seq in |- *. elim less_cotransitive_unfolded; intro Hm; simpl in |- *; elim less_cotransitive_unfolded; intro Hk; simpl in |- *. astepr ZeroR; split; apply less_leEq. astepr ( [--]ZeroR); apply inv_resp_less; apply one_div_succ_pos. apply one_div_succ_pos. apply leEq_imp_AbsSmall; apply less_leEq; auto. apply AbsSmall_minus. apply leEq_imp_AbsSmall; apply less_leEq; auto. apply less_leEq_trans with (one_div_succ (R:=IR) m); auto. apply one_div_succ_resp_leEq; auto. astepr ZeroR; split; apply less_leEq. astepr ( [--]ZeroR); apply inv_resp_less; apply one_div_succ_pos. apply one_div_succ_pos. Qed. Definition Max_CauchySeq : CauchySeqR. Proof. unfold CauchySeqR in |- *. apply Build_CauchySeq with Max_seq. exact Cauchy_Max_seq. Defined. Definition MAX : IR. Proof. apply Lim. exact Max_CauchySeq. Defined. (** Constructively, the elementary properties of the maximum function are: - [x [<=] Max (x,y)], - [x [<=] Max (y,x)], - [z [<] Max(x,y) -> z [<] x or z [<] y]. (This can be more concisely expressed as [z [<] Max(x,y) Iff z [<] x or z [<] y]). From these elementary properties we can prove all other properties, including strong extensionality. With strong extensionality, we can make the binary operation [Max]. (So [Max] is [MAX] coupled with some proofs.) *) Lemma lft_leEq_MAX : x [<=] MAX. Proof. astepr ([0][+]MAX); apply shift_leEq_plus. apply approach_zero_weak. intros e He. apply leEq_wdl with (Lim (Cauchy_const x) [-]MAX). 2: apply cg_minus_wd; [ apply eq_symmetric_unfolded; apply Lim_const | algebra ]. unfold MAX in |- *. eapply leEq_wdl. 2: apply Lim_minus. simpl in |- *. elim (Archimedes ([1][/] e[//]pos_ap_zero _ _ He)); intros n Hn. cut ([0] [<] nring (R:=IR) n). intro posn. apply str_seq_leEq_so_Lim_leEq. exists n; intros i Hi. simpl in |- *. unfold Max_seq in |- *. elim less_cotransitive_unfolded; intro H; simpl in |- *. astepl ZeroR; apply less_leEq; auto. apply less_leEq; eapply less_transitive_unfolded. apply H. unfold one_div_succ, Snring in |- *; apply shift_div_less. apply pos_nring_S. apply shift_less_mult' with (pos_ap_zero _ _ He). auto. eapply leEq_less_trans. apply Hn. apply nring_less; auto with arith. eapply less_leEq_trans. 2: apply Hn. apply recip_resp_pos; auto. Qed. Lemma rht_leEq_MAX : y [<=] MAX. Proof. unfold MAX in |- *. apply leEq_seq_so_leEq_Lim. intro i; simpl in |- *. unfold Max_seq in |- *. elim less_cotransitive_unfolded; intro H; simpl in |- *. 2: apply leEq_reflexive. apply less_leEq; astepl ([0][+]y). apply shift_plus_less; auto. Qed. Lemma less_MAX_imp : forall z : IR, z [<] MAX -> z [<] x or z [<] y. Proof. intros z H. unfold MAX in H. elim (less_Lim_so_less_seq _ _ H). intros N HN. simpl in HN. elim (Max_seq_char N); intro Hseq; inversion_clear Hseq; [ left | right ]; astepr (Max_seq N); auto with arith. Qed. End Max_function. Lemma MAX_strext : bin_op_strext _ MAX. Proof. unfold bin_op_strext in |- *. unfold bin_fun_strext in |- *. intros x1 x2 y1 y2 H. generalize (ap_imp_less _ _ _ H); intro H0. elim H0; intro H1. generalize (less_MAX_imp _ _ _ H1); intro H2. elim H2; intro H3. left. apply less_imp_ap. apply leEq_less_trans with (MAX x1 y1); auto. apply lft_leEq_MAX. right. apply less_imp_ap. apply leEq_less_trans with (MAX x1 y1); auto. apply rht_leEq_MAX. generalize (less_MAX_imp _ _ _ H1); intro H2. elim H2; intro. left. apply Greater_imp_ap. apply leEq_less_trans with (MAX x2 y2); auto. apply lft_leEq_MAX. right. apply Greater_imp_ap. apply leEq_less_trans with (MAX x2 y2); auto. apply rht_leEq_MAX. Qed. Lemma MAX_wd : bin_op_wd IR MAX. Proof. unfold bin_op_wd in |- *. apply bin_fun_strext_imp_wd. exact MAX_strext. Qed. Section properties_of_Max. (** *** Maximum *) Definition Max := Build_CSetoid_bin_op _ MAX MAX_strext. Lemma Max_wd_unfolded : forall x y x' y', x [=] x' -> y [=] y' -> Max x y [=] Max x' y'. Proof. cut (bin_op_wd _ MAX); [ intro | apply MAX_wd ]. red in H. red in H. intros; apply H; assumption. Qed. Lemma lft_leEq_Max : forall x y : IR, x [<=] Max x y. Proof. unfold Max in |- *. simpl in |- *. exact lft_leEq_MAX. Qed. Lemma rht_leEq_Max : forall x y : IR, y [<=] Max x y. Proof. unfold Max in |- *. simpl in |- *. exact rht_leEq_MAX. Qed. Lemma less_Max_imp : forall x y z : IR, z [<] Max x y -> z [<] x or z [<] y. Proof. unfold Max in |- *. simpl in |- *. exact less_MAX_imp. Qed. Lemma Max_leEq : forall x y z : IR, x [<=] z -> y [<=] z -> Max x y [<=] z. Proof. unfold Max in |- *. simpl in |- *. intros. rewrite -> leEq_def in |- *. intro H1. generalize (less_MAX_imp _ _ _ H1); intro H2. elim H2; intros. rewrite -> leEq_def in H; elim H. assumption. rewrite -> leEq_def in H0; elim H0. assumption. Qed. Lemma Max_less : forall x y z : IR, x [<] z -> y [<] z -> Max x y [<] z. Proof. intros. elim (smaller _ (z[-]x) (z[-]y)). intro e. intros H1 H2. elim H2. clear H2. intros H2 H3. cut (z[-]e [/]TwoNZ [<] z). intro H4. elim (less_cotransitive_unfolded _ _ _ H4 (Max x y)); intros H5. elim (less_Max_imp _ _ _ H5); intros H6. cut (Not (e [/]TwoNZ [<] z[-]x)). intro H7. elim H7. apply less_leEq_trans with e; auto. apply pos_div_two'; auto. apply less_antisymmetric_unfolded. apply shift_minus_less. apply shift_less_plus'. auto. cut (Not (e [/]TwoNZ [<] z[-]y)). intro H7. elim H7. apply less_leEq_trans with e; auto. apply pos_div_two'; auto. apply less_antisymmetric_unfolded. apply shift_minus_less. apply shift_less_plus'. auto. auto. apply shift_minus_less. astepl (z[+][0]). apply plus_resp_less_lft. apply pos_div_two. auto. apply shift_less_minus. astepl x. auto. apply shift_less_minus. astepl y. auto. Qed. Lemma equiv_imp_eq_max : forall x x' m, (forall y, x [<=] y -> x' [<=] y -> m [<=] y) -> (forall y, m [<=] y -> x [<=] y) -> (forall y, m [<=] y -> x' [<=] y) -> Max x x' [=] m. Proof. intros. apply not_ap_imp_eq. intros X. destruct (ap_imp_less _ _ _ X) as [X0|X0]. apply (less_irreflexive_unfolded _ (Max x x')). apply less_leEq_trans with m. assumption. apply H. apply lft_leEq_Max. apply rht_leEq_Max. case (less_Max_imp _ _ _ X0). change (Not (m[<]x)). rewrite <- (leEq_def). apply H0. apply leEq_reflexive. change (Not (m[<]x')). rewrite <- (leEq_def). apply H1. apply leEq_reflexive. Qed. Lemma Max_id : forall x : IR, Max x x [=] x. Proof. intros. apply equiv_imp_eq_max; auto. Qed. Lemma Max_comm : forall x y : IR, Max x y [=] Max y x. Proof. cut (forall x y : IR, Max x y [<=] Max y x). intros. apply leEq_imp_eq. apply H. apply H. intros. apply Max_leEq. apply rht_leEq_Max. apply lft_leEq_Max. Qed. Lemma leEq_imp_Max_is_rht : forall x y : IR, x [<=] y -> Max x y [=] y. Proof. intros. apply leEq_imp_eq. apply Max_leEq. assumption. apply leEq_reflexive. apply rht_leEq_Max. Qed. Lemma Max_is_rht_imp_leEq : forall x y : IR, Max x y [=] y -> x [<=] y. Proof. intros. rewrite -> leEq_def in |- *. intro H0. generalize (less_leEq _ _ _ H0); intro H1. generalize (leEq_imp_Max_is_rht _ _ H1); intro. cut (y [=] x). intro. elim (less_irreflexive_unfolded _ x). astepl y. assumption. astepl (Max x y). astepr (Max y x). apply Max_comm. Qed. Lemma Max_minus_eps_leEq : forall x y e, [0] [<] e -> {Max x y[-]e [<=] x} + {Max x y[-]e [<=] y}. Proof. intros. cut (Max x y[-]e [<] x or Max x y[-]e [<] y). intro H0; elim H0; intros; clear H0. left; apply less_leEq; assumption. right; apply less_leEq; assumption. apply less_Max_imp. apply shift_minus_less. apply shift_less_plus'. astepl ZeroR; assumption. Qed. Lemma max_one_ap_zero : forall x : IR, Max x [1] [#] [0]. Proof. intros. apply ap_symmetric_unfolded. apply less_imp_ap. apply less_leEq_trans with OneR. apply pos_one. apply rht_leEq_Max. Qed. Lemma pos_max_one : forall x : IR, [0] [<] Max x [1]. Proof. intro. apply less_leEq_trans with OneR; [ apply pos_one | apply rht_leEq_Max ]. Qed. Lemma x_div_Max_leEq_x : forall x y : IR, [0] [<] x -> (x[/] Max y [1][//]max_one_ap_zero _) [<=] x. Proof. intros. apply shift_div_leEq'. apply pos_max_one. astepl ([1][*]x). apply mult_resp_leEq_rht; [ apply rht_leEq_Max | apply less_leEq; assumption ]. Qed. Lemma max_plus : forall (a b c : IR), Max (a[+]c) (b[+]c) [=] Max a b [+] c. Proof. intros. apply equiv_imp_eq_max; intros. apply shift_plus_leEq. apply Max_leEq; apply shift_leEq_minus; auto. apply leEq_transitive with (Max a b [+]c); auto. apply plus_resp_leEq. apply lft_leEq_Max. apply leEq_transitive with (Max a b [+]c); auto. apply plus_resp_leEq. apply rht_leEq_Max. Qed. Lemma max_mult : forall (a b c : IR), [0] [<=] c -> (Max (c[*]a) (c[*]b)) [=] c[*](Max a b). Proof. intros a b c H. apply leEq_imp_eq. apply Max_leEq; apply mult_resp_leEq_lft. apply lft_leEq_Max. assumption. apply rht_leEq_Max. assumption. rewrite -> leEq_def in *. intros Z. assert (Not (Not ([0][<]c or [0][=]c))). intros X. apply X. right. apply not_ap_imp_eq. intros Y. destruct (ap_imp_less _ _ _ Y) as [Y0|Y0]. auto. auto. apply H0. intros X. generalize Z. clear H H0 Z. change (Not (Max (c[*]a) (c[*]b)[<]c[*]Max a b)). rewrite <- leEq_def. destruct X as [c0|c0]. assert (X:c[#][0]). apply ap_symmetric; apply less_imp_ap; assumption. apply shift_mult_leEq' with X. assumption. apply Max_leEq;(apply shift_leEq_div;[assumption|]). rstepl (c[*]a); apply lft_leEq_Max. rstepl (c[*]b); apply rht_leEq_Max. stepl (c[*]a). apply lft_leEq_Max. csetoid_rewrite_rev c0. rational. Qed. End properties_of_Max. End Maximum. #[global] Hint Resolve Max_id: algebra. Section Minimum. (** *** Mininum The minimum is defined by the formula [Min(x,y) [=] [--]Max( [--]x,[--]y)]. *) Definition MIN (x y : IR) : IR := [--] (Max [--]x [--]y). Lemma MIN_wd : bin_op_wd _ MIN. Proof. intros x1 x2 y1 y2. unfold MIN in |- *; algebra. Qed. Lemma MIN_strext : bin_op_strext _ MIN. Proof. intros x1 x2 y1 y2 H. unfold MIN in H. assert (H':=(un_op_strext_unfolded _ _ _ _ H)). elim (bin_op_strext_unfolded _ _ _ _ _ _ H'); intro H1; [left | right]; exact (un_op_strext_unfolded _ _ _ _ H1). Qed. Definition Min : CSetoid_bin_op IR := Build_CSetoid_bin_op _ MIN MIN_strext. Lemma Min_wd_unfolded : forall x y a b, x [=] a /\ y [=] b -> (Min x y) [=] (Min a b). Proof. intros; inversion H. apply MIN_wd; auto. Qed. Lemma Min_strext_unfolded : forall x y a b, (Min x y) [#] (Min a b) -> x [#] a or y [#] b. Proof. intros. apply MIN_strext; auto. Qed. Lemma Min_leEq_lft : forall x y : IR, Min x y [<=] x. Proof. intros. simpl in |- *; unfold MIN. rstepr ( [--][--]x). apply inv_resp_leEq. apply lft_leEq_Max. Qed. Lemma Min_leEq_rht : forall x y : IR, Min x y [<=] y. Proof. intros. simpl; unfold MIN. rstepr ( [--][--]y). apply inv_resp_leEq. apply rht_leEq_Max. Qed. Lemma Min_less_imp : forall x y z : IR, Min x y [<] z -> x [<] z or y [<] z. Proof. simpl; unfold MIN. intros. cut ( [--]z [<] [--]x or [--]z [<] [--]y). intros H0. elim H0; intro. left. apply inv_cancel_less; assumption. right. apply inv_cancel_less; assumption. apply less_Max_imp. apply inv_cancel_less. apply less_wdr with z. assumption. algebra. Qed. Lemma leEq_Min : forall x y z : IR, z [<=] x -> z [<=] y -> z [<=] Min x y. Proof. intros. simpl; unfold MIN. rstepl ( [--][--]z). apply inv_resp_leEq. apply Max_leEq; apply inv_resp_leEq; assumption. Qed. Lemma less_Min : forall x y z : IR, z [<] x -> z [<] y -> z [<] Min x y. Proof. intros. simpl; unfold MIN. rstepl ( [--][--]z). apply inv_resp_less. apply Max_less; apply inv_resp_less; assumption. Qed. Lemma equiv_imp_eq_min : forall x x' m, (forall y, y [<=] x -> y [<=] x' -> y [<=] m) -> (forall y, y [<=] m -> y [<=] x) -> (forall y, y [<=] m -> y [<=] x') -> Min x x' [=] m. Proof. intros x x' m X X0 X1. simpl; unfold MIN. astepr ( [--][--]m). apply un_op_wd_unfolded. apply equiv_imp_eq_max. intros. rstepr ( [--][--]y). apply inv_resp_leEq. apply X. rstepr ( [--][--]x). apply inv_resp_leEq. assumption. rstepr ( [--][--]x'). apply inv_resp_leEq. assumption. intros. rstepr ( [--][--]y). apply inv_resp_leEq. apply X0. rstepr ( [--][--]m). apply inv_resp_leEq. assumption. intros. rstepr ( [--][--]y). apply inv_resp_leEq. apply X1. rstepr ( [--][--]m). apply inv_resp_leEq. assumption. Qed. Lemma Min_id : forall x : IR, Min x x [=] x. Proof. intro. simpl; unfold MIN. astepr ( [--][--]x). apply un_op_wd_unfolded; apply Max_id. Qed. Lemma Min_comm : forall x y : IR, Min x y [=] Min y x. Proof. intros. simpl; unfold MIN. apply un_op_wd_unfolded; apply Max_comm. Qed. Lemma leEq_imp_Min_is_lft : forall x y : IR, x [<=] y -> Min x y [=] x. Proof. intros. simpl; unfold MIN. astepr ( [--][--]x). apply un_op_wd_unfolded. apply eq_transitive_unfolded with (Max [--]y [--]x). apply Max_comm. apply leEq_imp_Max_is_rht. apply inv_resp_leEq. assumption. Qed. Lemma Min_is_lft_imp_leEq : forall x y : IR, Min x y [=] x -> x [<=] y. Proof. simpl; unfold MIN. intros. rstepl ( [--][--]x). rstepr ( [--][--]y). apply inv_resp_leEq. apply Max_is_rht_imp_leEq. astepl ( [--][--] (Max [--]y [--]x)). apply eq_transitive_unfolded with ( [--][--] (Max [--]x [--]y)). apply un_op_wd_unfolded; apply un_op_wd_unfolded; apply Max_comm. apply un_op_wd_unfolded; assumption. Qed. Lemma leEq_Min_plus_eps : forall x y e, [0] [<] e -> {x [<=] Min x y[+]e} + {y [<=] Min x y[+]e}. Proof. intros. cut (x [<] Min x y[+]e or y [<] Min x y[+]e). intro H0; elim H0; intros; clear H0. left; apply less_leEq; assumption. right; apply less_leEq; assumption. apply Min_less_imp. apply shift_less_plus'. astepl ZeroR; assumption. Qed. Variables a b : IR. Lemma Min_leEq_Max : Min a b [<=] Max a b. Proof. intros. apply leEq_transitive with a; [ apply Min_leEq_lft | apply lft_leEq_Max ]. Qed. Lemma Min_leEq_Max' : forall z : IR, Min a z [<=] Max b z. Proof. intros; apply leEq_transitive with z. apply Min_leEq_rht. apply rht_leEq_Max. Qed. Lemma Min3_leEq_Max3 : forall c : IR, Min (Min a b) c [<=] Max (Max a b) c. Proof. intros; eapply leEq_transitive. apply Min_leEq_rht. apply rht_leEq_Max. Qed. Lemma Min_less_Max : forall c d : IR, a [<] b -> Min a c [<] Max b d. Proof. intros. apply leEq_less_trans with a. apply Min_leEq_lft. apply less_leEq_trans with b. assumption. apply lft_leEq_Max. Qed. Lemma ap_imp_Min_less_Max : a [#] b -> Min a b [<] Max a b. Proof. intro Hap; elim (ap_imp_less _ _ _ Hap); (intro H; [ eapply leEq_less_trans; [ idtac | eapply less_leEq_trans; [ apply H | idtac ] ] ]). apply Min_leEq_lft. apply rht_leEq_Max. apply Min_leEq_rht. apply lft_leEq_Max. Qed. Lemma Min_less_Max_imp_ap : Min a b [<] Max a b -> a [#] b. Proof. intro H. elim (Min_less_imp _ _ _ H); clear H; intro H; elim (less_Max_imp _ _ _ H); intro H0. exfalso; exact (less_irreflexive _ _ H0). apply less_imp_ap; auto. apply Greater_imp_ap; auto. exfalso; exact (less_irreflexive _ _ H0). Qed. Lemma Max_monotone : forall (f: PartIR), (forall (x y:IR) Hx Hy, (Min a b)[<=]x -> x[<=]y -> y[<=](Max a b) -> (f x Hx)[<=](f y Hy)) -> forall Ha Hb Hc, (Max (f a Ha) (f b Hb)) [=] f (Max a b) Hc. Proof. intros f H Ha Hb Hc. apply leEq_imp_eq. apply Max_leEq; apply H; (apply leEq_reflexive || apply Min_leEq_lft || apply Min_leEq_rht || apply lft_leEq_Max || apply rht_leEq_Max). rewrite -> leEq_def. intros X. apply (leEq_or_leEq IR a b). intros H0. generalize X; clear X. change (Not (Max (f a Ha) (f b Hb)[<]f (Max a b) Hc)). rewrite <- leEq_def. destruct H0. stepl (f b Hb). apply rht_leEq_Max. apply pfwdef. apply eq_symmetric; apply leEq_imp_Max_is_rht. assumption. stepl (f a Ha). apply lft_leEq_Max. apply pfwdef. stepr (Max b a). apply eq_symmetric; apply leEq_imp_Max_is_rht. assumption. now apply Max_comm. Qed. Lemma Min_monotone : forall (f: PartIR), (forall (x y:IR) Hx Hy, (Min a b)[<=]x -> x[<=]y -> y[<=](Max a b) -> (f x Hx)[<=](f y Hy)) -> forall Ha Hb Hc, (Min (f a Ha) (f b Hb)) [=] f (Min a b) Hc. Proof. intros f H Ha Hb Hc. apply leEq_imp_eq;[| apply leEq_Min; apply H; (apply leEq_reflexive || apply Min_leEq_lft || apply Min_leEq_rht || apply lft_leEq_Max || apply rht_leEq_Max)]. rewrite -> leEq_def. intros X. apply (leEq_or_leEq IR a b). intros H0. generalize X; clear X. change (Not (f (Min a b) Hc[<]Min (f a Ha) (f b Hb))). rewrite <- leEq_def. destruct H0. stepr (f a Ha). apply Min_leEq_lft. apply pfwdef. apply eq_symmetric; apply leEq_imp_Min_is_lft. assumption. stepr (f b Hb). apply Min_leEq_rht. apply pfwdef. stepr (Min b a). apply eq_symmetric; apply leEq_imp_Min_is_lft. assumption. apply Min_comm. Qed. End Minimum. (*---------------------------------*) Section Absolute. (*---------------------------------*) (** *** Absolute value *) Definition ABSIR (x : IR) : IR := Max x [--]x. Lemma ABSIR_strext : un_op_strext _ ABSIR. Proof. unfold un_op_strext in |- *. unfold fun_strext in |- *. unfold ABSIR in |- *. intros. generalize (csbf_strext _ _ _ Max); intro H0. unfold bin_fun_strext in H0. generalize (H0 _ _ _ _ X); intro H1. elim H1. intro H2. assumption. intro H2. apply zero_minus_apart. generalize (minus_ap_zero _ _ _ H2); intro H3. generalize (inv_resp_ap_zero _ _ H3); intro H4. cut (x[-]y [=] [--] ( [--]x[-][--]y)). intro. astepl ( [--] ( [--]x[-][--]y)). auto. rational. Qed. Lemma ABSIR_wd : un_op_wd _ ABSIR. Proof. unfold un_op_wd in |- *. apply fun_strext_imp_wd. exact ABSIR_strext. Qed. Definition AbsIR : CSetoid_un_op IR := Build_CSetoid_un_op _ ABSIR ABSIR_strext. Lemma AbsIR_wd : forall x y : IR, x [=] y -> AbsIR x [=] AbsIR y. Proof. algebra. Qed. Lemma AbsIR_wdl : forall x y e, x [=] y -> AbsIR x [<] e -> AbsIR y [<] e. Proof. intros. apply less_wdl with (AbsIR x). assumption. algebra. Qed. Lemma AbsIR_wdr : forall x y e, x [=] y -> e [<] AbsIR x -> e [<] AbsIR y. Proof. intros. apply less_wdr with (AbsIR x). assumption. algebra. Qed. Lemma AbsIRz_isz : AbsIR [0] [=] [0]. Proof. intros. unfold AbsIR in |- *. simpl in |- *. unfold ABSIR in |- *. Step_final (Max [0] [0]). Qed. Lemma AbsIR_nonneg : forall x : IR, [0] [<=] AbsIR x. Proof. intro x; rewrite -> leEq_def; intro H. cut ([0] [<] ZeroR). apply less_irreflexive. apply less_wdl with (AbsIR x); auto. eapply eq_transitive_unfolded. 2: apply AbsIRz_isz. apply AbsIR_wd. unfold AbsIR in H; simpl in H; unfold ABSIR in H. apply leEq_imp_eq; apply less_leEq. apply leEq_less_trans with (Max x [--]x). apply lft_leEq_Max. assumption. apply inv_cancel_less. apply leEq_less_trans with (Max x [--]x). apply rht_leEq_Max. astepr ZeroR; auto. Qed. Lemma AbsIR_pos : forall x : IR, x [#] [0] -> [0] [<] AbsIR x. Proof. intros. cut (x [<] [0] or [0] [<] x). 2: apply ap_imp_less; assumption. intros H0. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *. elim H0. intro. apply less_leEq_trans with ( [--]x). astepl ( [--]ZeroR). apply inv_resp_less. assumption. apply rht_leEq_Max. intro. apply less_leEq_trans with x. assumption. apply lft_leEq_Max. Qed. Lemma AbsIR_cancel_ap_zero : forall x : IR, AbsIR x [#] [0] -> x [#] [0]. Proof. intros. apply un_op_strext_unfolded with AbsIR. apply ap_wdr_unfolded with ZeroR. assumption. apply eq_symmetric_unfolded; apply AbsIRz_isz. Qed. Lemma AbsIR_resp_ap_zero : forall x : IR, x [#] [0] -> AbsIR x [#] [0]. Proof. intros. apply ap_symmetric_unfolded; apply less_imp_ap. apply AbsIR_pos; assumption. Qed. Lemma leEq_AbsIR : forall x : IR, x [<=] AbsIR x. Proof. intros. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *; apply lft_leEq_Max. Qed. Lemma inv_leEq_AbsIR : forall x : IR, [--]x [<=] AbsIR x. Proof. intros. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *; apply rht_leEq_Max. Qed. Lemma AbsSmall_e : forall e x : IR, AbsSmall e x -> [0] [<=] e. Proof. intros. red in H. cut ( [--]e [<=] e). 2: inversion_clear H; apply leEq_transitive with x; assumption. intro. apply mult_cancel_leEq with (Two:IR); astepl ZeroR. apply pos_two. rstepr (e[+]e). apply shift_leEq_plus; astepl ( [--]e). assumption. Qed. Lemma AbsSmall_imp_AbsIR : forall x y : IR, AbsSmall y x -> AbsIR x [<=] y. Proof. intros. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *. inversion_clear H. apply Max_leEq. assumption. apply inv_cancel_leEq. astepr x; auto. Qed. Lemma AbsIR_eq_AbsSmall : forall x e : IR, [--]e [<=] x -> x [<=] e -> AbsSmall e x. Proof. intros. unfold AbsSmall in |- *. auto. Qed. Lemma AbsIR_imp_AbsSmall : forall x y : IR, AbsIR x [<=] y -> AbsSmall y x. Proof. intros. unfold AbsSmall in |- *. simpl in H. unfold ABSIR in H. simpl in H. split. generalize (rht_leEq_Max x [--]x). intro H1. generalize (leEq_transitive _ _ (MAX x [--]x) _ H1 H). intro H2. rstepr ( [--][--]x). apply inv_resp_leEq. assumption. generalize (lft_leEq_Max x [--]x). intro H1. generalize (leEq_transitive _ _ (MAX x [--]x) _ H1 H). auto. Qed. Lemma AbsSmall_transitive : forall e x y : IR, AbsSmall e x -> AbsIR y [<=] AbsIR x -> AbsSmall e y. Proof. intros. apply AbsIR_imp_AbsSmall. eapply leEq_transitive. apply H0. apply AbsSmall_imp_AbsIR; assumption. Qed. Lemma zero_less_AbsIR_plus_one : forall q : IR, [0] [<] AbsIR q[+][1]. Proof. intros. apply less_leEq_trans with ([0][+]OneR). rstepr OneR; apply pos_one. apply plus_resp_leEq; apply AbsIR_nonneg. Qed. Lemma AbsIR_inv : forall x : IR, AbsIR x [=] AbsIR [--]x. Proof. intros. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *. apply eq_transitive_unfolded with (Max [--][--]x [--]x). apply bin_op_wd_unfolded; algebra. apply Max_comm. Qed. Lemma AbsIR_minus : forall x y : IR, AbsIR (x[-]y) [=] AbsIR (y[-]x). Proof. intros. eapply eq_transitive_unfolded. apply AbsIR_inv. apply AbsIR_wd; rational. Qed. Lemma AbsIR_mult : forall (x c: IR) (H : [0] [<=]c), c[*] AbsIR (x) [=] AbsIR (c[*]x). Proof. intros. unfold AbsIR. simpl. unfold ABSIR. rstepr (Max (c[*]x) (c[*]([--]x))). apply eq_symmetric_unfolded. apply max_mult; auto. Qed. Lemma AbsIR_eq_x : forall x : IR, [0] [<=] x -> AbsIR x [=] x. Proof. intros. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *. apply eq_transitive_unfolded with (Max [--]x x). apply Max_comm. apply leEq_imp_Max_is_rht. apply leEq_transitive with ZeroR. 2: assumption. astepr ( [--]ZeroR). apply inv_resp_leEq. assumption. Qed. Lemma AbsIR_eq_inv_x : forall x : IR, x [<=] [0] -> AbsIR x [=] [--]x. Proof. intros. apply eq_transitive_unfolded with (AbsIR [--]x). apply AbsIR_inv. apply AbsIR_eq_x. astepl ( [--]ZeroR). apply inv_resp_leEq. assumption. Qed. Lemma less_AbsIR : forall x y, [0] [<] x -> x [<] AbsIR y -> x [<] y or y [<] [--]x. Proof. intros x y H H0. simpl in H0. unfold ABSIR in H0. cut (x [<] y or x [<] [--]y). intro H1; inversion_clear H1. left; assumption. right; astepl ( [--][--]y); apply inv_resp_less; assumption. apply less_Max_imp; assumption. Qed. Lemma leEq_distr_AbsIR : forall x y : IR, [0] [<] x -> x [<=] AbsIR y -> {x [<=] y} + {y [<=] [--]x}. Proof. intros. cut (x[*]Three [/]FourNZ [<] AbsIR y); intros. elim (less_AbsIR (x[*]Three [/]FourNZ) y); intros; [ left | right | idtac | auto ]. astepr ([0][+]y); apply shift_leEq_plus. apply approach_zero. cut (forall e : IR, [0] [<] e -> e [<] x [/]TwoNZ -> x[-]y [<] e); intros. cut (x [/]FourNZ [<] x [/]TwoNZ); intros. 2: rstepl ((x [/]TwoNZ) [/]TwoNZ); apply pos_div_two'; apply pos_div_two; auto. rename X3 into H4. elim (less_cotransitive_unfolded _ _ _ H4 e); intro. apply leEq_less_trans with (x [/]FourNZ); auto. apply less_leEq. apply shift_minus_less; apply shift_less_plus'. rstepl (x[*]Three [/]FourNZ); auto. rename X1 into H2. apply H2; auto. apply shift_minus_less; apply shift_less_plus'. cut (x[-]e [<] AbsIR y); intros. 2: apply less_leEq_trans with x; auto. 2: apply shift_minus_less; apply shift_less_plus'; astepl ZeroR; auto. elim (less_AbsIR (x[-]e) y); auto. intro; exfalso. apply (less_irreflexive_unfolded _ y). eapply leEq_less_trans. 2: apply a. apply less_leEq; eapply less_transitive_unfolded. apply b. astepl ([0][-] (x[-]e)). apply shift_minus_less. astepr (x[*]Three [/]FourNZ[+]x[-]e). apply shift_less_minus; astepl e. eapply less_leEq_trans. rename X2 into H3. apply H3. apply less_leEq. rstepl (x[*] ([0][+][0][+][1] [/]TwoNZ)); rstepr (x[*] ([1][+][1] [/]FourNZ[+][1] [/]TwoNZ)). apply mult_resp_less_lft; auto. apply plus_resp_less_rht; apply plus_resp_less_leEq. apply pos_one. apply less_leEq; apply pos_div_four; apply pos_one. apply shift_less_minus; astepl e. eapply less_leEq_trans. rename X2 into H3. apply H3. apply less_leEq; apply pos_div_two'; auto. astepr ([0][+][--]x); apply shift_leEq_plus. apply leEq_wdl with (y[+]x). 2: unfold cg_minus in |- *; algebra. apply approach_zero. cut (forall e : IR, [0] [<] e -> e [<] x [/]TwoNZ -> y[+]x [<] e); intros. cut (x [/]FourNZ [<] x [/]TwoNZ); intros. 2: rstepl ((x [/]TwoNZ) [/]TwoNZ); apply pos_div_two'; apply pos_div_two; auto. rename X3 into H4. elim (less_cotransitive_unfolded _ _ _ H4 e); intro. apply leEq_less_trans with (x [/]FourNZ); auto. apply less_leEq; apply shift_plus_less. rstepr ( [--] (x[*]Three [/]FourNZ)); auto. rename X1 into H2. apply H2; auto. cut (x[-]e [<] AbsIR y); intros. 2: apply less_leEq_trans with x; auto. 2: apply shift_minus_less; apply shift_less_plus'; astepl ZeroR; auto. elim (less_AbsIR (x[-]e) y); auto. intro; exfalso. apply (less_irreflexive_unfolded _ y). eapply leEq_less_trans. 2: apply a. apply less_leEq; eapply less_transitive_unfolded. apply b. apply shift_less_minus; apply shift_plus_less'. eapply less_transitive_unfolded. rename X2 into H3. apply H3. rstepl (x[*] ([0][+][0][+][1] [/]TwoNZ)); rstepr (x[*] ([1][+][1] [/]FourNZ[+][1] [/]TwoNZ)). apply mult_resp_less_lft; auto. apply plus_resp_less_rht; apply plus_resp_less_leEq. apply pos_one. apply less_leEq; apply pos_div_four; apply pos_one. intro. rstepl (y[-][--]x). apply shift_minus_less. rstepr ( [--] (x[-]e)); auto. apply shift_less_minus; astepl e. eapply less_leEq_trans. rename X2 into H3. apply H3. apply less_leEq; apply pos_div_two'; auto. astepl (ZeroR[*]Three [/]FourNZ). apply mult_resp_less; auto. apply pos_div_four; apply pos_three. apply less_leEq_trans with x; auto. astepr (x[*][1]). astepr (x[*]Four [/]FourNZ). apply mult_resp_less_lft; auto. apply div_resp_less. apply pos_four. apply three_less_four. Qed. Lemma AbsIR_approach_zero : forall x, (forall e, [0] [<] e -> AbsIR x [<=] e) -> x [=] [0]. Proof. intros. apply leEq_imp_eq. apply approach_zero_weak. intros e H0. eapply leEq_transitive; [ apply leEq_AbsIR | exact (H e H0) ]. astepl ( [--]ZeroR); astepr ( [--][--]x); apply inv_resp_leEq. apply approach_zero_weak. intros e H0. eapply leEq_transitive; [ apply inv_leEq_AbsIR | exact (H e H0) ]. Qed. Lemma AbsSmall_approach : forall (a b : IR), (forall (e : IR), [0][<]e -> AbsSmall (a[+]e) b) -> AbsSmall a b. Proof. unfold AbsSmall. intros a b H. split. assert (forall e : IR, [0][<]e -> [--]a[-]b[<=]e). intros. assert ([--](a[+]e)[<=]b /\ b[<=]a[+]e). apply H; auto. destruct H0. apply shift_minus_leEq. apply shift_leEq_plus'. astepl ([--]a[+][--]e). astepl ([--](a[+]e)). auto. astepr (b[+][0]). apply shift_leEq_plus'. apply approach_zero_weak; auto. assert (forall e : IR, [0][<]e -> b[-]a[<=]e). intros. assert ([--](a[+]e)[<=]b /\ b[<=]a[+]e). apply H; auto. destruct H0. apply shift_minus_leEq. astepr (a[+]e). auto. astepr (a[+][0]). apply shift_leEq_plus'. apply approach_zero_weak; auto. Qed. Lemma AbsIR_eq_zero : forall x : IR, AbsIR x [=] [0] -> x [=] [0]. Proof. intros. apply AbsIR_approach_zero; intros. astepl ZeroR; apply less_leEq; auto. Qed. Lemma Abs_Max : forall a b : IR, AbsIR (a[-]b) [=] Max a b[-]Min a b. Proof. intros. apply leEq_imp_eq. apply leEq_wdl with (Max (a[-]b) (b[-]a)). 2: simpl in |- *; unfold ABSIR in |- *. 2: apply Max_wd_unfolded; rational. apply Max_leEq. unfold cg_minus in |- *; apply plus_resp_leEq_both. apply lft_leEq_Max. apply inv_resp_leEq; apply Min_leEq_rht. unfold cg_minus in |- *; apply plus_resp_leEq_both. apply rht_leEq_Max. apply inv_resp_leEq; apply Min_leEq_lft. astepr ([0][+]AbsIR (a[-]b)). apply shift_leEq_plus. apply approach_zero_weak. intros. do 2 apply shift_minus_leEq. eapply leEq_wdr. 2: apply CSemiGroups.plus_assoc. apply shift_leEq_plus'. rename X into H. elim (Max_minus_eps_leEq a b e H); intro. apply leEq_transitive with a. assumption. apply shift_leEq_plus'. apply leEq_Min. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply AbsIR_nonneg. apply shift_minus_leEq; apply shift_leEq_plus'. apply leEq_AbsIR. apply leEq_transitive with b. assumption. apply shift_leEq_plus'. apply leEq_Min. apply shift_minus_leEq; apply shift_leEq_plus'. rstepl ( [--] (a[-]b)); apply inv_leEq_AbsIR. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply AbsIR_nonneg. Qed. Lemma AbsIR_str_bnd : forall a b e : IR, AbsIR (a[-]b) [<] e -> b [<] a[+]e. Proof. intros. apply shift_less_plus'. apply leEq_less_trans with (AbsIR (a[-]b)); auto. eapply leEq_wdr; [ apply leEq_AbsIR | apply AbsIR_minus ]. Qed. Lemma AbsIR_bnd : forall a b e : IR, AbsIR (a[-]b) [<=] e -> b [<=] a[+]e. Proof. intros. apply shift_leEq_plus'. apply leEq_transitive with (AbsIR (a[-]b)); auto. eapply leEq_wdr; [ apply leEq_AbsIR | apply AbsIR_minus ]. Qed. Lemma AbsIR_less : forall a b, a[<]b -> [--]b[<]a -> AbsIR a[<]b. Proof. intros a b H0 H1. destruct (smaller _ _ _ (shift_zero_less_minus _ _ _ H0) (shift_zero_less_minus _ _ _ H1)) as [z Hz0 [Hz1 Hz2]]. apply shift_zero_less_minus'. eapply less_leEq_trans. apply Hz0. apply shift_leEq_minus. apply shift_plus_leEq'. apply AbsSmall_imp_AbsIR. split. rstepl (z[-]b). apply shift_minus_leEq. rstepr (a[-][--]b). assumption. apply shift_leEq_minus. apply shift_plus_leEq'. assumption. Qed. Lemma AbsIR_Qabs : forall (a:Q), AbsIR (inj_Q IR a)[=]inj_Q IR (Qabs a). Proof. intros a. apply Qabs_case; intros H. apply AbsIR_eq_x. stepl (inj_Q IR [0]). apply inj_Q_leEq. assumption. now apply (inj_Q_nring IR 0). stepr ([--](inj_Q IR a)). apply AbsIR_eq_inv_x. stepr (inj_Q IR [0]). apply inj_Q_leEq. assumption. now apply (inj_Q_nring IR 0). apply eq_symmetric. apply inj_Q_inv. Qed. End Absolute. #[global] Hint Resolve AbsIRz_isz: algebra. Section SeqMax. (** *** Bound of sequence *) Variable seq : nat -> IR. Fixpoint SeqBound0 (n : nat) : IR := match n with | O => [0] | S m => Max (AbsIR (seq m)) (SeqBound0 m) end. Lemma SeqBound0_greater : forall (m n : nat), (m < n)%nat -> AbsIR (seq m) [<=] SeqBound0 n. Proof. intros. elim H. simpl. apply lft_leEq_MAX. intros. simpl. apply leEq_transitive with (SeqBound0 m0); auto. apply rht_leEq_MAX. Qed. End SeqMax. Section Part_Function_Max. (** *** Functional Operators The existence of these operators allows us to lift them to functions. We will define the maximum, minimum and absolute value of two partial functions. %\begin{convention}% Let [F,G:PartIR] and denote by [P] and [Q] their respective domains. %\end{convention}% *) Variables F G : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Lemma part_function_Max_strext : forall x y (Hx : Conj P Q x) (Hy : Conj P Q y), Max (F x (Prj1 Hx)) (G x (Prj2 Hx)) [#] Max (F y (Prj1 Hy)) (G y (Prj2 Hy)) -> x [#] y. Proof. intros. rename X into H. elim (cs_bin_op_strext _ _ _ _ _ _ H). exact (pfstrx _ F _ _ _ _). exact (pfstrx _ G _ _ _ _). Qed. Definition FMax := Build_PartFunct IR _ (conj_wd (dom_wd _ _) (dom_wd _ _)) (fun x Hx => Max (F x (Prj1 Hx)) (G x (Prj2 Hx))) part_function_Max_strext. End Part_Function_Max. Section Part_Function_Abs. Variables F G : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) Definition FMin := {--} (FMax {--}F {--}G). Definition FAbs := FMax F {--}F. Lemma FMin_char : forall x Hx Hx' Hx'', FMin x Hx [=] Min (F x Hx') (G x Hx''). Proof. intros. Opaque Max. simpl in |- *; unfold MIN; algebra. Qed. Transparent Max. Lemma FAbs_char : forall x Hx Hx', FAbs x Hx [=] AbsIR (F x Hx'). Proof. intros. simpl in |- *; unfold ABSIR in |- *; apply MAX_wd; algebra. Qed. End Part_Function_Abs. #[global] Hint Resolve FAbs_char: algebra. Lemma FAbs_char' : forall F x Hx, AbsIR (FAbs F x Hx) [=] AbsIR (F x (ProjIR1 Hx)). Proof. intros. eapply eq_transitive_unfolded. apply AbsIR_eq_x. 2: apply FAbs_char. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply FAbs_char with (Hx' := ProjIR1 Hx). apply AbsIR_nonneg. Qed. Lemma FAbs_nonneg : forall F x Hx, [0] [<=] FAbs F x Hx. Proof. intros. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply FAbs_char with (Hx' := ProjIR1 Hx). apply AbsIR_nonneg. Qed. #[global] Hint Resolve FAbs_char': algebra. Section Inclusion. Variables F G : PartIR. (* begin hide *) Let P := Dom F. Let Q := Dom G. (* end hide *) (** %\begin{convention}% Let [R:IR->CProp]. %\end{convention}% *) Variable R : IR -> CProp. Lemma included_FMax : included R P -> included R Q -> included R (Dom (FMax F G)). Proof. intros; simpl in |- *; apply included_conj; assumption. Qed. Lemma included_FMax' : included R (Dom (FMax F G)) -> included R P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. Lemma included_FMax'' : included R (Dom (FMax F G)) -> included R Q. Proof. intro H; simpl in H; eapply included_conj_rht; apply H. Qed. Lemma included_FMin : included R P -> included R Q -> included R (Dom (FMin F G)). Proof. intros; simpl in |- *; apply included_conj; assumption. Qed. Lemma included_FMin' : included R (Dom (FMin F G)) -> included R P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. Lemma included_FMin'' : included R (Dom (FMin F G)) -> included R Q. Proof. intro H; simpl in H; eapply included_conj_rht; apply H. Qed. Lemma included_FAbs : included R P -> included R (Dom (FAbs F)). Proof. intros; simpl in |- *; apply included_conj; assumption. Qed. Lemma included_FAbs' : included R (Dom (FAbs F)) -> included R P. Proof. intro H; simpl in H; eapply included_conj_lft; apply H. Qed. End Inclusion. #[global] Hint Resolve included_FMax included_FMin included_FAbs : included. #[global] Hint Immediate included_FMax' included_FMin' included_FAbs' included_FMax'' included_FMin'' : included. corn-8.20.0/reals/NRootIR.v000066400000000000000000000573621473720167500153640ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing NRoot %\ensuremath{\sqrt[n]{\cdot}}% *) (** printing sqrt %\ensuremath{\sqrt{\cdot}}% *) Require Export CoRN.reals.OddPolyRootIR. Import CRing_Homomorphisms.coercions. (** * Roots of Real Numbers *) Section NRoot. (** ** Existence of roots %\begin{convention}% Let [n] be a natural number and [c] a nonnegative real. [p] is the auxiliary polynomial [_X_[^]n[-] (_C_ c)]. %\end{convention}% *) Variable n : nat. Hypothesis n_pos : 0 < n. Variable c : IR. Hypothesis c_nonneg : [0] [<=] c. (* begin hide *) Let p := _X_[^]n[-]_C_ c. (* end hide *) Lemma CnrootIR : {x : IR | [0] [<=] x | x[^]n [=] c}. Proof. intros. cut (monic n p). intro. elim (Ccpoly_pos' _ p [0] n); auto. intro X. intros H0 H1. cut {x : IR | [0] [<=] x /\ x [<=] X /\ p ! x [=] [0]}. intro H2. elim H2. clear H2. intro. intro H2. elim H2. clear H2. intros H2 H3. elim H3. clear H3. intros. exists x. auto. apply cg_inv_unique_2. astepl (_X_ ! x[^]n[-] (_C_ c) ! x). astepl ((_X_[^]n) ! x[-] (_C_ c) ! x). Step_final (_X_[^]n[-]_C_ c) ! x. apply Civt_poly; auto. apply monic_apzero with n; auto. unfold p in |- *. astepl ((_X_[^]n) ! [0][-] (_C_ c) ! [0]). astepl (_X_ ! [0][^]n[-]c). astepl ([0][^]n[-]c). astepl ([0][-]c). astepl ( [--]c). astepr ( [--]ZeroR). apply inv_resp_leEq. auto. unfold p in |- *. apply monic_minus with 0. apply degree_le_c_. pattern n at 1 in |- *. replace n with (1 * n). apply monic_nexp. apply monic_x_. auto with arith. auto. Qed. End NRoot. (** We define the root of order [n] for any nonnegative real number and prove its main properties: - $\left(\sqrt[n]x\right)^n=x$#(sqrt(n) x)^n =x#; - $0\leq\sqrt[n]x$#0≤sqrt(n)x#; - if [[0] [<] x] then $0<\sqrt[n]x$#0<sqrt(n)x#; - $\sqrt[n]{x^n}=x$#sqrt(n) x^n =x#; - the nth root is monotonous; - in particular, if [x [<] [1]] then $\sqrt[n]x<1$#sqrt(n) x<1#. [(nroot ??)] will be written as [NRoot]. *) Section Nth_Root. Lemma nroot : forall x k, [0] [<=] x -> 0 < k -> {y : IR | [0] [<=] y | y[^]k [=] x}. Proof. intros. elim (CnrootIR k H0 x H). intro y. intros. exists y; auto. Qed. Definition NRoot x n Hx Hn : IR := proj1_sig2T _ _ _ (nroot x n Hx Hn). Lemma NRoot_power : forall x k Hx Hk, NRoot x k Hx Hk[^]k [=] x. Proof. intros. unfold NRoot in |- *. apply proj2b_sig2T. Qed. Hint Resolve NRoot_power: algebra. Lemma NRoot_nonneg : forall x k Hx Hk, [0] [<=] NRoot x k Hx Hk. Proof. intros. unfold NRoot in |- *. apply proj2a_sig2T. Qed. Lemma NRoot_pos : forall x Hx k Hk, [0] [<] x -> [0] [<] NRoot x k Hx Hk. Proof. intros. rename X into H. cut ([0] [<=] NRoot x k Hx Hk); intros. cut (NRoot x k Hx Hk [<] [0] or [0] [<] NRoot x k Hx Hk). intros H1. elim H1; clear H1; intro H1. rewrite -> leEq_def in H0; elim (H0 H1). auto. apply ap_imp_less. apply un_op_strext_unfolded with (nexp_op (R:=IR) k). astepl x; astepr ZeroR. apply pos_ap_zero; auto. apply NRoot_nonneg. Qed. Lemma NRoot_power' : forall x k Hx' Hk, [0] [<=] x -> NRoot (x[^]k) k Hx' Hk [=] x. Proof. intros. apply root_unique with k; auto. apply NRoot_nonneg. apply NRoot_power. Qed. Lemma NRoot_pres_less : forall x Hx y Hy k Hk, x [<] y -> NRoot x k Hx Hk [<] NRoot y k Hy Hk. Proof. intros. apply power_cancel_less with k. apply NRoot_nonneg. eapply less_wdl. 2: apply eq_symmetric_unfolded; apply NRoot_power. eapply less_wdr. 2: apply eq_symmetric_unfolded; apply NRoot_power. auto. Qed. Lemma NRoot_less_one : forall x Hx k Hk, x [<] [1] -> NRoot x k Hx Hk [<] [1]. Proof. intros. apply power_cancel_less with k. apply less_leEq; apply pos_one. eapply less_wdl. 2: apply eq_symmetric_unfolded; apply NRoot_power. astepr OneR. assumption. Qed. Lemma NRoot_cancel : forall x Hx y Hy k Hk, NRoot x k Hx Hk [=] NRoot y k Hy Hk -> x [=] y. Proof. intros. apply eq_transitive_unfolded with (NRoot x k Hx Hk[^]k). apply eq_symmetric_unfolded; apply NRoot_power. apply eq_transitive_unfolded with (NRoot y k Hy Hk[^]k). 2: apply NRoot_power. apply nexp_wd; algebra. Qed. (** %\begin{convention}% Let [x,y] be nonnegative real numbers. %\end{convention}% *) Variables x y : IR. Hypothesis Hx : [0] [<=] x. Hypothesis Hy : [0] [<=] y. Lemma NRoot_wd : forall k Hk Hk', x [=] y -> NRoot x k Hx Hk [=] NRoot y k Hy Hk'. Proof. intros. apply root_unique with k; auto. apply NRoot_nonneg. apply NRoot_nonneg. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply H. apply NRoot_power. apply eq_symmetric_unfolded; apply NRoot_power. Qed. Lemma NRoot_unique : forall k Hk, [0] [<] x -> x[^]k [=] y -> x [=] NRoot y k Hy Hk. Proof. intros. rename H into H0. apply root_unique with k; auto. apply NRoot_nonneg. eapply eq_transitive_unfolded. apply H0. apply eq_symmetric_unfolded; apply NRoot_power. Qed. End Nth_Root. Arguments NRoot [x n]. #[global] Hint Resolve NRoot_power NRoot_power': algebra. Lemma NRoot_resp_leEq : forall x y xpos ypos k kpos, x [<=] y -> NRoot (x:=x) (n:=k) xpos kpos [<=] NRoot (x:=y) (n:=k) ypos kpos. Proof. intros. rewrite -> leEq_def; intro H0. assert (NRoot ypos kpos[^]k [<=] NRoot xpos kpos[^]k). apply power_resp_leEq. apply NRoot_nonneg. apply less_leEq; auto. assert (x [=] y). apply leEq_imp_eq; auto. eapply leEq_wdl. eapply leEq_wdr. eexact H1. algebra. algebra. clear H H1. generalize (NRoot_wd _ _ xpos ypos k kpos kpos H2). intro. apply (less_irreflexive_unfolded _ (NRoot ypos kpos)). astepr (NRoot xpos kpos). auto. Qed. Lemma NRoot_cancel_less : forall x (Hx:[0][<=]x) y (Hy:[0][<=]y) k (Hk Hk':0 x [<] y. Proof. intros x Hx y Hy k Hk Hk' H. astepl (NRoot Hx Hk[^]k). astepr (NRoot Hy Hk'[^]k). apply nexp_resp_less. auto with *. apply NRoot_nonneg. assumption. Qed. Lemma NRoot_str_ext : forall k (Hk Hk':0 < k) x y (Hx:[0][<=]x) (Hy:[0][<=]y), NRoot Hx Hk [#] NRoot Hy Hk' -> x[#]y. Proof. intros k Hk Hk' x y Hx Hy H0. destruct (ap_imp_less _ _ _ H0) as [H1|H1]. apply less_imp_ap. refine (NRoot_cancel_less _ _ _ _ _ _ _ H1). apply Greater_imp_ap. refine (NRoot_cancel_less _ _ _ _ _ _ _ H1). Qed. (*---------------------------------*) Section Square_root. (*---------------------------------*) (** ** Square root *) Definition sqrt x xpos : IR := NRoot (x:=x) (n:=2) xpos (Nat.lt_0_succ 1). Lemma sqrt_sqr : forall x xpos, sqrt x xpos[^]2 [=] x. Proof. intros. unfold sqrt in |- *. apply NRoot_power. Qed. Hint Resolve sqrt_sqr: algebra. Lemma sqrt_nonneg : forall x xpos, [0] [<=] sqrt x xpos. Proof. intros. unfold sqrt in |- *. apply NRoot_nonneg. Qed. Lemma sqrt_wd : forall x y xpos ypos, x [=] y -> sqrt x xpos [=] sqrt y ypos. Proof. intros. unfold sqrt in |- *. apply NRoot_wd. auto. Qed. Hint Resolve sqrt_wd: algebra_c. Lemma sqrt_to_nonneg : forall x, [0] [<=] x -> forall x2pos, sqrt (x[^]2) x2pos [=] x. Proof. intros. apply root_unique with 2. apply sqrt_nonneg. auto. auto. Step_final (x[^]2). Qed. Lemma sqrt_to_nonpos : forall x, x [<=] [0] -> forall x2pos, sqrt (x[^]2) x2pos [=] [--]x. Proof. intros. apply root_unique with 2. apply sqrt_nonneg. astepl ( [--]ZeroR). apply inv_resp_leEq. auto. auto. astepl (x[^]2). rational. Qed. Lemma sqrt_mult : forall x y xpos ypos xypos, sqrt (x[*]y) xypos [=] sqrt x xpos[*]sqrt y ypos. Proof. intros. apply root_unique with 2. apply sqrt_nonneg. apply mult_resp_nonneg; apply sqrt_nonneg. auto. astepl (x[*]y). astepl (sqrt x xpos[^]2[*]sqrt y ypos[^]2). rational. Qed. Hint Resolve sqrt_mult: algebra. Lemma sqrt_mult_wd : forall x y z xpos ypos zpos, z [=] x[*]y -> sqrt z zpos [=] sqrt x xpos[*]sqrt y ypos. Proof. intros. cut ([0] [<=] x[*]y). intro. Step_final (sqrt (x[*]y) H0). apply mult_resp_nonneg; auto. Qed. Lemma sqrt_less : forall x y ypos, x[^]2 [<] y -> x [<] sqrt y ypos. Proof. intros. apply power_cancel_less with 2. apply sqrt_nonneg. astepr y. auto. Qed. Lemma sqrt_less' : forall x y ypos, x[^]2 [<] y -> [--]x [<] sqrt y ypos. Proof. intros. apply power_cancel_less with 2. apply sqrt_nonneg. rstepl (x[^]2). astepr y. auto. Qed. Lemma sqrt_resp_leEq : forall x y xpos ypos, x [<=] y -> sqrt x xpos [<=] sqrt y ypos. Proof. intros. unfold sqrt in |- *. apply NRoot_resp_leEq. auto. Qed. Lemma sqrt_resp_less : forall x y xpos ypos, x [<] y -> sqrt x xpos [<] sqrt y ypos. Proof. intros. unfold sqrt in |- *. apply NRoot_pres_less. auto. Qed. End Square_root. #[global] Hint Resolve sqrt_wd: algebra_c. #[global] Hint Resolve sqrt_sqr sqrt_mult: algebra. Section Absolute_Props. (** ** More on absolute value With the help of square roots, we can prove some more properties of absolute values in [IR]. *) Lemma AbsIR_sqrt_sqr : forall x x2pos, AbsIR x [=] sqrt (x[^]2) x2pos. Proof. intros x xxpos. unfold AbsIR in |- *. simpl in |- *. unfold ABSIR in |- *. apply equiv_imp_eq_max; intros. apply power_cancel_leEq with 2. auto. apply mult_cancel_leEq with (Two:IR). apply pos_two. rstepl (x[+][--]x). rstepr (y[+]y). apply plus_resp_leEq_both; auto. astepl ([1][*]x[*]x). rstepl (x[^]2[+][0]). apply shift_plus_leEq'. rstepr ((y[-]x) [*] (y[-][--]x)). apply mult_resp_nonneg. apply shift_zero_leEq_minus. auto. apply shift_zero_leEq_minus. auto. apply leEq_transitive with (sqrt (x[^]2) xxpos). apply power_cancel_leEq with 2. auto. apply sqrt_nonneg. astepr (x[^]2). apply leEq_reflexive. auto. apply leEq_transitive with (sqrt (x[^]2) xxpos). apply power_cancel_leEq with 2. auto. apply sqrt_nonneg. astepr (x[^]2). rstepl (x[^]2). apply leEq_reflexive. auto. Qed. Hint Resolve AbsIR_sqrt_sqr: algebra. Lemma AbsIR_resp_mult : forall x y, AbsIR (x[*]y) [=] AbsIR x[*]AbsIR y. Proof. intros. astepl (sqrt ((x[*]y) [^]2) (sqr_nonneg _ (x[*]y))). cut ([0] [<=] x[^]2[*]y[^]2). intro. astepl (sqrt (x[^]2[*]y[^]2) H). Step_final (sqrt (x[^]2) (sqr_nonneg _ x) [*]sqrt (y[^]2) (sqr_nonneg _ y)). apply mult_resp_nonneg; apply sqr_nonneg. Qed. Lemma AbsIR_mult_pos : forall x y, [0] [<=] y -> AbsIR (x[*]y) [=] AbsIR x[*]y. Proof. intros. apply eq_transitive_unfolded with (AbsIR x[*]AbsIR y). apply AbsIR_resp_mult. apply bin_op_wd_unfolded. algebra. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *. apply eq_transitive_unfolded with (Max [--]y y). apply Max_comm. apply leEq_imp_Max_is_rht. apply leEq_transitive with ZeroR. astepr ( [--]ZeroR). apply inv_resp_leEq; assumption. assumption. Qed. Lemma AbsIR_mult_pos' : forall x y, [0] [<=] x -> AbsIR (x[*]y) [=] x[*]AbsIR y. Proof. intros. astepl (AbsIR (y[*]x)). eapply eq_transitive_unfolded. apply AbsIR_mult_pos; auto. algebra. Qed. Lemma AbsIR_nexp : forall x n, AbsIR (nexp _ n x) [=] nexp _ n (AbsIR x). Proof. intros. induction n as [| n Hrecn]. simpl in |- *; apply AbsIR_eq_x; apply less_leEq; apply pos_one. simpl in |- *. eapply eq_transitive_unfolded. apply AbsIR_resp_mult. algebra. Qed. Lemma AbsIR_nexp_op : forall n x, AbsIR (x[^]n) [=] AbsIR x[^]n. Proof. intros; simpl in |- *; apply AbsIR_nexp. Qed. Lemma AbsIR_less_square : forall x y, AbsIR x [<] y -> x[^]2 [<] y[^]2. Proof. intros. eapply less_wdl. 2: apply AbsIR_eq_x; apply sqr_nonneg. eapply less_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op. apply nexp_resp_less; auto. apply AbsIR_nonneg. Qed. Lemma AbsIR_leEq_square : forall x y, AbsIR x [<=] y -> x[^]2 [<=] y[^]2. Proof. intros. eapply leEq_wdl. 2: apply AbsIR_eq_x; apply sqr_nonneg. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op. apply nexp_resp_leEq; auto. apply AbsIR_nonneg. Qed. Lemma AbsIR_division : forall x y y_ y__, AbsIR (x[/] y[//]y_) [=] (AbsIR x[/] AbsIR y[//]y__). Proof. intros x y H Hy. rstepr (AbsIR x[*] ([1][/] AbsIR y[//]Hy)). apply eq_transitive_unfolded with (AbsIR (x[*] ([1][/] y[//]H))). apply un_op_wd_unfolded; rational. apply eq_transitive_unfolded with (AbsIR x[*]AbsIR ([1][/] y[//]H)). apply AbsIR_resp_mult. apply mult_wdr. cut (y [<] [0] or [0] [<] y). intros H0. elim H0. intros. apply eq_transitive_unfolded with ( [--] ([1][/] y[//]H)). apply AbsIR_eq_inv_x. rstepr ([0][/] [--]y[//]inv_resp_ap_zero _ _ H). apply shift_leEq_div. astepl ( [--]ZeroR). apply inv_resp_less; assumption. rstepl ( [--]OneR). astepr ( [--]ZeroR); apply inv_resp_leEq; apply less_leEq; apply pos_one. rstepl ([1][/] [--]y[//]inv_resp_ap_zero _ _ H). apply div_wd. algebra. apply eq_symmetric_unfolded; apply AbsIR_eq_inv_x. apply less_leEq; assumption. intros. apply eq_transitive_unfolded with ([1][/] y[//]H). apply AbsIR_eq_x. apply less_leEq; apply recip_resp_pos; assumption. apply div_wd; [ algebra | apply eq_symmetric_unfolded; apply AbsIR_eq_x; apply less_leEq; assumption ]. apply ap_imp_less. assumption. Qed. (** Some special cases. *) Lemma AbsIR_recip : forall x x_ x__, AbsIR ([1][/] x[//]x_) [=] ([1][/] AbsIR x[//]x__). Proof. intros x H Ha. apply eq_transitive_unfolded with (AbsIR [1][/] AbsIR x[//]Ha). apply AbsIR_division. apply div_wd. 2: algebra. apply AbsIR_eq_x; apply less_leEq; apply pos_one. Qed. Lemma AbsIR_div_two : forall x, AbsIR (x [/]TwoNZ) [=] AbsIR x [/]TwoNZ. Proof. intros. apply eq_transitive_unfolded with (AbsIR x[/] AbsIR Two[//] AbsIR_resp_ap_zero _ (ap_symmetric_unfolded _ _ _ (less_imp_ap _ _ _ (pos_two _)))). apply AbsIR_division. apply div_wd. algebra. apply AbsIR_eq_x; apply less_leEq; apply pos_two. Qed. (** Cauchy-Schwartz for IR and variants on that subject. *) Lemma triangle_IR : forall x y, AbsIR (x[+]y) [<=] AbsIR x[+]AbsIR y. Proof. intros. astepl (sqrt ((x[+]y) [^]2) (sqr_nonneg _ (x[+]y))). astepr (sqrt (x[^]2) (sqr_nonneg _ x) [+]sqrt (y[^]2) (sqr_nonneg _ y)). apply power_cancel_leEq with 2. auto. astepl ([0][+]ZeroR). apply plus_resp_leEq_both; apply sqrt_nonneg. astepl ((x[+]y) [^]2). rstepl (x[^]2[+]y[^]2[+]Two[*] (x[*]y)). rstepr (sqrt (x[^]2) (sqr_nonneg IR x) [^]2[+]sqrt (y[^]2) (sqr_nonneg IR y) [^]2[+] Two[*] (sqrt (x[^]2) (sqr_nonneg IR x) [*]sqrt (y[^]2) (sqr_nonneg IR y))). apply plus_resp_leEq_both. astepr (x[^]2[+]y[^]2). apply leEq_reflexive. apply mult_resp_leEq_lft. apply power_cancel_leEq with 2. auto. apply mult_resp_nonneg; apply sqrt_nonneg. rstepr (sqrt (x[^]2) (sqr_nonneg _ x) [^]2[*]sqrt (y[^]2) (sqr_nonneg _ y) [^]2). astepr (x[^]2[*]y[^]2). astepl (x[^]2[*]y[^]2). apply leEq_reflexive. apply less_leEq. apply pos_two. Qed. Lemma triangle_SumIR : forall k l s, k <= S l -> AbsIR (Sum k l s) [<=] Sum k l (fun i => AbsIR (s i)). Proof. intros. induction l as [| l Hrecl]. generalize (toCle _ _ H); clear H; intro H. inversion H as [|m H0 H1]. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. rstepr ZeroR. astepr (AbsIR [0]). apply eq_imp_leEq. apply AbsIR_wd. rational. inversion H0. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. rstepr (ABSIR (s 0)). apply eq_imp_leEq. apply AbsIR_wd. rational. elim (le_lt_eq_dec k (S (S l))); try intro y. apply leEq_wdl with (AbsIR (Sum k l s[+]s (S l))). apply leEq_wdr with (Sum k l (fun i : nat => AbsIR (s i)) [+]AbsIR (s (S l))). apply leEq_transitive with (AbsIR (Sum k l s) [+]AbsIR (s (S l))). apply triangle_IR. apply plus_resp_leEq. apply Hrecl. auto with arith. apply eq_symmetric_unfolded. apply Sum_last with (f := fun i : nat => AbsIR (s i)). apply AbsIR_wd. apply eq_symmetric_unfolded. apply Sum_last. rewrite y. unfold Sum in |- *. unfold Sum1 in |- *. simpl in |- *. rstepr ZeroR. astepr (AbsIR [0]). apply eq_imp_leEq. apply AbsIR_wd. rational. auto. Qed. Lemma triangle_IR_minus : forall x y, AbsIR (x[-]y) [<=] AbsIR x[+]AbsIR y. Proof. intros. unfold cg_minus in |- *. apply leEq_wdr with (AbsIR x[+]AbsIR [--]y). apply triangle_IR. apply bin_op_wd_unfolded. algebra. unfold AbsIR in |- *; simpl in |- *; unfold ABSIR in |- *. apply eq_transitive_unfolded with (Max [--]y y). apply bin_op_wd_unfolded; algebra. apply Max_comm. Qed. Lemma weird_triangleIR : forall x y, AbsIR x[-]AbsIR (y[-]x) [<=] AbsIR y. Proof. intros. apply shift_minus_leEq. simpl in |- *; unfold ABSIR in |- *; apply Max_leEq. rstepl (y[+][--] (y[-]x)). apply plus_resp_leEq_both; [ apply lft_leEq_Max | apply rht_leEq_Max ]. rstepl ( [--]y[+] (y[-]x)). apply plus_resp_leEq_both; [ apply rht_leEq_Max | apply lft_leEq_Max ]. Qed. Lemma triangle_IR_minus' : forall x y, AbsIR x[-]AbsIR y [<=] AbsIR (x[-]y). Proof. intros. eapply leEq_wdr. 2: apply AbsIR_minus. apply shift_minus_leEq; apply shift_leEq_plus'. apply weird_triangleIR. Qed. Lemma triangle_SumxIR : forall n (f : forall i, i < n -> IR), AbsIR (Sumx f) [<=] Sumx (fun i H => AbsIR (f i H)). Proof. simple induction n. intros; simpl in |- *. apply eq_imp_leEq; apply AbsIRz_isz. clear n; intros. simpl in |- *; eapply leEq_transitive. apply triangle_IR. apply plus_resp_leEq. eapply leEq_wdr. apply H. apply Sumx_wd. intros; algebra. Qed. Lemma triangle_Sum2IR : forall m n (f : forall i, m <= i -> i <= n -> IR), m <= S n -> AbsIR (Sum2 f) [<=] Sum2 (fun i Hm Hn => AbsIR (f i Hm Hn)). Proof. intros. unfold Sum2 in |- *. eapply leEq_wdr. apply triangle_SumIR. assumption. apply Sum_wd'. assumption. intros. elim (le_lt_dec m i); intro; [ simpl in |- * | exfalso; apply (Nat.le_ngt m i); auto with arith ]. elim (le_lt_dec i n); intro; [ simpl in |- * | exfalso; apply (Nat.le_ngt i n); auto with arith ]. algebra. Qed. Lemma AbsIR_str_bnd_AbsIR : forall a b e, AbsIR (a[-]b) [<] e -> AbsIR b [<] AbsIR a[+]e. Proof. do 3 intro. intro H. apply shift_less_plus'. eapply leEq_less_trans. apply triangle_IR_minus'. eapply less_wdl; [ apply H | apply AbsIR_minus ]. Qed. Lemma AbsIR_bnd_AbsIR : forall a b e, AbsIR (a[-]b) [<=] e -> AbsIR b [<=] AbsIR a[+]e. Proof. intros. apply shift_leEq_plus'. eapply leEq_transitive. apply triangle_IR_minus'. eapply leEq_wdl; [ apply H | apply AbsIR_minus ]. Qed. End Absolute_Props. Section Consequences. (** ** Cauchy sequences With these results, we can also prove that the sequence of reciprocals of a Cauchy sequence that is never zero and whose Limit is not zero is also a Cauchy sequence. *) Lemma Cauchy_Lim_recip : forall seq y, Cauchy_Lim_prop2 seq y -> forall seq_ y_, Cauchy_Lim_prop2 (fun n : nat => [1][/] seq n[//]seq_ n) ([1][/] y[//]y_). Proof. intros seq y H Hn Hy. red in |- *; red in H. intros eps He. cut {n0 : nat | forall n : nat, n0 <= n -> AbsIR y [/]TwoNZ [<=] AbsIR (seq n)}. intro H0. elim H0; clear H0; intros n0 Hn0. cut ([0] [<] eps [/]TwoNZ[*] (AbsIR y[*]AbsIR y)). intro H0. elim (H _ H0); clear H. intros N HN. exists (Nat.max N n0). intros. apply AbsIR_imp_AbsSmall. apply leEq_wdl with (([1][/] _[//]AbsIR_resp_ap_zero _ (Hn m)) [*] ([1][/] _[//]AbsIR_resp_ap_zero _ Hy) [*]AbsIR (seq m[-]y)). rstepr ((Two[/] _[//]AbsIR_resp_ap_zero _ Hy) [*] ([1][/] _[//]AbsIR_resp_ap_zero _ Hy) [*] (eps [/]TwoNZ[*] (AbsIR y[*]AbsIR y))). apply mult_resp_leEq_both. astepl (ZeroR[*][0]); apply mult_resp_leEq_both; try apply leEq_reflexive. apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hn. apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hy. apply AbsIR_nonneg. apply mult_resp_leEq_rht. rstepr ([1][/] _[//] div_resp_ap_zero_rev _ _ _ (two_ap_zero _) (AbsIR_resp_ap_zero _ Hy)). apply recip_resp_leEq. apply pos_div_two; apply AbsIR_pos; apply Hy. apply Hn0. apply Nat.le_trans with (Nat.max N n0); auto with arith. apply less_leEq; apply recip_resp_pos; apply AbsIR_pos; apply Hy. apply AbsSmall_imp_AbsIR. apply HN. apply Nat.le_trans with (Nat.max N n0); auto with arith. apply eq_transitive_unfolded with (AbsIR ([1][/] _[//]Hn m) [*]AbsIR ([1][/] _[//]Hy) [*]AbsIR (y[-]seq m)). repeat apply mult_wd; apply eq_symmetric_unfolded. apply AbsIR_recip. apply AbsIR_recip. apply AbsIR_minus. apply eq_transitive_unfolded with (AbsIR (([1][/] _[//]Hn m) [*] ([1][/] _[//]Hy) [*] (y[-]seq m))). eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_wdl. apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply AbsIR_wd. rational. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive. apply pos_div_two; assumption. astepl (ZeroR[*][0]); apply mult_resp_less_both; try apply leEq_reflexive; apply AbsIR_pos; apply Hy. cut {n0 : nat | forall n : nat, n0 <= n -> AbsSmall (AbsIR y [/]TwoNZ) (seq n[-]y)}. 2: apply H. 2: eapply less_wdr. 3: apply AbsIR_div_two. 2: apply AbsIR_pos. 2: apply div_resp_ap_zero_rev; apply Hy. intro H0. elim H0; intros n0 Hn0; clear H0; exists n0; intros. apply leEq_transitive with (AbsIR y[-]AbsIR (seq n[-]y)). apply shift_leEq_minus; apply shift_plus_leEq'. rstepr (AbsIR y [/]TwoNZ). apply AbsSmall_imp_AbsIR. apply Hn0; assumption. apply weird_triangleIR. Qed. Lemma Cauchy_recip : forall seq seq_, Lim seq [#] ([0]:IR) -> Cauchy_prop (fun n => [1][/] seq n[//]seq_ n). Proof. intros seq Hn Hy. apply Cauchy_prop2_prop. exists ([1][/] _[//]Hy). apply Cauchy_Lim_recip. apply Cauchy_complete. Qed. Lemma Lim_recip : forall seq seq_ seq__, Lim (Build_CauchySeq _ _ (Cauchy_recip seq seq_ seq__)) [=] ([1][/] _[//]seq__). Proof. intros. apply eq_symmetric_unfolded; apply Limits_unique. simpl in |- *; apply Cauchy_Lim_recip. apply Cauchy_complete. Qed. End Consequences. Section Part_Function_NRoot. (** *** Functional Operators %\begin{convention}% Let [F:PartIR] and denote by [P] its domain, which must be entirely nonnegative. %\end{convention}% *) Variables F : PartIR. Let P := Dom F. Let R := extend P (fun x Hx => [0][<=]F x Hx). Let Ext2R := ext2 (P:=P) (R:=fun x Hx => [0][<=]F x Hx). Variable n : nat. Hypothesis Hn : 0 < n. Lemma part_function_NRoot_strext : forall x y Hx Hy, NRoot (Ext2R x Hx) Hn [#] NRoot (Ext2R y Hy) Hn -> x [#] y. Proof. intros x y Hx Hy H. refine (pfstrx _ _ _ _ _ _ (NRoot_str_ext _ _ _ _ _ _ _ H)). Qed. Lemma part_function_NRoot_pred_wd : pred_wd _ R. Proof. intros x y H H0. elim H. intros H1 H2. split. apply (dom_wd _ F x y H1 H0). intros H3. astepr (F x H1). auto. Qed. Definition FNRoot := Build_PartFunct IR _ part_function_NRoot_pred_wd (fun x Hx => NRoot (Ext2R x Hx) Hn) part_function_NRoot_strext. Section Included. Variable S:IR -> CProp. Lemma included_FNRoot : included S P -> (forall x, S x -> forall Hx, [0][<=]F x Hx) -> included S (Dom FNRoot). Proof. intros H H0. simpl in |- *. unfold extend in |- *. split. apply H; assumption. intros; apply H0; assumption. Qed. Lemma included_FNRoot' : included S (Dom FNRoot) -> included S P. Proof. intro H; simpl in H; eapply included_extend; unfold R in *; apply H. Qed. End Included. End Part_Function_NRoot. #[global] Hint Resolve included_FNRoot included_FNRoot' : included. corn-8.20.0/reals/OddPolyRootIR.v000066400000000000000000000212361473720167500165300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.IVT. Import CRing_Homomorphisms.coercions. (** * Roots of polynomials of odd degree *) Section CPoly_Big. (** ** Monic polynomials are positive near infinity %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. (* begin hide *) Let RX := (cpoly R). (* end hide *) Lemma Cbigger : forall x y : R, {z : R | x [<=] z | y [<=] z}. Proof. intros. elim (less_cotransitive_unfolded _ x (x[+][1]) (less_plusOne _ _) y); intro. exists (y[+][1]); apply less_leEq. apply less_leEq_trans with y. auto. apply less_leEq; apply less_plusOne. apply less_plusOne. exists (x[+][1]); apply less_leEq. apply less_plusOne. auto. Qed. Lemma Ccpoly_big : forall (p : RX) n, 0 < n -> monic n p -> forall Y, {X : R | forall x, X [<=] x -> Y [<=] p ! x}. Proof. intro. elim p. unfold monic in |- *. simpl in |- *. intros. elim H0. intros H1 H2. cut ([0][~=] ([1]:R)). intro. elim (H3 H1). apply ap_imp_neq. apply ap_symmetric_unfolded. apply ring_non_triv. intros c q. intros H n H0 H1 Y. elim (O_or_S n); intro y. elim y. intro m. intro y0. rewrite <- y0 in H1. elim (zerop m); intro y1. simpl in |- *. exists (Y[-]c). intros. rewrite y1 in H1. apply shift_leEq_plus'. cut (q ! x [=] [1]). intro. astepr (x[*][1]). astepr x. auto. apply monic_one with c. auto. cut (monic m q). intro H2. elim (Cbigger [0] (Y[-]c)). intro Y'. intros H3 H4. elim (H m y1 H2 Y'). intro X'. intro H5. simpl in |- *. elim (Cbigger [1] X'). intro X. intros H6 H7. exists X. intros. apply shift_leEq_plus'. apply leEq_transitive with ([1][*]Y'). astepr Y'. auto. apply mult_resp_leEq_both; auto. apply less_leEq. apply pos_one. apply leEq_transitive with X; auto. change (Y' [<=] q ! x) in |- *. apply H5. apply leEq_transitive with X; auto. apply monic_cpoly_linear with c; auto. rewrite <- y in H0. elim (Nat.lt_irrefl _ H0). Qed. Lemma cpoly_pos : forall (p : RX) n, 0 < n -> monic n p -> {x : R | [0] [<=] p ! x}. Proof. intros. elim (Ccpoly_big _ _ H H0 [0]). intros x H1. exists (x[+][1]). apply H1. apply less_leEq. apply less_plusOne. Qed. Lemma Ccpoly_pos' : forall (p : RX) a n, 0 < n -> monic n p -> {x : R | a [<] x | [0] [<=] p ! x}. Proof. intros. elim (Ccpoly_big _ _ H H0 [0]). intro x'. intro H1. elim (Cbigger (a[+][1]) x'). intro x. intros. exists x; auto. apply less_leEq_trans with (a[+][1]). apply less_plusOne. auto. Qed. End CPoly_Big. Section Flip_Poly. (** ** Flipping a polynomial %\begin{convention}% Let [R] be a ring. %\end{convention}% *) Variable R : CRing. Add Ring R: (CRing_Ring R). (* begin hide *) Let RX := (cpoly R). (* end hide *) Fixpoint flip (p : RX) : RX := match p with | cpoly_zero _ => cpoly_zero _ | cpoly_linear _ c q => cpoly_inv _ (cpoly_linear _ c (flip q)) end. Lemma flip_poly : forall (p : RX) x, (flip p) ! x [=] [--]p ! ( [--]x). Proof. intro p. elim p. intros. simpl in |- *. algebra. intros c q. intros. change ( [--]c[+]x[*] (cpoly_inv _ (flip q)) ! x [=] [--] (c[+][--]x[*]q ! ( [--]x))) in |- *. astepl ( [--]c[+]x[*][--] (flip q) ! x). astepl ( [--]c[+]x[*][--][--]q ! ( [--]x)). ring. Qed. Lemma flip_coefficient : forall (p : RX) i, nth_coeff i (flip p) [=] [--] ( [--][1][^]i) [*]nth_coeff i p. Proof. intro p. elim p. simpl in |- *. algebra. intros c q. intros. elim i. simpl in |- *. ring. intros. simpl in |- *. astepl ( [--] (nth_coeff n (flip q))). astepl ( [--] ( [--] ( [--][1][^]n) [*]nth_coeff n q)). simpl in |- *. ring. Qed. Hint Resolve flip_coefficient: algebra. Lemma flip_odd : forall (p : RX) n, Nat.Odd n -> monic n p -> monic n (flip p). Proof. unfold monic in |- *. unfold degree_le in |- *. intros. elim H0. clear H0. intros. split. astepl ( [--] ( [--][1][^]n) [*]nth_coeff n p). astepl ( [--][--] ([1][^]n) [*]nth_coeff n p). astepl ([1][^]n[*]nth_coeff n p). astepl ([1][*]nth_coeff n p). Step_final ([1][*] ([1]:R)). intros. astepl ( [--] ( [--][1][^]m) [*]nth_coeff m p). Step_final ( [--] ( [--][1][^]m) [*] ([0]:R)). Qed. End Flip_Poly. #[global] Hint Resolve flip_poly: algebra. Section OddPoly_Signs. (** ** Sign of a polynomial of odd degree %\begin{convention}% Let [R] be an ordered field. %\end{convention}% *) Variable R : COrdField. (* begin hide *) Let RX := (cpoly R). (* end hide *) Lemma oddpoly_pos : forall (p : RX) n, Nat.Odd n -> monic n p -> {x : R | [0] [<=] p ! x}. Proof. intros p n H1 H2. apply cpoly_pos with n; auto. destruct H1 as [m ->]; rewrite Nat.add_1_r; exact (Nat.lt_0_succ _). Qed. Lemma oddpoly_pos' : forall (p : RX) a n, Nat.Odd n -> monic n p -> {x : R | a [<] x | [0] [<=] p ! x}. Proof. intros p a n H1 H2. elim (Ccpoly_pos' _ p a n). - intros x Hx Hp; exists x; assumption. - destruct H1 as [m ->]; rewrite Nat.add_1_r; exact (Nat.lt_0_succ _). - assumption. Qed. Lemma oddpoly_neg : forall (p : RX) n, Nat.Odd n -> monic n p -> {x : R | p ! x [<=] [0]}. Proof. intros. elim (oddpoly_pos _ _ H (flip_odd _ _ _ H H0)). intro x. intros. exists ( [--]x). astepl ( [--][--]p ! ( [--]x)). astepr ( [--] ([0]:R)). apply inv_resp_leEq. astepr (flip _ p) ! x. auto. Qed. End OddPoly_Signs. Section Poly_Norm. (** ** The norm of a polynomial %\begin{convention}% Let [R] be a field, and [RX] the polynomials over this field. %\end{convention}% *) Variable R : CField. (* begin hide *) Let RX := cpoly_cring R. (* end hide *) Lemma poly_norm_aux : forall (p : RX) n, degree n p -> nth_coeff n p [#] [0]. Proof. unfold degree in |- *. intros p n H. elim H. auto. Qed. Definition poly_norm p n H := _C_ ([1][/] _[//]poly_norm_aux p n H) [*]p. Lemma poly_norm_monic : forall p n H, monic n (poly_norm p n H). Proof. unfold poly_norm in |- *. unfold monic in |- *. unfold degree in |- *. unfold degree_le in |- *. intros. elim H. intros H0 H1. split. Step_final (([1][/] nth_coeff n p[//]poly_norm_aux p n (pair H0 H1)) [*] nth_coeff n p). intros. astepl (([1][/] nth_coeff n p[//]poly_norm_aux p n (pair H0 H1)) [*] nth_coeff m p). Step_final (([1][/] nth_coeff n p[//]poly_norm_aux p n H) [*][0]). Qed. Lemma poly_norm_apply : forall p n H x, (poly_norm p n H) ! x [=] [0] -> p ! x [=] [0]. Proof. unfold poly_norm in |- *. intros. apply mult_cancel_lft with ([1][/] nth_coeff n p[//]poly_norm_aux p n H). apply div_resp_ap_zero_rev. apply ring_non_triv. astepl ((_C_ ([1][/] nth_coeff n p[//]poly_norm_aux p n H)) ! x[*]p ! x). astepl (_C_ ([1][/] nth_coeff n p[//]poly_norm_aux p n H) [*]p) ! x. Step_final ([0]:R). Qed. End Poly_Norm. Section OddPoly_Root. (** ** Roots of polynomials of odd degree Polynomials of odd degree over the reals always have a root. *) Lemma oddpoly_root' : forall f n, Nat.Odd n -> monic n f -> {x : IR | f ! x [=] [0]}. Proof. intros. elim (oddpoly_neg _ f n); auto. intro a. intro H1. elim (oddpoly_pos' _ f a n); auto. intro b. intros H2 H3. cut {x : IR | a [<=] x /\ x [<=] b /\ f ! x [=] [0]}. intro H4. elim H4. clear H4. intros x H4. elim H4. clear H4. intros H4 H5. elim H5. clear H5. intros. exists x. auto. apply Civt_poly; auto. apply monic_apzero with n; auto. Qed. Lemma oddpoly_root : forall f n, Nat.Odd n -> degree n f -> {x : IR | f ! x [=] [0]}. Proof. intros f n H H0. elim (oddpoly_root' (poly_norm _ f n H0) n); auto. intros. exists x. apply poly_norm_apply with n H0; auto. apply poly_norm_monic; auto. Qed. Lemma realpolyn_oddhaszero : forall f, odd_cpoly _ f -> {x : IR | f ! x [=] [0]}. Proof. unfold odd_cpoly in |- *. intros f H. elim H. clear H. intro n. intros H H0. cut (Nat.Odd n). intro. elim (oddpoly_root f n H1 H0). intros. exists x. auto. apply Codd_to. assumption. Qed. End OddPoly_Root. corn-8.20.0/reals/PosSeq.v000066400000000000000000000114021473720167500152630ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.Series. Section SeqProperties. Definition seq_pos (x : nat -> IR) := forall n : nat, [0] [<] x n. Definition seq_inf_sum (x : nat -> IR) := forall M : IR, {N : nat | forall m : nat, N <= m -> M [<] seq_part_sum x m}. Lemma One_part_sum : forall (m : nat), seq_part_sum (fun n : nat => [1]) m [=] nring m. Proof. intros. induction m; simpl; algebra. Qed. Lemma One_seq_is_pos : seq_pos (fun n : nat => [1]). Proof. unfold seq_pos. intros. apply pos_one. Qed. Lemma One_seq_is_inf_sum : seq_inf_sum (fun n : nat => [1]). Proof. unfold seq_inf_sum. intros. assert ({N : nat | M [<] nring N}). apply Archimedes'. destruct X as [N H]. exists N. intros. apply less_leEq_trans with (nring (R:=IR) N); auto. assert (seq_part_sum (fun n : nat => [1]) m [=] nring m). apply One_part_sum. astepr (nring (R:=IR) m). apply nring_leEq. auto. Qed. Lemma seq_pos_imp_sum_pos : forall (x : nat -> IR), seq_pos x -> forall n, [0] [<] seq_part_sum x (S n). Proof. intros. induction n. simpl. astepl ([0][+][0]:IR). apply plus_resp_less_lft. apply X. simpl. simpl in |- *. apply plus_resp_pos. apply IHn. apply X. Qed. Lemma seq_pos_imp_sum_pos' : forall (x : nat -> IR) (H1 : seq_pos x) (n m : nat) (H2 : m < n), [0] [<] Sum m n x. Proof. unfold seq_pos. intros. induction n. assert (~ m < 0). auto with arith. contradiction. elim (le_lt_eq_dec _ _ H2); intros H3. astepr (Sum m n x [+] x (S n)). apply plus_resp_pos. apply IHn; auto with arith. apply H1. replace n with m; auto. astepr (Sum m m x [+]x (S m)). apply plus_resp_pos. astepr (x m). apply H1. apply H1. Qed. Lemma seq_pos_imp_ap_zero : forall (x : nat -> IR), seq_pos x -> forall n, seq_part_sum x (S n) [#] [0]. Proof. unfold seq_pos. intros. apply ap_symmetric_unfolded. apply less_imp_ap. apply seq_pos_imp_sum_pos; auto. Qed. Lemma seq_inf_sum_imp_div_small : forall (x : nat -> IR) (H1 : seq_inf_sum x) (H2: seq_pos x) (C e : IR) (H4 : [0] [<] e), { N : nat | forall m : nat, N <= m -> AbsSmall e (C [/](seq_part_sum x (S m)) [//] (seq_pos_imp_ap_zero x H2 m))}. Proof. unfold seq_inf_sum. unfold seq_pos. intros. assert ({N : nat | forall m : nat, N <= m -> ((AbsIR C)[/]e[//]pos_ap_zero IR e H4)[<]seq_part_sum x m}). apply (H1 ((AbsIR C) [/] e [//] (pos_ap_zero IR e H4))). destruct X as [N H]. exists N. intros. assert (H3 : ((AbsIR C)[/]e[//]pos_ap_zero IR e H4)[<]seq_part_sum x (S m)). apply H; auto. astepr ((C [/] seq_part_sum x (S m)[//] (seq_pos_imp_ap_zero x H2 m))). assert (AbsSmall ((seq_part_sum x (S m))[*]e) C). apply AbsIR_imp_AbsSmall. apply less_leEq. apply (shift_less_mult IR (AbsIR C) (seq_part_sum x (S m)) e (pos_ap_zero IR e H4)); auto. rstepl ((seq_part_sum x (S m))[*]e [/] (seq_part_sum x (S m))[//] pos_ap_zero IR (seq_part_sum x (S m)) (seq_pos_imp_sum_pos x H2 m)). rstepr (C [/] (seq_part_sum x (S m))[//] pos_ap_zero IR (seq_part_sum x (S m)) (seq_pos_imp_sum_pos x H2 m)). apply div_resp_AbsSmall. auto. Qed. Lemma seq_inf_sum_ratio_bound : forall (y : nat->IR) (H2 : seq_pos y) (m N1: nat) (H3: S N1 < m), AbsSmall [1] (Sum (G:=IR) (S N1) m (fun k : nat => y k)[/] seq_part_sum y (S m)[//]seq_pos_imp_ap_zero y H2 m). Proof. intros. apply leEq_imp_AbsSmall. apply shift_leEq_div. apply seq_pos_imp_sum_pos; auto. astepl ([0]:IR). apply less_leEq. apply seq_pos_imp_sum_pos'; auto. apply shift_div_leEq. apply seq_pos_imp_sum_pos; auto. astepl (Sum (G:=IR) (S N1) m y). astepr (seq_part_sum y (S m)). unfold Sum. unfold Sum1. unfold seq_part_sum. apply shift_zero_leEq_minus'. rstepr (Sum0 (G:=IR) (S N1) y). apply less_leEq. astepr (seq_part_sum y (S N1)). apply seq_pos_imp_sum_pos; auto. Qed. End SeqProperties. corn-8.20.0/reals/Q_dense.v000066400000000000000000000551051473720167500154370ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.reals.Q_in_CReals. (*----- Opaque_algebra.v will be loaded in line 151 -----*) Lemma or_not_and : forall (A : CProp) (B : Prop), Not A \/ ~ B -> Not (A and B). Proof. intros. intro H0. elim H0. intros. case H. intro H3. apply H3. assumption. intro H3. apply H3. assumption. Qed. Section Interval_definition. Variable OF : COrdField. Record Interval : Type := {pair_crr :> prodT OF OF; is_interval : fstT pair_crr[<]sndT pair_crr}. Definition Length (I1 : Interval) : OF := sndT I1[-]fstT I1. End Interval_definition. Definition Rat_Interval := Interval Q_as_COrdField. (* we have this in Q_COrdField... *) Lemma Qlt_eq_gt_dec' : forall q1 q2 : Q_as_COrdField, ((q1[<]q2) or (q2[<]q1)) or (q1[=]q2). Proof. intros. case (Q_dec q1 q2); intuition. Qed. (* Lemma ex_informative_on_Q:(P:Q_as_COrdField->Prop)(Ex [q:Q_as_COrdField](P q)) ->{q:Q_as_COrdField | (P q)}. Proof. Intro. Intro. Apply ex_informative. Assumption. Qed. *) Section COrdField_extra. Variable OF : COrdField. Lemma AbsSmall_pos_reflexive : forall x : OF, ([0][<=]x) -> AbsSmall x x. Proof. intros. split. apply leEq_transitive with (y := [0]:OF). apply inv_cancel_leEq. rstepl ([0]:OF). rstepr x. assumption. assumption. apply leEq_reflexive. Qed. Lemma AbsSmall_neg_reflexive : forall x : OF, ([0][<=]x) -> AbsSmall x [--]x. Proof. intros. split. apply leEq_reflexive. apply leEq_transitive with (y := [0]:OF). apply inv_cancel_leEq. rstepl ([0]:OF). rstepr x. assumption. assumption. Qed. Lemma AbsSmall_subinterval : forall a b x y : OF, (a[<=]x) -> (a[<=]y) -> (x[<=]b) -> (y[<=]b) -> AbsSmall (b[-]a) (x[-]y). Proof. intros. split. rstepl (a[+][--]b). rstepr (x[+][--]y). apply plus_resp_leEq_both. assumption. apply inv_resp_leEq. assumption. rstepl (x[+][--]y). rstepr (b[+][--]a). apply plus_resp_leEq_both. assumption. apply inv_resp_leEq. assumption. Qed. End COrdField_extra. Section Rational_sequence. Load "Opaque_algebra". (* WARNING: A file is being loaded *) Variable R1 : CReals. Definition start_l (x : R1) := let (N, _) := start_of_sequence _ x in N. Lemma start_of_sequence2 : forall x : R1, {q2 : Q_as_COrdField | inj_Q R1 (start_l x)[<]x | x[<]inj_Q R1 q2}. Proof. intro. apply (ProjT2 (start_of_sequence _ x)). Qed. Definition start_r (x : R1) := let (N, _, _) := start_of_sequence2 x in N. Lemma start_of_sequence_property : forall x : R1, (inj_Q R1 (start_l x)[<]x) and (x[<]inj_Q R1 (start_r x)). Proof. intro. unfold start_l, start_r in |- *. elim start_of_sequence2; auto. Qed. Lemma l_less_r : forall x : R1, start_l x[<]start_r x. Proof. intro. apply less_inj_Q with (R1 := R1). elim (start_of_sequence_property x). apply less_transitive_unfolded. Qed. Lemma shrink23 : forall q1 q2 : Q_as_COrdField, (q1[<]q2) -> q1[+](q2[-]q1) [/]ThreeNZ[<]q2[-](q2[-]q1) [/]ThreeNZ. Proof. intros. apply plus_cancel_less with (R := Q_as_COrdField) (z := (q2[-]q1) [/]ThreeNZ). rstepl (q2[-](q2[-]q1) [/]ThreeNZ). rstepr q2. apply plus_cancel_less with (R := Q_as_COrdField) (z := [--]q2). rstepr [--]([0]:Q_as_COrdField). rstepl [--]((q2[-]q1) [/]ThreeNZ). apply inv_resp_less. apply mult_cancel_less with (R := Q_as_COrdField) (z := Three:Q_as_COrdField). apply pos_nring_S. rstepl ([0]:Q_as_COrdField). rstepr (q2[-]q1). apply shift_zero_less_minus. assumption. Qed. Lemma shrink13 : forall q1 q2 : Q_as_COrdField, (q1[<]q2) -> q1[<]q2[-](q2[-]q1) [/]ThreeNZ. Proof. intros. apply less_transitive_unfolded with (q1[+](q2[-]q1) [/]ThreeNZ). astepl (q1[+][0]). apply plus_resp_less_lft. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. assumption. apply shrink23. assumption. Qed. Lemma shrink24 : forall q1 q2 : Q_as_COrdField, (q1[<]q2) -> q1[+](q2[-]q1) [/]ThreeNZ[<]q2. Proof. intros. apply less_transitive_unfolded with (q2[-](q2[-]q1) [/]ThreeNZ). apply shrink23. assumption. astepl (q2[+][--]((q2[-]q1) [/]ThreeNZ)). astepr (q2[+][0]). apply plus_resp_less_lft. apply inv_cancel_less. rstepl ([0]:Q_as_COrdField). rstepr ((q2[-]q1) [/]ThreeNZ). apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. assumption. Qed. Definition cotrans_analyze : forall (x : R1) (q1 q2 : Q_as_COrdField), (q1[<]q2) -> Q_as_COrdField. Proof. intros. cut (inj_Q R1 q1[<]inj_Q R1 q2). intro H0. case (less_cotransitive_unfolded R1 (inj_Q R1 q1) (inj_Q R1 q2) H0 x). intro. exact q1. intro. exact q2. apply inj_Q_less. assumption. Defined. Lemma cotrans_analyze_strong : forall (q1 q2 : Q_as_COrdField) (x : R1) (H : q1[<]q2), ((inj_Q R1 q1[<]x) and (cotrans_analyze x q1 q2 H[=]q1)) or (x[<]inj_Q R1 q2) and (cotrans_analyze x q1 q2 H[=]q2). Proof. intros. unfold cotrans_analyze in |- *. elim (less_cotransitive_unfolded R1 (inj_Q R1 q1) (inj_Q R1 q2) (inj_Q_less R1 q1 q2 H) x). intros. left. split. assumption. algebra. intros. right. split. assumption. algebra. Qed. Definition trichotomy : R1 -> Q_as_COrdField -> Q_as_COrdField -> Q_as_COrdField. Proof. intros x q1 q2. case (Qlt_eq_gt_dec' q1 q2). intro s. elim s. intro a. exact (cotrans_analyze x (q1[+](q2[-]q1) [/]ThreeNZ) (q2[-](q2[-]q1) [/]ThreeNZ) (shrink23 q1 q2 a)). intro. exact [0]. intro. exact q1. Defined. Lemma trichotomy_strong1 : forall (q1 q2 : Q_as_COrdField) (x : R1) (H : q1[<]q2), ((inj_Q R1 (q1[+](q2[-]q1) [/]ThreeNZ)[<]x) and (trichotomy x q1 q2[=]q1[+](q2[-]q1) [/]ThreeNZ)) or (x[<]inj_Q R1 (q2[-](q2[-]q1) [/]ThreeNZ)) and (trichotomy x q1 q2[=]q2[-](q2[-]q1) [/]ThreeNZ). Proof. intros. unfold trichotomy in |- *. elim (Qlt_eq_gt_dec' q1 q2). intro y. elim y. intro y0. simpl in |- *. apply cotrans_analyze_strong. intro. apply False_rect. generalize b. change (Not (q2[<]q1)) in |- *. apply less_antisymmetric_unfolded. assumption. intro. exfalso. generalize b. change (q1[~=]q2) in |- *. apply ap_imp_neq. apply less_imp_ap. assumption. Qed. Notation "( A , B )" := (pairT A B). Definition if_cotrans : forall (x : R1) (I1 : Rat_Interval), Rat_Interval. Proof. intros. case I1. intros i pi. elim (trichotomy_strong1 (fstT i) (sndT i) x pi). intro. exact (Build_Interval _ (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ, sndT i) (shrink24 (fstT i) (sndT i) pi)). intro. exact (Build_Interval _ (fstT i, sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) (shrink13 (fstT i) (sndT i) pi)). Defined. Lemma if_cotrans_strong : forall (x : R1) (I1 : Rat_Interval), ((inj_Q R1 (fstT I1[+](sndT I1[-]fstT I1) [/]ThreeNZ)[<]x) and if_cotrans x I1 = Build_Interval _ (fstT I1[+](sndT I1[-]fstT I1) [/]ThreeNZ, sndT I1) (shrink24 (fstT I1) (sndT I1) (is_interval _ I1))) or (x[<]inj_Q R1 (sndT I1[-](sndT I1[-]fstT I1) [/]ThreeNZ)) and if_cotrans x I1 = Build_Interval _ (fstT I1, sndT I1[-](sndT I1[-]fstT I1) [/]ThreeNZ) (shrink13 (fstT I1) (sndT I1) (is_interval _ I1)). Proof. intros. case I1. intros i pi. elim (trichotomy_strong1 (fstT i) (sndT i) x pi). intro y. elim y. intros H H0. left. split. exact H. cut (if_cotrans x (Build_Interval Q_as_COrdField i pi) = Build_Interval Q_as_COrdField (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ, sndT i) (shrink24 (fstT i) (sndT i) pi)). intro H1. rewrite H1. simpl in |- *. reflexivity. unfold if_cotrans in |- *. apply not_r_cor_rect. apply or_not_and. right. change (trichotomy x (fstT i) (sndT i)[~=]sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) in |- *. apply ap_imp_neq. astepl (fstT i[+](sndT i[-]fstT i) [/]ThreeNZ). apply less_imp_ap. apply shrink23. assumption. intro. elim b. intros H H0. right. split. exact H. cut (if_cotrans x (Build_Interval Q_as_COrdField i pi) = Build_Interval Q_as_COrdField (fstT i, sndT i[-](sndT i[-]fstT i) [/]ThreeNZ) (shrink13 (fstT i) (sndT i) pi)). intro H1. rewrite H1. simpl in |- *. reflexivity. unfold if_cotrans in |- *. apply not_l_cor_rect. apply or_not_and. right. change (trichotomy x (fstT i) (sndT i)[~=] (fstT i)[+]((sndT i[-]fstT i) [/]ThreeNZ)) in |- *. apply ap_imp_neq. astepl (sndT i[-](sndT i[-]fstT i) [/]ThreeNZ). apply Greater_imp_ap. apply shrink23. assumption. Qed. Fixpoint Intrvl (x : R1) (n : nat) {struct n} : Rat_Interval := match n with | O => Build_Interval _ (start_l x, start_r x) (l_less_r x) | S p => if_cotrans x (Intrvl x p) end. Definition G (x : R1) (n : nat) := (fstT (Intrvl x n)[+]sndT (Intrvl x n)) [/]TwoNZ. Opaque Q_as_CField. Lemma delta_Intrvl : forall (x : R1) (n : nat), Length _ (Intrvl x (S n))[=]Two [/]ThreeNZ[*]Length _ (Intrvl x n). Proof. intros. case (if_cotrans_strong x (Intrvl x n)). intro H. elim H. intros H0 H1. simpl in |- *. rewrite H1. unfold Length in |- *. simpl in |- *. rational. intro H. elim H. intros H0 H1. simpl in |- *. rewrite H1. unfold Length in |- *. simpl in |- *. rational. Qed. Lemma Length_Intrvl : forall (x : R1) (n : nat), Length _ (Intrvl x n)[=](Two [/]ThreeNZ)[^]n[*](start_r x[-]start_l x). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) unfold Length in |- *. simpl in |- *. rational. (* n=(S n0) & induction hypothesis *) astepr (Two [/]ThreeNZ[*]((Two [/]ThreeNZ)[^]n[*](start_r x[-]start_l x))). astepr (Two [/]ThreeNZ[*]Length Q_as_COrdField (Intrvl x n)). apply delta_Intrvl. astepr ((Two [/]ThreeNZ)[^]n[*]Two [/]ThreeNZ[*](start_r x[-]start_l x)). rational. Qed. Lemma Intrvl_inside_l_n : forall (x : R1) (m n : nat), m <= n -> fstT (Intrvl x m)[<=]fstT (Intrvl x n). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) cut (m = 0). intro. rewrite H0. apply leEq_reflexive. apply Nat.le_0_r. assumption. (* n=(S n0) *) cut ({m = S n} + {m <= n}). intro. case H0. intro H1. rewrite H1. apply leEq_reflexive. intro. apply leEq_transitive with (fstT (Intrvl x n)). apply Hrecn. assumption. case (if_cotrans_strong x (Intrvl x n)). intro H2. elim H2. intros H3 H4. change (fstT (Intrvl x n)[<=]fstT (if_cotrans x (Intrvl x n))) in |- *. rewrite H4. astepl (fstT (Intrvl x n)[+][0]). simpl. apply (plus_resp_leEq_both Q_as_COrdField). apply leEq_reflexive. apply less_leEq. apply (div_resp_pos Q_as_COrdField). apply (pos_three Q_as_COrdField). apply (shift_zero_less_minus Q_as_COrdField). apply (is_interval Q_as_COrdField). intro H2. elim H2. intros H3 H4. change (fstT (Intrvl x n)[<=]fstT (if_cotrans x (Intrvl x n))) in |- *. rewrite H4. apply leEq_reflexive. case (le_lt_eq_dec m (S n) H). intro. right. apply Nat.lt_succ_r. assumption. intro. left. assumption. Qed. Lemma Intrvl_inside_r_n : forall (x : R1) (m n : nat), m <= n -> sndT (Intrvl x n)[<=]sndT (Intrvl x m). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) cut (m = 0). intro. rewrite H0. apply leEq_reflexive. apply Nat.le_0_r. assumption. (* n=(S n0) *) cut ({m = S n} + {m <= n}). intro H0. case H0. intro H1. rewrite H1. apply leEq_reflexive. intro. apply leEq_transitive with (sndT (Intrvl x n)). case (if_cotrans_strong x (Intrvl x n)). intro H2. elim H2. intros H3 H4. change (sndT (if_cotrans x (Intrvl x n))[<=]sndT (Intrvl x n)) in |- *. rewrite H4. apply leEq_reflexive. intro H2. elim H2. intros H3 H4. change (sndT (if_cotrans x (Intrvl x n))[<=]sndT (Intrvl x n)) in |- *. rewrite H4. astepr (sndT (Intrvl x n)[+][0]). astepl (sndT (Intrvl x n)[+] [--]((sndT (Intrvl x n)[-]fstT (Intrvl x n)) [/]ThreeNZ)). apply plus_resp_leEq_both. apply leEq_reflexive. apply inv_cancel_leEq. astepl ([0]:Q_as_COrdField). astepr ((sndT (Intrvl x n)[-]fstT (Intrvl x n)) [/]ThreeNZ). apply less_leEq. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. apply is_interval. apply Hrecn. assumption. case (le_lt_eq_dec m (S n) H). intro. right. apply Nat.lt_succ_r. assumption. intro. left. assumption. Qed. Lemma G_m_n_lower : forall (x : R1) (m n : nat), m <= n -> fstT (Intrvl x m)[<]G x n. Proof. intros. unfold G in |- *. apply leEq_less_trans with (fstT (Intrvl x n)). apply Intrvl_inside_l_n. assumption. apply Smallest_less_Average. apply is_interval. Qed. Lemma G_m_n_upper : forall (x : R1) (m n : nat), m <= n -> G x n[<]sndT (Intrvl x m). Proof. intros. unfold G in |- *. apply less_leEq_trans with (sndT (Intrvl x n)). apply Average_less_Greatest. apply is_interval. apply Intrvl_inside_r_n. assumption. Qed. Opaque Q_as_COrdField. Lemma a_simple_inequality : forall m : nat, 4 <= m -> (Two [/]ThreeNZ)[^]m[<] (([1]:Q_as_COrdField)[/] nring (S m)[//]nringS_ap_zero _ m). Proof. intros. induction m as [| m Hrecm]. apply False_rect. generalize H. change (~ 4 <= 0) in |- *. apply Nat.nle_succ_0. case (le_lt_eq_dec 4 (S m) H). intro. apply less_transitive_unfolded with (Two [/]ThreeNZ[*] (([1]:Q_as_COrdField)[/] nring (S m)[//]nringS_ap_zero _ m)). astepl (((Two:Q_as_COrdField) [/]ThreeNZ)[^]m[*]Two [/]ThreeNZ). astepl ((Two:Q_as_COrdField) [/]ThreeNZ[*](Two [/]ThreeNZ)[^]m). apply mult_resp_less_lft. apply Hrecm. apply Nat.lt_succ_r. assumption. apply div_resp_pos. apply pos_three. apply pos_two. (* astepl ((Two::Q_as_COrdField)[/]ThreeNZ)[*](Two[/]ThreeNZ)[^]m. Apply nexp_Sn with ((Two::Q_as_COrdField)[/]ThreeNZ). *) apply mult_cancel_less with ((Three:Q_as_COrdField)[*]nring (S m)[*]nring (S (S m))). apply mult_resp_pos. apply mult_resp_pos. apply pos_three. apply pos_nring_S. apply pos_nring_S. rstepl ((Two:Q_as_COrdField)[*]nring (S (S m))). rstepr ((Three:Q_as_COrdField)[*]nring (S m)). astepl ((Two:Q_as_COrdField)[*](nring m[+]Two)). astepr ((Three:Q_as_COrdField)[*](nring m[+][1])). apply plus_cancel_less with ([--]((Two:Q_as_COrdField)[*]nring m[+]Three)). rstepl ([1]:Q_as_COrdField). rstepr (nring (R:=Q_as_COrdField) m). astepl (nring (R:=Q_as_COrdField) 1). apply nring_less. apply Nat.lt_trans with (m := 3). constructor. constructor. apply Nat.succ_lt_mono. assumption. simpl in |- *. rational. intro. rewrite <- e. apply mult_cancel_less with (nring (R:=Q_as_COrdField) 5[*]Three[^]4). apply mult_resp_pos. apply pos_nring_S. rstepr (Three[^]2[*]Three[^]2:Q_as_COrdField). apply mult_resp_pos. apply pos_square. apply nringS_ap_zero. apply pos_square. apply nringS_ap_zero. rstepl (Two[^]4[*]nring (R:=Q_as_COrdField) 5). rstepr (Three[^]4:Q_as_COrdField). rstepl (nring (R:=Q_as_COrdField) 80). rstepr (nring (R:=Q_as_COrdField) 81). apply nring_less. constructor. Qed. Lemma G_conversion_rate2 : forall (x : R1) (m n : nat), 4 <= m -> m <= n -> AbsSmall (start_r x[-]start_l x[/] nring (S m)[//]nringS_ap_zero _ m) (G x m[-]G x n). Proof. intros. apply AbsSmall_leEq_trans with (Length _ (Intrvl x m)). astepl ((Two [/]ThreeNZ)[^]m[*](start_r x[-]start_l x)). rstepr (([1][/] nring (S m)[//]nringS_ap_zero _ m)[*](start_r x[-]start_l x)). apply less_leEq. apply mult_resp_less. apply a_simple_inequality. assumption. apply shift_zero_less_minus. apply l_less_r. apply eq_symmetric_unfolded. apply Length_Intrvl. unfold Length in |- *. apply AbsSmall_subinterval; apply less_leEq. apply G_m_n_lower. constructor. apply G_m_n_lower. assumption. apply G_m_n_upper. constructor. apply G_m_n_upper. assumption. Qed. Lemma CS_seq_G : forall x : R1, Cauchy_prop (fun m : nat => G x m). Proof. intros. unfold Cauchy_prop in |- *. intros e H. cut {n : nat | (start_r x[-]start_l x[/] e[//]Greater_imp_ap _ e [0] H)[<]nring n}. intro H0. case H0. intro N. intro. exists (S (N + 3)). intros. apply AbsSmall_minus. apply AbsSmall_leEq_trans with (start_r x[-]start_l x[/] nring (S (S (N + 3)))[//] nringS_ap_zero Q_as_COrdField (S (N + 3))). apply less_leEq. apply swap_div with (z_ := Greater_imp_ap _ e [0] H). apply pos_nring_S. assumption. apply less_transitive_unfolded with (nring (R:=Q_as_COrdField) N). assumption. apply nring_less. apply Nat.lt_succ_r. constructor. apply Nat.le_add_r. apply G_conversion_rate2 with (m := S (N + 3)). apply le_n_S. rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply Q_is_archemaedian. (* Note the use of Q_is_archemaedian *) Qed. Definition G_as_CauchySeq (x : R1) := Build_CauchySeq Q_as_COrdField (fun m : nat => G x m) (CS_seq_G x). Lemma CS_seq_inj_Q_G : forall x : R1, Cauchy_prop (fun m : nat => inj_Q R1 (G x m)). Proof. intro. change (Cauchy_prop (fun m : nat => inj_Q R1 (CS_seq _ (G_as_CauchySeq x) m))) in |- *. apply inj_Q_Cauchy. Qed. Definition inj_Q_G_as_CauchySeq (x : R1) := Build_CauchySeq _ (fun m : nat => inj_Q R1 (G x m)) (CS_seq_inj_Q_G x). Lemma x_in_Intrvl_l : forall (x : R1) (n : nat), inj_Q R1 (fstT (Intrvl x n))[<]x. Proof. intros. induction n as [| n Hrecn]. (* n=0 *) simpl in |- *. cut ((inj_Q R1 (start_l x)[<]x) and (x[<]inj_Q R1 (start_r x))). intro H. elim H. intros. assumption. apply start_of_sequence_property. (* n= (S n0) *) case (if_cotrans_strong x (Intrvl x n)). intro H. elim H. intros H0 H1. change (inj_Q R1 (fstT (if_cotrans x (Intrvl x n)))[<]x) in |- *. rewrite H1. simpl in |- *. assumption. intro H. elim H. intros H0 H1. change (inj_Q R1 (fstT (if_cotrans x (Intrvl x n)))[<]x) in |- *. rewrite H1. simpl in |- *. assumption. Qed. Lemma x_in_Intrvl_r : forall (x : R1) (n : nat), x[<]inj_Q R1 (sndT (Intrvl x n)). Proof. intros. induction n as [| n Hrecn]. (* n=0 *) simpl in |- *. cut ((inj_Q R1 (start_l x)[<]x) and (x[<]inj_Q R1 (start_r x))). intro H. elim H. intros. assumption. apply start_of_sequence_property. (* n= (S n0) *) case (if_cotrans_strong x (Intrvl x n)). intro H. elim H. intros H0 H1. change (x[<]inj_Q R1 (sndT (if_cotrans x (Intrvl x n)))) in |- *. rewrite H1. simpl in |- *. assumption. intro H. elim H. intros H0 H1. change (x[<]inj_Q R1 (sndT (if_cotrans x (Intrvl x n)))) in |- *. rewrite H1. simpl in |- *. assumption. Qed. Lemma G_conversion_rate_resp_x : forall (x : R1) (m : nat), 4 <= m -> AbsSmall (inj_Q R1 (start_r x[-]start_l x[/] nring (S m)[//]nringS_ap_zero _ m)) (inj_Q R1 (G x m)[-]x). Proof. intros. apply AbsSmall_leEq_trans with (e1 := inj_Q R1 (Length _ (Intrvl x m))). apply less_leEq. apply inj_Q_less. astepl ((Two [/]ThreeNZ)[^]m[*](start_r x[-]start_l x)). rstepr (([1][/] nring (S m)[//]nringS_ap_zero _ m)[*](start_r x[-]start_l x)). apply mult_resp_less. apply a_simple_inequality. assumption. apply shift_zero_less_minus. apply l_less_r. apply eq_symmetric_unfolded. apply Length_Intrvl. unfold Length in |- *. astepl (inj_Q R1 (sndT (Intrvl x m))[-]inj_Q R1 (fstT (Intrvl x m))). apply AbsSmall_subinterval; apply less_leEq. apply inj_Q_less. apply G_m_n_lower. constructor. apply x_in_Intrvl_l. apply inj_Q_less. apply G_m_n_upper. constructor. apply x_in_Intrvl_r. Qed. Lemma x_is_SeqLimit_G : forall x : R1, SeqLimit (inj_Q_G_as_CauchySeq x) x. Proof. intros. unfold SeqLimit in |- *. intros e H. unfold inj_Q_G_as_CauchySeq in |- *. unfold CS_seq in |- *. cut {n : nat | (inj_Q R1 (start_r x[-]start_l x)[/] e[//]Greater_imp_ap _ e [0] H)[<] nring n}. intro H0. case H0. intro N. intro. exists (S (N + 3)). intros. apply AbsSmall_leEq_trans with (e1 := inj_Q R1 ((start_r x[-]start_l x)[/]nring (S (S (N + 3)))[//] nringS_ap_zero Q_as_COrdField (S (N + 3)))). apply less_leEq. apply less_transitive_unfolded with (y := inj_Q R1 ((start_r x[-]start_l x)[/]nring (R:=Q_as_COrdField) (S N)[//] nringS_ap_zero _ N)). apply inj_Q_less. apply mult_cancel_less with (nring (R:=Q_as_COrdField) (S (S (N + 3)))[*]nring (S N)). apply mult_resp_pos. apply pos_nring_S. apply pos_nring_S. rstepl ((start_r x[-]start_l x)[*]nring (S N)). rstepr ((start_r x[-]start_l x)[*]nring (S (S (N + 3)))). apply mult_resp_less_lft. apply nring_less. apply -> Nat.succ_lt_mono. apply Nat.lt_succ_r. apply Nat.le_add_r. apply shift_zero_less_minus. apply l_less_r. astepl (inj_Q R1 (start_r x[-]start_l x)[/]nring (S N)[//]nringS_ap_zero R1 N). apply swap_div with (z_ := Greater_imp_ap _ e [0] H). apply pos_nring_S. assumption. apply less_transitive_unfolded with (y := nring (R:=R1) N). assumption. apply nring_less. apply Nat.lt_succ_r. constructor. apply mult_cancel_lft with (z := nring (R:=R1) (S N)). apply nringS_ap_zero. rstepl (inj_Q R1 (start_r x[-]start_l x)). astepr (inj_Q R1 (nring (S N))[*] inj_Q R1 ((start_r x[-]start_l x)[/]nring (S N)[//] nringS_ap_zero Q_as_COrdField N)). astepr (inj_Q R1 (nring (S N)[*] ((start_r x[-]start_l x)[/]nring (S N)[//] nringS_ap_zero Q_as_COrdField N))). apply inj_Q_wd. rational. apply AbsSmall_leEq_trans with (e1 := inj_Q R1 ((start_r x[-]start_l x)[/]nring (S m)[//] nringS_ap_zero Q_as_COrdField m)). apply inj_Q_leEq. apply mult_cancel_leEq with (nring (R:=Q_as_COrdField) (S (S (N + 3)))[*]nring (S m)). apply mult_resp_pos. apply pos_nring_S. apply pos_nring_S. rstepl ((start_r x[-]start_l x)[*]nring (S (S (N + 3)))). rstepr ((start_r x[-]start_l x)[*]nring (S m)). apply mult_resp_leEq_lft. apply nring_leEq. apply le_n_S. assumption. apply less_leEq. apply shift_zero_less_minus. apply l_less_r. apply G_conversion_rate_resp_x. apply Nat.le_trans with (m := S (N + 3)). apply le_n_S. rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply Archimedes'. Qed. End Rational_sequence. (* end hide *) corn-8.20.0/reals/Q_in_CReals.v000066400000000000000000000610241473720167500161750ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** * On density of the image of [Q] in an arbitrary real number structure In this file we introduce the image of the concrete rational numbers (as defined earlier) in an arbitrary structure of type [CReals]. At the end of this file we assign to any real number two rational numbers for which the real number lies betwen image of them; in other words we will prove that the image of rational numbers in dense in any real number structure. *) Require Export CoRN.model.reals.Cauchy_IR. Require Export CoRN.model.monoids.Nmonoid. Require Export CoRN.model.rings.Zring. Require Import CoRN.algebra.CRing_Homomorphisms. Require Import CoRN.algebra.Expon. From Coq Require Import Qpower. Require Import CoRN.tactics.CornTac. Section Rational_sequence_prelogue. (** %\begin{convention}% Let [R1] be a real number structure. %\end{convention}% *) Variable R1 : CReals. (* We clone these proofs from CReals1.v just because there IR is an axiom *) (* begin hide *) Lemma CReals_is_CReals : is_CReals R1 (Lim (IR:=R1)). Proof. unfold Lim in |- *. elim R1; intros. exact crl_proof. Qed. Lemma Lim_Cauchy : forall s : CauchySeq R1, SeqLimit s (Lim s). Proof. elim CReals_is_CReals. intros. apply ax_Lim. Qed. Lemma Archimedes : forall x : R1, {n : nat | x [<=] nring n}. Proof. elim CReals_is_CReals. intros. apply ax_Arch. Qed. Lemma Archimedes' : forall x : R1, {n : nat | x [<] nring n}. Proof. intro x. elim (Archimedes (x[+][1])); intros n Hn. exists n. apply less_leEq_trans with (x[+][1]); auto. apply less_plusOne. Qed. (*--------------------------------------*) Local Coercion nat_of_P : positive >-> nat. (* end hide *) (** ** Injection from [Q] to an arbitrary real number structure First we need to define the injection from [Q] to [R1]. Note that in [Cauchy_CReals] we defined [inject_Q] from an arbitray field [F] to [(R_COrdField F)] which was the set of Cauchy sequences of that field. But since [R1] is an %\emph{arbitrary}%#arbitrary# real number structure we can not use [inject_Q]. To define the injection we need one elemntary lemma about the denominator: *) Lemma den_is_nonzero : forall x : Q_as_COrdField, nring (R:=R1) (Qden x) [#] [0]. Proof. intro. apply nring_ap_zero. intro. absurd (0 < Qden x). rewrite H. auto with arith. apply lt_O_nat_of_P. Qed. (** And we define the injection in the natural way, using [zring] and [nring]. We call this [inj_Q], in contrast with [inject_Q] defined in [Cauchy_CReals]. *) Definition inj_Q : Q_as_COrdField -> R1. Proof. intro x. case x. intros num0 den0. exact (zring num0[/]nring (R:=R1) den0[//]den_is_nonzero (Qmake num0 den0)). Defined. (** Next we need some properties of [nring], on the setoid of natural numbers: *) Lemma nring_strext : forall m n : nat_as_CMonoid, (nring (R:=R1) m [#] nring (R:=R1) n) -> m [#] n. Proof. intros m n. case m. case n. intro H. simpl in |- *. red in |- *. simpl in H. cut (Not ([0] [#] ([0]:R1))). intro. intro. elim H0. assumption. apply eq_imp_not_ap. apply eq_reflexive_unfolded. intros. simpl in |- *. red in |- *. discriminate. case n. intros. simpl in |- *. red in |- *. discriminate. intros. simpl in |- *. red in |- *. intro. cut (Not (nring (R:=R1) (S n1) [#] nring (R:=R1) (S n0))). intro H1. elim H1. assumption. apply eq_imp_not_ap. rewrite H. apply eq_reflexive_unfolded. Qed. Lemma nring_wd : forall m n : nat_as_CMonoid, (m [=] n) -> nring (R:=R1) m [=] nring (R:=R1) n. Proof. intros. simpl in H. rewrite H. apply eq_reflexive_unfolded. Qed. Lemma nring_eq : forall m n : nat, m = n -> nring (R:=R1) m [=] nring (R:=R1) n. Proof. intros. rewrite H. apply eq_reflexive_unfolded. Qed. Lemma nring_leEq : forall (OF : COrdField) m n, m <= n -> nring (R:=OF) m [<=] nring (R:=OF) n. Proof. intros. induction m as [| m Hrecm]. simpl in |- *. case n. simpl in |- *. apply leEq_reflexive. intro. apply less_leEq. apply pos_nring_S. case (le_lt_eq_dec (S m) n H). intro. apply less_leEq. apply nring_less. assumption. intro. rewrite e. apply leEq_reflexive. Qed. (** Similarly we prove some properties of [zring] on the ring of integers: *) Lemma zring_strext : forall m n : Z_as_CRing, (zring (R:=R1) m [#] zring n) -> m [#] n. Proof. intros m n. case m. case n. intro H. exfalso. cut ([0] [=] ([0]:R1)). change (~ ([0] [=] ([0]:R1))) in |- *. apply ap_imp_neq. simpl in H. assumption. apply eq_reflexive_unfolded. intros. simpl in |- *. red in |- *. discriminate. intros. simpl in |- *. red in |- *. discriminate. case n. intros. simpl in |- *. red in |- *. discriminate. intros. simpl in |- *. intro. cut (Not (zring (R:=R1) (BinInt.Zpos p0) [#] zring (R:=R1) (BinInt.Zpos p))). intro H1. elim H1. assumption. apply eq_imp_not_ap. rewrite H. apply eq_reflexive_unfolded. intros. simpl in |- *. red in |- *. discriminate. case n. intros. simpl in |- *. red in |- *. discriminate. intros. simpl in |- *. red in |- *. discriminate. intros. simpl in |- *. intro. cut (Not (zring (R:=R1) (Zneg p0) [#] zring (R:=R1) (Zneg p))). intro H1. elim H1. assumption. apply eq_imp_not_ap. rewrite H. apply eq_reflexive_unfolded. Qed. Lemma zring_wd : forall m n : Z_as_CRing, (m [=] n) -> zring (R:=R1) m [=] zring (R:=R1) n. Proof. intros. simpl in H. rewrite H. apply eq_reflexive_unfolded. Qed. Lemma zring_less : forall m n : Z_as_CRing, (m < n)%Z -> zring (R:=R1) m [<] zring (R:=R1) n. Proof. intros m n. case m. case n. intro. apply False_rect. generalize H. change (~ (0 < 0)%Z) in |- *. apply Z.lt_irrefl. intros. simpl in |- *. astepl (nring (R:=R1) 0). astepr (nring (R:=R1) (nat_of_P p)). apply nring_less. case (ZL4' p). intro a. intro H0. rewrite H0. apply Nat.lt_0_succ. intros. apply False_rect. generalize H. change (~ (0 < Zneg p)%Z) in |- *. apply Zlt_asym. constructor. case n. intros. apply False_rect. generalize H. change (~ (BinInt.Zpos p < 0)%Z) in |- *. apply Zlt_asym. constructor. intros p1 p2. intro. simpl in |- *. astepl (nring (R:=R1) (nat_of_P p2)). astepr (nring (R:=R1) (nat_of_P p1)). apply nring_less. apply nat_of_P_lt_Lt_compare_morphism. red in H. simpl in H. assumption. intros p1 p2. intro. apply False_rect. generalize H. change (~ (BinInt.Zpos p2 < Zneg p1)%Z) in |- *. apply Zlt_asym. constructor. case n. intros. simpl in |- *. astepl [--](nring (R:=R1) (nat_of_P p)). astepr ([0]:R1). apply inv_cancel_less. astepl ([0]:R1). astepr (nring (R:=R1) (nat_of_P p)). case (ZL4' p). intro h. intros H0. rewrite H0. apply pos_nring_S. intros p1 p2. intro. simpl in |- *. case (ZL4' p1). intro h1. case (ZL4' p2). intro h2. intros. apply less_transitive_unfolded with (y := [0]:R1). astepl [--](nring (R:=R1) (nat_of_P p2)). apply inv_cancel_less. astepl ([0]:R1). astepr (nring (R:=R1) (nat_of_P p2)). rewrite e. apply pos_nring_S. astepr (nring (R:=R1) p1). rewrite e0. apply pos_nring_S. intros p1 p2. intro. simpl in |- *. astepl [--](nring (R:=R1) (nat_of_P p2)). astepr [--](nring (R:=R1) (nat_of_P p1)). apply inv_resp_less. apply nring_less. apply nat_of_P_lt_Lt_compare_morphism. red in H. simpl in H. now rewrite ZC4. Qed. (** Using the above lemmata we prove the basic properties of [inj_Q], i.e.%\% it is a setoid function and preserves the ring operations and oreder operation. *) Lemma inj_Q_strext : forall q1 q2, (inj_Q q1 [#] inj_Q q2) -> q1 [#] q2. Proof. intros q1 q2. generalize (den_is_nonzero q1). generalize (den_is_nonzero q2). case q1. intros n1 d1. case q2. intros n2 d2. intros H H0 H1. simpl in |- *. simpl in H. simpl in H0. unfold Qap in |- *. unfold Qeq in |- *. unfold Qnum in |- *. unfold Qden in |- *. intro. cut (~ (inj_Q (Qmake n1 d1) [=] inj_Q (Qmake n2 d2))). intro. elim H3. simpl in |- *. apply mult_cancel_lft with (z := nring (R:=R1) d1[*]nring (R:=R1) d2). apply mult_resp_ap_zero. assumption. assumption. rstepl (zring (R:=R1) n1[*]nring (R:=R1) d2). rstepr (zring (R:=R1) n2[*]nring (R:=R1) d1). astepr (zring (R:=R1) (n1 * d2)). astepr (zring (R:=R1) n1[*]zring (R:=R1) d2). apply mult_wdr. astepl (zring (R:=R1) (Z_of_nat (nat_of_P d2))). rewrite inject_nat_convert. algebra. rewrite H2. astepl (zring (R:=R1) n2[*]zring (R:=R1) d1). apply mult_wdr. astepr (zring (R:=R1) (Z_of_nat (nat_of_P d1))). rewrite inject_nat_convert. algebra. change (inj_Q (Qmake n1 d1)[~=]inj_Q (Qmake n2 d2)) in |- *. apply ap_imp_neq. assumption. Qed. Lemma inj_Q_wd : forall q1 q2, (q1 [=] q2) -> inj_Q q1 [=] inj_Q q2. Proof. intros. apply not_ap_imp_eq. intro. cut (~ (q1 [=] q2)). intro H1. apply H1. assumption. change (q1[~=]q2) in |- *. apply ap_imp_neq. apply inj_Q_strext. assumption. Qed. Lemma inj_Q_plus : forall q1 q2, inj_Q (q1[+]q2) [=] inj_Q q1[+]inj_Q q2. Proof. intros. generalize (den_is_nonzero q1). generalize (den_is_nonzero q2). case q1. intros n1 d1. case q2. intros n2 d2. simpl in |- *. intros. apply mult_cancel_lft with (z := nring (R:=R1) d1[*]nring (R:=R1) d2). apply mult_resp_ap_zero. assumption. assumption. astepr (zring (R:=R1) (n1 * d2 + n2 * d1)). astepr (nring (R:=R1) (d1 * d2)%positive[*] (zring (R:=R1) (n1 * d2 + n2 * d1)[/]nring (R:=R1) (d1 * d2)%positive[//] den_is_nonzero (Qmake (n1 * d2 + n2 * d1)%Z (d1 * d2)%positive))). apply mult_wdl. rewrite nat_of_P_mult_morphism. algebra. astepr (zring (R:=R1) n1[*]nring (R:=R1) d2[+]zring (R:=R1) n2[*]nring (R:=R1) d1). astepl (zring (R:=R1) (n1 * d2)[+]zring (R:=R1) (n2 * d1)). apply bin_op_wd_unfolded. astepr (zring (R:=R1) n1[*]zring (R:=R1) (Z_of_nat (nat_of_P d2))). rewrite inject_nat_convert. algebra. astepr (zring (R:=R1) n2[*]zring (R:=R1) (Z_of_nat (nat_of_P d1))). rewrite inject_nat_convert. algebra. rational. Qed. Lemma inj_Q_mult : forall q1 q2, inj_Q (q1[*]q2) [=] inj_Q q1[*]inj_Q q2. Proof. intros. generalize (den_is_nonzero q1). generalize (den_is_nonzero q2). case q1. intros n1 d1. case q2. intros n2 d2. simpl in |- *. intros. apply mult_cancel_lft with (z := nring (R:=R1) d1[*]nring (R:=R1) d2). apply mult_resp_ap_zero. assumption. trivial. astepr (zring (R:=R1) (n1 * n2)). astepr (nring (R:=R1) (d1 * d2)%positive[*] (zring (R:=R1) (n1 * n2)[/]nring (R:=R1) (d1 * d2)%positive[//] den_is_nonzero (Qmake (n1 * n2)%Z (d1 * d2)%positive))). apply mult_wdl. rewrite nat_of_P_mult_morphism. algebra. astepr (zring (R:=R1) n1[*]zring (R:=R1) n2). apply zring_mult. rational. Qed. Lemma inj_Q_less : forall q1 q2, (q1 [<] q2) -> inj_Q q1 [<] inj_Q q2. Proof. intros q1 q2. case q1. intros n1 d1. case q2. intros n2 d2. intro H. simpl in H. unfold Qlt in H. simpl in H. simpl in |- *. apply mult_cancel_less with (z := nring (R:=R1) d1[*]nring (R:=R1) d2). apply mult_resp_pos. elim (ZL4' d1); intros. rewrite p. apply pos_nring_S. elim (ZL4' d2); intros. rewrite p. apply pos_nring_S. rstepl (zring (R:=R1) n1[*]nring (R:=R1) d2). rstepr (zring (R:=R1) n2[*]nring (R:=R1) d1). apply less_wdl with (x := zring (R:=R1) n1[*]zring (R:=R1) (Z_of_nat d2)). apply less_wdr with (y := zring (R:=R1) n2[*]zring (R:=R1) (Z_of_nat d1)). apply less_wdl with (x := zring (R:=R1) (n1 * d2)). apply less_wdr with (y := zring (R:=R1) (n2 * d1)). apply zring_less. apply CZlt_to. assumption. rewrite inject_nat_convert. apply zring_mult. rewrite inject_nat_convert. apply zring_mult. algebra. algebra. Qed. Lemma less_inj_Q : forall q1 q2, (inj_Q q1 [<] inj_Q q2) -> q1 [<] q2. Proof. intros. cut (q1 [#] q2). intro H0. case (ap_imp_less _ q1 q2 H0). intro. assumption. intro. exfalso. cut (inj_Q q2 [<] inj_Q q1). change (Not (inj_Q q2 [<] inj_Q q1)) in |- *. apply less_antisymmetric_unfolded. assumption. apply inj_Q_less. assumption. apply inj_Q_strext. apply less_imp_ap. assumption. Qed. Lemma inj_Q_ap : forall q1 q2, (q1 [#] q2) -> inj_Q q1 [#] inj_Q q2. Proof. intros q1 q2 H. destruct (ap_imp_less _ _ _ H); [apply less_imp_ap|apply Greater_imp_ap]; apply inj_Q_less; assumption. Qed. Lemma leEq_inj_Q : forall q1 q2, (inj_Q q1 [<=] inj_Q q2) -> q1 [<=] q2. Proof. intros. rewrite -> leEq_def; intro. apply less_irreflexive_unfolded with (x := inj_Q q2). eapply less_leEq_trans. 2: apply H. apply inj_Q_less. auto. Qed. Lemma inj_Q_leEq : forall q1 q2, (q1 [<=] q2) -> inj_Q q1 [<=] inj_Q q2. Proof. intros. rewrite -> leEq_def; intro. rewrite -> leEq_def in H; apply H. apply less_inj_Q. assumption. Qed. Lemma inj_Q_inv : forall q1, inj_Q [--]q1 [=] [--](inj_Q q1). Proof. intro. apply cg_cancel_lft with (x := inj_Q q1). astepr (inj_Q (q1[+][--]q1)). apply eq_symmetric_unfolded. apply inj_Q_plus. astepr (inj_Q [0]). apply inj_Q_wd. algebra. simpl in |- *. rstepl ([0]:R1). algebra. Qed. Lemma inj_Q_minus : forall q1 q2, inj_Q (q1[-]q2) [=] inj_Q q1[-]inj_Q q2. Proof. intros. astepl (inj_Q (q1[+][--]q2)). astepr (inj_Q q1[+]inj_Q [--]q2). apply inj_Q_plus. astepr (inj_Q q1[+][--](inj_Q q2)). apply plus_resp_eq. apply inj_Q_inv. Qed. Lemma inj_Q_div : forall q1 q2 H, inj_Q (q1/q2)%Q [=] (inj_Q q1[/]inj_Q q2[//]H). Proof. intros. apply mult_cancel_rht with (inj_Q q2);[apply H|]. apply eq_symmetric. eapply eq_transitive;[|apply inj_Q_mult]. eapply eq_transitive;[apply div_1|]. apply inj_Q_wd. simpl. field. apply inj_Q_strext. stepr ([0]:R1). apply H. rstepl (inj_Q q1[-]inj_Q q1). apply eq_symmetric. eapply eq_transitive;[|apply inj_Q_minus]. apply inj_Q_wd. unfold cg_minus. simpl. ring. Qed. Hint Resolve inj_Q_plus inj_Q_mult inj_Q_inv inj_Q_minus inj_Q_div : algebra. (** Moreover, and as expected, the [AbsSmall] predicate is also preserved under the [inj_Q] *) Lemma inj_Q_AbsSmall : forall q1 q2, AbsSmall q1 q2 -> AbsSmall (inj_Q q1) (inj_Q q2). Proof. intros. red in |- *. elim H. intros. split. astepl (inj_Q [--]q1). apply inj_Q_leEq. assumption. apply inj_Q_leEq. assumption. Qed. Lemma AbsSmall_inj_Q : forall q e, AbsSmall (inj_Q e) (inj_Q q) -> AbsSmall e q. Proof. intros. elim H. intros. split. apply leEq_inj_Q. apply leEq_wdl with (x := [--](inj_Q e)). assumption. apply eq_symmetric_unfolded. apply inj_Q_inv. apply leEq_inj_Q. assumption. Qed. (** ** Injection preserves Cauchy property We apply the above lemmata to obtain following theorem, which says that a Cauchy sequence of elemnts of [Q] will be Cauchy in [R1]. *) Theorem inj_Q_Cauchy : forall g : CauchySeq Q_as_COrdField, Cauchy_prop (fun n => inj_Q (g n)). Proof. intros. case g. intros g_ pg. simpl in |- *. red in |- *. intros e H. cut {n : nat | ([1][/]e[//]Greater_imp_ap _ e [0] H) [<] nring (R:=R1) n}. intro H0. case H0. intros N1 H1. unfold Cauchy_prop in pg. cut {N : nat | forall m : nat, N <= m -> AbsSmall (R:=Q_as_COrdField) (Qmake 1%Z (P_of_succ_nat N1)) (g_ m[-]g_ N)}. intro H2. case H2. intro N. intro. exists N. intros. apply AbsSmall_leEq_trans with (e1 := inj_Q (Qmake 1%Z (P_of_succ_nat N1))). apply less_leEq. apply mult_cancel_less with (z := nring (R:=R1) (S N1)[*]([1][/]e[//]Greater_imp_ap _ e [0] H)). apply mult_resp_pos. apply pos_nring_S. apply div_resp_pos. assumption. apply pos_one. unfold inj_Q in |- *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ with N1. rstepl ([1][/]e[//]Greater_imp_ap _ e [0] H). rstepr (nring (R:=R1) (P_of_succ_nat N1)). apply less_transitive_unfolded with (y := nring (R:=R1) N1). assumption. apply nring_less. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. apply Nat.lt_succ_diag_r. astepr (inj_Q (g_ m[-]g_ N)). apply inj_Q_AbsSmall. apply a. assumption. apply pg. simpl in |- *. red in |- *. simpl in |- *. constructor. apply Archimedes'. Qed. (** Furthermore we prove that applying [nring] (which is adding the ring unit [n] times) is the same whether we do it in [Q] or in [R1]: *) Lemma inj_Q_nring : forall n, inj_Q (nring n) [=] nring (R:=R1) n. Proof. intro. simpl in |- *. induction n as [| n Hrecn]. simpl in |- *. rational. change (inj_Q (nring n[+][1]) [=] nring (R:=R1) n[+][1]) in |- *. astepr (inj_Q (nring n)[+]inj_Q [1]). apply inj_Q_plus. apply bin_op_wd_unfolded. assumption. simpl in |- *. unfold pring in |- *; simpl in |- *. rational. Qed. Lemma inj_Q_pring : forall n, inj_Q (pring _ n) [=] pring R1 n. Proof. intros n. change (inj_Q (zring n)[=]zring n). stepr (inj_Q (nring n)). apply inj_Q_wd. rewrite <- inject_nat_convert. apply zring_plus_nat. stepr (nring n:R1). apply inj_Q_nring. apply eq_symmetric. rewrite <- inject_nat_convert. apply zring_plus_nat. Qed. Lemma inj_Q_zring : forall n, inj_Q (zring n) [=] zring (R:=R1) n. Proof. intros [|n|n]. simpl. rational. simpl. apply inj_Q_pring. change (inj_Q ([--](pring _ n))[=][--](pring _ n)). stepl ([--](inj_Q (zring (R:=Q_as_COrdField) n))). apply un_op_wd_unfolded. simpl. apply inj_Q_pring. apply eq_symmetric. apply inj_Q_inv. Qed. Lemma inj_Q_One : inj_Q [1] [=] [1]. Proof. rstepr ((nring 1):R1). apply (inj_Q_nring 1). Qed. Lemma inj_Q_Zero : inj_Q [0] [=] [0]. Proof. rstepr ((nring 0):R1). apply (inj_Q_nring 0). Qed. Hint Resolve inj_Q_nring inj_Q_pring inj_Q_zring inj_Q_One inj_Q_Zero : algebra. Definition inj_Q_hom : RingHom Q_as_CRing R1. Proof. exists (Build_CSetoid_fun _ _ _ inj_Q_strext). refine inj_Q_plus. refine inj_Q_mult. refine inj_Q_One. Defined. Lemma inj_Q_power : forall q1 (n:nat), inj_Q (q1^n)%Q [=] (inj_Q q1[^]n). Proof. intros q. induction n. apply inj_Q_One. rewrite inj_S. unfold Z.succ. stepr (inj_Q (q^n*q)%Q). apply inj_Q_wd. simpl. apply Qpower_plus'. auto with *. stepr (inj_Q (q^n)%Q[*]inj_Q q). apply inj_Q_mult. simpl. apply mult_wdl. assumption. Qed. Lemma inj_Q_power_Z : forall q1 (n:Z) H, inj_Q (q1^n)%Q [=] ((inj_Q q1)[//]H)[^^]n. Proof. intros q [|n|n] H. change (inj_Q (q ^ 0)%Q[=][1]). apply inj_Q_One. simpl. change (inj_Q (q ^ n)%Q[=]inj_Q q[^]n). csetoid_rewrite_rev (inj_Q_power q n). rewrite inject_nat_convert. apply eq_reflexive. change ((inj_Q (/q ^ n))%Q[=]([1][/]inj_Q q[//]H)[^]n). stepl (inj_Q ((1/q)^n)%Q). stepr ((inj_Q (1/q)%Q)[^]n). csetoid_rewrite_rev (inj_Q_power (1/q)%Q n). rewrite inject_nat_convert. apply eq_reflexive. apply nexp_wd. stepr (inj_Q 1%Q[/]_[//]H). apply inj_Q_div. apply div_wd. rstepr (nring 1:R1). apply (inj_Q_nring 1). apply eq_reflexive. apply inj_Q_wd. change (((1 * / q) ^ n)%Q==(/ q ^ n))%Q. rewrite <- Qinv_power. rewrite -> Qmult_1_l. reflexivity. Qed. Hint Resolve inj_Q_power inj_Q_power_Z : algebra. (** ** Injection of [Q] is dense Finally we are able to prove the density of image of [Q] in [R1]. We state this fact in two different ways. Both of them have their specific use. The first theorem states the fact that any real number can be bound by the image of two rational numbers. This is called [start_of_sequence] because it can be used as an starting point for the typical "interval trisection" argument, which is ubiquitous in constructive analysis. *) Theorem start_of_sequence : forall x : R1, {q1 : Q_as_COrdField | {q2 : Q_as_COrdField | inj_Q q1 [<] x | x [<] inj_Q q2}}. Proof. intros. cut {n : nat | x [<] nring (R:=R1) n}. intro H. cut {n : nat | [--]x [<] nring (R:=R1) n}. intro H0. case H. intro n2. intro. case H0. intro n1. intro. exists (Qmake (- n1) 1). exists (Qmake n2 1). simpl in |- *. rstepl (zring (R:=R1) (- Z_of_nat n1)). astepl [--](nring (R:=R1) n1). apply inv_cancel_less. astepr (nring (R:=R1) n1). assumption. simpl in |- *. rstepr (zring (R:=R1) (Z_of_nat n2)). astepr (nring (R:=R1) n2). assumption. apply Archimedes'. apply Archimedes'. Qed. (** The second version of the density of [Q] in [R1] states that given any positive real number, there is a rational number between it and zero. This lemma can be used to prove the more general fact that there is a rational number between any two real numbers. *) Lemma Q_dense_in_CReals : forall e : R1, [0] [<] e -> {q : Q_as_COrdField | [0] [<] inj_Q q | inj_Q q [<] e}. Proof. intros e H. cut {n : nat | ([1][/] e[//]Greater_imp_ap _ e [0] H) [<] nring (R:=R1) n}. intro H0. case H0. intro N. intros. exists (Qmake 1 (P_of_succ_nat N)). simpl in |- *. unfold pring in |- *; simpl in |- *. apply mult_cancel_less with (z := nring (R:=R1) N[+][1]). change ([0] [<] nring (R:=R1) (S N)) in |- *. apply pos_nring_S. astepl ([0]:R1). astepr (([0][+][1][-][0][/] nring (P_of_succ_nat N)[//] den_is_nonzero (Qmake 1%positive (P_of_succ_nat N)))[*] nring (S N)). rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ with N. rstepr ([1]:R1). apply pos_one. apply bin_op_wd_unfolded. rational. algebra. simpl in |- *. apply swap_div with (z_ := Greater_imp_ap _ e [0] H). rewrite nat_of_P_o_P_of_succ_nat_eq_succ. apply pos_nring_S. assumption. unfold pring in |- *; simpl in |- *. rstepl ([1][/] e[//]Greater_imp_ap _ e [0] H). apply less_transitive_unfolded with (y := nring (R:=R1) N). assumption. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. apply nring_less_succ. apply Archimedes'. Qed. Lemma Q_dense_in_CReals' : forall a b : R1, a [<] b -> {q : Q_as_COrdField | a [<] inj_Q q | inj_Q q [<] b}. Proof. cut (forall a b : R1, [0][<]b -> a[<]b -> {q : Q_as_COrdField | a[<]inj_Q q | inj_Q q[<]b}). intros H a b Hab. destruct (less_cotransitive_unfolded _ _ _ Hab [0]);[|apply H;assumption]. assert (X:[0][<][--]a). rstepl ([--][0]:R1). apply inv_resp_less. assumption. assert (Y:=inv_resp_less _ _ _ Hab). destruct (H _ _ X Y) as [q Hqa Hqb]. exists (-q)%Q. stepr ([--](inj_Q q)). apply inv_cancel_less. stepl (inj_Q q);[assumption|apply eq_symmetric; apply cg_inv_inv]. apply eq_symmetric; apply inj_Q_inv. stepl ([--](inj_Q q)). apply inv_cancel_less. stepr (inj_Q q);[assumption|apply eq_symmetric; apply cg_inv_inv]. apply eq_symmetric; apply inj_Q_inv. cut (forall a b : R1, [0][<]b -> (a[+][1])[<]b -> {n : nat | a[<]nring n | nring n[<]b}). intros H a b Hb Hab. destruct (Q_dense_in_CReals _ (shift_zero_less_minus _ _ _ Hab)) as [q Haq Hbq]. assert (X0 := pos_ap_zero _ _ Haq). assert (X1 : [0][<](b[/]inj_Q q[//]X0)). apply div_resp_pos; assumption. assert (X2 : (a[/]inj_Q q[//]X0)[+][1][<](b[/]inj_Q q[//]X0)). apply shift_plus_less'. rstepr ((b[-]a)[/]inj_Q q[//]X0). apply shift_less_div. assumption. rstepl (inj_Q q). assumption. destruct (H _ _ X1 X2) as [r Hra Hrb]. exists ((nring r)[*]q)%Q; csetoid_rewrite (inj_Q_mult (nring r) q). eapply shift_less_mult. assumption. stepr (nring (R:=R1) r). apply Hra. apply eq_symmetric. apply inj_Q_nring. eapply shift_mult_less. assumption. stepl (nring (R:=R1) r). apply Hrb. apply eq_symmetric. apply inj_Q_nring. intros a b Hb Hab. destruct (Archimedes' a) as [n Hn]. induction n. exists 0; try assumption. destruct (less_cotransitive_unfolded _ _ _ Hab (nring (R:=R1) (S n))). apply IHn. apply plus_cancel_less with [1]. apply c. exists (S n); assumption. Qed. End Rational_sequence_prelogue. #[global] Hint Resolve inj_Q_plus inj_Q_mult inj_Q_inv inj_Q_minus inj_Q_div : algebra. #[global] Hint Resolve inj_Q_nring inj_Q_pring inj_Q_zring : algebra. #[global] Hint Resolve inj_Q_power inj_Q_power_Z : algebra. corn-8.20.0/reals/R_morphism.v000066400000000000000000000332101473720167500161710ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) (* In this file a notion of morphism between two arbitrary real number structures, is introduced together with te proofs that this notion of morphism preserves the basic algebraic structure. *) Require Import CoRN.reals.CReals. (* This comes from CReals1.v *) Definition Cauchy_Lim_prop2 (IR : CReals) (seq : nat -> IR) (y : IR) := forall eps : IR, [0][<]eps -> {N : nat | forall m : nat, N <= m -> AbsSmall eps (seq m[-]y)}. Section morphism. Variables R1 R2 : CReals. Section morphism_details. Variable phi : R1 -> R2. Variable p1 : R1 -> R1 -> CProp. Variable p2 : R2 -> R2 -> CProp. Variable f1 : R1 -> R1. Variable f2 : R2 -> R2. Variable g1 : R1 -> R1 -> R1. Variable g2 : R2 -> R2 -> R2. Definition fun_pres_relation := forall x y : R1, p1 x y -> p2 (phi x) (phi y). Definition fun_pres_un_fun := forall x : R1, phi (f1 x)[=]f2 (phi x). Definition fun_pres_bin_fun := forall x y : R1, phi (g1 x y)[=]g2 (phi x) (phi y). (* Definition fun_pres_partial_fun:=(x:R1;H1:x[#][0];H2:(phi x)[#][0]) (phi (nzinj R1 (i1 (nzpro R1 x H1))))[=](nzinj R2 (i2 (nzpro R2 (phi x) H2))). *) Definition fun_pres_Lim := forall (a : nat -> R1) (l_a : R1), Cauchy_Lim_prop2 R1 a l_a -> Cauchy_Lim_prop2 R2 (fun n : nat => phi (a n)) (phi l_a). End morphism_details. Record Homomorphism : Type := {map :> R1 -> R2; map_strext : fun_strext map; map_pres_less : fun_pres_relation map (cof_less (c:=R1)) (cof_less (c:=R2)); map_pres_plus : fun_pres_bin_fun map (csg_op (c:=R1)) (csg_op (c:=R2)); map_pres_mult : fun_pres_bin_fun map (cr_mult (c:=R1)) (cr_mult (c:=R2)); map_pres_Lim : fun_pres_Lim map}. (* This might be useful later... Definition Homo_as_CSetoid_fun:= [f:Homomorphism] (Build_CSetoid_fun R1 R2 f (fun_strext_imp_wd R1 R2 f (!map_strext f)) (!map_strext f) ). *****************) Lemma map_strext_unfolded : forall (f : Homomorphism) (x y : R1), f x[#]f y -> x[#]y. Proof. intro f. case f. intros. rename X into H. apply map_strext0. exact H. Qed. Lemma map_wd_unfolded : forall (f : Homomorphism) (x y : R1), x[=]y -> f x[=]f y. Proof. intros. apply not_ap_imp_eq. intro H0. cut (Not (x[#]y)). intro H1. apply H1. apply map_strext_unfolded with (f := f). exact H0. apply eq_imp_not_ap. exact H. Qed. Lemma map_pres_less_unfolded : forall (f : Homomorphism) (x y : R1), x[<]y -> f x[<]f y. Proof. intro f. case f. intros. rename X into H. apply map_pres_less. exact H. Qed. Lemma map_pres_plus_unfolded : forall (f : Homomorphism) (x y : R1), f (x[+]y)[=]f x[+]f y. Proof. intros. case f. intros. apply map_pres_plus. Qed. Lemma map_pres_mult_unfolded : forall (f : Homomorphism) (x y : R1), f (x[*]y)[=]f x[*]f y. Proof. intros. case f. intros. apply map_pres_mult. Qed. (* Now we start to derive some useful properties of a Homomorphism *) Lemma map_pres_zero : forall f : Homomorphism, f (cm_unit R1)[=]cm_unit R2. Proof. intros. apply cg_cancel_lft with (x := f [0]). apply eq_transitive_unfolded with (f [0]). apply eq_transitive_unfolded with (f ([0][+][0])). apply eq_symmetric_unfolded. apply map_pres_plus_unfolded. apply map_wd_unfolded with (f := f). algebra. algebra. Qed. Lemma map_pres_zero_unfolded : forall f : Homomorphism, f [0][=][0]. Proof. intro. apply map_pres_zero. Qed. Lemma map_pres_minus : forall f : Homomorphism, fun_pres_un_fun f (cg_inv (c:=R1)) (cg_inv (c:=R2)). Proof. intro f. red in |- *. intro. apply cg_cancel_lft with (x := f x). astepr ([0]:R2). apply eq_transitive_unfolded with (f (x[+][--]x)). apply eq_symmetric_unfolded. apply map_pres_plus_unfolded. astepl (f [0]). apply map_pres_zero_unfolded. apply map_wd_unfolded. algebra. Qed. Lemma map_pres_minus_unfolded : forall (f : Homomorphism) (x : R1), f [--]x[=][--](f x). Proof. exact map_pres_minus. Qed. Lemma map_pres_apartness : forall (f : Homomorphism) (x y : R1), x[#]y -> f x[#]f y. Proof. intros f x y H. cut (x[<]y or y[<]x). intro H0. case H0. intro. apply less_imp_ap. apply map_pres_less_unfolded. assumption. intro H1. apply Greater_imp_ap. apply map_pres_less_unfolded. exact H1. apply ap_imp_less. exact H. Qed. (* Merely a useful special case *) Lemma map_pres_ap_zero : forall (f : Homomorphism) (x : R1), x[#][0] -> f x[#][0]. Proof. intros. rename X into H. apply ap_wdr_unfolded with (y := f [0]). apply map_pres_apartness with (y := [0]:R1). exact H. apply map_pres_zero_unfolded. Qed. Lemma map_pres_one : forall f : Homomorphism, f (cr_one R1)[=]cr_one R2. Proof. intros. apply eq_symmetric_unfolded. apply mult_cancel_lft with (z := f [1]). apply map_pres_ap_zero. apply ring_non_triv. astepl (f [1]). astepl (f ([1][*][1])). apply map_pres_mult_unfolded. apply map_wd_unfolded with (f := f). algebra. Qed. Lemma map_pres_one_unfolded : forall f : Homomorphism, f [1][=][1]. Proof. intro. apply map_pres_one. Qed. (* I will not use the following lemma *) Lemma map_pres_inv_unfolded : forall (f : Homomorphism) (x : R1) (H : x[#][0]), f ([1][/] x[//]H)[=]([1][/] f x[//]map_pres_ap_zero f x H). Proof. intros. apply mult_cancel_lft with (z := f x). apply map_pres_ap_zero. assumption. rstepr ([1]:R2). astepl (f [1]). apply map_pres_one_unfolded. astepl (f (x[*]([1][/] x[//]H))). apply map_pres_mult_unfolded. apply map_wd_unfolded. rational. Qed. End morphism. Section composition. Variables R1 R2 R3 : CReals. Variable f : Homomorphism R1 R2. Variable g : Homomorphism R2 R3. Definition compose (x : R1) := g (f x). Lemma compose_strext : fun_strext compose. Proof. red in |- *. unfold compose in |- *. case f. intro f_. intros f_1 f_2 f_3 f_4. case g. intro g_. intros g_1 g_2 g_3 g_4. intros. rename X into H. simpl in H. apply f_1. apply g_1. assumption. Qed. Lemma compose_pres_less : fun_pres_relation R1 R3 compose (cof_less (c:=R1)) (cof_less (c:=R3)). Proof. red in |- *. unfold compose in |- *. case f. intro f_. intros f_1 f_2 f_3 f_4. case g. intro g_. intros g_1 g_2 g_3 g_4. intros. simpl in |- *. apply g_2. apply f_2. assumption. Qed. Lemma compose_pres_plus : fun_pres_bin_fun R1 R3 compose (csg_op (c:=R1)) (csg_op (c:=R3)). Proof. red in |- *. unfold compose in |- *. case f. intro f_. intros f_1 f_2 f_3 f_4. cut (fun_wd g). case g. intro g_. intros g_1 g_2 g_3 g_4. intros. simpl in H. simpl in |- *. astepl (g_ (f_ x[+]f_ y)). apply g_3. red in |- *. intros. apply map_wd_unfolded. assumption. Qed. Lemma compose_pres_mult : fun_pres_bin_fun R1 R3 compose (cr_mult (c:=R1)) (cr_mult (c:=R3)). Proof. red in |- *. unfold compose in |- *. case f. intro f_. intros f_1 f_2 f_3 f_4. cut (fun_wd g). case g. intro g_. intros g_1 g_2 g_3 g_4. intros. simpl in H. simpl in |- *. astepl (g_ (f_ x[*]f_ y)). apply g_4. red in |- *. intros. apply map_wd_unfolded. assumption. Qed. Lemma compose_pres_Lim : fun_pres_Lim R1 R3 compose. Proof. red in |- *. unfold compose in |- *. case f. intro f_. intros f_1 f_2 f_3 f_4 f_5. case g. intro g_. intros g_1 g_2 g_3 g_4 g_5. intros. simpl in |- *. apply g_5 with (a := fun n : nat => f_ (a n)). apply f_5. assumption. Qed. Definition Compose := Build_Homomorphism R1 R3 compose compose_strext compose_pres_less compose_pres_plus compose_pres_mult compose_pres_Lim. End composition. Section isomorphism. Variables R1 R2 : CReals. Section identity_map. Variable R3 : CReals. Variable f : R3 -> R3. Definition map_is_id := forall x : R3, f x[=]x. End identity_map. Record Isomorphism : Type := {iso_map_lft : Homomorphism R1 R2; iso_map_rht : Homomorphism R2 R1; inversity_lft : map_is_id R2 (Compose R2 R1 R2 iso_map_rht iso_map_lft); inversity_rht : map_is_id R1 (Compose R1 R2 R1 iso_map_lft iso_map_rht)}. End isomorphism. Section surjective_map. Variables R1 R2 : CReals. Variable f : R1 -> R2. Definition map_is_surjective := forall y : R2, {x : R1 | y[=]f x}. End surjective_map. Section simplification. Variables R1 R2 : CReals. Variable f : R1 -> R2. Hypothesis H1 : fun_strext f. Lemma f_well_def : forall x y : R1, x[=]y -> f x[=]f y. Proof. intros. apply not_ap_imp_eq. intro. cut (Not (x[#]y)). intro H2. apply H2. red in H1. apply H1. assumption. apply eq_imp_not_ap. assumption. Qed. Section with_less. Hypothesis H2 : fun_pres_relation R1 R2 f (cof_less (c:=R1)) (cof_less (c:=R2)). Lemma less_pres_f : forall x y : R1, f x[<]f y -> x[<]y. Proof. intros. case (ap_imp_less R1 x y). red in H1. apply H1. apply less_imp_ap. assumption. intro. assumption. intro. exfalso. cut (f y[<]f x). change (Not (f y[<]f x)) in |- *. apply less_antisymmetric_unfolded. assumption. red in H2. apply H2. assumption. Qed. Lemma leEq_pres_f : forall x y : R1, f x[<=]f y -> x[<=]y. Proof. intros; rewrite -> leEq_def; intro. apply less_irreflexive_unfolded with (x := f x). apply leEq_less_trans with (f y); auto. Qed. Lemma f_pres_leEq : forall x y : R1, x[<=]y -> f x[<=]f y. Proof. intros; rewrite -> leEq_def; intro. apply less_irreflexive_unfolded with (x := x). apply leEq_less_trans with y; auto. apply less_pres_f; auto. Qed. Lemma f_pres_apartness : forall x y : R1, x[#]y -> f x[#]f y. Proof. intros. cut (x[<]y or y[<]x). intro H0. case H0. intro. apply less_imp_ap. red in H2. apply H2. assumption. intro. apply Greater_imp_ap. red in H2. apply H2. assumption. apply ap_imp_less. assumption. Qed. End with_less. Section with_plus. Hypothesis H3 : fun_pres_bin_fun R1 R2 f (csg_op (c:=R1)) (csg_op (c:=R2)). Lemma f_pres_One : f [0][=][0]. Proof. intros. apply cg_cancel_lft with (x := f [0]). astepr (f [0]). astepl (f ([0][+][0])). apply eq_symmetric_unfolded. red in H3. apply f_well_def. algebra. Qed. Lemma f_pres_minus : forall x : R1, f [--]x[=][--](f x). Proof. intro. apply cg_cancel_lft with (x := f x). astepr ([0]:R2). astepl (f (x[+][--]x)). astepr (f [0]). apply f_well_def. algebra. apply f_pres_One. Qed. Lemma f_pres_min : forall x y : R1, f (x[-]y)[=]f x[-]f y. Proof. intros. astepr (f (x[+][--]y)). apply f_well_def. algebra. astepr (f x[+][--](f y)). red in H3. astepr (f x[+]f [--]y). apply H3. apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply f_pres_minus. Qed. End with_plus. Section with_plus_less. Hypothesis H2 : fun_pres_relation R1 R2 f (cof_less (c:=R1)) (cof_less (c:=R2)). Hypothesis H3 : fun_pres_bin_fun R1 R2 f (csg_op (c:=R1)) (csg_op (c:=R2)). Lemma f_pres_ap_zero : forall x : R1, x[#][0] -> f x[#][0]. Proof. intros. apply ap_wdr_unfolded with (y := f [0]). apply f_pres_apartness with (y := [0]:R1). assumption. assumption. apply f_pres_One. assumption. Qed. Section surjectivity_helps. Hypothesis f_surj : map_is_surjective R1 R2 f. Lemma f_pres_Lim : fun_pres_Lim R1 R2 f. Proof. red in |- *. intros. rename X into H. unfold Cauchy_Lim_prop2 in |- *. intros e2 H0. red in f_surj. unfold Cauchy_Lim_prop2 in H. cut {x : R1 | e2[=]f x}. intro H4. case H4. intros e1 H5. cut {N : nat | forall m : nat, N <= m -> AbsSmall e1 (a m[-]l_a)}. intro H6. case H6. intro N. intros. exists N. intros. cut (AbsSmall e1 (a m[-]l_a)). intro. elim H8. intros. astepl (f e1). astepr (f (a m[-]l_a)). split. astepl (f [--]e1). apply f_pres_leEq. assumption. assumption. apply f_pres_minus. assumption. apply f_pres_leEq. assumption. assumption. apply f_pres_min. assumption. apply a0. assumption. apply H. apply less_pres_f. assumption. astepl ([0]:R2). astepr e2. assumption. apply eq_symmetric_unfolded. apply f_pres_One. assumption. apply f_surj. Qed. End surjectivity_helps. Section with_mult_plus_less. Hypothesis H4 : fun_pres_bin_fun R1 R2 f (cr_mult (c:=R1)) (cr_mult (c:=R2)). Lemma f_pres_one : f [1][=][1]. Proof. intros. apply eq_symmetric_unfolded. apply mult_cancel_lft with (z := f [1]). apply f_pres_ap_zero. apply ring_non_triv. astepl (f [1]). astepr (f ([1][*][1])). apply f_well_def. algebra. Qed. Lemma f_pres_inv : forall (x : R1) (H : x[#][0]), f ([1][/] x[//]H)[=]([1][/] f x[//]f_pres_ap_zero x H). Proof. intros. apply mult_cancel_lft with (z := f x). apply f_pres_ap_zero. assumption. rstepr ([1]:R2). astepr (f [1]). astepl (f (x[*]([1][/] x[//]H))). apply eq_symmetric_unfolded. apply f_well_def. rational. apply f_pres_one. Qed. Definition simplified_Homomorphism (f_surj : map_is_surjective R1 R2 f) := Build_Homomorphism R1 R2 f H1 H2 H3 H4 (f_pres_Lim f_surj). End with_mult_plus_less. End with_plus_less. End simplification. (* end hide *) corn-8.20.0/reals/RealCount.v000066400000000000000000000223421473720167500157520ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.CReals1. (* Consider Reals are enumerated by function f *) Section IntervalSequence. Variable f : nat -> IR. Record interv : Type := {interv_lft : IR; interv_rht : IR; interv_lft_rht : interv_lft [<] interv_rht}. Lemma interv_0_correct: f 0[+][1][<]f 0[+]Two. Proof. apply plus_resp_less_lft. apply one_less_two. Qed. Let interv_0 := (Build_interv (f 0 [+] [1]) (f 0[+]Two) interv_0_correct). (* FIXME: Reuse this code from IVT -----------------------------------*) Let Small : IR := Two [/]ThreeNZ. Let lft (a b : IR) := (Two[*]a[+]b) [/]ThreeNZ. Let rht (a b : IR) := (a[+]Two[*]b) [/]ThreeNZ. Lemma less_pres_lft : forall a b :IR, a[<] b -> a [<] lft a b. Proof. intros. unfold lft in |- *. apply shift_less_div. apply pos_three. rstepl (Two[*]a[+]a). apply plus_resp_less_lft. auto. Qed. Lemma less_pres_rht : forall a b :IR, a[<] b -> rht a b [<] b. Proof. intros. unfold rht in |- *. apply shift_div_less. apply pos_three. rstepr (b[+]Two[*]b). apply plus_resp_less_rht. auto. Qed. Lemma less_pres_lft_rht : forall a b :IR, a[<] b -> lft a b [<] rht a b. Proof. intros. unfold lft in |- *. unfold rht in |- *. apply div_resp_less_rht. rstepl (a[+]b[+]a). rstepr (a[+]b[+]b). apply plus_resp_less_lft. auto. apply pos_three. Qed. Lemma smaller_rht : forall (a b : IR), rht a b[-]a [=] Small[*] (b[-]a). Proof. intros. unfold Small in |- *. unfold rht in |- *. rational. Qed. Lemma smaller_lft : forall (a b : IR), b[-]lft a b [=] Small[*] (b[-]a). Proof. intros. unfold Small in |- *. unfold lft in |- *. rational. Qed. Hint Resolve smaller_lft smaller_rht: algebra. Lemma small_greater_zero : [0] [<=] Small. Proof. unfold Small. assert ([0][<](Two[/]ThreeNZ:IR)). apply pos_div_three; auto. apply pos_two; auto. apply less_leEq; auto. Qed. Lemma small_less_one : Small [<] [1]. Proof. unfold Small. apply mult_cancel_less with (Three:IR). apply pos_three. astepl (Two:IR). astepr (Three:IR). apply two_less_three. Qed. (* -------------------------------------------------------------- *) Definition seq_fun (I : interv) (n:nat) : interv. Proof. case (less_cotransitive_unfolded IR _ _ (less_pres_lft_rht _ _ (interv_lft_rht I)) (f n)). intro H1. apply (Build_interv (interv_lft I) (lft (interv_lft I) (interv_rht I))). apply less_pres_lft. apply interv_lft_rht. intro H2. apply (Build_interv (rht (interv_lft I) (interv_rht I)) (interv_rht I)). apply less_pres_rht. apply interv_lft_rht. Defined. Fixpoint seq1 (n:nat):interv := match n with 0 => interv_0 | (S p) => seq_fun (seq1 p) (S p) end. Definition seq1_lft := fun n:nat => interv_lft (seq1 n). Definition seq1_rht := fun n:nat => interv_rht (seq1 n). Lemma next_smaller : forall (I : interv) (n : nat), seq1_rht (S n)[-]seq1_lft (S n) [<=] Small [*](seq1_rht n[-]seq1_lft n). Proof. intros. unfold seq1_lft. unfold seq1_rht. astepl (interv_rht (seq_fun (seq1 n) (S n))[-]interv_lft (seq_fun (seq1 n) (S n))). unfold seq_fun. case (less_cotransitive_unfolded IR _ _ (less_pres_lft_rht _ _ (interv_lft_rht (seq1 n))) (f (S n))). intros. simpl. apply leEq_transitive with (rht (interv_lft (seq1 n)) (interv_rht (seq1 n))[-]interv_lft (seq1 n)). apply minus_resp_leEq. apply less_leEq. apply less_pres_lft_rht. apply interv_lft_rht. apply eq_imp_leEq. apply smaller_rht. intros. simpl. apply leEq_transitive with (interv_rht (seq1 n)[-]lft (interv_lft (seq1 n)) (interv_rht (seq1 n))). apply minus_resp_leEq_rht. apply less_leEq. apply less_pres_lft_rht. apply interv_lft_rht. apply eq_imp_leEq. apply smaller_lft. Qed. Lemma intervals_smaller : forall N : nat, seq1_rht N[-]seq1_lft N [<=]Small[^]N. Proof. intros. induction N. astepl (([1][-][0]):IR). astepr ([1]:IR). astepl ([1]:IR). apply leEq_reflexive. unfold seq1_lft. unfold seq1_rht. simpl. astepr ((Two [-] [1]):IR); rational. apply leEq_transitive with (Small[*](seq1_rht N[-]seq1_lft N)); auto. apply next_smaller; auto. astepr (Small[*]Small[^]N). apply mult_resp_leEq_lft; auto. apply small_greater_zero. Qed. Lemma grow_lft : forall N m : nat, N <= m -> interv_lft (seq1 N) [<=] interv_lft (seq1 m). Proof. intros. induction m. destruct N; auto. apply leEq_reflexive. assert (S N = 0); auto with arith. elim H0. apply leEq_reflexive. elim H. apply leEq_reflexive. clear IHm. clear H. clear m. intros. apply leEq_transitive with (interv_lft (seq1 m)); auto. astepr (interv_lft (seq_fun (seq1 m) (S m))). unfold seq_fun. case (less_cotransitive_unfolded IR _ _ (less_pres_lft_rht _ _ (interv_lft_rht (seq1 m))) (f (S m))). intros. simpl. apply leEq_reflexive. intros. simpl. apply less_leEq. apply less_transitive_unfolded with (lft (interv_lft (seq1 m)) (interv_rht (seq1 m))). apply less_pres_lft. apply interv_lft_rht. apply less_pres_lft_rht. apply interv_lft_rht. Qed. Lemma grow_rht : forall N m : nat, N <= m -> interv_rht (seq1 m) [<=] interv_rht (seq1 N). Proof. intros. induction m. destruct N; auto. apply leEq_reflexive. assert (S N = 0); auto with arith. elim H0. apply leEq_reflexive. elim H. apply leEq_reflexive. clear IHm. clear H. clear m. intros. apply leEq_transitive with (interv_rht (seq1 m)); auto. astepl (interv_rht (seq_fun (seq1 m) (S m))). unfold seq_fun. case (less_cotransitive_unfolded IR _ _ (less_pres_lft_rht _ _ (interv_lft_rht (seq1 m))) (f (S m))). simpl. intros. apply less_leEq. apply less_transitive_unfolded with (rht (interv_lft (seq1 m)) (interv_rht (seq1 m))). apply less_pres_lft_rht. apply interv_lft_rht. apply less_pres_rht. apply interv_lft_rht. simpl. intros. apply leEq_reflexive. Qed. Lemma intervals_embed : forall N m : nat, N <= m -> AbsSmall (R:=IR) (seq1_rht N[-]seq1_lft N) (seq1_lft m[-]seq1_lft N). Proof. intros. unfold seq1_rht. unfold seq1_lft. unfold AbsSmall. split. apply leEq_transitive with ([0]:IR). astepr ([--][0]:IR). apply inv_resp_leEq. apply shift_leEq_lft. apply less_leEq. apply interv_lft_rht. apply shift_leEq_lft. 2: apply minus_resp_leEq. apply grow_lft; auto. apply leEq_transitive with (interv_rht (seq1 m)). apply less_leEq. apply interv_lft_rht. apply grow_rht; auto. Qed. Lemma Cauchy_seq1_lft : Cauchy_prop seq1_lft. Proof. unfold Cauchy_prop in |- *. intro eps. intros H. assert ({ N : nat | Small[^]N[<=]eps}). apply (qi_yields_zero (Two[/]ThreeNZ) small_greater_zero small_less_one eps); auto. destruct X as [N H1]. exists N. intros. apply AbsSmall_leEq_trans with (seq1_rht N[-]seq1_lft N); auto. apply leEq_transitive with (Small[^]N); auto. apply intervals_smaller; auto. apply intervals_embed; auto. Qed. Definition f_lim := Lim (Build_CauchySeq _ seq1_lft Cauchy_seq1_lft). Lemma lim_smaller: forall (n : nat), f_lim [<=] (seq1_rht n). Proof. intros. unfold f_lim. apply str_seq_leEq_so_Lim_leEq. exists n. intros. simpl. unfold seq1_lft. unfold seq1_rht. apply leEq_transitive with (interv_rht (seq1 i)). apply less_leEq. apply interv_lft_rht. apply grow_rht. auto. Qed. Lemma lim_bigger: forall (n : nat), (seq1_lft n) [<=] f_lim. Proof. intros. unfold f_lim. apply str_leEq_seq_so_leEq_Lim. exists n. intros. simpl. unfold seq1_lft. unfold seq1_rht. apply grow_lft; auto. Qed. Lemma f_n_not_in_int : forall (n : nat), (f n) [<] (seq1_lft n) or (seq1_rht n) [<] (f n). Proof. intros. unfold seq1_lft. unfold seq1_rht. induction n. simpl. left. apply less_plusOne. cut (f (S n)[<]interv_lft (seq_fun (seq1 n) (S n)) or interv_rht (seq_fun (seq1 n) (S n))[<]f (S n)); auto. unfold seq_fun. elim less_cotransitive_unfolded. intros. simpl in |- *. right. auto. intros. simpl in |- *. left. auto. Qed. Lemma lim_not_in_ranf : forall (n : nat), f_lim [#] (f n). Proof. intros. elim (f_n_not_in_int n); intros. assert (f n [<] f_lim). apply less_leEq_trans with (seq1_lft n); auto. apply lim_bigger. apply ap_symmetric. apply less_imp_ap; auto. assert (f_lim [<] f n). apply leEq_less_trans with (seq1_rht n); auto. apply lim_smaller. apply less_imp_ap; auto. Qed. End IntervalSequence. Theorem reals_not_countable : forall (f : nat -> IR),{x :IR | forall n : nat, x [#] (f n)}. Proof. intros. exists (f_lim f). intros. apply lim_not_in_ranf. Qed. corn-8.20.0/reals/RealFuncts.v000066400000000000000000000173421473720167500161300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.CReals1. (** * Continuity of Functions on Reals *) (* begin hide *) Set Implicit Arguments. Unset Strict Implicit. (* end hide *) Section Continuity. Variable f : CSetoid_un_op IR. Variable f2 : CSetoid_bin_op IR. (** Let [f] be a unary setoid operation on [IR] and let [f2] be a binary setoid operation on [IR]. We use the following notations for intervals. [Intclr a b] for the closed interval [[a,b]], [Intolr a b] for the open interval [(a,b)], [Intcl a] for the left-closed interval $[a,\infty)$#[a,∞)#, [Intol a] for the left-open interval $(a,\infty)$#(a,∞)#, [Intcr b] for the right-closed interval $(-\infty,b]$#(-∞,b]#. Intervals like $[a,b]$#[a,b]# are defined for arbitrary reals [a,b] (being $\emptyset$#∅# for [a [>] b]). *) Definition Intclr (a b x : IR) : Prop := a [<=] x /\ x [<=] b. Definition Intolr (a b x : IR) : CProp := a [<] x and x [<] b. Definition Intol (a x : IR) : CProp := a [<] x. Definition Intcl (a x : IR) : Prop := a [<=] x. Definition Intcr (b x : IR) : Prop := x [<=] b. (** The limit of [f(x)] as [x] goes to [p = l], for both unary and binary functions: The limit of [f] in [p] is [l] if [[ forall e [>] [0], exists d [>] [0], forall (x : IR) ( [--]d [<] p[-]x [<] d) -> ( [--]e [<] [--]f(x) [<] e) ]] *) Definition funLim (p l : IR) : CProp := forall e, [0] [<] e -> {d : IR | [0] [<] d | forall x, AbsSmall d (p[-]x) -> AbsSmall e (l[-]f x)}. (** The definition of limit of [f] in [p] using Cauchy sequences. *) Definition funLim_Cauchy (p l : IR) : CProp := forall s : CauchySeqR, Lim s [=] p -> forall e, [0] [<] e -> {N : nat | forall m, N <= m -> AbsSmall e (f (s m) [-]l)}. (** The first definition implies the second one. *) (* Ax_iom funLim_prop1 :(p,l:IR)(funLim p l)->(funLim_Cauchy p l). Intros. Unfold funLim_Cauchy. Unfold funLim in H. Intros. Elim (H e H1). Intros. Elim s. Intros s_seq s_proof. Decompose [and] H2. Cut ([0] [<] x[/]TwoNZ). Intro Hx2. Elim (s_proof (x[/]TwoNZ) Hx2). Intros N HN. Exists N. Intros. Apply AbsSmall_minus. Apply H5. Generalize (HN m H3). Intro HmN. *) (** The limit of [f] in [(p,p')] is [l] if [[ forall e [>] [0], exists d [>] [0], forall (x : IR) ( [--]d [<] p[-]x [<] d) -> ( [--]d' [<] p'[-]y [<] d') -> ( [--]e [<] l[-]f(x,y) [<] e ]] *) Definition funLim2 (p p' l : IR) : CProp := forall e : IR, [0] [<] e -> {d : IR | [0] [<] d | forall x y, AbsSmall d (p[-]x) -> AbsSmall d (p'[-]y) -> AbsSmall e (l[-]f2 x y)}. (** The function [f] is continuous at [p] if the limit of [f(x)] as [x] goes to [p] is [f(p)]. This is the [eps [/] delta] definition. We also give the definition with limits of Cauchy sequences. *) Definition continAt (p : IR) : CProp := funLim p (f p). Definition continAtCauchy (p : IR) : CProp := funLim_Cauchy p (f p). Definition continAt2 (p q : IR) : CProp := funLim2 p q (f2 p q). (* Ax_iom continAt_prop1 :(p:IR)(continAt p)->(continAtCauchy p). *) Definition contin : CProp := forall x : IR, continAt x. Definition continCauchy : CProp := forall x : IR, continAtCauchy x. Definition contin2 : CProp := forall x y : IR, continAt2 x y. (** Continuous on a closed, resp.%\% open, resp.%\% left open, resp.%\% left closed interval *) Definition continOnc a b : CProp := forall x, Intclr a b x -> continAt x. Definition continOno a b : CProp := forall x, Intolr a b x -> continAt x. Definition continOnol a : CProp := forall x, Intol a x -> continAt x. Definition continOncl a : CProp := forall x, Intcl a x -> continAt x. (* Section Sequence_and_function_limits. _** If $\lim_{x->p} (f x) = l$, then for every sequence $p_n$ whose limit is $p$, $\lim_{n->\infty} f (p_n) =l$. *_ Lemma funLim_SeqLimit: (p,l:IR)(fl:(funLim p l)) (pn:nat->IR)(sl:(SeqLimit pn p)) (SeqLimit ( [n:nat] (f (pn n))) l). Proof. Intros; Unfold seqLimit. Intros eps epos. Elim (fl ? epos); Intros del dh; Elim dh; Intros H0 H1. Elim (sl ? H0); Intros N Nh. Exists N. Intros m leNm. Apply AbsSmall_minus. Apply H1. Apply AbsSmall_minus. Apply (Nh ? leNm). Qed. _**** Is the converse constructively provable? ** Lemma SeqLimit_funLim: (p,l:IR)((pn:nat->IR)(sl:(SeqLimit pn p)) (SeqLimit ( [n:nat] (f (pn n))) l))-> (funLim p l). ****_ _** Now the same Lemma in terms of Cauchy sequences: if $\lim_{x->p} (f x) = l$, then for every Cauchy sequence $s_n$ whose limit is $p$, $\lim_{n->\infty} f (s_n) =l$. *_ Ax_iom funLim_isCauchy: (p,l:IR)(funLim p l)->(s:CauchySeqR)((Lim s) [=] p)-> (e:IR)([0] [<] e)->(Ex [N:nat] (m:nat)(le N m) ->(AbsSmall e ((s m) [-] (s N)))). End Sequence_and_function_limits. Section Monotonic_functions. Definition str_monot := (x,y:IR)(x [<] y)->((f x) [<] (f y)). Definition str_monotOnc := [a,b:IR] (x,y:IR)(Intclr a b x)->(Intclr a b y) ->(x [<] y)->((f x) [<] (f y)). Definition str_monotOncl := [a:IR] (x,y:IR)(Intcl a x)->(Intcl a y) ->(x [<] y)->((f x) [<] (f y)). Definition str_monotOnol := [a:IR] (x,y:IR)(Intol a x)->(Intol a y) ->(x [<] y)->((f x) [<] (f y)). _** Following probably not needed for the FTA proof; it stated that strong monotonicity on a closed interval implies that the intermediate value theorem holds on this interval. For FTA we need IVT on $[0,\infty>$. *_ Ax_iom strmonc_imp_ivt :(a,b:IR)(str_monotOnc a b) ->(x,y:IR)(x [<] y)->(Intclr a b x)->(Intclr a b y) ->((f x) [<] [0])->([0] [<] (f y)) ->(EX z:IR | (Intclr x y z)/\((f z) [=] [0])). _** $\forall c\in\RR (f\mbox{ strongly monotonic on }[c,\infty>) \rightarrow \forall a,b\in\RR(c (a,b:IR)(Intcl c a)->(Intcl c b)->((f a) [<] [0])->([0] [<] (f b)) ->(x,y:IR)(Intclr a b x)->(Intclr a b y)->(x [<] y) ->(EX z:IR | (Intclr x y z)/\((f z) [#] [0])). _** The following is lemma 5.8 from the skeleton $\forall c\in\RR (f\mbox{ strongly monotonic on }[c,\infty>) \rightarrow \forall a,b\in\RR(a(a,b:IR)(a [<] b)->(Intcl c a)->(Intcl c b) ->((f a) [<] [0])->([0] [<] (f b)) ->(EX z:IR | (Intclr a b z)/\ ((f z) [=] [0])). End Monotonic_functions. *) End Continuity. (* begin hide *) Set Strict Implicit. Unset Implicit Arguments. (* end hide *) corn-8.20.0/reals/RealLists.v000066400000000000000000000310261473720167500157570ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.reals.CReals1. Section Lists. (** * Lists of Real Numbers In some contexts we will need to work with nested existential quantified formulas of the form $\exists_{n\in\NN}\exists_{x_1,\ldots,x_n}P(x_1,\ldots,x_n)$#exists n exists x1,...,xn P(x1,..,xn)#. One way of formalizing this kind of statement is through quantifying over lists. In this file we provide some tools for manipulating lists. Notice that some of the properties listed below only make sense in the context within which we are working. Unlike in the other lemma files, no care has been taken here to state the lemmas in their most general form, as that would make them very unpractical to use. %\bigskip% We start by defining maximum and minimum of lists of reals and two membership predicates. The value of these functions for the empty list is arbitrarily set to 0, but it will be irrelevant, as we will never work with empty lists. *) Fixpoint maxlist (l : list IR) : IR := match l with | nil => [0] | cons x nil => x | cons x m => Max x (maxlist m) end. Fixpoint minlist (l : list IR) : IR := match l with | nil => [0] | cons x nil => x | cons x m => Min x (minlist m) end. Fixpoint member (x : IR) (l : list IR) {struct l} : CProp := match l with | nil => False | cons y m => member x m or x [=] y end. (** Sometimes the length of the list has to be restricted; the next definition provides an easy way to do that. *) Definition length_leEq (A : Type) (l : list A) (n : nat) := length l <= n. (** Length is preserved by mapping. *) Arguments map [A B]. Lemma map_pres_length : forall (A B : Set) (l : list A) (f : A -> B), length l = length (map f l). Proof. intros. induction l as [| a l Hrecl]. auto. simpl in |- *; auto. Qed. (** Often we want to map partial functions through a list; this next operator provides a way to do that, and is proved to be correct. *) Arguments cons [A]. Definition map2 (F : PartIR) (l : list IR) : (forall y, member y l -> Dom F y) -> list IR. Proof. intros H. induction l as [| a l Hrecl]. apply (@nil IR). apply cons. cut (member a (cons a l)); [ intro | right; algebra ]; rename X into H0. apply (Part F a (H a H0)). cut (forall y : IR, member y l -> Dom F y); intros; rename X into H0. 2: apply H; left; assumption. apply (Hrecl H0). Defined. Lemma map2_wd : forall F l H H' x, member x (map2 F l H) -> member x (map2 F l H'). Proof. intros. rename X into H0. induction l as [| a l Hrecl]. simpl in |- *; simpl in H0; assumption. simpl in H0; inversion_clear H0. rename X into H0. simpl in |- *; left. apply Hrecl with (fun (y : IR) (H0 : member y l) => H y (@inl (member y l) (y [=] a) H0)). assumption. right. eapply eq_transitive_unfolded. apply H1. simpl in |- *; apply pfwdef; algebra. Qed. Lemma map2_pres_member : forall (F : PartIR) x Hx l H, member x l -> member (F x Hx) (map2 F l H). Proof. intros. rename X into H0. induction l as [| a l Hrecl]. simpl in |- *; simpl in H; assumption. simpl in |- *. elim H0. intro; left; apply Hrecl; assumption. intro; right. apply pfwdef; assumption. Qed. (** As [maxlist] and [minlist] are generalizations of [Max] and [Min] to finite sets of real numbers, they have the expected properties: *) Lemma maxlist_greater : forall l x, member x l -> x [<=] maxlist l. Proof. intros l x H. induction l as [| a l Hrecl]. exfalso; assumption. simpl in |- *. induction l as [| a0 l Hrecl0]. simpl in H; elim H. intro; tauto. intro; apply eq_imp_leEq. auto. simpl in H. elim H. intro. apply leEq_transitive with (maxlist (cons a0 l)). apply Hrecl; assumption. apply rht_leEq_Max. intro; astepl a; apply lft_leEq_Max. Qed. (* begin hide *) Let maxlist_aux : forall (a b : IR) (l : list IR), maxlist (cons a (cons b l)) [=] maxlist (cons b (cons a l)). Proof. intros. case l. simpl in |- *; apply Max_comm. intros c m. astepl (Max a (Max b (maxlist (cons c m)))). astepr (Max b (Max a (maxlist (cons c m)))). apply leEq_imp_eq; apply Max_leEq. eapply leEq_transitive. 2: apply rht_leEq_Max. apply lft_leEq_Max. apply Max_leEq. apply lft_leEq_Max. eapply leEq_transitive. 2: apply rht_leEq_Max. apply rht_leEq_Max. eapply leEq_transitive. 2: apply rht_leEq_Max. apply lft_leEq_Max. apply Max_leEq. apply lft_leEq_Max. eapply leEq_transitive. 2: apply rht_leEq_Max. apply rht_leEq_Max. Qed. (* end hide *) Lemma maxlist_leEq_eps : forall l : list IR, {x : IR | member x l} -> forall e, [0] [<] e -> {x : IR | member x l | maxlist l[-]e [<=] x}. Proof. intro l; induction l as [| a l Hrecl]. intro H; simpl in H; inversion H as [x H0]; inversion H0. clear Hrecl. intro H; induction l as [| a0 l Hrecl]; intros e H0. simpl in |- *; exists a. right; algebra. apply less_leEq; apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; assumption. cut ({Max a0 (maxlist (cons a l)) [-]e [/]TwoNZ [<=] a0} + {Max a0 (maxlist (cons a l)) [-]e [/]TwoNZ [<=] maxlist (cons a l)}). 2: apply Max_minus_eps_leEq; apply pos_div_two; assumption. intro H1. elim H1; intro H2. exists a0. simpl in |- *; left; right; algebra. apply leEq_transitive with (Max a (maxlist (cons a0 l)) [-]e [/]TwoNZ). astepl (Max a (maxlist (cons a0 l)) [-]e). apply shift_leEq_minus; apply shift_plus_leEq'. rstepr e. apply less_leEq; apply pos_div_two'; assumption. apply shift_minus_leEq. astepl (maxlist (cons a (cons a0 l))). eapply leEq_wdl. 2: apply maxlist_aux. astepl (Max a0 (maxlist (cons a l))). apply shift_leEq_plus; assumption. elim Hrecl with (e [/]TwoNZ). intros x p q. exists x. elim p; intro H3. left; left; assumption. right; assumption. apply shift_minus_leEq; eapply leEq_wdl. 2: apply maxlist_aux. apply shift_leEq_plus. astepl (Max a0 (maxlist (cons a l)) [-]e). rstepl (Max a0 (maxlist (cons a l)) [-]e [/]TwoNZ[-]e [/]TwoNZ). apply leEq_transitive with (maxlist (cons a l) [-]e [/]TwoNZ). apply minus_resp_leEq; assumption. assumption. exists a; right; algebra. apply pos_div_two; assumption. Qed. Lemma maxlist_less : forall x l, 0 < length l -> (forall y, member y l -> y [<] x) -> maxlist l [<] x. Proof. simple induction l. simpl in |- *; intros; exfalso; inversion H. clear l. do 2 intro. intro H. clear H; induction l as [| a0 l Hrecl]. simpl in |- *; intros H H0. apply H0; right; algebra. generalize l a0 Hrecl; clear Hrecl l a0. intros l b; intros. rename X into H0. eapply less_wdl. 2: apply maxlist_aux. astepl (Max b (maxlist (cons a l))). apply Max_less. apply H0; left; right; algebra. apply Hrecl. simpl in |- *; apply Nat.lt_0_succ. intros y H1. apply H0. inversion_clear H1. left; left; assumption. right; assumption. Qed. Lemma maxlist_leEq : forall y l, 0 < length l -> (forall x, member x l -> x [<=] y) -> maxlist l [<=] y. Proof. simple induction l. simpl in |- *; intros; exfalso; inversion H. clear l. do 3 intro. clear H; induction l as [| a0 l Hrecl]. simpl in |- *; intros. apply H0; right; algebra. generalize l a0 Hrecl; clear Hrecl l a0. intros l b; intros. eapply leEq_wdl. 2: apply maxlist_aux. astepl (Max b (maxlist (cons a l))). apply Max_leEq. apply H0; left; right; algebra. apply Hrecl. simpl in |- *; auto with arith. intros x H1. apply H0. inversion_clear H1. left; left; assumption. right; assumption. Qed. Lemma minlist_smaller : forall l x, member x l -> minlist l [<=] x. Proof. intros l x H. induction l as [| a l Hrecl]. easy. simpl in |- *. astepl match l with | nil => a | cons _ _ => Min a (minlist l) end. induction l as [| a0 l Hrecl0]. simpl in H; elim H. intro; tauto. intro; cut (a [=] x); [ apply eq_imp_leEq | apply eq_symmetric_unfolded; assumption ]. simpl in H. elim H. intro. apply leEq_transitive with (minlist (cons a0 l)). apply Min_leEq_rht. apply Hrecl; assumption. intro; astepr a; apply Min_leEq_lft. Qed. (* begin hide *) Let minlist_aux : forall (a b : IR) (l : list IR), minlist (cons a (cons b l)) [=] minlist (cons b (cons a l)). Proof. intros. case l. astepl (Min a b); astepr (Min b a); apply Min_comm. intros c m. astepl (Min a (Min b (minlist (cons c m)))). astepr (Min b (Min a (minlist (cons c m)))). apply leEq_imp_eq; apply leEq_Min. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_lft. apply leEq_Min. apply Min_leEq_lft. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_rht. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_lft. apply leEq_Min. apply Min_leEq_lft. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_rht. Qed. (* end hide *) Lemma minlist_leEq_eps : forall l : list IR, {x : IR | member x l} -> forall e, [0] [<] e -> {x : IR | member x l | x [<=] minlist l[+]e}. Proof. intro l; induction l as [| a l Hrecl]. intro H; simpl in H; inversion H as [x H0]; inversion H0. clear Hrecl. intro H; induction l as [| a0 l Hrecl]; intros e He. simpl in |- *; exists a. right; algebra. apply less_leEq; apply shift_less_plus'. astepl ZeroR; assumption. cut ({a0 [<=] Min a0 (minlist (cons a l)) [+]e [/]TwoNZ} + {minlist (cons a l) [<=] Min a0 (minlist (cons a l)) [+]e [/]TwoNZ}). 2: apply leEq_Min_plus_eps; apply pos_div_two; assumption. intro H1. elim H1; intro H2. exists a0. simpl in |- *; left; right; algebra. apply leEq_transitive with (Min a (minlist (cons a0 l)) [+]e [/]TwoNZ). apply shift_leEq_plus. astepr (minlist (cons a (cons a0 l))). eapply leEq_wdr. 2: apply minlist_aux. astepr (Min a0 (minlist (cons a l))). apply shift_minus_leEq; assumption. astepr (Min a (minlist (cons a0 l)) [+]e). apply plus_resp_leEq_lft. apply less_leEq; apply pos_div_two'; assumption. elim Hrecl with (e [/]TwoNZ). intros x p q. exists x. elim p; intro H3. left; left; assumption. right; assumption. apply shift_leEq_plus; eapply leEq_wdr. 2: apply minlist_aux. apply shift_minus_leEq. astepr (Min a0 (minlist (cons a l)) [+]e). rstepr (Min a0 (minlist (cons a l)) [+]e [/]TwoNZ[+]e [/]TwoNZ). apply leEq_transitive with (minlist (cons a l) [+]e [/]TwoNZ). assumption. apply plus_resp_leEq; assumption. exists a; right; algebra. apply pos_div_two; assumption. Qed. Lemma less_minlist : forall x l, 0 < length l -> (forall y, member y l -> x [<] y) -> x [<] minlist l. Proof. simple induction l. simpl in |- *; intros; exfalso; inversion H. clear l. do 2 intro. intro H. clear H; induction l as [| a0 l Hrecl]. simpl in |- *; intros H H0. apply H0; right; algebra. generalize l a0 Hrecl; clear Hrecl l a0. intros l b; intros. rename X into H0. eapply less_wdr. 2: apply minlist_aux. astepr (Min b (minlist (cons a l))). apply less_Min. apply H0; left; right; algebra. apply Hrecl. simpl in |- *; auto with arith. intros y H1; apply H0. inversion_clear H1. left; left; assumption. right; assumption. Qed. Lemma leEq_minlist : forall x l, 0 < length l -> (forall y, member y l -> x [<=] y) -> x [<=] minlist l. Proof. simple induction l. simpl in |- *; intros; exfalso; inversion H. clear l. do 3 intro. clear H; induction l as [| a0 l Hrecl]. simpl in |- *; intros. apply H0; right; algebra. generalize l a0 Hrecl; clear Hrecl l a0. intros l b; intros. eapply leEq_wdr. 2: apply minlist_aux. astepr (Min b (minlist (cons a l))). apply leEq_Min. apply H0; left; right; algebra. apply Hrecl. simpl in |- *; auto with arith. intros y H1; apply H0. inversion_clear H1. left; left; assumption. right; assumption. Qed. End Lists. corn-8.20.0/reals/Series.v000066400000000000000000001205111473720167500153050ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing seq_part_sum %\ensuremath{\sum^n}% #∑n# *) (** printing series_sum %\ensuremath{\sum_0^{\infty}}% #∑0∞# *) (** printing pi %\ensuremath{\pi}% #π *) Require Export CoRN.reals.CSumsReals. Require Export CoRN.reals.NRootIR. From Coq Require Import Lia. Section Definitions. (** * Series of Real Numbers In this file we develop a theory of series of real numbers. ** Definitions A series is simply a sequence from the natural numbers into the reals. To each such sequence we can assign a sequence of partial sums. %\begin{convention}% Let [x:nat->IR]. %\end{convention}% *) Variable x : nat -> IR. Definition seq_part_sum (n : nat) := Sum0 n x. (** For subsequent purposes it will be very useful to be able to write the difference between two arbitrary elements of the sequence of partial sums as a sum of elements of the original sequence. *) Lemma seq_part_sum_n : forall m n, 0 < n -> m <= n -> seq_part_sum n[-]seq_part_sum m [=] Sum m (pred n) x. Proof. intros. elim (le_lt_eq_dec _ _ H0); intro. unfold seq_part_sum in |- *. unfold Sum, Sum1 in |- *. rewrite Nat.lt_succ_pred with 0 n; auto. algebra. rewrite b. astepl ZeroR. apply eq_symmetric_unfolded; apply Sum_empty. assumption. Qed. (** A series is convergent iff its sequence of partial Sums is a Cauchy sequence. To each convergent series we can assign a Sum. *) Definition convergent := Cauchy_prop seq_part_sum. Definition series_sum (H : convergent) := Lim (Build_CauchySeq _ _ H). (** Divergence can be characterized in a positive way, which will sometimes be useful. We thus define divergence of sequences and series and prove the obvious fact that no sequence can be both convergent and divergent, whether considered either as a sequence or as a series. *) Definition divergent_seq (a : nat -> IR) := {e : IR | [0] [<] e | forall k, {m : nat | {n : nat | k <= m /\ k <= n /\ e [<=] AbsIR (a m[-]a n)}}}. Definition divergent := divergent_seq seq_part_sum. Lemma conv_imp_not_div : forall a, Cauchy_prop a -> Not (divergent_seq a). Proof. intros a Hconv. intro Hdiv. red in Hconv, Hdiv. elim Hdiv; clear Hdiv; intros e He He'. elim (Hconv _ (pos_div_three _ _ He)); clear Hconv; intros N HN. elim (He' N); clear He'; intros m Hm. elim Hm; clear Hm; intros n Hm'. elim Hm'; clear Hm'; intros Hm Hn. elim Hn; clear Hn; intros Hn Hmn. rewrite -> leEq_def in Hmn; apply Hmn. rstepr (e [/]ThreeNZ[+]e [/]ThreeNZ[+]e [/]ThreeNZ). apply leEq_less_trans with (AbsIR (a m[-]a N) [+]AbsIR (a N[-]a n)). eapply leEq_wdl. apply triangle_IR. apply AbsIR_wd; rational. astepl ([0][+]AbsIR (a m[-]a N) [+]AbsIR (a N[-]a n)). repeat apply plus_resp_less_leEq; try apply AbsSmall_imp_AbsIR; try exact (pos_div_three _ _ He). auto. apply AbsSmall_minus; auto. Qed. Lemma div_imp_not_conv : forall a, divergent_seq a -> Not (Cauchy_prop a). Proof. intros a H. red in |- *; intro H0. generalize H; generalize H0. apply conv_imp_not_div. Qed. Lemma convergent_imp_not_divergent : convergent -> Not divergent. Proof. intro H. intro H0. red in H, H0. generalize H0; apply conv_imp_not_div. assumption. Qed. Lemma divergent_imp_not_convergent : divergent -> Not convergent. Proof. intro H. intro H0. red in H, H0. generalize H0; apply div_imp_not_conv. assumption. Qed. (** Finally we have the well known fact that every convergent series converges to zero as a sequence. *) Lemma series_seq_Lim : convergent -> Cauchy_Lim_prop2 x [0]. Proof. intros H. red in |- *. intros eps H0. red in H. red in H. elim (H _ (pos_div_two _ _ H0)). intros N HN. exists (Nat.max N 1); intros. apply AbsSmall_wdr_unfolded with (seq_part_sum (S m) [-]seq_part_sum m). apply AbsSmall_wdr_unfolded with (seq_part_sum (S m) [-]seq_part_sum N[+] (seq_part_sum N[-]seq_part_sum m)). rstepl (eps [/]TwoNZ[+]eps [/]TwoNZ). apply AbsSmall_plus. apply HN. apply Nat.le_trans with (Nat.max N 1); auto with arith. apply AbsSmall_minus; apply HN. apply Nat.le_trans with (Nat.max N 1); auto with arith. rational. eapply eq_transitive_unfolded. apply seq_part_sum_n; auto with arith. simpl in |- *; astepr (x m); apply Sum_one. Qed. Lemma series_seq_Lim' : convergent -> forall H, Lim (Build_CauchySeq _ x H) [=] [0]. Proof. intros. apply eq_symmetric_unfolded; apply Limits_unique. apply series_seq_Lim; auto. Qed. End Definitions. Section More_Definitions. Variable x : nat -> IR. (** We also define absolute convergence. *) Definition abs_convergent := convergent (fun n => AbsIR (x n)). End More_Definitions. Section Power_Series. (** ** Power Series Power series are an important special case. *) Definition power_series (c : IR) n := c[^]n. (** Specially important is the case when [c] is a real number whose absolute value is less than 1; in this case not only the power series is convergent, but we can also compute its sum. %\begin{convention}% Let [c] be a real number between -1 and 1. %\end{convention}% *) Variable c : IR. Hypothesis Hc : AbsIR c [<] [1]. Lemma c_exp_Lim : Cauchy_Lim_prop2 (power_series c) [0]. Proof. red in |- *; intros eps H. elim (qi_yields_zero (AbsIR c) (AbsIR_nonneg _) Hc eps H). intros N Hn. exists N; intros. unfold power_series in |- *. astepr (c[^]m). apply AbsSmall_transitive with (c[^]N). apply AbsIR_imp_AbsSmall. eapply leEq_wdl. apply Hn. apply eq_symmetric_unfolded; apply (AbsIR_nexp c N). eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply (AbsIR_nexp c m). eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply (AbsIR_nexp c N). change ((AbsIR c)[^]m[<=](AbsIR c)[^]N). apply nexp_resp_le'. apply AbsIR_nonneg. apply less_leEq; assumption. assumption. Qed. Lemma power_series_Lim1 : forall H : [1][-]c [#] [0], Cauchy_Lim_prop2 (seq_part_sum (power_series c)) ([1][/] _[//]H). Proof. intro. red in |- *. intros. unfold power_series in |- *; unfold seq_part_sum in |- *. cut ({N : nat | (AbsIR c)[^]N [<=] eps[*]AbsIR ([1][-]c)}). intro H1. elim H1; clear H1; intros N HN. exists N; intros. apply AbsSmall_wdr_unfolded with ( [--] (c[^]m[/] _[//]H)). apply inv_resp_AbsSmall. apply AbsIR_imp_AbsSmall. eapply leEq_wdl. 2: apply eq_symmetric_unfolded. 2: apply (AbsIR_division (c[^]m) ([1][-]c) H (AbsIR_resp_ap_zero _ H)). apply shift_div_leEq. apply AbsIR_pos; assumption. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op. eapply leEq_transitive. 2: apply HN. apply nexp_resp_le'; auto. apply AbsIR_nonneg. apply less_leEq; auto. astepl ( [--] (c[^]m[/] _[//]H) [+] ([1][/] _[//]H) [-] ([1][/] _[//]H)). apply cg_minus_wd. 2: algebra. cut (c[-][1] [#] [0]). intros H2. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. apply Sum0_c_exp with (H := H2). rational. apply minus_ap_zero. apply ap_symmetric. apply zero_minus_apart. assumption. apply qi_yields_zero. apply AbsIR_nonneg. assumption. apply less_wdl with ([0][*]AbsIR ([1][-]c)). apply mult_resp_less. assumption. apply AbsIR_pos. assumption. apply cring_mult_zero_op. Qed. Lemma power_series_conv : convergent (power_series c). Proof. intros. red in |- *. apply Cauchy_prop2_prop. cut ([1][-]c [#] [0]). intro H. exists ([1][/] _[//]H). apply power_series_Lim1. apply minus_ap_zero. apply Greater_imp_ap. eapply leEq_less_trans. apply leEq_AbsIR. assumption. Qed. Lemma power_series_sum : forall H Hc, series_sum (power_series c) Hc [=] ([1][/] [1][-]c[//]H). Proof. intros. unfold series_sum in |- *. apply eq_symmetric_unfolded; apply Limits_unique. apply power_series_Lim1. Qed. End Power_Series. Section Operations. (** ** Operations Some operations with series preserve convergence. We start by defining the series that is zero everywhere. *) Lemma conv_zero_series : convergent (fun n => [0]). Proof. exists 0. intros. simpl in |- *. eapply AbsSmall_wdr_unfolded. apply zero_AbsSmall; apply less_leEq; assumption. unfold seq_part_sum in |- *. induction m as [| m Hrecm]. simpl in |- *; algebra. simpl in |- *. eapply eq_transitive_unfolded. apply Hrecm; auto with arith. rational. Qed. Lemma series_sum_zero : forall H : convergent (fun n => [0]), series_sum _ H [=] [0]. Proof. intro. unfold series_sum in |- *. apply eq_symmetric_unfolded; apply Limits_unique. exists 0. intros. simpl in |- *. eapply AbsSmall_wdr_unfolded. apply zero_AbsSmall; apply less_leEq; assumption. unfold seq_part_sum in |- *. induction m as [| m Hrecm]. simpl in |- *; algebra. simpl in |- *. eapply eq_transitive_unfolded. apply Hrecm; auto with arith. rational. Qed. (** Next we consider extensionality, as well as the sum and difference of two convergent series. %\begin{convention}% Let [x,y:nat->IR] be convergent series. %\end{convention}% *) Variables x y : nat -> IR. Hypothesis convX : convergent x. Hypothesis convY : convergent y. Lemma convergent_wd : (forall n, x n [=] y n) -> convergent x -> convergent y. Proof. intros H H0. red in |- *; red in H0. apply Cauchy_prop_wd with (seq_part_sum x). assumption. intro. unfold seq_part_sum in |- *. apply Sum0_wd. assumption. Qed. Lemma series_sum_wd : (forall n, x n [=] y n) -> series_sum _ convX [=] series_sum _ convY. Proof. intros. unfold series_sum in |- *. apply Lim_wd'. intro; simpl in |- *. unfold seq_part_sum in |- *. apply Sum0_wd; assumption. Qed. Lemma conv_series_plus : convergent (fun n => x n[+]y n). Proof. red in |- *. red in convX, convY. eapply Cauchy_prop_wd. apply Cauchy_plus with (seq1 := Build_CauchySeq _ _ convX) (seq2 := Build_CauchySeq _ _ convY). simpl in |- *. unfold seq_part_sum in |- *. intro. apply eq_symmetric_unfolded; apply Sum0_plus_Sum0. Qed. Lemma series_sum_plus : forall H : convergent (fun n => x n[+]y n), series_sum _ H [=] series_sum _ convX[+]series_sum _ convY. Proof. intros. unfold series_sum in |- *. eapply eq_transitive_unfolded. 2: apply Lim_plus. apply Lim_wd'. intro; simpl in |- *. unfold seq_part_sum in |- *. apply Sum0_plus_Sum0. Qed. Lemma conv_series_minus : convergent (fun n => x n[-]y n). Proof. red in |- *. red in convX, convY. eapply Cauchy_prop_wd. apply Cauchy_minus with (seq1 := Build_CauchySeq _ _ convX) (seq2 := Build_CauchySeq _ _ convY). simpl in |- *. unfold seq_part_sum in |- *. intro. apply eq_symmetric_unfolded; unfold cg_minus in |- *. eapply eq_transitive_unfolded. apply Sum0_plus_Sum0 with (g := fun n : nat => [--] (y n)). apply bin_op_wd_unfolded. algebra. apply inv_Sum0. Qed. Lemma series_sum_minus : forall H : convergent (fun n => x n[-]y n), series_sum _ H [=] series_sum _ convX[-]series_sum _ convY. Proof. intros. unfold series_sum in |- *. eapply eq_transitive_unfolded. 2: apply Lim_minus. apply Lim_wd'. intro; simpl in |- *. unfold seq_part_sum in |- *. unfold cg_minus in |- *. eapply eq_transitive_unfolded. apply Sum0_plus_Sum0 with (g := fun n : nat => [--] (y n)). apply bin_op_wd_unfolded. algebra. apply inv_Sum0. Qed. (** Multiplication by a scalar [c] is also permitted. *) Variable c : IR. Lemma conv_series_mult_scal : convergent (fun n => c[*]x n). Proof. red in |- *. red in convX. eapply Cauchy_prop_wd. apply Cauchy_mult with (seq2 := Build_CauchySeq _ _ convX) (seq1 := Cauchy_const c). simpl in |- *. unfold seq_part_sum in |- *. intro. apply eq_symmetric_unfolded. apply Sum0_comm_scal'. Qed. Lemma series_sum_mult_scal : forall H : convergent (fun n => c[*]x n), series_sum _ H [=] c[*]series_sum _ convX. Proof. intros. unfold series_sum in |- *. apply eq_transitive_unfolded with (Lim (Cauchy_const c) [*]Lim (Build_CauchySeq _ _ convX)). 2: apply mult_wdl; apply eq_symmetric_unfolded; apply Lim_const. eapply eq_transitive_unfolded. 2: apply Lim_mult. apply Lim_wd'. intro; simpl in |- *. unfold seq_part_sum in |- *. apply Sum0_comm_scal'. Qed. End Operations. Section More_Operations. Variable x : nat -> IR. Hypothesis convX : convergent x. (** As a corollary, we get the series of the inverses. *) Lemma conv_series_inv : convergent (fun n => [--] (x n)). Proof. red in |- *. red in convX. eapply Cauchy_prop_wd. apply Cauchy_minus with (seq1 := Cauchy_const [0]) (seq2 := Build_CauchySeq _ _ convX). simpl in |- *. unfold seq_part_sum in |- *. intro. apply eq_symmetric_unfolded; apply eq_transitive_unfolded with ([0][+]Sum0 n (fun n : nat => [--] (x n))). algebra. unfold cg_minus in |- *; apply bin_op_wd_unfolded. algebra. apply inv_Sum0. Qed. Lemma series_sum_inv : forall H : convergent (fun n => [--] (x n)), series_sum _ H [=] [--] (series_sum _ convX). Proof. intros. set (y := Cauchy_const [0]) in *. cut (convergent y). intros H0. eapply eq_transitive_unfolded. apply series_sum_wd with (y := fun n : nat => y n[-]x n) (convY := conv_series_minus _ _ H0 convX). intro; unfold y in |- *; simpl in |- *; algebra. cut (series_sum y H0 [=] [0]); intros. astepr ([0][-]series_sum x convX). astepr (series_sum y H0[-]series_sum x convX). apply series_sum_minus. apply series_sum_zero. apply conv_zero_series. Qed. End More_Operations. Section Almost_Everywhere. (** ** Almost Everywhere In this section we strengthen some of the convergence results for sequences and derive an important corollary for series. Let [x,y : nat->IR] be equal after some natural number. *) Variables x y : nat -> IR. Definition aew_eq := {n : nat | forall k, n <= k -> x k [=] y k}. Hypothesis aew_equal : aew_eq. Lemma aew_Cauchy : Cauchy_prop x -> Cauchy_prop y. Proof. intro H. red in |- *; intros e H0. elim (H _ (pos_div_two _ _ H0)). intros N HN. elim aew_equal; intros n Hn. exists (Nat.max n N). intros. apply AbsSmall_wdr_unfolded with (x m[-]x (Nat.max n N)). rstepr (x m[-]x N[+] (x N[-]x (Nat.max n N))). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply HN; apply Nat.le_trans with (Nat.max n N); auto with arith. apply AbsSmall_minus; apply HN; apply Nat.le_trans with (Nat.max n N); auto with arith. apply cg_minus_wd; apply Hn. apply Nat.le_trans with (Nat.max n N); auto with arith. apply Nat.le_max_l. Qed. Lemma aew_Cauchy2 : forall c, Cauchy_Lim_prop2 x c -> Cauchy_Lim_prop2 y c. Proof. intros c H. red in |- *; intros eps H0. elim (H eps H0). intros N HN. elim aew_equal; intros n Hn. exists (Nat.max n N). intros. apply AbsSmall_wdr_unfolded with (x m[-]c). apply HN; apply Nat.le_trans with (Nat.max n N); auto with arith. apply cg_minus_wd; [ apply Hn | algebra ]. apply Nat.le_trans with (Nat.max n N); auto with arith. Qed. Lemma aew_series_conv : convergent x -> convergent y. Proof. intro H. red in |- *; red in |- *; intros. rename X into H0. elim (H _ (pos_div_two _ _ H0)); intros N HN. elim aew_equal; intros n Hn. set (k := Nat.max (Nat.max n N) 1) in *. exists k; intros. apply AbsSmall_wdr_unfolded with (seq_part_sum x m[-]seq_part_sum x k). rstepr (seq_part_sum x m[-]seq_part_sum x N[+] (seq_part_sum x N[-]seq_part_sum x k)). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply HN; cut (N <= k). lia. apply Nat.le_trans with (Nat.max n N); unfold k in |- *; auto with arith. apply AbsSmall_minus; apply HN; auto. apply Nat.le_trans with (Nat.max n N); unfold k in |- *; auto with arith. cut (1 <= k); intros. eapply eq_transitive_unfolded. apply seq_part_sum_n; auto. apply Nat.lt_le_trans with k; auto. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply seq_part_sum_n; auto. 2: apply Nat.lt_le_trans with k; auto. apply Sum_wd'. rewrite Nat.lt_succ_pred with 0 m; auto with arith. apply Nat.lt_le_trans with k; auto. intros; apply Hn. apply Nat.le_trans with (Nat.max n N); auto with arith. apply Nat.le_trans with k; unfold k in |- *; auto with arith. unfold k in |- *; apply Nat.le_max_r. Qed. End Almost_Everywhere. Section Cauchy_Almost_Everywhere. (** Suppose furthermore that [x,y] are Cauchy sequences. *) Variables x y : CauchySeq IR. Hypothesis aew_equal : aew_eq x y. Lemma aew_Lim : Lim x [=] Lim y. Proof. intros. cut (Cauchy_Lim_prop2 x (Lim y)). intro. apply eq_symmetric_unfolded. apply Limits_unique; assumption. apply aew_Cauchy2 with (y:nat -> IR). elim aew_equal; intros n Hn; exists n; intros. apply eq_symmetric_unfolded; apply Hn; auto. apply Cauchy_complete. Qed. End Cauchy_Almost_Everywhere. Section Convergence_Criteria. (** ** Convergence Criteria %\begin{convention}% Let [x:nat->IR]. %\end{convention}% *) Variable x : nat -> IR. (** We include the comparison test for series, both in a strong and in a less general (but simpler) form. *) Lemma str_comparison : forall y, convergent y -> {k : nat | forall n, k <= n -> AbsIR (x n) [<=] y n} -> convergent x. Proof. intros y H H0. elim H0; intros k Hk. red in |- *; red in |- *; intros. cut {N : nat | k < N /\ (forall m : nat, N <= m -> AbsSmall e (seq_part_sum y m[-]seq_part_sum y N))}. intros H2. elim H2; clear H2. intros N HN; elim HN; clear HN; intros HN' HN. exists N; intros. apply AbsIR_imp_AbsSmall. apply leEq_transitive with (seq_part_sum y m[-]seq_part_sum y N). apply leEq_transitive with (Sum N (pred m) (fun n : nat => AbsIR (x n))). apply leEq_wdl with (AbsIR (Sum N (pred m) x)). 2: apply AbsIR_wd; apply eq_symmetric_unfolded; apply seq_part_sum_n; auto. 2: apply Nat.lt_le_trans with N; auto; apply Nat.le_lt_trans with k; auto with arith. apply triangle_SumIR. rewrite (Nat.lt_succ_pred k m); auto with arith. apply Nat.lt_le_trans with N; auto. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply seq_part_sum_n; auto. 2: apply Nat.le_lt_trans with k; auto with arith; apply Nat.lt_le_trans with N; auto. apply Sum_resp_leEq. rewrite (Nat.lt_succ_pred k m); auto with arith. apply Nat.lt_le_trans with N; auto. intros. apply Hk; apply Nat.le_trans with N; auto with arith. eapply leEq_transitive. apply leEq_AbsIR. apply AbsSmall_imp_AbsIR. apply HN; assumption. rename X into H1. elim (H _ (pos_div_two _ _ H1)). intros N HN; exists (S (Nat.max N k)). cut (N <= Nat.max N k); [ intro | apply Nat.le_max_l ]. cut (k <= Nat.max N k); [ intro | apply Nat.le_max_r ]. split. auto with arith. intros. rstepr (seq_part_sum y m[-]seq_part_sum y N[+] (seq_part_sum y N[-]seq_part_sum y (S (Nat.max N k)))). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply HN; apply Nat.le_trans with (Nat.max N k); auto with arith. apply AbsSmall_minus; apply HN; auto with arith. Qed. Lemma comparison : forall y, convergent y -> (forall n, AbsIR (x n) [<=] y n) -> convergent x. Proof. intros y H H0. apply str_comparison with y. assumption. exists 0; intros; apply H0. Qed. (** As a corollary, we get that every absolutely convergent series converges. *) Lemma abs_imp_conv : abs_convergent x -> convergent x. Proof. intros H. apply Convergence_Criteria.comparison with (fun n : nat => AbsIR (x n)). apply H. intro; apply leEq_reflexive. Qed. (** Next we have the ratio test, both as a positive and negative result. *) Lemma divergent_crit : {r : IR | [0] [<] r | forall n, {m : nat | n <= m | r [<=] AbsIR (x m)}} -> divergent x. Proof. intro H. elim H; clear H; intros r Hr H. exists r. assumption. intro. elim (H k); clear H; intros m Hm Hrm. exists (S m). exists m. split. auto. split. assumption. eapply leEq_wdr. apply Hrm. apply AbsIR_wd. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply seq_part_sum_n; auto with arith. apply Sum_one. Qed. Lemma tail_series : forall y, convergent y -> {k : nat | {N : nat | forall n, N <= n -> x n [=] y (n + k)}} -> convergent x. Proof. red in |- *. intros y H H0. elim H0; intros k Hk. elim Hk; intros N HN. clear Hk H0. red in |- *. intros e H0. elim (H (e [/]TwoNZ) (pos_div_two _ _ H0)); intros M HM. exists (S (Nat.max N M)); intros. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_wdr_unfolded with (seq_part_sum y (m + k) [-]seq_part_sum y (S (Nat.max N M) + k)). rstepr (seq_part_sum y (m + k) [-]seq_part_sum y M[+] (seq_part_sum y M[-]seq_part_sum y (S (Nat.max N M) + k))). apply AbsSmall_plus. apply HM. apply Nat.le_trans with (Nat.max N M); auto with arith. apply AbsSmall_minus. apply HM. auto with arith. unfold seq_part_sum in |- *. apply eq_transitive_unfolded with (Sum (S (Nat.max N M) + k) (pred (m + k)) y). unfold Sum, Sum1 in |- *. rewrite Nat.lt_succ_pred with (z := 0). algebra. apply Nat.lt_le_trans with (S (Nat.max N M)); auto with arith. astepr (Sum (S (Nat.max N M)) (pred m) x). 2: unfold Sum, Sum1 in |- *. 2: rewrite -> Nat.lt_succ_pred with (z := 0). 2: algebra. 2: apply Nat.lt_le_trans with (S (Nat.max N M)); auto with arith. replace (pred (m + k)) with (pred m + k). apply eq_symmetric_unfolded; apply Sum_big_shift. intros; apply HN. apply Nat.le_trans with (Nat.max N M); auto with arith. rewrite -> Nat.lt_succ_pred with (z := 0); auto. apply Nat.lt_le_trans with (S (Nat.max N M)); auto with arith. lia. Qed. Lemma join_series : convergent x -> forall y, {k : nat | {N : nat | forall n, N <= n -> x n [=] y (n + k)}} -> convergent y. Proof. red in |- *; intros H y H0. elim H0; intros k Hk. elim Hk; intros N HN. clear Hk H0. red in |- *; intros e H0. elim (H (e [/]TwoNZ) (pos_div_two _ _ H0)); intros M HM. exists (S (Nat.max N M + k)); intros. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_wdr_unfolded with (seq_part_sum x (m - k) [-]seq_part_sum x (S (Nat.max N M + k) - k)). rstepr (seq_part_sum x (m - k) [-]seq_part_sum x M[+] (seq_part_sum x M[-]seq_part_sum x (S (Nat.max N M + k) - k))). apply AbsSmall_plus. apply HM. apply (fun p n m : nat => Nat.add_le_mono_l n m p) with k. rewrite (Nat.add_comm k (m- k)). rewrite Nat.sub_add. apply Nat.le_trans with (Nat.max N M + k); auto with arith. rewrite Nat.add_comm; auto with arith. apply Nat.le_trans with (S (Nat.max N M + k)); auto with arith. apply AbsSmall_minus. apply HM. apply (fun p n m : nat => Nat.add_le_mono_l n m p) with k. rewrite (Nat.add_comm k (S (Nat.max N M + k) - k)). rewrite Nat.sub_add. apply Nat.le_trans with (Nat.max N M + k); auto. rewrite Nat.add_comm; auto with arith. apply Nat.le_trans with (S (Nat.max N M + k)); auto with arith. unfold seq_part_sum in |- *. apply eq_transitive_unfolded with (Sum (S (Nat.max N M + k) - k) (pred (m - k)) x). unfold Sum, Sum1 in |- *. rewrite Nat.lt_succ_pred with (z := 0). algebra. lia. astepr (Sum (S (Nat.max N M + k)) (pred m) y). 2: unfold Sum, Sum1 in |- *. 2: rewrite Nat.lt_succ_pred with (z := 0). 2: algebra. 2: lia. replace (pred m) with (pred (m - k) + k). 2: lia. pattern (S (Nat.max N M + k)) at 2 in |- *; replace (S (Nat.max N M + k)) with (S (Nat.max N M + k) - k + k). 2: lia. apply Sum_big_shift. intros; apply HN. apply Nat.le_trans with (Nat.max N M); auto with arith. lia. rewrite Nat.lt_succ_pred with (z := 0); auto. lia. apply Nat.lt_le_trans with (S (Nat.max N M)); auto with arith. lia. Qed. End Convergence_Criteria. Section More_CC. Variable x : nat -> IR. Lemma ratio_test_conv : {N : nat | {c : IR | c [<] [1] | [0] [<=] c /\ (forall n, N <= n -> AbsIR (x (S n)) [<=] c[*]AbsIR (x n))}} -> convergent x. Proof. intro H. elim H; clear H; intros N H. elim H; clear H; intros c Hc1 H. elim H; clear H; intros H0c H. cut (forall n : nat, N <= n -> AbsIR (x n) [<=] AbsIR (x N) [*]c[^] (n - N)). intro. apply str_comparison with (fun n : nat => AbsIR (x N) [*]c[^] (n - N)). 2: exists N; assumption. apply conv_series_mult_scal with (x := fun n : nat => c[^] (n - N)). apply join_series with (power_series c). apply power_series_conv. apply AbsIR_less. assumption. apply less_leEq_trans with [0]. rstepr ([--][0]:IR). apply inv_resp_less. apply pos_one. assumption. exists N. exists 0. intro. rewrite Nat.add_sub. algebra. simple induction n. intro. cut (N = 0); [ intro | auto with arith ]. rewrite H1. apply eq_imp_leEq. simpl in |- *; algebra. clear n; intros. cut ({N < S n} + {N = S n}). 2: apply le_lt_eq_dec; assumption. intro; inversion_clear H2. apply leEq_transitive with (c[*]AbsIR (x n)). apply H; auto with arith. rewrite Nat.sub_succ_l. astepr (AbsIR (x N) [*] (c[*]c[^] (n - N))). rstepr (c[*] (AbsIR (x N) [*]c[^] (n - N))). apply mult_resp_leEq_lft. apply H0; auto with arith. assumption. auto with arith. rewrite H3. rewrite Nat.sub_diag. apply eq_imp_leEq. simpl in |- *; algebra. Qed. Lemma ratio_test_div : {N : nat | {c : IR | [1] [<=] c | forall n, N <= n -> c[*]AbsIR (x n) [<] AbsIR (x (S n))}} -> divergent x. Proof. intros H. elim H; clear H; intros N H. elim H; clear H; intros c Hc Hn. apply divergent_crit. exists (AbsIR (x (S N))). apply leEq_less_trans with (c[*]AbsIR (x N)). astepl (c[*][0]); apply mult_resp_leEq_lft. apply AbsIR_nonneg. apply less_leEq; eapply less_leEq_trans; [ apply pos_one | assumption ]. apply Hn; auto with arith. cut (forall n : nat, S N <= n -> {m : nat | n <= m /\ AbsIR (x (S N)) [<=] AbsIR (x m)}). intro H. clear Hn. intro n. cut (S N <= Nat.max (S N) n); [ intro | apply Nat.le_max_l ]. elim (H _ H0); intros m Hm; elim Hm; clear H Hm; intros Hm H; exists m. apply Nat.le_trans with (Nat.max (S N) n); auto with arith. assumption. intros; exists n. split. auto. induction n as [| n Hrecn]. inversion H. clear Hrecn; induction n as [| n Hrecn]. inversion H. rewrite <- H1; apply eq_imp_leEq; algebra. inversion H1. elim (le_lt_eq_dec _ _ H); intro. apply leEq_transitive with (AbsIR (x (S n))). apply Hrecn; auto with arith. apply less_leEq; apply leEq_less_trans with (c[*]AbsIR (x (S n))). astepl ([1][*]AbsIR (x (S n))); apply mult_resp_leEq_rht. assumption. apply AbsIR_nonneg. apply Hn; auto with arith. rewrite b; apply eq_imp_leEq; algebra. Qed. End More_CC. Section Alternate_Series. (** ** Alternate Series Alternate series are a special case. Suppose that [x] is nonnegative and decreasing convergent to 0. *) Variable x : nat -> IR. Hypothesis pos_x : forall n : nat, [0] [<=] x n. Hypothesis Lim_x : Cauchy_Lim_prop2 x [0]. Hypothesis mon_x : forall n : nat, x (S n) [<=] x n. (* begin hide *) Let y (n : nat) := [--][1][^]n[*]x n. Let alternate_lemma1 : forall n m : nat, [--][1][^]n[*]Sum n (n + (m + m)) y [<=] x n. Proof. intros; induction m as [| m Hrecm]. cut (n = n + (0 + 0)); [ intro | auto with arith ]. rewrite <- H. apply eq_imp_leEq. cut (Sum n n y [=] y n); [ intro | apply Sum_one ]. astepl ( [--][1][^]n[*]y n). unfold y in |- *; simpl in |- *. apply eq_transitive_unfolded with ( [--]OneR[^] (n + n) [*]x n). astepl ( [--][1][^]n[*][--][1][^]n[*]x n). apply mult_wdl. apply nexp_plus. astepr ([1][*]x n). apply mult_wdl. apply inv_one_even_nexp. auto with arith. cut (n + (S m + S m) = S (S (n + (m + m)))); [ intro | simpl in |- *; repeat rewrite plus_n_Sm; auto ]. rewrite H. apply leEq_wdl with ( [--][1][^]n[*]Sum n (n + (m + m)) y[+] [--][1][^]n[*] (y (S (n + (m + m))) [+]y (S (S (n + (m + m)))))). apply leEq_transitive with (x n[+][--][1][^]n[*] (y (S (n + (m + m))) [+]y (S (S (n + (m + m)))))). apply plus_resp_leEq. apply Hrecm. apply shift_plus_leEq'; astepr ZeroR. unfold y in |- *. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply ring_dist_unfolded. apply leEq_wdl with ( [--] (x (S (n + (m + m)))) [+]x (S (S (n + (m + m))))). apply shift_plus_leEq'; rstepr (x (S (n + (m + m)))). apply mon_x. apply bin_op_wd_unfolded. rstepl ( [--][1][*]x (S (n + (m + m)))). rstepr ( [--][1][^]n[*][--][1][^]S (n + (m + m)) [*]x (S (n + (m + m)))). apply mult_wdl. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply nexp_plus. apply inv_one_odd_nexp. replace (n + S (n + (m + m))) with (2 * (n + m) + 1) by ring; now exists (n + m). astepl ([1][*]x (S (S (n + (m + m))))). rstepr ( [--][1][^]n[*][--][1][^]S (S (n + (m + m))) [*]x (S (S (n + (m + m))))). apply mult_wdl. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply nexp_plus. apply inv_one_even_nexp. replace (n + S (S (n + (m + m)))) with (2 * (S (n + m))) by ring; now exists (S (n + m)). unfold Sum in |- *; simpl in |- *. unfold Sum1 in |- *; simpl in |- *. rational. Qed. Let alternate_lemma2 : forall n m : nat, [--][1][^]n[*]Sum n (n + S (m + m)) y [<=] x n. Proof. intros. cut (n + S (m + m) = S (n + (m + m))); [ intro | auto with arith ]. rewrite H. apply leEq_wdl with ( [--][1][^]n[*]Sum n (n + (m + m)) y[+][--][1][^]n[*]y (S (n + (m + m)))). apply leEq_transitive with (x n[+][--][1][^]n[*]y (S (n + (m + m)))). apply plus_resp_leEq. apply alternate_lemma1. apply shift_plus_leEq'; rstepr (ZeroR[*]x (S (n + (m + m)))). unfold y in |- *. rstepl ( [--][1][^]n[*][--][1][^]S (n + (m + m)) [*]x (S (n + (m + m)))). apply mult_resp_leEq_rht. apply leEq_wdl with ( [--]OneR). astepr ( [--]ZeroR); apply less_leEq; apply inv_resp_less; apply pos_one. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. apply nexp_plus. apply inv_one_odd_nexp. replace (n + S (n + (m + m))) with (2 * (n + m) + 1) by ring; now exists (n + m). apply pos_x. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply ring_dist_unfolded. apply mult_wdr. unfold Sum in |- *; unfold Sum1 in |- *; simpl in |- *; rational. Qed. Let alternate_lemma3 : forall n m : nat, [0] [<=] [--][1][^]n[*]Sum n (n + S (m + m)) y. Proof. intros; induction m as [| m Hrecm]. cut (S n = n + S (0 + 0)); [ intro | rewrite <- plus_n_Sm; auto ]. rewrite <- H. cut (Sum n (S n) y [=] y n[+]y (S n)). intro; astepr ( [--][1][^]n[*] (y n[+]y (S n))). unfold y in |- *. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply ring_dist_unfolded. apply leEq_wdr with (x n[-]x (S n)). apply shift_leEq_minus; astepl (x (S n)). apply mon_x. unfold cg_minus in |- *; apply bin_op_wd_unfolded. astepl ([1][*]x n). astepr ( [--][1][^]n[*][--][1][^]n[*]x n). apply mult_wdl. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply nexp_plus. apply inv_one_even_nexp. auto with arith. rstepl ( [--][1][*]x (S n)). astepr ( [--][1][^]n[*][--][1][^]S n[*]x (S n)). apply mult_wdl. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply nexp_plus. apply inv_one_odd_nexp. replace (n + S n) with (2 * n + 1) by ring; now exists n. unfold Sum, Sum1 in |- *; simpl in |- *; rational. cut (n + S (S m + S m) = S (S (n + S (m + m)))); [ intro | simpl in |- *; repeat rewrite <- plus_n_Sm; auto with arith ]. rewrite H. apply leEq_wdr with ( [--][1][^]n[*] (Sum n (n + S (m + m)) y[+] (y (S (n + S (m + m))) [+]y (S (S (n + S (m + m))))))). eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply ring_dist_unfolded. astepl (ZeroR[+][0]). apply plus_resp_leEq_both. apply Hrecm. unfold y in |- *. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply ring_dist_unfolded. apply leEq_wdr with (x (S (n + S (m + m))) [-]x (S (S (n + S (m + m))))). apply shift_leEq_minus; astepl (x (S (S (n + S (m + m))))); apply mon_x. unfold cg_minus in |- *; apply bin_op_wd_unfolded. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply mult_assoc_unfolded. astepl ([1][*]x (S (n + S (m + m)))); apply mult_wdl. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded; [ apply nexp_plus | apply inv_one_even_nexp ]. replace (n + S (n + S (m + m))) with (2 * (n + m + 1)) by ring; now exists (n + m + 1). eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply mult_assoc_unfolded. rstepl ( [--][1][*]x (S (S (n + S (m + m))))); apply mult_wdl. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded; [ apply nexp_plus | apply inv_one_odd_nexp ]. replace (n + S (S (n + S (m + m)))) with (2 * (n + m + 1) + 1) by ring; now exists (n + m + 1). apply mult_wdr. unfold Sum, Sum1 in |- *; simpl in |- *; rational. Qed. Let alternate_lemma4 : forall n m : nat, [0] [<=] [--][1][^]n[*]Sum n (n + (m + m)) y. Proof. intros. case m. cut (n + (0 + 0) = n); [ intro | auto ]. rewrite H. cut (Sum n n y [=] y n); [ intro | apply Sum_one ]. astepr ( [--][1][^]n[*]y n). unfold y in |- *. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply mult_assoc_unfolded. astepl ([0][*]x n). apply mult_resp_leEq_rht. apply leEq_wdr with OneR. apply less_leEq; apply pos_one. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. apply nexp_plus. apply inv_one_even_nexp; auto with arith. apply pos_x. clear m; intro m. cut (n + (S m + S m) = S (n + S (m + m))); [ intro | simpl in |- *; rewrite <- plus_n_Sm; auto ]. rewrite H. apply leEq_wdr with ( [--][1][^]n[*]Sum n (n + S (m + m)) y[+] [--][1][^]n[*]y (S (n + S (m + m)))). apply leEq_transitive with ([0][+][--][1][^]n[*]y (S (n + S (m + m)))). astepr ( [--][1][^]n[*]y (S (n + S (m + m)))). unfold y in |- *. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply mult_assoc_unfolded. astepl ([0][*]x (S (n + S (m + m)))). apply mult_resp_leEq_rht. apply leEq_wdr with OneR. apply less_leEq; apply pos_one. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. apply nexp_plus. replace (n + S (n + S (m + m))) with (2 * (n + m + 1)) by ring. apply inv_one_even_nexp; now exists (n + m + 1). apply pos_x. apply plus_resp_leEq. apply alternate_lemma3. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply ring_dist_unfolded. apply mult_wdr. unfold Sum in |- *; unfold Sum1 in |- *; simpl in |- *; rational. Qed. (* end hide *) Lemma alternate_series_conv : convergent (fun n => [--][1][^]n[*]x n). Proof. red in |- *. red in |- *. intros e H. elim (Lim_x e H). intros N' HN'. cut {N : nat | 0 < N | forall m : nat, N <= m -> AbsSmall e (x m)}. intro H0. elim H0; clear H0; intros N HNm HN. exists N; intros. apply AbsSmall_transitive with (x N). apply HN; auto. cut (AbsIR (seq_part_sum (fun n : nat => [--][1][^]n[*]x n) m[-] seq_part_sum (fun n : nat => [--][1][^]n[*]x n) N) [=] AbsIR ( [--][1][^]N[*]Sum N (pred m) y)). intro. apply leEq_wdl with (AbsIR ( [--][1][^]N[*]Sum N (pred m) y)). eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x; apply pos_x. cut ({N < m} + {N = m}); intros. 2: apply le_lt_eq_dec; assumption. apply leEq_wdl with (Max ( [--][1][^]N[*]Sum N (pred m) y) [--] ( [--][1][^]N[*]Sum N (pred m) y)). apply Max_leEq. inversion_clear H2. cut {j : nat & {pred m = N + (j + j)} + {pred m = N + S (j + j)}}. 2: apply even_or_odd_plus_gt; apply le_2; auto. intro. elim H2; intros j Hj. clear H2; inversion_clear Hj. rewrite H2; apply alternate_lemma1. rewrite H2; apply alternate_lemma2. rewrite <- H3. cut (Sum N (pred N) y [=] [0]); [ intro | apply Sum_empty; auto ]. astepl ( [--][1][^]N[*]ZeroR). astepl ZeroR; apply pos_x. astepr ( [--][--] (x N)); apply inv_resp_leEq. apply leEq_transitive with ZeroR. astepr ( [--]ZeroR); apply inv_resp_leEq; apply pos_x. inversion_clear H2. cut {j : nat & {pred m = N + (j + j)} + {pred m = N + S (j + j)}}. 2: apply even_or_odd_plus_gt; apply le_2; auto. intro. elim H2; intros j Hj. clear H2; inversion_clear Hj. rewrite H2; apply alternate_lemma4. rewrite H2; apply alternate_lemma3. rewrite <- H3. cut (Sum N (pred N) y [=] [0]); [ intro | apply Sum_empty; auto ]. astepr ( [--][1][^]N[*]ZeroR). astepr ZeroR; apply leEq_reflexive. simpl in |- *; unfold ABSIR in |- *; apply eq_reflexive_unfolded. apply eq_symmetric_unfolded; assumption. destruct (Nat.Even_or_Odd N) as [HE | HO]. apply AbsIR_wd. eapply eq_transitive_unfolded. apply seq_part_sum_n; auto; apply Nat.lt_le_trans with N; auto. eapply eq_transitive_unfolded. 2: apply Sum_comm_scal'. apply Sum_wd. intro. unfold y in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply mult_assoc_unfolded. apply mult_wdl. astepl (OneR[*][--][1][^]i). apply mult_wdl. apply eq_symmetric_unfolded; apply inv_one_even_nexp; assumption. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply AbsIR_inv. apply AbsIR_wd. eapply eq_transitive_unfolded. apply seq_part_sum_n; auto; apply Nat.lt_le_trans with N; auto. rstepr ( [--] ( [--][1][^]N) [*]Sum N (pred m) y). eapply eq_transitive_unfolded. 2: apply Sum_comm_scal'. apply Sum_wd. intro. unfold y in |- *. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply mult_assoc_unfolded. apply mult_wdl. astepl (OneR[*][--][1][^]i). now apply mult_wdl; rewrite inv_one_odd_nexp, cg_inv_inv by assumption. exists (S N'); [exact (Nat.lt_0_succ _) |]. intros. astepr (x m[-][0]); apply HN'; auto with arith. Qed. End Alternate_Series. Section Important_Numbers. (** ** Important Numbers We end this chapter by defining two important numbers in mathematics: [pi] and $e$#e#, both as sums of convergent series. *) Definition e_series (n : nat) := [1][/] _[//]nring_fac_ap_zero IR n. Lemma e_series_conv : convergent e_series. Proof. apply ratio_test_conv. exists 1. exists (OneR [/]TwoNZ). apply pos_div_two'; apply pos_one. split. apply less_leEq; apply pos_div_two; apply pos_one. intros. unfold e_series in |- *. eapply leEq_wdr. 2: apply mult_commutes. eapply leEq_wdr. 2: apply AbsIR_mult_pos. 2: apply less_leEq; apply pos_div_two; apply pos_one. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. rstepr ([1][*][1][/] _[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (nring_fac_ap_zero _ n)). rstepr ([1][/] _[//] mult_resp_ap_zero _ _ _ (two_ap_zero IR) (nring_fac_ap_zero _ n)). apply recip_resp_leEq. astepl ((Two:IR) [*][0]); apply mult_resp_less_lft. apply pos_nring_fac. apply pos_two. cut (fact (S n) = S n * fact n). 2: simpl in |- *; auto with arith. intro. rewrite H0. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply nring_comm_mult. apply mult_resp_leEq_rht. apply nring_leEq; auto with arith. apply less_leEq; apply pos_nring_fac. apply less_leEq; apply mult_resp_pos; apply recip_resp_pos. apply pos_nring_fac. apply pos_two. apply less_leEq; apply recip_resp_pos; apply pos_nring_fac. Qed. Definition E := series_sum _ e_series_conv. Definition pi_series n := [--][1][^]n[*] ([1][/] _[//]Greater_imp_ap IR _ _ (pos_nring_S _ (n + n))). Lemma pi_series_conv : convergent pi_series. Proof. unfold pi_series in |- *. apply alternate_series_conv with (x := fun n : nat => [1][/] _[//]Greater_imp_ap IR _ _ (pos_nring_S _ (n + n))). intro; apply less_leEq. apply recip_resp_pos; apply pos_nring_S. apply Cauchy_Lim_prop3_prop2. red in |- *; intros. exists (S k); intros. apply AbsIR_imp_AbsSmall. apply less_leEq. apply less_wdl with ([1][/] _[//]Greater_imp_ap IR _ _ (pos_nring_S _ (m + m))). unfold one_div_succ, Snring in |- *. apply recip_resp_less. apply pos_nring_S. apply nring_less; auto with arith. apply eq_symmetric_unfolded. apply eq_transitive_unfolded with (AbsIR ([1][/] _[//]Greater_imp_ap IR _ _ (pos_nring_S _ (m + m)))). apply AbsIR_wd; algebra. apply AbsIR_eq_x; apply less_leEq. apply recip_resp_pos; apply pos_nring_S. intros. apply less_leEq; apply recip_resp_less. apply pos_nring_S. apply nring_less; simpl in |- *; rewrite <- plus_n_Sm; auto with arith. Qed. Definition pi := Four[*]series_sum _ pi_series_conv. End Important_Numbers. corn-8.20.0/reals/fast/000077500000000000000000000000001473720167500146215ustar00rootroot00000000000000corn-8.20.0/reals/fast/CRAlternatingSum.v000066400000000000000000001274171473720167500202060ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ArithRing. From Coq Require Import Bool. From Coq Require Import ZArith. From Coq Require Import Qpower Qabs. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRArith. Require Export CoRN.model.metric2.Qmetric. Require Import CoRN.reals.fast.LazyNat. Require Import CoRN.reals.fast.CRstreams. Require Export CoRN.metric2.Limit. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.classes.Qclasses. Require Import MathClasses.interfaces.abstract_algebra. Opaque CR. (** ** Computing Alternating Series. Alternating series are particularly nice to sum because each term is also a bound on the error of the partial sum. *) Section RationalStreamSum. Variable X : Type. (* The current rational value is part of the state. For example a^k/k! is used to produce a^(k+1)/(k+1)! by multiplying by a and dividing by k+1. *) Variable f : X*Q -> X*Q. Definition Str_pth (p : positive) (x:X*Q) : Q := snd (CRstreams.iterate _ f p x). (* Decreasing and alternating stream. *) Definition Str_alt_decr (x:X*Q) : Prop := forall p : positive, Qabs (Str_pth (Pos.succ p) x) <= Qabs (Str_pth p x) /\ (Str_pth (Pos.succ p) x)*(Str_pth p x) <= 0. Lemma Str_alt_decr_tl : forall x p, Str_alt_decr x -> Str_alt_decr (CRstreams.iterate _ f p x). Proof. assert (forall x, Str_alt_decr x -> Str_alt_decr (f x)). { intros x H p. specialize (H (Pos.succ p)). unfold Str_pth. unfold Str_pth in H. rewrite <- iterate_shift, <- iterate_succ. rewrite <- iterate_shift, <- iterate_succ. apply H. } intros x p. revert p x. apply (Pos.peano_ind (fun p => forall (x : X * Q), Str_alt_decr x → Str_alt_decr (CRstreams.iterate (X * Q) f p x))). - intros. simpl. apply H, H0. - intros. rewrite iterate_succ. apply H, H0, H1. Qed. Lemma Str_alt_even_step : forall p x, Str_alt_decr x -> 0 <= Str_pth p x * Str_pth (p+2) x. Proof. intros. pose proof (H p). pose proof (H (Pos.succ p)). destruct H0, H1. replace (p+2)%positive with (Pos.succ (Pos.succ p)). destruct (Str_pth p x). destruct (Str_pth (Pos.succ p) x). destruct (Str_pth (Pos.succ (Pos.succ p)) x). unfold Qmult, Qle; simpl. rewrite Z.mul_1_r. unfold Qmult, Qle in H2; simpl in H2. rewrite Z.mul_1_r in H2. unfold Qmult, Qle in H3; simpl in H3. rewrite Z.mul_1_r in H3. destruct Qnum, Qnum1; try discriminate. destruct Qnum0. exfalso; apply H1; reflexivity. exfalso; apply H2; reflexivity. exfalso; apply H3; reflexivity. destruct Qnum0. exfalso; apply H1; reflexivity. exfalso; apply H3; reflexivity. exfalso; apply H2; reflexivity. rewrite <- Pos.add_1_r, <- Pos.add_1_r. rewrite <- Pos.add_assoc. reflexivity. Qed. Lemma Str_alt_zero : forall p x, Str_alt_decr x -> Str_pth p x == 0 -> Str_pth (Pos.succ p) x == 0. Proof. intros. pose proof (H p) as [H1 _]. rewrite H0 in H1. apply Qabs_Qle_condition in H1. destruct H1. apply (Qle_antisym _ _ H2) in H1. exact H1. Qed. Lemma Str_alt_neg : forall p x, Str_alt_decr x -> 0 <= snd (f x) -> Str_pth (p~0) x <= 0. Proof. apply (Pos.peano_ind (fun p => forall (x : X * Q), Str_alt_decr x → 0 <= snd (f x) → Str_pth (p~0) x <= 0)). - intros. simpl. specialize (H xH). unfold Str_pth in H. simpl in H. destruct H. destruct (Q_dec (snd (f x)) 0). destruct s. exfalso; exact (Qlt_not_le _ _ q H0). rewrite <- (Qmult_0_l (snd (f x))) in H1. apply Qmult_le_r in H1. exact H1. exact q. rewrite q in H. exact (Qle_trans _ _ _ (Qle_Qabs _) H). - intros. pose proof (Str_alt_even_step (p~0) x H0). specialize (H x H0 H1). replace (p~0+2)%positive with ((Pos.succ p)~0)%positive in H2. apply Qnot_lt_le. intro abs. rewrite <- (Qmult_0_l (Str_pth ((Pos.succ p)~0) x)) in H2. apply Qmult_le_r in H2. 2: exact abs. apply (Qle_antisym _ _ H) in H2. clear H. apply (Str_alt_zero _ _ H0) in H2. apply (Str_alt_zero _ _ H0) in H2. rewrite <- Pos.double_succ in H2. rewrite H2 in abs. exact (Qlt_irrefl 0 abs). rewrite Pos.double_succ. rewrite <- Pos.add_1_r, <- Pos.add_1_r, <- Pos.add_assoc. reflexivity. Qed. Lemma Str_alt_pos : forall p x, Str_alt_decr x -> 0 <= snd (f x) -> 0 <= snd (CRstreams.iterate (X * Q) f p~1 x). Proof. intros. rewrite Pos.xI_succ_xO. pose proof (Str_alt_neg p x H H0). specialize (H (p~0))%positive. unfold Str_pth in H. destruct H. destruct (Q_dec 0 (snd (CRstreams.iterate (X * Q) f p~0 x))). destruct s. exfalso; exact (Qlt_not_le _ _ q H1). apply Qopp_le_compat in H2. change (-0)%Q with 0%Q in H2. setoid_replace (- (snd (CRstreams.iterate (X * Q) f (Pos.succ p~0) x) * snd (CRstreams.iterate (X * Q) f p~0 x)))%Q with ( (snd (CRstreams.iterate (X * Q) f (Pos.succ p~0) x) * -snd (CRstreams.iterate (X * Q) f p~0 x)))%Q in H2 by (unfold equiv, Q_eq; ring). rewrite <- (Qmult_0_l (-snd (CRstreams.iterate (X * Q) f p~0 x))) in H2. apply Qmult_le_r in H2. exact H2. rewrite <- (Qplus_0_l (- snd (CRstreams.iterate (X * Q) f p~0 x))). rewrite <- Qlt_minus_iff. exact q. rewrite <- q in H. apply Qabs_Qle_condition in H. apply H. Qed. Definition Limit_zero x (cvmod : Qpos -> positive) : Prop := forall q:Qpos, Qabs (Str_pth (cvmod q) x) <= proj1_sig q. Lemma Limit_zero_tl : forall x (cvmod : Qpos -> positive) (p : positive), Str_alt_decr x -> Limit_zero x cvmod -> Limit_zero (CRstreams.iterate _ f p x) (fun e => cvmod e - p)%positive. Proof. intros. intro e. unfold Str_pth. rewrite <- iterate_add. assert (forall q:positive, Qabs (snd (CRstreams.iterate (X * Q) f (q+cvmod e) x)) <= ` e). { apply Pos.peano_ind. - intros. rewrite Pos.add_1_l. apply (Qle_trans _ (Qabs (snd (CRstreams.iterate (X * Q) f (cvmod e) x)))). apply H. apply H0. - intros. rewrite <- Pos.add_1_l, <- Pos.add_assoc, Pos.add_1_l. refine (Qle_trans _ _ _ _ H1). apply H. } destruct (Pos.lt_total p (cvmod e)). 2: destruct H2. - rewrite Pos.sub_add. apply H0. exact H2. - subst p. rewrite Pos.sub_diag. apply H1. - rewrite Pos.sub_lt. 2: exact H2. replace (1+p)%positive with (1+(p-cvmod e)+cvmod e)%positive. apply H1. rewrite <- Pos.add_assoc. apply f_equal. rewrite Pos.sub_add. reflexivity. exact H2. Qed. Definition SumStream x (p : positive) (e : Qpos) : Q := snd (iterate_stop _ (fun y:X*Q*Q => let (z,r) := f (fst y) in (z, r, Qred (r + snd y))) (fun y:X*Q*Q => Qle_bool (Qabs (snd (fst y))) (proj1_sig e)) p (x, 0)). Lemma SumStream_fst : forall p z, fst (CRstreams.iterate _ (fun y:X*Q*Q => let (z,r) := f (fst y) in (z, r, r + snd y)) p z) ≡ CRstreams.iterate _ f p (fst z). Proof. apply (Pos.peano_ind (fun p => forall z : X * Q * Q, fst (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z0, r) := f (fst y) in (z0, r, r + snd y)) p z) ≡ CRstreams.iterate (X * Q) f p (fst z))). - intro z. simpl. destruct (f (fst z)); reflexivity. - intros. rewrite iterate_succ, H. rewrite iterate_succ. destruct (f (CRstreams.iterate (X * Q) f p (fst z))). reflexivity. Qed. Lemma SumStream_fst_red : forall p z, fst (CRstreams.iterate _ (fun y:X*Q*Q => let (z,r) := f (fst y) in (z, r, Qred (r + snd y))) p z) ≡ CRstreams.iterate _ f p (fst z). Proof. apply (Pos.peano_ind (fun p => forall z : X * Q * Q, fst (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z0, r) := f (fst y) in (z0, r, Qred (r + snd y))) p z) ≡ CRstreams.iterate (X * Q) f p (fst z))). - intro z. simpl. destruct (f (fst z)); reflexivity. - intros. rewrite iterate_succ, H. rewrite iterate_succ. destruct (f (CRstreams.iterate (X * Q) f p (fst z))). reflexivity. Qed. Lemma SumStream_red : forall (p:positive) z, snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) p z) == snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p z). Proof. apply (Pos.peano_ind (fun p => forall z, snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) p z) == snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p z))). - intros. rewrite iterate_one, iterate_one. destruct (f (fst z)). apply Qred_correct. - intros. rewrite iterate_succ, SumStream_fst_red. rewrite iterate_succ, SumStream_fst. destruct (f (CRstreams.iterate (X * Q) f p (fst z))). unfold snd at 1 4. rewrite Qred_correct. rewrite H. reflexivity. Qed. Lemma SumStream_init : forall (p:positive) z (r:Q), snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p (z, r)) == r + snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p (z, 0)). Proof. apply (Pos.peano_ind (fun p => forall (z : X * Q) (r : Q), snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p (z, r)) == r + snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p (z, 0)))). - intros. rewrite iterate_one, iterate_one. unfold fst. destruct (f z). unfold snd. rewrite Qplus_0_r. apply Qplus_comm. - intros. rewrite iterate_succ, SumStream_fst. rewrite iterate_succ, SumStream_fst. change (fst (z,r)) with z. change (fst (z,0)) with z. destruct (f (CRstreams.iterate (X * Q) f p z)). unfold snd at 1 4. rewrite H. rewrite (Qplus_comm q), <- Qplus_assoc. rewrite <- (Qplus_comm q). reflexivity. Qed. Lemma SumStream_assoc : forall x (p q : positive), snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (p+q) (x,0)) == snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p (x,0)) + snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) q (CRstreams.iterate _ f p x, 0)). Proof. intros x p. revert p x. apply (Pos.peano_ind (fun p => forall x q, snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (p + q) (x, 0)) == snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p (x, 0)) + snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) q (CRstreams.iterate _ f p x, 0)))). - intros x q. rewrite Pos.add_comm, iterate_add. simpl. destruct (f x) as [z r0]. rewrite SumStream_init. reflexivity. - intros. rewrite <- Pos.add_1_r, <- Pos.add_assoc, Pos.add_1_l. rewrite H, H. simpl. rewrite <- Qplus_assoc. apply Qplus_comp. reflexivity. clear H. rewrite iterate_add. simpl. rewrite <- iterate_shift. rewrite <- Pos.add_1_r, iterate_add. simpl. destruct (f (CRstreams.iterate (X * Q) f p x)). simpl. rewrite SumStream_init. reflexivity. Qed. (* Using AltSumF_stop is faster than AltSumF. *) Definition AltSeries_raw x (cvmod : Qpos -> positive) (e : QposInf) : Q := match e with | Qpos2QposInf d => SumStream x (cvmod d) d | QposInfinity => 0 end. Lemma AltSeries_small_pos_even : forall p x, Str_alt_decr x -> 0 <= snd (f x) -> 0 <= snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (p~0) (x, 0)). Proof. (* Sum of positive terms. *) assert (forall x, Str_alt_decr x -> 0 <= snd (f x) -> 0 <= snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (1 + 1) (x, 0))). { intros. pose proof (Str_alt_neg 1 x H H0) as H1. unfold Str_pth in H1. simpl in H1. specialize (H xH). simpl. unfold Str_pth in H. simpl in H. destruct (f x); simpl. simpl in H. unfold snd in H0. destruct (f (x0,q)); simpl. rewrite Qplus_0_r. simpl in H. unfold snd in H1. destruct H. rewrite Qabs_neg in H. 2: exact H1. rewrite Qabs_pos in H. 2: exact H0. apply Qle_minus_iff in H. rewrite Qopp_involutive, Qplus_comm in H. exact H. } apply (Pos.peano_ind (fun p => forall x, Str_alt_decr x -> 0 <= snd (f x) -> 0 <= snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (p~0) (x, 0)))). - intros. exact (H x H0 H1). - intros. rewrite <- Qplus_0_r. rewrite Pos.double_succ, <- Pos.add_1_l, <- Pos.add_1_l. rewrite Pos.add_assoc, SumStream_assoc. apply Qplus_le_compat. exact (H x H1 H2). apply H0. exact (Str_alt_decr_tl x 2 H1). rewrite <- iterate_succ. exact (Str_alt_pos _ x H1 H2). Qed. Lemma AltSeries_small_neg_even : forall p x, Str_alt_decr x -> snd (f x) <= 0 -> snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (p~0) (x, 0)) <= 0. Proof. (* Sum of negative terms. *) assert (forall x, Str_alt_decr x -> snd (f x) <= 0 -> snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (1 + 1) (x, 0)) <= 0). { intros. specialize (H xH). simpl. unfold Str_pth in H. simpl in H. destruct (f x); simpl. simpl in H. unfold snd in H0. destruct (f (x0,q)); simpl. rewrite Qplus_0_r. simpl in H. destruct H. apply (Qplus_le_l _ _ (-q)). rewrite <- Qplus_assoc, Qplus_opp_r, Qplus_0_r. apply (Qle_trans _ _ _ (Qle_Qabs _)). apply (Qle_trans _ _ _ H). rewrite Qplus_0_l, Qabs_neg. apply Qle_refl. exact H0. } apply (Pos.peano_ind (fun p => forall x, Str_alt_decr x -> snd (f x) <= 0 -> snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) (p~0) (x, 0)) <= 0)). - intros. exact (H x H0 H1). - intros. rewrite <- (Qplus_0_r 0). rewrite Pos.double_succ, <- Pos.add_1_l, <- Pos.add_1_l. rewrite Pos.add_assoc, SumStream_assoc. apply Qplus_le_compat. exact (H x H1 H2). apply H0. exact (Str_alt_decr_tl x 2 H1). simpl. pose proof (Str_alt_even_step 1 x H1). unfold Str_pth in H3. simpl in H3. apply Qnot_lt_le. intro abs. rewrite <- (Qmult_0_l (snd (f (f (f x))))) in H3. apply Qmult_le_r in H3. 2: exact abs. apply (Qle_antisym _ _ H2) in H3. clear H2. apply (Str_alt_zero 1 _ H1) in H3. apply (Str_alt_zero 2 _ H1) in H3. unfold Str_pth in H3. simpl in H3. rewrite H3 in abs. exact (Qlt_irrefl 0 abs). Qed. Lemma AltSeries_small_pos : forall x (p : positive), Str_alt_decr x -> 0 <= snd (f x) -> 0 <= snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p (x, 0)) <= snd (f x). Proof. (* This truncated sum starts at 0, and oscillates around 0 while staying in [-e,e]. *) (* TODO remove induction. *) intros x p. revert p x. apply (Pos.peano_ind (fun p => forall x, Str_alt_decr x -> 0 <= snd (f x) -> 0 <= snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p (x, 0)) <= snd (f x))). - intros. simpl. destruct (f x). simpl. rewrite Qplus_0_r. split. exact H0. apply Qle_refl. - intros. destruct p. + split. rewrite Pos.xI_succ_xO, <- Pos.double_succ. exact (AltSeries_small_pos_even _ x H0 H1). rewrite <- Pos.add_1_r. rewrite SumStream_assoc, iterate_one. specialize (H x H0 H1) as [_ H]. apply (Qle_trans _ (snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p~1 (x, 0)) + 0)). 2: rewrite Qplus_0_r; exact H. apply Qplus_le_r. unfold fst. apply (Qle_trans _ (snd (f (CRstreams.iterate (X * Q) f p~1 x)))). destruct (f (CRstreams.iterate (X * Q) f p~1 x)). simpl. rewrite Qplus_0_r. apply Qle_refl. rewrite <- iterate_succ. pose proof (Str_alt_neg (Pos.succ p) x H0 H1). specialize (H0 (p~1)%positive) as [_ H0]. unfold Str_pth in H0. exact H2. + split. rewrite <- Pos.add_1_r. rewrite SumStream_assoc, iterate_one. rewrite <- (Qplus_0_r 0). apply Qplus_le_compat. exact (AltSeries_small_pos_even _ x H0 H1). apply (Qle_trans _ (snd (f (CRstreams.iterate (X * Q) f p~0 x)))). rewrite <- iterate_succ, <- Pos.xI_succ_xO. exact (Str_alt_pos _ x H0 H1). unfold fst. destruct (f (CRstreams.iterate (X * Q) f p~0 x)). simpl. rewrite Qplus_0_r. apply Qle_refl. rewrite <- Pos.add_1_l, SumStream_assoc, iterate_one. simpl (fst (x,0)). rewrite <- (Qplus_0_r (snd (f x))). setoid_replace (snd (let (z, r0) := f x in (z, r0, r0 + snd (x, 0)))) with (snd (f x)) by (destruct (f x); apply Qplus_0_r). apply Qplus_le_r. apply AltSeries_small_neg_even. apply (Str_alt_decr_tl x _ H0). rewrite <- iterate_succ. apply (Str_alt_neg _ x H0 H1). + pose proof (Str_alt_neg 1 x H0 H1) as sndNeg. unfold Str_pth in sndNeg. simpl in sndNeg. specialize (H0 xH). unfold Str_pth in H0. simpl in H0. simpl. destruct (f x). simpl. simpl in H0. unfold snd in H1. destruct (f (x0,q)). simpl. simpl in H0. rewrite Qplus_0_r. destruct H0. rewrite (Qabs_pos q) in H0. 2: exact H1. unfold snd in sndNeg. split. rewrite Qabs_neg in H0. 2: exact sndNeg. rewrite Qle_minus_iff, Qopp_involutive, Qplus_comm in H0. exact H0. apply (Qle_trans _ (0 + q)). apply Qplus_le_l. exact sndNeg. rewrite Qplus_0_l. apply Qle_refl. Qed. Lemma AltSeries_small : forall x (p : positive), Str_alt_decr x -> Qabs (snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p (x, 0))) <= Qabs (snd (f x)). Proof. intros. destruct (Qlt_le_dec (snd (f x)) 0). - apply (Pos.peano_case (fun p => Qabs (snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z, r0) := f (fst y) in (z, r0, r0 + snd y)) p (x, 0))) <= Qabs (snd (f x)))). + simpl. destruct (f x). unfold snd. rewrite Qplus_0_r. apply Qle_refl. + assert (0 <= snd (f (f x))) as sndPos. { specialize (H xH) as [_ H]. unfold Str_pth in H. simpl in H. rewrite <- (Qmult_0_l (-snd (f x))) in H. setoid_replace (snd (f (f x)) * snd (f x))%Q with (-snd (f (f x)) * -snd (f x))%Q in H. apply Qmult_le_r in H. apply (Qopp_le_compat _ 0) in H. rewrite Qopp_involutive in H. exact H. apply (Qplus_lt_l _ _ (snd (f x))). ring_simplify. exact q. unfold equiv, Q_eq. simpl. ring. } intro n. rewrite <- Pos.add_1_l, SumStream_assoc, iterate_one. setoid_replace (snd (let (z, r0) := f (fst (x, 0)) in (z, r0, r0 + snd (x, 0)))) with (snd (f x)) by (simpl; destruct (f x); apply Qplus_0_r). rewrite Qabs_neg, Qabs_neg. apply Qopp_le_compat. rewrite <- (Qplus_0_r (snd (f x))) at 1. apply Qplus_le_r. apply AltSeries_small_pos. exact (Str_alt_decr_tl x _ H). exact sndPos. apply Qlt_le_weak, q. apply (Qle_trans _ (snd (f x) + snd (f (f x)))). apply Qplus_le_r. apply AltSeries_small_pos. exact (Str_alt_decr_tl x 1 H). exact sndPos. specialize (H xH) as [H _]. unfold Str_pth in H. simpl in H. rewrite (Qabs_pos _ sndPos) in H. rewrite Qabs_neg in H. apply (Qplus_le_r _ _ (snd (f x))) in H. rewrite Qplus_opp_r in H. exact H. apply Qlt_le_weak, q. - pose proof (AltSeries_small_pos x p H q). rewrite (Qabs_pos (snd (f x)) q). rewrite Qabs_pos. apply H0. apply H0. Qed. Lemma AltSeries_further : forall x (p q : positive) (d1 d2 ε1 ε2 : Qpos), Str_alt_decr x -> Qabs (Str_pth p x) <= proj1_sig ε1 -> Qabs (Str_pth q x) <= proj1_sig ε2 -> proj1_sig d1 <= proj1_sig ε1 -> proj1_sig d2 <= proj1_sig ε2 -> Qball (proj1_sig ε1 + proj1_sig ε2) (SumStream x p d1) (SumStream x q d2). Proof. (* Because the stopping conditions are satisfied at p and q, those positive bounds are useless and the sums will stop at prior indices where the terms are less than ε1 and ε2. *) intros. unfold SumStream. (* Replace p by its stopping index r. *) pose proof (iterate_stop_correct _ (fun y : X * Q * Q => let (z, r) := f (fst y) in (z, r, Qred (r + snd y))) (fun y : X * Q * Q => Qle_bool (Qabs (snd (fst y))) (` d1)) p (x,0)) as [r [req [_ H4]]]. rewrite req. clear req. assert (Qabs (Str_pth r x) <= proj1_sig ε1) as rstop. { destruct H4. rewrite <- H4. exact H0. destruct H4. rewrite SumStream_fst_red in H5. unfold fst in H5. apply Qle_bool_iff in H5. exact (Qle_trans _ _ _ H5 H2). } clear H4 H2 d1 H0 p. rewrite SumStream_red. (* Replace q by its stopping index s. *) pose proof (iterate_stop_correct _ (fun y : X * Q * Q => let (z, r) := f (fst y) in (z, r, Qred (r + snd y))) (fun y : X * Q * Q => Qle_bool (Qabs (snd (fst y))) (` d2)) q (x,0)) as [s [seq [_ H2]]]. rewrite seq. clear seq. assert (Qabs (Str_pth s x) <= proj1_sig ε2) as sstop. { destruct H2. rewrite <- H0. exact H1. destruct H0. rewrite SumStream_fst_red in H2. unfold fst in H2. apply Qle_bool_iff in H2. exact (Qle_trans _ _ _ H2 H3). } clear H2 H3 d2 H1 q. rewrite SumStream_red. destruct (Pos.lt_total r s). - (* r < s *) unfold Qball. rewrite <- (Pplus_minus s r). 2: apply Pos.lt_gt, H0. apply AbsSmall_Qabs. rewrite (SumStream_assoc x r (s-r)). unfold Qminus. assert (forall a b : Q, -(a+b) == -a+-b). { intros. ring. } rewrite H1, Qplus_assoc, Qplus_opp_r, Qplus_0_l. clear H1. rewrite Qabs_opp. refine (Qle_trans _ _ _ (AltSeries_small _ _ _) _). apply Str_alt_decr_tl, H. rewrite <- iterate_succ. destruct (H r). apply (Qle_trans _ _ _ H1). apply (Qle_trans _ (` ε1 + 0)). rewrite Qplus_0_r. exact rstop. apply Qplus_le_r, Qpos_nonneg. - destruct H0. rewrite H0. apply ball_refl, (Qpos_nonneg (ε1 + ε2)). (* Now s < r. *) unfold Qball. rewrite <- (Pplus_minus r s). 2: apply Pos.lt_gt, H0. apply AbsSmall_Qabs. rewrite (SumStream_assoc x s (r-s)). rewrite Qplus_comm. unfold Qminus. rewrite <- Qplus_assoc, Qplus_opp_r, Qplus_0_r. refine (Qle_trans _ _ _ (AltSeries_small _ _ _) _). apply Str_alt_decr_tl, H. rewrite <- iterate_succ. destruct (H s). apply (Qle_trans _ _ _ H1). apply (Qle_trans _ (0 + ` ε2)). rewrite Qplus_0_l. exact sstop. apply Qplus_le_l, Qpos_nonneg. Qed. Lemma AltSeries_raw_prf : forall x cvmod, Str_alt_decr x -> Limit_zero x cvmod -> is_RegularFunction Qball (AltSeries_raw x cvmod). Proof. intros x cvmod decr lz ε1 ε2. apply AltSeries_further. exact decr. apply lz. apply lz. apply Qle_refl. apply Qle_refl. Qed. Definition AltSeries (x:X*Q) cvmod (decr : Str_alt_decr x) lz : CR := Build_RegularFunction (AltSeries_raw_prf x cvmod decr lz). Lemma SumStream_shift : forall p x e, ` e < Qabs (snd (f x)) -> snd (f x) + SumStream (f x) p e == SumStream x (Pos.succ p) e. Proof. intros. unfold SumStream. pose proof (iterate_stop_correct _ (fun y : X * Q * Q => let (z, r) := f (fst y) in (z, r, Qred (r + snd y))) (fun y : X * Q * Q => Qle_bool (Qabs (snd (fst y))) (` e)) p (f x,0)) as [s [seq [H0 H1]]]. rewrite seq, SumStream_red. pose proof (SumStream_assoc x 1 s) as H2. rewrite iterate_one, iterate_one in H2. setoid_replace (snd (f x)) with (snd (let (z, r0) := f (fst (x, 0)) in (z, r0, r0 + snd (x, 0)))) by (simpl; destruct (f x); simpl; rewrite Qplus_0_r; reflexivity). rewrite <- H2. clear H2. rewrite Pos.add_1_l. pose proof (iterate_stop_correct _ (fun y : X * Q * Q => let (z, r) := f (fst y) in (z, r, Qred (r + snd y))) (fun y : X * Q * Q => Qle_bool (Qabs (snd (fst y))) (` e)) (Pos.succ p) (x,0)) as [r [req [H2 H3]]]. rewrite req, SumStream_red. clear req seq. assert (r ≢ 1%positive) as rone. { intro abs. clear H2 H0 H1. subst r. destruct H3. pose proof (Pos.lt_1_succ p). rewrite H0 in H1. inversion H1. destruct H0. rewrite SumStream_fst_red in H1. simpl in H1. apply Qle_bool_iff in H1. exact (Qlt_not_le _ _ H H1). } destruct H1 as [finish|stop]. - subst s. destruct H3. subst r. reflexivity. exfalso. destruct H1. apply Qle_bool_iff in H3. (* 1 < r by hypothesis. *) rewrite SumStream_fst_red in H3. unfold fst in H3. rewrite <- (Pos.succ_pred r) in H1. 2: exact rone. apply Pos.succ_lt_mono in H1. specialize (H0 (Pos.pred r) H1). rewrite SumStream_fst_red in H0. unfold fst in H0. rewrite <- iterate_shift, <- iterate_succ, Pos.succ_pred in H0. apply Qle_bool_iff in H3. rewrite H0 in H3. discriminate. exact rone. - destruct stop. rewrite SumStream_fst_red in H4. unfold fst in H4. rewrite <- iterate_shift, <- iterate_succ in H4. destruct H3. exfalso. subst r. apply Pos.succ_lt_mono in H1. specialize (H2 (Pos.succ s) H1). rewrite SumStream_fst_red in H2. unfold fst in H2. rewrite H4 in H2. discriminate. destruct (Pos.lt_total r (Pos.succ s)). exfalso. destruct H3. rewrite SumStream_fst_red in H6. unfold fst in H6. rewrite <- (Pos.succ_pred r) in H5. 2: exact rone. apply Pos.succ_lt_mono in H5. specialize (H0 _ H5). rewrite SumStream_fst_red in H0. unfold fst in H0. rewrite <- iterate_shift, <- iterate_succ, Pos.succ_pred in H0. rewrite H0 in H6. discriminate. exact rone. destruct H5. rewrite H5. reflexivity. exfalso. specialize (H2 (Pos.succ s) H5). rewrite SumStream_fst_red in H2. unfold fst in H2. rewrite H4 in H2. discriminate. Qed. (* AltSeries makes an infinite sum in the real numbers. *) Lemma AltSeries_shift : forall x cvmod decr lz, (AltSeries x cvmod decr lz == '(snd (f x)) + AltSeries (f x) _ (Str_alt_decr_tl x 1 decr) (Limit_zero_tl x cvmod 1 decr lz))%CR. Proof. intros. rewrite -> CRplus_translate. apply regFunEq_equiv, regFunEq_e. intros e. simpl. rewrite <- Pos.pred_sub. destruct (Qlt_le_dec (proj1_sig e) (Qabs (snd (f x)))). - (* The sum recombines after f x. *) rewrite SumStream_shift. 2: exact q. specialize (lz e). revert lz. generalize (cvmod e). apply (Pos.peano_case (fun p => Qabs (Str_pth p x) <= ` e → Qball (` e + ` e) (SumStream x p e) (SumStream x (Pos.succ (Pos.pred p)) e))). + intros. exfalso. unfold Str_pth in H. simpl in H. exact (Qlt_not_le _ _ q H). + intros. rewrite Pos.pred_succ. apply ball_refl. apply (Qpos_nonneg (e+e)). - (* The sum stops at f x. *) unfold SumStream. rewrite (iterate_stop_indep _ _ _ (cvmod e) 1). rewrite (iterate_stop_indep _ _ _ (Pos.pred (cvmod e)) 1). + rewrite iterate_stop_one, iterate_stop_one. unfold fst. setoid_replace (snd (let (z, r) := f x in (z, r, Qred (r + snd (x, 0))))) with (snd (f x)) by (destruct (f x); unfold snd; rewrite Qred_correct; apply Qplus_0_r). setoid_replace (snd (let (z, r) := f (f x) in (z, r, Qred (r + snd (x, 0))))) with (snd (f (f x))) by (destruct (f (f x)); unfold snd; rewrite Qred_correct; apply Qplus_0_r). apply AbsSmall_Qabs. rewrite Qabs_Qminus. unfold Qminus. rewrite (Qplus_comm (snd (f x))), <- Qplus_assoc. rewrite Qplus_opp_r, Qplus_0_r. specialize (decr xH) as [decr _]. apply (Qle_trans _ _ _ decr). apply (Qle_trans _ (proj1_sig e + 0)). rewrite Qplus_0_r. exact q. apply Qplus_le_r, Qpos_nonneg. + rewrite SumStream_fst_red. unfold fst. apply Qle_bool_iff. rewrite <- iterate_shift, <- iterate_succ. specialize (lz e). revert lz. generalize (cvmod e). apply (Pos.peano_case (fun p => Qabs (Str_pth p x) <= ` e → Qabs (snd (CRstreams.iterate (X * Q) f (Pos.succ (Pos.pred p)) x)) <= ` e)). intros _. simpl. specialize (decr xH) as [decr _]. unfold Str_pth in decr. simpl in decr. apply (Qle_trans _ _ _ decr q). intros. rewrite Pos.pred_succ. apply H. + rewrite SumStream_fst_red. unfold fst. simpl. apply Qle_bool_iff. specialize (decr xH) as [decr _]. apply (Qle_trans _ _ _ decr). exact q. + rewrite SumStream_fst_red. unfold fst. apply Qle_bool_iff. apply lz. + rewrite SumStream_fst_red. unfold fst. apply Qle_bool_iff. exact q. Qed. End RationalStreamSum. Lemma Str_alt_decr_pos : forall (X:Type) (f : X*Q->X*Q) x (fdecr : Str_alt_decr X f x) (n:nat), 0 <= Str_pth _ f 1 x -> 0 <= (-1)^Z.of_nat n * Str_pth X f (Pos.of_nat (S n)) x. Proof. intros X f x fdecr. induction n. - intros. simpl. rewrite Qmult_1_l. exact H. - intro H. specialize (IHn H). specialize (fdecr (Pos.of_nat (S n))). rewrite Nat2Pos.inj_succ. 2: discriminate. destruct (Str_pth X f (Pos.of_nat (S n)) x) as [p q]. destruct p as [|p|p]. + destruct fdecr. setoid_replace (Qabs (0#q)) with 0%Q in H0 by reflexivity. apply Qabs_Qle_condition in H0. change (-0) with 0 in H0. setoid_replace (Str_pth X f (Pos.succ (Pos.of_nat (S n))) x) with 0%Q. rewrite Qmult_0_r. apply Qle_refl. apply Qle_antisym; apply H0. + destruct fdecr. clear H0. rewrite <- (Qmult_0_l (Z.pos p # q)) in H1. rewrite Qmult_le_r in H1. 2: reflexivity. rewrite <- (Qmult_0_l (Z.pos p # q)) in IHn. rewrite Qmult_le_r in IHn. 2: reflexivity. change (S n) with (1+n)%nat. rewrite (Nat2Z.inj_add 1 n). rewrite Qpower_plus. simpl ((-1)^Z.of_nat 1). rewrite (Qmult_comm (-1)). rewrite <- Qmult_assoc. rewrite Qmult_comm, <- (Qmult_0_l ((-1)^Z.of_nat n)). apply Qmult_le_compat_r. 2: exact IHn. change (S n) with (1+n)%nat in H1. destruct (Str_pth X f (Pos.succ (Pos.of_nat (1+ n))) x). destruct Qnum. apply Z.le_refl. unfold Qle, Z.le in H1. simpl in H1. exfalso; apply H1; reflexivity. discriminate. intro abs. discriminate. + destruct fdecr. clear H0. assert ((Z.neg p # q) == (-1) * (Z.pos p#q)) by reflexivity. rewrite H0, Qmult_assoc in H1. rewrite H0, Qmult_assoc in IHn. rewrite <- (Qmult_0_l (Z.pos p # q)) in H1. rewrite Qmult_le_r in H1. 2: reflexivity. rewrite <- (Qmult_0_l (Z.pos p # q)) in IHn. rewrite Qmult_le_r in IHn. 2: reflexivity. change (S n) with (1+n)%nat. rewrite (Nat2Z.inj_add 1 n). rewrite Qpower_plus. simpl ((-1)^Z.of_nat 1%nat). rewrite (Qmult_comm (-1)). rewrite (Qmult_comm ((-1) ^ Z.of_nat n * -1)). rewrite <- (Qmult_0_l ((-1) ^ Z.of_nat n * -1)). apply Qmult_le_compat_r. 2: exact IHn. change (S n) with (1+n)%nat in H1. destruct (Str_pth X f (Pos.succ (Pos.of_nat (1+ n))) x). destruct Qnum. apply Z.le_refl. discriminate. unfold Qle, Z.le in H1. simpl in H1. exfalso; apply H1; reflexivity. discriminate. Qed. Lemma CRstream_opp_decr : forall (X:Type) (f : X*Q->X*Q) x, Str_alt_decr X f x -> Str_alt_decr X (CRstreams.CRstream_opp X f) (let (y, r) := x in (y, - r)). Proof. intros X f x H p. specialize (H p). pose proof (CRstreams.CRstream_opp_pth X f x p). pose proof (CRstreams.CRstream_opp_pth X f x (Pos.succ p)). unfold Str_pth. unfold Str_pth in H. destruct x as [x q]. unfold negate, Q_opp. destruct (CRstreams.iterate _ f p (x,q)). destruct (CRstreams.iterate _ f (Pos.succ p) (x,q)). unfold snd in H. destruct (CRstreams.iterate _ (CRstreams.CRstream_opp X f) (Pos.succ p) (x, (-q)%Q)). destruct (CRstreams.iterate _ (CRstreams.CRstream_opp X f) p (x, (-q)%Q)). unfold snd. destruct H1. subst q2. subst x2. destruct H0. subst q3. subst x3. destruct H. split. - rewrite Qabs_opp, Qabs_opp. exact H. - setoid_replace (- q1 * - q0)%Q with (q1*q0)%Q. exact H0. unfold equiv, Q_eq. ring. Qed. Lemma CRstream_opp_limit_zero : forall (X:Type) (f : X*Q->X*Q) x cvmod, Limit_zero X f x cvmod -> Limit_zero X (CRstreams.CRstream_opp X f) (let (y, r) := x in (y, - r)) cvmod. Proof. intros. intro e. specialize (H e). pose proof (CRstreams.CRstream_opp_pth X f x (cvmod e)). unfold Str_pth. unfold Str_pth in H. destruct (CRstreams.iterate (X * Q) f (cvmod e) x) as [y r]. destruct x as [x q]. unfold negate, Q_opp. destruct (CRstreams.iterate (X * Q) (CRstream_opp X f) (cvmod e) (x, (- q)%Q)). unfold snd. unfold snd in H. destruct H0. subst q0. rewrite Qabs_opp. exact H. Qed. Lemma SumStream_wd : forall (p:positive) (X Y:Type) (f : X*Q -> X*Q) (g : Y*Q -> Y*Q) (x : X*Q) (y : Y*Q), (forall p:positive, Str_pth _ f p x == Str_pth _ g p y) -> snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p (x,0)) == snd (CRstreams.iterate _ (fun y : Y * Q * Q => let (z0, r1) := g (fst y) in (z0, r1, r1 + snd y)) p (y,0)). Proof. apply (Pos.peano_ind (fun p => forall (X Y:Type) (f : X*Q -> X*Q) (g : Y*Q -> Y*Q) (x : X*Q) (y : Y*Q), (forall p:positive, Str_pth _ f p x == Str_pth _ g p y) -> snd (CRstreams.iterate _ (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, r1 + snd y)) p (x,0)) == snd (CRstreams.iterate _ (fun y : Y * Q * Q => let (z0, r1) := g (fst y) in (z0, r1, r1 + snd y)) p (y,0)))). - intros. simpl. specialize (H xH). unfold Str_pth in H. simpl in H. destruct (f x), (g y). simpl. simpl in H. rewrite H. reflexivity. - intros. pose proof (H0 (Pos.succ p)). unfold Str_pth in H1. rewrite iterate_succ, iterate_succ in H1. rewrite iterate_succ, iterate_succ, SumStream_fst, SumStream_fst. unfold fst. destruct (f (CRstreams.iterate (X * Q) f p x)). unfold snd at 1. destruct (g (CRstreams.iterate (Y * Q) g p y)). unfold snd at 3. specialize (H X Y f g x y H0). rewrite H. simpl in H1. rewrite H1. reflexivity. Qed. Lemma AltSeries_wd : forall (X Y:Type) (f : X*Q -> X*Q) (g : Y*Q -> Y*Q) (x : X*Q) (y : Y*Q) cvmod ccvmod (fdecr : Str_alt_decr X f x) (gdecr : Str_alt_decr Y g y) (flz : Limit_zero X f x cvmod) (glz : Limit_zero Y g y ccvmod), (forall p:positive, Str_pth _ f p x == Str_pth _ g p y) -> (forall e, cvmod e ≡ ccvmod e) -> (AltSeries X f x cvmod fdecr flz == AltSeries Y g y ccvmod gdecr glz)%CR. Proof. intros. apply regFunEq_equiv, regFunEq_e. intros e. simpl. setoid_replace (SumStream X f x (cvmod e) e) with (SumStream Y g y (cvmod e) e). rewrite H0. apply ball_refl. apply (Qpos_nonneg (e+e)). unfold SumStream. destruct (iterate_stop_correct _ (fun y0 : X * Q * Q => let (z, r) := f (fst y0) in (z, r, Qred (r + snd y0))) (fun y0 : X * Q * Q => Qle_bool (Qabs (snd (fst y0))) (` e)) (cvmod e) (x,0)) as [q [qeq [H1 H2]]]. rewrite qeq, SumStream_red. clear qeq. destruct (iterate_stop_correct _ (fun y0 : Y * Q * Q => let (z, r) := g (fst y0) in (z, r, Qred (r + snd y0))) (fun y0 : Y * Q * Q => Qle_bool (Qabs (snd (fst y0))) (` e)) (cvmod e) (y,0)) as [r [req [H3 H4]]]. rewrite req, SumStream_red. clear req. destruct H4 as [fuel|predicate]. - subst r. destruct H2. + subst q. apply (SumStream_wd _ _ _ _ _ _ _ H). + exfalso. destruct H2. specialize (H3 q H2). rewrite SumStream_fst_red in H3. unfold fst in H3. rewrite SumStream_fst_red in H4. unfold fst in H4. specialize (H q). unfold Str_pth in H. rewrite H in H4. rewrite H4 in H3. discriminate. - destruct predicate. rewrite SumStream_fst_red in H5. unfold fst in H5. destruct H2. + exfalso. subst q. specialize (H1 r H4). rewrite SumStream_fst_red in H1. unfold fst in H1. specialize (H r). unfold Str_pth in H. rewrite <- H in H5. rewrite H5 in H1. discriminate. + destruct H2. rewrite SumStream_fst_red in H6. unfold fst in H6. destruct (Pos.lt_total q r). exfalso. specialize (H3 q H7). rewrite SumStream_fst_red in H3; unfold fst in H3. specialize (H q). unfold Str_pth in H. rewrite H in H6. rewrite H6 in H3. discriminate. destruct H7. rewrite H7. exact (SumStream_wd _ _ _ _ _ _ _ H). exfalso. specialize (H1 r H7). rewrite SumStream_fst_red in H1; unfold fst in H1. specialize (H r). unfold Str_pth in H. rewrite H in H1. rewrite H1 in H5. discriminate. Qed. Lemma sym_sub_add_distr (p q r:positive) : (p-(q+r) ≡ p-q-r)%positive. Proof. destruct (Pos.lt_total (q+r) p). - apply Pos.sub_add_distr, H. - destruct H. subst p. rewrite Pos.sub_diag. rewrite Pos.add_comm, Pos.add_sub. rewrite Pos.sub_diag. reflexivity. rewrite Pos.sub_lt. 2: exact H. rewrite Pos.sub_le. reflexivity. destruct (Pos.lt_total p q). + rewrite Pos.sub_lt. apply Pos.le_1_l. exact H0. + destruct H0. subst q. rewrite Pos.sub_diag. apply Pos.le_1_l. change (Zpos (p-q) <= Zpos r)%Z. rewrite Pos2Z.inj_sub. 2: exact H0. apply (Z.add_le_mono_r _ _ (Zpos q)). ring_simplify. rewrite <- Pos2Z.inj_add. apply Z.lt_le_incl, H. Qed. Lemma AltSeries_shift_pth : forall (p:positive) (X : Type) f x cvmod decr lz, (AltSeries X f x cvmod decr lz == inject_Q_CR (snd (CRstreams.iterate _ (fun y : (X * Q) * Q => let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) p (x, 0%Q))) + AltSeries X f (CRstreams.iterate _ f p x) _ (Str_alt_decr_tl X f x p decr) (Limit_zero_tl X f x cvmod p decr lz))%CR. Proof. apply (Pos.peano_ind (fun p => forall X f x cvmod decr lz, (AltSeries X f x cvmod decr lz == inject_Q_CR (snd (CRstreams.iterate _ (fun y : (X * Q) * Q => let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) p (x, 0%Q))) + AltSeries X f _ _ (Str_alt_decr_tl X f x p decr) (Limit_zero_tl X f x cvmod p decr lz))%CR)). - intros. rewrite AltSeries_shift. apply CRplus_eq_l. rewrite SumStream_red. rewrite iterate_one. simpl. destruct (f x). simpl. rewrite Qplus_0_r. reflexivity. - intros. setoid_replace (AltSeries X f (CRstreams.iterate (X * Q) f (Pos.succ p) x) (fun e : Qpos => (cvmod e - Pos.succ p)%positive) (Str_alt_decr_tl X f x (Pos.succ p) decr) (Limit_zero_tl X f x cvmod (Pos.succ p) decr lz)) with (AltSeries X f (CRstreams.iterate (X * Q) f p (f x)) _ (Str_alt_decr_tl X f (f x) p (Str_alt_decr_tl X f x 1 decr)) (Limit_zero_tl X f (f x) _ p (Str_alt_decr_tl X f x 1 decr) (Limit_zero_tl X f x _ 1 decr lz))). + setoid_replace (inject_Q_CR (snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) (Pos.succ p) (x, 0)))) with (inject_Q_CR (snd (f x)) + inject_Q_CR (snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) p (f x, 0%Q))))%CR. rewrite <- CRplus_assoc, <- (H X f (f x)). rewrite <- AltSeries_shift. reflexivity. clear H. rewrite SumStream_red, SumStream_red. rewrite iterate_succ. rewrite SumStream_fst. simpl. rewrite CRplus_Qplus. apply inject_Q_CR_wd. transitivity (snd (f (CRstreams.iterate (X * Q) f p x) ) + snd (CRstreams.iterate (X * Q * Q) (fun y : X * Q * Q => let (z1, r0) := f (fst y) in (z1, r0, r0 + snd y)) p (x, 0))). destruct (f (CRstreams.iterate (X * Q) f p x)); reflexivity. pose proof (SumStream_assoc X f x 1 p). rewrite iterate_one, iterate_one in H. setoid_replace (snd (let (z, r0) := f (fst (x, 0)) in (z, r0, r0 + snd (x, 0)))%Q) with (snd (f x))%Q in H. rewrite <- H. clear H. rewrite Pos.add_1_l, iterate_succ, SumStream_fst. unfold fst. destruct (f (CRstreams.iterate (X * Q) f p x)). simpl. reflexivity. simpl. destruct (f x). simpl. rewrite Qplus_0_r. reflexivity. + apply AltSeries_wd. intros. rewrite iterate_succ, iterate_shift. reflexivity. intro e. rewrite <- Pos.add_1_l. rewrite sym_sub_add_distr. reflexivity. Qed. corn-8.20.0/reals/fast/CRAlternatingSum_alg.v000066400000000000000000000356621473720167500210310ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.iso_CReals. Require Import CoRN.reals.Q_in_CReals. From Coq Require Import ArithRing. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.fast.CRabs. From Coq Require Import Bool. Require Import CoRN.algebra.COrdAbs. Require Import CoRN.model.ordfields.Qordfield. Require Export CoRN.model.metric2.Qmetric. Require Import CoRN.reals.fast.LazyNat. Require Export CoRN.metric2.Limit. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Qpower. From Coq Require Import Qabs. Require Export MathClasses.theory.CoqStreams. Require Import CoRN.transc.PowerSeries. Require Import CoRN.tactics.CornTac. Require Import CoRN.classes.Qclasses. Require Import MathClasses.interfaces.abstract_algebra MathClasses.interfaces.orders MathClasses.theory.series MathClasses.theory.streams. Require Import CoRN.reals.fast.CRAlternatingSum. Opaque CR. Local Open Scope Q_scope. Lemma abs_power_neg_one : forall n:nat, Qabs ((-1)^n) == 1. Proof. induction n. reflexivity. change (S n) with (1+n)%nat. rewrite Nat2Z.inj_add, Qpower_plus. rewrite Qabs_Qmult, IHn. reflexivity. intro abs. discriminate. Qed. Lemma Str_alt_decr_decr : forall (X:Type) (f : X*Q->X*Q) x (fdecr : Str_alt_decr X f x) (n : nat), 0 <= Str_pth _ f 1 x -> (-1) ^ S n * Str_pth X f (Pos.of_nat (S (S n))) x <= (-1) ^ n [*] Str_pth X f (Pos.of_nat (S n)) x. Proof. intros. pose proof (Str_alt_decr_pos X f x fdecr). specialize (fdecr (Pos.of_nat (S n))) as [fdecr _]. rewrite <- Qmult_1_l in fdecr. rewrite <- (abs_power_neg_one (S n)) in fdecr. rewrite <- (Qmult_1_l (Qabs (Str_pth X f (Pos.of_nat (S n)) x))) in fdecr. rewrite <- (abs_power_neg_one n) in fdecr. rewrite <- Qabs_Qmult, <- Qabs_Qmult in fdecr. rewrite Qabs_pos, Qabs_pos in fdecr. rewrite Nat2Pos.inj_succ. 2: discriminate. exact fdecr. apply H0, H. apply H0, H. Qed. Lemma AltSeries_convergent_pos : forall (X:Type) (f : X*Q->X*Q) x cvmod (fdecr : Str_alt_decr X f x) (flz : Limit_zero X f x cvmod), 0 <= Str_pth _ f 1 x -> convergent (fun n:nat => inj_Q IR (Str_pth _ f (Pos.of_nat (S n)) x)). Proof. intros. assert (forall n:nat, [--] [1] [^] n [=] (inj_Q IR ((-1)^n))) as power_neg_one. { intro n. rewrite inj_Q_power. apply nexp_wd. rewrite (inj_Q_inv IR 1), inj_Q_One. reflexivity. } apply (convergent_wd (fun n : nat => [--][1][^]n[*]([--][1][^]n[*]inj_Q IR (Str_pth _ f (Pos.of_nat (S n)) x)))). - intro n. rewrite power_neg_one. rewrite <- inj_Q_mult, <- inj_Q_mult. apply inj_Q_wd. rewrite Qmult_assoc. rewrite <- Qpower_plus. replace (n+n)%Z with (2* Z.of_nat n)%Z. rewrite Qpower_mult. replace ((-1)^2) with 1%Q by reflexivity. rewrite Qpower_1, Qmult_1_l. reflexivity. ring. intro abs. discriminate. - apply alternate_series_conv. + (* positivity *) clear flz. intro n. pose proof (Str_alt_decr_pos X f x fdecr n). rewrite power_neg_one. rewrite <- inj_Q_mult, <- inj_Q_Zero. apply inj_Q_leEq, H0, H. + (* f tends to zero. *) intros e epos. destruct (Q_dense_in_CReals IR e epos) as [q qpos qmaj]. apply (less_wdl IR [0] _ (inj_Q IR 0)) in qpos. apply less_inj_Q in qpos. specialize (flz (exist _ _ qpos)). exists (Pos.to_nat (cvmod (exist _ _ qpos))). intros m H1. apply (AbsSmall_wdr _ _ (inj_Q IR ((-1)^m * Str_pth X f (Pos.of_nat (S m)) x))). 2: rewrite inj_Q_mult, power_neg_one; rational. apply (AbsSmall_trans _ (inj_Q IR q) _ _ qmaj). apply inj_Q_AbsSmall. apply AbsSmall_Qabs. refine (Qle_trans _ _ _ _ flz). clear flz. rewrite Qabs_pos. 2: apply (Str_alt_decr_pos X f x fdecr), H. rewrite <- (Pos2Nat.id (cvmod (q ↾ qpos))). pose proof (Pos2Nat.is_pos (cvmod (q ↾ qpos))). destruct (Pos.to_nat (cvmod (q ↾ qpos))). exfalso; inversion H0. clear H0. rewrite <- (Qmult_1_l (Qabs (Str_pth X f (Pos.of_nat (S n)) x))). rewrite <- (abs_power_neg_one n). rewrite <- Qabs_Qmult, Qabs_pos. 2: apply (Str_alt_decr_pos X f x fdecr), H. revert m n H1. induction m. intros. exfalso; inversion H1. intros. apply Nat.le_succ_r in H1. destruct H1. specialize (IHm n H0). apply (Qle_trans _ _ _ (Str_alt_decr_decr X f x fdecr m H) IHm). inversion H0. subst n. apply Str_alt_decr_decr. exact fdecr. exact H. rewrite inj_Q_Zero. reflexivity. + (* Decreasing *) intro n. rewrite power_neg_one, power_neg_one. rewrite <- inj_Q_mult, <- inj_Q_mult. apply inj_Q_leEq. apply Str_alt_decr_decr; assumption. Qed. Lemma AltSeries_convergent : forall (X:Type) (f : X*Q->X*Q) x cvmod (fdecr : Str_alt_decr X f x) (flz : Limit_zero X f x cvmod), convergent (fun n:nat => inj_Q IR (Str_pth _ f (Pos.of_nat (S n)) x)). Proof. (* Test whether the first term is positive or negative. *) intros. destruct (Qlt_le_dec (Str_pth _ f 1 x) 0). 2: exact (AltSeries_convergent_pos X f x cvmod fdecr flz q). apply (convergent_wd (fun n : nat => [--][1][*]inj_Q IR (Str_pth _ (CRstreams.CRstream_opp X f) (Pos.of_nat (S n)) (let (y,r):=x in (y,-r))))). - (* the sequences are pointwise equal *) intro n. pose proof (CRstreams.CRstream_opp_pth X f x (Pos.of_nat (S n))). unfold Str_pth. destruct (CRstreams.iterate _ (CRstreams.CRstream_opp X f) (Pos.of_nat (S n)) (let (y, r) := x in (y, - r))), (CRstreams.iterate (X and Q) f (Pos.of_nat (S n)) x). unfold snd. destruct H as [_ H]. subst q0. rewrite (inj_Q_inv IR q1), inv_mult_invol. rewrite <- inj_Q_One, <- inj_Q_mult. apply inj_Q_wd, Qmult_1_l. - apply conv_series_mult_scal. apply (AltSeries_convergent_pos X (CRstreams.CRstream_opp X f) (let (y, r) := x in (y, - r)) cvmod). apply CRstream_opp_decr, fdecr. apply CRstream_opp_limit_zero, flz. unfold CRstreams.CRstream_opp, Str_pth; simpl. destruct x. unfold Str_pth in q; simpl in q. replace (--q0) with q0. destruct (f (x,q0)). unfold snd. unfold snd in q. apply (Qopp_le_compat q1 0), Qlt_le_weak, q. destruct q0. unfold Qopp; simpl. rewrite Z.opp_involutive. reflexivity. Qed. Lemma AltSeries_convergent_0 : forall (X:Type) (f : X*Q->X*Q) x cvmod q (fdecr : Str_alt_decr X f x) (flz : Limit_zero X f x cvmod), convergent (fun n:nat => match n with | O => q | S _ => inj_Q IR (Str_pth _ f (Pos.of_nat n) x) end). Proof. intros. (* Get rid of the initial zero. *) apply (join_series (fun n : nat => inj_Q IR (Str_pth _ f (Pos.of_nat (S n)) x))). - exact (AltSeries_convergent X f x cvmod fdecr flz). - exists 1%nat. exists O. intros n _. rewrite Nat.add_comm. reflexivity. Qed. Lemma AltSeries_small_inf : forall (X : Type) (f : X * Q → X * Q) (x : X * Q) (cvmod : Qpos → positive) (fdecr : Str_alt_decr X f x) (flz : Limit_zero X f x cvmod) (e : CRasCReals), AbsSmall e (' snd (f x))%CR -> AbsSmall e (AltSeries X f x cvmod fdecr flz)%CR. Proof. intros. apply CRabs_AbsSmall. apply CRabs_AbsSmall in H. rewrite inject_Q_CR_abs in H. refine (CRle_trans _ H). clear H e. intro e. simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0%Q). apply (Qopp_le_compat 0), Qpos_nonneg. unfold Qminus. rewrite <- Qle_minus_iff. generalize (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Zpos xH; Qden := xO xH |} (@eq_refl Datatypes.comparison Datatypes.Lt)) e). clear e. intro e. unfold SumStream. pose proof (CRstreams.iterate_stop_correct _ (λ y : X * Q * Q, let (z, r) := f (fst y) in (z, r, Qred (r + snd y))) (λ y : X * Q * Q, Qle_bool (Qabs (snd (fst y))) (proj1_sig e)) (cvmod e) (x,0%Q)) as [s [seq [_ H4]]]. unfold zero, Q_0. rewrite seq. clear seq. rewrite SumStream_red. apply (AltSeries_small X f x s). exact fdecr. Qed. Lemma AltSeries_remainder : forall (X : Type) (f : X * Q → X * Q) (x : X * Q) (cvmod : Qpos → positive) (fdecr : Str_alt_decr X f x) (flz : Limit_zero X f x cvmod) (e : CRasCReals) (p : positive), AbsSmall e (' Str_pth X f p x)%CR -> AbsSmall e (inject_Q_CR (snd (CRstreams.iterate ((X and Q) and Q) (λ y : (X and Q) and Q, let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) p (x, 0%Q))) - AltSeries X f x cvmod fdecr flz)%CR. Proof. intros. rewrite (AltSeries_shift_pth p). rewrite CRopp_plus_distr, CRplus_assoc. rewrite CRplus_opp. apply (AbsSmall_minus CRasCOrdField e _ 0%CR). unfold cg_minus. simpl. rewrite CRopp_0, CRplus_0_r. apply AltSeries_small_inf. specialize (fdecr p) as [fdecr _]. unfold Str_pth in fdecr. rewrite <- CRstreams.iterate_succ. apply CRabs_AbsSmall. rewrite inject_Q_CR_abs. apply (@CRle_trans _ (inject_Q_CR (Qabs (snd (CRstreams.iterate (X and Q) f p x))))). apply (order_embedding_preserving inject_Q_CR), fdecr. rewrite <- inject_Q_CR_abs. apply CRabs_AbsSmall. apply H. Qed. Lemma AltSeries_correct : forall (X:Type) (f : X*Q->X*Q) x cvmod (fdecr : Str_alt_decr X f x) (flz : Limit_zero X f x cvmod) (g:nat -> IR) (H : convergent g), (forall n:positive, inj_Q IR (Str_pth _ f n x)%Q [=] g (Pos.to_nat n)) -> (IRasCR (g O) + AltSeries _ f x cvmod fdecr flz == IRasCR (series_sum g H))%CR. Proof. (* z equals to limit, means the sequence converges towards z. *) intros. unfold series_sum. rewrite -> IR_Lim_as_CR. apply (SeqLimit_unique CRasCReals). (* then prove convergence. Apply the Cauchy proof as C at e/2 to get an index n. *) intros e He. generalize (IR_Cauchy_prop_as_CR (Build_CauchySeq IR (seq_part_sum g) H)). intro C. destruct (C _ (pos_div_two CRasCOrdField _ He)) as [n Hn]. exists (S (S n)). (* prove that the partial sum of g until m >= 2+n minus the infinite sum of f is less than e. It is equal to the remaining infinite sum of g after m. *) intros m Hm. unfold CS_seq in *. clear C. unfold seq_part_sum in *. destruct m. exfalso; inversion Hm. apply le_S_n in Hm. (* Replace g by f. *) assert (forall k:positive, le n (Pos.to_nat k) -> AbsSmall e (inject_Q_CR (Str_pth _ f k x))) as kSmall. { intros. stepr (IRasCR (g (Pos.to_nat k))). setoid_replace (IRasCR (g (Pos.to_nat k))) with (@Sum CRasCAbGroup (Pos.to_nat k) (Pos.to_nat k) (fun n => IRasCR (g n))) by (rewrite Sum_one; reflexivity). unfold Sum, Sum1. rewrite <- IR_Sum0_as_CR, <- IR_Sum0_as_CR. (* Triangle inequality with the sum until n. *) stepr ((IRasCR (Sum0 (G:=IR) (S (Pos.to_nat k)) g) - (IRasCR (Sum0 (G:=IR) n g))) + (IRasCR (Sum0 (G:=IR) n g) - IRasCR (Sum0 (G:=IR) (Pos.to_nat k) g)))%CR by (unfold cg_minus; simpl; unfold msp_Equiv; ring). apply (AbsSmall_eps_div_two CRasCOrdField e (IRasCR (Sum0 (S (Pos.to_nat k)) g) - IRasCR (Sum0 n g)) (IRasCR (Sum0 n g) - IRasCR (Sum0 (Pos.to_nat k) g)))%CR. apply (Hn (S (Pos.to_nat k))). apply le_S, H1. apply (AbsSmall_minus CRasCOrdField (e [/]TwoNZ) (IRasCR (Sum0 (Pos.to_nat k) g)) (IRasCR (Sum0 n g))). apply Hn. exact H1. rewrite <- IR_inj_Q_as_CR. apply IRasCR_wd. symmetry. apply H0. } stepr (IRasCR (Sum0 (S m) g) - IRasCR (g 0%nat) - AltSeries X f x cvmod fdecr flz)%CR by (unfold cg_minus; simpl; unfold msp_Equiv; ring). setoid_replace (IRasCR (Sum0 (S m) g) - IRasCR (g 0%nat))%CR with (inject_Q_CR (snd (CRstreams.iterate _ (λ y : X * Q * Q, let (z0, r1) := f (fst y) in (z0, r1, Qred (r1 + snd y))) (Pos.of_nat m) (x,0%Q)))). - apply AltSeries_remainder. apply kSmall. rewrite Nat2Pos.id. apply (Nat.le_trans _ (S n)). apply le_S, Nat.le_refl. exact Hm. destruct m. inversion Hm. discriminate. - clear kSmall. replace (S m) with (S (Pos.to_nat (Pos.of_nat m))). generalize (Pos.of_nat m). clear Hm m. apply Pos.peano_ind. + rewrite SumStream_red. rewrite CRstreams.iterate_one. specialize (H0 xH). unfold Str_pth, Pos.to_nat in H0. simpl in H0. simpl. destruct (f x). simpl. simpl in H0. rewrite <- IR_minus_as_CR, <- IR_inj_Q_as_CR. apply IRasCR_wd. rewrite cm_lft_unit, cag_commutes. unfold cg_minus. rewrite <- CSemiGroups.plus_assoc. rewrite cg_rht_inv_unfolded, cm_rht_unit. rewrite <- H0. apply inj_Q_wd. rewrite Qplus_0_r. reflexivity. + intros p IHp. simpl (Sum0 (S (Pos.to_nat (Pos.succ p))) g). rewrite IR_plus_as_CR. rewrite (CRplus_comm (IRasCR (Sum0 (Pos.to_nat (Pos.succ p)) g))). rewrite Pos2Nat.inj_succ. rewrite <- CRplus_assoc, IHp. clear IHp. rewrite SumStream_red. rewrite SumStream_red. rewrite CRstreams.iterate_succ. rewrite SumStream_fst. simpl. rewrite <- CRstreams.iterate_succ. specialize (H0 (Pos.succ p)). unfold Str_pth in H0. destruct (CRstreams.iterate (X and Q) f (Pos.succ p) x). simpl. simpl in H0. rewrite Pos2Nat.inj_succ in H0. rewrite <- CRplus_Qplus. apply CRplus_eq_l. rewrite <- IR_inj_Q_as_CR. apply IRasCR_wd. symmetry. exact H0. + rewrite Nat2Pos.id. reflexivity. destruct m. inversion Hm. discriminate. Qed. corn-8.20.0/reals/fast/CRArith.v000066400000000000000000002454231473720167500163160ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Ring_theory. From Coq Require Import Setoid. From Coq Require Import QArith. From Coq Require Import Qabs. From Coq Require Import Qround. Require Import CoRN.metric2.Complete. Require Import CoRN.metric2.ProductMetric. Require Export CoRN.reals.fast.CRFieldOps. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.logic.Stability. From Coq Require Import ConstructiveEpsilon. Require Import CoRN.util.Qdlog. Require Import MathClasses.interfaces.abstract_algebra. Require Import MathClasses.interfaces.orders. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Local Open Scope CR_scope. (** Operations on rational numbers over CR are the same as the operations on rational numbers. *) Lemma CReq_Qeq : forall (x y:Q), inject_Q_CR x == inject_Q_CR y <-> (x == y)%Q. Proof. intros x y. rewrite <- Qball_0. apply Cunit_eq. Qed. Lemma CRlt_Qlt : forall a b, (a < b)%Q -> ((' a%Q) < (' b))%CR. Proof. intros a b H. destruct (Qpos_sub _ _ H) as [c Hc]. exists c. intros d. change (-proj1_sig d <= b + - a + - proj1_sig c)%Q. rewrite -> Hc. rewrite -> Qle_minus_iff. ring_simplify. apply Qpos_nonneg. Qed. Lemma CRplus_Qplus : forall (x y:Q), inject_Q_CR x + inject_Q_CR y == inject_Q_CR (x + y)%Q. Proof. intros x y e1 e2; apply ball_refl. rewrite Qplus_0_r. apply (Qpos_nonneg (e1+e2)). Qed. #[global] Hint Rewrite <- CRplus_Qplus : toCRring. Lemma CRopp_Qopp : forall (x:Q), - inject_Q_CR x == inject_Q_CR (- x)%Q. Proof. intros x e1 e2; apply ball_refl. rewrite Qplus_0_r. apply (Qpos_nonneg (e1+e2)). Qed. (* begin hide *) #[global] Hint Rewrite CRopp_Qopp : CRfast_compute. #[global] Hint Rewrite <- CRopp_Qopp : toCRring. (* end hide *) Lemma CRminus_Qminus : forall (x y:Q), inject_Q_CR x - inject_Q_CR y == inject_Q_CR (x - y)%Q. Proof. intros x y e1 e2; apply ball_refl. rewrite Qplus_0_r. apply (Qpos_nonneg (e1+e2)). Qed. (* begin hide *) #[global] Hint Rewrite <- CRminus_Qminus : toCRring. (* end hide *) Lemma CRmult_Qmult : forall (x y:Q), inject_Q_CR x * inject_Q_CR y == inject_Q_CR (x * y)%Q. Proof. intros x y. rewrite -> CRmult_scale. intros e1 e2; apply ball_refl. rewrite Qplus_0_r. apply (Qpos_nonneg (e1+e2)). Qed. (* begin hide *) #[global] Hint Rewrite <- CRmult_Qmult : toCRring. (* end hide *) Lemma Qap_CRap : forall (x y:Q), (~(x==y))%Q -> (' x)><(' y). Proof. intros x y Hxy. destruct (Q_dec x y) as [[H|H]|H]; try contradiction; destruct (Qpos_sub _ _ H) as [c Hc];[left|right]; exists c; abstract (rewrite -> CRminus_Qminus; rewrite -> CRle_Qle; rewrite -> Hc; ring_simplify; apply Qle_refl). Defined. Lemma CRinv_Qinv : forall (x:Q) x_, CRinvT (inject_Q_CR x) x_ == inject_Q_CR (/x)%Q. Proof. intros x [[c x_]|[c x_]]; [change (' proj1_sig c <= 0 + - 'x)%CR in x_|change (' proj1_sig c <= ' x + - 0)%CR in x_]; unfold CRinvT; rewrite -> CRopp_Qopp, CRplus_Qplus, CRle_Qle in x_; try rewrite -> CRopp_Qopp; rewrite -> (@CRinv_pos_Qinv c). rewrite -> CRopp_Qopp. rewrite -> CReq_Qeq. assert (~x==0)%Q. intros H. rewrite -> H in x_. apply (Qle_not_lt _ _ x_). apply Qpos_ispos. field. intros X; apply H. assumption. rewrite -> Qplus_0_l in x_. assumption. reflexivity. rewrite -> Qplus_0_r in x_. assumption. Qed. (* begin hide *) #[global] Hint Rewrite <- CRinv_Qinv : toCRring. (* end hide *) (** ** Ring CR forms a ring for the ring tactic. *) Lemma CRplus_0_l (x: CR): (0 + x == x)%CR. Proof. intros e1 e2. destruct x; simpl. unfold Cap_raw; simpl. rewrite Qplus_0_r. rewrite Qplus_0_l. assert ((1#2)*`e1 + `e2 <= `e1 + `e2)%Q. { apply Qplus_le_l. rewrite <- (Qmult_1_l (`e1)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. } apply (ball_weak_le Q_as_MetricSpace _ _ H), (regFun_prf ((1#2)*e1)%Qpos e2). Qed. (* Lifting of Qplus_comm *) Lemma CRplus_comm (x y: CR): x + y == y + x. Proof. rewrite CRplus_uncurry_eq. rewrite CRplus_uncurry_eq. apply Cmap2_comm. intros a b. apply Qball_0, Qplus_comm. Qed. Lemma CRplus_assoc (x y z: CR): x + (y + z) == (x + y) + z. Proof. intros. intros e1 e2. destruct x,y,z; simpl; unfold Cap_raw; simpl. unfold Cap_raw; simpl. apply AbsSmall_Qabs. setoid_replace (approximate ((1 # 2) * e1)%Qpos + (approximate0 ((1 # 2) * ((1 # 2) * e1))%Qpos + approximate1 ((1 # 2) * ((1 # 2) * e1))%Qpos) - (approximate ((1 # 2) * ((1 # 2) * e2))%Qpos + approximate0 ((1 # 2) * ((1 # 2) * e2))%Qpos + approximate1 ((1 # 2) * e2)%Qpos))%Q with ((approximate ((1 # 2) * e1)%Qpos - approximate ((1 # 2) * ((1 # 2) * e2))%Qpos) + (approximate0 ((1 # 2) * ((1 # 2) * e1))%Qpos - approximate0 ((1 # 2) * ((1 # 2) * e2))%Qpos) + (approximate1 ((1 # 2) * ((1 # 2) * e1))%Qpos - approximate1 ((1 # 2) * e2)%Qpos))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). rewrite Qplus_0_r. setoid_replace (` e1 + ` e2)%Q with (((1#2)* ` e1 + (1#2)*((1#2) * `e2)) + ((1#2)*((1#2)* `e1) + (1#2)*((1#2)*`e2)) + ((1#2)*((1#2)* `e1) + (1#2)* ` e2))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). apply Qplus_le_compat. apply (Qle_trans _ _ _ (Qabs_triangle _ _)). apply Qplus_le_compat. - apply AbsSmall_Qabs. apply (regFun_prf ((1#2)*e1)%Qpos ((1#2)*((1#2)*e2))%Qpos). - apply AbsSmall_Qabs. apply (regFun_prf0 ((1#2)*((1#2)*e1))%Qpos ((1#2)*((1#2)*e2))%Qpos). - apply AbsSmall_Qabs. apply (regFun_prf1 ((1#2)*((1#2)*e1))%Qpos ((1#2)*e2)%Qpos). Qed. Lemma CRmult_1_l : forall (x: CR), 1 * x == x. Proof. intro x. rewrite CRmult_scale. intros e1 e2. destruct x; simpl. rewrite Qplus_0_r. rewrite Qmult_1_l. rewrite <- (Qmult_1_l (`e1)). apply (regFun_prf ((1#1)*e1)%Qpos e2). Qed. (* Lift Qmult_comm. *) Lemma CRmult_comm_bounded (x y: CR) (b:Qpos) : (' (- ` b)%Q <= x)%CR -> (x <= 'proj1_sig b)%CR -> (' (- ` b)%Q <= y)%CR -> (y <= 'proj1_sig b)%CR -> CRmult_bounded b x y == CRmult_bounded b y x. Proof. intros. rewrite CRmult_uncurry_eq, CRmult_uncurry_eq; try assumption. apply Cmap2_comm. intros. apply Qball_0, Qmult_comm. Qed. Lemma CRmult_comm (x y: CR): x * y == y * x. Proof. pose (Qpos_max (CR_b (1#1) x) (CR_b (1#1) y)) as b. assert (' (- ` b)%Q <= x) as xlower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) x))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat, Qpos_max_ub_l. } assert (x <= '(` b)%Q) as xupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) x))) _ (CR_b_upperBound _ _)). apply CRle_Qle. apply Qpos_max_ub_l. } assert (' (- ` b)%Q <= y) as ylower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) y))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat, Qpos_max_ub_r. } assert (y <= '(` b)%Q) as yupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) y))) _ (CR_b_upperBound _ _)). apply CRle_Qle. apply Qpos_max_ub_r. } rewrite <- (@CRmult_bounded_mult b x y). 2: exact ylower. 2: exact yupper. rewrite <- (@CRmult_bounded_mult b y x). 2: exact xlower. 2: exact xupper. - apply CRmult_comm_bounded. + exact xlower. + exact xupper. + exact ylower. + exact yupper. Qed. Lemma CRmult_1_r : forall (x: CR), x * 1 == x. Proof. intro x. rewrite CRmult_comm. apply CRmult_1_l. Qed. Lemma CRmult_assoc (x y z : CR): (x * y) * z == x * (y * z). Proof. pose ((CR_b (1#1) x + (1#1)) * (CR_b (1#1) y + (1#1)) * (CR_b (1#1) z + (1#1)))%Qpos as b. assert (' (- ` b)%Q <= z) as zlower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) z))%Q)). 2: apply CR_b_lowerBound. apply CRle_Qle. apply Qopp_le_compat. apply (Qle_trans _ (` (CR_b (1#1)%Qpos z) + (1#1))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_zfactor_le. } assert (z <= ' (` b)%Q) as zupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) z))%Q)). apply CR_b_upperBound. apply CRle_Qle. apply (Qle_trans _ (` (CR_b (1#1)%Qpos z) + (1#1))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_zfactor_le. } rewrite <- (@CRmult_bounded_mult b x y), <- (@CRmult_bounded_mult b). 2: exact zlower. 2: exact zupper. rewrite <- (@CRmult_bounded_mult b), <- (@CRmult_bounded_mult b). apply CRmult_assoc_bounded. - exact zlower. - exact zupper. - apply (@CRle_trans _ ('(-proj1_sig ((CR_b (1#1) y) * CR_b (1#1) z)%Qpos)%Q)). 2: apply CR_b_lowerBound_2. apply CRle_Qle, Qopp_le_compat. apply (Qle_trans _ ((1#1)*proj1_sig (CR_b (1#1) y + (1#1))%Qpos * proj1_sig ((CR_b (1#1) z) + (1#1))%Qpos)). rewrite Qmult_1_l. apply (Qpos_mult_le_compat (CR_b (1#1) y) (CR_b (1#1) z)). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. rewrite <- Qplus_0_l at 1. apply Qplus_le_l. apply Qpos_nonneg. - apply (CRle_trans (CR_b_upperBound_2 y z)). apply CRle_Qle. apply (Qle_trans _ ((1#1)*proj1_sig (CR_b (1#1) y + (1#1))%Qpos * proj1_sig ((CR_b (1#1) z) + (1#1))%Qpos)). rewrite Qmult_1_l. apply (Qpos_mult_le_compat (CR_b (1#1) y) (CR_b (1#1) z)). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. rewrite <- Qplus_0_l at 1. apply Qplus_le_l. apply Qpos_nonneg. - apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) y))%Q)). 2: apply CR_b_lowerBound. apply CRle_Qle. apply Qopp_le_compat. apply (Qle_trans _ (` (CR_b (1#1)%Qpos y) + (1#1))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_yfactor_le. - apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) y))%Q)). apply CR_b_upperBound. apply CRle_Qle. apply (Qle_trans _ (` (CR_b (1#1)%Qpos y) + (1#1))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_yfactor_le. Qed. Lemma CRmult_plus_distr_r : ∀ x y z : CR, ((x + y) * z == x * z + y * z). Proof. intros x y z. pose ((CR_b (1#1) x + CR_b (1#1) y + CR_b (1#1) z))%Qpos as b. assert (forall u v, QboundAbs u v <= `u)%Q as qbound_bound. { intros. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. } assert ( ' (- ` b)%Q <= x)%CR as xlower. { apply (@CRle_trans _ ('(-(proj1_sig (CR_b (1#1) x)))%Q)). 2: apply CR_b_lowerBound. apply CRle_Qle, Qopp_le_compat. rewrite <- Qplus_0_r. simpl. rewrite <- (Qplus_assoc (Qabs (approximate x (Qpos2QposInf (1#1))) + 1)). apply Qplus_le_r. apply (Qpos_nonneg (CR_b (1#1) y + CR_b (1#1) z)). } assert (x <= ' (` b)%Q)%CR as xupper. { apply (@CRle_trans _ ('((proj1_sig (CR_b (1#1) x)))%Q)). apply CR_b_upperBound. apply CRle_Qle. rewrite <- Qplus_0_r. simpl. rewrite <- (Qplus_assoc (Qabs (approximate x (Qpos2QposInf (1#1))) + 1)). apply Qplus_le_r. apply (Qpos_nonneg (CR_b (1#1) y + CR_b (1#1) z)). } assert ( ' (- ` b)%Q <= y)%CR as ylower. { apply (@CRle_trans _ ('(-(proj1_sig (CR_b (1#1) y)))%Q)). 2: apply CR_b_lowerBound. apply CRle_Qle, Qopp_le_compat. rewrite <- Qplus_0_l. simpl. rewrite <- Qplus_assoc. apply Qplus_le_compat. apply (Qpos_nonneg ((CR_b (1#1) x))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. apply (Qpos_nonneg ((CR_b (1#1) z))). } assert (y <= ' (` b)%Q)%CR as yupper. { apply (@CRle_trans _ ('((proj1_sig (CR_b (1#1) y)))%Q)). apply CR_b_upperBound. apply CRle_Qle. rewrite <- Qplus_0_l. simpl. rewrite <- Qplus_assoc. apply Qplus_le_compat. apply (Qpos_nonneg ((CR_b (1#1) x))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. apply (Qpos_nonneg ((CR_b (1#1) z))). } rewrite <- (CRboundAbs_Eq _ (CR_b_lowerBound (1#1) y) (CR_b_upperBound (1#1) y)). rewrite <- (CRboundAbs_Eq _ (CR_b_lowerBound (1#1) x) (CR_b_upperBound (1#1) x)). assert ( ' (- ` b)%Q <= z)%CR as zlower. { apply (@CRle_trans _ ('(-(proj1_sig (CR_b (1#1) z)))%Q)). 2: apply CR_b_lowerBound. apply CRle_Qle, Qopp_le_compat. rewrite <- Qplus_0_l. apply Qplus_le_compat. apply Qpos_nonneg. apply Qle_refl. } assert (z <= ' (` b)%Q)%CR as zupper. { apply (@CRle_trans _ ('((proj1_sig (CR_b (1#1) z)))%Q)). apply CR_b_upperBound. apply CRle_Qle. rewrite <- Qplus_0_l. apply Qplus_le_compat. apply Qpos_nonneg. apply Qle_refl. } rewrite <- (@CRmult_bounded_mult b (CRboundAbs _ x) z). 2: exact zlower. 2: exact zupper. rewrite <- (@CRmult_bounded_mult b (CRboundAbs _ y) z). 2: exact zlower. 2: exact zupper. rewrite <- (@CRmult_bounded_mult b). 2: exact zlower. 2: exact zupper. rewrite (@CRmult_uncurry_eq b (CRboundAbs _ x) z). 2: rewrite (CRboundAbs_Eq _ (CR_b_lowerBound (1#1) x) (CR_b_upperBound (1#1) x)) ; exact xlower. 2: rewrite (CRboundAbs_Eq _ (CR_b_lowerBound (1#1) x) (CR_b_upperBound (1#1) x)) ; exact xupper. rewrite (@CRmult_uncurry_eq b (CRboundAbs _ y) z). 2: rewrite (CRboundAbs_Eq _ (CR_b_lowerBound (1#1) y) (CR_b_upperBound (1#1) y)) ; exact ylower. 2: rewrite (CRboundAbs_Eq _ (CR_b_lowerBound (1#1) y) (CR_b_upperBound (1#1) y)) ; exact yupper. rewrite CRmult_uncurry_eq. intros e1 e2. rewrite Qplus_0_r. change (Qball (`e1 + `e2) (QboundAbs b (approximate (CRboundAbs (CR_b (1#1) x) x) ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos + approximate (CRboundAbs (CR_b (1#1) y) y) ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos)%Q * QboundAbs b (approximate z (Qmult_modulus b ((1 # 2) * e1)))) (QboundAbs b (approximate (CRboundAbs (CR_b (1#1) x) x) (Qmult_modulus b ((1 # 2) * ((1 # 2) * e2)))) * QboundAbs b (approximate z (Qmult_modulus b ((1 # 2) * ((1 # 2) * e2)))) + QboundAbs b (approximate (CRboundAbs (CR_b (1#1) y) y) (Qmult_modulus b ((1 # 2) * ((1 # 2) * e2)))) * QboundAbs b (approximate z (Qmult_modulus b ((1 # 2) * ((1 # 2) * e2)))))). rewrite <- Qmult_plus_distr_l. unfold Qmult_modulus. apply AbsSmall_Qabs. assert (forall i j k l : Q, Qabs (i*j-k*l) <= Qabs i * Qabs(j-l) + Qabs(i-k)*Qabs l)%Q as multMaj. { intros. setoid_replace (i*j-k*l)%Q with (i*(j-l)+ (i-k)*l)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite Qabs_Qmult, Qabs_Qmult. apply Qle_refl. } apply (Qle_trans _ ((1#2)*`e1 + (1#2)*`e2 +((1#2)*`e1 +(1#2)*`e2))). 2: ring_simplify; apply Qle_refl. apply (Qle_trans _ _ _ (multMaj _ _ _ _)). clear multMaj. apply Qplus_le_compat. - apply (Qle_trans _ (`b * Qabs (QboundAbs b (approximate z ((1 # 2) * e1 * Qpos_inv b)%Qpos) - QboundAbs b (approximate z ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos)))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. rewrite QboundAbs_abs. apply Qmin_lb_r. rewrite Qmult_comm. apply (Qle_trans _ (Qabs (approximate z ((1 # 2) * e1 * Qpos_inv b)%Qpos - approximate z ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos) * ` b)). apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply QboundAbs_contract. apply (Qle_trans _ (((1#2)*`e1 / `b + (1#2)*`e2 / `b) * `b)). apply Qmult_le_r. apply Qpos_ispos. pose proof (regFun_prf z ((1 # 2) * e1 * Qpos_inv b)%Qpos ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). apply Qplus_le_r. simpl. rewrite Qmult_assoc. apply Qmult_le_r. apply Qinv_lt_0_compat, (Qpos_ispos b). apply Qmult_le_r. apply Qpos_ispos. discriminate. rewrite Qmult_comm. rewrite Qmult_plus_distr_r. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. - assert (forall u, Qabs u <= `b -> QboundAbs b u == u)%Q. { intros u H. apply QboundAbs_elim. intros. apply Qle_antisym. exact H0. apply (Qle_trans _ (Qabs u)). apply Qle_Qabs. exact H. intros. apply Qle_antisym. 2: exact H0. rewrite <- (Qopp_involutive u). apply Qopp_le_compat. rewrite <- Qabs_opp in H. exact (Qle_trans _ _ _ (Qle_Qabs _) H). intros. reflexivity. } rewrite H, H, H; clear H. rewrite QboundAbs_abs. rewrite Qmult_comm. apply (Qle_trans _ (` b * Qabs (approximate (CRboundAbs (CR_b (1#1) x) x) ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos + approximate (CRboundAbs (CR_b (1#1) y) y) ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos - (approximate (CRboundAbs (CR_b (1#1) x) x) ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos + approximate (CRboundAbs (CR_b (1#1) y) y) ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos)))). + apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply Qmin_lb_r. + rewrite Qmult_comm. apply (Qle_trans _ (((1#2)*`e1 / `b + (1#2)*`e2 / `b) * `b)). apply Qmult_le_r. apply Qpos_ispos. assert (forall a b c d, a + b - (c+d) == a - c + (b-d))%Q by (intros; ring). rewrite H; clear H. apply (Qle_trans _ _ _ (Qabs_triangle _ _)). apply (Qle_trans _ (((1#2) * ((1 # 2) * ` e1 / ` b) + (1#2) * ((1 # 2) * ` e2) / ` b) + ((1#2) * ((1 # 2) * ` e1 / ` b) + (1#2) * ((1 # 2) * ` e2) / ` b))). apply Qplus_le_compat. pose proof (regFun_prf (CRboundAbs (CR_b (1#1) x) x) ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). clear H4. apply Qle_refl. pose proof (regFun_prf (CRboundAbs (CR_b (1#1) y) y) ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). clear H4. apply Qle_refl. unfold Qdiv. ring_simplify. setoid_replace (8#16)%Q with (1#2)%Q by reflexivity. apply Qle_refl. rewrite Qmult_comm, Qmult_plus_distr_r. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. + change (Qabs (QboundAbs (CR_b (1#1) y) (approximate y ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos)) <= `b)%Q. rewrite QboundAbs_abs. apply (Qle_trans _ _ _ (Qmin_lb_r _ _)). rewrite <- Qplus_0_r. apply Qplus_le_compat. 2: apply Qpos_nonneg. rewrite <- Qplus_0_l. apply Qplus_le_l. apply Qpos_nonneg. + change (Qabs (QboundAbs (CR_b (1#1) x) (approximate x ((1 # 2) * ((1 # 2) * e2) * Qpos_inv b)%Qpos)) <= `b)%Q. rewrite QboundAbs_abs. apply (Qle_trans _ _ _ (Qmin_lb_r _ _)). rewrite <- Qplus_0_r. apply Qplus_le_compat. 2: apply Qpos_nonneg. rewrite <- Qplus_0_r. apply Qplus_le_r. apply Qpos_nonneg. + apply (Qle_trans _ _ _ (Qabs_triangle _ _)). setoid_replace (proj1_sig b) with (proj1_sig (CR_b (1#1) x) + (proj1_sig (CR_b (1#1) y) + proj1_sig (CR_b (1#1) z)))%Q by (simpl; unfold equiv, stdlib_rationals.Q_eq; ring). apply Qplus_le_compat. change (Qabs (QboundAbs (CR_b (1#1) x) (approximate x ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos)) <= proj1_sig (CR_b (1#1) x))%Q. rewrite QboundAbs_abs. apply Qmin_lb_r. change (Qabs (QboundAbs (CR_b (1#1) y) (approximate y ((1 # 2) * ((1 # 2) * e1 * Qpos_inv b))%Qpos)) <= proj1_sig (CR_b (1#1) y) + proj1_sig (CR_b (1#1) z))%Q. rewrite QboundAbs_abs. apply (Qle_trans _ (proj1_sig (CR_b (1#1) y) + 0)). rewrite Qplus_0_r. apply Qmin_lb_r. apply Qplus_le_r. apply Qpos_nonneg. - simpl. intro e. simpl. unfold Cap_raw; simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply (Qle_trans _ (- (Qabs (approximate x (Qpos2QposInf (1#1))) + 1) - (Qabs (approximate y (Qpos2QposInf (1#1))) + 1))). 2: apply Qplus_le_compat; apply Qmax_ub_l. setoid_replace (- (Qabs (approximate x (Qpos2QposInf (1#1))) + 1) - (Qabs (approximate y (Qpos2QposInf (1#1))) + 1))%Q with (- ((Qabs (approximate x (Qpos2QposInf (1#1))) + 1) + (Qabs (approximate y (Qpos2QposInf (1#1))) + 1)))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qopp_le_compat. rewrite <- Qplus_0_r. apply Qplus_le_r. apply (Qpos_nonneg (CR_b (1#1) z)). - simpl. intro e. simpl. unfold Cap_raw; simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply (Qle_trans _ (Qabs (approximate x (Qpos2QposInf (1#1))) + 1 + (Qabs (approximate y (Qpos2QposInf (1#1))) + 1))). apply Qplus_le_compat. apply (qbound_bound (CR_b (1#1) x)). apply (qbound_bound (CR_b (1#1) y)). rewrite <- Qplus_0_r. apply Qplus_le_r. apply (Qpos_nonneg (CR_b (1#1) z)). Qed. Lemma CRmult_plus_distr_l : ∀ x y z : CR, (z * (x + y) == z * x + z * y)%CR. Proof. intros. rewrite CRmult_comm, CRmult_plus_distr_r. rewrite (CRmult_comm z). rewrite (CRmult_comm z). reflexivity. Qed. Lemma CR_ring_theory : @ring_theory CR 0 1 (ucFun2 CRplus_uc) CRmult (fun (x y:CR) => (x + - y)) CRopp (@msp_eq CR). Proof. split. - exact CRplus_0_l. - exact CRplus_comm. - exact CRplus_assoc. - exact CRmult_1_l. - exact CRmult_comm. - intros. symmetry. apply CRmult_assoc. - exact CRmult_plus_distr_r. - reflexivity. - intros x e1 e2. simpl. unfold Cap_raw;simpl. rewrite Qplus_0_r. rewrite Qplus_opp_r. apply Qball_Reflexive. apply (Qpos_nonneg (e1+e2)). Qed. Lemma CR_Q_ring_morphism : ring_morph 0%CR 1%CR (ucFun2 CRplus_uc) CRmult (fun x y => (x + - y)) CRopp (@msp_eq CR) (0%Q) (1%Q) Qplus Qmult Qminus Qopp Qeq_bool (inject_Q_CR). Proof. split; try reflexivity. apply CRplus_Qplus. apply CRminus_Qminus. intros x y; rewrite -> CRmult_Qmult; reflexivity. apply CRopp_Qopp. intros x y H. rewrite -> CReq_Qeq. apply Qeq_bool_eq. assumption. Qed. Ltac CRcst t := match t with | (inject_Q_CR ?z) => Qcst z | _ => NotConstant end. Ltac CRring_pre := autorewrite with toCRring. Lemma CR_ring_eq_ext : ring_eq_ext (ucFun2 CRplus_uc) CRmult CRopp (@msp_eq CR). Proof. split. rapply ucFun2_wd. rapply CRmult_wd. rapply uc_wd. Qed. Add Ring CR_ring : CR_ring_theory (morphism CR_Q_ring_morphism, setoid (@msp_Setoid CR) CR_ring_eq_ext, constants [CRcst], preprocess [CRring_pre]). (** Relationship between strict and nonstrict positivity *) Lemma CRpos_nonNeg : forall x, CRpos x -> CRnonNeg x. Proof. intros x [c Hx]. cut (0 <= x)%CR. unfold CRle. intros H. assert (x == x - 0)%CR. ring. rewrite -> H0. assumption. apply CRle_trans with (' proj1_sig c)%CR; auto with *. rewrite -> CRle_Qle; auto with *. Qed. Lemma CRneg_nonPos : forall x, CRneg x -> CRnonPos x. Proof. intros x [c Hx]. cut (x <= 0)%CR. unfold CRle. intros H. assert (0 - x == -x)%CR. ring. rewrite -> H0 in H. intros e. rewrite <- (Qopp_involutive (proj1_sig e)). rewrite <- (Qopp_involutive (approximate x e)). apply Qopp_le_compat. apply H. apply CRle_trans with ('(-proj1_sig c)%Q)%CR; auto with *. rewrite -> CRle_Qle. apply (Qopp_le_compat 0). apply Qpos_nonneg. Qed. (** Now that we have ring-ness, we can easily prove some auxiliary utility lemmas about operations on CR. *) Ltac CRring_replace x y := assert (x == y) as CRring_replace_temp by ring; rewrite CRring_replace_temp; clear CRring_replace_temp. (* setoid_replace picks the st_eq equality which ring doesn't work for... *) Lemma CRle_opp (x y: CR): x <= y <-> - y <= - x. Proof. unfold CRle. intros. assert (- x - - y == y - x)%CR as E by ring. rewrite E. intuition. Qed. Lemma CRopp_opp (x: CR): (--x == x)%CR. Proof. intros. ring. Qed. Lemma CRplus_opp (x: CR): (x + - x == 0)%CR. Proof. intros. ring. Qed. Lemma CRopp_0: (-0 == 0)%CR. Proof. intros. ring. Qed. Lemma CRplus_0_r (x: CR): (x + 0 == x)%CR. Proof. intros. ring. Qed. Lemma CRmult_0_r (x: CR): (x * 0 == 0)%CR. Proof. intros. ring. Qed. Lemma CRopp_plus_distr : forall (r1 r2 : CR), - (r1 + r2) == - r1 + - r2. Proof. intros. ring. Qed. Lemma CRopp_mult_distr_r : forall (r1 r2 : CR), - (r1 * r2) == r1 * (- r2). Proof. intros. ring. Qed. Lemma CRopp_mult_distr_l : forall (r1 r2 : CR), - (r1 * r2) == (-r1) * r2. Proof. intros. ring. Qed. Lemma approximate_CRplus (x y: CR) (e: Qpos): approximate (x + y)%CR e = (approximate x ((1#2) * e)%Qpos + approximate y ((1#2) * e)%Qpos)%Q. Proof. reflexivity. Qed. Lemma CRnonNeg_CRplus (x y: CR): CRnonNeg x -> CRnonNeg y -> CRnonNeg (x + y)%CR. Proof. unfold CRnonNeg. intros. rewrite approximate_CRplus. setoid_replace (- proj1_sig e)%Q with (- proj1_sig ((1#2)*e)%Qpos + - proj1_sig ((1#2)*e)%Qpos)%Q by (simpl; unfold equiv, stdlib_rationals.Q_eq; ring). apply Qplus_le_compat; auto. Qed. Lemma CRplus_eq_l (z x y: CR): x == y <-> x + z == y + z. Proof with ring. split; intro E. rewrite E... rewrite <- (CRplus_0_r x), <- (CRplus_opp z), CRplus_assoc, E... Qed. Lemma CRplus_eq_r (z x y: CR): x == y <-> z + x == z + y. Proof. intros. do 2 rewrite (CRplus_comm z). apply CRplus_eq_l. Qed. Lemma CRplus_le_r (x y z: CR): x <= y <-> x+z <= y+z. Proof. unfold CRle. intros. assert (y + z - (x + z) == y - x)%CR as E by ring. rewrite E. intuition. Qed. Lemma CRplus_le_l x: forall y z : CR, x <= y <-> z + x <= z + y. Proof. intros. rewrite (CRplus_le_r x y z), (CRplus_comm x), (CRplus_comm y). reflexivity. Qed. Lemma CRplus_le_compat (x x' y y': CR): x <= x' -> y <= y' -> x+y <= x'+y'. Proof. unfold CRle. intros. assert (x' + y' - (x + y) == (x' - x) + (y' - y)) as E by ring. rewrite E. apply CRnonNeg_CRplus; assumption. Qed. Lemma CRplus_lt_r (x y z: CR): prod (x < y -> x+z < y+z) (x+z < y+z -> x < y). Proof. split. - intros. destruct H as [q H]. exists q. setoid_replace (y+z-(x+z))%CR with (y-x)%CR by (unfold equiv, msp_Equiv; ring). exact H. - intros. destruct H as [q H]. exists q. setoid_replace (y-x) with (y+z-(x+z)) by (unfold equiv, msp_Equiv; ring). exact H. Qed. Lemma CRplus_lt_l (x y z: CR): prod (x < y -> z+x < z+y) (z+x < z+y -> x < y). Proof. split. - intros. destruct H as [q H]. exists q. setoid_replace (z+y-(z+x)) with (y-x) by (unfold equiv, msp_Equiv; ring). exact H. - intros. destruct H as [q H]. exists q. setoid_replace (y-x) with (z+y-(z+x)) by (unfold equiv, msp_Equiv; ring). exact H. Qed. Lemma CRopp_lt_compat : forall x y : CR, x < y -> -y < -x. Proof. intros. apply (CRplus_lt_l _ _ (x+y)). assert (x == x+y-y)%CR by ring. assert (y == x+y-x)%CR by ring. apply (CRltT_wd H0 H1), H. Qed. Lemma CRopp_lt_cancel : forall x y : CR, -y < -x -> x < y. Proof. intros. apply (CRplus_lt_l _ _ (-x-y)). assert (-y == -x-y+x)%CR by ring. assert (-x == -x-y+y)%CR by ring. apply (CRltT_wd H0 H1), H. Qed. Lemma CRopp_le_compat : forall x y : CR, x <= y -> -y <= -x. Proof. intros. apply (CRplus_le_l _ _ (x+y)). ring_simplify. exact H. Qed. Lemma CRopp_le_cancel : forall x y : CR, -y <= -x -> x <= y. Proof. intros. apply (CRplus_le_l (-y) (-x) (x+y)) in H. ring_simplify in H. exact H. Qed. Lemma CRle_Q : forall (x : CR) (q : Q), ('q <= x)%CR <-> (forall e:Qpos, q <= approximate x e + proj1_sig e)%Q. Proof. split. - intros. unfold CRle in H. rewrite CRopp_Qopp, CRplus_comm, CRplus_translate in H. specialize (H e). simpl in H. apply (Qplus_le_l _ _ (`e + q)) in H. ring_simplify in H. rewrite Qplus_comm. exact H. - intros. unfold CRle. rewrite CRopp_Qopp, CRplus_comm, CRplus_translate. intro e. simpl. apply (Qplus_le_l _ _ (`e + q)). ring_simplify. rewrite Qplus_comm. apply H. Qed. Lemma CRlt_irrefl (x: CR): x < x -> False. Proof with auto. unfold CRltT. intro. assert (x - x == 0)%CR by ring. intros. generalize (CRpos_wd H0 H). unfold CRpos. intros. destruct H1. destruct x0. simpl in c. assert (x0 <= 0)%Q. rewrite <- CRle_Qle... apply Qlt_irrefl with 0%Q. apply Qlt_le_trans with x0... Qed. Lemma CRAbsSmall_ball : forall (x y:CR) (e:Q), (-'e <= x-y /\ x-y <= 'e)%CR <-> ball e x y. Proof. intros x y e. split. - intros [H1 H2]. rewrite <- (doubleSpeed_Eq x). rewrite <- (doubleSpeed_Eq (doubleSpeed x)). rewrite <- (doubleSpeed_Eq y). rewrite <- (doubleSpeed_Eq (doubleSpeed y)). apply regFunBall_e. intros d. assert (H1':=H1 d). assert (H2':=H2 d). clear H1 H2. simpl. set (x':=approximate x ((1#2)*((1#2)*d))%Qpos). set (y':=approximate y ((1#2)*((1#2)*d))%Qpos). change (-proj1_sig d <= x' - y' + - - e)%Q in H1'. change (-proj1_sig d <= e + - (x' - y'))%Q in H2'. rewrite -> Qle_minus_iff in *. apply ball_weak. apply Qpos_nonneg. split; simpl; rewrite -> Qle_minus_iff. rewrite Qopp_involutive. do 2 rewrite Qopp_involutive in H1'. rewrite (Qplus_comm (proj1_sig d)). rewrite Qplus_assoc. exact H1'. rewrite <- Qplus_assoc, Qplus_comm. rewrite Qopp_involutive in H2'. exact H2'. - intros H. rewrite <- (doubleSpeed_Eq x) in H. rewrite <- (doubleSpeed_Eq y) in H. split; intros d; destruct (H ((1#2)*d)%Qpos ((1#2)*d)%Qpos) as [H1 H2]; clear H; set (x':=(approximate (doubleSpeed x) ((1 # 2) * d)%Qpos)) in *; set (y':=(approximate (doubleSpeed y) ((1 # 2) * d)%Qpos)) in *. autorewrite with QposElim in H1. change (- ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)<=x' - y')%Q in H1. change (-proj1_sig d <= x' - y' + - - e)%Q. rewrite -> Qle_minus_iff. rewrite -> Qle_minus_iff in H1. setoid_replace (x' - y' + - - e + - - ` d)%Q with (x' - y' + - - ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). assumption. autorewrite with QposElim in H2. change (x' - y'<=((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d))%Q in H2. change (-proj1_sig d <= e + - (x' - y'))%Q. rewrite -> Qle_minus_iff. rewrite -> Qle_minus_iff in H2. setoid_replace (e + - (x' - y') + - - ` d)%Q with ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d + - (x' - y'))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). assumption. Qed. Lemma in_CRball (r: Q) (x y : CR) : x - ' r <= y /\ y <= x + ' r <-> ball r x y. (* A characterization of ball in terms of <=, similar to CRAbsSmall. *) Proof with intuition. intros. cut ((-' r <= x - y /\ x-y <= 'r) <-> (x - ' r <= y /\ y <= x + ' r)). - pose proof (CRAbsSmall_ball x y r)... - simpl. setoid_replace (x - y <= ' r) with (x - ' r <= y). setoid_replace (- ' r <= x - y) with (y <= x + ' r). intuition. rewrite (CRplus_le_r (- ' r) (x - y) ('r + y)). assert (- ' r + (' r + y) == y) as E by ring. rewrite E. assert (x - y + (' r + y) == x + ' r)%CR as F by ring. rewrite F... rewrite (CRplus_le_r (x - y) (' r) (y - 'r)). assert (x - y + (y - ' r) == x - ' r) as E by ring. rewrite E. assert (' r + (y - ' r) == y) as F by ring. rewrite F... Qed. (* And the same for gball: *) Lemma in_CRgball (r: Q) (x y: CR): x - ' r <= y /\ y <= x + ' r <-> ball r x y. Proof with intuition. apply in_CRball. Qed. Lemma CRgball_plus (x x' y y': CR) e1 e2: ball e1 x x' -> ball e2 y y' -> ball (e1 + e2) (x + y)%CR (x' + y')%CR. Proof with auto. do 3 rewrite <- in_CRgball. intros [A B] [C D]. CRring_replace (x + y - ' (e1 + e2)%Q) (x - ' e1 + (y - ' e2)). CRring_replace (x + y + ' (e1 + e2)%Q) (x + ' e1 + (y + ' e2)). split; apply CRplus_le_compat... Qed. Lemma Qlt_from_CRlt (a b: Q): (' a < ' b)%CR -> (a < b)%Q. Proof with auto. unfold CRltT. unfold CRpos. intros [[e p] H]. revert H. simpl. rewrite CRminus_Qminus. rewrite CRle_Qle. intros. apply Qlt_le_trans with (a + e)%Q. rewrite <-(Qplus_0_r a) at 1. apply Qplus_lt_r... apply Q.Qplus_le_l with (-a)%Q. ring_simplify. rewrite Qplus_comm... Qed. Lemma CRlt_trans (x y z: CR): x < y -> y < z -> x < z. Proof. intros [q H] [r H0]. exists (q+r)%Qpos. rewrite <- (doubleSpeed_Eq z). rewrite <- (doubleSpeed_Eq x). intro e. simpl. unfold Cap_raw; simpl. unfold Cap_raw; simpl. specialize (H ((1#2)*e)%Qpos). simpl in H. specialize (H0 ((1#2)*e)%Qpos). simpl in H0. unfold Cap_raw in H0; simpl in H0. unfold Cap_raw in H0; simpl in H0. unfold Cap_raw in H; simpl in H. unfold Cap_raw in H; simpl in H. apply (Qplus_le_compat _ _ _ _ H) in H0. setoid_replace (- ((1 # 2) * ` e) + - ((1 # 2) * ` e))%Q with (-`e)%Q in H0 by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ H0). ring_simplify. apply Qle_refl. Qed. Lemma CRle_lt_trans (x y z: CR): x <= y -> y < z -> x < z. Proof with auto. intros ? [e ?]. exists e. apply CRle_trans with (z - y)%CR... assert (z - x - (z - y) == y - x)%CR as E by ring. unfold CRle. rewrite E... Qed. Lemma CRlt_le_trans (x y z: CR): x < y -> y <= z -> x < z. Proof with auto. intros [e ?] ?. exists e. apply CRle_trans with (y - x)%CR... assert (z - x - (y - x) == z - y)%CR as E by ring. unfold CRle. rewrite E... Qed. Lemma CRlt_le_weak (x y: CR): (x < y -> x <= y)%CR. Proof. intros. apply CRpos_nonNeg. assumption. Qed. Lemma lower_CRapproximation (x: CR) (e: Qpos): ' (approximate x e - proj1_sig e)%Q <= x. Proof. intros. rewrite <- CRminus_Qminus. apply CRplus_le_r with ('proj1_sig e)%CR. ring_simplify. rewrite CRplus_comm. apply in_CRball, ball_approx_r. Qed. Lemma upper_CRapproximation (x: CR) (e: Qpos): x <= ' (approximate x e + proj1_sig e)%Q. Proof. intros. rewrite <- CRplus_Qplus. apply CRplus_le_r with (-'proj1_sig e)%CR. assert (' approximate x e + 'proj1_sig e - 'proj1_sig e == ' approximate x e)%CR as E by ring. rewrite E. apply (in_CRball (proj1_sig e) x ('approximate x e)), ball_approx_r. Qed. #[global] Hint Immediate lower_CRapproximation upper_CRapproximation. Lemma reverseRegFun : forall (x : CR) (e1 e2 : Qpos), (-(`e1+`e2) <= Qabs (approximate x e1) - Qabs (approximate x e2))%Q. Proof. intros. setoid_replace (Qabs (approximate x e1) - Qabs (approximate x e2))%Q with (-(Qabs (approximate x e2) - Qabs (approximate x e1)))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qopp_le_compat. apply (Qle_trans _ _ _ (Qabs_triangle_reverse _ _)). pose proof (regFun_prf x e2 e1). apply AbsSmall_Qabs in H. rewrite Qplus_comm. exact H. Qed. Lemma CRinv_0_lt_compat : forall (x : CR) (xnz : (x >< 0)%CR), (0 < x -> 0 < CRinvT x xnz)%CR. Proof. intros. unfold CRinvT. destruct xnz. - exfalso. apply (CRlt_irrefl x). exact (CRlt_trans _ _ _ c H). - destruct c as [q c]. pose (CR_b (1#1) x + (1#1))%Qpos as b. exists (Qpos_inv b). rewrite CRopp_0, CRplus_0_r. rewrite CRopp_0, CRplus_0_r in c. intro e. simpl. unfold Cap_raw. simpl. unfold Qinv_modulus. change (Qabs (approximate x (Qpos2QposInf (1 # 1))) + 1 + 1)%Q with (`b). assert (`q <= `b)%Q as qleb. { apply CRle_Qle. apply (CRle_trans c). apply (CRle_trans (CR_b_upperBound (1#1)%Qpos x)). simpl. apply CRle_Qle. rewrite <- Qplus_assoc. apply Qplus_le_r. discriminate. } apply Qmax_case. + intros _. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply Qle_shift_inv_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_shift_div_l. apply Qpos_ispos. rewrite Qmult_1_l. exact qleb. + intros. apply (Qmult_le_l _ _ (approximate x (q * q * ((1 # 2)%Q ↾ eq_refl * e))%Qpos)). exact (Qlt_le_trans _ (`q) _ (Qpos_ispos q) H0). rewrite Qmult_plus_distr_r, Qmult_inv_r. apply (Qmult_le_l _ _ (`b)). apply Qpos_ispos. rewrite Qmult_plus_distr_r. setoid_replace (` b * ((approximate x (q * q * ((1 # 2) * e))%Qpos) * - / ` b))%Q with (-(approximate x (q * q * ((1 # 2)%Q ↾ eq_refl * e))%Qpos))%Q by (unfold equiv, stdlib_rationals.Q_eq; field). 2: apply Qpos_nonzero. rewrite Qmult_1_r. apply (Qle_trans _ (-(`q * `q * `e))). setoid_replace (` b * (approximate x (q * q * ((1 # 2)%Q ↾ eq_refl * e))%Qpos * - ` e))%Q with (-(` b * (approximate x (q * q * ((1 # 2)%Q ↾ eq_refl * e))%Qpos *` e)))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qopp_le_compat. rewrite Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. apply Qpos_mult_le_compat. exact qleb. exact H0. unfold b, CR_b. simpl. rewrite <- (Qabs_pos (approximate x (q * q * ((1 # 2)%Q ↾ eq_refl * e))%Qpos)). apply (Qle_trans _ (-((1#1)+(`q * `q * ((1 # 2) * `e))) + (2#1)))%Q. apply (Qle_trans _ (-(`q * `q * ((1 # 2) * `e)))). apply Qopp_le_compat. apply Qmult_le_l. apply (Qpos_ispos (q*q)). rewrite <- (Qmult_1_l (`e)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. rewrite <- Qplus_0_r. setoid_replace (- ((1#1) + ` q * ` q * ((1 # 2) * ` e)) + (2#1))%Q with (- (` q * ` q * ((1 # 2) * ` e)) + (1#1))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qplus_le_r. discriminate. rewrite <- Qplus_assoc, <- Qplus_assoc, (Qplus_assoc (1#1)). setoid_replace ((1#1)+(1#1))%Q with (2#1)%Q by reflexivity. rewrite (Qplus_comm (2#1)), Qplus_assoc. apply Qplus_le_compat. apply (reverseRegFun x (1#1) (q * q * ((1 # 2) * e))). discriminate. apply (Qle_trans _ (`q)). apply Qpos_nonneg. exact H0. intro abs. rewrite abs in H0. apply (Qle_not_lt _ _ H0), Qpos_ispos. Qed. Lemma CRlt_Qmid (x y: CR): x < y -> sigT (λ q: Q, prod (x < 'q) ('q < y)). Proof with auto. intros [q E]. set (quarter := ((1#4)*q)%Qpos). exists (proj1_sig quarter + (approximate x quarter + proj1_sig quarter))%Q. split. apply CRle_lt_trans with (' (0 + (approximate x quarter + proj1_sig quarter))%Q)%CR... rewrite Qplus_0_l... apply CRlt_Qlt. apply Qplus_lt_l... apply CRlt_le_trans with (x + 'proj1_sig q)%CR. apply CRlt_le_trans with (' (approximate x quarter - proj1_sig quarter + proj1_sig q)%Q)%CR. apply CRlt_Qlt. setoid_replace (proj1_sig q) with (proj1_sig quarter + proj1_sig quarter + proj1_sig quarter + proj1_sig quarter)%Q. ring_simplify. apply Qplus_lt_l. apply Qmult_lt_compat_r... reflexivity. simpl. unfold equiv, stdlib_rationals.Q_eq; ring. rewrite <- CRplus_Qplus. apply CRplus_le_compat... apply CRle_refl. apply CRplus_le_r with (-x)%CR. CRring_replace (x + 'proj1_sig q - x) ('proj1_sig q)... Qed. Lemma CRlt_linear : forall x y z : CR, x < z -> (sum (x < y) (y < z)). Proof. intros. destruct (CRlt_Qmid _ _ H) as [q [H0 H1]]. (* Destructing x < z and dividing the witness by 2 would be faster. *) destruct (CRlt_Qmid _ _ H1) as [r [H2 H3]]. assert (Qlt 0 ((1#2)*(r-q))) as qltr. { rewrite <- (Qmult_0_r (1#2)). apply Qmult_lt_l. reflexivity. unfold Qminus. rewrite <- Qlt_minus_iff. apply Qlt_from_CRlt, H2. } destruct (Qlt_le_dec (approximate y (Qpos2QposInf (exist (Qlt 0) _ qltr))) ((1#2)*(q+r))). - right. refine (CRle_lt_trans _ ('r) _ _ H3). pose proof (upper_CRapproximation y (exist (Qlt 0) _ qltr)). apply (@CRle_trans _ _ _ H4). apply CRle_Qle. apply (Qle_trans _ ((1 # 2) * (q + r) + (1 # 2) * (r - q))). apply Qplus_le_l, Qlt_le_weak, q0. ring_simplify. apply Qle_refl. - left. apply (CRlt_le_trans _ ('q) _ H0). pose proof (lower_CRapproximation y (exist (Qlt 0) _ qltr)). refine (@CRle_trans _ _ _ _ H4). apply CRle_Qle. apply (Qle_trans _ ((1 # 2) * (q + r) - (1 # 2) * (r - q))). ring_simplify. apply Qle_refl. apply Qplus_le_l, q0. Qed. Lemma CRle_not_lt (x y: CR): (x <= y)%CR <-> (y < x -> False)%CR. Proof. split. - intros H [q H0]. apply (CRplus_le_compat _ _ _ _ H) in H0. setoid_replace (y + (x-y))%CR with (x+0) in H0 by (unfold equiv, msp_Equiv; ring). apply CRplus_le_l in H0. apply CRle_Qle in H0. apply (Qle_not_lt _ _ H0 (Qpos_ispos q)). - intros. assert (forall z:CR, (0 < z -> False) -> z <= 0) as zero_irrefl. { clear H x y. intros z H0. unfold CRltT in H0. unfold CRle. apply (@CRnonNeg_wd (-z)). ring. intro q. apply Qnot_lt_le. intro abs. apply H0. clear H0. apply (@CRpos_wd z). ring. simpl in abs. apply Qlt_minus_iff in abs. rewrite Qopp_involutive, Qplus_comm in abs. exists (exist (Qlt 0) _ abs). intro r. simpl. unfold Cap_raw; simpl. pose proof (regFun_prf z q ((1#2)*r)%Qpos). apply AbsSmall_Qabs in H. apply (Qle_trans _ _ _ (Qle_Qabs _)) in H. apply (Qplus_le_l _ _ (approximate z q + `r)). simpl. ring_simplify. apply (Qplus_le_l _ _ (approximate z ((1#2)*r)%Qpos)) in H. ring_simplify in H. rewrite (Qplus_comm (`r)). apply (Qle_trans _ _ _ H). rewrite <- Qplus_assoc, <- Qplus_assoc. apply Qplus_le_r. rewrite Qplus_comm. apply Qplus_le_l. simpl. rewrite <- (Qmult_1_l (`r)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. } assert (0 False)%CR. { intros [q H0]. apply H. clear H zero_irrefl. exists q. unfold CRle. unfold CRle in H0. setoid_replace (x - y - ' 0%Q - ' ` q)%CR with (x - y - ' ` q) in H0 by (unfold equiv, msp_Equiv; ring). exact H0. } apply (CRplus_le_r _ _ (-y)). rewrite CRplus_opp. apply zero_irrefl, H0. Qed. Lemma CRle_alt : forall (x y : CR), x <= y <-> forall e:Qpos, (-(2#1)*proj1_sig e <= approximate y e - approximate x e)%Q. Proof. split. - intros. apply Qnot_lt_le. intro abs. pose proof (lower_CRapproximation x e). pose proof (upper_CRapproximation y e). apply (Qplus_lt_l _ _ (`e + approximate x e)) in abs. ring_simplify in abs. setoid_replace (approximate x e + -(1#1) * `e)%Q with (approximate x e - `e)%Q in abs by (unfold equiv, stdlib_rationals.Q_eq; ring). apply CRlt_Qlt in abs. apply (CRle_lt_trans _ _ _ H1) in abs. clear H1. apply (CRlt_le_trans _ _ _ abs) in H0. apply CRle_not_lt in H. contradiction. exact H0. - intros. intro e. specialize (H ((1#2)*e)%Qpos). simpl in H. setoid_replace (- (2#1) * ((1 # 2) * ` e))%Q with (-`e)%Q in H by (unfold equiv, stdlib_rationals.Q_eq; ring). apply H. Qed. Lemma CRnonNeg_le_0 x: CRnonNeg x <-> 0 <= x. Proof. unfold CRle. assert (x - 0 == x)%CR as E by ring. rewrite E. intuition. Qed. Lemma CRnonNeg_0: CRnonNeg (0)%CR. Proof. unfold CRnonNeg. simpl. intros. apply (Qopp_le_compat 0). apply Qpos_nonneg. Qed. #[global] Hint Immediate CRnonNeg_0. Definition CRle_lt_dec: forall x y, DN ((x <= y)%CR + (y < x)%CR). Proof with auto. intros. apply (DN_fmap (@DN_decisionT (y < x)%CR)). intros [A | B]... left. apply CRle_not_lt in B. exact B. Qed. Definition CRle_dec: forall (x y: CR), DN ((x<=y)%CR + (y<=x)%CR). Proof with auto. intros. apply (DN_fmap (CRle_lt_dec x y)). intros [A | B]... right. apply CRlt_le_weak... Qed. Lemma approximate_CRminus (x y: CR) (e: QposInf): approximate (x - y)%CR e = (approximate x (Qpos2QposInf (1 # 2) * e)%QposInf - approximate y (Qpos2QposInf (1 # 2) * e)%QposInf)%Q. Proof. destruct e; reflexivity. Qed. Lemma CRnonNeg_criterion (x: CR): (forall q, (x <= ' q)%CR -> 0 <= q)%Q -> CRnonNeg x. Proof with auto with qarith. unfold CRle. unfold CRnonNeg. intros. apply Q.Qplus_le_l with (proj1_sig e). ring_simplify. apply H. intros. rewrite approximate_CRminus. simpl. cut (approximate x ((1 # 2) * e0)%Qpos - approximate x e <= proj1_sig e0 + proj1_sig e)%Q. - intros. apply Q.Qplus_le_l with (proj1_sig e0 + approximate x ((1#2)*e0)%Qpos - approximate x e)%Q. simpl. ring_simplify... - apply Qle_trans with (Qabs (approximate x ((1 # 2) * e0)%Qpos - approximate x e))%Q. apply Qle_Qabs. apply Qle_trans with (proj1_sig ((1#2)*e0)%Qpos + proj1_sig e)%Q... pose proof (regFun_prf x ((1#2)*e0)%Qpos e). apply Qball_Qabs in H0... apply Qplus_le_compat. simpl. rewrite <- (Qmult_1_r (proj1_sig e0)) at 2. rewrite (Qmult_comm (proj1_sig e0)). apply Qmult_le_compat_r... apply Qle_refl. Qed. (* Similarly, we can derive non-strict inequalities between reals from non-strict inequalities which approximate it by a rational on one or both sides. *) Lemma Qle_CRle_r (x y: CR): (forall y', y <= ' y' -> x <= ' y') <-> x <= y. Proof with auto. split; intros. 2: apply CRle_trans with y... apply from_DN. apply (DN_bind (CRle_lt_dec x y)). intros [?|W]. apply DN_return... exfalso. destruct (CRlt_Qmid _ _ W) as [w [A B]]. pose proof (H w (CRlt_le_weak _ _ A)). apply (CRle_not_lt x ('w)%CR)... Qed. Lemma Qle_CRle_l (x y: CR): (forall x', ' x' <= x -> ' x' <= y) <-> x <= y. Proof with auto. intros. rewrite CRle_opp. rewrite <- Qle_CRle_r. split; intros. rewrite CRle_opp, CRopp_opp, CRopp_Qopp. apply H. rewrite CRle_opp, CRopp_Qopp, Qopp_opp... rewrite CRle_opp, CRopp_Qopp. apply H. rewrite CRle_opp, CRopp_Qopp, CRopp_opp, Qopp_opp... Qed. Lemma Qle_CRle (x y: CR): (forall x' y', ' x' <= x -> y <= ' y' -> (x' <= y')%Q) <-> x <= y. Proof with auto. split; intros. apply (proj1 (Qle_CRle_l _ _)). intros. apply (proj1 (Qle_CRle_r _ _)). intros. apply CRle_Qle... apply CRle_Qle. apply CRle_trans with x... apply CRle_trans with y... Qed. Lemma CRnonNegQpos : forall e : Qpos, CRnonNeg (' ` e). Proof. intros [e e_pos]; apply CRnonNeg_criterion; simpl. intros q A; apply Qlt_le_weak, Qlt_le_trans with (y := e); trivial. now apply CRle_Qle. Qed. Lemma scale_0 x: scale 0 x == 0. Proof. rewrite <- CRmult_scale. ring. Qed. Lemma scale_CRplus (q: Q) (x y: CR): scale q (x + y) == scale q x + scale q y. Proof. intros. do 3 rewrite <- CRmult_scale. ring. Qed. Lemma scale_CRopp (q: Q) (x: CR): scale q (-x) == - scale q x. Proof. intros. do 2 rewrite <- CRmult_scale. ring. Qed. (** This returs GT if x is clearly greater than e, returns LT if x is clearly less than (-e), and returns Eq otherwise. *) Definition CR_epsilon_sign_dec (e:Qpos) (x:CR) : comparison := let z := approximate x e in match Q.Qle_dec ((2#1) * proj1_sig e) z with | left p => Gt | right _ => match Q.Qle_dec z (-(2#1) * proj1_sig e)%Q with | left p => Datatypes.Lt | right _ => Eq end end. (** This helper lemma reduces a CRpos problem to a sigma type with a simple equality proposition. *) Lemma CR_epsilon_sign_dec_pos : forall x, {e:Qpos | CR_epsilon_sign_dec e x ≡ Gt} -> CRpos x. Proof. intros x [e H]. apply (@CRpos_char e). abstract (unfold CR_epsilon_sign_dec in H; destruct (Q.Qle_dec ((2#1) * proj1_sig e) (approximate x e)) as [A|A]; [assumption | destruct (Q.Qle_dec (approximate x e) (- (2#1) * proj1_sig e)) as [B|B]; discriminate H]). Defined. Lemma CR_epsilon_sign_dec_Gt (e:Qpos) (x:CR) : ((2#1) * proj1_sig e <= approximate x e)%Q -> CR_epsilon_sign_dec e x ≡ Gt. Proof. intros. unfold CR_epsilon_sign_dec. destruct Q.Qle_dec; intuition. Qed. (* nasty because approximate is not Proper *) Lemma CR_epsilon_sign_dec_pos_rev (x : CR) (e : Qpos) : ('proj1_sig e <= x)%CR -> CR_epsilon_sign_dec ((1#4) * e) x ≡ Gt. Proof. intros E. apply CR_epsilon_sign_dec_Gt. apply Qplus_le_l with (-proj1_sig e)%Q. simpl ((2#1) * ` ((1 # 4)%Q ↾ eq_refl * e)%Qpos + - ` e)%Q. setoid_replace ((2#1) * ((1 # 4) * proj1_sig e) + - proj1_sig e)%Q with (-((1#2) * proj1_sig e))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). replace ((1#4) * e)%Qpos with ((1#2) * ((1#2) * e))%Qpos. now apply (E ((1#2) * e))%Qpos. apply Qpos_hprop. now destruct e as [[[ | | ] ?] ?]. Qed. Lemma CRbound_distance_from_below : forall (x : CR) (q : Q) (a b : Qpos), (approximate x a <= q)%Q -> ('q <= x)%CR -> (Qabs (approximate x b - q) <= `a + `b)%Q. Proof. intros. assert (x <= 'q + '`a)%CR. { apply (CRle_trans (upper_CRapproximation x a)). rewrite CRplus_Qplus. apply CRle_Qle. apply Qplus_le_l. exact H. } apply Qabs_case. - intros. pose proof (lower_CRapproximation x b). apply (Qplus_le_l _ _ (q-`b)). ring_simplify. setoid_replace (-(1#1)*`b)%Q with (- ` b)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply CRle_Qle. apply (CRle_trans H3). rewrite <- CRplus_Qplus. exact H1. - intros. pose proof (upper_CRapproximation x b). apply (Qplus_le_r _ _ (approximate x b)). ring_simplify. rewrite (Qplus_comm (approximate x b)), <- Qplus_assoc. apply (Qle_trans _ (0 + (approximate x b + `b))). rewrite Qplus_0_l. apply CRle_Qle. apply (CRle_trans H0), H3. apply Qplus_le_l. apply Qpos_nonneg. Qed. Lemma CRmult_inv_r_bounded : forall (x : CR) (q b : Qpos), (' ` q <= x)%CR -> (`q < `b)%Q -> (/ `q <= `b)%Q -> (forall e:Qpos, approximate x e <= `b)%Q -> (forall e:Qpos, - `b <= approximate x e)%Q -> CRmult_bounded b x (CRinv_pos q x) == 1. Proof. intros x q b pos qltb invqleb xbelow xabove. rewrite CRmult_uncurry_eq. intros e1 e2. simpl. apply AbsSmall_Qabs. assert (forall a c : Q, 0 < c -> Qabs (a*/c-(1#1)) == Qabs (/c) * Qabs (a-c))%Q as absShift. { intros. rewrite <- (Qmult_inv_r c). setoid_replace (a * / c - c * / c)%Q with ((a-c)*/c)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). rewrite Qabs_Qmult. apply Qmult_comm. intro abs. rewrite abs in H. exact (Qlt_irrefl 0 H). } assert (forall i j : Q, i<=j -> Qmax i j == j)%Q as elim_max. { intros. apply (Qle_max_r i j), H. } assert (forall i j : Q, j<=i -> Qmin i j == j)%Q as elim_min. { intros. apply (Qle_min_r i j), H. } assert (QboundAbs b (/ Qmax (` q) (approximate x (Qinv_modulus q ((1 # 2) ↾ eq_refl * e1 * Qpos_inv b)))) == / Qmax (` q) (approximate x (Qinv_modulus q ((1 # 2) ↾ eq_refl * e1 * Qpos_inv b))))%Q. { simpl. rewrite elim_max. apply Qle_min_r. apply (Qle_trans _ (/`q)). 2: exact invqleb. apply Qle_shift_inv_l. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_shift_div_r. apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. rewrite Qmult_1_l. apply Qmax_ub_l. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qmin_glb. apply Qpos_nonneg. apply Qlt_le_weak, Qinv_lt_0_compat. apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. } simpl in H. rewrite H, absShift. clear absShift H. rewrite Qabs_pos. rewrite Qmult_comm. apply Qle_shift_div_r. apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. apply (Qle_trans _ ((1#2)*`e1 * `q + (1#2)*`e1 * `q)). assert (((1 # 2) * ` e1 * / ` b + ` q * ` q * ((1 # 2) * ` e1 * / ` b) <= (1 # 2) * ` e1 * ` q + (1 # 2) * ` e1 * ` q))%Q as dist_ok. { apply Qplus_le_compat. - apply Qmult_le_l. apply (Qpos_ispos ((1#2)*e1)). apply Qle_shift_inv_r. apply Qpos_ispos. rewrite <- (Qmult_inv_r (`q)). apply Qmult_le_l. apply Qpos_ispos. exact invqleb. apply Qpos_nonzero. - rewrite <- Qmult_assoc, (Qmult_comm (`q)). apply Qmult_le_r. apply Qpos_ispos. rewrite Qmult_assoc. apply (Qle_shift_div_r _ (`b)). apply Qpos_ispos. rewrite Qmult_comm. apply Qmult_le_l. apply (Qpos_ispos ((1#2)*e1)). apply Qlt_le_weak, qltb. } apply (Qmax_case (`q)). - unfold Qinv_modulus. intros. unfold Qmult_modulus. assert (QboundAbs b (` q) == `q)%Q as H1. { simpl. transitivity (Qmin (`b) (`q)). apply Qle_max_r. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qmin_glb. apply Qpos_nonneg. apply Qpos_nonneg. apply Qle_min_r. apply Qlt_le_weak, qltb. } rewrite <- H1 at 1. clear H1. apply (Qle_trans _ (Qabs (approximate x ((1 # 2)%Q ↾ eq_refl * e1 * Qpos_inv b)%Qpos - (` q)))). apply QboundAbs_contract. apply (Qle_trans _ ((`q * `q * ((1 # 2) * `e1 * / `b)) + (1 # 2) * `e1 * / `b )). apply (CRbound_distance_from_below x (`q) (q * q * ((1 # 2)%Q ↾ eq_refl * e1 * Qpos_inv b))%Qpos ((1 # 2) * e1 * Qpos_inv b)%Qpos). 2: exact pos. exact H. rewrite Qplus_comm. exact dist_ok. - unfold Qinv_modulus. intros. unfold Qmult_modulus. rewrite elim_min. rewrite elim_max. pose proof (regFun_prf x ((1 # 2)%Q ↾ eq_refl * e1 * Qpos_inv b)%Qpos (q * q * ((1 # 2)%Q ↾ eq_refl * e1 * Qpos_inv b))%Qpos) as H1. apply AbsSmall_Qabs in H1. apply (Qle_trans _ _ _ H1). clear H1. exact dist_ok. apply xabove. apply xbelow. - rewrite <- Qmult_plus_distr_l. rewrite <- Qmult_plus_distr_l. setoid_replace ((1 # 2) + (1 # 2))%Q with (1#1)%Q by reflexivity. rewrite Qmult_1_l. apply (Qle_trans _ ((`e1+`e2)*`q)). rewrite <- Qplus_0_r, Qmult_plus_distr_l. apply Qplus_le_r. apply (Qpos_nonneg (e2*q)). rewrite Qplus_0_r. apply Qmult_le_l. apply (Qpos_ispos (e1+e2)). apply Qmax_ub_l. - apply Qlt_le_weak, Qinv_lt_0_compat. apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. - apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. - intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply xabove. - intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply xbelow. Qed. Lemma CRmult_inv_r_pos : forall (x : CR) (xnz : (x >< 0)%CR), (0 < x)%CR -> (x * CRinvT x xnz == 1). Proof. intros. destruct xnz. exfalso. exact (CRlt_irrefl x (CRlt_trans _ _ _ c H)). destruct c as [q pos]. unfold CRinvT. rewrite CRopp_0, CRplus_0_r in pos. pose (Qpos_max (Qpos_inv q) (CR_b (1#1) x + (1#1))) as b. assert (' (- ` b)%Q <= x) as xlower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) x))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat. apply (Qle_trans _ (proj1_sig (CR_b (1#1)%Qpos x) + (1#1))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply (Qpos_max_ub_r (Qpos_inv q) (CR_b (1#1) x + (1#1))). } assert (x <= '(` b)%Q) as xupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) x))) _ (CR_b_upperBound _ _)). apply CRle_Qle. apply (Qle_trans _ (proj1_sig (CR_b (1#1)%Qpos x) + (1#1))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply (Qpos_max_ub_r (Qpos_inv q) (CR_b (1#1) x + (1#1))). } rewrite <- (CRboundAbs_Eq _ xlower xupper). assert (`q < `b)%Q as qltb. { apply Qlt_from_CRlt. apply (CRle_lt_trans _ _ _ pos). apply (CRle_lt_trans _ _ _ (CR_b_upperBound (1#1) x)). apply CRlt_Qlt. unfold b. apply (Qlt_le_trans _ (proj1_sig (CR_b (1#1) x + (1#1))%Qpos)). rewrite <- Qplus_0_r. apply Qplus_lt_r. reflexivity. apply Qpos_max_ub_r. } assert (/`q <= `b)%Q as invqleb. { apply (Qpos_max_ub_l (Qpos_inv q) (CR_b (1#1) x + (1#1))). } rewrite <- (CRmult_bounded_mult b). apply (CRmult_inv_r_bounded (CRboundAbs b x) q b). - rewrite (CRboundAbs_Eq _ xlower xupper). exact pos. - exact qltb. - exact invqleb. - intros. simpl. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. - intros. simpl. apply Qmax_ub_l. - rewrite (CRboundAbs_Eq _ xlower xupper). intro e. simpl. unfold Cap_raw. simpl. rewrite Qopp_involutive. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply (Qle_trans _ (/ Qmax (` q) (approximate x (Qinv_modulus q ((1 # 2) ↾ eq_refl * e))) + 0)). rewrite Qplus_0_r. apply Qlt_le_weak, Qinv_lt_0_compat. apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. apply Qplus_le_r. apply Qpos_nonneg. - rewrite (CRboundAbs_Eq _ xlower xupper). intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply (Qle_trans _ (/ `q)). 2: apply (Qpos_max_ub_l (Qpos_inv q) (CR_b (1#1) x + (1#1))). apply Qle_shift_inv_r. apply (Qlt_le_trans _ (`q)). apply Qpos_ispos. apply Qmax_ub_l. rewrite Qmult_comm. apply Qle_shift_div_l. apply Qpos_ispos. rewrite Qmult_1_l. apply Qmax_ub_l. Qed. Lemma CRmult_inv_r : forall (x : CR) (xnz : (x >< 0)%CR), x * CRinvT x xnz == 1. Proof. intros. destruct xnz as [neg|pos]. - pose proof neg as otherNeg. destruct neg as [q neg]. unfold CRinvT. setoid_replace (x * - CRinv_pos q (- x))%CR with (-x * CRinv_pos q (- x))%CR by (unfold equiv, msp_Equiv; ring). apply CRopp_lt_compat in otherNeg. apply (CRltT_wd CRopp_0 (reflexivity _)) in otherNeg. pose proof (CRmult_inv_r_pos (-x)%CR (inr otherNeg) otherNeg). pose proof (CRinvT_pos_inv q (inr otherNeg)). destruct otherNeg as [r H1]. unfold CRinvT in H. unfold CRinvT in H0. rewrite H0. exact H. rewrite CRplus_0_l in neg. exact neg. - apply CRmult_inv_r_pos, pos. Qed. (* Type class versions of a lot of the above *) Close Scope CR_scope. Local Opaque CR. #[global] Instance: Ring CR. Proof. apply (rings.from_stdlib_ring_theory CR_ring_theory). Qed. (* We need the (1#4) because CR_epsilon_sign_dec_pos_rev is nasty *) #[global] Instance CRlt: Lt CR := λ x y, ∃ n : nat, CR_epsilon_sign_dec ((1#4) * Qpos_power (2#1) (-cast nat Z n)) (y - x) ≡ Gt. Lemma CR_lt_ltT x y : prod (x < y -> CRltT x y) (CRltT x y -> x < y). Proof. split. intros E. apply CR_epsilon_sign_dec_pos. apply constructive_indefinite_description_nat in E. destruct E as [n En]. now exists ((1#4) * Qpos_power (2#1) (-cast nat Z n))%Qpos. intros. now apply comparison_eq_dec. intros [ε Eε]. exists (Z.nat_of_Z (-Qdlog2 ('ε))). apply CR_epsilon_sign_dec_pos_rev. apply CRle_trans with ('proj1_sig ε); auto. apply CRle_Qle. simpl. destruct (decide (proj1_sig ε ≤ 1)). rewrite Z.nat_of_Z_nonneg. rewrite Z.opp_involutive. apply Qdlog2_spec. now destruct ε. apply Z.opp_nonneg_nonpos. now apply Qdlog2_nonpos. rewrite Z.nat_of_Z_nonpos. now apply Qlt_le_weak, Qnot_le_lt. apply Z.opp_nonpos_nonneg. apply Qdlog2_nonneg. now apply Qlt_le_weak, Qnot_le_lt. Qed. #[global] Instance CRapart: Apart CR := λ x y, x < y ∨ y < x. Lemma CR_apart_apartT x y : prod (x ≶ y -> CRapartT x y) (CRapartT x y -> x ≶ y). Proof. split. intros E. set (f (n : nat) := CR_epsilon_sign_dec ((1#4) * Qpos_power (2#1) (-cast nat Z n))). assert (∃ n, f n (y - x) ≡ Gt ∨ f n (x - y) ≡ Gt) as E2. now destruct E as [[n En] | [n En]]; exists n; [left | right]. apply constructive_indefinite_description_nat in E2. destruct E2 as [n E2]. destruct (comparison_eq_dec (f n (y - x)) Gt) as [En|En]. left. apply CR_epsilon_sign_dec_pos. now exists ((1#4) * Qpos_power (2#1) (-cast nat Z n))%Qpos. right. apply CR_epsilon_sign_dec_pos. exists ((1#4) * Qpos_power (2#1) (-cast nat Z n))%Qpos. destruct E2; tauto. intros n. destruct (comparison_eq_dec (f n (y - x)) Gt); auto. destruct (comparison_eq_dec (f n (x - y)) Gt); tauto. intros [E|E]. left. now apply CR_lt_ltT. right. now apply CR_lt_ltT. Qed. Lemma CReq_not_apart : forall x y : CR, (x == y)%CR <-> (CRapartT x y -> False). Proof. split. - intros. destruct H0. revert c. apply CRle_not_lt. rewrite H. apply CRle_refl. revert c. apply CRle_not_lt. rewrite H. apply CRle_refl. - intros. apply CRle_antisym. split. apply CRle_not_lt. intro abs. contradict H. right. exact abs. apply CRle_not_lt. intro abs. contradict H. left. exact abs. Qed. #[global] Instance: StrongSetoid CR. Proof. split. - intros x E. destruct E; apply CR_lt_ltT in H; exact (CRlt_irrefl x H). - intros x y E. destruct E. right. exact H. left. exact H. - intros x y E z. destruct E. apply CR_lt_ltT in H. apply (@CRlt_linear x z y) in H. destruct H. left. left. apply CR_lt_ltT. exact c. right. left. apply CR_lt_ltT. exact c. apply CR_lt_ltT in H. apply (@CRlt_linear _ z) in H. destruct H. right. right. apply CR_lt_ltT. exact c. left. right. apply CR_lt_ltT. exact c. - split. + intros. apply CRle_antisym. split. apply CRle_not_lt. intro abs. apply H. right. apply CR_lt_ltT. exact abs. apply CRle_not_lt. intro abs. apply H. left. apply CR_lt_ltT. exact abs. + intros H abs. destruct abs. apply CR_lt_ltT in H0. pose proof (@CRltT_wd _ _ H y y (reflexivity _) H0). exact (CRlt_irrefl y H1). apply CR_lt_ltT in H0. symmetry in H. pose proof (@CRltT_wd _ _ H x x (reflexivity _) H0). exact (CRlt_irrefl x H1). Qed. Lemma CRle_scale : forall (a b : CR) (q : Qpos), (a <= b)%CR <-> (scale (`q) a <= scale (`q) b)%CR. Proof. assert (forall (a b:CR) (q:Qpos), (a <= b)%CR -> (scale (`q) a <= scale (`q) b)%CR). { intros. intro e. simpl. unfold Cap_raw; simpl. unfold Qscale_modulus. destruct q, x, Qnum. simpl. - exfalso; inversion q. - simpl. rewrite CRle_alt in H. specialize (H ((Qden # p) * ((1#2)*e))%Qpos). simpl in H. setoid_replace (- (2#1) * ((Zpos Qden # p) * ((1 # 2) * ` e)))%Q with (-`e * (Zpos Qden#p))%Q in H by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qle_shift_div_l in H. 2: reflexivity. apply (Qle_trans _ _ _ H). clear H. unfold Qdiv. setoid_replace (/ (Zpos Qden # p)) with (Zpos p # Qden) by reflexivity. rewrite Qmult_comm. unfold Qminus. rewrite Qmult_plus_distr_r. apply Qplus_le_r. ring_simplify. apply Qle_refl. - exfalso. inversion q. } split. intros. apply H, H0. intros. apply (H _ _ (Qpos_inv q)) in H0. setoid_replace (scale (` (Qpos_inv q)) (scale (` q) a)) with a in H0. setoid_replace (scale (` (Qpos_inv q)) (scale (` q) b)) with b in H0. exact H0. - rewrite <- CRmult_scale, <- CRmult_scale. rewrite <- CRmult_assoc. rewrite CRmult_Qmult. setoid_replace (` (Qpos_inv q) * ` q)%Q with 1%Q. apply CRmult_1_l. simpl. rewrite Qmult_comm, Qmult_inv_r. reflexivity. apply Qpos_nonzero. - rewrite <- CRmult_scale, <- CRmult_scale. rewrite <- CRmult_assoc. rewrite CRmult_Qmult. setoid_replace (` (Qpos_inv q) * ` q)%Q with 1%Q. apply CRmult_1_l. simpl. rewrite Qmult_comm, Qmult_inv_r. reflexivity. apply Qpos_nonzero. Qed. Lemma QboundAbs_mult : forall (a b : Q) (c : Qpos), -(`c*`c) <= QboundAbs c a * QboundAbs c b. Proof. intros. destruct (Qlt_le_dec 0 a). - assert (-`c <= QboundAbs c b) by apply Qmax_ub_l. apply (Qmult_le_compat_r _ _ (QboundAbs c a)) in H. rewrite (Qmult_comm (QboundAbs c b)) in H. refine (Qle_trans _ _ _ _ H). setoid_replace (- ` c * QboundAbs c a)%Q with (-(` c * QboundAbs c a))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qopp_le_compat. apply Qmult_le_l. apply Qpos_ispos. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. apply (Qle_trans _ (Qmin (`c) a)). apply Qmin_glb. apply Qpos_nonneg. apply Qlt_le_weak, q. apply Qmax_ub_r. - rewrite <- (Qopp_involutive (QboundAbs c a * QboundAbs c b)). apply Qopp_le_compat. assert (QboundAbs c b <= `c)%Q. { apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. } apply (Qmult_le_compat_r _ _ (-QboundAbs c a)) in H. rewrite Qmult_comm in H. setoid_replace (-(QboundAbs c a * QboundAbs c b))%Q with (- QboundAbs c a * QboundAbs c b)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ H). apply Qmult_le_l. apply Qpos_ispos. rewrite <- (Qopp_involutive (`c)). apply Qopp_le_compat. apply Qmax_ub_l. apply (Qopp_le_compat _ 0). apply Qmax_lub. apply (Qopp_le_compat 0), Qpos_nonneg. apply (Qle_trans _ a). apply Qmin_lb_r. exact q. Qed. Lemma CRmult_le_0_compat_bounded : forall (a b : CR) (c : Qpos), CRnonNeg b -> CRnonNeg a -> (forall e:Qpos, -`c <= approximate a e) -> (forall e:Qpos, approximate a e <= `c) -> (forall e:Qpos, -`c <= approximate b e) -> (forall e:Qpos, approximate b e <= `c) -> (0 <= CRmult_bounded c a b)%CR. Proof. intros a b c H0 H alower aupper blower bupper. rewrite CRmult_uncurry_eq. intro e. simpl. unfold Cap_raw;simpl. rewrite Qplus_0_r. unfold Qmult_modulus. destruct (Qlt_le_dec (`c*`c) (`e)). apply (Qle_trans _ (-(`c*`c))). apply Qopp_le_compat, Qlt_le_weak, q. apply QboundAbs_mult. specialize (H ((1 # 2) * ((1 # 2) * e) * Qpos_inv c)%Qpos). specialize (H0 ((1 # 2) * ((1 # 2) * e) * Qpos_inv c)%Qpos). apply Qle_minus_iff in H. rewrite Qopp_involutive in H. apply Qle_minus_iff in H0. rewrite Qopp_involutive in H0. apply (Qmult_le_0_compat _ _ H) in H0. clear H. rewrite Qmult_plus_distr_r in H0. rewrite Qmult_plus_distr_l, Qmult_plus_distr_l in H0. assert (forall i j k l:Q, 0 <= i + j + (k + l) -> -(j+k+l) <= i). { intros. apply (Qplus_le_r _ _ (j+k+l)). ring_simplify. rewrite <- Qplus_assoc, (Qplus_comm i) in H. rewrite Qplus_assoc in H. exact H. } apply H in H0. clear H. simpl in H0. assert (forall i j : Q, i<=j -> Qmax i j == j)%Q as elim_max. { intros. apply (Qle_max_r i j), H. } assert (forall i j : Q, j<=i -> Qmin i j == j)%Q as elim_min. { intros. apply (Qle_min_r i j), H. } rewrite elim_min, elim_min, elim_max, elim_max. refine (Qle_trans _ _ _ _ H0). apply Qopp_le_compat. apply (Qle_trans _ ((1#3)*`e + (1#3)*`e + (1#3)*`e)). 2: ring_simplify; apply Qle_refl. apply Qplus_le_compat. apply Qplus_le_compat. - apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult. rewrite Qmult_comm. apply (Qle_trans _ (`c * Qabs ((1 # 2) * ((1 # 2) * ` e) * / ` c))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. pose proof (QboundAbs_abs c (approximate b ((1 # 2) * ((1 # 2) * e) * Qpos_inv c)%Qpos)) as H. simpl in H. rewrite elim_min, elim_max in H. rewrite H. clear H. apply Qmin_lb_r. apply blower. apply bupper. rewrite Qmult_comm, Qabs_pos, <- Qmult_assoc. rewrite (Qmult_comm (/`c)), Qmult_inv_r, Qmult_1_r. 2: apply Qpos_nonzero. rewrite Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply Qmult_le_0_compat. apply Qmult_le_0_compat. discriminate. apply Qmult_le_0_compat. discriminate. apply Qpos_nonneg. apply Qlt_le_weak, Qinv_lt_0_compat, Qpos_ispos. - apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult. apply (Qle_trans _ (`c * Qabs ((1 # 2) * ((1 # 2) * ` e) * / ` c))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. pose proof (QboundAbs_abs c (approximate a ((1 # 2) * ((1 # 2) * e) * Qpos_inv c)%Qpos)). simpl in H. rewrite elim_min, elim_max in H. rewrite H. clear H. apply Qmin_lb_r. apply alower. apply aupper. rewrite Qmult_comm, Qabs_pos, <- Qmult_assoc. rewrite (Qmult_comm (/`c)), Qmult_inv_r, Qmult_1_r. 2: apply Qpos_nonzero. rewrite Qmult_assoc. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply Qmult_le_0_compat. apply Qmult_le_0_compat. discriminate. apply Qmult_le_0_compat. discriminate. apply Qpos_nonneg. apply Qlt_le_weak, Qinv_lt_0_compat, Qpos_ispos. - apply (Qle_trans _ ((1#16)*(`e*/`c*/`c)*`e)). ring_simplify. apply Qle_refl. apply Qmult_le_r. apply Qpos_ispos. apply (Qle_trans _ ((1#16)*(1#1))). 2: discriminate. apply Qmult_le_l. reflexivity. apply Qle_shift_div_r. apply Qpos_ispos. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_1_l. exact q. - apply blower. - apply alower. - apply bupper. - apply aupper. - intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply alower. - intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply aupper. Qed. Lemma CRmult_le_0_compat : forall a b : CR, (0 <= a)%CR -> (0 <= b)%CR -> (0 <= a*b)%CR. Proof. intros. pose (Qpos_max (CR_b (1#1) a) (CR_b (1#1) b)) as c. assert (' (- ` c)%Q <= a)%CR as alower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) a))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat, Qpos_max_ub_l. } assert (a <= '(` c)%Q)%CR as aupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) a))) _ (CR_b_upperBound _ _)). apply CRle_Qle. apply Qpos_max_ub_l. } assert (' (- ` c)%Q <= b)%CR as blower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) b))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat, Qpos_max_ub_r. } assert (b <= '(` c)%Q)%CR as bupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) b))) _ (CR_b_upperBound _ _)). apply CRle_Qle. apply Qpos_max_ub_r. } unfold CRle in H0. rewrite CRopp_0, CRplus_0_r in H0. unfold CRle in H. rewrite CRopp_0, CRplus_0_r in H. rewrite <- (@CRboundAbs_Eq c a) in H. 2: exact alower. 2: exact aupper. rewrite <- (@CRboundAbs_Eq c b) in H0. 2: exact blower. 2: exact bupper. rewrite <- (CRmult_bounded_mult c). 2: exact blower. 2: exact bupper. change (0 <= ucFun2 (CRmult_bounded c) a b)%CR. rewrite <- (@CRboundAbs_Eq c a). rewrite <- (@CRboundAbs_Eq c b). apply (CRmult_le_0_compat_bounded (CRboundAbs c a) (CRboundAbs c b) c). - exact H0. - exact H. - intros. apply Qmax_ub_l. - intros. simpl. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. - intros. apply Qmax_ub_l. - intros. simpl. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. - exact blower. - exact bupper. - exact alower. - exact aupper. Qed. Lemma CRmult_lt_0_compat : forall a b : CR, (0 < a)%CR -> (0 < b)%CR -> (0 < a*b)%CR. Proof. intros a b [q H] [r H0]. exists (q*r). rewrite CRopp_0, CRplus_0_r. rewrite CRopp_0, CRplus_0_r in H. rewrite CRopp_0, CRplus_0_r in H0. pose proof (CRle_scale ('`r) b q) as [H1 _]. specialize (H1 H0). rewrite <- CRmult_scale in H1. rewrite CRmult_Qmult in H1. apply (CRle_trans H1). apply (CRplus_le_r _ _ (-scale (`q) b)%CR). rewrite CRplus_opp. rewrite <- CRmult_scale. setoid_replace (a * b - ' ` q * b)%CR with ((a-'`q)*b)%CR by (unfold equiv, msp_Equiv; ring). apply CRmult_le_0_compat. apply (CRplus_le_l _ _ ('`q)%CR). ring_simplify. exact H. apply (@CRle_trans _ ('`r)%CR). apply CRle_Qle. apply Qpos_nonneg. exact H0. Qed. Lemma CRmult_lt_r : forall (x y z: CR), (0 < z)%CR -> prod (x < y -> x*z < y*z)%CR (x*z < y*z -> x < y)%CR. Proof. assert (forall (x y z: CR), (0 < z)%CR -> (x < y -> x*z < y*z)%CR). { intros. pose proof (@CRplus_lt_r x y (-x)%CR) as [H1 _]. apply H1 in H0. clear H1. apply (CRltT_wd (CRplus_opp x) (reflexivity (y-x)%CR)) in H0. apply (CRmult_lt_0_compat _ _ H) in H0. pose proof (@CRplus_lt_r 0%CR (z*(y-x))%CR (x*z)%CR) as [H1 _]. apply H1 in H0. clear H1. assert (z*(y-x)+x*z == y*z)%CR by ring. pose proof (CRltT_wd (CRplus_0_l (x*z)%CR) H1). apply H2 in H0. exact H0. } split. apply X, H. intros. (* Divide by z in H0. *) pose proof (CRinv_0_lt_compat _ (inr H) H). specialize (X (x*z)%CR (y*z)%CR _ H1 H0). assert (x * z * CRinvT z (inr H) == x)%CR. { rewrite CRmult_assoc, CRmult_inv_r. apply CRmult_1_r. } assert (y * z * CRinvT z (inr H) == y)%CR. { rewrite CRmult_assoc, CRmult_inv_r. apply CRmult_1_r. } apply (CRltT_wd H2 H3) in X. exact X. Qed. Lemma CRmult_lt_l (x y z: CR): (0 < z)%CR -> prod (x < y -> z*x < z*y)%CR (z*x < z*y -> x < y)%CR. Proof. split. - intros. apply (CRltT_wd (CRmult_comm x z) (CRmult_comm y z)). pose proof (CRmult_lt_r x y z H) as [H1 _]. apply H1, H0. - intros. pose proof (CRmult_lt_r x y z H) as [_ H1]. apply H1. clear H1. apply (CRltT_wd (CRmult_comm z x) (CRmult_comm z y)). apply H0. Qed. Lemma CRmult_le_compat_l : forall (x y z: CR), (0 <= z -> x <= y -> z*x <= z*y)%CR. Proof. intros. pose proof (@CRplus_le_r x y (-x)%CR) as [H1 _]. specialize (H1 H0). rewrite CRplus_opp in H1. apply (CRmult_le_0_compat _ _ H) in H1. pose proof (@CRplus_le_l 0%CR (z*(y-x))%CR (x*z)%CR) as [H2 _]. specialize (H2 H1). ring_simplify in H2. rewrite CRmult_comm in H2. exact H2. Qed. Lemma CRmult_lt_0_weaken : forall (x y : CR), (0 < x * y -> 0 <= y -> 0 < x)%CR. Proof. intros. pose proof (CRlt_Qlt 0 1 eq_refl) as zeroLtOne. destruct (CRlt_linear 0%CR x 1%CR zeroLtOne) as [H3|H3]. - exact H3. - clear zeroLtOne. (* Prove that x*y <= y, then 0 < y and then 0 < x. *) apply CRlt_le_weak in H3. pose proof (CRmult_le_compat_l x 1%CR y H0 H3) as H1. rewrite CRmult_1_r in H1. rewrite CRmult_comm in H1. apply (@CRlt_le_trans 0%CR (x*y) y H) in H1. assert (0 == 0*y)%CR by ring. apply (CRltT_wd H2 (reflexivity _)) in H. clear H2. apply (CRmult_lt_r 0%CR x y). exact H1. exact H. Qed. Lemma CRmult_lt_0_cancel_l : forall a b : CR, (0 < a*b)%CR -> prod (a≶0) (b≶0). Proof. pose proof (CRlt_Qlt 0 1 eq_refl). intros. destruct (CRlt_linear _ a _ H) as [H1|H1]. - split. right. apply CR_lt_ltT, H1. (* Divide by a *) right. pose proof (CRinv_0_lt_compat _ (inr H1) H1). pose proof (CRmult_lt_l 0%CR (a*b)%CR _ H2) as [H3 _]. apply H3 in H0. clear H3 H2. assert (CRinvT a (inr H1) * (a * b) == b)%CR. rewrite <- CRmult_assoc. rewrite <- (CRmult_comm a), CRmult_inv_r. apply CRmult_1_l. assert (CRinvT a (inr H1) * 0 == 0)%CR by ring. apply (CRltT_wd H3 H2) in H0. apply CR_lt_ltT, H0. - destruct (CRlt_linear _ b _ H0) as [H2|H2]. + split. 2: right; apply CR_lt_ltT, H2. right. pose proof (CRmult_lt_r 0%CR a b H2) as [_ H3]. apply CR_lt_ltT, H3. assert (0 == 0 * b)%CR by ring. apply (CRltT_wd H4 (reflexivity _)), H0. + (* Both a and b are negative *) assert (a*b == (-a)*(-b))%CR by ring. apply (CRltT_wd (reflexivity 0%CR) H3) in H0. clear H3. assert (0 <= -b)%CR. { apply (CRplus_le_l _ _ b). rewrite CRplus_opp, CRplus_0_r. apply CRle_not_lt. intro abs. pose proof (CRmult_lt_r 1 a b abs)%CR as [_ H3]. apply (CRlt_irrefl a). apply (CRlt_trans _ _ _ H1), H3. assert (b == 1 * b)%CR by ring. apply (CRltT_wd H4 (reflexivity _)), H2. } pose proof (CRmult_lt_0_weaken _ _ H0 H3). split; left. apply CR_lt_ltT, (CRopp_lt_cancel a 0%CR). pose proof CRopp_0. symmetry in H5. apply (CRltT_wd H5 (reflexivity _)), H4. pose proof (@CRplus_lt_r b 0%CR (-b)%CR) as [_ H5]. apply CR_lt_ltT, H5. clear H5. assert (-b == 0-b)%CR by ring. pose proof (CRplus_opp b). symmetry in H6. apply (CRltT_wd H6 H5). clear H6 H5. pose proof (CRmult_lt_l 0 (-b) (-a) H4)%CR as [_ H5]. apply H5. clear H5. assert (0 == (-a) * 0)%CR by ring. apply (CRltT_wd H5 (reflexivity _)), H0. Qed. Lemma CRmult_lt_cancel_l : forall a b c : CR, (a*b < a*c)%CR -> (prod (a≶0) (b≶c)). Proof. intros. pose proof (CRplus_lt_l (a*b) (a*c) (-a*b))%CR as [H0 _]. specialize (H0 H). assert (- a * b + a * b == 0)%CR by ring. assert (- a * b + a * c == a*(c-b))%CR by ring. apply (CRltT_wd H1 H2) in H0. clear H1 H2. apply CRmult_lt_0_cancel_l in H0. destruct H0. split. exact a0. destruct a1. - right. apply CR_lt_ltT in H0. pose proof (CRplus_lt_l (c-b) (0) b)%CR as [H1 _]. specialize (H1 H0). assert (b + (c - b) == c)%CR by ring. assert (b + 0 == b)%CR by ring. apply (CRltT_wd H2 H3) in H1. apply CR_lt_ltT, H1. - left. apply CR_lt_ltT in H0. pose proof (CRplus_lt_l 0 (c-b) b)%CR as [H1 _]. specialize (H1 H0). assert (b + (c - b) == c)%CR by ring. assert (b + 0 == b)%CR by ring. apply (CRltT_wd H3 H2) in H1. apply CR_lt_ltT, H1. Qed. Lemma CRmult_le_0_reg_l : forall a b : CR, ~((0 < a)%CR -> False) -> (0 <= a * b)%CR -> (0 <= b)%CR. Proof. intros. apply CRle_not_lt. intro abs. contradict H; intro H. rewrite <- CRopp_0 in H0. setoid_replace (a*b)%CR with (-(a*-b))%CR in H0 by (unfold equiv, msp_Equiv; ring). apply CRopp_le_cancel in H0. pose proof (CRle_not_lt (a*-b)%CR 0%CR) as [H1 _]. specialize (H1 H0). contradict H1. clear H0. apply CRmult_lt_0_compat. exact H. apply (CRltT_wd CRopp_0 (reflexivity _)). apply CRopp_lt_compat, abs. Qed. Lemma CRmult_eq_0_reg_l : forall x y : CR, (~(y == 0)%CR) -> (x*y == 0)%CR -> (x == 0)%CR. Proof. intros. apply ball_stable. change (~~(x==0)%CR). intros abs. rewrite CReq_not_apart in abs. contradict abs; intro xap0. rewrite CReq_not_apart in H. contradict H; intro yap0. pose proof CRopp_0 as opp0. symmetry in opp0. destruct xap0. - pose proof (CRopp_opp x). symmetry in H. apply (CRltT_wd H opp0) in c. clear H. apply CRopp_lt_cancel in c. destruct yap0. + pose proof (CRopp_opp y). symmetry in H. apply (CRltT_wd H opp0) in c0. clear H. apply CRopp_lt_cancel in c0. pose proof (CRmult_lt_0_compat _ _ c c0) as H. revert H. apply CRle_not_lt. setoid_replace (-x*-y)%CR with (x*y)%CR by (unfold equiv, msp_Equiv; ring). rewrite H0. apply CRle_refl. + pose proof (CRmult_lt_0_compat _ _ c c0) as H. revert H. apply CRle_not_lt. rewrite opp0. setoid_replace (-x*y)%CR with (-(x*y))%CR by (unfold equiv, msp_Equiv; ring). apply CRopp_le_compat. rewrite H0. apply CRle_refl. - destruct yap0. + pose proof (CRopp_opp y). symmetry in H. apply (CRltT_wd H opp0) in c0. clear H. apply CRopp_lt_cancel in c0. pose proof (CRmult_lt_0_compat _ _ c c0) as H. revert H. apply CRle_not_lt. setoid_replace (x*-y)%CR with (-(x*y))%CR by (unfold equiv, msp_Equiv; ring). rewrite H0, <- opp0. apply CRle_refl. + pose proof (CRmult_lt_0_compat _ _ c c0) as H. revert H. apply CRle_not_lt. rewrite H0. apply CRle_refl. Qed. Lemma CRsquare_pos : forall x : CR, (0 <= x*x)%CR. Proof. (* Goal is a negation, use excluded middle x is positive or not. *) intros x. apply CRle_not_lt. intro abs. assert (~(0 <= x)%CR) as H. { intro J. revert abs. apply CRle_not_lt. exact (CRmult_le_0_compat x x J J). } contradict H. apply CRle_not_lt. intro H. revert abs. apply CRle_not_lt. apply CRlt_le_weak in H. setoid_replace (x*x)%CR with (-x*-x)%CR by (unfold equiv, msp_Equiv; ring). apply CRmult_le_0_compat. rewrite <- CRopp_0. apply CRopp_le_compat, H. rewrite <- CRopp_0. apply CRopp_le_compat, H. Qed. #[global] Instance: StrongSetoid_BinaryMorphism CRmult. Proof. split; try apply _. assert (forall a b c d : CR, (a*b < c*d)%CR -> (sum (a≶c) (b≶d))). { intros. pose proof (@CRlt_linear _ (a*d)%CR _ H) as [H0|H0]. right. apply CRmult_lt_cancel_l in H0. apply H0. left. apply (@CRltT_wd (a*d) (d*a) (CRmult_comm _ _) (c*d) (d*c) (CRmult_comm _ _)) in H0. apply CRmult_lt_cancel_l in H0. apply H0. } intros x₁ y₁ x₂ y₂ E. destruct E. apply CR_lt_ltT in H. apply X in H. destruct H. left. exact a. right. exact a. apply CR_lt_ltT, X in H. destruct H. left. destruct a. right. exact H. left. exact H. right. destruct a. right. exact H. left. exact H. Qed. #[global] Instance: FullPseudoOrder CRle CRlt. Proof. split. split; try apply _. - intros x y [E1 E2]. apply CR_lt_ltT in E1. apply CR_lt_ltT in E2. exact (@CRlt_irrefl x (@CRlt_trans x y x E1 E2)). - intros x y E z. apply CR_lt_ltT in E. pose proof (CRlt_linear _ z _ E). destruct H. left. apply CR_lt_ltT. exact c. right. apply CR_lt_ltT. exact c. - intros x y; split. intro E. exact E. intro E. exact E. - split. intros. pose proof (CRle_not_lt x y) as [H0 _]. specialize (H0 H). intro abs. apply CR_lt_ltT in abs. apply H0, abs. intros. apply CRle_not_lt. intro abs. apply H. apply CR_lt_ltT. exact abs. Qed. #[global] Instance: FullPseudoSemiRingOrder CRle CRlt. Proof. apply rings.from_full_pseudo_ring_order. - repeat (split; try apply _). intros. apply CR_lt_ltT. apply CRplus_lt_l. apply CR_lt_ltT. exact H. - split; try apply _. intros. apply (strong_binary_extensionality CRmult), H. - intros. apply CR_lt_ltT. apply CRmult_lt_0_compat. apply CR_lt_ltT, H. apply CR_lt_ltT, H0. Qed. #[global] Program Instance CRinv: Recip CR := λ x, CRinvT x _. Next Obligation. apply CR_apart_apartT. now destruct x. Qed. #[global] Instance: Field CR. Proof. split; try apply _. - apply CR_apart_apartT. right. exists (1#1)%Qpos. simpl. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. - split; try apply _. intros [x Px] [y Py] E. unfold recip, CRinv. simpl. apply (CRinvT_wd (CRinv_obligation_1 (x ↾ Px)) (CRinv_obligation_1 (y ↾ Py))). apply E. - intros x. unfold recip. simpl. destruct x as [x xnz]. apply CRmult_inv_r. Qed. #[global] Instance: StrongSetoid_Morphism inject_Q_CR. Proof. apply strong_setoids.dec_strong_morphism. split; try apply _. Qed. #[global] Instance: StrongSemiRing_Morphism inject_Q_CR. Proof. repeat (split; try apply _); intros; try reflexivity; symmetry. now apply CRplus_Qplus. now apply CRmult_Qmult. Qed. #[global] Instance: StrongInjective inject_Q_CR. Proof. repeat (split; try apply _); intros. apply CR_apart_apartT. now apply Qap_CRap. Qed. #[global] Instance: OrderEmbedding inject_Q_CR. Proof. repeat (split; try apply _); now apply CRle_Qle. Qed. #[global] Instance: StrictOrderEmbedding inject_Q_CR. Proof. split; apply _. Qed. corn-8.20.0/reals/fast/CRArith_alg.v000066400000000000000000000057401473720167500171350ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Ring_theory. From Coq Require Import Setoid. From Coq Require Import QArith. From Coq Require Import Qabs. From Coq Require Import Qround. Require Export CoRN.model.reals.CRreal. Require Import CoRN.metric2.Complete. Require Export CoRN.reals.fast.CRFieldOps. Require Import CoRN.model.rings.Qring. Require Import CoRN.algebra.CRing_Homomorphisms. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.tactics.CornTac. Require Import CoRN.logic.Stability. From Coq Require Import ConstructiveEpsilon. Require Import CoRN.util.Qdlog. Require Import MathClasses.interfaces.abstract_algebra. Require Import MathClasses.interfaces.orders. Require Import CRArith. Local Open Scope CR_scope. Lemma inject_Q_product (l: list Q) : (' cr_Product l) == @cr_Product CRasCRing (map inject_Q_CR l). Proof. induction l. reflexivity. change (' (a * cr_Product l)%Q == @cr_Product CRasCRing (map inject_Q_CR (a :: l))). rewrite <- CRmult_Qmult. rewrite IHl. reflexivity. Qed. Lemma inject_Qred_ap (x y: Q): Qred x <> Qred y -> ' x >< ' y. Proof with auto. intro. apply Qap_CRap. intro. apply H. apply Qred_complete... Qed. Lemma inject_Q_strext : @fun_strext _ CRasCSetoid inject_Q_CR. Proof. intros x y [Hxy|Hxy]. apply: Qlt_not_eq. apply Qnot_le_lt. intros H. absurd ('y <= 'x). rewrite -> leEq_def. auto with *. rewrite -> CRle_Qle. auto. apply ap_symmetric. apply: Qlt_not_eq. apply Qnot_le_lt. intros H. absurd ('x <= 'y). rewrite -> leEq_def. auto with *. rewrite -> CRle_Qle. auto. Qed. Definition inject_Q_csf := Build_CSetoid_fun _ _ _ inject_Q_strext. Lemma inject_Q_hom : RingHom Q_as_CRing CRasCRing. Proof. exists (inject_Q_csf). apply: CRplus_Qplus. intros x y. apply eq_symmetric. apply CRmult_Qmult. apply eq_reflexive. Defined. corn-8.20.0/reals/fast/CRFieldOps.v000066400000000000000000001732041473720167500167510ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.model.lattice.CRlattice. Require Import CoRN.model.totalorder.QMinMax. From Coq Require Import Qabs. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.metric2.ProductMetric. Require Import MathClasses.interfaces.canonical_names. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque Qmin Qmax Qred. (** ** Strict Inequality First we defined positivity. We define positivity to contain a positive rational witness of a lower bound on x. This seems the best way because this witness contains exactly the information needed for functions (such as inverse and logorithm) that have domains restricted to the positive reals. *) Definition CRpos (x:CR) := sig (fun e:Qpos => ' proj1_sig e <= x)%CR. Lemma CRpos_wd : forall x y, (x==y)%CR -> (CRpos x) -> (CRpos y). Proof. intros x y Hxy [e H]. exists e. abstract ( rewrite <- Hxy; assumption ). Defined. (** This is a characterization closer to Bishop's definiton. If we replace [2*e] with [e], the theorem still holds, but it could be very expensive to call. We prefer to avoid that. *) Program Definition CRpos_char (e:Qpos) (x:CR) (H: (2#1)*proj1_sig e <= (approximate x e)) : CRpos x := e. Next Obligation. change (CRle (inject_Q_CR (proj1_sig e)) x). intros a. simpl. unfold Cap_raw. simpl. apply Qle_trans with (-(1#2)* proj1_sig a). rewrite -> Qle_minus_iff. ring_simplify. apply Qmult_le_0_compat; auto with *. rewrite -> Qle_minus_iff. destruct (regFun_prf x e ((1#2)*a)%Qpos) as [_ X]. apply (Qle_trans _ (approximate x ((1 # 2) * a)%Qpos + (1#2)*proj1_sig a + proj1_sig e + - ((2#1)*proj1_sig e))). 2: simpl; ring_simplify; apply Qle_refl. rewrite <- Qle_minus_iff; apply Qle_trans with (approximate x e); try assumption; simpl in X. rewrite -> Qle_minus_iff in X; rewrite -> Qle_minus_iff; autorewrite with QposElim in X. apply (Qle_trans _ _ _ X). ring_simplify. apply Qle_refl. Qed. (** Negative reals are defined similarly. *) Definition CRneg (x:CR) := sig (fun e:Qpos => x <= ' (-proj1_sig e)%Q)%CR. Lemma CRneg_wd : forall x y, (x==y)%CR -> (CRneg x) -> (CRneg y). Proof. intros x y Hxy [e H]. exists e. abstract ( rewrite <- Hxy; assumption ). Defined. Program Definition CRneg_char (e:Qpos) (x:CR) (H: (approximate x e) <= -(2#1)*e): CRneg x := e. Next Obligation. change (x <= '(-proj1_sig e)%Q)%CR. intros a; simpl; unfold Cap_raw; simpl; apply Qle_trans with (-(1#2)*proj1_sig a). rewrite -> Qle_minus_iff; ring_simplify. apply Qmult_le_0_compat; auto with *. rewrite -> Qle_minus_iff. destruct (regFun_prf x e ((1#2)*a)%Qpos) as [X _]. apply (Qle_trans _ ( - proj1_sig e + - approximate x ((1 # 2) * a)%Qpos + (1 # 2) * proj1_sig a + approximate x e + - approximate x e)). 2: simpl; ring_simplify; apply Qle_refl. rewrite <- Qle_minus_iff. apply Qle_trans with (-(2#1)*proj1_sig e); try assumption. simpl in X. rewrite -> Qle_minus_iff in X. rewrite -> Qle_minus_iff. apply (Qle_trans _ _ _ X). simpl. ring_simplify. apply Qle_refl. Qed. (** Strict inequality is defined in terms of positivity. *) Definition CRltT (x y:CR) := CRpos (y-x)%CR. Infix "<" := CRltT : CR_scope. Lemma CRltT_wd : forall x1 x2, (x1==x2 -> forall y1 y2, y1==y2 -> x1 < y1 -> x2 < y2)%CR. Proof. intros x1 x2 Hx y1 y2 Hy H. refine (CRpos_wd _ _). 2:apply H. abstract ( rewrite <- Hx; rewrite <- Hy; reflexivity ). Defined. (** ** Apartness *) Definition CRapartT (x y:CR) := (sum (x < y) (y < x))%CR. Notation "x >< y" := (CRapartT x y) (at level 70, no associativity) : CR_scope. Lemma CRapartT_wd : forall x1 x2, (x1==x2 -> forall y1 y2, y1==y2 -> x1> x2> QposInfinity | (Zpos an) # ad => Qpos2QposInf ((ad # an) * e) | (Zneg an) # ad => Qpos2QposInf ((ad # an) * e) end. Lemma Qscale_modulus_elim : forall (P:QposInf -> Type) (x:Q) (e:Qpos), (x==0 -> P QposInfinity)%Q -> (forall y:Qpos, QAbsSmall (proj1_sig e/proj1_sig y)%Q (x)%Q -> (P y)) -> P (Qscale_modulus x e). Proof. intros P [xn xd] e H1. cut (forall xn:positive, (forall y : Qpos, QAbsSmall (proj1_sig e/proj1_sig y)%Q (Z.pos xn#xd)%Q -> P y) -> P (Qscale_modulus (Z.pos xn # xd) e)). intros H H2. destruct xn as [|xn|xn]. apply H1. constructor. apply H. assumption. apply H. intros y Hy. apply H2. change (Zneg xn # xd)%Q with (-(Zpos xn # xd))%Q. apply QAbsSmall_opp, Hy. clear xn H1. intros xn H2. simpl. apply H2. simpl. unfold QAbsSmall. setoid_replace (` e / ((Zpos xd # xn) * ` e)) with (Zpos xn # xd). split. 2: apply Qle_refl. apply (Qplus_le_l _ _ (Zpos xn # xd)). ring_simplify. apply (Qpos_nonneg ((2#1)*(xn#xd))). unfold Qdiv. rewrite Qinv_mult_distr. rewrite <- (Qmult_comm (/ `e)), Qmult_assoc. rewrite Qmult_inv_r, Qmult_1_l. reflexivity. apply Qpos_nonzero. Qed. Lemma Qscale_modulus_pos (a e: Qpos): exists P, Qscale_modulus (proj1_sig a) e ≡ Qpos2QposInf (exist (Qlt 0) (/ proj1_sig a * proj1_sig e)%Q P). Proof. revert a. intros [[[] ad] P]; try discriminate. simpl. unfold Qpos_inv, Qpos_mult. eauto. Qed. Lemma Qscale_uc_prf (a:Q) : @is_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace (fun b:Q => a*b) (Qscale_modulus a). Proof. revert a. intros [[|an|an] ad] e b0 b1 H. - simpl in *. setoid_replace ((0 # ad)) with 0 by constructor. rewrite Qmult_0_l, Qmult_0_l. apply Qball_Reflexive, Qpos_nonneg. - simpl. simpl in *. unfold Qball in *. unfold QAbsSmall. setoid_replace ((Zpos an # ad) * b0 - (Zpos an # ad) * b1) with (b0 * (Zpos an # ad) - b1 * (Zpos an # ad)) by (unfold equiv, stdlib_rationals.Q_eq; ring). unfold QAbsSmall in H. setoid_replace ((Zpos ad # an) * ` e) with (` e / (Zpos an # ad)) in H. apply (Qball_Qmult_r e (an#ad)) in H. exact H. rewrite Qmult_comm. apply Qmult_comp; reflexivity. - simpl. setoid_replace ((Z.neg an # ad) * b0) with (-((Z.pos an # ad) * b0)). setoid_replace ((Z.neg an # ad) * b1) with (-((Z.pos an # ad) * b1)). apply Qball_opp. simpl in H. unfold Qball, QAbsSmall. setoid_replace ((Zpos an # ad) * b0 - (Zpos an # ad) * b1) with (b0*(Zpos an#ad)-b1*(Zpos an#ad)) by (unfold equiv, stdlib_rationals.Q_eq; ring). setoid_replace ((Zpos ad # an) * ` e) with (` e / (Zpos an # ad)) in H. apply (Qball_Qmult_r e (an#ad)) in H. simpl in H. apply H. rewrite Qmult_comm. apply Qmult_comp; reflexivity. destruct b1, Qnum; reflexivity. destruct b0, Qnum; reflexivity. Qed. (** Scaling by a constant is [Qmult] lifted on one parameter. *) Definition Qscale_uc (a:Q_as_MetricSpace) : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (Qscale_uc_prf a). Definition scale (a:Q) : CR --> CR := Cmap QPrelengthSpace (Qscale_uc a). #[global] Instance Qscale_uc_Proper: Proper (Qeq ==> @msp_eq _) Qscale_uc. Proof. intros x y E. apply ucEq_equiv. intros q. simpl. apply Qball_0. rewrite E. reflexivity. Qed. #[global] Instance scale_Proper: Proper (Qeq ==> @msp_eq (UniformlyContinuousSpace CR CR)) scale. Proof. intros x y E. apply ucEq_equiv. intro z. simpl ucFun. rewrite E. reflexivity. Qed. (** [CRboundAbs] clamps a real number between -c and c where c is rational. *) Definition QboundAbs (c:Qpos) : Q_as_MetricSpace --> Q_as_MetricSpace := uc_compose (QboundBelow_uc (-proj1_sig c)) (QboundAbove_uc (proj1_sig c)). Definition CRboundAbs (c:Qpos) : CR -> CR := Cmap QPrelengthSpace (QboundAbs c). Lemma QboundAbs_absorb: forall (a b:Qpos) (c:Q), proj1_sig a <= proj1_sig b -> QboundAbs b (QboundAbs a c) == QboundAbs a c. Proof. intros a b c H. simpl. rewrite -> Qmin_max_distr_r. setoid_replace (Qmin (proj1_sig b) (-proj1_sig a)) with (-proj1_sig a). rewrite -> Qmax_assoc. rewrite <- Qmin_max_de_morgan. rewrite -> Qmin_assoc. setoid_replace (Qmin (proj1_sig b) (proj1_sig a)) with (proj1_sig a). reflexivity. rewrite <- Qle_min_r. assumption. rewrite <- Qle_min_r. rewrite -> Qle_minus_iff. ring_simplify. destruct a,b. simpl. rewrite <- (Qplus_0_l 0). apply Qplus_le_compat; apply Qlt_le_weak; assumption. Qed. (** Properties of CRboundAbs. *) Lemma CRboundAbs_Eq : forall (a:Qpos) (x:CR), ('(-proj1_sig a)%Q <= x -> x <= ' proj1_sig a -> CRboundAbs a x == x)%CR. Proof. intros a x Ha Hb. unfold CRboundAbs. transitivity (uc_compose (Cmap QPrelengthSpace (QboundBelow_uc (-proj1_sig a))) (Cmap QPrelengthSpace (QboundAbove_uc (proj1_sig a))) x). simpl (Cmap QPrelengthSpace (QboundAbs a) x). simpl ((Cmap QPrelengthSpace (QboundBelow_uc (- ` a)) ∘ Cmap QPrelengthSpace (QboundAbove_uc (` a))) x). repeat rewrite -> Cmap_fun_correct. apply MonadLaw2. simpl ((Cmap QPrelengthSpace (QboundBelow_uc (- ` a)) ∘ Cmap QPrelengthSpace (QboundAbove_uc (` a))) x). change (boundBelow (-proj1_sig a) (boundAbove (proj1_sig a) x) == x)%CR. assert (X:(boundAbove (proj1_sig a) x==x)%CR). rewrite <- CRmin_boundAbove. rewrite <- CRle_min_r. assumption. rewrite -> X. rewrite <- CRmax_boundBelow. rewrite <- CRle_max_r. assumption. Qed. Lemma QboundAbs_elim : forall (z:Qpos) (a:Q) (P:Q->Prop), ((proj1_sig z <= a)%Q -> P (proj1_sig z)) -> ((a <= -proj1_sig z)%Q -> P (- proj1_sig z)%Q) -> (QAbsSmall (proj1_sig z) a -> P (a)) -> P (QboundAbs z a). Proof. intros z a P H1 H2 H3. simpl. apply Qmax_case; apply Qmin_case; intros Z0 Z1; try solve [apply H1;assumption|apply H2;assumption]. elim (Qle_not_lt _ _ Z1). rewrite -> Qlt_minus_iff. ring_simplify. apply (Qpos_ispos ((2#1)*z)). apply H3. split;assumption. Qed. Lemma QboundAbs_abs : forall (z:Qpos) (a:Q), Qabs (QboundAbs z a) == Qmin (Qabs a) (proj1_sig z). Proof. intros. apply QboundAbs_elim. - intros. symmetry. rewrite Qabs_pos, Qabs_pos. apply Qle_min_r, H. apply Qpos_nonneg. apply (Qle_trans _ (`z)). apply Qpos_nonneg. exact H. - intros. symmetry. rewrite Qabs_opp. rewrite (Qabs_pos (`z)). apply Qle_min_r. rewrite Qabs_neg, <- Qopp_involutive. apply Qopp_le_compat, H. apply (Qle_trans _ _ _ H). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. - intros. symmetry. apply Qle_min_l. apply AbsSmall_Qabs in H. exact H. Qed. (** The modulus of continuity for multiplication depends on the bound, c, on the second argument. *) Definition Qmult_modulus (c:Qpos)(e:Qpos) : QposInf := Qpos2QposInf (e * Qpos_inv c). Lemma Qmult_uc_prf (c:Qpos) : @is_UniformlyContinuousFunction Q_as_MetricSpace (Q_as_MetricSpace --> Q_as_MetricSpace) (fun a:Q => uc_compose (Qscale_uc a) (QboundAbs c)) (Qmult_modulus c). Proof with simpl in *; auto with *. intros e a0 a1 H. split. apply Qpos_nonneg. intro b. simpl in *. set (b' := Qmax (- proj1_sig c) (Qmin (proj1_sig c) b)). repeat rewrite -> (fun x => Qmult_comm x b'). apply Qscale_uc_prf. assert (QposEq (e * Qpos_inv c) (Qpos_inv c*e)%Qpos) by (unfold QposEq; simpl; ring). apply (ball_wd _ H0 _ _ (reflexivity _) _ _ (reflexivity _)) in H. clear H0. apply ball_ex_weak_le with (Qpos_inv c*e)%Qpos;[|assumption]. unfold b'. destruct c as [[cn cd] cpos]. destruct cn as [|cn|cn]. inversion cpos. 2: inversion cpos. apply Qmax_case. intros. apply Qle_refl. simpl. apply Qmin_case. intros. apply Qle_refl. intros H1 H2. destruct b as [[|bn|bn] bd]... - apply Qmult_le_r. destruct e; exact q. apply Qle_shift_inv_r. reflexivity. rewrite <- Qmult_1_l in H1. apply Qle_shift_div_l in H1. apply (Qle_trans _ _ _ H1). rewrite Qmult_comm. apply Qmult_le_l. reflexivity. apply Z.le_refl. reflexivity. - apply Qmult_le_r. destruct e; exact q. apply Qle_shift_inv_r. reflexivity. apply Qopp_le_compat in H2. rewrite Qopp_involutive in H2. rewrite <- Qmult_1_l in H2. apply Qle_shift_div_l in H2. 2: reflexivity. apply (Qle_trans _ _ _ H2). rewrite Qmult_comm. apply Qmult_le_l. reflexivity. apply Z.le_refl. Qed. (* begin hide *) Arguments Qmult_uc_prf : clear implicits. (* end hide *) Definition Qmult_uc (c:Qpos) : Q_as_MetricSpace --> Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (Qmult_uc_prf c). (** This multiplication function is correct when yBound is a bound on the absolute value of the second CR argument. *) Definition CRmult_bounded (yBound : Qpos) : CR --> CR --> CR := Cmap2 QPrelengthSpace QPrelengthSpace (Qmult_uc yBound). #[global] Instance: Proper (QposEq ==> @msp_eq _) Qmult_uc. Proof. intros e1 e2 E. simpl. split. discriminate. intro a. simpl. split. discriminate. intro b. simpl. apply Qball_0. unfold QposEq in E. rewrite E. reflexivity. Qed. #[global] Instance CRmult_bounded_wd : Proper (QposEq ==> @msp_eq _) CRmult_bounded. Proof. intros e1 e2 E. simpl. split. discriminate. intro x1. split. discriminate. intro x2. simpl (CRmult_bounded e1 x1 x2). simpl (CRmult_bounded e2 x1 x2). rewrite E. reflexivity. Qed. (** CR_b computes a rational bound on the absolute value of x *) Lemma CR_b_pos (e : Qpos) (x : CR) : 0 < Qabs (approximate x e) + proj1_sig e. Proof. apply (Qle_lt_trans _ (Qabs (approximate x e) + 0)). rewrite Qplus_0_r. apply Qabs_nonneg. apply Qplus_lt_r, Qpos_ispos. Qed. Definition CR_b (e:Qpos) (x:CR) : Qpos := exist (Qlt 0) (Qabs (approximate x e) + proj1_sig e) (CR_b_pos _ _). Lemma CR_b_lowerBound : forall e x, (' (-proj1_sig (CR_b e x))%Q <= x)%CR. Proof. intros e x e'. unfold CR_b. simpl. unfold Cap_raw. simpl. rewrite -> Qle_minus_iff, Qopp_involutive, Qopp_involutive. destruct (regFun_prf x ((1#2)*e')%Qpos e) as [H _]. simpl in H. rewrite -> Qle_minus_iff in H. ring_simplify in H. apply (Qle_trans _ _ _ H). rewrite -> Qle_minus_iff. ring_simplify. clear H. apply Qabs_case; intros H. apply (Qle_trans _ (approximate x e + 0)). rewrite Qplus_0_r. exact H. rewrite <- Qplus_assoc. apply Qplus_le_r. apply (Qle_trans _ (0+approximate x e)). rewrite Qplus_0_l. exact H. apply Qplus_le_l. apply (Qpos_nonneg ((1#2)*e')). ring_simplify. apply (Qpos_nonneg ((1#2)*e')). Qed. Lemma CR_b_upperBound : forall e x, (x <= 'proj1_sig (CR_b e x))%CR. Proof. intros e x e'. unfold CR_b. simpl. unfold Cap_raw. simpl. rewrite -> Qle_minus_iff. ring_simplify. destruct (regFun_prf x ((1#2)*e')%Qpos e) as [_ H]. simpl in H. rewrite -> Qle_minus_iff in H. ring_simplify in H. eapply Qle_trans. apply H. rewrite -> Qle_minus_iff. ring_simplify. clear H. apply Qabs_case; intros H. ring_simplify. apply (Qpos_nonneg ((1#2)*e')). apply (Qplus_le_r _ _ ((2#1)*approximate x e)). simpl. ring_simplify. apply (Qle_trans _ 0). rewrite <- (Qmult_0_r (2#1)). apply Qmult_le_l. reflexivity. exact H. apply (Qpos_nonneg ((1#2)*e')). Qed. (** This version of multiply computes a bound on the second argument just in time. It should be avoided in favour of the bounded version whenever possible. *) #[global] Instance CRmult: Mult CR := λ x y, ucFun2 (CRmult_bounded (CR_b (1#1) y)) x y. Infix "*" := CRmult : CR_scope. Lemma CRmult_bounded_weaken : forall (c1 c2:Qpos) x y, ((' (-proj1_sig c1)%Q <= y) -> (y <= ' proj1_sig c1) -> (proj1_sig c1 <= proj1_sig c2)%Q -> CRmult_bounded c1 x y == CRmult_bounded c2 x y)%CR. Proof. intros c1 c2 x y Hc1a Hc1b Hc2. assert (Hy:=CRboundAbs_Eq _ Hc1a Hc1b). set (y':= (CRboundAbs c1 y)) in *. transitivity (ucFun2 (CRmult_bounded c2) x y'); [|rewrite -> Hy;reflexivity]. assert (H:forall x:Qpos, proj1_sig (x*c1*Qpos_inv c2)%Qpos <= proj1_sig x). { intros a. simpl. rewrite <- (Qmult_1_r (`a)), <- Qmult_assoc, <- Qmult_assoc. apply Qmult_le_l. destruct a; exact q. rewrite Qmult_1_l. apply Qle_shift_div_r. destruct c2; exact q. rewrite Qmult_1_l. exact Hc2. } change (ucFun2 (CRmult_bounded c1) x y == ucFun2 (CRmult_bounded c2) x y')%CR. rewrite <- (QreduceApprox_Eq x). set (x''':=(QreduceApprox x)). set (x':=faster x''' (fun x => (x * c1 * Qpos_inv c2)%Qpos) H). transitivity (ucFun2 (CRmult_bounded c1) x' y). unfold x'. rewrite -> fasterIsEq. reflexivity. apply regFunEq_equiv, regFunEq_e; intros e. intros. simpl. do 3 (unfold Cap_raw; simpl). assert (X:=fun c => QboundAbs_absorb _ _ c Hc2). unfold QboundAbs in X. simpl in X. rewrite -> X. clear X. assert (eq (Qpos_red ((1 # 2) * e * Qpos_inv c1 * c1 * Qpos_inv c2)) (Qpos_red ((1 # 2) * e * Qpos_inv c2))). { apply Qpos_red_eq. unfold QposEq. simpl. field. split. intro abs. destruct c2. simpl in abs. apply (Qlt_not_le _ _ q). rewrite abs. apply Qle_refl. intro abs. destruct c1. simpl in abs. apply (Qlt_not_le _ _ q). rewrite abs. apply Qle_refl. } simpl. simpl in H0. rewrite H0. do 2 rewrite QposInf_bind_id. apply Qball_Reflexive. apply (Qpos_nonneg (e+e)). Qed. Lemma CRmult_bounded_mult : forall (c:Qpos) (x y:CR), (' (-proj1_sig c)%Q <= y -> y <= ' proj1_sig c -> CRmult_bounded c x y == x*y)%CR. Proof. intros c x y Hc1 Hc2. unfold CRmult. set (d:=(CR_b (1 # 1) y)). destruct (Qle_total (proj1_sig c) (proj1_sig d)). apply CRmult_bounded_weaken; assumption. symmetry. apply CRmult_bounded_weaken; try assumption. apply CR_b_lowerBound. apply CR_b_upperBound. Qed. (* begin hide *) Add Morphism CRmult with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as CRmult_wd. Proof. intros x1 x2 Hx y1 y2 Hy. unfold CRmult. set (c:=(CR_b (1 # 1) y1)). set (d:=(CR_b (1 # 1) y2)). rewrite -> Hx. rewrite -> Hy. unfold d. apply CRmult_bounded_mult; rewrite <- Hy. apply CR_b_lowerBound. apply CR_b_upperBound. Qed. (* end hide *) Lemma CRmult_scale : forall (a:Q) (y:CR), ((' a)*y==scale a y)%CR. Proof. intros a y. unfold CRmult. unfold CRmult_bounded. unfold ucFun2. unfold Cmap2. unfold inject_Q_CR. change (msp_eq (Cap_fun QPrelengthSpace (Cmap_fun QPrelengthSpace (Qmult_uc (CR_b (1 ↾ eq_refl) y)) (Cunit_fun Q_as_MetricSpace a)) y) (Cmap_fun QPrelengthSpace (Qscale_uc a) y)). rewrite -> Cap_fun_correct. repeat rewrite -> Cmap_fun_correct. rewrite -> MonadLaw3. rewrite -> StrongMonadLaw1. change (msp_eq (Cmap_slow_fun (Qscale_uc a ∘ QboundAbs (CR_b (1 ↾ eq_refl) y)) y) (Cmap_slow_fun (Qscale_uc a) y)). transitivity (uc_compose (Cmap QPrelengthSpace (Qscale_uc a)) (Cmap QPrelengthSpace (QboundAbs (CR_b (1#1) y))) y). simpl ((Cmap QPrelengthSpace (Qscale_uc a) ∘ Cmap QPrelengthSpace (QboundAbs (CR_b (1 ↾ eq_refl) y))) y). repeat rewrite -> Cmap_fun_correct. apply MonadLaw2. simpl ((Cmap QPrelengthSpace (Qscale_uc a) ∘ Cmap QPrelengthSpace (QboundAbs (CR_b (1 ↾ eq_refl) y))) y). repeat rewrite -> Cmap_fun_correct. change (Cmap_slow (Qscale_uc a) (Cmap_slow_fun (QboundAbs (CR_b (1 # 1) y)) y) == Cmap_slow (Qscale_uc a) y)%CR. apply uc_wd. rewrite <- (Cmap_fun_correct (Y:=Q_as_MetricSpace) QPrelengthSpace). apply CRboundAbs_Eq. apply CR_b_lowerBound. apply CR_b_upperBound. Qed. (* begin hide *) #[global] Hint Rewrite CRmult_scale : CRfast_compute. (* end hide *) Lemma scale_Qmult : forall a b:Q, (scale a ('b)=='(a*b)%Q)%CR. Proof. intros a b. unfold scale. change (msp_eq (Cmap_fun QPrelengthSpace (Qscale_uc a) (' b)%CR) (' (a * b)%Q)%CR). rewrite -> Cmap_fun_correct. apply MonadLaw3. Qed. (* begin hide *) #[global] Hint Rewrite scale_Qmult : CRfast_compute. (* end hide *) (** ** Inverse The modulus of continuity for inverse depends on a rational bound away from 0 of x. *) Definition Qinv_modulus (c:Qpos) (e:Qpos) : Qpos := (c*c*e)%Qpos. Lemma Qpos_Qmax : forall (a:Qpos) (b:Q), 0 /(Qmax (proj1_sig c) a) ) (Qinv_modulus c). Proof. intros e a0 a1 Ha. simpl in *. unfold Qball in *. assert (forall (a:Qpos) (b:Q), 0 < Qmax (`a) b) as max_pos. { intros. apply (Qlt_le_trans _ (`a)). destruct a; exact q. apply Qmax_ub_l. } assert ( 0 < Qmax (` c) a0 * Qmax (` c) a1). { apply (Qle_lt_trans _ (Qmax (`c) a0 * 0)). rewrite Qmult_0_r. apply Qle_refl. apply Qmult_lt_l. apply max_pos. apply max_pos. } apply AbsSmall_Qabs. setoid_replace (/ Qmax (` c) a0 - / Qmax (` c) a1) with ((Qmax (` c) a1 - Qmax (` c) a0) / (Qmax (` c) a0 * Qmax (` c) a1)). 2: unfold equiv, stdlib_rationals.Q_eq; field. unfold Qdiv. rewrite Qabs_Qmult. rewrite (Qabs_pos (/ ( Qmax (` c) a0 * Qmax (` c) a1))). 2: apply Qlt_le_weak, Qinv_lt_0_compat, H. apply Qle_shift_div_r. exact H. apply (Qle_trans _ _ _ (Qmax_contract _ _ _)). apply AbsSmall_Qabs in Ha. rewrite Qabs_Qminus. apply (Qle_trans _ _ _ Ha). rewrite (Qmult_comm (`e)). apply Qmult_le_r. apply Qpos_ispos. apply (Qle_trans _ (`c * Qmax (`c) a1)). apply Qmult_le_l. apply Qpos_ispos. apply Qmax_ub_l. apply Qmult_le_r. apply max_pos. apply Qmax_ub_l. split; intro abs. specialize (max_pos c a1). rewrite abs in max_pos. exact (Qlt_irrefl 0 max_pos). specialize (max_pos c a0). rewrite abs in max_pos. exact (Qlt_irrefl 0 max_pos). Qed. Arguments Qinv_pos_uc_prf : clear implicits. Definition Qinv_pos_uc (c:Qpos) : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (Qinv_pos_uc_prf c). Lemma Qinv_pos_uc_wd : forall (c1 c2:Qpos), (proj1_sig c1 <= proj1_sig c2) -> forall x, (proj1_sig c2 <= x) -> msp_eq (Qinv_pos_uc c1 x) (Qinv_pos_uc c2 x). Proof. intros c1 c2 Hc x Hx. simpl. setoid_replace (Qmax (proj1_sig c2) x) with x by (rewrite <- Qle_max_r; assumption). setoid_replace (Qmax (proj1_sig c1) x) with x. apply Qball_Reflexive. discriminate. rewrite <- Qle_max_r. apply Qle_trans with (proj1_sig c2); assumption. Qed. (** [CRinv_pos] works for inputs greater than c *) Definition CRinv_pos (c:Qpos) : CR --> CR := (Cmap QPrelengthSpace (Qinv_pos_uc c)). Lemma CRinv_pos_weaken : forall (c1 c2:Qpos), proj1_sig c1 <= proj1_sig c2 -> forall (x:CR), (' proj1_sig c2 <= x -> CRinv_pos c1 x == CRinv_pos c2 x)%CR. Proof. intros c1 c2 Hc x Hx. assert (X:((boundBelow (proj1_sig c2) x)==x)%CR). rewrite <- CRmax_boundBelow. rewrite <- CRle_max_r. assumption. rewrite <- X. rewrite <- (QreduceApprox_Eq x). pose (f:=(fun e:Qpos => (c1*c1*Qpos_inv c2*Qpos_inv c2)*e)%Qpos). assert (Y:forall e:Qpos, proj1_sig (f e) <= proj1_sig e). { intros e. unfold f. simpl. rewrite <- (Qmult_1_l (`e)) at 2. apply Qmult_le_r. apply Qpos_ispos. apply Qle_shift_div_r. apply Qpos_ispos. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_1_l. apply (Qle_trans _ (`c1*`c2)). apply Qmult_le_l. apply Qpos_ispos. exact Hc. apply Qmult_le_r. apply Qpos_ispos. exact Hc. } transitivity (CRinv_pos c2 (boundBelow (proj1_sig c2) (faster (QreduceApprox x) f Y))). apply regFunEq_equiv, regFunEq_e. intros e. assert (Z:=Qinv_pos_uc_wd _ _ Hc). simpl in Z. simpl. rewrite -> Z;[|apply Qmax_ub_l]. unfold Qinv_modulus. replace (Qpos_red (c1 * c1 * e)) with (Qpos_red (f (c2 * c2 * e)%Qpos)); [apply ball_refl|]. apply (Qpos_nonneg (e+e)). apply Qpos_red_eq. unfold f. unfold QposEq. simpl. field. apply Qpos_nonzero. rewrite -> fasterIsEq. reflexivity. Qed. #[global] Instance CRinv_pos_uc_Proper : Proper (QposEq ==> @msp_eq _ ==> @msp_eq _) Qinv_pos_uc. Proof. intros [c1 ?] [c2 ?] E x1 x2 F. unfold QposEq in E. simpl in *. apply Qball_0. apply Qball_0 in F. rewrite E, F. reflexivity. Qed. #[global] Instance: Proper (QposEq ==> @msp_eq _) CRinv_pos. Proof. intros c1 c2 E. apply ucEq_equiv. intro x. simpl (CRinv_pos c1 x). simpl (CRinv_pos c2 x). setoid_replace (Qinv_pos_uc c1) with (Qinv_pos_uc c2). easy. apply ucEq_equiv. intros y. now apply CRinv_pos_uc_Proper. Qed. Lemma CRinv_pos_Qinv : forall (c:Qpos) x, (proj1_sig c <= x)%Q -> (CRinv_pos c (' x) == (' (/x)))%CR. Proof. intros c x H. apply regFunEq_equiv, regFunEq_e. intros e. simpl. setoid_replace (Qmax (proj1_sig c) x) with x. apply Qball_Reflexive. apply (Qpos_nonneg (e+e)). rewrite <- Qle_max_r. assumption. Qed. (** [CRinvT] works for inputs apart from 0 *) Definition CRinvT (x:CR)(x_: (x >< 0)%CR) : CR. Proof. revert x_. intros [[c H]|[c H]]. exact ((-(CRinv_pos c (-x)))%CR). exact (CRinv_pos c x). Defined. Arguments CRinvT : clear implicits. Lemma CRinvT_pos_inv : forall (c:Qpos) (x:CR) x_, ('proj1_sig c <= x -> CRinv_pos c x == CRinvT x x_)%CR. Proof. intros c x [[e He]|[e He]] H. assert (X:(' proj1_sig e <= -x)%CR). rewrite <- (doubleSpeed_Eq x). intros d. eapply Qle_trans. apply He. simpl. do 2 (unfold Cap_raw;simpl). ring_simplify. apply Qle_refl. assert (' proj1_sig c <= ' (- proj1_sig e)%Q)%CR. eapply CRle_trans. apply H. intros d. eapply Qle_trans. apply X. simpl. do 2 (unfold Cap_raw;simpl). rewrite -> Qle_minus_iff. ring_simplify. apply Qle_refl. assert (0 < proj1_sig c) as cpos. { destruct c; exact q. } elim (Qlt_not_le _ _ cpos). assert (Y:=H0 (e)%Qpos). simpl in Y. do 2 (unfold Cap_raw in Y ;simpl in Y). rewrite -> Qle_minus_iff in Y. ring_simplify in Y. rewrite -> Qle_minus_iff. ring_simplify;assumption. assert (' proj1_sig e <= x)%CR. rewrite <- (doubleSpeed_Eq x). intros d. eapply Qle_trans. apply He. simpl. do 2 (unfold Cap_raw;simpl). ring_simplify. apply Qle_refl. destruct (Qle_total (proj1_sig c) (proj1_sig e)); [|symmetry]; apply CRinv_pos_weaken; assumption. Qed. Lemma CRinvT_wd : forall (x y:CR) x_ y_, (x == y -> CRinvT x x_ == CRinvT y y_)%CR. Proof. assert (X:forall x, (0 + x == x)%CR). intros x. transitivity (doubleSpeed x);[|apply doubleSpeed_Eq]. apply regFunEq_equiv, regFunEq_e. intros e. simpl. unfold Cap_raw; simpl. rewrite Qplus_0_l. apply Qball_Reflexive. apply (Qpos_nonneg (e+e)). assert (Y:forall x, (x + - 0 == x)%CR). intros x. transitivity (doubleSpeed x);[|apply doubleSpeed_Eq]. apply regFunEq_equiv, regFunEq_e. intros e. simpl. unfold Cap_raw; simpl. rewrite Qplus_0_r. apply Qball_Reflexive. apply (Qpos_nonneg (e+e)). intros x y [[c x_]|[c x_]] [[d y_]|[d y_]] H. change (-(CRinv_pos c (-x))== (-(CRinv_pos d (-y))))%CR. rewrite -> H in *. rewrite -> X in *. intros. apply CRopp_wd. destruct (Qle_total (proj1_sig c) (proj1_sig d)); [|symmetry]; apply CRinv_pos_weaken; try assumption. assert (0 < proj1_sig c) as cpos. { destruct c; exact q. } elim (Qlt_not_le _ _ cpos). rewrite -> X in *. rewrite -> Y in *. rewrite -> H in *. assert (Z:=Qplus_le_compat _ _ _ _ (x_ ((1#2)*d)%Qpos) (y_ ((1#2)*d)%Qpos)). simpl in Z. unfold Cap_raw in Z; simpl in Z. autorewrite with QposElim in Z. rewrite -> Qle_minus_iff in Z. ring_simplify in Z. rewrite -> Qle_minus_iff. ring_simplify. assumption. assert (0 < proj1_sig c) as cpos. { destruct c; exact q. } elim (Qlt_not_le _ _ cpos). rewrite -> X in *. rewrite -> Y in *. rewrite -> H in *. assert (Z:=Qplus_le_compat _ _ _ _ (x_ ((1#2)*d)%Qpos) (y_ ((1#2)*d)%Qpos)). simpl in Z. unfold Cap_raw in Z; simpl in Z. autorewrite with QposElim in Z. rewrite -> Qle_minus_iff in Z. ring_simplify in Z. rewrite -> Qle_minus_iff. ring_simplify. assumption. change (CRinv_pos c x== (CRinv_pos d y))%CR. rewrite -> H in *. rewrite -> Y in *. destruct (Qle_total (proj1_sig c) (proj1_sig d)); [|symmetry]; apply CRinv_pos_weaken; try assumption. Qed. Lemma CRinvT_irrelevant : forall x x_ x__, (CRinvT x x_ == CRinvT x x__)%CR. Proof. intros. apply CRinvT_wd. reflexivity. Qed. (* Non-curried equivalent version of multiplication. *) Lemma QboundAbs_contract : forall (c : Qpos) (j k : Q), Qabs (QboundAbs c j - QboundAbs c k) <= Qabs (j-k). Proof. intros. apply QboundAbs_elim. - intros. apply QboundAbs_elim. + intros. unfold Qminus. rewrite Qplus_opp_r. apply Qabs_nonneg. + intros. unfold Qminus. rewrite Qopp_involutive. rewrite Qabs_pos, Qabs_pos. apply Qplus_le_compat. exact H. rewrite <- Qopp_involutive. apply Qopp_le_compat. exact H0. apply (Qle_trans _ (`c + `c)). apply (Qpos_nonneg (c+c)). apply Qplus_le_compat. exact H. rewrite <- Qopp_involutive. apply Qopp_le_compat. exact H0. apply (Qpos_nonneg (c+c)). + intros [H0 H1]. rewrite Qabs_pos. 2: unfold Qminus; rewrite <- Qle_minus_iff; exact H1. apply (Qle_trans _ (j-k)). apply Qplus_le_l. exact H. apply Qle_Qabs. - intros. apply QboundAbs_elim. + intros. setoid_replace (- `c - `c) with (-(`c+`c)) by (unfold equiv, stdlib_rationals.Q_eq; ring). rewrite Qabs_opp. rewrite Qabs_pos. 2: apply (Qpos_nonneg (c+c)). rewrite Qabs_Qminus. rewrite Qabs_pos. apply Qplus_le_compat. exact H0. rewrite <- Qopp_involutive. apply Qopp_le_compat. exact H. apply (Qle_trans _ (`c + `c)). apply (Qpos_nonneg (c+c)). apply Qplus_le_compat. exact H0. rewrite <- Qopp_involutive. apply Qopp_le_compat. exact H. + intros. unfold Qminus. rewrite Qopp_involutive, Qplus_comm, Qplus_opp_r. apply Qabs_nonneg. + intros [H0 H1]. setoid_replace (- `c - k) with (-(`c+k)) by (unfold equiv, stdlib_rationals.Q_eq; ring). rewrite Qabs_opp. rewrite Qabs_pos, Qabs_Qminus. apply (Qle_trans _ (k-j)). rewrite Qplus_comm. apply Qplus_le_r. rewrite <- Qopp_involutive. apply Qopp_le_compat. exact H. apply Qle_Qabs. apply (Qplus_le_l _ _ (-`c)). ring_simplify. ring_simplify in H0. exact H0. - intros [H0 H1]. apply QboundAbs_elim. + intros. rewrite Qabs_Qminus, Qabs_pos. rewrite Qabs_Qminus, Qabs_pos. apply Qplus_le_l, H. unfold Qminus. rewrite <- Qle_minus_iff. exact (Qle_trans _ _ _ H1 H). unfold Qminus. rewrite <- Qle_minus_iff. exact H1. + intros. unfold Qminus. rewrite Qopp_involutive, Qabs_pos. apply (Qle_trans _ (j-k)). apply Qplus_le_r. rewrite <- Qopp_involutive. apply Qopp_le_compat. exact H. apply Qle_Qabs. apply (Qplus_le_l _ _ (`c)) in H0. ring_simplify in H0. rewrite Qplus_comm. exact H0. + intros [H2 H3]. apply Qle_refl. Qed. Lemma Qmult_uc_uncurry (c:Qpos) : @is_UniformlyContinuousFunction (ProductMS Q_as_MetricSpace Q_as_MetricSpace) Q_as_MetricSpace (fun ab => QboundAbs c (fst ab) * QboundAbs c (snd ab)) (fun e => Qmult_modulus c ((1#2)*e)). Proof. assert (forall i j k l : Q, Qabs (i*j-k*l) <= Qabs j * Qabs(i-k) + Qabs(j-l)*Qabs k)%Q as multMaj. { intros. setoid_replace (i*j-k*l)%Q with (j*(i-k)+ (j-l)*k)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite Qabs_Qmult, Qabs_Qmult. apply Qle_refl. } assert (forall i:Q, Qabs (QboundAbs c i) <= ` c) as bound. { intro i. apply Qabs_Qle_condition. split. apply Qmax_ub_l. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0). apply Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. } simpl. unfold Qmult_modulus. intros e1 [i j] [k l] [H H0]. simpl. simpl in H, H0. apply AbsSmall_Qabs. apply AbsSmall_Qabs in H. apply AbsSmall_Qabs in H0. apply (Qle_trans _ _ _ (multMaj _ _ _ _)). apply (Qle_trans _ (`c * (Qabs (QboundAbs c i - QboundAbs c k)) + `c * (Qabs (QboundAbs c j - QboundAbs c l)))). - apply Qplus_le_compat. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply bound. rewrite Qmult_comm. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply bound. - apply (Qle_trans _ ((1#2)*`e1+(1#2)*`e1)). apply Qplus_le_compat. apply (Qle_trans _ (`c * Qabs (i-k))). apply Qmult_le_l. apply Qpos_ispos. apply QboundAbs_contract. rewrite Qmult_comm. apply (Qmult_le_r _ _ (/ `c)). apply Qinv_lt_0_compat, Qpos_ispos. rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. exact H. apply Qpos_nonzero. apply (Qle_trans _ (`c * Qabs (j-l))). apply Qmult_le_l. apply Qpos_ispos. apply QboundAbs_contract. rewrite Qmult_comm. apply (Qmult_le_r _ _ (/ `c)). apply Qinv_lt_0_compat, Qpos_ispos. rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. exact H0. apply Qpos_nonzero. ring_simplify. apply Qle_refl. Qed. Definition Qmult_uncurry (c : Qpos) : (ProductMS Q_as_MetricSpace Q_as_MetricSpace) --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (@Qmult_uc_uncurry c). Lemma CRmult_uncurry_eq : forall (c:Qpos) (x y : CR), (' (-proj1_sig c)%Q <= x)%CR -> (x <= ' (proj1_sig c)%Q)%CR -> (CRmult_bounded c x y == (Cmap (ProductMS_prelength QPrelengthSpace QPrelengthSpace) (Qmult_uncurry c) (undistrib_Complete (x,y))))%CR. Proof. (* Cannot use Cmap2_curry, because CRmult_bounded is not exactly Qmult_uc_uncurry, the first factor is not bounded. *) intros. transitivity (CRmult_bounded c (CRboundAbs c x) y). apply (ucFun2_wd (CRmult_bounded c) x (CRboundAbs c x)). symmetry. apply (CRboundAbs_Eq c H H0). reflexivity. intros e1 e2. rewrite Qplus_0_r. simpl. unfold Cap_raw; simpl. assert (forall i, eq (QposInf_bind (λ e : Qpos, e) i) i) as bind_id. { intro i. destruct i; reflexivity. } rewrite bind_id. clear bind_id. assert (forall i j k l : Q, Qabs (i*j-k*l) <= Qabs i * Qabs(j-l) + Qabs(i-k)*Qabs l)%Q as multMaj. { intros. setoid_replace (i*j-k*l)%Q with (i*(j-l)+ (i-k)*l)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite Qabs_Qmult, Qabs_Qmult. apply Qle_refl. } apply AbsSmall_Qabs. apply (Qle_trans _ _ _ (multMaj _ _ _ _)). apply (Qle_trans _ ((1#2)*`e1 + (1#2)*`e2 +((1#2)*`e1 +(1#2)*`e2))). 2: ring_simplify; apply Qle_refl. apply Qplus_le_compat. - apply (Qle_trans _ ( Qabs (approximate y (Qscale_modulus (QboundAbs c (approximate x (Qmult_modulus c ((1 # 2) * e1)))) ((1 # 2) * e1)) - (approximate y (Qmult_modulus c ((1 # 2) * e2)))) * Qabs (QboundAbs c (approximate x (Qmult_modulus c ((1 # 2) * e1)))))). rewrite Qmult_comm. apply Qmult_le_compat_r. apply QboundAbs_contract. apply Qabs_nonneg. unfold Qscale_modulus. simpl (Qmult_modulus c ((1 # 2) * e1)). destruct (QboundAbs c (approximate x (Qmult_modulus c ((1 # 2) ↾ @eq_refl comparison Datatypes.Lt * e1)))) eqn:des. destruct Qnum. + setoid_replace (0#Qden) with (0#1) by reflexivity. rewrite Qmult_0_r. apply (Qpos_nonneg ((1#2)*e1+(1#2)*e2)). + rewrite Qmult_comm, Qabs_pos. 2: discriminate. apply (Qle_trans _ ((Zpos p#Qden) * ((Zpos Qden # p)%Q * ((1 # 2)%Q * `e1) + (1 # 2) * `e2 / `c))). apply Qmult_le_l. reflexivity. pose proof (regFun_prf y ((Zpos Qden # p)%Q ↾ eq_refl * ((1 # 2)%Q ↾ eq_refl * e1))%Qpos ((1 # 2) * e2 * Qpos_inv c)%Qpos) as H3. apply AbsSmall_Qabs in H3. exact H3. rewrite Qmult_plus_distr_r. rewrite Qmult_assoc. setoid_replace ((Zpos p # Qden) * (Zpos Qden # p))%Q with (1#1)%Q by (unfold equiv, stdlib_rationals.Q_eq; unfold Qeq; simpl; rewrite Pos.mul_1_r, Pos.mul_comm; reflexivity). rewrite Qmult_1_l. apply Qplus_le_r. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qmult_le_l. apply (Qpos_ispos ((1#2)*e2)). rewrite <- des. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0). apply Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. + rewrite Qmult_comm, Qabs_neg. 2: discriminate. setoid_replace (- (Z.neg p # Qden)) with (Zpos p # Qden) by reflexivity. apply (Qle_trans _ ((Zpos p#Qden) * ((Zpos Qden # p)%Q * ((1 # 2)%Q * `e1) + (1 # 2) * `e2 / `c))). apply Qmult_le_l. reflexivity. pose proof (regFun_prf y ((Zpos Qden # p)%Q ↾ eq_refl * ((1 # 2)%Q ↾ eq_refl * e1))%Qpos ((1 # 2) * e2 * Qpos_inv c)%Qpos) as H3. apply AbsSmall_Qabs in H3. exact H3. rewrite Qmult_plus_distr_r. rewrite Qmult_assoc. setoid_replace ((Zpos p # Qden) * (Zpos Qden # p))%Q with (1#1)%Q by (unfold equiv, stdlib_rationals.Q_eq; unfold Qeq; simpl; rewrite Pos.mul_1_r, Pos.mul_comm; reflexivity). rewrite Qmult_1_l. apply Qplus_le_r. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qmult_le_l. apply (Qpos_ispos ((1#2)*e2)). rewrite <- (Qopp_involutive (`c)). setoid_replace (Zpos p # Qden) with (-(Z.neg p # Qden)) by reflexivity. apply Qopp_le_compat. rewrite <- des. apply Qmax_ub_l. - apply (Qle_trans _ (Qabs (approximate x (Qmult_modulus c ((1 # 2) * e1)) - approximate x (Qmult_modulus c ((1 # 2) * e2))) * Qabs (QboundAbs c (approximate y (Qmult_modulus c ((1 # 2) ↾ eq_refl * e2)))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply QboundAbs_contract. rewrite QboundAbs_abs. apply (Qle_trans _ (`c * Qabs (approximate x (Qmult_modulus c ((1 # 2) * e1)) - approximate x (Qmult_modulus c ((1 # 2) * e2))))). rewrite Qmult_comm. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply Qmin_lb_r. apply (Qle_trans _ (`c * ((1#2)*`e1 / `c + (1#2)*`e2 / `c))). apply Qmult_le_l. apply Qpos_ispos. unfold Qmult_modulus. pose proof (regFun_prf x ((1 # 2) * e1 * Qpos_inv c)%Qpos ((1 # 2) * e2 * Qpos_inv c)%Qpos) as H3. apply AbsSmall_Qabs in H3. exact H3. rewrite Qmult_plus_distr_r. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. Qed. (* Request bounds on all left factors : x and CRmult_bounded c x y. *) Lemma CRmult_uncurry_eq_3 : forall (c:Qpos) (x y z : CR), (' (- ` c)%Q <= x)%CR -> (x <= 'proj1_sig c)%CR -> (' (- ` c)%Q <= CRmult_bounded c x y)%CR -> (CRmult_bounded c x y <= 'proj1_sig c)%CR -> (CRmult_bounded c (CRmult_bounded c x y) z == Cmap (ProductMS_prelength (ProductMS_prelength QPrelengthSpace QPrelengthSpace) QPrelengthSpace) (uc_compose (Qmult_uncurry c) (together (Qmult_uncurry c) (uc_id Q_as_MetricSpace))) (undistrib_Complete (undistrib_Complete (x,y), z)))%CR. Proof. intros. assert (forall a, Qabs (QboundAbs c a) <= `c) as qbound_bound. { intros a. rewrite QboundAbs_abs. apply Qmin_lb_r. } rewrite (@CRmult_uncurry_eq c (CRmult_bounded c x y) z); try assumption. assert (msp_eq (undistrib_Complete (CRmult_bounded c x y, z)) (undistrib_Complete ((Cmap (ProductMS_prelength QPrelengthSpace QPrelengthSpace) (Qmult_uncurry c) (undistrib_Complete (x,y))), z))) as H4. { intros e1 e2. split. apply (@CRmult_uncurry_eq c x y H H0). rewrite Qplus_0_r. apply regFun_prf. } rewrite H4. clear H4. rewrite fast_MonadLaw2. apply Cmap_wd. reflexivity. intros e1 e2. split. - simpl. apply AbsSmall_Qabs. assert (forall i j k l : Q, Qabs (i*j-k*l) <= Qabs i * Qabs(j-l) + Qabs(i-k)*Qabs l)%Q as multMaj. { intros. setoid_replace (i*j-k*l)%Q with (i*(j-l)+ (i-k)*l)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite Qabs_Qmult, Qabs_Qmult. apply Qle_refl. } apply (Qle_trans _ ((1#2)*`e1 + (1#2)*`e2 +((1#2)*`e1 +(1#2)*`e2))). 2: ring_simplify; apply Qle_refl. apply (Qle_trans _ _ _ (multMaj _ _ _ _)). clear multMaj. apply Qplus_le_compat. + apply (Qle_trans _ (`c * (Qabs (Qmax (- ` c) (Qmin (` c) (approximate y (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)))) - Qmax (- ` c) (Qmin (` c) (approximate y (Qpos_min ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c) e2))))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply qbound_bound. rewrite Qmult_comm. apply (Qle_trans _ (Qabs (approximate y (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)) - approximate y (Qpos_min ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c) e2)) * `c)). apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply QboundAbs_contract. apply (Qle_trans _ (((1#2)*`e1 / `c + (1#2)*`e2 / `c) * `c)). apply Qmult_le_r. apply Qpos_ispos. unfold Qmult_modulus. pose proof (regFun_prf y ((1 # 2) * e1 * Qpos_inv c)%Qpos (Qpos_min ((1 # 2) * e2 * Qpos_inv c)%Qpos e2)) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). clear H4. apply Qplus_le_r. rewrite Q_Qpos_min. simpl. apply Qmin_lb_l. rewrite Qmult_plus_distr_l. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. + rewrite Qmult_comm. apply (Qle_trans _ (`c * (Qabs (Qmax (- ` c) (Qmin (` c) (approximate x (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)))) - Qmax (- ` c) (Qmin (` c) (approximate x (Qpos_min ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c) e2))))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply qbound_bound. rewrite Qmult_comm. apply (Qle_trans _ (Qabs (approximate x (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)) - approximate x (Qpos_min ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c) e2)) * `c)). apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply QboundAbs_contract. apply (Qle_trans _ (((1#2)*`e1 / `c + (1#2)*`e2 / `c) * `c)). apply Qmult_le_r. apply Qpos_ispos. unfold Qmult_modulus. pose proof (regFun_prf x ((1 # 2) * e1 * Qpos_inv c)%Qpos (Qpos_min ((1 # 2) * e2 * Qpos_inv c)%Qpos e2)) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). clear H4. apply Qplus_le_r. rewrite Q_Qpos_min. simpl. apply Qmin_lb_l. rewrite Qmult_plus_distr_l. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. - simpl. assert (`e1 + proj1_sig (Qpos_min ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c) e2) <= `e1 + `e2) as H4. { apply Qplus_le_r. apply Qpos_min_lb_r. } rewrite Qplus_0_r. apply (ball_weak_le _ _ _ H4). apply regFun_prf. Qed. (* Request bounds on all left factors : x and y. *) Lemma CRmult_uncurry_eq_3r : forall (c:Qpos) (x y z : CR), (' (- ` c)%Q <= x)%CR -> (x <= 'proj1_sig c)%CR -> (' (- ` c)%Q <= y)%CR -> (y <= 'proj1_sig c)%CR -> (CRmult_bounded c x (CRmult_bounded c y z) == Cmap (ProductMS_prelength (ProductMS_prelength QPrelengthSpace QPrelengthSpace) QPrelengthSpace) (uc_compose (Qmult_uncurry c) (uc_compose (together (uc_id Q_as_MetricSpace) (Qmult_uncurry c)) (uc_assoc _ _ _))) (undistrib_Complete (undistrib_Complete (x,y), z)))%CR. Proof. intros. assert (forall a, Qabs (QboundAbs c a) <= `c) as qbound_bound. { intros a. rewrite QboundAbs_abs. apply Qmin_lb_r. } rewrite (@CRmult_uncurry_eq c x (CRmult_bounded c y z)); try assumption. assert (msp_eq (undistrib_Complete (x, CRmult_bounded c y z)) (undistrib_Complete (x, Cmap (ProductMS_prelength QPrelengthSpace QPrelengthSpace) (Qmult_uncurry c) (undistrib_Complete (y,z))))) as H4. { intros e1 e2. split. rewrite Qplus_0_r. apply regFun_prf. apply (@CRmult_uncurry_eq c y z H1 H2). } rewrite H4. clear H4. rewrite fast_MonadLaw2. apply Cmap_wd. reflexivity. intros e1 e2. rewrite Qplus_0_r. split. - simpl. assert (`e1 + proj1_sig (Qpos_min e2 ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c)) <= `e1 + `e2) as H4. { apply Qplus_le_r. apply Qpos_min_lb_l. } apply (ball_weak_le _ _ _ H4). apply regFun_prf. - simpl. apply AbsSmall_Qabs. assert (forall i j k l : Q, Qabs (i*j-k*l) <= Qabs i * Qabs(j-l) + Qabs(i-k)*Qabs l)%Q as multMaj. { intros. setoid_replace (i*j-k*l)%Q with (i*(j-l)+ (i-k)*l)%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite Qabs_Qmult, Qabs_Qmult. apply Qle_refl. } apply (Qle_trans _ ((1#2)*`e1 + (1#2)*`e2 +((1#2)*`e1 +(1#2)*`e2))). 2: ring_simplify; apply Qle_refl. apply (Qle_trans _ _ _ (multMaj _ _ _ _)). clear multMaj. apply Qplus_le_compat. + apply (Qle_trans _ (`c * (Qabs (Qmax (- ` c) (Qmin (` c) (approximate z (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)))) - Qmax (- ` c) (Qmin (` c) (approximate z (Qpos_min e2 ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c)))))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply qbound_bound. rewrite Qmult_comm. apply (Qle_trans _ (Qabs (approximate z (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)) - approximate z (Qpos_min e2 ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c))) * `c)). apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply QboundAbs_contract. apply (Qle_trans _ (((1#2)*`e1 / `c + (1#2)*`e2 / `c) * `c)). apply Qmult_le_r. apply Qpos_ispos. unfold Qmult_modulus. pose proof (regFun_prf z ((1 # 2) * e1 * Qpos_inv c)%Qpos (Qpos_min e2 ((1 # 2) * e2 * Qpos_inv c)%Qpos)) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). clear H4. apply Qplus_le_r. rewrite Q_Qpos_min. simpl. apply Qmin_lb_r. rewrite Qmult_plus_distr_l. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. + rewrite Qmult_comm. apply (Qle_trans _ (`c * (Qabs (Qmax (- ` c) (Qmin (` c) (approximate y (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)))) - Qmax (- ` c) (Qmin (` c) (approximate y (Qpos_min e2 ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c)))))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply qbound_bound. rewrite Qmult_comm. apply (Qle_trans _ (Qabs (approximate y (Qmult_modulus c ((1 # 2) ↾ eq_refl * e1)) - approximate y (Qpos_min e2 ((1 # 2) ↾ eq_refl * e2 * Qpos_inv c))) * `c)). apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply QboundAbs_contract. apply (Qle_trans _ (((1#2)*`e1 / `c + (1#2)*`e2 / `c) * `c)). apply Qmult_le_r. apply Qpos_ispos. unfold Qmult_modulus. pose proof (regFun_prf y ((1 # 2) * e1 * Qpos_inv c)%Qpos (Qpos_min e2 ((1 # 2) * e2 * Qpos_inv c)%Qpos)) as H4. apply AbsSmall_Qabs in H4. apply (Qle_trans _ _ _ H4). clear H4. apply Qplus_le_r. rewrite Q_Qpos_min. simpl. apply Qmin_lb_r. rewrite Qmult_plus_distr_l. apply Qplus_le_compat. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. unfold Qdiv. rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply Qpos_ispos. rewrite Qmult_comm. apply Qle_refl. Qed. Lemma Qmult_uncurry_assoc : forall (i j k:Q) (b : Qpos), Qabs i <= `b -> Qabs j <= `b -> Qabs k <= `b -> Qabs (j*k) <= `b -> Qabs (i*j) <= `b -> Qmult_uncurry b (Qmult_uncurry b (i, j), k) == Qmult_uncurry b (i, Qmult_uncurry b (j,k)). Proof. intros. simpl. apply Qabs_Qle_condition in H. destruct H as [ilower iupper]. apply Qabs_Qle_condition in H0. destruct H0 as [jlower jupper]. apply Qabs_Qle_condition in H1. destruct H1 as [klower kupper]. apply Qabs_Qle_condition in H2. destruct H2 as [jklower jkupper]. apply Qabs_Qle_condition in H3. destruct H3 as [ijlower ijupper]. assert (forall a:Q, a <= `b -> Qmin (`b) a == a)%Q as elim_min. { apply Qle_min_r. } assert (forall a:Q, -(`b) <= a -> Qmax (-(`b)) a == a)%Q as elim_max. { intros. apply Qle_max_r, H. } rewrite (elim_min j jupper). rewrite (elim_min i iupper). rewrite (elim_min k kupper). rewrite (elim_max j jlower). rewrite (elim_max i ilower). rewrite (elim_max k klower). rewrite (elim_min (j*k) jkupper). rewrite (elim_min (i*j) ijupper). rewrite (elim_max (j*k) jklower). rewrite (elim_max (i*j) ijlower). rewrite Qmult_assoc. reflexivity. Qed. Lemma quarter_approx_le_abs_1 : forall (x : CR) (q : Q), Qabs (q - approximate x (Qpos2QposInf (1 # 4))) <= (3#4) -> Qabs q <= ` (CR_b (1 ↾ eq_refl) x + 1 ↾ eq_refl)%Qpos. Proof. intros. simpl. apply (Qle_trans _ _ _ (Qabs_triangle_reverse _ _)) in H. apply (Qplus_le_l _ _ (-Qabs (approximate x (Qpos2QposInf (1#4))))). apply (Qle_trans _ _ _ H). clear H q. pose proof (regFun_prf x (1#4)%Qpos (1#1)%Qpos). apply AbsSmall_Qabs in H. apply Qopp_le_compat in H. apply (Qplus_le_r _ _ (2#1)) in H. setoid_replace (2 + - (` ((1 # 4) ↾ eq_refl) + ` (1 ↾ eq_refl))) with (3#4) in H by reflexivity. rewrite <- Qplus_assoc, <- Qplus_assoc, Qplus_comm, Qplus_assoc. setoid_replace ((1#1)+(1#1)) with (2#1) by reflexivity. apply (Qle_trans _ _ _ H). clear H. rewrite <- Qplus_assoc. apply Qplus_le_r. setoid_replace (- Qabs (approximate x (Qpos2QposInf (1 # 4))) + Qabs (approximate x (Qpos2QposInf (1#1))))%Q with (- (Qabs (approximate x (Qpos2QposInf (1 # 4))) - Qabs (approximate x (Qpos2QposInf (1#1))))) by (unfold equiv, stdlib_rationals.Q_eq; ring). apply Qopp_le_compat, Qabs_triangle_reverse. Qed. Lemma QboundAbs_lowerBound_2 : forall (a b : Qpos) (c d : Q), (- (`a * `b) <= QboundAbs a c * QboundAbs b d)%Q. Proof. intros. apply (Qle_trans _ (-Qabs (QboundAbs a c * QboundAbs b d))). apply Qopp_le_compat. rewrite Qabs_Qmult. rewrite QboundAbs_abs, QboundAbs_abs. apply (Qle_trans _ (`a * Qmin (Qabs d) (`b))). apply Qmult_le_compat_r. apply Qmin_lb_r. apply Qmin_glb. apply Qabs_nonneg. apply Qpos_nonneg. apply Qmult_le_l. apply Qpos_ispos. apply Qmin_lb_r. rewrite <- (Qopp_involutive (QboundAbs a c * QboundAbs b d)) at 2. apply Qopp_le_compat. rewrite <- Qabs_opp. apply Qle_Qabs. Qed. Lemma QboundAbs_upperBound_2 : forall (a b : Qpos) (c d : Q), (QboundAbs a c * QboundAbs b d <= `a * `b)%Q. Proof. intros. apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_Qmult. rewrite QboundAbs_abs, QboundAbs_abs. apply (Qle_trans _ (`a * Qmin (Qabs d) (`b))). apply Qmult_le_compat_r. apply Qmin_lb_r. apply Qmin_glb. apply Qabs_nonneg. apply Qpos_nonneg. apply Qmult_le_l. apply Qpos_ispos. apply Qmin_lb_r. Qed. Lemma CR_b_lowerBound_2 : forall x y : CR, ('(-proj1_sig ((CR_b (1#1) x) * CR_b (1#1) y)%Qpos)%Q <= x * y)%CR. Proof. intros. rewrite <- (CRboundAbs_Eq (CR_b (1#1) x) (CR_b_lowerBound (1#1) x) (CR_b_upperBound (1#1) x)) at 2. unfold CRmult, ucFun2. intros e. simpl. unfold Cap_raw; simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. unfold Qminus. rewrite <- Qle_minus_iff. apply (QboundAbs_lowerBound_2 (CR_b (1#1) x) (CR_b (1#1) y)). Qed. Lemma CR_b_upperBound_2 : forall x y : CR, (x * y <= 'proj1_sig ((CR_b (1#1) x) * CR_b (1#1) y)%Qpos)%CR. Proof. intros. rewrite <- (CRboundAbs_Eq (CR_b (1#1) x) (CR_b_lowerBound (1#1) x) (CR_b_upperBound (1#1) x)) at 1. unfold CRmult, ucFun2. intros e. simpl. unfold Cap_raw; simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. unfold Qminus. rewrite <- Qle_minus_iff. apply (QboundAbs_upperBound_2 (CR_b (1#1) x) (CR_b (1#1) y)). Qed. Lemma CRle_Qle : forall (x y:Q), (inject_Q_CR x <= inject_Q_CR y)%CR <-> (x <= y)%Q. Proof. split. intros H. destruct (Qlt_le_dec y x) as [X|X];[|assumption]. destruct (Qpos_sub _ _ X) as [c Hc]. assert (Y:=(H ((1#2)*c)%Qpos)). simpl in Y. unfold Cap_raw in Y; simpl in Y. rewrite -> Qle_minus_iff in Y. rewrite -> Hc in Y. autorewrite with QposElim in Y. ring_simplify in Y. elim (Qle_not_lt _ _ Y). rewrite -> Qlt_minus_iff. ring_simplify. apply Q.Qmult_lt_0_compat; auto with *. intros H e. simpl. unfold Cap_raw; simpl. rewrite -> Qle_minus_iff in H. apply Qle_trans with (0%Q);[|assumption]. rewrite -> Qle_minus_iff; ring_simplify. apply Qpos_nonneg. Qed. Lemma CRmult_assoc_yfactor_le : forall (x y z : CR), let b := ((CR_b (1#1) x + (1#1)) * (CR_b (1#1) y + (1#1)) * (CR_b (1#1) z + (1#1)))%Qpos in (` (CR_b (1 ↾ eq_refl) y) + 1 <= ` b)%Q. Proof. intros. unfold b. simpl. rewrite <- Qmult_assoc, (Qmult_comm (Qabs (approximate y (Qpos2QposInf (1#1))) + 1 + 1)). rewrite Qmult_assoc. rewrite <- Qmult_1_l, <- Qmult_1_l. rewrite Qmult_assoc. apply Qmult_le_compat_r. apply (Qpos_mult_le_compat (1#1) (1#1)). rewrite <- Qplus_0_l. apply Qplus_le_l, (Qpos_nonneg (CR_b (1#1) x)). rewrite <- Qplus_0_l. apply Qplus_le_l, (Qpos_nonneg (CR_b (1#1) z)). rewrite <- Qplus_assoc. apply (Qle_trans _ (0+2)). discriminate. apply Qplus_le_l. apply Qabs_nonneg. Qed. Lemma CRmult_assoc_xfactor_le : forall (x y z : CR), let b := ((CR_b (1#1) x + (1#1)) * (CR_b (1#1) y + (1#1)) * (CR_b (1#1) z + (1#1)))%Qpos in (` (CR_b (1 ↾ eq_refl) x) + 1 <= ` b)%Q. Proof. intros. unfold b. simpl. rewrite <- Qmult_assoc, Qmult_comm. rewrite <- Qmult_1_l, <- Qmult_1_l at 1. rewrite Qmult_assoc. apply Qmult_le_compat_r. apply (Qpos_mult_le_compat (1#1) (1#1)). rewrite <- Qplus_0_l. apply Qplus_le_l, (Qpos_nonneg (CR_b (1#1) y)). rewrite <- Qplus_0_l. apply Qplus_le_l, (Qpos_nonneg (CR_b (1#1) z)). rewrite <- Qplus_assoc. apply (Qle_trans _ (0+2)). discriminate. apply Qplus_le_l. apply Qabs_nonneg. Qed. Lemma CRmult_assoc_zfactor_le : forall (x y z : CR), let b := ((CR_b (1#1) x + (1#1)) * (CR_b (1#1) y + (1#1)) * (CR_b (1#1) z + (1#1)))%Qpos in (` (CR_b (1 ↾ eq_refl) z) + 1 <= ` b)%Q. Proof. intros. rewrite <- Qmult_1_l, <- Qmult_1_l, Qmult_assoc. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply (Qpos_mult_le_compat (1#1) (1#1)). rewrite <- Qplus_0_l. apply Qplus_le_l, Qpos_nonneg. rewrite <- Qplus_0_l. apply Qplus_le_l, Qpos_nonneg. Qed. (* Request bounds on all left factors : x, CRmult_bounded b x y, and y. *) Lemma CRmult_assoc_bounded (x y z : CR) : let b := ((CR_b (1#1) x + (1#1)) * (CR_b (1#1) y + (1#1)) * (CR_b (1#1) z + (1#1)))%Qpos in (CRmult_bounded b (CRmult_bounded b x y) z == CRmult_bounded b x (CRmult_bounded b y z))%CR. Proof. intros. assert (' (- ` b)%Q <= x)%CR as xlower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) x))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat. apply (Qle_trans _ ((` (CR_b (1#1)%Qpos x) + (1#1)))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_xfactor_le. } assert (x <= ' (` b)%Q)%CR as xupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) x))%Q)). apply CR_b_upperBound. apply CRle_Qle. apply (Qle_trans _ ((` (CR_b (1#1)%Qpos x) + (1#1)))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_xfactor_le. } assert (' (- ` b)%Q <= y)%CR as ylower. { apply (@CRle_trans _ (' (-proj1_sig (CR_b (1#1) y))%Q)). 2: apply (CR_b_lowerBound _ _). apply CRle_Qle. apply Qopp_le_compat. apply (Qle_trans _ ((` (CR_b (1#1)%Qpos y) + (1#1)))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_yfactor_le. } assert (y <= ' (` b)%Q)%CR as yupper. { apply (@CRle_trans _ (' (proj1_sig (CR_b (1#1) y))%Q)). apply CR_b_upperBound. apply CRle_Qle. apply (Qle_trans _ ((` (CR_b (1#1)%Qpos y) + (1#1)))). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. apply CRmult_assoc_yfactor_le. } assert (` (CR_b (1 ↾ eq_refl) x + 1 ↾ eq_refl)%Qpos * ` (CR_b (1 ↾ eq_refl) y + 1 ↾ eq_refl)%Qpos <= ` b) as xyfactor_le. { rewrite <- Qmult_1_l. unfold b. simpl. rewrite (Qmult_comm ((Qabs (approximate x (Qpos2QposInf (1 ↾ eq_refl))) + 1 + 1) * (Qabs (approximate y (Qpos2QposInf (1 ↾ eq_refl))) + 1 + 1))). apply Qmult_le_compat_r. apply (Qle_trans _ (0+2)). discriminate. rewrite <- Qplus_assoc. apply Qplus_le_l, Qabs_nonneg. apply Qmult_le_0_compat. apply (Qle_trans _ (0+2)). discriminate. rewrite <- Qplus_assoc. apply Qplus_le_l, Qabs_nonneg. apply (Qle_trans _ (0+2)). discriminate. rewrite <- Qplus_assoc. apply Qplus_le_l, Qabs_nonneg. } rewrite CRmult_uncurry_eq_3r. rewrite CRmult_uncurry_eq_3. 2: exact xlower. 2: exact xupper. 4: exact xlower. 4: exact xupper. 4: exact ylower. 4: exact yupper. (* Qmult_uncurry is not associative everywhere, so use Cmap_wd_loc. *) apply Cmap_wd_loc with (e:=(1#4)%Qpos). intros [[i j] k]. intros H. specialize (H (1#4)%Qpos (1#4)%Qpos). destruct H,H. simpl in H1. simpl in H0. apply Qball_0. apply (@Qmult_uncurry_assoc i j k b). - clear H0 H1. simpl in H. apply AbsSmall_Qabs in H. apply (Qle_trans _ (proj1_sig (CR_b (1#1) x + (1#1))%Qpos)). setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H by reflexivity. apply quarter_approx_le_abs_1, H. clear H. apply CRmult_assoc_xfactor_le. - clear H H0. apply (Qle_trans _ (proj1_sig (CR_b (1#1) y + (1#1))%Qpos)). apply AbsSmall_Qabs in H1. setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H1 by reflexivity. apply quarter_approx_le_abs_1, H1. apply CRmult_assoc_yfactor_le. - clear H H1. apply (Qle_trans _ (proj1_sig (CR_b (1#1) z + (1#1))%Qpos)). apply AbsSmall_Qabs in H0. setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H0 by reflexivity. apply quarter_approx_le_abs_1, H0. apply CRmult_assoc_zfactor_le. - apply (Qle_trans _ (proj1_sig (CR_b (1#1) y + (1#1))%Qpos * proj1_sig (CR_b (1#1) z + (1#1))%Qpos)). rewrite Qabs_Qmult. apply (Qle_trans _ (proj1_sig (CR_b (1#1) y + (1#1))%Qpos * Qabs k)). apply Qmult_le_compat_r. apply AbsSmall_Qabs in H1. setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H1 by reflexivity. apply quarter_approx_le_abs_1, H1. apply Qabs_nonneg. apply Qmult_le_l. apply Qpos_ispos. apply AbsSmall_Qabs in H0. setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H0 by reflexivity. apply quarter_approx_le_abs_1, H0. rewrite <- Qmult_1_l, Qmult_assoc. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. apply Qmult_le_compat_r. 2: apply Qpos_nonneg. simpl. rewrite <- Qplus_assoc. apply (Qle_trans _ (0+2)). discriminate. apply Qplus_le_l, Qabs_nonneg. - apply (Qle_trans _ (proj1_sig (CR_b (1#1) x + (1#1))%Qpos * proj1_sig (CR_b (1#1) y + (1#1))%Qpos)). rewrite Qabs_Qmult. apply (Qle_trans _ (proj1_sig (CR_b (1#1) x + (1#1))%Qpos * Qabs j)). apply Qmult_le_compat_r. simpl in H. apply AbsSmall_Qabs in H. setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H by reflexivity. apply quarter_approx_le_abs_1, H. apply Qabs_nonneg. apply Qmult_le_l. apply Qpos_ispos. apply AbsSmall_Qabs in H1. setoid_replace ((1#4)+(1#4)+(1#4)) with (3#4) in H1 by reflexivity. apply quarter_approx_le_abs_1, H1. exact xyfactor_le. - rewrite (@CRmult_bounded_mult b). 2: exact ylower. 2: exact yupper. apply (@CRle_trans _ ('(-proj1_sig ((CR_b (1#1) x) * CR_b (1#1) y)%Qpos)%Q)). 2: apply CR_b_lowerBound_2. apply CRle_Qle, Qopp_le_compat. apply (Qle_trans _ (proj1_sig (CR_b (1#1) x + (1#1))%Qpos * proj1_sig ((CR_b (1#1) y) + (1#1))%Qpos)). apply (Qpos_mult_le_compat (CR_b (1#1) x) (CR_b (1#1) y)). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. exact xyfactor_le. - rewrite (@CRmult_bounded_mult b). 2: exact ylower. 2: exact yupper. apply (@CRle_trans _ ('(proj1_sig ((CR_b (1#1) x) * CR_b (1#1) y)%Qpos)%Q)). apply CR_b_upperBound_2. apply CRle_Qle. apply (Qle_trans _ (proj1_sig (CR_b (1#1) x + (1#1))%Qpos * proj1_sig ((CR_b (1#1) y) + (1#1))%Qpos)). apply (Qpos_mult_le_compat (CR_b (1#1) x) (CR_b (1#1) y)). rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. rewrite <- Qplus_0_r at 1. apply Qplus_le_r. discriminate. exact xyfactor_le. Qed. corn-8.20.0/reals/fast/CRGeometricSum.v000066400000000000000000001207131473720167500176440ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.fast.CRAlternatingSum. Require Import CoRN.reals.fast.CRstreams. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.model.totalorder.QMinMax. From Coq Require Import Qpower. From Coq Require Import Qabs. From Coq Require Import Zdiv. Set Implicit Arguments. Opaque Qabs. Local Open Scope Q_scope. Import MathClasses.theory.CoqStreams. (** [InfiniteSum] approximates the limit of the series s within err_prop. *) (* This Fixpoint is fat because the fuel is a unary nat, which can waste a lot of memory in normal form inside vm_compute. *) Fixpoint InfiniteSum_fat (filter:Stream Q -> bool) (s:Stream Q) (q : Q) (fuel:nat) : Q := if filter s then q else match fuel with | O => q | S p => InfiniteSum_fat filter (tl s) (Qplus' q (hd s)) p end. Definition InfiniteSum_raw_F (cont: Stream Q -> Q -> Q) (err_prop:Stream Q -> bool) (s:Stream Q) (q : Q) : Q := if (err_prop s) then q (* the error is small enough, stop the sum *) else cont (tl s) (Qplus' q (hd s)). (* continue the calculations *) (** Sum a rational stream up to the first index at which the filter Stream Q -> bool equals true, or 2^n. n is intended as a termination proof (fuel). It is otherwise useless for the calculations and we want it as small as possible in memory, because vm_compute will start by computing its normal form. By choosing 2^n we make the fuel logarithmic in the actual number of iterations. cont is a continuation that holds the rest of the computations to do in the recursion, it starts with fun _ q => q. This has the same calculation speed as InfiniteSum_fat, and should take less memory. *) Fixpoint InfiniteSum_raw_N (n:nat) (filter: Stream Q -> bool) (cont: Stream Q -> Q -> Q) {struct n} : Stream Q -> Q -> Q := match n with | O => InfiniteSum_raw_F cont filter | S p => InfiniteSum_raw_N p filter (fun s => InfiniteSum_raw_N p filter cont s) end. (* Remark : the eta expension here is important, else the virtual machine will compute the value of (InfiniteGeometricSum_raw_N n') before reducing the call of InfiniteGeometricSum_raw_F.*) (* Get an idea of how the recursion goes. The continuation will unfold n layers deep, before being folded by additions. *) Lemma InfiniteSum_raw_N_unfold : forall n cont (filter : Stream Q -> bool) s, InfiniteSum_raw_N (S (S n)) filter cont s = InfiniteSum_raw_N n filter (fun s0 => InfiniteSum_raw_N n filter (fun s1 => InfiniteSum_raw_N (S n) filter cont s1) s0) s. Proof. reflexivity. Qed. Lemma InfiniteSum_fat_plus : forall (fuel:nat) (filter:Stream Q -> bool) (s:Stream Q) (q : Q), InfiniteSum_fat filter s q fuel == q + InfiniteSum_fat filter s 0 fuel. Proof. induction fuel. - intros. simpl. destruct (filter s); rewrite Qplus_0_r; reflexivity. - intros. simpl. destruct (filter s). symmetry. apply Qplus_0_r. rewrite IHfuel. rewrite (IHfuel filter (tl s) (Qplus' 0 (hd s))). rewrite Qplus_assoc. apply Qplus_comp. 2: reflexivity. rewrite Qplus'_correct, Qplus'_correct, Qplus_0_l. reflexivity. Qed. Lemma InfiniteSum_fat_remove_filter : forall (fuel:nat) (filter:Stream Q -> bool) (s:Stream Q) (q : Q), filter (Str_nth_tl fuel s) = true -> exists n:nat, InfiniteSum_fat filter s q fuel = InfiniteSum_fat (fun _ => false) s q n /\ (forall p:nat, lt p n -> filter (Str_nth_tl p s) = false) /\ filter (Str_nth_tl n s) = true. Proof. induction fuel. - intros. exists O. split. 2: split. simpl. destruct (filter s); reflexivity. intros. exfalso; inversion H0. exact H. - intros. destruct (filter s) eqn:des. + exists O. split. 2: split. simpl. rewrite des. reflexivity. intros. exfalso; inversion H0. exact des. + specialize (IHfuel filter (tl s) (Qplus' q (hd s)) H) as [n [H1 H2]]. exists (S n). split. 2: split. simpl. rewrite des. rewrite H1. reflexivity. intros. destruct p. exact des. simpl. apply H2. apply le_S_n in H0. exact H0. apply H2. Qed. Lemma InfiniteSum_fat_add_stop : forall (p n : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q), le n p -> filter (Str_nth_tl n s) = true -> InfiniteSum_fat filter s q p = InfiniteSum_fat filter s q n. Proof. induction p. - intros n s filter q H H0. inversion H. reflexivity. - intros n s filter q H H0. destruct n. + simpl in H0. simpl. rewrite H0. reflexivity. + specialize (IHp n (tl s) filter). simpl. destruct (filter s) eqn:des. reflexivity. rewrite IHp. reflexivity. apply le_S_n, H. exact H0. Qed. Lemma InfiniteSum_fat_extend : forall (n : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q), filter (Str_nth_tl n s) = true -> InfiniteSum_fat filter s q n = InfiniteSum_fat filter s q (S n). Proof. intros. symmetry. apply InfiniteSum_fat_add_stop. apply le_S, Nat.le_refl. exact H. Qed. Lemma InfiniteSum_fat_add_pass : forall (n p : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q), (forall k:nat, lt k n -> filter (Str_nth_tl k s) = false) -> InfiniteSum_fat filter s q (n+p) = InfiniteSum_fat filter (Str_nth_tl n s) (InfiniteSum_fat filter s q n) p. Proof. induction n. - intros. simpl. destruct (filter s); reflexivity. - intros. pose proof (H O (le_n_S 0 n (Nat.le_0_l _))) as zeroFalse. simpl in zeroFalse. simpl. rewrite zeroFalse. rewrite IHn. reflexivity. intros k H0. destruct n. exfalso; inversion H0. apply Nat.le_succ_r in H0. destruct H0. apply (H (S k)), le_n_S, le_S, H0. inversion H0. subst k. apply (H (S n) (Nat.le_refl _)). Qed. Lemma decide_filter_before_n : forall (n : nat) (filter : Stream Q -> bool) (s : Stream Q), (exists p:nat, lt p n /\ filter (Str_nth_tl p s) = true) \/ (forall p:nat, lt p n -> filter (Str_nth_tl p s) = false). Proof. induction n. - intros. right. intros. exfalso. inversion H. - intros. destruct (filter (Str_nth_tl n s)) eqn:des. left. exists n. split. apply Nat.le_refl. exact des. destruct (IHn filter s). + left. destruct H as [p [H H0]]. exists p. split. apply le_S, H. exact H0. + right. intros. apply Nat.le_succ_r in H0. destruct H0. apply H, H0. inversion H0. subst p. exact des. Qed. Lemma InfiniteSum_raw_N_step : forall (fuel : nat) c (filter : Stream Q -> bool) (s : Stream Q) (q : Q), (forall p:nat, p < 2 ^ fuel -> filter (Str_nth_tl p s) = false)%nat -> InfiniteSum_raw_N fuel filter c s q = c (Str_nth_tl (2^fuel) s) (InfiniteSum_raw_N fuel filter (fun _ r => r) s q). Proof. induction fuel. - intros. simpl. unfold InfiniteSum_raw_F. destruct (filter s) eqn:des. 2: reflexivity. exfalso. specialize (H O (Nat.le_refl _)). simpl in H. rewrite H in des. discriminate. - intros. simpl. assert (forall p : nat, (p < 2 ^ fuel)%nat -> filter (Str_nth_tl p s) = false) as firstHalf. { intros. apply (H p). simpl. rewrite Nat.add_0_r. apply (Nat.lt_le_trans _ (0+2^fuel)). exact H0. apply Nat.add_le_mono_r, Nat.le_0_l. } rewrite IHfuel, IHfuel. 3: exact firstHalf. rewrite Nat.add_0_r, Str_nth_tl_plus. apply f_equal. symmetry. apply IHfuel. exact firstHalf. intros. rewrite Str_nth_tl_plus. apply H. simpl. rewrite Nat.add_0_r. apply Nat.add_lt_mono_r, H0. Qed. (* The initial continuation is not reached when the filter is triggered before. *) Lemma InfiniteSum_raw_N_cont_invariant : forall (fuel p : nat) c d (filter : Stream Q -> bool) (s : Stream Q) (q : Q), (p < 2 ^ fuel)%nat -> filter (Str_nth_tl p s) = true -> InfiniteSum_raw_N fuel filter c s q = InfiniteSum_raw_N fuel filter d s q. Proof. induction fuel. - intros. simpl in H. simpl. unfold InfiniteSum_raw_F. destruct (filter s) eqn:des. reflexivity. apply le_S_n in H. inversion H. exfalso. subst p. simpl in H0. rewrite H0 in des. discriminate. - intros. simpl. simpl in H. rewrite Nat.add_0_r in H. destruct (decide_filter_before_n (2^fuel) filter s). destruct H1 as [k [H1 H2]]. apply (IHfuel k). exact H1. exact H2. (* Now 2^fuel <= p *) destruct (Nat.lt_ge_cases p (2^fuel)). exfalso. specialize (H1 p H2). rewrite H0 in H1. discriminate. apply Nat.le_exists_sub in H2. destruct H2 as [k [H2 _]]. subst p. rewrite <- Str_nth_tl_plus in H0. rewrite (InfiniteSum_raw_N_step fuel (fun s0 : Stream Q => InfiniteSum_raw_N fuel filter c s0)). 2: exact H1. rewrite (InfiniteSum_raw_N_step fuel (fun s0 : Stream Q => InfiniteSum_raw_N fuel filter d s0)). 2: exact H1. apply (IHfuel k). apply Nat.add_lt_mono_r in H. exact H. exact H0. Qed. Lemma InfiniteSum_raw_N_correct : forall (fuel : nat) (s : Stream Q) (filter : Stream Q -> bool) (q : Q), InfiniteSum_raw_N fuel filter (fun _ r => r) s q = InfiniteSum_fat filter s q (2 ^ fuel)%nat. Proof. induction fuel. - intros. simpl. unfold InfiniteSum_raw_F. destruct (filter s). reflexivity. simpl. destruct (filter (tl s)); reflexivity. - intros s filter q. simpl. rewrite Nat.add_0_r. destruct (decide_filter_before_n (2^fuel)%nat filter s). + destruct H as [p [H H0]]. rewrite (@InfiniteSum_fat_add_stop _ p). 3: exact H0. rewrite <- (@InfiniteSum_fat_add_stop (2^fuel)). 2: apply (Nat.le_trans _ (S p) _ (le_S _ _ (Nat.le_refl p)) H). 2: exact H0. rewrite <- IHfuel. apply (@InfiniteSum_raw_N_cont_invariant fuel p). exact H. exact H0. apply (Nat.le_trans _ (2^fuel + 0)). rewrite Nat.add_0_r. apply (Nat.le_trans _ (S p) _ (le_S _ _ (Nat.le_refl p)) H). apply Nat.add_le_mono_l, Nat.le_0_l. + rewrite InfiniteSum_fat_add_pass. 2: exact H. rewrite <- IHfuel. rewrite <- IHfuel. rewrite InfiniteSum_raw_N_step. reflexivity. exact H. Qed. Lemma InfiniteSum_raw_N_extend : forall (p q:nat) s (err : Stream Q -> bool) (r:Q), (Is_true (err (Str_nth_tl (2^p) s))) -> (p <= q)%nat -> InfiniteSum_raw_N p err (fun _ r => r) s r = InfiniteSum_raw_N q err (fun _ r => r) s r. Proof. intros. rewrite InfiniteSum_raw_N_correct, InfiniteSum_raw_N_correct. symmetry. apply InfiniteSum_fat_add_stop. apply Nat.pow_le_mono_r. discriminate. exact H0. unfold Is_true in H. destruct (err (Str_nth_tl (2 ^ p) s)). reflexivity. contradiction. Qed. Lemma InfiniteSum_fat_minus : forall (i p : nat) (s : Stream Q) (q : Q), InfiniteSum_fat (fun _ => false) s q (p + i) - InfiniteSum_fat (fun _ => false) s q i == InfiniteSum_fat (fun _ => false) (Str_nth_tl i s) 0 p. Proof. induction i. - intros. simpl. rewrite Nat.add_0_r. unfold Qminus. rewrite InfiniteSum_fat_plus. ring. - intros. rewrite Nat.add_succ_r. simpl. rewrite IHi. reflexivity. Qed. Lemma InfiniteSum_fat_wd : forall (fuel:nat) (filter:Stream Q -> bool) (s:Stream Q) (q r : Q), q == r -> InfiniteSum_fat filter s q fuel == InfiniteSum_fat filter s r fuel. Proof. induction fuel. - intros. simpl. destruct (filter s); exact H. - intros. simpl. destruct (filter s). exact H. apply IHfuel. rewrite Qplus'_correct, Qplus'_correct. apply Qplus_comp. exact H. reflexivity. Qed. (** ** Geometric Series A geometric series is simple to sum. However we do something slightly more general. We sum a series that satifies the ratio test. *) Section GeometricSeries. Variable a : Q. Hypothesis Ha0 : 0 <= a. Hypothesis Ha1 : a < 1. (** The definition of what we are calling a [GeometricSeries]: a series that satifies the ratio test. *) Definition GeometricSeries := ForAll (fun s => Qabs ((hd (tl s))) <= a*(Qabs(hd s))). (** [err_bound] majorates the distance between the head of the series and its limit. *) Let err_bound (s:Stream Q) : Q := Qabs (hd s)/(1-a). (** [err_prop]: is err a bound on the series s? *) Let err_prop (err:Q) (s:Stream Q) : bool := match ((err_bound s) ?= err) with Gt => false |_ => true end. Lemma err_prop_prop : forall e s, err_prop e s = true <-> err_bound s <= e. Proof. intros e s. unfold err_prop, err_bound, Qcompare, Qle, Z.le. destruct (Qnum (Qabs (hd s) / (1 - a))%Q * Zpos (Qden e) ?= Qnum e * Zpos (Qden (Qabs (hd s) / (1 - a))%Q))%Z; split; auto with *. Qed. Lemma err_prop_nonneg : forall e s, err_prop e s = true -> 0 <= e. Proof. intros. apply err_prop_prop in H. refine (Qle_trans _ _ _ _ H). apply Qmult_le_0_compat. apply Qabs_nonneg. apply Qlt_le_weak, Qinv_lt_0_compat. unfold Qminus. rewrite <- Qlt_minus_iff. exact Ha1. Qed. (** The key lemma about error bounds. *) Lemma err_prop_key : forall (e:Q) (s: Stream Q) (x:Q), err_prop e s = true -> Qabs x <= a*e -> Qabs (Qplus' (hd s) x) <= e. Proof. intros e s x Hs Hx. rewrite -> Qplus'_correct. eapply Qle_trans. apply Qabs_triangle. setoid_replace e with (e*(1-a) + a*e) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). assert (X:0 < 1 - a). change (0 < 1 + - a). rewrite <- Qlt_minus_iff. assumption. apply Qplus_le_compat; try assumption. rewrite -> err_prop_prop in Hs. unfold err_bound in Hs. apply Qmult_lt_0_le_reg_r with (/(1-a)). apply Qinv_lt_0_compat; assumption. rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. assumption. auto with *. Qed. Lemma err_prop_key' : forall (e:Q) (s: Stream Q), GeometricSeries s -> err_prop e s = true -> err_prop (a*e) (tl s) = true. Proof. intros e s [H _] Hs. rewrite -> err_prop_prop in *. unfold err_bound in *. rewrite -> Qle_minus_iff in H, Hs |- *. rewrite -> Qlt_minus_iff in Ha1. setoid_replace (a * e + - (Qabs (hd (tl s)) / (1 - a))) with (a * (e + - (Qabs (hd s)/(1-a)))+ (a * Qabs (hd s) + - Qabs (hd (tl s)))/(1+-a)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field). rewrite <- Qplus_0_r. apply Qplus_le_compat. apply Qmult_le_0_compat. exact Ha0. exact Hs. apply Qmult_le_0_compat. exact H. apply Qlt_le_weak, Qinv_lt_0_compat, Ha1. intro abs. rewrite abs in Ha1. exact (Qlt_irrefl 0 Ha1). Qed. Lemma err_prop_monotone : forall (e0 e1:Q) (s: Stream Q), (e0 <= e1) -> err_prop e0 s = true -> err_prop e1 s = true. Proof. intros e0 e1 s He H. rewrite -> err_prop_prop in *. apply Qle_trans with e0; assumption. Qed. Lemma err_prop_monotone' : forall (e:Q) (s: Stream Q), GeometricSeries s -> err_prop e s = true -> err_prop e (tl s) = true. Proof. intros e s Hs H. rewrite -> err_prop_prop in *. eapply Qle_trans;[|apply H]. unfold err_bound. apply Qmult_le_r. - apply Qinv_lt_0_compat. unfold Qminus. rewrite <- Qlt_minus_iff. exact Ha1. - destruct Hs as [H0 _]. eapply Qle_trans;[apply H0|]. rewrite <- (Qmult_1_l (Qabs(hd s))) at 2. apply Qmult_le_compat_r. apply Qlt_le_weak, Ha1. apply Qabs_nonneg. Qed. (** If a geometric sum s is bounded by e, summing s to any index p is within bound e. *) Lemma err_prop_correct : forall (p:nat) (e:Q) (s : Stream Q) (e':Stream Q -> bool), GeometricSeries s -> err_prop e s = true -> Qabs (InfiniteSum_fat e' s 0%Q p) <= e. Proof. induction p. - intros. simpl. apply err_prop_nonneg in H0. destruct (e' s); exact H0. - intros. simpl. destruct (e' s). apply err_prop_nonneg in H0. exact H0. rewrite InfiniteSum_fat_plus. rewrite Qplus'_correct, Qplus_0_l. rewrite <- Qplus'_correct. apply err_prop_key. exact H0. apply (IHp (a*e)). apply H. apply err_prop_key'; assumption. Qed. (** This lemma tells us how to compute an upper bound on the number of terms we will need to compute. It is okay for this error to be loose because the partial sums will bail out early when it sees that its estimate of the error is small enough. *) Lemma GeometricCovergenceLemma : forall (n:positive) (e:Qpos), /(proj1_sig e*(1 - a)) <= inject_Z (Zpos n) -> a^Zpos n <= proj1_sig e. Proof. destruct (Qle_lt_or_eq _ _ Ha0) as [Ha0'|Ha0']. - intros n e H. assert (0 < a^Zpos n). { assert (X:0 < proj1_sig (Qpos_power (exist _ _ Ha0') (Zpos n))%Qpos) by auto with *. exact X. } apply Qmult_lt_0_le_reg_r with ((/proj1_sig e)*/(a^Zpos n)). apply (Qle_lt_trans _ (0 * (/a^Zpos n))). rewrite Qmult_0_l. apply Qle_refl. apply Qmult_lt_r. apply Qinv_lt_0_compat; exact H0. apply Qinv_lt_0_compat, Qpos_ispos. assert (0 < proj1_sig e) by (apply Qpos_ispos). rewrite (Qmult_assoc (proj1_sig e)), Qmult_inv_r, Qmult_1_l. 2: apply Qpos_nonzero. setoid_replace (a ^ Zpos n * (/ proj1_sig e * / a ^ Zpos n)) with (/proj1_sig e) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field). 2: split. 2: apply Qpos_nonzero. 2: auto with *. rewrite -> Qlt_minus_iff in Ha1. change (0<1-a) in Ha1. rewrite -> Qle_minus_iff in H. apply Qle_trans with (1 + inject_Z (Zpos n) * (/a -1)). + rewrite -> Qle_minus_iff. setoid_replace (1 + inject_Z (Zpos n) * (/ a - 1) + - / proj1_sig e) with (1+(1 - a)*((inject_Z (Zpos n)*(1-a)*/a + (inject_Z (Zpos n) +-(/(proj1_sig e*(1 - a))))))) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field). 2: split; auto with *. apply (Qle_trans _ (1+0)). discriminate. apply Qplus_le_r. repeat apply Qmult_le_0_compat; simpl; auto with *. assert (0 <= 1-a) by auto with *. apply (Qle_trans _ (0+0)). discriminate. apply Qplus_le_compat. 2: exact H. apply Qmult_le_0_compat. apply Qmult_le_0_compat. discriminate. exact H2. apply Qlt_le_weak, Qinv_lt_0_compat, Ha0'. + clear -n Ha0'. induction n using Pind. simpl. setoid_replace (1 + inject_Z 1 * (/ a - 1)) with (/a) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). apply Qle_refl. rewrite Zpos_succ_morphism. unfold Z.succ. rewrite -> Qpower_plus;[|auto with *]. rewrite -> Qinv_mult_distr. rewrite -> Q.Zplus_Qplus. apply Qle_trans with ((1 + inject_Z (Zpos n) * (/ a - 1))*/a). rewrite -> Qle_minus_iff. setoid_replace ( (1 + inject_Z (Z.pos n) * (/ a - 1)) * / a + - (1 + (inject_Z (Z.pos n) + inject_Z 1) * (/ a - 1))) with (inject_Z (Zpos n)*(/a -1)^2) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). apply Qmult_le_0_compat. discriminate. unfold Qle. rewrite Z.mul_0_l. simpl. rewrite Z.mul_1_r. apply Z.square_nonneg. apply Qmult_le_compat_r. assumption. apply Qinv_le_0_compat; auto with *. - intros n e _. rewrite <- Ha0'. rewrite -> Qpower_0; auto with *. Qed. Definition InfiniteGeometricSum_maxIter series (err:Qpos) : positive := let x := (1-a) in let (n,d) := (Qabs (hd series))/(proj1_sig err*x*x) in match Z.succ (Z.div n (Zpos d)) with | Zpos p => p | _ => 1%positive end. Lemma InfiniteGeometricSum_maxIter_monotone : forall series (err:Qpos), GeometricSeries series -> (InfiniteGeometricSum_maxIter (tl series) err <= InfiniteGeometricSum_maxIter series err)%positive. Proof. intros series err Gs. unfold InfiniteGeometricSum_maxIter. cut ((Qabs (hd (tl series)) / (proj1_sig err * (1 - a) * (1 - a))) <= (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a)))). - generalize (Qabs (hd (tl series)) / (proj1_sig err * (1 - a) * (1 - a))) (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a))). intros [na da] [nb db] H. cut (Z.succ (na/Zpos da) <= Z.succ (nb/Zpos db))%Z. generalize (Z.succ (na / Zpos da)) (Z.succ (nb/Zpos db)). intros [|x|x] [|y|y] Hxy; try solve [apply Hxy | apply Qle_refl | elim Hxy; constructor | unfold Qle; simpl; repeat rewrite Pmult_1_r]. apply Pos.le_1_l. discriminate. apply Pos.le_1_l. discriminate. apply Zsucc_le_compat. unfold Qle in H. simpl in H. rewrite <- (Zdiv_mult_cancel_r na (Zpos da) (Zpos db)). 2: discriminate. rewrite <- (Zdiv_mult_cancel_r nb (Zpos db) (Zpos da)). 2: discriminate. rewrite (Zmult_comm (Zpos db) (Zpos da)). apply Z_div_le. reflexivity. exact H. - assert (X:0 < 1 - a). change (0 < 1 + - a). rewrite <- Qlt_minus_iff. assumption. apply Qle_shift_div_l. apply (Qpos_ispos (err * (exist _ _ X) * (exist _ _ X))). unfold Qdiv. rewrite <- Qmult_assoc. rewrite <- (Qmult_comm (proj1_sig err * (1 - a) * (1 - a))). rewrite Qmult_inv_r, Qmult_1_r. destruct Gs as [H _]. eapply Qle_trans. apply H. rewrite <- (Qmult_1_l (Qabs (hd series))) at 2. apply Qmult_le_compat_r. apply Qlt_le_weak, Ha1. apply Qabs_nonneg. apply (Qpos_nonzero (err * (exist _ _ X) * (exist _ _ X))). Qed. Lemma InfiniteGeometricSum_maxIter_correct : forall series (err:Qpos), GeometricSeries series -> err_prop (proj1_sig err) (Str_nth_tl (nat_of_P (InfiniteGeometricSum_maxIter series err)) series) = true. Proof. intros series err H. rewrite -> err_prop_prop. unfold err_bound. assert (X:0 < 1 - a). change (0 < 1 + - a). rewrite <- Qlt_minus_iff. assumption. apply Qle_shift_div_r; try assumption. assert (Y:(Qabs (hd series) * a ^ Zpos (InfiniteGeometricSum_maxIter series err) <= proj1_sig err * (1 - a))). { destruct (Qlt_le_dec 0 (Qabs (hd series))). apply Qmult_lt_0_le_reg_r with (/Qabs (hd series)). apply Qinv_lt_0_compat; assumption. rewrite (Qmult_comm (Qabs (hd series))), <- Qmult_assoc. rewrite Qmult_inv_r, Qmult_1_r. 2: auto with *. cut (a ^ Zpos (InfiniteGeometricSum_maxIter series err) <= proj1_sig (err * exist _ _ X * Qpos_inv (exist _ _ q))%Qpos). autorewrite with QposElim; auto. apply GeometricCovergenceLemma. autorewrite with QposElim. unfold InfiniteGeometricSum_maxIter. simpl (/ (proj1_sig (err * exist (Qlt 0) (1 - a) X * Qpos_inv (exist (Qlt 0) (Qabs (hd series)) q))%Qpos * (1 - a))). setoid_replace (/ (proj1_sig err * (1 - a) * / Qabs (hd series) * (1 - a))) with (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a))) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field). 2: repeat split;auto with *;apply Qpos_nonzero. cut (0 < (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a)))). generalize (Qabs (hd series) / (proj1_sig err * (1 - a) * (1 - a))). intros [n d] Hnd. apply Qle_trans with (inject_Z (Z.succ (n/Zpos d))). unfold Qle. simpl. unfold Z.succ. apply Zle_0_minus_le. replace ((n / Zpos d + 1) * Zpos d - n * 1)%Z with (Zpos d*(n/Zpos d) + n mod (Zpos d) - n mod (Zpos d) - n + Zpos d)%Z by ring. rewrite <- Z_div_mod_eq_full. replace (n - n mod (Zpos d) - n + Zpos d)%Z with (Zpos d - n mod (Zpos d))%Z by ring. apply Zle_minus_le_0. destruct (Z_mod_lt n (Zpos d)); auto with *. generalize (Z.succ (n/Zpos d)). intros [|z|z]. discriminate. apply Qle_refl. discriminate. cut (0 < proj1_sig ((exist _ _ q) * Qpos_inv(err * (exist _ _ X)*(exist _ _ X)))%Qpos). simpl; auto. apply Q.Qmult_lt_0_compat; auto with *. setoid_replace (Qabs (hd series)) with 0. rewrite Qmult_0_l. apply (Qpos_nonneg (err * (exist _ _ X))). apply Qle_antisym; try assumption. apply Qabs_nonneg. } apply Qle_trans with (Qabs (hd series)*a^Zpos (InfiniteGeometricSum_maxIter series err)); try assumption. clear Y. generalize (InfiniteGeometricSum_maxIter series err). intros p. revert series H. induction p using Pind; intros series H. simpl. destruct H. rewrite -> Qmult_comm. assumption. rewrite nat_of_P_succ_morphism. rewrite Zpos_succ_morphism. unfold Z.succ. rewrite -> Qpower_plus';[|discriminate]. rewrite Qmult_assoc. apply Qle_trans with (Qabs (hd (Str_nth_tl (nat_of_P p) series))*a). change (S (nat_of_P p)) with (1+(nat_of_P p))%nat. rewrite <- Str_nth_tl_plus. cut (GeometricSeries (Str_nth_tl (nat_of_P p) series)). generalize (Str_nth_tl (nat_of_P p) series). intros s [H0 _]. rewrite -> Qmult_comm. assumption. clear -H. induction (nat_of_P p). auto. change (S n) with (1+n)%nat. rewrite <- Str_nth_tl_plus. simpl. destruct IHn; assumption. apply Qmult_le_compat_r; try assumption. apply IHp; assumption. Qed. (** The implemenation of [InfiniteGeometricSum]. *) Definition InfiniteGeometricSum_fat series (e:QposInf) : Q := match e with | QposInfinity => 0 | Qpos2QposInf err => InfiniteSum_fat (err_prop (proj1_sig err)) series 0%Q (Pos.to_nat (InfiniteGeometricSum_maxIter series err)) end. Definition InfiniteGeometricSum_raw series (e:QposInf) : Q := match e with | QposInfinity => 0 | Qpos2QposInf err => InfiniteSum_raw_N (Pos.to_nat (Pos.size (InfiniteGeometricSum_maxIter series err))) (err_prop (proj1_sig err)) (fun _ r => r) series 0%Q end. Lemma InfiniteGeometricSum_raw_correct : forall (series : Stream Q) (e : QposInf), GeometricSeries series -> InfiniteGeometricSum_raw series e = InfiniteGeometricSum_fat series e. Proof. assert (forall n:nat, lt 0 n -> Pos.of_nat (2 ^ n) = (2 ^ Pos.of_nat n)%positive) as inj_pow. { induction n. - intros. exfalso; inversion H. - intros _. destruct n. reflexivity. rewrite Nat2Pos.inj_succ. 2: discriminate. rewrite Pos.pow_succ_r. rewrite <- IHn. 2: apply le_n_S, Nat.le_0_l. clear IHn. generalize (S n). intro k. change (2 ^ S k)%nat with (2 * 2 ^ k)%nat. rewrite Nat2Pos.inj_mul. reflexivity. discriminate. apply Nat.pow_nonzero. discriminate. } intros. destruct e. 2: reflexivity. simpl. rewrite InfiniteSum_raw_N_correct. apply InfiniteSum_fat_add_stop. 2: apply InfiniteGeometricSum_maxIter_correct, H. specialize (inj_pow (Pos.to_nat (Pos.size (InfiniteGeometricSum_maxIter series q))) (Pos2Nat.is_pos _)). rewrite Pos2Nat.id in inj_pow. rewrite <- Nat2Pos.id. rewrite inj_pow. apply Pos2Nat.inj_le. apply Pos.lt_le_incl, Pos.size_gt. apply Nat.pow_nonzero. discriminate. Qed. (* Now we prove that bounds are correct when applied to tails of a geometric series at indexes p and p0. *) Lemma err_prop_tail_correct : forall (series : Stream Q) (e0 e1:Q) (p p0 : nat), GeometricSeries series -> e1 <= e0 -> err_prop e0 (Str_nth_tl p series) = true -> err_prop e1 (Str_nth_tl p0 series) = true -> Qball e0 (InfiniteSum_fat (err_prop e0) series 0%Q p) (InfiniteSum_fat (err_prop e1) series 0%Q p0). Proof. intros series e0 e1 p0 p1 H He H0 H1. (* err_prop e1 implies err_prop e0 so the e1 sum is longer. Replace by the first indexes where the filters are triggered, the one of e1 being higher. The subtraction is a tail sum of e0 after the convergence index, so it is below e0. *) pose proof (@InfiniteSum_fat_remove_filter p0 (err_prop e0) series 0%Q) as [i [H2 H3]]. exact H0. rewrite H2. pose proof (@InfiniteSum_fat_remove_filter p1 (err_prop e1) series 0%Q) as [j [H4 H5]]. exact H1. rewrite H4. clear H4 H2 H1 H0 p0 p1. destruct H3. destruct H5. destruct (Nat.lt_ge_cases j i). - exfalso. specialize (H0 j H4). pose proof (err_prop_monotone (Str_nth_tl j series) He H3) as mon. rewrite mon in H0. discriminate. - unfold Qball. rewrite <- AbsSmall_Qabs, Qabs_Qminus. apply Nat.le_exists_sub in H4. destruct H4 as [p [H4 _]]. subst j. clear H3 H2 He e1. rewrite InfiniteSum_fat_minus. apply err_prop_correct. 2: exact H1. apply ForAll_Str_nth_tl, H. Qed. Lemma InfiniteGeometricSum_raw_prf : forall series, GeometricSeries series -> is_RegularFunction Qball (InfiniteGeometricSum_raw series). Proof. intros series H e0 e1. rewrite InfiniteGeometricSum_raw_correct. rewrite InfiniteGeometricSum_raw_correct. 2: exact H. 2: exact H. pose proof (InfiniteGeometricSum_maxIter_correct e0 H) as H0. pose proof (InfiniteGeometricSum_maxIter_correct e1 H) as H1. destruct (Qle_total (proj1_sig e1) (proj1_sig e0)). - apply ball_weak. apply Qpos_nonneg. apply (err_prop_tail_correct _ _ H q H0 H1). - rewrite Qplus_comm. apply ball_weak. apply Qpos_nonneg. apply ball_sym. apply (err_prop_tail_correct _ _ H q H1 H0). Qed. Definition InfiniteGeometricSum series (Gs:GeometricSeries series) : CR := Build_RegularFunction (InfiniteGeometricSum_raw_prf Gs). (** The [InfiniteGeometricSum] is correct. *) Lemma InfiniteGeometricSum_step : forall series (Gs:GeometricSeries series), (InfiniteGeometricSum Gs == ('(hd series))+(InfiniteGeometricSum (ForAll_Str_nth_tl 1%nat Gs)))%CR. Proof. intros series Gs. rewrite -> CRplus_translate. apply regFunEq_equiv, regFunEq_e. intros e. change (approximate (InfiniteGeometricSum Gs) e) with (InfiniteGeometricSum_raw series e). rewrite InfiniteGeometricSum_raw_correct. 2: exact Gs. simpl (InfiniteGeometricSum (ForAll_Str_nth_tl 1 Gs)). change (approximate (translate (hd series) (InfiniteGeometricSum (ForAll_Str_nth_tl 1 Gs))) e) with (hd series + (InfiniteGeometricSum_raw (tl series) e)). rewrite InfiniteGeometricSum_raw_correct. 2: apply Gs. simpl. rewrite InfiniteSum_fat_extend. 2: apply InfiniteGeometricSum_maxIter_correct, Gs. simpl. case_eq (err_prop (proj1_sig e) series); intros He. - apply ball_sym. simpl. unfold Qball. rewrite <- AbsSmall_Qabs. unfold Qminus. rewrite Qplus_0_r. eapply Qle_trans. apply Qabs_triangle. apply Qplus_le_compat; simpl. rewrite -> err_prop_prop in He. unfold err_bound in He. assert (X:0 < 1 - a). change (0 < 1 + - a). rewrite <- Qlt_minus_iff. assumption. clear - He Ha0 X. setoid_replace (Qabs (hd series)) with ((Qabs (hd series)/(1-a))*(1-a)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field). 2: auto with *. apply (Qle_trans _ ((proj1_sig e) * (1-a))). apply Qmult_le_compat_r. exact He. apply Qlt_le_weak, X. rewrite <- (Qmult_1_r (proj1_sig e)) at 2. apply Qmult_le_l. apply Qpos_ispos. rewrite <- (Qplus_0_r 1) at 2. apply Qplus_le_r. apply (Qopp_le_compat 0), Ha0. apply err_prop_correct. destruct Gs; assumption. apply err_prop_monotone'; assumption. - assert (Qplus' 0 (hd series) == hd series). { rewrite Qplus'_correct. apply Qplus_0_l. } rewrite (InfiniteSum_fat_wd _ _ _ H). rewrite InfiniteSum_fat_plus. rewrite (@InfiniteSum_fat_add_stop (Pos.to_nat (InfiniteGeometricSum_maxIter series e)) (Pos.to_nat (InfiniteGeometricSum_maxIter (tl series) e))). apply Qball_Reflexive. apply (Qpos_nonneg (e+e)). apply Pos2Nat.inj_le. apply (@InfiniteGeometricSum_maxIter_monotone series e), Gs. apply InfiniteGeometricSum_maxIter_correct, Gs. Qed. Lemma InfiniteGeometricSum_bound : forall series (Gs:GeometricSeries series), (-'(err_bound series) <= InfiniteGeometricSum Gs /\ InfiniteGeometricSum Gs <= '(err_bound series))%CR. Proof. intros series Gs. assert (Y:0 < 1 - a). { change (0 < 1 + - a). rewrite <- Qlt_minus_iff. assumption. } destruct (Qeq_dec (err_bound series) 0) as [Hq|Hq]. - setoid_replace (InfiniteGeometricSum Gs) with 0%CR. split; simpl; rewrite -> Hq; try apply CRle_refl. rewrite CRopp_0. apply CRle_refl. apply regFunEq_equiv, regFunEq_e. intros e. apply ball_sym. change (approximate (InfiniteGeometricSum Gs) e) with (InfiniteGeometricSum_raw series e). rewrite InfiniteGeometricSum_raw_correct. 2: exact Gs. simpl. unfold Qball. unfold QAbsSmall. setoid_replace (0 - InfiniteSum_fat (err_prop (proj1_sig e)) series 0 (Pos.to_nat (InfiniteGeometricSum_maxIter series e)))%Q with 0. split. apply (Qopp_le_compat 0), (Qpos_nonneg (e+e)). apply (Qpos_nonneg (e+e)). unfold canonical_names.equiv, stdlib_rationals.Q_eq. unfold Qminus. rewrite Qplus_0_l. assert (X:err_prop (proj1_sig e) series = true). rewrite -> err_prop_prop. rewrite -> Hq. apply Qpos_nonneg. destruct (InfiniteGeometricSum_maxIter series e) using Pind. simpl. destruct (err_prop (proj1_sig e) series). reflexivity. discriminate. rewrite Pos2Nat.inj_succ. simpl. destruct (err_prop (proj1_sig e) series). reflexivity. discriminate. - cut (-(' err_bound series) <= InfiniteGeometricSum Gs /\ InfiniteGeometricSum Gs <= 'err_bound series)%CR. + intros [H0 H1]. split; assumption. + setoid_replace (InfiniteGeometricSum Gs) with (InfiniteGeometricSum Gs - 0)%CR by (unfold canonical_names.equiv, msp_Equiv; ring). apply CRAbsSmall_ball. apply regFunBall_e. intros d. change (approximate (InfiniteGeometricSum Gs) d) with (InfiniteGeometricSum_raw series d). rewrite InfiniteGeometricSum_raw_correct. 2: exact Gs. simpl. set (p:=(InfiniteGeometricSum_maxIter series d)). unfold Qball. rewrite <- AbsSmall_Qabs. unfold Qminus. rewrite Qplus_0_r. apply (err_prop_correct _ (proj1_sig d+err_bound series+proj1_sig d)); try assumption. apply err_prop_monotone with (err_bound series). simpl. apply (Qle_trans _ (0 + err_bound series + 0)). rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl. apply Qplus_le_compat. apply Qplus_le_compat. apply Qpos_nonneg. apply Qle_refl. apply Qpos_nonneg. rewrite -> err_prop_prop. apply Qle_refl. Qed. Lemma InfiniteGeometricSum_small_tail : forall series (e : Qpos), GeometricSeries series -> {n : nat & forall Gs : GeometricSeries (Str_nth_tl n series), (- ' proj1_sig e <= InfiniteGeometricSum Gs /\ InfiniteGeometricSum Gs <= 'proj1_sig e)%CR }. Proof. intros series e. exists (nat_of_P (InfiniteGeometricSum_maxIter series e)). intros Gs. pose proof (InfiniteGeometricSum_bound Gs) as [H0 H1]. split. refine (CRle_trans _ H0). apply CRopp_le_compat. rewrite -> CRle_Qle. rewrite <- err_prop_prop. apply InfiniteGeometricSum_maxIter_correct. assumption. apply (CRle_trans H1). rewrite -> CRle_Qle. rewrite <- err_prop_prop. apply InfiniteGeometricSum_maxIter_correct. assumption. Qed. End GeometricSeries. (** If one stream is [DecreasingNonNegative] and the other is a [GeometricSeries], then the result is a [GeometricSeries]. *) Lemma mult_Streams_Gs : forall a (x y : Stream Q), (DecreasingNonNegative x) -> (GeometricSeries a y) -> (GeometricSeries a (mult_Streams x y)). Proof. cofix mult_Streams_Gs. intros a x y Hx Hy. constructor. destruct Hy as [Hy _]. apply dnn_alt in Hx. destruct Hx as [[[Hx2 _] [[Hx0 Hx1] _]] _]. simpl. rewrite -> Qabs_Qmult. apply Qle_trans with (Qabs (CoqStreams.hd x) * Qabs (CoqStreams.hd (CoqStreams.tl y))). apply Qmult_le_compat_r. do 2 (rewrite -> Qabs_pos; try assumption). apply Qabs_nonneg. rewrite -> Qabs_Qmult. rewrite Qmult_comm. rewrite (Qmult_comm (Qabs (CoqStreams.hd x))), Qmult_assoc. apply Qmult_le_compat_r; try assumption. apply Qabs_nonneg. destruct Hy. apply mult_Streams_Gs. 2: exact Hy. apply Hx. Qed. (** [powers] is a [GeometricSeries]. *) Lemma powers_help_Gs (a : Q) : (0 <= a) -> forall c, (GeometricSeries a (powers_help a c)). Proof. intros Ha. cofix powers_help_Gs. intros c. constructor. simpl. rewrite -> Qmult_comm. rewrite -> Qabs_Qmult. rewrite -> (Qabs_pos a); try assumption. apply Qle_refl. apply powers_help_Gs. Qed. Lemma powers_Gs (a : Q) : (0 <= a) -> (GeometricSeries a (powers a)). Proof. intros Ha. apply (powers_help_Gs Ha). Qed. Definition InfiniteGeometricSum_shift_raw (s : Stream Q) (n : nat) {a : Q} (Gs : GeometricSeries a (Str_nth_tl n s)) (e : QposInf) : Q := take s n Qplus' 0 + InfiniteGeometricSum_raw a (Str_nth_tl n s) e. Lemma InfiniteGeometricSum_raw_shift_prf : forall (s : Stream Q) (n : nat) {a : Q} (Gs : GeometricSeries a (Str_nth_tl n s)), 0 <= a -> a < 1 -> is_RegularFunction Qball (InfiniteGeometricSum_shift_raw s n Gs). Proof. intros. intros e1 e2. apply AbsSmall_Qabs. unfold InfiniteGeometricSum_shift_raw. setoid_replace (take s n Qplus' 0 + InfiniteGeometricSum_raw a (Str_nth_tl n s) e1 - (take s n Qplus' 0 + InfiniteGeometricSum_raw a (Str_nth_tl n s) e2)) with (InfiniteGeometricSum_raw a (Str_nth_tl n s) e1 - InfiniteGeometricSum_raw a (Str_nth_tl n s) e2) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; ring). apply AbsSmall_Qabs. apply (InfiniteGeometricSum_raw_prf H H0 Gs). Qed. Definition InfiniteGeometricSum_shift (s : Stream Q) (n : nat) (a : Q) (Gs : GeometricSeries a (Str_nth_tl n s)) (apos : 0 <= a) (aone : a < 1) : CR := Build_RegularFunction (InfiniteGeometricSum_raw_shift_prf s n Gs apos aone). (* Proof of correctness : the limit of the geometric series does not depend on the geometric ratio. *) Lemma InfiniteGeometricSum_wd : forall (s : Stream Q) (a b : Q) (Gsa : GeometricSeries a s) (Gsb : GeometricSeries b s) (apos : 0 <= a) (aone : a < 1) (bpos : 0 <= b) (bone : b < 1), msp_eq (InfiniteGeometricSum apos aone Gsa) (InfiniteGeometricSum bpos bone Gsb). Proof. assert (forall (s : Stream Q) (a b : Q) (Gsa : GeometricSeries a s) (Gsb : GeometricSeries b s) (apos : 0 <= a) (aone : a < 1) (bpos : 0 <= b) (bone : b < 1), a <= b -> msp_eq (InfiniteGeometricSum apos aone Gsa) (InfiniteGeometricSum bpos bone Gsb)). { intros. (* The same series is summed up to 2 different indexes, the distance is the sum between the lower and upper index. The upper index is associated to b, which corresponds to a slower geometric series. *) intros e1 e2. change (approximate (InfiniteGeometricSum apos aone Gsa) e1) with (InfiniteGeometricSum_raw a s e1). rewrite (InfiniteGeometricSum_raw_correct apos aone _ Gsa). change (approximate (InfiniteGeometricSum bpos bone Gsb) e2) with (InfiniteGeometricSum_raw b s e2). rewrite (InfiniteGeometricSum_raw_correct bpos bone _ Gsb). simpl. pose proof (@InfiniteSum_fat_remove_filter (Pos.to_nat (InfiniteGeometricSum_maxIter a s e1)) (fun s0 : Stream Q => match Qabs (hd s0) / (1 - a) ?= proj1_sig e1 with | Gt => false | _ => true end) s 0%Q) as [i [H2 H3]]. apply (InfiniteGeometricSum_maxIter_correct apos aone _ Gsa). rewrite H2. pose proof (@InfiniteSum_fat_remove_filter (Pos.to_nat (InfiniteGeometricSum_maxIter b s e2)) (fun s0 : Stream Q => match Qabs (hd s0) / (1 - b) ?= proj1_sig e2 with | Gt => false | _ => true end) s 0%Q) as [j [H4 H5]]. apply (InfiniteGeometricSum_maxIter_correct bpos bone _ Gsb). rewrite H4. destruct (Nat.lt_ge_cases i j) as [H0|H0]. - rewrite Qplus_0_r. apply Nat.le_exists_sub in H0. destruct H0 as [k [H0 _]]. subst j. unfold Qball. clear H5. rewrite <- AbsSmall_Qabs, Qabs_Qminus. replace (k + S i)%nat with (S k + i)%nat by (rewrite Nat.add_succ_r; reflexivity). rewrite InfiniteSum_fat_minus. apply (Qle_trans _ (proj1_sig e1 + 0)). rewrite Qplus_0_r. apply (err_prop_correct apos aone). apply ForAll_Str_nth_tl, Gsa. apply H3. apply Qplus_le_r, Qpos_nonneg. - rewrite Qplus_0_r. apply Nat.le_exists_sub in H0. destruct H0 as [k [H0 _]]. subst i. unfold Qball. clear H3. rewrite <- AbsSmall_Qabs, Qabs_Qminus. rewrite Qabs_Qminus. rewrite InfiniteSum_fat_minus. apply (Qle_trans _ (0 + proj1_sig e2)). rewrite Qplus_0_l. apply (err_prop_correct bpos bone). apply ForAll_Str_nth_tl, Gsb. apply H5. apply Qplus_le_l, Qpos_nonneg. } intros. destruct (Qle_total a b). apply H, q. symmetry. apply H, q. Qed. corn-8.20.0/reals/fast/CRGroupOps.v000066400000000000000000000566421473720167500170300ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import QArith Qabs. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.model.metric2.CRmetric. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.metric2.ProductMetric. Require Import CoRN.stdlib_omissions.Pair. Require Import MathClasses.interfaces.canonical_names. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Opaque CR Qmin Qmax. Local Open Scope Q_scope. Local Open Scope uc_scope. #[global] Instance CR0: Zero CR := cast Q CR 0. Notation "0" := (inject_Q_CR 0) : CR_scope. #[global] Instance CR1: One CR := cast Q CR 1. Notation "1" := (inject_Q_CR 1) : CR_scope. (** ** Addition Lifting addition over [Q] by one parameter yields a rational translation function. *) Lemma Qtranslate_uc_prf (a:Q) : is_UniformlyContinuousFunction (fun b:Q => (a+b):Q) Qpos2QposInf. Proof. intros e b0 b1 H. simpl in *. unfold Qball in *. unfold QAbsSmall. setoid_replace (a + b0 - (a + b1)) with (b0 - b1)%Q. apply H. ring_simplify. reflexivity. Qed. Definition Qtranslate_uc (a:Q_as_MetricSpace) : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (Qtranslate_uc_prf a). Transparent CR. Definition translate (a:Q) : CR --> CR := Cmap QPrelengthSpace (Qtranslate_uc a). Lemma translate_ident : forall x:CR, (translate 0 x==x)%CR. Proof. intros x. unfold translate. assert (H:msp_eq (Qtranslate_uc 0) (uc_id _)). apply ucEq_equiv. intros a. simpl. rewrite Qplus_0_l. reflexivity. simpl. intros e1 e2. destruct x; simpl. rewrite Qplus_0_r. rewrite Qplus_0_l. apply regFun_prf. Qed. (** Lifting translate yields binary addition over CR. *) Lemma Qplus_uc_prf : is_UniformlyContinuousFunction Qtranslate_uc Qpos2QposInf. Proof. intros e a0 a1 H. split. apply Qpos_nonneg. intro b. simpl in *. do 2 rewrite -> (fun x => Qplus_comm x b). apply Qtranslate_uc_prf. assumption. Qed. Definition Qplus_uc : Q_as_MetricSpace --> Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction Qplus_uc_prf. (** Finally, CRplus: *) Definition CRplus_uc : CR --> CR --> CR := Cmap2 QPrelengthSpace QPrelengthSpace Qplus_uc. #[global] Instance CRplus: Plus CR := ucFun2 CRplus_uc. Notation "x + y" := (ucFun2 CRplus_uc x y) : CR_scope. Lemma CRplus_translate : forall (a:Q) (y:CR), (' a + y == translate a y)%CR. Proof. intros a y. unfold ucFun2, CRplus. unfold Cmap2. unfold inject_Q_CR. simpl. intros e1 e2. simpl. unfold Cap_raw. simpl. destruct y; simpl. simpl. split. - ring_simplify. destruct (regFun_prf ((1#2)*e1)%Qpos e2) as [H _]. simpl in H. refine (Qle_trans _ _ _ _ H). ring_simplify. apply Qplus_le_l. apply Qmult_le_r. apply Qpos_ispos. discriminate. - ring_simplify. destruct (regFun_prf ((1#2)*e1)%Qpos e2) as [_ H]. apply (Qle_trans _ _ _ H). apply Qplus_le_l. simpl. rewrite <- (Qmult_1_l (` e1)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. Qed. #[global] Hint Rewrite CRplus_translate : CRfast_compute. Lemma translate_Qplus : forall a b:Q, (translate a ('b)=='(a+b)%Q)%CR. Proof. intros a b. unfold translate, Cmap. setoid_rewrite -> Cmap_fun_correct. apply MonadLaw3. Qed. #[global] Hint Rewrite translate_Qplus : CRfast_compute. (** ** Negation Lifting negation on [Q] yields negation on CR. *) Lemma Qopp_uc_prf : @is_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace Qopp Qpos2QposInf. Proof. intros e a b H. simpl in *. unfold Qball in *. apply QAbsSmall_opp in H. unfold QAbsSmall. setoid_replace (-a - - b) with (-(a-b)). apply H. ring_simplify. reflexivity. Qed. Definition Qopp_uc : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction Qopp_uc_prf. #[global] Instance CRopp: Negate CR := Cmap QPrelengthSpace Qopp_uc. Notation "- x" := (CRopp x) : CR_scope. (** ** Subtraction There is no subtraction on CR. It is simply notation for adding a negated quantity. This way all lemmas about addition automatically apply to subtraction. *) Notation "x - y" := (x + (- y))%CR : CR_scope. (* begin hide *) Add Morphism CRopp with signature (@msp_eq _) ==> (@msp_eq _) as CRopp_wd. Proof. apply uc_wd. Qed. (* end hide *) (** ** Inequality First a predicate for nonnegative numbers is defined. *) Definition CRnonNeg (x:CR) := forall e:Qpos, (-proj1_sig e) <= (approximate x e). (* begin hide *) Add Morphism CRnonNeg with signature (@msp_eq _) ==> iff as CRnonNeg_wd. Proof. assert (forall x1 x2 : RegularFunction Qball, regFunEq x1 x2 -> CRnonNeg x1 -> CRnonNeg x2). intros x y Hxy Hx e. apply Qnot_lt_le. intros He. rewrite -> Qlt_minus_iff in He. pose (e' := exist _ _ He). pose (H1:=(Hx ((1#3)*e')%Qpos)). pose (H2:=(Hxy ((1#3)*e')%Qpos e)). destruct H2 as [_ H2]. change (approximate x ((1 # 3) * e')%Qpos - approximate y e <= proj1_sig ((1 # 3) * e' + e)%Qpos) in H2. rewrite -> Qle_minus_iff in H1. rewrite -> Qle_minus_iff in H2. autorewrite with QposElim in *. ring_simplify in H1. ring_simplify in H2. assert (0+0<=(approximate x ((1 # 3) * e')%Qpos + (1 # 3) * proj1_sig e') + ((1 # 3) * proj1_sig e' + proj1_sig e + (-1 # 1) * approximate x ((1 # 3) * e')%Qpos + approximate y e)) as H3. apply Qplus_le_compat; assumption. ring_simplify in H3. setoid_replace ((6 # 9) * proj1_sig e' + proj1_sig e + approximate y e) with ((6#9)* proj1_sig e' - proj1_sig e') in H3. ring_simplify in H3. apply (Qle_not_lt _ _ H3). rewrite -> Qlt_minus_iff. ring_simplify. apply (Qpos_ispos ((3#9)*e')). unfold e'. simpl. ring_simplify. reflexivity. intros. split. apply H, regFunEq_equiv; assumption. apply H. apply regFunEq_equiv. symmetry. assumption. Qed. (* end hide *) (** And similarly for nonpositive. *) Definition CRnonPos (x:CR) := forall e:Qpos, (approximate x e) <= proj1_sig e. (* begin hide *) Add Morphism CRnonPos with signature (@msp_eq _) ==> iff as CRnonPos_wd. Proof. assert (forall x1 x2 : RegularFunction Qball, regFunEq x1 x2 -> CRnonPos x1 -> CRnonPos x2). intros x y Hxy Hx e. apply Qnot_lt_le. intros He. rewrite -> Qlt_minus_iff in He. pose (e' := exist _ _ He). pose (H1:=(Hx ((1#3)*e')%Qpos)). pose (H2:=(Hxy ((1#3)*e')%Qpos e)). destruct H2 as [H2 _]. change (-proj1_sig ((1 # 3) * e' + e)%Qpos <= approximate x ((1 # 3) * e')%Qpos - approximate y e) in H2. rewrite -> Qle_minus_iff in H1. rewrite -> Qle_minus_iff in H2. simpl in *. ring_simplify in H1. ring_simplify in H2. assert (H3: 0+0<=((1 # 3) * proj1_sig e' + (-1 # 1) * approximate x ((1 # 3) * e')%Qpos) +(approximate x ((1 # 3) * e')%Qpos + (-1 # 1) * approximate y e + (1 # 3) * proj1_sig e' + proj1_sig e)). apply Qplus_le_compat. simpl. ring_simplify. assumption. simpl. ring_simplify. assumption. ring_simplify in H3. setoid_replace ((6 # 9) * proj1_sig e' + (-1 # 1) * approximate y e + proj1_sig e) with ((6#9)*proj1_sig e'-proj1_sig e') in H3. ring_simplify in H3. apply (Qle_not_lt _ _ H3). rewrite -> Qlt_minus_iff. ring_simplify. apply (Qpos_ispos ((3#9)*e')). unfold e'. simpl. ring_simplify. reflexivity. intros. split. apply H, regFunEq_equiv; assumption. apply H. apply regFunEq_equiv. symmetry. assumption. Qed. (* end hide *) (** Inequality is defined in terms of nonnegativity. *) #[global] Instance CRle: Le CR := λ x y, (CRnonNeg (y - x))%CR. Infix "<=" := CRle : CR_scope. (* begin hide *) Add Morphism CRle with signature (@msp_eq _) ==> (@msp_eq _) ==> iff as CRle_wd. Proof. intros x1 x2 Hx y1 y2 Hy. change (x1==x2)%CR in Hx. change (y1==y2)%CR in Hy. unfold CRle. apply CRnonNeg_wd. apply ucFun2_wd. assumption. apply CRopp_wd. assumption. Qed. (* end hide *) (** Basic properties of inequality *) Lemma CRle_refl : forall x, (x <= x)%CR. Proof. intros x e. simpl. unfold Cap_raw. simpl. rewrite -> Qle_minus_iff. ring_simplify. apply Qlt_le_weak. destruct e; exact q. Qed. Lemma CRle_antisym : forall x y, (x==y <-> (x <= y /\ y <= x))%CR. Proof. intros x y. split;[intros H;rewrite -> H;split; apply CRle_refl|]. intros [H1 H2]. rewrite <- (doubleSpeed_Eq x). rewrite <- (doubleSpeed_Eq y). apply regFunEq_equiv, regFunEq_e. intros e. apply ball_weak. apply Qpos_nonneg. split;[apply H2|]. specialize (H1 e). apply Qopp_le_compat in H1. rewrite Qopp_involutive in H1. refine (Qle_trans _ _ _ _ H1). simpl. unfold Cap_raw. simpl. ring_simplify. apply Qle_refl. Qed. Lemma CRle_trans : forall x y z, (x <= y -> y <= z -> x <= z)%CR. Proof. intros x y z H1 H2. unfold CRle. rewrite <- (doubleSpeed_Eq (z-x)%CR). intros e. assert (H1':=H1 ((1#2)*e)%Qpos). assert (H2':=H2 ((1#2)*e)%Qpos). clear H1 H2. simpl in *. unfold Cap_raw in *. simpl in *. apply (Qle_trans _ ((approximate z ((1 # 2) * ((1 # 2) * e))%Qpos - approximate y ((1 # 2) * ((1 # 2) * e))%Qpos + (approximate y ((1 # 2) * ((1 # 2) * e))%Qpos - approximate x ((1 # 2) * ((1 # 2) * e))%Qpos)))). 2: ring_simplify; apply Qle_refl. apply (Qle_trans _ (-(1#2)*proj1_sig e + - (1#2)* proj1_sig e)). ring_simplify. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply Qplus_le_compat; apply (Qle_trans _ (- ((1 # 2) * ` e))). destruct e. simpl. ring_simplify. apply Qle_refl. assumption. destruct e. simpl. ring_simplify. apply Qle_refl. assumption. Qed. (** ** Maximum [QboundBelow] ensures that a real number is at least some fixed rational number. It is the lifting of the first parameter of [Qmax]. *) Lemma QboundBelow_uc_prf (a:Q) : is_UniformlyContinuousFunction (fun b:Q => (Qmax a b):Q) Qpos2QposInf. Proof. intros e b0 b1 H. simpl in *. assert (X:forall a b0 b1, Qball (proj1_sig e) b0 b1 -> b0 <= a <= b1 -> Qball (proj1_sig e) a b1). clear a b0 b1 H. intros a b0 b1 H [H1 H2]. unfold Qball in *. unfold QAbsSmall in *. split. apply Qle_trans with (b0-b1). apply H. apply Qplus_le_l. assumption. apply Qle_trans with 0. apply (Qplus_le_l _ _ b1). ring_simplify. assumption. apply Qpos_nonneg. do 2 apply Qmax_case; intros H1 H2. apply ball_refl. apply Qpos_nonneg. eapply X. apply H. tauto. apply ball_sym. apply X with b1. apply ball_sym. apply H. tauto. assumption. Qed. Definition QboundBelow_uc (a:Q_as_MetricSpace) : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (QboundBelow_uc_prf a). Definition boundBelow (a:Q) : CR --> CR := Cmap QPrelengthSpace (QboundBelow_uc a). (** CRmax is the lifting of [QboundBelow]. *) Lemma Qmax_uc_prf : is_UniformlyContinuousFunction QboundBelow_uc Qpos2QposInf. Proof. intros e a0 a1 H. split. apply Qpos_nonneg. intro b. simpl in *. do 2 rewrite -> (fun x => Qmax_comm x b). apply QboundBelow_uc_prf. assumption. Qed. Definition Qmax_uc : Q_as_MetricSpace --> Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction Qmax_uc_prf. Definition CRmax : CR --> CR --> CR := Cmap2 QPrelengthSpace QPrelengthSpace Qmax_uc. Lemma Qmax_contract : forall (a b c : Q), Qabs (Qmax a b - Qmax a c) <= Qabs (b - c). Proof. intros. apply Qabs_Qle_condition. split. - apply Qmax_case. + intros. apply Qmax_case. intros. unfold Qminus. rewrite Qplus_opp_r. apply (Qopp_le_compat 0). apply Qabs_nonneg. intros. rewrite Qabs_neg, Qopp_involutive. apply Qplus_le_l, H. apply (Qplus_le_l _ _ c). ring_simplify. exact (Qle_trans _ _ _ H H0). + intros. apply Qmax_case. intros. apply (Qle_trans _ 0). apply (Qopp_le_compat 0). apply Qabs_nonneg. unfold Qminus. rewrite <- Qle_minus_iff. exact H. intros. setoid_replace (b-c)%Q with (-(c-b)). apply Qopp_le_compat. rewrite Qabs_opp. apply Qle_Qabs. unfold equiv, stdlib_rationals.Q_eq. ring. - apply Qmax_case. + intros. apply Qmax_case. intros. unfold Qminus. rewrite Qplus_opp_r. apply Qabs_nonneg. intros. apply (Qle_trans _ 0). apply (Qplus_le_l _ _ c). ring_simplify. exact H0. apply Qabs_nonneg. + intros. apply Qmax_case. intros. rewrite Qabs_pos. apply Qplus_le_r, Qopp_le_compat, H0. unfold Qminus. rewrite <- Qle_minus_iff. exact (Qle_trans _ _ _ H0 H). intros. apply Qle_Qabs. Qed. Lemma CRmax_boundBelow : forall (a:Q) (y:CR), (CRmax (' a) y == boundBelow a y)%CR. Proof. intros a y. unfold ucFun2, CRmax. unfold Cmap2. unfold inject_Q_CR. intros e1 e2. destruct y; simpl; unfold Cmap_fun, Cap_fun, Cap_raw; simpl. specialize (regFun_prf ((1 # 2) * e1)%Qpos e2). apply AbsSmall_Qabs. apply (Qle_trans _ _ _ (Qmax_contract _ _ _)). apply AbsSmall_Qabs in regFun_prf. apply (Qle_trans _ _ _ regFun_prf). apply Qplus_le_l. simpl. rewrite <- (Qmult_1_l (proj1_sig e1)) at 2. rewrite Qplus_0_r. apply Qmult_le_r. apply Qpos_ispos. discriminate. Qed. (** Basic properties of CRmax. *) Lemma CRmax_ub_l : forall x y, (x <= CRmax x y)%CR. Proof. intros x y e. simpl. unfold Cap_raw. simpl. unfold Cap_raw. simpl. rewrite -> Qmax_plus_distr_l. eapply Qle_trans;[|apply Qmax_ub_l]. cut (QAbsSmall (proj1_sig e) (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos + - approximate x ((1 # 2) * e)%Qpos));[unfold QAbsSmall;tauto|]. change (ball (proj1_sig e) (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos) (approximate x ((1 # 2) * e)%Qpos)). eapply ball_weak_le;[|apply regFun_prf]. simpl. rewrite -> Qle_minus_iff. ring_simplify. apply (Qpos_nonneg ((2#8)*e)). Qed. Lemma CRmax_ub_r : forall x y, (y <= CRmax x y)%CR. Proof. intros y x e. simpl. unfold Cap_raw. simpl. unfold Cap_raw. simpl. rewrite -> Qmax_plus_distr_l. eapply Qle_trans;[|apply Qmax_ub_r]. cut (QAbsSmall (proj1_sig e) (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos + - approximate x ((1 # 2) * e)%Qpos));[unfold QAbsSmall;tauto|]. change (ball (proj1_sig e) (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos) (approximate x ((1 # 2) * e)%Qpos)). eapply ball_weak_le;[|apply regFun_prf]. simpl. rewrite -> Qle_minus_iff. ring_simplify. apply (Qpos_nonneg ((2#8)*e)). Qed. Lemma CRmax_lub: forall x y z : CR, (x <= z -> y <= z -> CRmax x y <= z)%CR. Proof. intros x y z Hx Hy. rewrite <- (doubleSpeed_Eq z) in * |- *. intros e. assert (Hx':=Hx ((1#2)*e)%Qpos). assert (Hy':=Hy ((1#2)*e)%Qpos). clear Hx Hy. simpl in *. unfold Cap_raw in *. simpl in *. unfold Cap_raw. simpl. apply (Qle_trans _ ((-(1#2)*proj1_sig e) + (- (1#2)*proj1_sig e))). ring_simplify. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply (Qle_trans _ ((approximate z ((1#2)*((1 # 2) * e))%Qpos + - approximate z ((1#2)*((1 # 2) * ((1 # 2) * e)))%Qpos) + (approximate z ((1#2)*((1 # 2) * ((1 # 2) * e)))%Qpos - Qmax (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos) (approximate y ((1 # 2) * ((1 # 2) * e))%Qpos)))). 2: ring_simplify; apply Qle_refl. apply Qplus_le_compat. - apply (Qle_trans _ (- ((1 # 2) * ` e))). destruct e; simpl; ring_simplify; apply Qle_refl. cut (ball ((1#2)*proj1_sig e) (approximate z ((1#2)*((1 # 2) * e))%Qpos) (approximate z ((1#2)*((1 # 2) * ((1 # 2) * e)))%Qpos)). intros [A B]. assumption. refine (ball_weak_le _ _ _ _ _). 2:apply regFun_prf. rewrite -> Qle_minus_iff. simpl. ring_simplify. apply (Qpos_nonneg ((8#64)*e)). - apply (Qle_trans _ (- ((1 # 2) * ` e))). destruct e; simpl; ring_simplify; apply Qle_refl. apply Qmax_case; intros; assumption. Qed. (** ** Minimum [QboundAbove] ensures that a real number is at most some fixed rational number. It is the lifting of the first parameter of [Qmin]. *) Lemma QboundAbove_uc_prf (a:Q) : is_UniformlyContinuousFunction (fun b:Q => (Qmin a b):Q) Qpos2QposInf. Proof. intros e b0 b1 H. simpl in *. unfold Qball. unfold QAbsSmall. setoid_replace (Qmin a b0 - Qmin a b1) with ((Qmax (- a) (-b1)) - (Qmax (-a) (-b0))). apply QboundBelow_uc_prf. apply Qopp_uc_prf. apply ball_sym. assumption. unfold Qminus. simpl. rewrite -> Qmin_max_de_morgan. rewrite -> Qmax_min_de_morgan. repeat rewrite -> Qopp_involutive. ring_simplify. reflexivity. Qed. Definition QboundAbove_uc (a:Q_as_MetricSpace) : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (QboundAbove_uc_prf a). Definition boundAbove (a:Q) : CR --> CR := Cmap QPrelengthSpace (QboundAbove_uc a). (** CRmin is the lifting of [QboundAbove]. *) Lemma Qmin_uc_prf : is_UniformlyContinuousFunction QboundAbove_uc Qpos2QposInf. Proof. intros e a0 a1 H. split. apply Qpos_nonneg. intro b. simpl in *. do 2 rewrite -> (fun x => Qmin_comm x b). apply QboundAbove_uc_prf. assumption. Qed. Definition Qmin_uc : Q_as_MetricSpace --> Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction Qmin_uc_prf. Definition CRmin : CR --> CR --> CR := Cmap2 QPrelengthSpace QPrelengthSpace Qmin_uc. Lemma CRmin_boundAbove : forall (a:Q) (y:CR), (CRmin (' a) y == boundAbove a y)%CR. Proof. intros a y. unfold ucFun2, CRmin. unfold Cmap2. unfold inject_Q_CR. intros e1 e2. destruct y; simpl; unfold Cmap_fun, Cap_fun, Cap_raw; simpl. specialize (regFun_prf ((1 # 2) * e1)%Qpos e2). rewrite Qplus_0_r. split. - apply Qmin_case. intros. apply Qmin_case. intros. unfold Qminus. rewrite Qplus_opp_r. apply (Qopp_le_compat 0). apply (Qpos_nonneg (e1+e2)). intros. intros. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), (Qpos_nonneg (e1+e2)). unfold Qminus. rewrite <- Qle_minus_iff. exact H0. intros. apply (Qle_trans _ (approximate ((1 # 2)%Q ↾ eq_refl * e1)%Qpos - approximate e2)). destruct regFun_prf as [H1 _]. refine (Qle_trans _ _ _ _ H1). simpl. ring_simplify. apply Qplus_le_l. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply Qplus_le_r. apply Qopp_le_compat. apply Qmin_case. intros. exact H0. intros. apply Qle_refl. - apply Qmin_case. apply Qmin_case. intros. unfold Qminus. rewrite Qplus_opp_r. apply (Qpos_nonneg (e1+e2)). intros. apply (Qle_trans _ (approximate ((1 # 2) * e1)%Qpos - approximate e2)). apply Qplus_le_l, H0. destruct regFun_prf as [_ H1]. apply (Qle_trans _ _ _ H1). apply Qplus_le_l. simpl. rewrite <- (Qmult_1_l (proj1_sig e1)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. intros. apply Qmin_case. intros. apply (Qle_trans _ 0). apply (Qplus_le_l _ _ a). ring_simplify. exact H. apply (Qpos_nonneg (e1+e2)). intros. destruct regFun_prf as [_ H1]. apply (Qle_trans _ _ _ H1). apply Qplus_le_l. simpl. rewrite <- (Qmult_1_l (proj1_sig e1)) at 2. apply Qmult_le_r. apply Qpos_ispos. discriminate. Qed. (** Basic properties of CRmin. *) Lemma CRmin_lb_l : forall x y, (CRmin x y <= x)%CR. Proof. intros x y e. simpl. unfold Cap_raw. simpl. unfold Cap_raw. simpl. rewrite -> Qmin_max_de_morgan. rewrite -> Qmax_plus_distr_r. eapply Qle_trans;[|apply Qmax_ub_l]. cut (QAbsSmall (proj1_sig e) (approximate x ((1 # 2) * e)%Qpos + - approximate x ((1 # 2) * ((1 # 2) * e))%Qpos));[unfold QAbsSmall;tauto|]. change (ball (proj1_sig e) (approximate x ((1 # 2) * e)%Qpos) (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos)). eapply ball_weak_le;[|apply regFun_prf]. simpl. rewrite -> Qle_minus_iff. ring_simplify. apply (Qpos_nonneg ((2#8)*e)). Qed. Lemma CRmin_lb_r : forall x y, (CRmin x y <= y)%CR. Proof. intros y x e. simpl. unfold Cap_raw. simpl. unfold Cap_raw. simpl. rewrite -> Qmin_max_de_morgan. rewrite -> Qmax_plus_distr_r. eapply Qle_trans;[|apply Qmax_ub_r]. cut (QAbsSmall (proj1_sig e) (approximate x ((1 # 2) * e)%Qpos + - approximate x ((1 # 2) * ((1 # 2) * e))%Qpos));[unfold QAbsSmall;tauto|]. change (ball (proj1_sig e) (approximate x ((1 # 2) * e)%Qpos) (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos)). eapply ball_weak_le;[|apply regFun_prf]. simpl. rewrite -> Qle_minus_iff. ring_simplify. apply (Qpos_nonneg ((2#8)*e)). Qed. Lemma CRmin_glb: forall x y z : CR, (z <= x -> z <= y -> z <= CRmin x y)%CR. Proof. intros x y z Hx Hy. rewrite <- (doubleSpeed_Eq z) in * |- *. intros e. assert (Hx':=Hx ((1#2)*e)%Qpos). assert (Hy':=Hy ((1#2)*e)%Qpos). clear Hx Hy. simpl in *. unfold Cap_raw in *. simpl in *. unfold Cap_raw. simpl. apply (Qle_trans _ ((-(1#2)*proj1_sig e) + (- (1#2)*proj1_sig e))). ring_simplify. apply Qmult_le_r. apply Qpos_ispos. discriminate. apply (Qle_trans _ ((approximate z ((1#2)*((1 # 2) * ((1 # 2) * e)))%Qpos + - approximate z ((1#2)*((1 # 2) * e))%Qpos) + (Qmin (approximate x ((1 # 2) * ((1 # 2) * e))%Qpos) (approximate y ((1 # 2) * ((1 # 2) * e))%Qpos) + - approximate z ((1#2)*((1 # 2) * ((1 # 2) * e)))%Qpos))). 2: ring_simplify; rewrite Qplus_comm; apply Qle_refl. apply Qplus_le_compat. - apply (Qle_trans _ (- ((1 # 2) * ` e))). destruct e; simpl; ring_simplify; apply Qle_refl. cut (ball ((1#2)*proj1_sig e) (approximate z ((1#2)*((1 # 2) * ((1 # 2) * e)))%Qpos) (approximate z ((1#2)*((1 # 2) * e))%Qpos)) ;[intros [A B]; assumption|]. refine (ball_weak_le _ _ _ _ _). 2:apply regFun_prf. rewrite -> Qle_minus_iff. simpl. ring_simplify. apply (Qpos_nonneg ((8#64)*e)). - apply (Qle_trans _ (- ((1 # 2) * ` e))). destruct e; simpl; ring_simplify; apply Qle_refl. apply Qmin_case;intro;assumption. Qed. (* Non-curried equivalent version of addition. *) Lemma Qplus_uc_uncurry : is_UniformlyContinuousFunction (fun ab : ProductMS Q_as_MetricSpace Q_as_MetricSpace => fst ab + snd ab) (fun e => (1#2)*e)%Qpos. Proof. intros e1 [a b] [c d] [H H0]. simpl. simpl in H, H0. apply AbsSmall_Qabs. setoid_replace (a + b - (c + d))%Q with (a - c + (b - d)) by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). apply (Qle_trans _ ((1#2)*`e1 + (1#2)*`e1)). apply Qplus_le_compat. - apply AbsSmall_Qabs in H. apply H. - apply AbsSmall_Qabs in H0. apply H0. - ring_simplify. apply Qle_refl. Qed. Definition Qplus_uncurry : ProductMS Q_as_MetricSpace Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction Qplus_uc_uncurry. Lemma CRplus_uncurry_eq : forall x y : CR, msp_eq (CRplus x y) (Cmap (ProductMS_prelength QPrelengthSpace QPrelengthSpace) Qplus_uncurry (undistrib_Complete (x,y))). Proof. intros x y. unfold CRplus, ucFun2, CRplus_uc. transitivity (Cmap2 QPrelengthSpace QPrelengthSpace (uc_curry Qplus_uncurry) x y). 2: apply Cmap2_curry. apply Cap_wd. 2: reflexivity. apply Cmap_wd. 2: reflexivity. apply ucEq_equiv. split. apply Qle_refl. intros a. reflexivity. Qed. corn-8.20.0/reals/fast/CRIR.v000066400000000000000000000255311473720167500155550ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.CauchySeq. Require Import CoRN.reals.iso_CReals. Require Import CoRN.reals.R_morphism. Require Import CoRN.reals.fast.CRArith. Require Export CoRN.model.reals.CRreal. Require Import CoRN.tactics.CornTac. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Opaque CR inject_Q. (** ** Isomorphism between CR and IR Because CR and IR are both real number structures, they are isomorphic. This module develops lemmas for translating between expressions over CR and IR. A rewrite database [IRtoCR] contains rewrite lemmas for converting expressions over IR to expressions over CR. *) Lemma CRIR_iso : Isomorphism CRasCReals IR. Proof. apply Canonic_Isomorphism_between_CReals. Qed. Definition CRasIR : CR -> IR := iso_map_lft _ _ CRIR_iso. Definition IRasCR : IR -> CR := iso_map_rht _ _ CRIR_iso. Lemma CRasIRasCR_id : forall (x:CR), (IRasCR (CRasIR x)==x)%CR. Proof. apply (inversity_rht _ _ CRIR_iso). Qed. Lemma IRasCRasIR_id : forall (x:IR), (CRasIR (IRasCR x)[=]x). Proof. apply (inversity_lft _ _ CRIR_iso). Qed. Lemma IRasCR_wd : forall x y, x[=]y -> (IRasCR x == IRasCR y)%CR. Proof. apply (map_wd_unfolded _ _ (iso_map_rht _ _ CRIR_iso)). Qed. Lemma IR_eq_as_CR : forall x y, x[=]y <-> (IRasCR x == IRasCR y)%CR. Proof. split. apply (map_wd_unfolded _ _ (iso_map_rht _ _ CRIR_iso)). intros H. stepl (CRasIR (IRasCR x)); [| now apply IRasCRasIR_id]. stepr (CRasIR (IRasCR y)); [| now apply IRasCRasIR_id]. apply map_wd_unfolded. assumption. Qed. Lemma CRasIR_wd : forall x y, (x==y)%CR -> CRasIR x [=] CRasIR y. Proof. apply (map_wd_unfolded _ _ (iso_map_lft _ _ CRIR_iso)). Qed. Lemma CR_less_as_IR : forall x y, (IRasCR x < IRasCR y -> x[<]y)%CR. Proof. intros x y H. stepl (CRasIR (IRasCR x)); [| now apply IRasCRasIR_id]. stepr (CRasIR (IRasCR y)); [| now apply IRasCRasIR_id]. apply map_pres_less. assumption. Qed. Lemma CR_ap_as_IR : forall x y, (IRasCR x >< IRasCR y -> x[#]y)%CR. Proof. intros. stepl (CRasIR (IRasCR x)); [| now apply IRasCRasIR_id]. stepr (CRasIR (IRasCR y)); [| now apply IRasCRasIR_id]. apply map_pres_apartness. assumption. Qed. Lemma IR_leEq_as_CR : forall x y, x[<=]y <-> (IRasCR x <= IRasCR y)%CR. Proof. intros x y. split;[apply: f_pres_leEq|apply: leEq_pres_f]; solve [ apply map_strext |apply map_pres_less]. Qed. Lemma IR_Zero_as_CR : (IRasCR [0]==0)%CR. Proof. apply (map_pres_zero_unfolded _ _ (iso_map_rht _ _ CRIR_iso)). Qed. #[global] Hint Rewrite IR_Zero_as_CR : IRtoCR. Lemma CR_ap_zero_as_IR : forall x, (IRasCR x >< 0 -> x[#][0])%CR. Proof. intros x H. apply CR_ap_as_IR. generalize H. apply CRapartT_wd. reflexivity. symmetry. apply IR_Zero_as_CR. Qed. Lemma IR_plus_as_CR : forall x y, (IRasCR (x[+]y)== IRasCR x + IRasCR y)%CR. Proof. apply (map_pres_plus _ _ (iso_map_rht _ _ CRIR_iso)). Qed. #[global] Hint Rewrite IR_plus_as_CR : IRtoCR. Lemma IR_Sum0_as_CR : forall m x, (IRasCR (Sum0 m x)==@Sum0 CRasCAbGroup m (fun n => IRasCR (x n)))%CR. Proof. intros m x. induction m. apply IR_Zero_as_CR. simpl in *. set (a:=Sum0 (G:=CRasCAbGroup) m (fun n : nat => IRasCR (x n))) in *. clearbody a. rewrite <- IHm. apply IR_plus_as_CR. Qed. Lemma IR_opp_as_CR : forall x, (IRasCR ([--]x)== - IRasCR x)%CR. Proof. apply (map_pres_minus _ _ (iso_map_rht _ _ CRIR_iso)). Qed. #[global] Hint Rewrite IR_opp_as_CR : IRtoCR. Lemma IR_minus_as_CR : forall x y, (IRasCR (x[-]y)== IRasCR x - IRasCR y)%CR. Proof. unfold cg_minus. intros x y. rewrite -> IR_plus_as_CR. rewrite -> IR_opp_as_CR. reflexivity. Qed. #[global] Hint Rewrite IR_minus_as_CR : IRtoCR. Lemma IR_One_as_CR : (IRasCR [1]==1)%CR. Proof. apply (map_pres_one_unfolded _ _ (iso_map_rht _ _ CRIR_iso)). Qed. #[global] Hint Rewrite IR_One_as_CR : IRtoCR. Lemma IR_mult_as_CR : forall x y, (IRasCR (x[*]y)==(IRasCR x * IRasCR y))%CR. Proof. apply (map_pres_mult _ _ (iso_map_rht _ _ CRIR_iso)). Qed. #[global] Hint Rewrite IR_mult_as_CR : IRtoCR. Lemma IR_div_as_CR : forall x y y_ y__, (IRasCR (x[/]y[//]y_) == IRasCR x * CRinvT (IRasCR y) y__)%CR. Proof. intros x y y_ y__. apply (@mult_cancel_lft CRasCField _ _ (IRasCR y)). apply (map_pres_ap_zero _ _ (iso_map_rht _ _ CRIR_iso) y y_). rewrite <- IR_mult_as_CR. transitivity (IRasCR x). apply IRasCR_wd; rational. simpl. rewrite (CRmult_comm (IRasCR x)), <- CRmult_assoc, CRmult_inv_r. rewrite CRmult_1_l. reflexivity. Qed. Lemma IR_div_as_CR_1 :forall x y y_, (IRasCR (x[/]y[//]y_)== IRasCR x * CRinvT (IRasCR y) (map_pres_ap_zero _ _ (iso_map_rht _ _ CRIR_iso) y y_))%CR. Proof. intros; apply IR_div_as_CR. Qed. Lemma IR_div_as_CR_2 :forall x y y_, (IRasCR (x[/]y[//](CR_ap_zero_as_IR _ y_))== IRasCR x * CRinvT (IRasCR y) y_)%CR. Proof. intros; apply IR_div_as_CR. Qed. Lemma IR_recip_as_CR :forall y y_ y__, (IRasCR ([1][/]y[//]y_)==(CRinvT (IRasCR y) y__))%CR. Proof. intros y y_ y__. assert (X:=(IR_div_as_CR [1] y y_ y__)). rewrite -> X. change ((IRasCR [1] * CRinvT (IRasCR y) y__) == (CRinvT (IRasCR y) y__))%CR. rewrite -> IR_One_as_CR. change ((1 * CRinvT (IRasCR y) y__ == CRinvT (IRasCR y) y__)%CR). ring. Qed. Lemma IR_recip_as_CR_1 :forall y y_, (IRasCR ([1][/]y[//]y_)==(CRinvT (IRasCR y) (map_pres_ap_zero _ _ (iso_map_rht _ _ CRIR_iso) y y_)))%CR. Proof. intros; apply IR_recip_as_CR. Qed. Lemma IR_recip_as_CR_2 :forall y y_, (IRasCR ([1][/]y[//](CR_ap_zero_as_IR _ y_))==(CRinvT (IRasCR y) y_))%CR. Proof. intros; apply IR_recip_as_CR. Qed. Lemma IR_nring_as_CR : forall (n:nat), (IRasCR (nring n) == @nring CRasCRing n)%CR. Proof. induction n. apply IR_Zero_as_CR. simpl in *. set (a:= (nring (R:=CRasCRing) n)) in *. clearbody a. rewrite -> IR_plus_as_CR. rewrite -> IHn. rewrite -> IR_One_as_CR. reflexivity. Qed. #[global] Hint Rewrite IR_nring_as_CR : IRtoCR. Lemma IR_pring_as_CR : forall p, (IRasCR (pring _ p) == @pring CRasCRing p)%CR. Proof. unfold pring. intro p. simpl. cut (IRasCR [1] == 1)%CR;[|apply IR_One_as_CR]. generalize ([1]:IR). generalize (1%CR). induction p;intros a b Hab. - simpl. assert (IRasCR (([0][+][1][+][1])[*]b) == (0+1+1)*a)%CR as H. { simpl. rewrite -> IR_mult_as_CR. repeat rewrite -> IR_plus_as_CR. repeat rewrite -> IR_One_as_CR. rewrite -> IR_Zero_as_CR. rewrite -> Hab. reflexivity. } pose proof (IHp _ _ H) as X. simpl in X. set (c:=pring_aux CRasCRing p ((0 + 1 + 1) * a)%CR) in *. clearbody c. rewrite <- X. rewrite -> IR_plus_as_CR. rewrite -> Hab. reflexivity. - simpl. assert (IRasCR (([0][+][1][+][1])[*]b)== (0+1+1)*a)%CR. simpl. rewrite -> IR_mult_as_CR. repeat rewrite -> IR_plus_as_CR. repeat rewrite -> IR_One_as_CR. simpl. rewrite -> IR_Zero_as_CR. simpl. rewrite -> Hab. reflexivity. apply (IHp _ _ H). - simpl. assumption. Qed. Lemma IR_zring_as_CR : forall z, (IRasCR (zring z) == @zring CRasCRing z)%CR. Proof. intros [|p|p]. apply IR_Zero_as_CR. apply IR_pring_as_CR. change ((IRasCR [--](pring IR p) == - ((pring CRasCRing p):CR))%CR). rewrite -> IR_opp_as_CR. apply CRopp_wd. apply IR_pring_as_CR. Qed. #[global] Hint Rewrite IR_zring_as_CR : IRtoCR. Lemma IR_inj_Q_as_CR : forall (a:Q), (IRasCR (inj_Q IR a)==('a))%CR. Proof. intros [n d]. unfold inj_Q. rewrite -> IR_div_as_CR_1. generalize (map_pres_ap_zero IR CRasCReals (iso_map_rht CRasCReals IR CRIR_iso) (nring (R:=IR) (nat_of_P d)) (den_is_nonzero IR (n # d)%Q)). intros d_. setoid_replace (n#d)%Q with ((n # 1) * / (d # 1))%Q by (unfold Qeq; simpl; rewrite Z.mul_1_r; reflexivity). rewrite <- CRmult_Qmult. assert (d__:('d >< 0)%CR). { apply Qap_CRap. discriminate. } rewrite <- (CRinv_Qinv d d__). unfold cf_div. assert (X:(forall (n:positive), IRasCR (nring (R:=IR) (nat_of_P n)) == ' Zpos n)%CR). { intros x. clear -x. rewrite <- convert_is_POS. induction (nat_of_P x); clear x. apply IR_Zero_as_CR. simpl. rewrite -> IR_plus_as_CR. rewrite -> IHn. rewrite -> IR_One_as_CR. simpl. rewrite -> CRplus_Qplus. rewrite -> CReq_Qeq. unfold Qeq. simpl. rewrite Pmult_1_r. rewrite <- POS_anti_convert. ring_simplify. symmetry. rewrite Zplus_comm. apply (inj_plus 1 n). } apply (mult_wd CRasCRing);[|apply: f_rcpcl_wd;apply (X d)]. destruct n as [|p|p];[apply IR_Zero_as_CR| |];simpl. transitivity (IRasCR (nring (nat_of_P p))). apply IRasCR_wd. apply pring_convert. apply (X p). transitivity (IRasCR [--](nring (nat_of_P p))). apply IRasCR_wd. apply csf_wd_unfolded. apply pring_convert. rewrite -> IR_opp_as_CR. rewrite -> X. rewrite -> CRopp_Qopp. reflexivity. Qed. #[global] Hint Rewrite IR_inj_Q_as_CR : IRtoCR. Lemma IR_Cauchy_prop_as_CR : forall (x:CauchySeq IR), (@Cauchy_prop CRasCOrdField (fun n => (IRasCR (x n)))). Proof. intros x. assert (X:=map_pres_Lim _ _ (iso_map_rht CRasCReals IR CRIR_iso) _ _ (Cauchy_complete x)). intros e He. destruct (X _ (pos_div_two _ _ He)) as [n Hn]. exists n. intros m Hm. assert (A:=Hn m Hm). assert (B:=Hn n (le_n n)). set (a:=(IRasCR (x m))) in *. set (b:=IRasCR (Lim (IR:=IR) x)) in *. set (c:=IRasCR (x n)) in *. setoid_replace (@cg_minus CRasCGroup a c) with (a-b+(b-c))%CR by (unfold cg_minus; simpl; ring). apply (AbsSmall_eps_div_two CRasCOrdField e (a-b)%CR (b-c)%CR). assumption. apply (AbsSmall_minus CRasCOrdField (e [/]TwoNZ) c b). assumption. Qed. Lemma IR_Lim_as_CR : forall (x:CauchySeq IR), (IRasCR (Lim x)==Lim (Build_CauchySeq _ _ (IR_Cauchy_prop_as_CR x)))%CR. Proof. intros x. apply (SeqLimit_unique CRasCReals). apply (map_pres_Lim _ _ (iso_map_rht CRasCReals IR CRIR_iso) _ _ (Cauchy_complete x)). Qed. Lemma IR_AbsSmall_as_CR : forall (x y:IR), AbsSmall x y <-> AbsSmall (R:=CRasCOrdField) (IRasCR x) (IRasCR y). Proof. unfold AbsSmall. intros x y. simpl. do 2 rewrite -> IR_leEq_as_CR. rewrite -> IR_opp_as_CR. reflexivity. Qed. corn-8.20.0/reals/fast/CRabs.v000066400000000000000000000267611473720167500160160ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.model.totalorder.QposMinMax. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.model.metric2.Qmetric. From Coq Require Import Qabs. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.logic.Stability. Local Open Scope Q_scope. (** ** Absolute Value *) Lemma Qabs_uc_prf : is_UniformlyContinuousFunction (Qabs:Q_as_MetricSpace -> Q_as_MetricSpace) Qpos2QposInf. Proof. intros e a b Hab. simpl in *. unfold Qball in *. rewrite <- AbsSmall_Qabs in *. apply Qabs_case. intros _. eapply Qle_trans;[|apply Hab]. apply Qabs_triangle_reverse. intros _. setoid_replace (- (Qabs a - Qabs b)) with (Qabs b - Qabs a) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; ring). rewrite Qabs_Qminus in Hab. eapply Qle_trans;[|apply Hab]. apply Qabs_triangle_reverse. Qed. Local Open Scope uc_scope. Definition Qabs_uc : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction Qabs_uc_prf. Definition CRabs : CR --> CR := Cmap QPrelengthSpace Qabs_uc. Lemma CRabs_wd : Proper (@msp_eq CR ==> @msp_eq CR) CRabs. Proof. intros x y xyeq. apply Cmap_wd. reflexivity. rewrite xyeq. reflexivity. Qed. Lemma approximate_CRabs (x: CR) (e: Qpos): approximate (CRabs x) e = Qabs (approximate x e). Proof. reflexivity. Qed. Lemma inject_Q_CR_abs : forall q : Q, (CRabs (inject_Q_CR q) == inject_Q_CR (Qabs q))%CR. Proof. intros q. apply regFunEq_equiv. intros e1 e2. apply ball_refl, (Qpos_nonneg (e1+e2)). Qed. Lemma CRabs_AbsSmall : forall a b : CR, (CRabs b <= a)%CR <-> (-a <= b /\ b <= a)%CR. Proof. split. - intros. split. + intro e. simpl. unfold Cap_raw. simpl. specialize (H e). simpl in H. unfold Cap_raw in H. simpl in H. apply (Qle_trans _ _ _ H). rewrite Qopp_involutive, Qplus_comm. apply Qplus_le_l. rewrite <- (Qopp_involutive (approximate b ((1#2)*e)%Qpos)) at 2. apply Qopp_le_compat. rewrite <- Qabs_opp. apply Qle_Qabs. + intro e. simpl. unfold Cap_raw. simpl. specialize (H e). simpl in H. unfold Cap_raw in H. simpl in H. apply (Qle_trans _ _ _ H). apply Qplus_le_r, Qopp_le_compat, Qle_Qabs. - intros [H H0]. intro e. simpl. unfold Cap_raw. simpl. specialize (H e). simpl in H. unfold Cap_raw in H. simpl in H. specialize (H0 e). simpl in H0. unfold Cap_raw in H0. simpl in H0. apply (Qplus_le_l _ _ (Qabs (approximate b ((1 # 2) * e)%Qpos) + proj1_sig e)). simpl. ring_simplify. apply Qabs_Qle_condition. split. + apply (Qplus_le_l _ _ (- approximate a ((1 # 2) * e)%Qpos)) in H. simpl in H. ring_simplify in H. ring_simplify. exact H. + apply (Qplus_le_l _ _ (proj1_sig e + approximate b ((1 # 2) * e)%Qpos)) in H0. simpl in H0. ring_simplify in H0. exact H0. Qed. Local Open Scope CR_scope. Lemma CRabs_pos : forall x:CR, 0 <= x -> CRabs x == x. Proof. intros x H. apply CRle_antisym. split. - apply CRabs_AbsSmall. split. 2: apply CRle_refl. apply (@CRle_trans _ 0). 2: exact H. rewrite <- CRopp_0. apply CRopp_le_compat, H. - intro e. simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply Qle_Qabs. Qed. Lemma CRabs_0: CRabs 0 == 0. Proof. apply CRabs_pos, CRle_refl. Qed. Lemma CRabs_neg: forall x, x <= 0 -> CRabs x == - x. Proof. intros x H. apply CRle_antisym. split. - apply CRabs_AbsSmall. split. apply (CRplus_le_l _ _ (-x)). ring_simplify. apply CRle_refl. apply (@CRle_trans _ 0). exact H. rewrite <- CRopp_0. apply CRopp_le_compat, H. - intro e. simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff, <- Qabs_opp. apply Qle_Qabs. Qed. Lemma CRabs_cases (P: CR -> Prop) {Pp: Proper (@msp_eq _ ==> iff) P} {Ps: forall x, Stable (P x)}: forall x, ((0 <= x -> P x) /\ (x <= 0 -> P (- x))) <-> P (CRabs x). Proof with auto. intros. apply from_DN. apply (DN_bind (CRle_dec x 0)). intro. apply DN_return. destruct H. rewrite (CRabs_neg _ c)... intuition. revert H. rewrite (proj2 (CRle_antisym x 0))... rewrite CRopp_0... rewrite (CRabs_pos _ c)... intuition. revert H. rewrite (proj2 (CRle_antisym x 0))... rewrite CRopp_0... Qed. Lemma CRabs_opp (x: CR): CRabs (-x) == CRabs x. Proof with auto. intros. apply from_DN. apply (DN_bind (CRle_dec x 0)). intros [A | B]; apply DN_return. rewrite (CRabs_neg _ A). apply CRabs_pos. change (-0 <= -x). apply -> CRle_opp... rewrite (CRabs_pos _ B). rewrite CRabs_neg. apply CRopp_opp. change (-x <= -0). apply -> CRle_opp... Qed. Lemma CRabs_nonneg (x: CR): 0 <= CRabs x. Proof. intro e. simpl. unfold Cap_raw; simpl. rewrite Qplus_0_r. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qabs_nonneg. Qed. Lemma CRle_abs : forall x:CR, (x <= CRabs x)%CR. Proof. intros x e1. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ (approximate x ((1 # 2) * e1)%Qpos + - approximate x ((1 # 2) * e1)%Qpos)). rewrite Qplus_opp_r. apply (Qopp_le_compat 0), Qpos_nonneg. apply Qplus_le_l. apply Qabs.Qle_Qabs. Qed. Lemma CRabs_scale (a : Q) (x : CR) : CRabs (scale a x) == scale (Qabs a) (CRabs x). Proof. apply lift_eq_complete with (f := uc_compose CRabs (scale a)) (g := uc_compose (scale (Qabs a)) CRabs). intros q e1 e2. rewrite Qplus_0_r. change (@ball Q_as_MetricSpace (proj1_sig e1 + proj1_sig e2) (Qabs (a * q)) (Qabs a * Qabs q)%Q). apply <- ball_eq_iff. apply Qball_0, Qabs_Qmult. apply (Qpos_ispos (e1+e2)). Qed. (* begin hide *) (* Another proof *) Lemma CRabs_scale' (a : Q) (x : CR) : CRabs (scale a x) == scale (Qabs a) (CRabs x). Proof. unfold CRabs, scale. setoid_rewrite <- fast_MonadLaw2. apply map_eq_complete. intro q. apply Qball_0, Qabs_Qmult. Qed. Lemma CRabs_triangle : forall (x y : CR), CRabs (x+y) <= CRabs x + CRabs y. Proof. intros. apply CRabs_AbsSmall. split. 2: apply CRplus_le_compat; apply CRle_abs. rewrite CRopp_plus_distr. apply CRplus_le_compat; apply CRopp_le_cancel; rewrite CRopp_opp; rewrite <- CRabs_opp; apply CRle_abs. Qed. (* end hide *) Lemma CRabs_CRmult_Q (a : Q) (x : CR) : CRabs ('a * x) == '(Qabs a) * (CRabs x). Proof. rewrite !CRmult_scale. apply CRabs_scale. Qed. Definition CRdistance (x y: CR): CR := CRabs (x - y). Lemma CRdistance_CRle (r x y: CR): x - r <= y /\ y <= x + r <-> CRdistance x y <= r. Proof. intros. unfold CRdistance. rewrite CRabs_AbsSmall. simpl. rewrite (CRplus_le_l (x - r) y (r - y)). CRring_replace (r - y + (x - r)) (x - y). CRring_replace (r - y + y) r. rewrite (CRplus_le_l y (x + r) (-r - y)). CRring_replace (-r - y + y) (-r). CRring_replace (- r - y + (x + r)) (x - y). intuition. Qed. Lemma CRdistance_comm (x y: CR): CRdistance x y == CRdistance y x. Proof. unfold CRdistance. intros. CRring_replace (x - y) (-(y - x)). apply CRabs_opp. Qed. Lemma CRdistance_triangle : forall (x y z : CR), CRdistance x z <= CRdistance x y + CRdistance y z. Proof. intros. unfold CRdistance. setoid_replace (x-z) with (x-y + (y-z)) by (unfold canonical_names.equiv, msp_Equiv; ring). apply CRabs_triangle. Qed. Lemma regFunBall_e2 : forall (X: MetricSpace) (x y:Complete X) (e:Q), (forall d:Qpos, ball (proj1_sig d + e) (approximate x ((1#2)*d)%Qpos) (approximate y ((1#2)*d)%Qpos)) -> ball e x y. Proof. intros X x y e H. apply ball_closed. intros d dpos. setoid_replace (e + d)%Q with ((1#2)*((1#2)*d) + ((1#2)*((1#2)*d) + e+(1#2)*((1#2)*d)) + (1#2)*((1#2)*d))%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). apply (regFunBall_ball x y ((1 # 2) * ((1#2)*d) + e + (1 # 2) * ((1#2)*d))%Q ((1#2)*((1#2)*exist _ _ dpos))%Qpos ((1#2)*((1#2)*exist _ _ dpos))%Qpos ). setoid_replace ((1 # 2) * ((1 # 2) * d) + e + (1 # 2) * ((1 # 2) * d))%Q with ((1 # 2) * d + e)%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). apply (H ((1#2)*(exist _ _ dpos))%Qpos). Qed. Lemma CRabs_ball : forall (x y : CR) (e:Q), ball e x y <-> (CRabs (x-y) <= 'e)%CR. Proof. assert (forall (x y:CR) e d, ball e x y -> (- proj1_sig d <= e + approximate x ((1 # 2) * d)%Qpos + - approximate y ((1 # 2) * d)%Qpos)%Q). { intros. specialize (H ((1#2)*d)%Qpos ((1#2)*d)%Qpos). apply AbsSmall_Qabs in H. simpl (proj1_sig ((1 # 2) * d)%Qpos) in H. rewrite Qabs_Qminus in H. apply (Qle_trans _ _ _ (Qle_Qabs _)) in H. apply (Qplus_le_r _ _ (proj1_sig d + approximate y ((1#2)*d)%Qpos)). ring_simplify. setoid_replace ((1 # 2) * proj1_sig d + e + (1 # 2) * proj1_sig d)%Q with (proj1_sig d + e)%Q in H by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; ring). apply (Qplus_le_l _ _ (approximate x ((1#2)*d)%Qpos)) in H. ring_simplify in H. rewrite (Qplus_comm (proj1_sig d + e)), Qplus_assoc. exact H. } split. - intro H0. rewrite <- (CRdistance_CRle ('e)%CR x y). split. + apply (CRplus_le_r _ _ ('e)%CR). ring_simplify. rewrite CRplus_translate. intro d. simpl. unfold Cap_raw. simpl. apply H, ball_sym, H0. + rewrite CRplus_comm, CRplus_translate. intro d. simpl. unfold Cap_raw. simpl. apply H, H0. - intros H0. apply regFunBall_e2. intro d. simpl. apply CRdistance_CRle in H0. destruct H0. rewrite CRplus_comm, CRplus_translate in H1. rewrite (CRplus_le_r _ _ ('e)%CR) in H0. ring_simplify in H0. rewrite CRplus_translate in H0. apply AbsSmall_Qabs, Qabs_Qle_condition. split. + specialize (H1 d). simpl in H1. unfold Cap_raw in H1. simpl in H1. apply (Qplus_le_l _ _ (approximate y ((1#2)*d)%Qpos + proj1_sig d + e)). simpl. ring_simplify. apply (Qplus_le_l _ _ (approximate y ((1 # 2) * d)%Qpos + proj1_sig d)) in H1. simpl in H1. ring_simplify in H1. exact H1. + specialize (H0 d). simpl in H0. unfold Cap_raw in H0. simpl in H0. apply (Qplus_le_l _ _ (approximate y ((1#2)*d)%Qpos)). simpl. ring_simplify. apply (Qplus_le_l _ _ (approximate x ((1 # 2) * d)%Qpos + proj1_sig d)) in H0. simpl in H0. ring_simplify in H0. rewrite <- Qplus_assoc, Qplus_comm. exact H0. Qed. Import MathClasses.interfaces.canonical_names. #[global] Instance CR_abs : Abs CR. Proof. intro x. exists (CRabs x). split; [apply CRabs_pos | apply CRabs_neg]. Defined. corn-8.20.0/reals/fast/CRarctan.v000066400000000000000000000274031473720167500165130ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.Q_in_CReals. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.reals.fast.CRarctan_small. Require Import CoRN.reals.fast.CRpi. Require Import CoRN.transc.MoreArcTan. Require Import CoRN.reals.fast.ModulusDerivative. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.tactics.CornTac. Require Import CoRN.stdlib_omissions.Q. Require Import MathClasses.interfaces.abstract_algebra. From Coq Require Import Psatz. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR. (** ** Arctangent Using pi and properties of arctangent, we define arctangent from 1 to infinity. *) Lemma Qinv_one_lt : forall (a:Q), 1 < a -> -1 < /a < 1. Proof. split. apply (Qlt_le_trans _ 0). reflexivity. apply Qinv_le_0_compat; apply Qle_trans with 1; auto with qarith. change (/a < /1); apply Q.Qdiv_flip_lt; auto with qarith. Qed. Definition rational_arctan_big_pos (a:Q) (Ha:1 < a) : CR := (r_pi (1#2) - @rational_arctan_small (/a) (widen_interval (Qinv_one_lt Ha)))%CR. Lemma rational_arctan_big_pos_correct_aux (a : Q) : 0 < a → (r_pi (1 # 2) - IRasCR (ArcTan (inj_Q IR (/ a))))%CR = IRasCR (ArcTan (inj_Q IR a)). Proof. intros Ha. rewrite -> r_pi_correct. assert (H1:(inj_Q IR a)[#][0]). stepr (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_ap. apply (Greater_imp_ap _ a 0); assumption. rewrite <- IR_minus_as_CR. apply IRasCR_wd. stepl (Pi[/]TwoNZ[-](ArcTan ([1][/]_[//]H1))). assert (H2:[0][<]inj_Q IR a). stepl (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_less; assumption. unfold cg_minus. csetoid_rewrite (ArcTan_recip _ H1 H2). rational. apply bin_op_wd_unfolded. rstepl (((nring 1)[/]TwoNZ)[*]Pi). apply mult_wdl. change (1#2) with (1/2). assert (H2:(inj_Q IR (2#1))[#][0]). stepr (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_ap; discriminate. apply eq_transitive with ((inj_Q IR 1)[/]_[//]H2). apply div_wd. apply eq_symmetric; apply (inj_Q_nring IR 1). apply eq_symmetric; apply (inj_Q_nring IR 2). apply eq_symmetric; apply inj_Q_div. apply un_op_wd_unfolded. apply ArcTan_wd. apply eq_transitive with ((inj_Q IR 1)[/]_[//]H1). apply div_wd. rstepl (nring 1:IR). apply eq_symmetric; apply (inj_Q_nring IR 1). apply eq_reflexive. eapply eq_transitive. apply eq_symmetric; apply inj_Q_div. apply inj_Q_wd. simpl. unfold Qdiv. ring. Qed. Lemma rational_arctan_big_pos_correct : forall a (Ha: 1 < a), (rational_arctan_big_pos Ha == IRasCR (ArcTan (inj_Q IR a)))%CR. Proof. intros a Ha. unfold rational_arctan_big_pos. rewrite -> rational_arctan_small_correct. apply rational_arctan_big_pos_correct_aux. now apply Qlt_trans with 1. Qed. Lemma rational_arctan_mid_pos_prf a : 0 < a → - (1) < (a - 1) / (a + 1) < 1. Proof. split;(try apply Qlt_shift_div_l; try apply Qlt_shift_div_r; psatzl Q). Qed. (** Because we have slow convergence near 1, we have another computation that works for nonnegative numbers, and is particularly fast near 1. *) Definition rational_arctan_mid_pos (a:Q) (Ha : 0 < a) : CR := (r_pi (1#4) + (rational_arctan_small (widen_interval (rational_arctan_mid_pos_prf Ha))))%CR. Lemma rational_arctan_mid_pos_correct_aux (a : Q) : 0 < a → (r_pi (1#4) + IRasCR (ArcTan (inj_Q IR ((a - 1) / (a + 1)))))%CR = IRasCR (ArcTan (inj_Q IR a)). Proof. intros Ha. rewrite r_pi_correct. rewrite <-IR_plus_as_CR. apply IRasCR_wd. stepl (Pi[/]FourNZ[+]ArcTan (inj_Q IR ((a - 1) / (a + 1)))). csetoid_rewrite_rev (ArcTan_one). set (y:= (inj_Q IR ((a - 1) / (a + 1)))). assert (Y:[0][<][1][-][1][*]y). apply shift_zero_less_minus. rstepl y. rstepr (nring 1:IR). stepr (inj_Q IR 1); [| now apply (inj_Q_nring IR 1)]. apply inj_Q_less. now apply rational_arctan_mid_pos_prf. apply eq_transitive with (ArcTan ([1][+]y[/]_[//](Greater_imp_ap _ _ _ Y))). apply ArcTan_plus_ArcTan. apply shift_zero_leEq_minus'. rstepr (Two:IR). apply nring_nonneg. apply leEq_reflexive. rstepl ([--](nring 1:IR)). stepl (inj_Q IR ([--](1))). apply inj_Q_leEq. apply less_leEq. now apply rational_arctan_mid_pos_prf. csetoid_rewrite_rev (inj_Q_nring IR 1). apply inj_Q_inv. rstepr (nring 1:IR). stepr (inj_Q IR 1); [| now apply (inj_Q_nring IR 1)]. apply inj_Q_leEq. apply less_leEq. now apply rational_arctan_mid_pos_prf. apply ArcTan_wd. apply mult_cancel_lft with ([1][-][1][*]y). apply Greater_imp_ap; assumption. rstepl ([1][+]y). rstepr (inj_Q IR a[-]y[*]inj_Q IR a). csetoid_replace ([1]:IR) (inj_Q IR 1). unfold y. set (y' := ((a - 1) / (a + 1))). unfold cg_minus. csetoid_rewrite_rev (inj_Q_mult IR y' a). eapply eq_transitive. apply eq_symmetric; apply inj_Q_plus. apply eq_transitive with (inj_Q IR (a[+][--](y'[*]a)));[| apply inj_Q_minus]. apply inj_Q_wd. simpl. unfold y'. field. intros E. destruct (Qlt_irrefl 0). transitivity a; auto. rewrite <-E, Qlt_minus_iff. now ring_simplify. rstepl (nring 1:IR). apply eq_symmetric; apply (inj_Q_nring IR 1). apply bin_op_wd_unfolded;[|apply eq_reflexive]. apply mult_cancel_lft with Four. apply four_ap_zero. rstepl ((nring 1:IR)[*]Pi). rstepr ((Four[*]inj_Q IR (1 # 4))[*]Pi). apply mult_wdl. stepl (inj_Q IR 1); [| now apply (inj_Q_nring IR 1)]. stepr (inj_Q IR (4*(1#4))). apply inj_Q_wd. simpl. reflexivity. eapply eq_transitive. apply inj_Q_mult. apply mult_wdl. apply (inj_Q_nring IR 4). Qed. Lemma rational_arctan_mid_pos_correct : forall a (Ha: 0 < a), (rational_arctan_mid_pos Ha == IRasCR (ArcTan (inj_Q IR a)))%CR. Proof. intros. unfold rational_arctan_mid_pos. rewrite rational_arctan_small_correct. now apply rational_arctan_mid_pos_correct_aux. Qed. (** We glue all of are different methods of computing arctangent into a nice fast one that works for nonnegative numbers. *) Definition rational_arctan_pos (a:Q) (Ha:0 <= a) : CR. Proof. revert Ha. destruct (Qle_total (2#5) a) as [A|A]. destruct (Qle_total (5#2) a) as [B|_]; intros _. apply (@rational_arctan_big_pos a). abstract (eapply Qlt_le_trans;[|apply B];auto with qarith). apply (@rational_arctan_mid_pos a). abstract (eapply Qlt_le_trans;[|apply A];auto with qarith). intros H. apply (@rational_arctan_small a). apply widen_interval. abstract ( split;[refine (Qlt_le_trans _ 0 a _ H); reflexivity| eapply Qle_lt_trans;[apply A|auto with qarith]]). Defined. Lemma rational_arctan_pos_correct : forall a (Ha: 0 <= a), (rational_arctan_pos Ha == IRasCR (ArcTan (inj_Q IR a)))%CR. Proof. intros a Ha. unfold rational_arctan_pos. destruct (Qle_total (2 # 5) a). destruct (Qle_total (5 # 2) a). apply rational_arctan_big_pos_correct. apply rational_arctan_mid_pos_correct. apply rational_arctan_small_correct. Qed. (** By symmetry we get arctangent for all numbers. *) Definition rational_arctan (a:Q) : CR. Proof. destruct (Qle_total a 0) as [H|H]. refine (-(@rational_arctan_pos (-a)%Q _))%CR. abstract ( change (-0 <= -a); apply: (inv_resp_leEq); assumption). apply (rational_arctan_pos H). Defined. Lemma rational_arctan_small_correct_aux (a : Q) : (- IRasCR (ArcTan (inj_Q IR (- a)%Q)))%CR = IRasCR (ArcTan (inj_Q IR a)). Proof. rewrite <- IR_opp_as_CR. apply IRasCR_wd. csetoid_rewrite_rev (ArcTan_inv (inj_Q IR (-a))). apply ArcTan_wd. eapply eq_transitive. apply eq_symmetric; apply (inj_Q_inv IR (-a)). apply inj_Q_wd. simpl. ring. Qed. Lemma rational_arctan_correct : forall (a:Q), (rational_arctan a == IRasCR (ArcTan (inj_Q IR a)))%CR. Proof. intros a. unfold rational_arctan. destruct (Qle_total a 0); rewrite -> rational_arctan_pos_correct. apply rational_arctan_small_correct_aux. reflexivity. Qed. Lemma rational_arctan_opp (a : Q) : (-rational_arctan (-a) = rational_arctan a)%CR. Proof. do 2 rewrite rational_arctan_correct. now apply rational_arctan_small_correct_aux. Qed. Lemma rational_arctan_half_pi (a : Q) : 0 < a → (r_pi (1 # 2) - rational_arctan (/ a) = rational_arctan a)%CR. Proof. intros. do 2 rewrite rational_arctan_correct. now apply rational_arctan_big_pos_correct_aux. Qed. Lemma rational_arctan_fourth_pi (a : Q) : 0 < a → (r_pi (1 # 4) + rational_arctan ((a - 1) / (a + 1)) = rational_arctan a)%CR. Proof. intros. do 2 rewrite rational_arctan_correct. now apply rational_arctan_mid_pos_correct_aux. Qed. (** Lift arctangent on the rationals to the reals. *) Lemma arctan_uc_prf : @is_UniformlyContinuousFunction Q_as_MetricSpace CR rational_arctan Qpos2QposInf. Proof. apply (is_UniformlyContinuousFunction_wd) with rational_arctan (Qscale_modulus (1#1)). reflexivity. intros x. simpl. autorewrite with QposElim. change (/1) with 1. replace RHS with (proj1_sig x) by simpl; ring. apply Qle_refl. apply (is_UniformlyContinuousD None None I _ _ (Derivative_ArcTan I) rational_arctan). intros q [] _. apply rational_arctan_correct. intros x Hx _. assert (X:[0][<][1][+][1][*]x[*]x). apply plus_resp_pos_nonneg. apply pos_one. rstepr (x[^]2). apply sqr_nonneg. stepr ([1]:IR). simpl. apply AbsSmall_imp_AbsIR. apply leEq_imp_AbsSmall. apply shift_leEq_div. assumption. rstepl ([0]:IR). apply less_leEq; apply pos_one. apply shift_div_leEq. assumption. rstepr ([1][+]x[^]2). apply shift_leEq_plus'. rstepl ([0]:IR). apply sqr_nonneg. rstepl (nring 1:IR). apply eq_symmetric; apply (inj_Q_nring IR 1). Qed. Definition arctan_uc : Q_as_MetricSpace --> CR := Build_UniformlyContinuousFunction arctan_uc_prf. Definition arctan : CR --> CR := Cbind QPrelengthSpace arctan_uc. Lemma arctan_correct : forall x, (IRasCR (ArcTan x) == arctan (IRasCR x))%CR. Proof. intros x. apply (ContinuousCorrect (I:proper realline)); [apply Continuous_ArcTan | | constructor]. intros q [] _. transitivity (rational_arctan q);[|apply rational_arctan_correct]. unfold arctan. pose proof (Cbind_correct QPrelengthSpace arctan_uc). apply ucEq_equiv in H. rewrite -> (H (' q))%CR. apply BindLaw1. Qed. (* begin hide *) #[global] Hint Rewrite arctan_correct : IRtoCR. (* end hide *) Lemma arctan_Qarctan : forall x : Q, (arctan (' x) == rational_arctan x)%CR. Proof. intros x. unfold arctan. pose proof (Cbind_correct QPrelengthSpace arctan_uc). apply ucEq_equiv in H. rewrite -> (H (' x))%CR. apply BindLaw1. Qed. (* begin hide *) #[global] Hint Rewrite arctan_Qarctan : CRfast_compute. (* end hide *) #[global] Instance: Proper ((=) ==> (=)) rational_arctan. Proof. intros x1 x2 E. rewrite <-2!arctan_Qarctan. now rewrite E. Qed. corn-8.20.0/reals/fast/CRarctan_small.v000066400000000000000000000321461473720167500177030ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.fast.CRAlternatingSum. Require Import CoRN.reals.fast.CRAlternatingSum_alg. Require Import CoRN.reals.fast.CRstreams. Require Import CoRN.reals.fast.CRexp. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. From Coq Require Import Qpower Qabs Qround. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.reals.Q_in_CReals. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.transc.MoreArcTan. Require Import CoRN.tactics.CornTac. Require Import MathClasses.interfaces.abstract_algebra. Require Import CoRN.stdlib_omissions.Q. Require Import Coq.Init.Datatypes. Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR. Lemma Qmult_pos_neg : forall (a b : Q), 0 <= a -> b <= 0 -> a*b <= 0. Proof. intros. rewrite Qmult_comm. rewrite <- (Qmult_0_l a). apply Qmult_le_compat_r; assumption. Qed. Lemma Qmult_opp_1 : forall q : Q, eq (-q) (-1 * q). Proof. reflexivity. Qed. (** ** Arctangent (small) For values between in [[-1,1]], arctangent is computed by it's alternating taylor series. *) Section ArcTanSeries. Variable a:Q. (* (1,a) -> (3, -a^3/3) -> ... With a bigger state type, 1/(2i+1) could be set directly. It will be done in faster reals with a stream of positive*AQ*AQ. *) Definition arctanStream (px : prod positive Q) : prod positive Q := let d := Pos.add 2 (fst px) in (d, Qred (- snd px * a * a * (fst px#d))). Lemma arctanStream_fst : forall p, fst (iterate _ arctanStream p (1%positive, a)) ≡ Pos.succ (2*p). Proof. apply Pos.peano_ind. - reflexivity. - intros p H. rewrite iterate_succ. destruct (iterate (positive and Q) arctanStream p (1%positive, a)). simpl in H. subst p0. transitivity (Pos.add 2 (p~1)). reflexivity. clear q a. rewrite Pos.mul_succ_r. rewrite <- Pos.add_1_l, (Pos.add_comm 1). rewrite <- Pos.add_assoc. apply f_equal. reflexivity. Qed. Lemma Str_pth_arctanStream : forall p, Str_pth _ arctanStream p (xH, a) == (1#(1+2*p)) * ((-1)^p*a^(1+2*p))%Q. Proof. apply Pos.peano_ind. - unfold arctanStream, Str_pth, iterate, snd. rewrite Qred_correct. simpl. rewrite (Qmult_comm (1#3)), Qmult_assoc, Qmult_assoc. reflexivity. - intros p pInd. unfold Str_pth. rewrite iterate_succ. unfold Str_pth in pInd. pose proof (arctanStream_fst p) as H0. destruct (iterate _ arctanStream p (1%positive, a)) as [p0 q]. simpl in H0. subst p0. unfold snd in pInd. unfold arctanStream, snd, fst. rewrite Qred_correct. rewrite pInd. clear pInd q. (* Get rid of (-1)^p *) rewrite <- (Qmult_comm ((-1) ^ Pos.succ p * a ^ (1 + 2 * Pos.succ p))). rewrite <- (Pos.add_1_l p). rewrite Pos2Z.inj_add, (Qpower_plus (-1)%Q). simpl ((-1)^1). rewrite Qmult_opp_1. do 5 rewrite <- (Qmult_assoc (-1)). apply (Qmult_comp (-1)). reflexivity. rewrite (Qmult_comm (1 # (1 + 2 * p))). do 5 rewrite <- (Qmult_assoc ((-1)^p)). apply (Qmult_comp ((-1)^p)). reflexivity. (* Get rid of a *) setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)). do 4 rewrite <- (Qmult_assoc (a ^ (1 + 2 * p))). apply Qmult_comp. reflexivity. rewrite <- (Qmult_assoc _ a a). rewrite (Qmult_comm (1 # (1 + 2 * p))). rewrite <- (Qmult_assoc (a*a)). apply Qmult_comp. reflexivity. (* Finish equalities *) unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. reflexivity. rewrite <- (Qpower_plus_positive a 1 1). rewrite <- (Qpower_plus_positive a (1+2*p)). apply Qpower_positive_comp. reflexivity. rewrite <- Pos.add_assoc. apply f_equal. rewrite (Pos.add_comm 1 p). reflexivity. intro abs. discriminate. Qed. Hypothesis Ha: (-1 <= a <= 1). Lemma arctanStream_alt : Str_alt_decr _ arctanStream (1%positive,a). Proof. split. - (* Replace a by Qabs a *) rewrite Str_pth_arctanStream, Str_pth_arctanStream. rewrite Qabs_Qmult, Qabs_Qmult, Qabs_Qmult, Qabs_Qmult. rewrite Qabs_Qpower, Qabs_Qpower. change (Qabs (-1)) with 1. rewrite Qpower_1, Qpower_1, Qmult_1_l, Qmult_1_l. rewrite (Qabs_Qpower a (1+2*Pos.succ p)), (Qabs_Qpower a (1+2*p)). (* Finish inequality *) setoid_replace (Qabs a ^ (1 + 2 * Pos.succ p)%positive) with (Qabs a * Qabs a * Qabs a ^ (1 + 2 * p)%positive). rewrite Qmult_assoc. apply Qmult_le_compat_r. 2: rewrite <- Qabs_Qpower; apply Qabs_nonneg. + rewrite Qmult_comm. apply (Qabs_Qle_condition a 1) in Ha. apply (Qle_trans _ (1* (1 # (1 + 2 * (Pos.succ p))))). apply Qmult_le_compat_r. 2: discriminate. apply (Qle_trans _ (1*Qabs a)). apply Qmult_le_compat_r. exact Ha. apply Qabs_nonneg. rewrite Qmult_1_l. exact Ha. rewrite Qmult_1_l. unfold Qabs, Z.abs. unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. change (p <= Pos.succ p)%positive. apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.le_refl. + replace (1 + 2 * Pos.succ p)%positive with (2 + (1 + 2 * p))%positive. generalize (1 + 2 * p)%positive. clear p. intro p. unfold Qpower. rewrite Qpower_plus_positive. reflexivity. rewrite Pos.add_comm, <- Pos.add_assoc. apply f_equal. rewrite <- Pos.add_1_l. rewrite Pos.mul_add_distr_l, Pos.mul_1_r. apply Pos.add_comm. - rewrite Str_pth_arctanStream, Str_pth_arctanStream. rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg. discriminate. rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg. discriminate. rewrite <- Pos.add_1_l. change ((-1) ^ (1 + p)%positive) with (Qpower_positive (-1) (1 + p)). rewrite Qpower_plus_positive. simpl (Qpower_positive (-1) 1). rewrite <- Qmult_assoc, <- Qmult_assoc. apply (Qopp_le_compat 0). rewrite (Qmult_comm (a ^ (1 + 2 * (1 + p)%positive))). rewrite Qmult_assoc, Qmult_assoc. rewrite <- Qmult_assoc. apply Qmult_le_0_compat. simpl. destruct (Qpower_positive (-1) p), Qnum; discriminate. setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)). rewrite Qmult_assoc. apply Qmult_le_0_compat. destruct (a ^ (1 + 2 * p)), Qnum; discriminate. destruct a, Qnum; discriminate. change (a*a) with (Qpower_positive a 2). rewrite <- (Qpower_plus_positive a (1+2*p)). change (a ^ (1 + 2 * (1 + p))) with (Qpower_positive a (1 + 2 * (1 + p))). replace (1 + 2 * (1 + p))%positive with (1 + 2 * p + 2)%positive. reflexivity. rewrite <- Pos.add_assoc. apply f_equal. rewrite Pos.mul_add_distr_l, Pos.mul_1_r. apply Pos.add_comm. Qed. Lemma arctanStream_zl : Limit_zero _ arctanStream (xH,a) (fun e:Qpos => Z.to_pos (Qceiling (/ (proj1_sig e)))). Proof. intros [e epos]. rewrite Str_pth_arctanStream, Qabs_Qmult, Qabs_Qmult. rewrite Qabs_Qpower. change (Qabs (-1)) with 1. rewrite Qpower_1, Qmult_1_l. rewrite Qmult_comm. apply (Qle_trans _ (1 * Qabs (1 # 1 + 2 * Z.to_pos (Qceiling (/ ` (e ↾ epos)))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. - rewrite (Qabs_Qpower a (1 + 2 * Z.to_pos (Qceiling (/ ` (e ↾ epos))))). apply Qpower_le_1. split. apply Qabs_nonneg. apply Qabs_Qle_condition, Ha. - clear Ha a. rewrite Qmult_1_l. unfold Qabs, Z.abs, proj1_sig. rewrite <- (Qinv_involutive e) at 2. assert (0 < /e) as H. { apply Qinv_lt_0_compat, epos. } apply (@Qinv_le_compat (/e) (Zpos (1 + 2 * Z.to_pos (Qceiling (/ e))) # 1)). exact H. apply (Qle_trans _ _ _ (Qle_ceiling (/e))). generalize (Qceiling (/ e)). clear H epos e. intros [|p|p]. discriminate. 2: discriminate. pose proof (Zle_Qle p (Z.pos (1 + 2 * Z.to_pos p))). unfold inject_Z. unfold inject_Z in H. rewrite <- H. clear H. change (p <= 1 + 2*p)%positive. rewrite <- Pplus_one_succ_l. apply Pos.lt_le_incl, Pos.lt_succ_r. apply (Pos.mul_le_mono_r p 1 2). discriminate. Qed. End ArcTanSeries. Definition rational_arctan_small (a:Q) (p: -1 <= a <= 1) : CR := (inject_Q_CR a + AltSeries _ (arctanStream a) (xH,a) _ (arctanStream_alt p) (arctanStream_zl p))%CR. Lemma rational_arctan_small_wd : forall (a1 a2 : Q) (p1 : -1 <= a1 <= 1) (p2 : -1 <= a2 <= 1), a1 = a2 → rational_arctan_small p1 = rational_arctan_small p2. Proof. intros. unfold rational_arctan_small. apply ucFun2_wd. rewrite H. reflexivity. apply AltSeries_wd. 2: reflexivity. intro p. rewrite Str_pth_arctanStream, Str_pth_arctanStream, H. reflexivity. Qed. Lemma widen_interval : forall a:Q, -1 < a < 1 -> -1 <= a <= 1. Proof. intros a [H H0]. split; apply Qlt_le_weak; assumption. Qed. Lemma rational_arctan_small_correct : forall (a:Q) (Ha : -1 < a < 1), (@rational_arctan_small a (widen_interval Ha) == IRasCR (ArcTan (inj_Q IR a)))%CR. Proof. intros a Ha. unfold rational_arctan_small. rewrite <- (IR_inj_Q_as_CR a). rewrite (AltSeries_correct _ _ _ _ (arctanStream_alt (widen_interval Ha)) (arctanStream_zl (widen_interval Ha)) _ (AltSeries_convergent_0 _ _ _ _ (inj_Q IR a) (arctanStream_alt (widen_interval Ha)) (arctanStream_zl (widen_interval Ha)))). - apply IRasCR_wd. assert (olor ([--][1]) [1] (inj_Q IR a)) as X. { split. stepl (inj_Q IR (-1)). apply inj_Q_less, Ha. rewrite (inj_Q_inv IR 1), inj_Q_One. reflexivity. stepr (inj_Q IR 1); [| now apply inj_Q_One]. apply inj_Q_less, Ha. } eapply eq_transitive_unfolded; [|apply (arctan_series (inj_Q IR a) (arctan_series_convergent_IR) X)]. apply series_sum_wd. intros n. transitivity (inj_Q IR (((-1)^n)%Q *(a^(1+2*Z.of_nat n) * (1#(Pos.of_nat (1+2*n)))))). + destruct n. apply inj_Q_wd. simpl. rewrite Qmult_1_l, Qmult_1_r. reflexivity. apply inj_Q_wd. rewrite Str_pth_arctanStream. rewrite (Qmult_assoc ((-1)^S n)). rewrite (Qmult_comm ((-1) ^ S n * a ^ (1 + 2 * S n))). apply Qmult_comp. unfold Qeq, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. change 2%positive with (Pos.of_nat 2). rewrite <- (Nat2Pos.inj_mul 2 (S n)). 2: discriminate. 2: discriminate. rewrite <- (Nat2Pos.inj_add 1). reflexivity. discriminate. discriminate. apply Qmult_comp. rewrite <- Pos.of_nat_succ, POS_anti_convert. reflexivity. replace (1 + 2 * Z.pos (Pos.of_nat (S n)))%Z with (1 + 2 * S n)%Z. reflexivity. rewrite <- Pos.of_nat_succ, POS_anti_convert. reflexivity. + transitivity (([--][1][^]n[/]nring (R:=IR) (S (2 * n))[//]nringS_ap_zero IR (2 * n))[*] (inj_Q IR a)[^](2 * n + 1)). 2: reflexivity. rstepr (([--][1][^]n)[*]((inj_Q IR a)[^](2*n+1)[/]nring (R:=IR) (S (2 * n))[//]nringS_ap_zero IR (2 * n))). rewrite inj_Q_mult. apply mult_wd. rewrite inj_Q_power. apply nexp_wd. rewrite (inj_Q_inv IR 1), inj_Q_One. reflexivity. apply mult_cancel_lft with (nring (R:=IR) (S (2 * n))). apply nringS_ap_zero. rstepr (inj_Q IR a[^](2 * n + 1)). stepr (inj_Q IR (a^(2*n+1)%nat)); [| now apply inj_Q_power]. stepl ((inj_Q IR (nring (S (2*n))))[*]inj_Q IR (a ^ (1 + 2 * n) * (1 # Pos.of_nat (1 + 2 * n)))); [| now apply mult_wdl; apply inj_Q_nring]. rewrite <- inj_Q_mult. apply inj_Q_wd. setoid_rewrite (nring_Q (S (2*n))). change (S (2 * n) * (a ^ (1 + 2 * n) * (1 # Pos.of_nat (1 + 2 * n))) == a ^ (2 * n + 1)%nat)%Q. rewrite Qmult_comm. rewrite <- Qmult_assoc. setoid_replace ((1 # Pos.of_nat (1 + 2 * n)) * S (2 * n)) with 1%Q. rewrite Qmult_1_r, Nat.add_comm. rewrite Nat2Z.inj_add, Nat2Z.inj_mul. reflexivity. unfold Qeq, inject_Z, Qmult, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l, Z.mul_1_r, Pos.mul_1_r. unfold Z.of_nat. rewrite Pos.of_nat_succ. reflexivity. - intro p. destruct (Pos.to_nat p) eqn:des. exfalso. pose proof (Pos2Nat.is_pos p). rewrite des in H. inversion H. apply inj_Q_wd. rewrite <- des, Pos2Nat.id. reflexivity. Qed. corn-8.20.0/reals/fast/CRartanh_slow.v000066400000000000000000000350621473720167500175640ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.iso_CReals. Require Import CoRN.reals.fast.CRAlternatingSum. Require Import CoRN.reals.fast.CRGeometricSum. Require Import CoRN.reals.fast.CRstreams. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. From Coq Require Import Qabs. From Coq Require Import Qpower. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.reals.Q_in_CReals. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.transc.ArTanH. Require Import CoRN.reals.fast.CRarctan_small. Require Import CoRN.tactics.Qauto. Require Import CoRN.tactics.CornTac. Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR. (** ** Area Tangens Hyperbolicus (artanh) [artanh] is implemented by as the [GeometricSum] of it's taylor series. The Taylor series of arctan is the alternation of arctanh's, so we cannot use alternating series here. *) Definition artanhSequence (a:Q) : Stream Q := mult_Streams (everyOther Qrecip_positives) (powers_help (a^2) a). Lemma Str_nth_artanhSequence n : forall a, (Str_nth n (artanhSequence a) == (1#P_of_succ_nat (2*n))*a^(1+2*n)%nat)%Q. Proof. intro a. unfold artanhSequence. unfold mult_Streams. rewrite Str_nth_zipWith. rewrite Str_nth_everyOther. rewrite Str_nth_Qrecip_positives. rewrite -> (Str_nth_powers_help_int_pow _ Z.of_nat). rewrite <- Qpower_mult. rewrite inj_plus. rewrite -> (Qpower_plus' a 1 (2*n)%nat); auto with *. rewrite inj_mult. reflexivity. Qed. Lemma arctanSequence_Gs : forall a, GeometricSeries (a^2) (artanhSequence a). Proof. intros a. apply mult_Streams_Gs. apply _. apply powers_help_Gs. apply Qsqr_nonneg. Qed. Lemma Qsqr_lt_one : forall (a:Q), (-(1) < a) -> a < 1 -> (a^2 < 1). Proof. intros a H0 H1. rewrite -> Qlt_minus_iff in *. replace RHS with ((1 + - a)*(a + - -(1))) by simpl; ring. Qauto_pos. Qed. Lemma artanh_DomArTanH : forall a, (a^2 < 1) -> DomArTanH (inj_Q IR a). Proof. intros a Ha. split. stepl (inj_Q IR (-(1))%Q). apply inj_Q_less; simpl. apply Qnot_le_lt. intros H. apply (Qlt_not_le _ _ Ha). rewrite -> Qle_minus_iff in *. replace RHS with ((- (1) + - a + 2)*(-(1) +- a)) by simpl; ring. Qauto_nonneg. stepr ([--](inj_Q IR 1)). apply inj_Q_inv. apply un_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). stepr (inj_Q IR (1)). apply inj_Q_less; simpl. apply Qnot_le_lt. intros H. apply (Qlt_not_le _ _ Ha). rewrite -> Qle_minus_iff in *. replace RHS with ((a + - (1) + 2)*(a +- (1))) by simpl; ring. Qauto_nonneg. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). Qed. (** Although this function works on the entire domain of [artanh], it is only reasonably fast for values close to 0, say [[-(2/3), 2/3]]. *) Definition rational_artanh_slow (a:Q) (p1: a^2 < 1) : CR := InfiniteGeometricSum (Qsqr_nonneg a) p1 (arctanSequence_Gs a). Lemma GeometricSeries_convergent : forall (a : Q) (apos : 0 <= a) (aone : a < 1) (series:Stream Q), GeometricSeries a series -> convergent (fun n => inj_Q IR (Str_nth n series)). Proof. intros a apos aone series H. apply ratio_test_conv. exists 0%nat. exists (inj_Q IR a). rstepr (nring 1:IR). stepr (inj_Q IR (nring 1)); [| now apply (inj_Q_nring IR 1)]. apply inj_Q_less. assumption. assert (Ha0':[0][<=]inj_Q IR a). rstepl (nring 0:IR). stepl (inj_Q IR (nring 0)); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_leEq. assumption. split. assumption. intros n _. destruct (ForAll_Str_nth_tl n H) as [H0 _]. stepr (inj_Q IR a[*](inj_Q IR (Qabs (Str_nth n series)))); [| now apply mult_wdr; apply eq_symmetric; apply AbsIR_Qabs]. stepl (inj_Q IR (Qabs (Str_nth (S n) series))); [| now apply eq_symmetric; apply AbsIR_Qabs]. rewrite <- inj_Q_mult. apply inj_Q_leEq. replace (S n) with (1+n)%nat by auto with *. rewrite <- Str_nth_plus. assumption. Qed. (* This is a horrendous proof. I'm sure half of it isn't needed, but I don't care to make it better all proofs of this are extensionally equivalent anyway *) Lemma InfiniteGeometricSum_correct : forall (a : Q) (apos : 0 <= a) (aone : a < 1) (series:Stream Q) (x:nat -> IR), (forall n:nat, inj_Q IR (Str_nth n series)%Q[=]x n) -> forall (Gs:GeometricSeries a series) H, (InfiniteGeometricSum apos aone Gs==IRasCR (series_sum x H))%CR. Proof. intros a apos aone seq x Hx Gs H. unfold series_sum. rewrite -> IR_Lim_as_CR. apply (SeqLimit_unique CRasCReals). intros e He. generalize (IR_Cauchy_prop_as_CR (Build_CauchySeq IR (seq_part_sum x) H)). intros C. destruct (C _ (pos_div_two _ _ He)) as [n Hn]. exists n. intros m Hm. unfold CS_seq in *. clear C. unfold seq_part_sum in *. setoid_replace (@cg_minus CRasCGroup (IRasCR (Sum0 m x)) (InfiniteGeometricSum apos aone Gs)) with (((IRasCR (Sum0 (G:=IR) m x) - (IRasCR (Sum0 (G:=IR) n x))) + ((IRasCR (Sum0 (G:=IR) n x) - InfiniteGeometricSum apos aone Gs))))%CR by (unfold cg_minus; simpl; ring). apply (AbsSmall_eps_div_two CRasCOrdField e (IRasCR (Sum0 m x) - IRasCR (Sum0 n x)) (IRasCR (Sum0 n x) - InfiniteGeometricSum apos aone Gs))%CR. exact (Hn m Hm). clear m Hm. setoid_replace (IRasCR (Sum0 n x)) with ('(@Sum0 Q_as_CAbGroup n (fun n => (Str_nth n seq))%Q))%CR. revert seq x H Hx Gs Hn. induction n. intros seq x H Hx Gs Hn. simpl (Sum0 0 (fun n : nat => Str_nth n seq)). apply (AbsSmall_minus CRasCOrdField (e [/]TwoNZ) (InfiniteGeometricSum apos aone Gs) 0%CR). setoid_replace (@cg_minus CRasCOrdField (InfiniteGeometricSum apos aone Gs) 0%CR) with (InfiniteGeometricSum apos aone Gs) by (unfold cg_minus; simpl; ring). assert (Hn' : forall m : nat, (0 <= m)%nat -> AbsSmall (R:=CRasCOrdField) (e [/]TwoNZ) (IRasCR (Sum0 (G:=IR) m x))). { intros m Hm. setoid_replace (IRasCR (Sum0 m x)) with (@cg_minus CRasCOrdField (IRasCR (Sum0 (G:=IR) m x)) (IRasCR (Sum0 (G:=IR) 0 x))). apply Hn; assumption. unfold cg_minus. simpl. rewrite -> IR_Zero_as_CR. ring. } stepl (IRasCR (CRasIR (e[/]TwoNZ)))%CR; [| now apply CRasIRasCR_id]. stepr (IRasCR (CRasIR (InfiniteGeometricSum apos aone Gs)))%CR; [| now apply CRasIRasCR_id]. rewrite <- IR_AbsSmall_as_CR. apply AbsSmall_approach. intros d Hd. rewrite -> IR_AbsSmall_as_CR. stepr (InfiniteGeometricSum apos aone Gs); [| now apply eq_symmetric; apply CRasIRasCR_id]. destruct (Q_dense_in_CReals IR d) as [q Hq0 Hq]. assumption. assert (Hq0': 0 < q). apply (less_inj_Q IR). stepl ([0]:IR). assumption. apply eq_symmetric; apply (inj_Q_nring IR 0). destruct (InfiniteGeometricSum_small_tail apos aone (exist _ _ Hq0') Gs) as [m Hm]. setoid_replace (InfiniteGeometricSum apos aone Gs) with ((IRasCR (Sum0 (G:=IR) m x)) + ((InfiniteGeometricSum apos aone Gs) - (IRasCR (Sum0 (G:=IR) m x))))%CR by ring. stepl (IRasCR (CRasIR (e [/]TwoNZ)) + (IRasCR d))%CR; [| now apply eq_symmetric; apply IR_plus_as_CR]. apply (AbsSmall_plus CRasCOrdField (IRasCR (CRasIR (e [/]TwoNZ))) (IRasCR d) (IRasCR (Sum0 m x)) (InfiniteGeometricSum apos aone Gs - IRasCR (Sum0 m x)))%CR. stepl (e [/]TwoNZ); [| now apply eq_symmetric; apply CRasIRasCR_id]. apply Hn'; auto with *. apply AbsSmall_leEq_trans with ('q)%CR. stepl (IRasCR (inj_Q IR q)); [| now apply IR_inj_Q_as_CR]. rewrite <- IR_leEq_as_CR. apply less_leEq. assumption. simpl in Hm. clear - Hm Hx. revert seq x Hx Gs Hm. induction m. intros seq x Hx Gs Hm. stepr (InfiniteGeometricSum apos aone Gs). apply Hm. unfold cg_minus. simpl. rewrite -> IR_Zero_as_CR. unfold msp_Equiv; ring. intros seq x Hx Gs Hm. setoid_replace (InfiniteGeometricSum apos aone Gs - IRasCR (Sum0 (S m) x))%CR with (InfiniteGeometricSum apos aone (ForAll_Str_nth_tl 1 Gs) - IRasCR (Sum0 (G:=IR) m (fun n => (x (S n)))))%CR. apply IHm. intros n. stepl ((inj_Q IR (Str_nth (S n) seq)%Q)). apply Hx. apply eq_reflexive. intros. apply Hm. rewrite -> InfiniteGeometricSum_step. setoid_replace (IRasCR (Sum0 (G:=IR) (S m) x)) with (IRasCR (inj_Q _ (CoqStreams.hd seq) [+](Sum0 (G:=IR) m (fun n0 : nat => (x (S n0)))%Q))). rewrite -> (IR_plus_as_CR). rewrite -> IR_inj_Q_as_CR. ring. apply IRasCR_wd. apply eq_symmetric. stepl (x O[+]Sum0 (G:=IR) m (fun n0 : nat => (x (S n0)))). apply Sum0_shift. intros i. apply eq_reflexive. apply bin_op_wd_unfolded. apply eq_symmetric. apply (Hx O). apply eq_reflexive. intros seq x H Hx Gs Hn. set (y:=(fun n => (x (n + 1)%nat))). setoid_replace (' Sum0 (S n) (fun n0 : nat => Str_nth n0 seq) - InfiniteGeometricSum apos aone Gs)%CR with (('(((Sum0 (G:=Q_as_CAbGroup) n (fun n0 : nat => Str_nth n0 (CoqStreams.tl seq))%Q)))%CR) - InfiniteGeometricSum apos aone (ForAll_Str_nth_tl 1 Gs))%CR. apply (IHn (CoqStreams.tl seq) y ). apply tail_series with x. assumption. exists 1%nat. exists 0%nat. intros; apply eq_reflexive. intros m. unfold y. stepr ((inj_Q IR (Str_nth (m+1) seq))); [| now apply (Hx (m + 1)%nat)]. rewrite <- Str_nth_plus. apply eq_reflexive. intros m Hm. setoid_replace (@cg_minus CRasCOrdField (IRasCR (Sum0 m y)) (IRasCR (Sum0 n y))) with (IRasCR (Sum0 (G:=IR) (S m) x) - IRasCR (Sum0 (G:=IR) (S n) x))%CR. apply (Hn (S m)). apply le_n_S, Hm. symmetry. change (@cg_minus CRasCOrdField (IRasCR (Sum0 m y)) (IRasCR (Sum0 n y))) with (IRasCR (Sum0 m y) - IRasCR (Sum0 n y))%CR. do 2 rewrite <- IR_minus_as_CR. apply IRasCR_wd. stepr ((x O[+]Sum0 (G:=IR) m y[-](x O[+]Sum0 (G:=IR) n y))). apply bin_op_wd_unfolded;[|apply un_op_wd_unfolded]; apply eq_symmetric; apply Sum0_shift; intros; unfold y;rewrite Nat.add_comm; apply eq_reflexive. rational. rewrite -> InfiniteGeometricSum_step. set (z:=(fun n0 : nat => (Str_nth n0 seq)%Q)). setoid_replace ((Sum0 (G:=Q_as_CAbGroup) (S n) z):Q) with ((z O + (Sum0 (G:=Q_as_CAbGroup) n (fun n0 : nat => (Str_nth n0 (CoqStreams.tl seq))%Q)))). rewrite <- (CRplus_Qplus (z O)). unfold z, Str_nth. simpl. ring. symmetry. apply (@Sum0_shift Q_as_CAbGroup). intros i. reflexivity. clear - Hx. induction n. exact IR_Zero_as_CR. simpl. rewrite IR_plus_as_CR, IHn. rewrite <- CRplus_Qplus. apply CRplus_eq_r. transitivity (IRasCR (inj_Q IR (Str_nth n seq)%Q)). apply IRasCR_wd; symmetry; apply Hx. apply IR_inj_Q_as_CR. Qed. Lemma InfiniteGeometricSum_correct' : forall (series:Stream Q) (a : Q) (apos : 0 <= a) (aone : a < 1), forall (Gs:GeometricSeries a series), (InfiniteGeometricSum apos aone Gs == IRasCR (series_sum _ (GeometricSeries_convergent apos aone Gs)))%CR. Proof. intros series a apos aone Gs. apply InfiniteGeometricSum_correct. intros; apply eq_reflexive. Qed. Lemma rational_artanh_slow_correct : forall (a:Q) Ha Ha0, (@rational_artanh_slow a Ha == IRasCR (ArTanH (inj_Q IR a) Ha0))%CR. Proof. intros a Ha Ha0. unfold rational_artanh_slow. rewrite InfiniteGeometricSum_correct'. apply IRasCR_wd. eapply eq_transitive_unfolded; [|apply (ArTanH_series (inj_Q IR a) (ArTanH_series_convergent_IR) (artanh_DomArTanH Ha) Ha0)]. simpl. unfold series_sum. apply Lim_seq_eq_Lim_subseq with Nat.double. unfold Nat.double; auto with *. intros n. exists (S n). unfold Nat.double; auto with *. intros n. simpl. clear - n. induction n. apply eq_reflexive. simpl. set (A:=nexp IR (Nat.add n (S n)) (inj_Q IR a[-][0])). rewrite Nat.add_comm. simpl. fold (Nat.double n). csetoid_rewrite_rev IHn. clear IHn. csetoid_replace (ArTanH_series_coef (Nat.double n)[*]nexp IR (Nat.double n) (inj_Q IR a[-][0])) ([0]:IR). csetoid_replace (ArTanH_series_coef (S (Nat.double n))[*]A) (inj_Q IR (Str_nth n (artanhSequence a))). rational. unfold ArTanH_series_coef. case_eq (CLogic.Even_Odd_dec (S (Nat.double n))); intros H. elim (Nat.Even_Odd_False _ H). now rewrite <-Nat.add_1_r, Nat.double_twice; exists n. intros _. eapply eq_transitive; [|apply inj_Q_wd; simpl;symmetry;apply Str_nth_artanhSequence]. eapply eq_transitive; [|apply eq_symmetric; apply inj_Q_mult]. apply mult_wd. assert (X:(inj_Q IR (nring (S (Nat.double n))))[#][0]). stepr (inj_Q IR [0]). apply inj_Q_ap. apply nringS_ap_zero. apply (inj_Q_nring IR 0). stepr (inj_Q IR (nring 1)[/]_[//]X). apply div_wd. rstepl (nring 1:IR). apply eq_symmetric. apply (inj_Q_nring IR 1). apply eq_symmetric. apply (inj_Q_nring). assert (X0:inj_Q IR (inject_Z (P_of_succ_nat (2 * n)))[#][0]). stepr (inj_Q IR [0]). apply inj_Q_ap. discriminate. apply (inj_Q_nring IR 0). eapply eq_transitive; [|apply inj_Q_wd; symmetry; apply Qmake_Qdiv]. eapply eq_transitive; [|apply eq_symmetric; apply (fun b => inj_Q_div _ b _ X0)]. apply div_wd. apply eq_reflexive. apply inj_Q_wd. rewrite <- POS_anti_convert. eapply eq_transitive;[apply nring_Q|]. unfold Nat.double. simpl. replace (n+0)%nat with n by ring. reflexivity. unfold A; clear A. eapply eq_transitive;[|apply eq_symmetric; apply inj_Q_power]. change ((inj_Q IR a[-][0])[^](n+S n)[=]inj_Q IR a[^](1 + 2 * n)). replace (n + S n)%nat with (1 + 2*n)%nat by ring. apply nexp_wd. rational. unfold ArTanH_series_coef. case_eq (CLogic.Even_Odd_dec (Nat.double n)). intros _ _. rational. intros o. elim (fun x=> Nat.Even_Odd_False _ x o). apply even_plus_n_n. Qed. (* This development is incomplete. At the moment only what is needed for logorithm has been developed. *) corn-8.20.0/reals/fast/CRball.v000066400000000000000000000070501473720167500161510ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Qabs. Require Import CoRN.reals.fast.CRArith CoRN.reals.fast.CRabs. (** Balls with real radii instead of rational radii. *) Open Scope CR_scope. Section contents. Context {M: MetricSpace}. Definition CRball (r: CR) (x y: M): Prop := forall (q:Q), r <= ' q -> ball q x y. Global Instance proper: Proper (@msp_eq _ ==> @msp_eq _ ==> @msp_eq _ ==> iff) CRball. Proof. intros ?? E ?? F ?? G. split. intros. intros q H0. rewrite <- E in H0. specialize (H q H0). rewrite <- F, <- G. exact H. intros. intros q H0. rewrite E in H0. specialize (H q H0). rewrite F, G. exact H. Qed. Global Instance reflexive (r: CR): CRnonNeg r -> Reflexive (CRball r). Proof with auto. unfold CRball, Reflexive. intros. apply ball_refl. apply CRle_Qle. apply CRle_trans with r... apply -> CRnonNeg_le_0... Qed. Lemma zero (x y: M): msp_eq x y <-> CRball 0 x y. Proof with auto. split. intros H z zpos. apply (@ball_weak_le _ 0). apply CRle_Qle, zpos. exact H. intros. apply H. apply CRle_refl. Qed. Lemma weak_le (r r': CR): r <= r' -> forall x y, CRball r x y -> CRball r' x y. Proof. intros ??? E ??. apply E. apply CRle_trans with r'; assumption. Qed. Lemma rational (r: Q) (x y: M): ball r x y <-> CRball ('r) x y. Proof with auto. split... repeat intro. apply CRle_Qle in H0. apply ball_weak_le with r... intros. apply H, CRle_refl. Qed. End contents. (* In the CR metric space, CRball is what you'd expect. *) Lemma as_distance_bound (r x y: CR): CRball r x y <-> CRdistance x y <= r. Proof with auto. unfold CRball. rewrite <- CRdistance_CRle. assert ((forall x0 : Q, r <= ' x0 -> x - ' x0 <= y /\ y <= x + ' x0) <-> x - r <= y /\ y <= x + r). split; intros. - split. + apply CRplus_le_l with (r - y). CRring_replace (r - y + (x - r)) (x - y). CRring_replace (r - y + y) r. apply (proj1 (Qle_CRle_r _ _)). intros. apply CRplus_le_l with (y - ' y'). CRring_replace (y - 'y' + (x - y)) (x - 'y'). CRring_replace (y - 'y' + 'y') y. now apply (H y'). + apply CRplus_le_r with (-x). CRring_replace (x + r - x) r. apply (proj1 (Qle_CRle_r _ _)). intros. apply CRplus_le_l with x. CRring_replace (x + (y - x)) y... apply H... - split. apply CRle_trans with (x - r). apply CRplus_le_compat... apply CRle_refl. apply -> CRle_opp... apply H. apply CRle_trans with (x + r). apply H. apply CRplus_le_compat... apply CRle_refl. - split. intros. destruct H. apply H. intros; rewrite in_CRgball; intuition. intros. destruct H. rewrite <- in_CRgball. apply H2; assumption. Qed. (* todo: clean up *) Lemma gball_CRabs (r : Q) (x y : CR) : ball r x y <-> CRabs (x - y) <= ' r. Proof. rewrite rational. apply as_distance_bound. Qed. Lemma gball_CRmult_Q (e a : Q) (x y : CR) : ball e x y -> ball (Qabs a * e) ('a * x) ('a * y). Proof. intro A. apply gball_CRabs. setoid_replace ('a * x - 'a * y) with ('a * (x - y)) by (unfold canonical_names.equiv, msp_Equiv; ring). rewrite CRabs_CRmult_Q, <- CRmult_Qmult. assert (0 <= 'Qabs a) by (apply CRle_Qle, Qabs_nonneg). apply (orders.order_preserving (CRmult (' Qabs a))). now apply gball_CRabs. Qed. Lemma gball_CRmult_Q_nonneg (e a : Q) (x y : CR) : (0 <= a)%Q -> ball e x y -> ball (a * e) ('a * x) ('a * y). Proof. intros A1 A2. rewrite <- (Qabs_pos a) at 1; [apply gball_CRmult_Q |]; easy. Qed. Module notations. Notation CRball := CRball. End notations. corn-8.20.0/reals/fast/CRconst.v000066400000000000000000000017051473720167500163660ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Import Coq.Unicode.Utf8 CoRN.model.metric2.Qmetric CoRN.model.metric2.CRmetric CoRN.metric2.UniformContinuity. Section const_fun_uc. Variable X : MetricSpace. Variable c : X. (** The uniformly continuous constant function *) Definition const_raw : X → Complete X := λ _, Cunit c. (* Any modulus bigger than 0 will do, so we pick \infty *) Definition const_mu (ε:Qpos) : QposInf := QposInfinity. Lemma const_uc_prf : is_UniformlyContinuousFunction const_raw const_mu. Proof. unfold is_UniformlyContinuousFunction; now intuition. Qed. (** [const_uc c] defines the uniformly continuous function [λ _, c] *) Open Scope uc_scope. Definition const_uc : X --> Complete X := Build_UniformlyContinuousFunction (const_uc_prf). End const_fun_uc. Arguments const_uc {X}. corn-8.20.0/reals/fast/CRcorrect.v000066400000000000000000000757311473720167500167130ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.model.reals.Cauchy_IR. Require Import CoRN.tactics.CornTac. From Coq Require Import Lia. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.model.totalorder.QMinMax. From Coq Require Import Qabs. Require Export CoRN.reals.fast.CRFieldOps. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Local Open Scope nat_scope. Opaque Qmin Qmax. (** ** Isomorphism between CR and Cauchy_IR In prove that CR is a real number structure, we must climb the algebraic heirarchy. The easiest way of doing this is to construct an isomorphism between Cauchy_IR and CR because they are similar strucutres. Then we can leverage the proofs that Cauchy_IR is a real number structure. *** CR to Cauchy_IR *) Definition CRasCauchy_IR_raw (x:CR) (n:nat) := approximate x (Qpos2QposInf (1 # P_of_succ_nat n)). Lemma CRasCauchy_IR_raw_is_Cauchy : forall (x:CR), Cauchy_prop (R:=Q_as_COrdField) (CRasCauchy_IR_raw x). Proof. intros x e He. destruct e as [en ed]. destruct en as [|en|en]. inversion He. 2: inversion He. unfold CRasCauchy_IR_raw. exists (pred (nat_of_P (2*ed))). rewrite <- anti_convert_pred_convert. intros m Hm. change (ball (en#ed) (approximate x (Qpos2QposInf (1 # P_of_succ_nat m))) (approximate x (Qpos2QposInf (1#(2*ed))))). eapply ball_weak_le ;[|apply regFun_prf]. simpl. apply Qle_trans with (((1 # P_of_succ_nat (pred (nat_of_P (2*ed)))) + (1 # 2 * ed)))%Q. eapply plus_resp_leEq. change (P_of_succ_nat (pred (nat_of_P (2*ed))) <= P_of_succ_nat m)%Z. rewrite <-!POS_anti_convert. apply inj_le. lia. rewrite <- anti_convert_pred_convert. stepl ((2#1)*(1#(2*ed)))%Q; [|simpl; ring]. change ((2#1)*((1/2)*(1/ed)) <= en#ed)%Q. ring_simplify. change ((2#2)*(1/ed)<=en#ed)%Q. setoid_replace (2#2)%Q with 1%Q by constructor. ring_simplify. auto with *. Qed. Definition CRasCauchy_IR (x:CR) : Cauchy_IR := Build_CauchySeq _ _ (CRasCauchy_IR_raw_is_Cauchy x). Lemma CRasCauchy_IR_wd : forall (x y:CR), (x==y)%CR -> CRasCauchy_IR x[=]CRasCauchy_IR y. Proof. intros x y Hxy. eapply Eq_alt_2_2. intros e He. destruct e as [en ed]. destruct en as [|en|en]. inversion He. 2: inversion He. exists (pred(nat_of_P (2*ed))). intros m Hm. simpl. unfold CRasCauchy_IR_raw. set (d:=(1 # P_of_succ_nat m)%Qpos). change (ball (en#ed) (approximate x (Qpos2QposInf d)) (approximate y (Qpos2QposInf d))). eapply ball_weak_le;[|apply Hxy]. unfold d. simpl. ring_simplify. apply Qle_trans with ((2#1)*(1#(2 * ed)))%Q. eapply mult_resp_leEq_lft;try discriminate. change ((2*ed)<=P_of_succ_nat m)%Z. rewrite <- Zpos_mult_morphism. rewrite (anti_convert_pred_convert (2*ed)). do 2 rewrite <- POS_anti_convert. apply inj_le. auto with *. change (1#2*ed)%Q with ((1#2)*(1#ed))%Q. ring_simplify. auto with *. Qed. (** *** Cauchy_IR to CR *) Definition Cauchy_IRasCR_raw (x:Cauchy_IR) (e:QposInf) : Q. Proof. revert e. intros [e|];[|exact 0%Q]. destruct x as [f Hf]. unfold Cauchy_prop in Hf. destruct (Hf (proj1_sig e) (Qpos_ispos e)) as [n Hn]. exact (f n). Defined. Lemma Cauchy_IRasCR_is_Regular : forall (x:Cauchy_IR), is_RegularFunction Qball (Cauchy_IRasCR_raw x). Proof. intros [f Hf] e1 e2. simpl. destruct (Hf (proj1_sig e1) (Qpos_ispos e1)) as [n1 Hn1]. destruct (Hf (proj1_sig e2) (Qpos_ispos e2)) as [n2 Hn2]. cut (forall (e1 e2:Qpos) n1 n2, n2 <= n1 -> (forall m : nat, n1 <= m -> AbsSmall (R:=Q_as_COrdField) (proj1_sig e1) (f m[-]f n1)) -> (forall m : nat, n2 <= m -> AbsSmall (R:=Q_as_COrdField) (proj1_sig e2) (f m[-]f n2)) -> Qball (proj1_sig e1 + proj1_sig e2) (f n1) (f n2)). intros H. destruct (le_ge_dec n1 n2). eapply ball_sym;simpl. assert (QposEq (e1+e2) (e2+e1)) by (unfold QposEq; simpl; ring). apply (ball_wd _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. apply H; assumption. auto. clear - Hf. intros e1 e2 n1 n2 H Hn1 Hn2. assert (QposEq (e1+e2) (e2+e1)) by (unfold QposEq; simpl; ring). apply (ball_wd _ H0 _ _ (reflexivity _) _ _ (reflexivity _)). clear H0. eapply ball_weak. apply Qpos_nonneg. eapply Hn2. assumption. Qed. Definition Cauchy_IRasCR (x:Cauchy_IR) : CR := Build_RegularFunction (Cauchy_IRasCR_is_Regular x). Lemma Cauchy_IRasCR_wd : forall (x y:Cauchy_IR), x[=]y -> (Cauchy_IRasCR x==Cauchy_IRasCR y)%CR. Proof. intros [x Hx] [y Hy] Hxy. apply regFunEq_equiv, regFunEq_e. intros e. apply ball_closed. intros d dpos. simpl. destruct (Hx (proj1_sig e) (Qpos_ispos e)) as [a Ha]. destruct (Hy (proj1_sig e) (Qpos_ispos e)) as [b Hb]. destruct (Eq_alt_2_1 _ _ _ Hxy _ dpos) as [c Hc]. simpl in Hc. unfold Qball. set (n:= Nat.max (Nat.max a b) c). unfold QAbsSmall. setoid_replace (x a - y b)%Q with ((x a - x n) + (y n - y b) + (x n - y n))%Q. 2: ring. autorewrite with QposElim. repeat (eapply AbsSmall_plus). apply AbsSmall_minus. apply Ha;unfold n;apply Nat.le_trans with (Nat.max a b); auto with *. apply Hb; unfold n;apply Nat.le_trans with (Nat.max a b); auto with *. apply Hc; unfold n;auto with *. Qed. (** Composition is the identity *) Lemma CRasCR : forall x:CR, (Cauchy_IRasCR (CRasCauchy_IR x)==x)%CR. Proof. intros x. apply regFunEq_equiv, regFunEq_e. intros e. simpl. destruct (CRasCauchy_IR_raw_is_Cauchy x (proj1_sig e) (Qpos_ispos e)) as [n Hn]. unfold CRasCauchy_IR_raw in *. apply ball_closed. intros d dpos. setoid_replace (proj1_sig e+proj1_sig e+d)%Q with (proj1_sig (e+(exist _ _ dpos+e))%Qpos) by (simpl; ring). destruct d as [dn dd]. destruct dn as [|dn|dn]. inversion dpos. 2: inversion dpos. apply ball_triangle with (approximate x (Qpos2QposInf (1#P_of_succ_nat (n+(nat_of_P dd)))))%Qpos. - apply ball_sym. eapply Hn;auto with *. - eapply ball_weak_le;[|apply regFun_prf]. simpl. eapply plus_resp_leEq;simpl. apply Qle_trans with (1#dd)%Q. change (dd <= P_of_succ_nat (n + nat_of_P dd))%Z. destruct n. simpl. rewrite P_of_succ_nat_o_nat_of_P_eq_succ. rewrite Pplus_one_succ_r. rewrite Zpos_plus_distr. auto with *. rewrite <- nat_of_P_o_P_of_succ_nat_eq_succ. rewrite <- nat_of_P_plus_morphism. rewrite P_of_succ_nat_o_nat_of_P_eq_succ. rewrite Pplus_one_succ_r. repeat rewrite Zpos_plus_distr. rewrite <- Zplus_assoc. rewrite Zplus_comm. rewrite <- Zplus_assoc. rewrite <- Zpos_plus_distr. rewrite <- Pplus_one_succ_l. change (dd+0 <= dd + Pos.succ (P_of_succ_nat n))%Z. auto with *. change (dd <= dn*dd)%Z. auto with *. Qed. Lemma Cauchy_IRasCauchy_IR : forall x:Cauchy_IR, CRasCauchy_IR (Cauchy_IRasCR x)[=]x. Proof. intros [x Hx]. eapply Eq_alt_2_2. intros e He. assert (Z:(0<(1#2)*e)%Q). rewrite <- (Qmult_0_r (1#2)). eapply mult_resp_less_lft. exact He. constructor. destruct (Hx _ Z) as [n Hn]. destruct e as [en ed]. destruct en as [|en|en]. inversion He. 2: inversion He. exists (Nat.max n (nat_of_P ed)). intros m Hm. simpl. destruct Hx as [n' Hn']. apply AbsSmall_minus. destruct (le_lt_dec n' m) as [H|H]. eapply AbsSmall_trans;[|apply Hn';assumption]. change (ed < en*(P_of_succ_nat m))%Z. apply Z.lt_le_trans with (P_of_succ_nat m). rewrite <- POS_anti_convert. rewrite Zpos_eq_Z_of_nat_o_nat_of_P. apply inj_lt. apply Nat.lt_succ_r. apply Nat.le_trans with (Nat.max n (nat_of_P ed));auto with *. change (1*P_of_succ_nat m <= en * P_of_succ_nat m)%Z. apply Zmult_lt_0_le_compat_r;auto with *. stepl ((1#2)*(Z.pos en#ed)+(1#2)*(Z.pos en#ed))%Q; [| simpl; ring]. rstepr ((x m[-]x n)[+](x n[-]x n')). assert (Y:n <= m). apply Nat.le_trans with (Nat.max n (nat_of_P ed));auto with *. apply AbsSmall_plus. apply Hn. assumption. apply AbsSmall_minus; auto with *. Qed. (** Equalities are well defined. *) Lemma Cauchy_IR_eq_as_CR_eq : forall (x y:Cauchy_IR), ((Cauchy_IRasCR x) == (Cauchy_IRasCR y))%CR <-> x[=]y. Proof. intros x y. split;[|apply Cauchy_IRasCR_wd]. intros H. stepl (CRasCauchy_IR (Cauchy_IRasCR x)); [| apply Cauchy_IRasCauchy_IR]. stepr (CRasCauchy_IR (Cauchy_IRasCR y)); [| apply Cauchy_IRasCauchy_IR]. apply CRasCauchy_IR_wd. assumption. Qed. Lemma CR_eq_as_Cauchy_IR_eq : forall (x y:CR), (CRasCauchy_IR x [=] CRasCauchy_IR y) <-> (x==y)%CR. Proof. intros x y. set (x':=CRasCauchy_IR x). set (y':=CRasCauchy_IR y). rewrite <- (CRasCR x). rewrite <- (CRasCR y). symmetry. apply Cauchy_IR_eq_as_CR_eq. Qed. Local Open Scope uc_scope. (** *** Functions preserved by isomorphism. *) Lemma reverse_iso_wd_fun : forall (f:Cauchy_IR -> Cauchy_IR) (g:CR -> CR), (forall x y, (x==y -> g x == g y)%CR) -> (forall (x:Cauchy_IR), (g (Cauchy_IRasCR x) == Cauchy_IRasCR (f x))%CR) -> forall (x:CR), (f (CRasCauchy_IR x) [=] CRasCauchy_IR (g x)). Proof. intros f g g_wd H x. stepl (CRasCauchy_IR (Cauchy_IRasCR (f (CRasCauchy_IR x)))); [| apply Cauchy_IRasCauchy_IR]. apply CRasCauchy_IR_wd. symmetry. transitivity (g (Cauchy_IRasCR (CRasCauchy_IR x))). apply g_wd. symmetry. apply CRasCR. apply H. Qed. Lemma reverse_iso_uc_fun : forall (f:Cauchy_IR -> Cauchy_IR) (g:CR --> CR), (forall (x:Cauchy_IR), (g (Cauchy_IRasCR x) == Cauchy_IRasCR (f x))%CR) -> forall (x:CR), (f (CRasCauchy_IR x) [=] CRasCauchy_IR (g x)). Proof. intros f g H x. apply reverse_iso_wd_fun. apply uc_wd. assumption. Qed. Lemma reverse_iso_bin_wd_fun : forall (f:Cauchy_IR -> Cauchy_IR -> Cauchy_IR) (g:CR -> CR -> CR), (forall w x, (w == x)%CR -> forall y z, (y == z -> g w y == g x z)%CR) -> (forall (x y:Cauchy_IR), (g (Cauchy_IRasCR x) (Cauchy_IRasCR y) == Cauchy_IRasCR (f x y))%CR) -> forall (x y:CR), (f (CRasCauchy_IR x) (CRasCauchy_IR y) [=] CRasCauchy_IR (g x y)). Proof. intros f g g_wd H x y. stepl (CRasCauchy_IR (Cauchy_IRasCR (f (CRasCauchy_IR x) (CRasCauchy_IR y)))); [| apply Cauchy_IRasCauchy_IR]. apply CRasCauchy_IR_wd. symmetry. transitivity (g (Cauchy_IRasCR (CRasCauchy_IR x)) (Cauchy_IRasCR (CRasCauchy_IR y))); [|apply H]. apply g_wd; symmetry; apply CRasCR. Qed. Lemma reverse_iso_bin_uc_fun : forall (f:Cauchy_IR -> Cauchy_IR -> Cauchy_IR) (g:CR --> CR --> CR), (forall (x y:Cauchy_IR), (g (Cauchy_IRasCR x) (Cauchy_IRasCR y) == Cauchy_IRasCR (f x y))%CR) -> forall (x y:CR), (f (CRasCauchy_IR x) (CRasCauchy_IR y) [=] CRasCauchy_IR (g x y)). Proof. intros f g H x y. apply (reverse_iso_bin_wd_fun f (ucFun2 g)). apply ucFun2_wd. assumption. Qed. (** injection of rationals is preserved. *) Lemma Cauchy_IR_inject_Q_as_CR_inject_Q : forall x:Q, (' x == Cauchy_IRasCR (Cauchy_CReals.inject_Q _ x))%CR. Proof. intros x. apply regFunEq_equiv, regFunEq_e. intros e. simpl. destruct (CS_seq_const Q_as_COrdField x (proj1_sig e) (Qpos_ispos e)). eapply ball_refl. apply (Qpos_nonneg (e + e)). Qed. #[global] Hint Rewrite Cauchy_IR_inject_Q_as_CR_inject_Q : CRtoCauchy_IR. Lemma CR_inject_Q_as_Cauchy_IR_inject_Q : forall x:Q, Cauchy_CReals.inject_Q _ x [=] CRasCauchy_IR (' x)%CR. Proof. intros x. eapply Eq_alt_2_2. simpl. intros e He. exists 0. intros m Hm. unfold cg_minus. rstepr ([0]:Q). apply zero_AbsSmall. apply Qlt_le_weak. assumption. Qed. (** plus is preserved. *) Lemma Cauchy_IR_plus_as_CR_plus : forall x y:Cauchy_IR, (Cauchy_IRasCR x + Cauchy_IRasCR y == Cauchy_IRasCR (x[+]y))%CR. Proof. intros [x Hx] [y Hy]. apply regFunEq_equiv, regFunEq_e. intros e. simpl. unfold Cap_raw. simpl. destruct (Hx (proj1_sig ((1 # 2) * e)%Qpos)) as [n1 Hn1]. destruct (Hy (proj1_sig ((1 # 2) * e)%Qpos)) as [n2 Hn2]. destruct (CS_seq_plus) as [n3 Hn3]. set (n:= Nat.max n3 (Nat.max n1 n2)). change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (x n1 + y n2) (x n3 + y n3))%Q. apply ball_triangle with (x n + y n)%Q. assert (QposEq e (((1 # 2) * e +(1 # 2) * e))) by (unfold QposEq; simpl; ring). apply (ball_wd _ H _ _ (reflexivity _) _ _ (reflexivity _)). clear H. apply ball_triangle with (x n1 + y n)%Q; simpl; unfold Qball. unfold QAbsSmall. setoid_replace (x n1 + y n2 - (x n1 + y n))%Q with (y n2 - y n)%Q. 2: ring. apply AbsSmall_minus. apply Hn2. unfold n. rewrite Nat.max_assoc. auto with *. unfold QAbsSmall. setoid_replace (x n1 + y n - (x n + y n))%Q with (x n1 - x n)%Q. 2: ring. apply AbsSmall_minus. apply Hn1. unfold n. rewrite (Nat.max_comm n1). rewrite Nat.max_assoc. auto with *. eapply Hn3; unfold n; auto with *. Qed. #[global] Hint Rewrite Cauchy_IR_plus_as_CR_plus : CRtoCauchy_IR. Lemma CR_plus_as_Cauchy_IR_plus : forall x y:CR, CRasCauchy_IR x [+] CRasCauchy_IR y [=] CRasCauchy_IR (x+y)%CR. Proof. apply reverse_iso_bin_uc_fun. apply Cauchy_IR_plus_as_CR_plus. Qed. (** opp is preserved. *) Lemma Cauchy_IR_opp_as_CR_opp : forall x:Cauchy_IR, (-Cauchy_IRasCR x == Cauchy_IRasCR ([--]x))%CR. Proof. intros [x Hx]. apply regFunEq_equiv, regFunEq_e. intros e. simpl. destruct (Hx (proj1_sig e) (Qpos_ispos e)) as [n1 Hn1]. destruct (CS_seq_inv Q_as_COrdField x Hx (proj1_sig e) (Qpos_ispos e)) as [n2 Hn2]. set (n:=(Nat.max n1 n2)). change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (- x n1) (- x n2))%Q. apply (@ball_triangle Q_as_MetricSpace _ _ _ (- x n)%Q). simpl; unfold Qball. unfold QAbsSmall. setoid_replace (- x n1 - - x n)%Q with (x n - x n1)%Q. 2: ring. apply (Hn1 n). apply Nat.le_max_l. apply Hn2. apply Nat.le_max_r. Qed. #[global] Hint Rewrite Cauchy_IR_opp_as_CR_opp : CRtoCauchy_IR. Lemma CR_opp_as_Cauchy_IR_opp : forall x:CR, [--](CRasCauchy_IR x) [=] CRasCauchy_IR (- x)%CR. Proof. apply reverse_iso_uc_fun. apply Cauchy_IR_opp_as_CR_opp. Qed. (** le is preserved. *) Lemma Cauchy_IR_le_as_CR_le : forall (x y:Cauchy_IR), (Cauchy_IRasCR x <= Cauchy_IRasCR y)%CR <-> x[<=]y. Proof. intros [x Hx] [y Hy]. split. intros H1 [n [e He H2]]. assert (H1':=H1 ((1#3)*(exist _ _ He))%Qpos). clear H1. simpl in H1'. unfold Cap_raw in H1'; simpl in H1'. destruct (Hy (proj1_sig ((1 # 2) * ((1#3)* exist _ _ He))%Qpos)) as [n1 Hn1] in H1'. destruct (Hx (proj1_sig ((1 # 2) * ((1#3)* exist _ _ He))%Qpos)) as [n2 Hn2] in H1'. simpl in H2. set (m:=Nat.max n (Nat.max n1 n2)). assert (m1:n<=m);[unfold m; auto with *|]. assert (m2:n1<=m);[unfold m; apply Nat.le_trans with (Nat.max n1 n2); auto with *|]. assert (m3:n2<=m);[unfold m; apply Nat.le_trans with (Nat.max n1 n2); auto with *|]. apply (Qle_not_lt _ _ H1'). eapply inv_cancel_less;simpl. clear H1'. autorewrite with QposElim in *. apply Qlt_le_trans with ((2#3)*e)%Q. ring_simplify. eapply mult_resp_less. constructor. assumption. stepl (e + - ((1#2)*((1#3)*e)) + - ((1#2)*((1#3)*e)))%Q; [| simpl; ring]. stepr ((x m - y m) + (y m - y n1) + -(x m - x n2))%Q; [| simpl; ring]. eapply plus_resp_leEq_both. apply plus_resp_leEq_both. apply H2; assumption. refine (proj1 (Hn1 m _));assumption. apply inv_resp_leEq. refine (proj2 (Hn2 m _));assumption. (*Other Direction*) intros H e. simpl. unfold Cap_raw; simpl. destruct (Hy (proj1_sig ((1 # 2) * e)%Qpos)) as [n1 Hn1]. destruct (Hx (proj1_sig ((1 # 2) * e)%Qpos)) as [n2 Hn2]. apply Qnot_lt_le. intros A. apply H; clear H. exists (Nat.max n1 n2). simpl. set (n:=Nat.max n1 n2). exists (- proj1_sig e + - (y n1 + - x n2))%Q. rewrite <- Qlt_minus_iff. assumption. intros m Hm. unfold cg_minus. simpl. stepr ((x m - x n2) + -(y m - y n1) + -(y n1 + - x n2))%Q; [| simpl; ring]. eapply plus_resp_leEq. stepl (-((1 # 2) * proj1_sig e) + - ((1 # 2) * proj1_sig e))%Q; [| simpl; ring]. apply plus_resp_leEq_both. refine (proj1 (Hn2 _ _)). apply Nat.le_trans with n; [unfold n;auto with *|assumption]. apply inv_resp_leEq. refine (proj2 (Hn1 _ _)). apply Nat.le_trans with n; [unfold n;auto with *|assumption]. Qed. #[global] Hint Rewrite Cauchy_IR_le_as_CR_le : CRtoCauchy_IR. Lemma CR_le_as_Cauchy_IR_le : forall (x y:CR), CRasCauchy_IR x[<=]CRasCauchy_IR y <-> (x<=y)%CR. Proof. intros x y. rewrite <- Cauchy_IR_le_as_CR_le. do 2 rewrite -> CRasCR. reflexivity. Qed. (** mult is preserved. *) Lemma Cauchy_IR_mult_as_CRmult_bounded : forall x y:Cauchy_IR, forall (z:Qpos) (N:nat), (forall i:nat, (N<=i) -> AbsSmall (proj1_sig z) (CS_seq _ y i)) -> (ucFun2 (CRmult_bounded z) (Cauchy_IRasCR x) (Cauchy_IRasCR y) == Cauchy_IRasCR (x[*]y))%CR. Proof. intros [x Hx] y z N Hz. destruct y as [y Hy]. apply regFunEq_equiv, regFunEq_e. intros e. simpl. destruct CS_seq_mult as [n3 Hn3]. unfold Cap_raw. simpl in *. destruct Hx as [n1 Hn1]. apply Qscale_modulus_elim. intros Hxn1. pose (n:=(Nat.max n3 (Nat.max n1 N))). rewrite -> Hxn1. assert (Qeq (0 * Qmax (- proj1_sig z) (Qmin (proj1_sig z) (Cauchy_IRasCR_raw (Build_CauchySeq Q_as_COrdField y Hy)(QposInf_bind (fun e0 : Qpos => e0) QposInfinity))))%Q (0 * y n)%Q). ring. rewrite -> H. clear H. change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (0 * y n) (x n3 * y n3))%Q. apply ball_triangle with (x n*y n)%Q;[|eapply Hn3; unfold n; auto with *]. apply ball_sym. simpl. setoid_replace (0 * y n)%Q with (x n1 * y n)%Q. 2: rewrite Hxn1; reflexivity. unfold Qball. unfold QAbsSmall. setoid_replace (x n * y n - x n1 * y n)%Q with ((x n - x n1)*y n)%Q. 2: ring. apply AbsSmall_trans with ((1#2)*proj1_sig e)%Q. apply half_3. apply Qpos_ispos. stepl (((1#2)*proj1_sig e/ proj1_sig z)* proj1_sig z)%Q; [| simpl;field;apply Qpos_nonzero]. apply mult_AbsSmall;[apply Hn1|apply Hz]; unfold n; apply Nat.le_trans with (Nat.max n1 N); auto with *. intros w Hw. simpl. destruct (Hy (proj1_sig w) (Qpos_ispos w)) as [n2 Hn2]. pose (n:=(Nat.max (Nat.max n1 n2) (Nat.max n3 N))). assert (n1 <= n);[unfold n; apply Nat.le_trans with (Nat.max n1 n2); auto with *|]. assert (n2 <= n);[unfold n; apply Nat.le_trans with (Nat.max n1 n2); auto with *|]. assert (n3 <= n);[unfold n; apply Nat.le_trans with (Nat.max n3 N); auto with *|]. assert (N <= n);[unfold n; apply Nat.le_trans with (Nat.max n3 N); auto with *|]. change (Qball (proj1_sig e+proj1_sig e)) with (@ball Q_as_MetricSpace (proj1_sig e + proj1_sig e)). apply ball_triangle with (x n * y n)%Q;[|eapply Hn3; assumption]. clear Hn3. assert (QposEq e ((1#2)*e + (1#2)*e)) by (unfold QposEq; simpl; ring). apply (ball_wd _ H3 _ _ (reflexivity _) _ _ (reflexivity _)). clear H3. apply ball_triangle with (x n1 * y n)%Q; apply ball_sym; simpl; unfold Qball. unfold QAbsSmall. setoid_replace (x n1 * y n - x n1 * Qmax (- proj1_sig z) (Qmin (proj1_sig z) (y n2)))%Q with (x n1*(y n - Qmax (- proj1_sig z) (Qmin (proj1_sig z) (y n2))))%Q. 2: ring. simpl. stepl (((1#2)*proj1_sig e/proj1_sig w)*proj1_sig w)%Q; [| simpl;field;apply Qpos_nonzero]. apply mult_AbsSmall;[apply Hw|]. destruct (Hz n H2) as [X0 X1]. destruct (Hn2 _ H0) as [X2 X3]. unfold cg_minus in *. simpl in *. change (Qmax (- proj1_sig z) (Qmin (proj1_sig z) (y n2)))%Q with (QboundAbs z (y n2))%Q. assert (A0:(- proj1_sig w<=0)%Q). rewrite -> Qle_minus_iff. ring_simplify. apply Qpos_nonneg. rewrite -> Qle_minus_iff in *. clear - A0 X0 X1 X2 X3 Hn2 H0. ring_simplify in A0. ring_simplify in X0. ring_simplify in X1. ring_simplify in X2. ring_simplify in X3. apply QboundAbs_elim; intros I; try solve [apply Hn2;assumption]; rewrite -> Qle_minus_iff in I. apply AbsSmall_minus. unfold cg_minus;simpl. apply leEq_imp_AbsSmall. apply X1. rewrite -> Qle_minus_iff. stepr ((y n + (-1 # 1) * y n2 + proj1_sig w)+(y n2 + - proj1_sig z))%Q; [| simpl; ring]. eapply plus_resp_nonneg; assumption. eapply leEq_imp_AbsSmall; simpl; ring_simplify. apply X0. rewrite -> Qle_minus_iff. stepr ((proj1_sig w + (-1 # 1) * y n + y n2)+(- proj1_sig z + - y n2))%Q; [| simpl; ring]. eapply plus_resp_nonneg; assumption. unfold QAbsSmall. setoid_replace (x n * y n - x n1 * y n)%Q with ((x n - x n1)*y n)%Q. 2: ring. autorewrite with QposElim. stepl (((1#2)*proj1_sig e/proj1_sig z)*proj1_sig z)%Q; [| simpl; field; apply Qpos_nonzero]. apply mult_AbsSmall;[apply Hn1;assumption|apply Hz;assumption]. Qed. Lemma AbsSmall_Qabs : forall x y, (Qabs y <= x)%Q <-> AbsSmall x y. Proof. cut (forall x y, (0 <= y)%Q -> ((Qabs y <= x)%Q <-> AbsSmall (R:=Q_as_COrdField) x y)). intros H x y. generalize (H x y) (H x (-y)%Q). clear H. rewrite -> Qabs_opp. apply Qabs_case; intros H H1 H2. auto. assert (X:AbsSmall (R:=Q_as_COrdField) x y <-> AbsSmall (R:=Q_as_COrdField) x (- y)%Q). split. apply inv_resp_AbsSmall. intros X. stepr (- - y)%Q; [| simpl; ring]. apply inv_resp_AbsSmall. assumption. rewrite -> X. eapply H2. rewrite -> Qle_minus_iff in H. ring_simplify in H. ring_simplify. apply H. intros x y H. rewrite -> Qabs_pos;[|assumption]. split. intros H0. apply leEq_imp_AbsSmall; assumption. intros [_ H0]. assumption. Qed. Lemma Cauchy_IR_mult_as_CR_mult : forall x y:Cauchy_IR, ((Cauchy_IRasCR x)*(Cauchy_IRasCR y) == Cauchy_IRasCR (x[*]y))%CR. Proof. intros x [y Hy]. destruct (CS_seq_bounded _ y Hy) as [k Hk [n Hn]]. set (y':=Build_CauchySeq Q_as_COrdField y Hy). set (k':=(exist _ _ Hk)). transitivity ((ucFun2 (CRmult_bounded (CR_b (1 # 1) (Cauchy_IRasCR y')+k')%Qpos) (Cauchy_IRasCR x) (Cauchy_IRasCR y'))). apply CRmult_bounded_weaken. apply CR_b_lowerBound. apply CR_b_upperBound. simpl. rewrite -> Qle_minus_iff. ring_simplify. auto with *. apply Cauchy_IR_mult_as_CRmult_bounded with n. intros i Hi. eapply AbsSmall_trans;[|apply Hn;assumption]. simpl. rewrite -> Qlt_minus_iff. unfold k'. autorewrite with QposElim. ring_simplify. clear. destruct Hy. rewrite Qplus_comm. apply Q.Qplus_lt_le_0_compat. reflexivity. apply Qabs_nonneg. Qed. #[global] Hint Rewrite Cauchy_IR_mult_as_CR_mult : CRtoCauchy_IR. Lemma CR_mult_as_Cauchy_IR_mult : forall x y:CR, (CRasCauchy_IR x)[*](CRasCauchy_IR y) [=] CRasCauchy_IR (x*y)%CR. Proof. apply reverse_iso_bin_wd_fun. apply CRmult_wd. apply Cauchy_IR_mult_as_CR_mult. Qed. (** lt is preserved. *) Lemma Cauchy_IR_lt_as_CR_lt_1 : forall (x y:Cauchy_IR), x[<]y -> (Cauchy_IRasCR x < Cauchy_IRasCR y)%CR. Proof. intros x y [n [e He Hn]]. exists (exist _ _ He). abstract ( autorewrite with CRtoCauchy_IR; intros [m [d Hd Hm]]; refine (Qle_not_lt _ _ (Hn (Nat.max n m) _) _);[auto with *|]; rewrite -> Qlt_minus_iff; apply Qlt_le_trans with d;[assumption|]; autorewrite with QposElim in Hm; eapply Hm; auto with * ). Defined. Lemma CR_lt_as_Cauchy_IR_lt_1 : forall (x y:CR), (x < y)%CR -> (CRasCauchy_IR x)[<](CRasCauchy_IR y). Proof. intros x y [e He]. apply shift_zero_less_minus'. apply (less_leEq_trans _ [0] (Cauchy_CReals.inject_Q _ (proj1_sig e))). eapply ing_lt. apply Qpos_ispos. unfold cg_minus. stepr (CRasCauchy_IR (y-x))%CR. stepl (CRasCauchy_IR (' proj1_sig e)%CR). rewrite <- Cauchy_IR_le_as_CR_le. do 2 rewrite -> CRasCR. assumption. eapply CR_inject_Q_as_Cauchy_IR_inject_Q. stepl (CRasCauchy_IR y[+]CRasCauchy_IR(- x)%CR). apply plus_resp_eq. eapply CR_opp_as_Cauchy_IR_opp. eapply CR_plus_as_Cauchy_IR_plus. Qed. Lemma Cauchy_IR_lt_as_CR_lt_2 : forall (x y:Cauchy_IR), ((Cauchy_IRasCR x) < (Cauchy_IRasCR y))%CR -> x[<]y. Proof. intros x y H. stepl (CRasCauchy_IR (Cauchy_IRasCR (x))); [| apply Cauchy_IRasCauchy_IR]. stepr (CRasCauchy_IR (Cauchy_IRasCR (y))); [| apply Cauchy_IRasCauchy_IR]. apply CR_lt_as_Cauchy_IR_lt_1. assumption. Qed. Lemma CR_lt_as_Cauchy_IR_lt_2 : forall (x y:CR), (CRasCauchy_IR x)[<](CRasCauchy_IR y) -> (x < y)%CR. Proof. intros x y H. eapply CRltT_wd;try apply CRasCR. apply Cauchy_IR_lt_as_CR_lt_1. assumption. Qed. (** appartness is preserved. *) Lemma Cauchy_IR_ap_as_CR_ap_1 : forall (x y:Cauchy_IR), x[#]y -> (CRapartT (Cauchy_IRasCR x) (Cauchy_IRasCR y))%CR. Proof. intros x y [H|H];[left|right];apply Cauchy_IR_lt_as_CR_lt_1; apply H. Defined. Lemma CR_ap_as_Cauchy_IR_ap_1 : forall (x y:CR), CRapartT x y -> (CRasCauchy_IR x) [#] (CRasCauchy_IR y). Proof. intros x y [H|H];[left|right];apply CR_lt_as_Cauchy_IR_lt_1; apply H. Defined. Lemma Cauchy_IR_ap_as_CR_ap_2 : forall (x y:Cauchy_IR), (CRapartT (Cauchy_IRasCR x) (Cauchy_IRasCR y))%CR -> x[#]y. Proof. intros x y [H|H];[left|right];apply Cauchy_IR_lt_as_CR_lt_2; apply H. Qed. Lemma CR_ap_as_Cauchy_IR_ap_2 : forall (x y:CR), (CRasCauchy_IR x) [#] (CRasCauchy_IR y) -> CRapartT x y. Proof. intros x y [H|H];[left|right];apply CR_lt_as_Cauchy_IR_lt_2; apply H. Defined. (** inv is preserved. *) Lemma Cauchy_IR_inv_as_CRinv_pos : forall (x:Cauchy_IR) x_, forall (z:Qpos) (N:nat), (forall i:nat, (N<=i) -> (proj1_sig z <= (CS_seq _ x i))%Q) -> (CRinv_pos z (Cauchy_IRasCR x) == Cauchy_IRasCR (f_rcpcl x (@inr _ _ x_)))%CR. Proof. intros [x Hx] [a [d d_ x_]] z n Hn. apply regFunEq_equiv, regFunEq_e. intros e. simpl. unfold Qinv_modulus. destruct (Hx (proj1_sig z * proj1_sig z * proj1_sig e)%Q) as [b Hb]. destruct (CS_seq_recip) as [c Hc]. set (y := (CS_seq_recip_seq Q_as_COrdField x d d_ a (fun (n : nat) (H : le a n) => leEq_wdr Q_as_COrdField d (@cg_minus Q_as_CGroup (x n) (Qmake Z0 xH)) (x n) (x_ n H) (cg_inv_zero Q_as_CGroup (x n))))) in *. unfold CS_seq_recip_seq in y. simpl in y. set (m:=Nat.max (Nat.max a n) (Nat.max b c)). assert (Hm1: c<=m). unfold m; apply Nat.le_trans with (Nat.max b c); auto with *. change (@ball Q_as_MetricSpace (proj1_sig e+proj1_sig e) (/ Qmax (proj1_sig z) (x b))%Q (y c)). apply ball_triangle with (y m);[|eapply Hc;assumption]. clear Hc. unfold y. destruct (lt_le_dec m a) as [Z|Z]. elim (proj1 (Nat.le_ngt _ _) Z). unfold m. apply Nat.lt_le_trans with (S (Nat.max a n)); auto with *. change (AbsSmall (proj1_sig e) (/ Qmax (proj1_sig z) (x b)-1 * / x m))%Q. clear y. assert (T:(~ (x m == 0)%Q /\ ~ (Qmax (proj1_sig z) (x b) == 0)%Q)). split; apply (ap_symmetric_unfolded Q_as_CSetoid); eapply Qlt_not_eq. apply Qlt_le_trans with (proj1_sig z). apply Qpos_ispos. apply Hn. apply Nat.le_trans with (Nat.max a n). auto with *. unfold m; auto with *. apply Qlt_le_trans with (proj1_sig z); auto with *. stepr ((/(Qmax (proj1_sig z) (x b))*/(x m))*(x m - (Qmax (proj1_sig z) (x b))))%Q; [| simpl; field; assumption]. stepl ((/ Qmax (proj1_sig z) (x b) * / x m)*((Qmax (proj1_sig z) (x b))*(x m)* proj1_sig e))%Q; [| simpl;field; assumption]. apply mult_resp_AbsSmall. assert (foo:forall q:Q, (0<=q -> 0<=/q)%Q). intros [[|p|p] q] qH; apply qH. apply mult_resp_nonneg. apply foo. apply Qle_trans with (proj1_sig z). apply Qpos_nonneg. apply Qmax_ub_l. apply foo. apply Qle_trans with (proj1_sig z). apply Qpos_nonneg. apply Hn. apply Nat.le_trans with (Nat.max a n); unfold m; auto with *. simpl in x_. apply (AbsSmall_leEq_trans _ (proj1_sig z*proj1_sig z*proj1_sig e)%Q). apply mult_resp_leEq_rht;[apply mult_resp_leEq_both|]; try apply Qpos_nonneg. apply Qmax_ub_l. apply Hn. apply Nat.le_trans with (Nat.max a n); unfold m; auto with *. assert (W:AbsSmall (R:=Q_as_COrdField) (proj1_sig z * proj1_sig z * proj1_sig e)%Q (x m - x b)%Q). apply Hb. apply Nat.le_trans with (Nat.max b c); unfold m; auto with *. apply Qmax_case;intros C;[|assumption]. apply leEq_imp_AbsSmall. unfold Qminus. rewrite <- Qle_minus_iff. apply Hn. apply Nat.le_trans with (Nat.max a n); unfold m; auto with *. apply Qle_trans with (x m - x b)%Q. rewrite -> Qle_minus_iff. stepr (proj1_sig z + - x b)%Q; [| simpl; ring]. rewrite <- Qle_minus_iff. assumption. destruct W; assumption. Qed. Lemma Cauchy_IR_nonZero_as_CR_nonZero_1 : forall (x:Cauchy_IR), Dom (f_rcpcl' _) x -> (CRapartT (Cauchy_IRasCR x) 0)%CR. Proof. intros x x_. eapply CRapartT_wd. reflexivity. symmetry. apply Cauchy_IR_inject_Q_as_CR_inject_Q. apply Cauchy_IR_ap_as_CR_ap_1. assumption. Defined. Lemma CR_nonZero_as_Cauchy_IR_nonZero_1 : forall (x:CR), (CRapartT x 0)%CR -> Dom (f_rcpcl' _) (CRasCauchy_IR x). Proof. intros x x_. change ((CRasCauchy_IR x)[#][0]). stepr (CRasCauchy_IR 0%CR). apply CR_ap_as_Cauchy_IR_ap_1. assumption. eapply CR_inject_Q_as_Cauchy_IR_inject_Q. Defined. Lemma Cauchy_IR_inv_as_CR_inv_short : forall (x:Cauchy_IR) x_, (@CRinvT (Cauchy_IRasCR x) (Cauchy_IR_nonZero_as_CR_nonZero_1 _ x_) == Cauchy_IRasCR (f_rcpcl x x_))%CR. Proof. intros [x Hx] [H|H]. set (x':=(Build_CauchySeq Q_as_COrdField x Hx)) in *. assert (H':(cm_unit Cauchy_IR)[<][--](x':Cauchy_IR)). apply inv_cancel_less. rstepl x'. assumption. set (y:= (Cauchy_IRasCR [--](f_rcpcl (F:=Cauchy_IR) ([--](x':Cauchy_IR)) (@inr _ _ H')))%CR). transitivity y. destruct H as [n [e He H]]. change (-(CRinv_pos (exist _ _ He) (- Cauchy_IRasCR (Build_CauchySeq Q_as_COrdField x Hx)))==y)%CR. unfold y. rewrite <- Cauchy_IR_opp_as_CR_opp. apply CRopp_wd. set (X := (Cauchy_IRasCR (f_rcpcl (F:=Cauchy_IR) [--](x':Cauchy_IR) (@inr (R_lt Q_as_COrdField [--](x':Cauchy_IR) ([0]:Cauchy_IR)) ([0][<][--](x':Cauchy_IR)) H')))%CR). rewrite -> Cauchy_IR_opp_as_CR_opp. eapply Cauchy_IR_inv_as_CRinv_pos. intros i Hi. autorewrite with QposElim. simpl. stepr (0 - x i)%Q; [| simpl; ring]. eapply H. apply Hi. unfold y. apply Cauchy_IRasCR_wd. eapply mult_cancel_lft. left. apply H. stepr ([1]:Cauchy_IR). eapply eq_transitive. apply cring_inv_mult_lft. apply eq_symmetric. eapply eq_transitive;[|apply cring_inv_mult_rht]. apply eq_symmetric. apply x_div_x. apply eq_symmetric. apply x_div_x. destruct H as [n [e He H]]. eapply Cauchy_IR_inv_as_CRinv_pos. intros i Hi. autorewrite with QposElim. simpl in *. stepr (x i- 0)%Q; [| simpl; ring]. apply H. apply Hi. Qed. #[global] Hint Rewrite Cauchy_IR_inv_as_CR_inv_short : CRtoCauchy_IR. Lemma Cauchy_IR_inv_as_CR_inv : forall (x:Cauchy_IR) x_ H, (@CRinvT (Cauchy_IRasCR x) H == Cauchy_IRasCR (f_rcpcl x x_))%CR. Proof. intros x x_ H. rewrite <- Cauchy_IR_inv_as_CR_inv_short. apply CRinvT_irrelevant. Qed. Lemma CR_inv_as_Cauchy_IR_inv : forall (x:CR) x_ H, f_rcpcl (CRasCauchy_IR x) H [=] CRasCauchy_IR (@CRinvT x x_). Proof. intros x x_ H. stepl (CRasCauchy_IR (Cauchy_IRasCR (f_rcpcl (CRasCauchy_IR x) H))); [| apply Cauchy_IRasCauchy_IR]. apply CRasCauchy_IR_wd. rewrite <- Cauchy_IR_inv_as_CR_inv_short. apply CRinvT_wd. apply CRasCR. Qed. Lemma CR_inv_as_Cauchy_IR_inv_short : forall (x:CR) x_, f_rcpcl (CRasCauchy_IR x) (CR_nonZero_as_Cauchy_IR_nonZero_1 _ x_) [=] CRasCauchy_IR (@CRinvT x x_). Proof. intros. apply CR_inv_as_Cauchy_IR_inv. Qed. corn-8.20.0/reals/fast/CRcos.v000066400000000000000000000222231473720167500160220ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRsin. Require Import CoRN.reals.fast.CRpi. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.fast.Compress. From Coq Require Import Qpower. Require Import CoRN.model.ordfields.Qordfield. From Coq Require Import Qround. Require Import CoRN.transc.Pi. Require Import CoRN.reals.fast.ModulusDerivative. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.transc.SinCos. Require Import CoRN.tactics.CornTac. Require Import MathClasses.interfaces.abstract_algebra. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Opaque inj_Q CR Qmin Qmax. Local Open Scope Q_scope. Local Open Scope uc_scope. (** ** Cosine Cosine is defined in terms of Sine. [cos x = 1 - 2*(sin(x/2))^2]. But cosine is still first defined on the rational numbers, and lifted to the real numbers. *) Section Cos_Poly. Definition cos_poly_fun (x:Q) :Q := 1 - (2#1) * x * x. Global Instance: Proper ((=) ==> (=)) cos_poly_fun. Proof. unfold cos_poly_fun. solve_proper. Qed. Lemma cos_poly_fun_correct : forall (q:Q), inj_Q IR (cos_poly_fun q)[=][1][-]Two[*](inj_Q IR q[^]2). Proof. intros q. unfold cos_poly_fun. stepr (inj_Q IR ([1][-]Two*q^2)). apply inj_Q_wd. unfold cg_minus; simpl; ring. stepr (inj_Q IR ([1])[-]inj_Q IR (Two[*]q ^ 2))%Q. apply inj_Q_minus. apply cg_minus_wd. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). stepr (inj_Q IR Two[*]inj_Q IR (q^2)). apply inj_Q_mult. apply mult_wd. apply (inj_Q_nring IR 2). apply (inj_Q_power IR q 2). Qed. Definition cos_poly_modulus (e:Qpos) := Qpos2QposInf ((1#4)*e). Lemma DoneMinusX2 : Derivative (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))) (inj_Q_less _ (-1) 1 eq_refl) ([-C-]([1]:IR){-}(Two:IR){**}FId{^}2) ([-C-]([0]:IR){-}(Two:IR){**}((nring 2){**}([-C-][1]{*}FId{^}1))). Proof. apply Derivative_minus. apply Derivative_const. apply Derivative_scal. apply Derivative_nth. apply Derivative_id. Qed. Lemma cos_poly_prf : @is_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace (fun x => cos_poly_fun (QboundAbs (1#1) x)) cos_poly_modulus. Proof. apply (fun a => is_UniformlyContinuousD_Q (Some (-(1))%Q) (Some (1:Q)) eq_refl _ _ DoneMinusX2 cos_poly_fun a (4#1)). simpl; intros q _ _. apply cos_poly_fun_correct. simpl; intros x' _ [Hx0 Hx1]. set (x:=(inj_Q IR x')) in *. stepr (Four:IR); [| now (apply eq_symmetric; apply (inj_Q_nring IR 4))]. stepl (ABSIR ([--](Four[*]x))); [| now (apply AbsIR_wd; rational)]. stepl (ABSIR (Four[*]x)); [| now apply AbsIR_inv]. rstepr (Four[*][1]:IR). apply AbsSmall_imp_AbsIR. apply mult_resp_AbsSmall. apply nring_nonneg. split. stepl ([--](pring IR 1)[/][0][+][1][//]den_is_nonzero IR (-1#1)). assumption. unfold pring; simpl; rational. stepr (pring IR 1[/][0][+][1][//]den_is_nonzero IR 1). assumption. unfold pring; simpl; rational. Qed. Definition cos_poly_uc : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction cos_poly_prf. Definition cos_poly : CR --> CR := Cmap QPrelengthSpace cos_poly_uc. Lemma cos_poly_correct : forall x, AbsSmall (inj_Q IR (1)) x -> (IRasCR ([1][-]Two[*]x[^]2)==cos_poly (IRasCR x))%CR. Proof. intros x Hx. assert (Y:Continuous (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))) ([-C-]([1]:IR){-}(Two:IR){**}FId{^}2)). eapply Derivative_imp_Continuous. apply DoneMinusX2. apply: (ContinuousCorrect (I:=(clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q)))) (inj_Q_less _ (-1) 1 eq_refl) Y); [|repeat constructor|]. intros q Hq Hq0. transitivity (IRasCR (inj_Q IR (cos_poly_fun q)));[|apply IRasCR_wd; apply cos_poly_fun_correct]. simpl. change (' q)%CR with (Cunit_fun Q_as_MetricSpace q). rewrite -> Cmap_fun_correct. rewrite -> MonadLaw3. rewrite -> IR_inj_Q_as_CR. rewrite -> CReq_Qeq. simpl. unfold cos_poly_fun. setoid_replace (Qmax (- (1)) (Qmin (1 # 1) q)) with q. reflexivity. setoid_replace (Qmin (1 # 1) q) with q. rewrite <- Qle_max_r. apply leEq_inj_Q with IR. destruct Hq0; assumption. rewrite <- Qle_min_r. apply leEq_inj_Q with IR. destruct Hq0; assumption. destruct Hx; split;[stepl [--](inj_Q IR (1:Q)); [| now apply eq_symmetric; apply inj_Q_inv]|];assumption. Qed. Lemma Cos_double_angle : forall x, (Cos(Two[*]x)[=][1][-]Two[*]Sin x[^]2). Proof. intros x. csetoid_replace (Two[*]x) (x[+]x);[|rational]. csetoid_rewrite (Cos_plus x x). set (sx:=Sin x). set (cx:=Cos x). rstepl ((cx[^]2)[-](sx[^]2)). unfold cg_minus. csetoid_replace (cx[^]2) ([1][-]sx[^]2). rational. apply cg_inv_unique_2. rstepl ((cx[^]2[+]sx[^]2)[-][1]). apply x_minus_x. apply FFT. Qed. End Cos_Poly. Definition rational_cos (x:Q) := cos_poly (rational_sin (x/2)). Lemma rational_cos_correct_aux a : (cos_poly (IRasCR (Sin (inj_Q IR (a / 2)))) == IRasCR (Cos (inj_Q IR a)))%CR. Proof. rewrite <- cos_poly_correct. apply IRasCR_wd. csetoid_rewrite_rev (Cos_double_angle (inj_Q IR (a/2))). apply Cos_wd. csetoid_replace (Two:IR) (inj_Q IR (2:Q));[|apply eq_symmetric; apply (inj_Q_nring IR 2)]. stepl (inj_Q IR (2*(a/2))); [| now apply inj_Q_mult]. apply inj_Q_wd. simpl; field; discriminate. apply AbsIR_imp_AbsSmall. stepr (nring 1:IR); [| now (apply eq_symmetric; apply (inj_Q_nring IR 1))]. rstepr ([1]:IR). apply AbsIR_Sin_leEq_One. Qed. (** Cosine is correct. *) Lemma rational_cos_correct : forall (a:Q), (rational_cos a == IRasCR (Cos (inj_Q IR a)))%CR. Proof. intros a. unfold rational_cos. rewrite -> rational_sin_correct. apply rational_cos_correct_aux. Qed. Lemma rational_cos_sin a : cos_poly (rational_sin (a / 2)) = rational_cos a. Proof. rewrite rational_sin_correct, rational_cos_correct. now apply rational_cos_correct_aux. Qed. Definition cos_uc_prf : @is_UniformlyContinuousFunction Q_as_MetricSpace CR rational_cos Qpos2QposInf. Proof. apply (is_UniformlyContinuousFunction_wd) with (fun x => rational_cos x) (Qscale_modulus (1#1)). reflexivity. intros x. simpl. autorewrite with QposElim. change (/1) with 1. replace RHS with (proj1_sig x) by simpl; ring. apply Qle_refl. apply (is_UniformlyContinuousD None None I _ _ (Derivative_Cos I) rational_cos). intros q [] _. apply rational_cos_correct. intros x [] _. stepr ([1]:IR). change (AbsIR ([--](Sin x))[<=][1]). stepl (AbsIR (Sin x)); [| now apply AbsIR_inv]. apply AbsIR_Sin_leEq_One. rstepl (nring 1:IR). apply eq_symmetric. apply (inj_Q_nring IR 1). Qed. Definition cos_uc : Q_as_MetricSpace --> CR := Build_UniformlyContinuousFunction cos_uc_prf. Definition cos_slow : CR --> CR := Cbind QPrelengthSpace cos_uc. Lemma cos_slow_correct : forall x, (IRasCR (Cos x) == cos_slow (IRasCR x))%CR. Proof. intros x. apply: (ContinuousCorrect (I:proper realline)); [apply Continuous_Cos | | constructor]. intros q [] _. transitivity (rational_cos q);[|apply rational_cos_correct]. unfold cos_slow. pose proof (Cbind_correct QPrelengthSpace cos_uc). apply ucEq_equiv in H. rewrite -> (H (' q))%CR. apply BindLaw1. Qed. Definition cos (x:CR) := cos_slow (x - (compress (scale (2*Qceiling (approximate (x*(CRinv_pos (6#1) (scale 2 CRpi))) (Qpos2QposInf (1#2)) -(1#2))) CRpi)))%CR. Lemma cos_correct : forall x, (IRasCR (Cos x) == cos (IRasCR x))%CR. Proof. intros x. unfold cos. generalize (Qceiling (approximate (IRasCR x * CRinv_pos (6 # 1) (scale 2 CRpi)) (Qpos2QposInf (1 # 2)) - (1 # 2)))%CR. intros z. rewrite -> compress_correct. rewrite <- CRpi_correct, <- CRmult_scale, <- IR_inj_Q_as_CR, <- IR_mult_as_CR, <- IR_minus_as_CR, <- cos_slow_correct. apply IRasCR_wd. rewrite -> inj_Q_mult. change (2:Q) with (Two:Q). rewrite -> inj_Q_nring. rstepr (Cos (x[+]([--](inj_Q IR z))[*](Two[*]Pi))). setoid_replace (inj_Q IR z) with (zring z:IR). rewrite <- zring_inv. symmetry; apply Cos_periodic_Z. rewrite <- inj_Q_zring. apply inj_Q_wd. symmetry; apply zring_Q. Qed. (* begin hide *) #[global] Hint Rewrite cos_correct : IRtoCR. (* end hide *) corn-8.20.0/reals/fast/CRexp.v000066400000000000000000001020661473720167500160360ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.reals.fast.CRAlternatingSum. Require Import CoRN.reals.fast.CRAlternatingSum_alg. Require Import CoRN.reals.fast.CRstreams. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.iso_CReals. From Coq Require Import Qpower. Require Import CoRN.algebra.COrdFields2. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.transc.PowerSeries. Require Import CoRN.reals.fast.CRpower. Require Import CoRN.transc.Exponential. Require Import CoRN.transc.RealPowers. Require Import CoRN.reals.fast.Compress. Require Import CoRN.reals.fast.ModulusDerivative. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.reals.fast.CRsign. Require Import CoRN.reals.Q_in_CReals. From Coq Require Import Qabs. From Coq Require Import Qround. Require Import CoRN.tactics.CornTac. Require Import MathClasses.theory.int_pow. Require Import MathClasses.interfaces.abstract_algebra. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Opaque CR. Opaque Exp. Local Open Scope Q_scope. Local Open Scope uc_scope. Lemma Qpower_le_1 : forall (a : Q) (p : positive), 0 <= a <= 1 -> 0 <= a ^ p <= 1. Proof. split. - apply Qpower_pos, H. - revert p. apply Pos.peano_ind. apply H. intros p Hp. unfold Qpower. rewrite <- Pos.add_1_l, Qpower_plus_positive. apply (Qle_trans _ (1*Qpower_positive a p)). apply Qmult_le_compat_r. apply H. apply (Qpower_pos a p), H. rewrite Qmult_1_l. apply Hp. Qed. Lemma Qabs_Qpower : forall (a:Q) (p:positive), Qabs (a ^ p) == (Qabs a) ^ p. Proof. intro a. apply Pos.peano_ind. - reflexivity. - intros p Hp. simpl. rewrite <- Pos.add_1_l. rewrite Qpower_plus_positive. rewrite Qabs_Qmult, Hp. clear Hp. rewrite Qpower_plus_positive. reflexivity. Qed. Lemma Qinv_le_compat : forall (a b : Q), 0 < a -> a <= b -> /b <= /a. Proof. intros. apply Qle_shift_inv_l. exact H. apply (Qmult_le_l _ _ b). exact (Qlt_le_trans _ a _ H H0). rewrite Qmult_1_r, Qmult_assoc. rewrite Qmult_inv_r. rewrite Qmult_1_l. exact H0. intro abs. rewrite abs in H0. apply (Qlt_irrefl 0). exact (Qlt_le_trans _ _ _ H H0). Qed. Lemma fact_power_2 : forall n:nat, (2^pred n <= fact n)%nat. Proof. induction n. - apply Nat.le_refl. - apply (Nat.le_trans _ ((S n) * 2^pred n)). 2: apply Nat.mul_le_mono_nonneg_l; [apply Nat.le_0_l | exact IHn]. clear IHn. destruct n. simpl. apply Nat.le_refl. simpl. apply Nat.add_le_mono_l, Nat.add_le_mono_l, Nat.le_0_l. Qed. Lemma Qceiling_fact_le : forall q:Q, 0 < q -> q <= Pos.of_nat (fact (Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling q)))))) # 1. Proof. intros q H. apply (Qle_trans _ _ _ (Qle_ceiling q)). assert (0 < Qceiling q)%Z. { rewrite Zlt_Qlt. apply (Qlt_le_trans _ _ _ H). apply Qle_ceiling. } revert H0. generalize (Qceiling q). intros p ppos. clear H q. unfold Qle; simpl. rewrite Z.mul_1_r, Pos.mul_1_r. destruct p as [|p|p]. exfalso; inversion ppos. 2: exfalso; inversion ppos. clear ppos. apply (Z.le_trans _ (2 ^ Z.log2_up p)). apply Z.log2_up_le_pow2. reflexivity. apply Z.le_refl. revert p. apply Pos.peano_case. discriminate. intro p. generalize (Z.log2_up (Pos.succ p)) (Z.log2_up_pos (Pos.succ p) (Pos.lt_1_succ p)). clear p. intros p ppos. destruct p. inversion ppos. 2: inversion ppos. clear ppos. unfold Z.to_pos. pose proof (fact_power_2 (Pos.to_nat (Pos.succ p))). rewrite Pos2Nat.inj_succ in H. unfold pred in H. rewrite Pos2Nat.inj_succ. simpl (2^p)%Z. rewrite <- Pos2Z.inj_pow_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. 2: apply fact_neq_0. refine (Nat.le_trans _ _ _ _ H). clear H. generalize p. apply Pos.peano_ind. + apply Nat.le_refl. + intros. rewrite Pos2Nat.inj_succ, Pos.pow_succ_r. rewrite Pos2Nat.inj_mul. apply Nat.mul_le_mono_nonneg_l. apply Nat.le_0_l. exact H. Qed. (** ** Exponential [exp] is implement by its alternating Taylor's series. *) Section ExpSeries. Variable a:Q. Definition expStream (px : positive*Q) : positive*Q := (Pos.succ (fst px), snd px * a * (1#fst px)). Lemma expStream_fst : forall p, fst (iterate _ expStream p (1%positive, 1)) ≡ Pos.succ p. Proof. apply Pos.peano_ind. - reflexivity. - intros. rewrite iterate_succ. simpl. rewrite H. reflexivity. Qed. Lemma Str_pth_expStream : forall p, Str_pth _ expStream p (xH,1) == (1#Pos.of_nat (fact (Pos.to_nat p)))*a^p. Proof. apply Pos.peano_ind. - unfold Str_pth. simpl. apply Qmult_1_r. - intros. unfold Str_pth. rewrite iterate_succ. simpl. unfold Str_pth in H. rewrite H. clear H. rewrite expStream_fst. simpl. rewrite <- (Qmult_comm (1#Pos.succ p)), Qmult_assoc, Qmult_assoc. rewrite <- (Qmult_assoc ((1 # Pos.succ p) * (1 # Pos.of_nat (fact (Pos.to_nat p))))). apply Qmult_comp. + unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_l. rewrite Z.mul_1_l. rewrite Pos2Nat.inj_succ. change (fact (S (Pos.to_nat p)))%nat with (S (Pos.to_nat p) * fact (Pos.to_nat p))%nat. rewrite Nat2Pos.inj_mul. 2: discriminate. 2: apply fact_neq_0. rewrite Nat2Pos.inj_succ, Pos2Nat.id. reflexivity. pose proof (Pos2Nat.is_pos p). intro abs. rewrite abs in H. inversion H. + rewrite <- Pos.add_1_r. rewrite Qpower_plus_positive. reflexivity. Qed. Lemma expStream_alt : -1 <= a <= 0 -> Str_alt_decr _ expStream (xH,1). Proof. intros aneg p. unfold Str_pth. rewrite iterate_succ. generalize (iterate (positive and Q) expStream p (1%positive, 1)). intros [n q]. unfold expStream, snd, fst. split. - rewrite <- Qmult_assoc. rewrite <- (Qmult_1_l (Qabs q)). rewrite Qabs_Qmult, Qmult_comm. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. rewrite Qabs_Qmult. apply (Qle_trans _ (1 * Qabs (1#n))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply Qabs_Qle_condition. split. apply aneg. apply (Qle_trans _ 0). apply aneg. discriminate. rewrite Qmult_1_l. apply Pos.le_1_l. - destruct aneg as [_ aneg]. rewrite <- (Qmult_comm a). rewrite <- Qmult_assoc, <- Qmult_assoc. rewrite <- (Qmult_0_l (q * ((1 # n) * q))). apply Qmult_le_compat_r. exact aneg. rewrite Qmult_comm. destruct q, Qnum; unfold Qle; discriminate. Qed. Lemma expStream_zl : -1 <= a <= 0 -> Limit_zero _ expStream (xH,1) (fun e:Qpos => Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ (proj1_sig e)))))). Proof. (* 1/e <= Qceiling (1/e) <= 2 ^ (Z.log2_up (Qceiling (1/e))) and we add 1 more to get <= fact. *) intros aneg [e epos]; unfold proj1_sig. (* Replace a^k by 1 *) rewrite Str_pth_expStream. rewrite Qabs_Qmult, Qmult_comm. apply (Qle_trans _ (1 * Qabs (1 # Pos.of_nat (fact (Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e)))))))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. - generalize (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))). intro p. rewrite Qabs_Qpower. apply Qpower_le_1. split. apply Qabs_nonneg. apply Qabs_Qle_condition. split. apply aneg. apply (Qle_trans _ 0). apply aneg. discriminate. - rewrite Qmult_1_l. clear aneg a. (* Replace fact k by 2^k. *) simpl. rewrite <- (Qinv_involutive e) at 2. assert (0 < /e) as H. { apply Qinv_lt_0_compat, epos. } apply (@Qinv_le_compat (/e) ((Pos.of_nat (fact (Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e)))))))) # 1)). exact H. apply Qceiling_fact_le, H. Qed. End ExpSeries. Lemma exp_ps_correct : forall (a:Q) (p:positive) H, inj_Q IR (Str_pth _ (expStream a) p (xH,1))%Q = Exp_ps (Pos.to_nat p) (inj_Q IR a) H. Proof. intros a p H. rewrite (inj_Q_wd _ _ _ (Str_pth_expStream a p)). revert p H. apply (Pos.peano_ind (fun p => ∀ (H : Dom (Exp_ps (Pos.to_nat p)) (inj_Q IR a)), inj_Q IR ((1 # Pos.of_nat (fact (Pos.to_nat p))) * a ^ p) = Exp_ps (Pos.to_nat p) (inj_Q IR a) H)). - intros H. simpl ((1 # Pos.of_nat (fact (Pos.to_nat 1))) * a ^ 1). rewrite (inj_Q_wd _ _ _ (one_mult _ a)). unfold Pos.to_nat. simpl. rewrite one_mult. setoid_replace ([1] [/] [0] [+] [1] [//] nring_fac_ap_zero IR 1) with (cr_one IR). rewrite one_mult. rewrite cg_inv_zero. reflexivity. unfold cf_div. rewrite one_mult. rewrite <- inv_one at 2. apply f_rcpcl_wd. rewrite cm_lft_unit. reflexivity. - intros p IHp H. rewrite Pos2Nat.inj_succ. stepl (([1][/](nring (S (Pos.to_nat p)))[//]nringS_ap_zero IR (Pos.to_nat p)) [*](inj_Q IR a)[*]Exp_ps (Pos.to_nat p) (inj_Q IR a) H). + simpl. rewrite (mult_commutes IR (nexp IR (Pos.to_nat p) (inj_Q IR a [-] [0]))). rewrite (ax_mult_assoc IR _ _ (cr_proof IR)). rewrite (ax_mult_assoc IR _ _ (cr_proof IR)). apply mult_wd. 2: reflexivity. rewrite cg_inv_zero. rewrite <- (mult_commutes IR (inj_Q IR a)). rewrite <- (mult_commutes IR (inj_Q IR a)). rewrite <- (ax_mult_assoc IR _ _ (cr_proof IR)). apply mult_wd. reflexivity. pose proof (mult_resp_ap_zero _ _ _ (nringS_ap_zero IR (Pos.to_nat p)) (nring_fac_ap_zero IR (Pos.to_nat p))) as X. rewrite <- (mult_of_divs _ _ _ _ _ _ _ X). apply div_wd. apply mult_one. apply eq_symmetric. change (fact (Pos.to_nat p) + (Pos.to_nat p) * fact (Pos.to_nat p))%nat with (S (Pos.to_nat p)*(fact (Pos.to_nat p)))%nat. apply nring_comm_mult. + stepl (inj_Q IR ((1#(Pos.succ p)) *a*((1 # Pos.of_nat (fact (Pos.to_nat p))) * a ^ Pos.to_nat p))%Q). * apply inj_Q_wd. rewrite <- Pos.add_1_l at 2. rewrite (Qpower_plus' a 1 p). 2: discriminate. simpl (a ^ 1). rewrite Qmult_assoc, Qmult_assoc. apply Qmult_comp. rewrite <- (Qmult_comm a), <- Qmult_assoc, Qmult_comm. apply Qmult_comp. 2: reflexivity. change (fact (S (Pos.to_nat p)))%nat with ((S (Pos.to_nat p)) * fact (Pos.to_nat p))%nat. rewrite Nat2Pos.inj_mul. 2: discriminate. 2: apply fact_neq_0. replace (Pos.of_nat (S (Pos.to_nat p))) with (Pos.succ p). reflexivity. rewrite Nat2Pos.inj_succ. rewrite Pos2Nat.id. reflexivity. pose proof (Pos2Nat.is_pos p). intro abs. rewrite abs in H0. inversion H0. rewrite positive_nat_Z. reflexivity. * stepl (([1][/]nring (R:=IR) (S (Pos.to_nat p))[//]nringS_ap_zero IR (Pos.to_nat p))[*]inj_Q IR a[*] inj_Q IR ((1 # Pos.of_nat (fact (Pos.to_nat p))) * a ^ p)%Q) ; [apply mult_wdr; apply IHp|]. clear IHp H. apply eq_symmetric. eapply eq_transitive;[apply inj_Q_mult|]. eapply eq_transitive;[apply mult_wdl;apply inj_Q_mult|]. rewrite positive_nat_Z. apply mult_wdl. apply mult_wdl. change (1 # Pos.succ p)%Q with (1/Pos.succ p)%Q. assert (A:inj_Q IR ((Pos.succ p):Q)[=]nring (S (Pos.to_nat p))). { stepl (inj_Q IR (nring (S (Pos.to_nat p)))). apply inj_Q_nring. apply inj_Q_wd. simpl. rewrite <- Pos.add_1_r. rewrite Pos2Z.inj_add, inject_Z_plus. apply Qplus_comp. 2: reflexivity. revert p. apply Pos.peano_ind. reflexivity. intros p IHp. rewrite Pos2Nat.inj_succ. simpl. rewrite -> IHp. rewrite <- Pos.add_1_r. rewrite Pos2Z.inj_add, inject_Z_plus. reflexivity. } assert (B:inj_Q IR (Pos.succ p:Q)[#][0]). { stepl (nring (R:=IR) (S (Pos.to_nat p))). apply nringS_ap_zero. apply eq_symmetric;assumption. } eapply eq_transitive;[apply inj_Q_div|]. instantiate (1:=B). apply div_wd. apply inj_Q_One. exact A. Qed. Definition rational_exp_small_neg (a:Q) (p:-(1) <= a <= 0) : CR := translate 1 (AltSeries _ (expStream a) (xH,1%Q) _ (expStream_alt p) (expStream_zl p)). Lemma rational_exp_small_neg_wd (a1 a2 : Q) (p1 : -(1) <= a1 <= 0) (p2 : -(1) <= a2 <= 0) : a1 == a2 → rational_exp_small_neg p1 = rational_exp_small_neg p2. Proof. intros E. unfold rational_exp_small_neg. rewrite <- CRplus_translate. rewrite <- CRplus_translate. apply CRplus_eq_r. apply AltSeries_wd. apply Pos.peano_ind. - unfold Str_pth; simpl. rewrite E. reflexivity. - intros. unfold Str_pth. rewrite iterate_succ, iterate_succ. simpl. unfold Str_pth in H. rewrite H. clear H. apply Qmult_comp. apply Qmult_comp. reflexivity. exact E. rewrite expStream_fst, expStream_fst. reflexivity. - reflexivity. Qed. Lemma rational_exp_small_neg_correct : forall (a:Q) Ha, (@rational_exp_small_neg a Ha == IRasCR (Exp (inj_Q IR a)))%CR. Proof. intros a Ha. unfold rational_exp_small_neg. rewrite <- CRplus_translate. setoid_replace 1%CR with (IRasCR ((λ n : nat, Exp_ps n (inj_Q IR a) (fun_series_inc_IR realline Exp_ps Exp_conv (inj_Q IR a) I n)) 0%nat)). apply: AltSeries_correct. intro p. apply exp_ps_correct. simpl. rewrite <- IR_One_as_CR. apply IRasCR_wd. rewrite mult_one. unfold cf_div. rewrite one_mult. rewrite <- inv_one at 1. apply f_rcpcl_wd. rewrite cm_lft_unit. reflexivity. Qed. Program Definition CRe_inv := @rational_exp_small_neg (-1) _. Next Obligation. constructor; discriminate. Qed. (** exp is extended to work on [[-2^n, 0]] for all n. *) (* Faster to compress between the powers of 2, than take a big power 2^n. *) Fixpoint CRpower_2_iter (n : nat) (x : CR) : CR := match n with | O => x | S p => CRpower_N_bounded 2 (1#1) (compress (CRpower_2_iter p x)) end. Lemma CRpower_2_iter_wd : forall (n : nat) (x y : CR), (x == y)%CR -> (CRpower_2_iter n x == CRpower_2_iter n y)%CR. Proof. induction n. - intros. exact H. - intros. simpl. apply Cmap_wd. reflexivity. rewrite compress_fun_correct, compress_fun_correct. apply IHn, H. Qed. Local Opaque compress CRpower_N_bounded. Lemma rational_exp_neg_bounded_correct_aux (a : Q) : a ≤ 0 → (CRpower_N_bounded 2 (1 # 1)) (IRasCR (Exp (inj_Q IR (a / 2)))) = IRasCR (Exp (inj_Q IR a)). Proof. intros Ea. rewrite <- CRpower_N_bounded_correct. - change (CRpower_slow (IRasCR (Exp (inj_Q IR (a / 2)))) (N.to_nat 2))%CR with (IRasCR (Exp (inj_Q IR (a / 2))) * (IRasCR (Exp (inj_Q IR (a / 2))) * 1))%CR. rewrite CRmult_1_r. rewrite <- IR_mult_as_CR. apply IRasCR_wd. set (a':=inj_Q IR (a/2)). simpl. stepl (Exp (a'[+]a')); [| now apply Exp_plus]. apply Exp_wd. unfold a'. eapply eq_transitive. apply eq_symmetric; apply (inj_Q_plus IR). apply inj_Q_wd. change (a / (2#1) + a / (2#1) == a). field. - apply leEq_imp_AbsSmall. + rewrite <- IR_Zero_as_CR. apply IR_leEq_as_CR. apply less_leEq; apply Exp_pos. + apply (@CRle_trans _ (IRasCR [1])). apply IR_leEq_as_CR. apply Exp_leEq_One. stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_leEq. apply mult_cancel_leEq with (2:Q). constructor. change (a/2*2<=0). now replace LHS with a by (simpl; field; discriminate). simpl. rewrite IR_One_as_CR. apply CRle_refl. Qed. (** [exp] works on all nonpositive numbers. *) (* Do not do 2^n in nat, it could make a very large unary nat. *) Lemma rational_exp_neg_bounded_correct : forall (n:nat) (a:Q) (Ha : -1 <= a*(1#2)^n <= 0), (CRpower_2_iter n (rational_exp_small_neg Ha) == IRasCR (Exp (inj_Q IR a)))%CR. Proof. induction n. - intros. simpl. assert (-1 <= a <= 0) as Ha_simpl. { simpl in Ha. rewrite Qmult_1_r in Ha. exact Ha. } rewrite <- (rational_exp_small_neg_correct Ha_simpl). apply rational_exp_small_neg_wd. apply Qmult_1_r. - intros a Ha. simpl. rewrite -> compress_correct. rewrite <- rational_exp_neg_bounded_correct_aux. apply Cmap_wd. reflexivity. assert (-1 <= (a/2)*(1#2)^n <= 0) as Ha_div. { change (S n) with (1+n)%nat in Ha. rewrite Nat2Z.inj_add, Qpower_plus in Ha. simpl in Ha. rewrite Qmult_assoc in Ha. exact Ha. discriminate. } rewrite <- (IHn _ Ha_div). apply CRpower_2_iter_wd, rational_exp_small_neg_wd. unfold Qdiv. rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. change (/2) with ((1#2)^1). rewrite <- Qpower_plus. clear IHn. change 1%Z with (Z.of_nat 1). rewrite <- (Nat2Z.inj_add 1 n). reflexivity. discriminate. destruct Ha as [_ Ha]. apply (Qmult_le_r _ _ ((1#2)^S n)). apply Q.Qpower_0_lt. reflexivity. rewrite Qmult_0_l. exact Ha. Qed. (* Improve n such as -2^n <= a. -a <= 2^n is equivalent to Qceiling(-a) <= 2^n and then we can use the integer log2. *) Lemma rational_exp_bound_power_2 : forall (a:Q), a <= 0 -> - inject_Z (2^Z.to_nat (Z.log2_up (Qceiling(-a)))) <= a. Proof. intros [[|n|n] d] Ha; simpl. discriminate. elim Ha. reflexivity. rewrite Z2Nat.id. clear Ha. rewrite <- (Qopp_involutive (Z.neg n # d)) at 2. apply Qopp_le_compat. change (-(Z.neg n#d)) with (Zpos n # d). apply Q.Zle_Qle_Qceiling. apply Z.log2_up_le_pow2. 2: apply Z.le_refl. apply Z2Nat.inj_lt. apply Z.le_refl. apply (Qceiling_resp_le 0). discriminate. apply Q.Qlt_lt_of_nat_inject_Z. reflexivity. apply Z.log2_up_nonneg. Qed. Lemma power_2_improve_bound_correct : forall (n:nat) (a:Q), a <= 0 -> -inject_Z (2^n) <= a -> -1 <= a*(1#2)^n <= 0. Proof. split. - apply (Qmult_le_r _ _ ((2#1)^n)). apply Q.Qpower_0_lt. reflexivity. apply (Qle_trans _ a). rewrite Zpower_Qpower in H0. exact H0. apply Nat2Z.is_nonneg. rewrite <- Qmult_assoc, <- Qmult_power. setoid_replace ((1 # 2) * 2)%Q with 1%Q by reflexivity. rewrite Qpower_1, Qmult_1_r. apply Qle_refl. - rewrite <- (Qmult_0_l ((1#2)^n)). apply Qmult_le_compat_r. exact H. apply Qpower_pos. discriminate. Qed. Definition rational_exp_neg (a:Q) (Ha : a <= 0) : CR := CRpower_2_iter (Z.to_nat (Z.log2_up (Qceiling(-a)))) (rational_exp_small_neg (power_2_improve_bound_correct _ Ha (rational_exp_bound_power_2 Ha))). (* Some time measures on a 5000 bogomips CPU Lemma Zneg_neg : forall p:positive, Z.neg p # 1 <= 0. Proof. intros. discriminate. Qed. Time Eval vm_compute in (approximate (rational_exp_neg (@Zneg_neg 100%positive)) (Qpos2QposInf (1#(10 ^ 100)%positive))). (* 1.3 secs *) Time Eval vm_compute in (approximate (rational_exp_neg (@Zneg_neg 200%positive)) (Qpos2QposInf (1#(10 ^ 200)%positive))). (* 8 secs *) Time Eval vm_compute in (approximate (rational_exp_neg (@Zneg_neg 300%positive)) (Qpos2QposInf (1#(10 ^ 300)%positive))). (* 23.6 secs *) *) Lemma rational_exp_neg_correct : forall (a:Q) Ha, (@rational_exp_neg a Ha == IRasCR (Exp (inj_Q IR a)))%CR. Proof. intros a Ha. apply rational_exp_neg_bounded_correct. Qed. (** exp(x) is bounded below by (3^x) for x nonpositive, and hence exp(x) is positive. *) Lemma CRe_inv_posH : ('(1#3) <= CRe_inv)%CR. Proof. unfold CRle. apply CRpos_nonNeg. CR_solve_pos (1#1)%Qpos. Qed. (* We parametrize the following lemmas by a lowerbound of [CRe_inv] so that we can easily swap lowerbounds. *) Lemma rational_exp_neg_posH (q : Qpos) (n:nat) (a:Q) : -n ≤ a → a ≤ 0 → '(proj1_sig q) ≤ CRe_inv → '(proj1_sig q^n) ≤ IRasCR (Exp (inj_Q IR a)). Proof. intros Hn Ha small. rewrite <- IR_inj_Q_as_CR. rewrite <- IR_leEq_as_CR. stepl (inj_Q IR (proj1_sig q) [^]n) by (now (apply eq_symmetric; apply inj_Q_power)). assert (X:[0][<]inj_Q IR (`q)). stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_less. now destruct q. astepl (inj_Q IR (`q)[!](nring n)[//]X). unfold power. apply Exp_resp_leEq. destruct n. simpl (nring 0). rewrite cring_mult_zero_op. stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_leEq. assumption. apply (fun a b => (shift_mult_leEq' _ a b _ (nringS_ap_zero IR n))). apply nring_pos; auto with *. stepr (inj_Q IR (a/(S n))). apply Exp_cancel_leEq. astepl (inj_Q IR (`q)). rewrite -> IR_leEq_as_CR. rewrite -> IR_inj_Q_as_CR. assert (Ha0 : -(1)<=(a/S n)<=0). split. rewrite -> Qle_minus_iff. replace RHS with ((a + S n)*(1/(S n))) by (simpl; field;discriminate). replace LHS with (0*(1/(S n))) by simpl; ring. apply: mult_resp_leEq_rht;simpl. replace RHS with (a + - (- (P_of_succ_nat n))) by simpl; ring. rewrite <- Qle_minus_iff. assumption. rewrite <- (Qmake_Qdiv 1 (P_of_succ_nat n)). discriminate. replace RHS with (0*(1/(S n))) by simpl; ring. apply: mult_resp_leEq_rht;simpl. assumption. rewrite <- (Qmake_Qdiv 1 (P_of_succ_nat n)). discriminate. rewrite <- (rational_exp_small_neg_correct Ha0). apply CRle_trans with CRe_inv. apply small. unfold CRe_inv. do 2 rewrite -> (rational_exp_small_neg_correct). rewrite <- IR_leEq_as_CR. apply Exp_resp_leEq. apply inj_Q_leEq. tauto. assert (X0:inj_Q IR (inject_Z (S n))[#][0]). stepl (inj_Q IR (nring (S n))). stepl (@nring IR (S n)); [| now (apply eq_symmetric; apply (inj_Q_nring IR (S n)))]. apply (nringS_ap_zero). apply inj_Q_wd. apply nring_Q. stepl (inj_Q IR a[/]_[//]X0). apply div_wd. apply eq_reflexive. stepl (inj_Q IR (nring (S n))). apply inj_Q_nring. apply inj_Q_wd. apply nring_Q. apply eq_symmetric. apply inj_Q_div. Qed. Lemma rational_exp_neg_posH' (c : Qpos) (a : Q) : a ≤ 0 → '(proj1_sig c) ≤ CRe_inv → '(proj1_sig (Qpos_power c (-Qfloor a))) ≤ IRasCR (Exp (inj_Q IR a)). Proof. intros Ha small. assert (X0:(0 <= -Qfloor a)%Z). apply Z.opp_nonneg_nonpos. rewrite Q.Zle_Qle. apply Qle_trans with a; [| assumption]. now apply Qfloor_le. setoid_replace (proj1_sig (Qpos_power c (-Qfloor a))) with (proj1_sig c ^ Z_to_nat X0). apply rational_exp_neg_posH; trivial. rewrite <- (Z_to_nat_correct X0). rewrite inject_Z_opp, Qopp_involutive. now apply Qfloor_le. now rewrite <- Z_to_nat_correct. Qed. (* Need transparent and fast positivity to define exponential on positive rationals by division. *) Lemma rational_exp_neg_pos : forall (a:Q) Ha, CRpos (@rational_exp_neg a Ha). Proof. intros a Ha. exists (Qpos_power (1#3) (-Qfloor a))%Qpos. simpl. rewrite rational_exp_neg_correct. apply (rational_exp_neg_posH' (1#3)); trivial. apply CRe_inv_posH. Defined. (** exp is extended to all numbers by saying exp(x) = 1/exp(-x) when x is positive. *) Definition rational_exp (a:Q) : CR. Proof. destruct a as [[|n|n] d]. - exact 1%CR. - refine (CRinv_pos (Qpos_power (1#3) (Qceiling (n#d)))%Qpos (@rational_exp_neg (Zneg n#d) _)). discriminate. - apply (@rational_exp_neg (Zneg n#d)). discriminate. Defined. (* Some time measures on a 5000 bogomips CPU Time Eval vm_compute in (approximate (rational_exp (100#1)) (Qpos2QposInf (1#1))). (* 1.2 secs *) Time Eval vm_compute in (approximate (rational_exp (200#1)) (Qpos2QposInf (1#1))). (* 7.1 secs *) Time Eval vm_compute in (approximate (rational_exp (300#1)) (Qpos2QposInf (1#1))). (* 21 secs *) *) Lemma rational_exp_pos_correct (a : Q) (Pa : 0 ≤ a) (c : Qpos) : ('proj1_sig c <= IRasCR (Exp (inj_Q IR (-a)%Q)))%CR → CRinv_pos c (IRasCR (Exp (inj_Q IR (-a)))) = IRasCR (Exp (inj_Q IR a)). Proof. intros Ec. assert (X: (IRasCR (Exp (inj_Q IR (-a)%Q)) >< 0)%CR). right. exists c. now ring_simplify. rewrite (CRinvT_pos_inv c X); trivial. rewrite <- IR_recip_as_CR_2. apply IRasCR_wd. apply eq_symmetric. eapply eq_transitive;[|apply div_wd; apply eq_reflexive]. apply Exp_inv'. rewrite (inj_Q_inv IR a), cg_inv_inv. reflexivity. Qed. Lemma rational_exp_correct (a : Q) : (rational_exp a = IRasCR (Exp (inj_Q IR a)))%CR. Proof. unfold rational_exp. destruct a as [[|n|n] d]. - rewrite <- IR_One_as_CR. apply IRasCR_wd. setoid_replace (inj_Q IR (0 # d)) with (cm_unit IR). symmetry. apply Exp_zero. rewrite <- inj_Q_Zero. apply inj_Q_wd. reflexivity. - rewrite rational_exp_neg_correct. apply (@rational_exp_pos_correct (Zpos n#d)). discriminate. apply (rational_exp_neg_posH' (1#3)). discriminate. now apply CRe_inv_posH. - apply rational_exp_neg_correct. Qed. Lemma rational_exp_square (a : Q) : a ≤ 0 → CRpower_N_bounded 2 (1 # 1) (rational_exp (a / 2)) = rational_exp a. Proof. intros. rewrite 2!rational_exp_correct. now apply rational_exp_neg_bounded_correct_aux. Qed. Lemma rational_exp_opp (c : Qpos) (a : Q) : 0 ≤ a → '(proj1_sig c) ≤ rational_exp (-a) → CRinv_pos c (rational_exp (-a)) = rational_exp a. Proof. rewrite ?rational_exp_correct. intros. now apply rational_exp_pos_correct. Qed. Lemma rational_exp_lower_bound (c : Qpos) (a : Q) : a ≤ 0 → '(proj1_sig c) ≤ CRe_inv → '(proj1_sig (Qpos_power c (-Qfloor a))) ≤ rational_exp a. Proof. rewrite rational_exp_correct. now apply rational_exp_neg_posH'. Qed. (** *** e *) Definition CRe : CR := rational_exp 1. Lemma CRe_correct : (CRe = IRasCR E)%CR. Proof. unfold CRe. rewrite -> rational_exp_correct. apply IRasCR_wd. rewrite inj_Q_One. algebra. Qed. #[global] Hint Rewrite <- CRe_correct : IRtoCR. Opaque inj_Q. (** [exp] is uniformly continuous below any given integer. *) Definition exp_bound (z:Z) : Qpos := (match z with |Z0 => 1#1 |Zpos p => Qpos_power (3#1) p |Zneg p => Qpos_power (1#2) p end)%Qpos. Lemma exp_bound_bound : forall (z:Z) x, closer (inj_Q IR (z:Q)) x -> AbsIR (Exp x)[<=]inj_Q IR (proj1_sig (exp_bound z)). Proof. intros [|z|z]; simpl; intros x Hx; apply AbsSmall_imp_AbsIR; (apply leEq_imp_AbsSmall;[apply less_leEq; apply Exp_pos|]). rewrite inj_Q_One. apply Exp_leEq_One. rewrite inj_Q_Zero in Hx. exact Hx. apply leEq_transitive with (Exp (Max x [0])). apply Exp_resp_leEq. apply lft_leEq_Max. stepr (Three[!](inj_Q IR (inject_Z z))[//](pos_three IR)). astepl (E[!](Max x [0])[//]pos_E). apply real_power_resp_leEq_both; try solve [IR_solve_ineq (1#1)%Qpos]. apply rht_leEq_Max. apply Max_leEq; auto. stepl (inj_Q IR 0). apply inj_Q_leEq. simpl; auto with *. apply (inj_Q_nring IR 0). stepl (Three[!]nring (nat_of_P z)[//]pos_three IR). astepl (@nring IR 3 [^](nat_of_P z)). stepl ((inj_Q IR (3%mc:Q))[^](nat_of_P z)). stepl (inj_Q IR (3%mc^z)). apply inj_Q_wd. apply eq_symmetric. reflexivity. rewrite <- convert_is_POS. apply inj_Q_power. apply nexp_wd. apply (inj_Q_nring IR 3). apply power_wd. apply eq_reflexive. apply eq_symmetric. rewrite <- convert_is_POS. stepl (inj_Q IR (nring (nat_of_P z))). apply (inj_Q_nring). apply inj_Q_wd; apply nring_Q. stepr (Half[!](inj_Q IR (inject_Z z))[//](pos_half IR)). astepl (Exp [--][--]x). astepl ([1][/]_[//](Exp_ap_zero [--]x)). unfold Half. astepr (([1][!]inj_Q IR (z:Q)[//]pos_one _)[/]((Two[!]inj_Q IR (z:Q)[//]pos_two _))[//]power_ap_zero _ _ _). astepr ([1][/]((Two[!]inj_Q IR (z:Q)[//]pos_two _))[//]power_ap_zero _ _ _). apply recip_resp_leEq. apply power_pos. astepr (E[!][--]x[//]pos_E). apply real_power_resp_leEq_both; try solve [IR_solve_ineq (1#1)%Qpos]. stepl (inj_Q IR 0). apply inj_Q_leEq. simpl; auto with *. apply (inj_Q_nring IR 0). rewrite <- cg_inv_inv. apply inv_resp_leEq. stepr (inj_Q IR ((Zneg z):Q)). assumption. astepr (inj_Q IR (-(z:Q))). apply inj_Q_wd. simpl; reflexivity. stepl (Half[!]nring (nat_of_P z)[//]pos_half IR). astepl (@Half IR [^](nat_of_P z)). stepl ((inj_Q IR ((1#2):Q))[^](nat_of_P z)). stepl (inj_Q IR ((1#2)^z)). apply inj_Q_wd. apply eq_symmetric. reflexivity. rewrite <- (convert_is_POS z). apply inj_Q_power. apply nexp_wd. assert (X:(inj_Q IR (2:Q))[#][0]). stepr (inj_Q IR 0). apply inj_Q_ap; discriminate. apply (inj_Q_nring IR 0). stepr ((inj_Q IR 1)[/]_[//]X). stepl (inj_Q IR (1/2)). apply inj_Q_div. apply inj_Q_wd. apply eq_symmetric; apply Qmake_Qdiv. apply div_wd. apply inj_Q_One. apply (inj_Q_nring IR 2). apply power_wd. apply eq_reflexive. apply eq_symmetric. rewrite <- convert_is_POS. stepl (inj_Q IR (nring (nat_of_P z))). apply (inj_Q_nring). apply inj_Q_wd; apply nring_Q. Qed. Lemma exp_bound_uc_prf : forall z:Z, is_UniformlyContinuousFunction (fun a => rational_exp (Qmin z a)) (Qscale_modulus (proj1_sig (exp_bound z))). Proof. intros z. assert (Z:Derivative (closer (inj_Q IR (z:Q))) I Expon Expon). apply (Included_imp_Derivative realline I). Deriv. Included. apply (is_UniformlyContinuousD None (Some (z:Q)) I _ _ Z). intros q [] H. apply rational_exp_correct. intros x [] H. apply: exp_bound_bound. assumption. Qed. Definition exp_bound_uc (z:Z) : Q_as_MetricSpace --> CR := Build_UniformlyContinuousFunction (@exp_bound_uc_prf z). (** [exp] for any real number upto a given integer. *) Definition exp_bounded (z:Z) : CR --> CR := (Cbind QPrelengthSpace (exp_bound_uc z)). Lemma exp_bounded_correct : forall (z:Z) x, closer (inj_Q _ (z:Q)) x -> (IRasCR (Exp x)==exp_bounded z (IRasCR x))%CR. Proof. intros z x Hx. assert (Z:Continuous (closer (inj_Q IR (z:Q))) Expon). apply (Included_imp_Continuous realline). Contin. Included. apply (fun a b c => @ContinuousCorrect _ a Expon Z b c x I); auto with *. constructor. intros q [] H. transitivity (exp_bound_uc z q);[|]. change (' q)%CR with (Cunit_fun _ q). unfold exp_bounded. pose proof (Cbind_correct QPrelengthSpace (exp_bound_uc z)). apply ucEq_equiv in H0. rewrite (H0 (Cunit_fun Q_as_MetricSpace q)). clear H0. apply BindLaw1. change (rational_exp (Qmin z q) == IRasCR (Exp (inj_Q IR q)))%CR. rewrite -> rational_exp_correct. apply IRasCR_wd. apply Exp_wd. apply inj_Q_wd. simpl. rewrite <- Qle_min_r. apply leEq_inj_Q with IR. assumption. Qed. (** exp on all real numbers. [exp_bounded] should be used instead when [x] is known to be bounded by some intenger. *) Definition exp (x:CR) : CR := exp_bounded (Qceiling (approximate x (Qpos2QposInf (1#1)) + (1#1))) x. (* begin hide *) Arguments exp : clear implicits. (* end hide *) Lemma exp_bound_lemma : forall x : CR, (x <= ' (approximate x (Qpos2QposInf (1 # 1)) + 1)%Q)%CR. Proof. intros x. assert (X:=ball_approx_l x (1#1)). rewrite <- CRAbsSmall_ball in X. destruct X as [X _]. simpl in X. rewrite <- CRplus_Qplus. apply CRle_trans with (doubleSpeed x). rewrite -> (doubleSpeed_Eq x); apply CRle_refl. intros e. assert (Y:=X e). simpl in *. do 2 (unfold Cap_raw in *; simpl in * ). apply (Qle_trans _ _ _ Y). ring_simplify. apply Qle_refl. Qed. Lemma exp_correct : forall x, (IRasCR (Exp x) = exp (IRasCR x))%CR. Proof. intros x. unfold exp. apply exp_bounded_correct. simpl. apply leEq_transitive with (inj_Q IR ((approximate (IRasCR x) (Qpos2QposInf (1 # 1)) + 1))); [|apply inj_Q_leEq; simpl;auto with *]. rewrite -> IR_leEq_as_CR. rewrite -> IR_inj_Q_as_CR. apply exp_bound_lemma. Qed. (* begin hide *) #[global] Hint Rewrite exp_correct : IRtoCR. (* end hide *) Lemma exp_bound_exp : forall (z:Z) (x:CR), (x <= 'z -> exp_bounded z x == exp x)%CR. Proof. intros z x H. unfold exp. set (a:=(approximate x (Qpos2QposInf (1 # 1)) + 1)). rewrite <- (CRasIRasCR_id x). rewrite <- exp_bounded_correct. rewrite <- exp_bounded_correct. reflexivity. change (CRasIR x [<=] inj_Q IR (Qceiling a:Q)). rewrite -> IR_leEq_as_CR. autorewrite with IRtoCR. rewrite -> CRasIRasCR_id. apply CRle_trans with ('a)%CR. apply exp_bound_lemma. rewrite -> CRle_Qle. auto with *. change (CRasIR x [<=] inj_Q IR (z:Q)). rewrite -> IR_leEq_as_CR. autorewrite with IRtoCR. rewrite -> CRasIRasCR_id. assumption. Qed. (* begin hide *) Add Morphism exp with signature (@msp_eq _) ==> (@msp_eq _) as exp_wd. Proof. intros x y Hxy. unfold exp at 1. set (a := (approximate x (Qpos2QposInf (1 # 1)) + 1)). rewrite -> Hxy. apply exp_bound_exp. rewrite <- Hxy. apply CRle_trans with ('a)%CR. apply exp_bound_lemma. rewrite -> CRle_Qle. auto with *. Qed. (* end hide *) Lemma exp_Qexp : forall x : Q, (exp (' x) = rational_exp x)%CR. Proof. intros x. rewrite <- IR_inj_Q_as_CR. rewrite <- exp_correct. rewrite <- rational_exp_correct. reflexivity. Qed. #[global] Instance: Proper ((=) ==> (=)) rational_exp. Proof. intros x1 x2 E. rewrite <-2!exp_Qexp. now rewrite E. Qed. (* begin hide *) #[global] Hint Rewrite exp_Qexp : CRfast_compute. (* end hide *) corn-8.20.0/reals/fast/CRln.v000066400000000000000000000324531473720167500156550ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.fast.CRartanh_slow. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. From Coq Require Import Qpower. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.reals.fast.ModulusDerivative. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.tactics.Qauto. Require Import CoRN.transc.Exponential. Require Import CoRN.transc.ArTanH. Require Import CoRN.tactics.CornTac. Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR Logarithm. (** ** Logarithm Logarithm is defined in terms of artanh. [ln (n/d) = 2*artan((n-d)/(n+d))] *) Lemma lnDomainAdaptor : forall a, (0 < a) -> (let (n,d) := a in (n - Zpos d)/(n + Zpos d))^2 < 1. Proof. intros [[|n|n] d] Ha; try solve [elim (Qlt_not_le _ _ Ha); auto with *]. simpl. replace LHS with ((n-d)*(n-d)/((n+d)*(n+d))) by simpl; field; auto with *. apply Qlt_shift_div_r. auto with *. rewrite -> Qlt_minus_iff. ring_simplify. Qauto_pos. Qed. (** Although [rational_ln_slow] works on the entire to domain, it is only efficent for values close 1. *) Definition rational_ln_slow (a:Q) (p: 0 < a) : CR := scale 2 (rational_artanh_slow (lnDomainAdaptor p)). Lemma Qpos_adaptor : forall q, 0 < q -> [0][<]inj_Q IR q. Proof. intros q H. stepl (inj_Q IR 0). apply inj_Q_less. assumption. apply (inj_Q_nring IR 0). Qed. Lemma rational_ln_slow_correct : forall (a:Q) Ha Ha0, (@rational_ln_slow a Ha == IRasCR (Log (inj_Q IR a) Ha0))%CR. Proof. intros a Ha Ha0. unfold rational_ln_slow. assert (X:=artanh_DomArTanH (lnDomainAdaptor Ha)). rewrite -> (fun x => rational_artanh_slow_correct x X). rewrite <- CRmult_scale. rewrite <- IR_inj_Q_as_CR. rewrite <- IR_mult_as_CR. apply IRasCR_wd. csetoid_replace (inj_Q IR (2:Q)) (Two:IR); [|apply (inj_Q_nring IR 2)]. stepr (Two[*](Half[*]Log _ Ha0)); [|unfold Half; rational]. do 2 apply: mult_wdr. unfold Log. simpl. apply cspf_wd. set (b:=let (n, d) := a in (n - Zpos d) / (n + Zpos d)). assert (Y:inj_Q IR a[+][1][#][0]). apply Greater_imp_ap. apply plus_resp_pos; try assumption. apply pos_one. assert (Z:[1][-](inj_Q IR a[-][1][/]_[//]Y)[#][0]). apply Greater_imp_ap. rstepr (Two[/]_[//]Y). apply div_resp_pos. apply plus_resp_pos; try assumption. apply pos_one. apply pos_two. rstepr ([1][+](inj_Q IR a[-][1][/]_[//]Y)[/]_[//]Z). cut (inj_Q IR b[=](inj_Q IR a[-][1][/]inj_Q IR a[+][1][//]Y)). intros. apply div_wd; apply bin_op_wd_unfolded; try apply eq_reflexive; try apply un_op_wd_unfolded; assumption. stepr (inj_Q IR ((a-1)/(a+1))). apply inj_Q_wd. clear - Ha. destruct a as [n d]. simpl. unfold b. rewrite -> Qmake_Qdiv. field. split. unfold Qeq. auto with *. unfold Qeq, Qlt in *. simpl in *. intros H. apply (Zlt_not_le _ _ Ha). ring_simplify in H. ring_simplify. apply Z.le_trans with (-(d*1))%Z. 2: auto with *. apply Zle_left_rev. replace RHS with (-(n + (d*1)))%Z by ring. simpl. rewrite H. apply Z.le_refl. clear - Y. assert (X:inj_Q IR (a + 1)[#][0]). stepl (inj_Q IR a [+]inj_Q IR (nring 1)); [| now apply eq_symmetric; apply inj_Q_plus]. csetoid_rewrite (inj_Q_nring IR 1). rstepl (inj_Q IR a[+][1]). assumption. stepl (inj_Q IR (a - 1)[/]_[//]X); [| now apply eq_symmetric; apply inj_Q_div]. apply div_wd. stepl (inj_Q IR a[-]inj_Q IR 1); [| now apply eq_symmetric; apply inj_Q_minus]. apply bin_op_wd_unfolded. apply eq_reflexive. apply un_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). stepl (inj_Q IR a[+]inj_Q IR 1); [| now apply eq_symmetric; apply inj_Q_plus]. apply bin_op_wd_unfolded. apply eq_reflexive. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). Qed. Lemma rational_ln_slow_correct' : forall (a:Q) Ha, (@rational_ln_slow a Ha == IRasCR (Log (inj_Q IR a) (Qpos_adaptor Ha)))%CR. Proof. intros. apply rational_ln_slow_correct. Qed. (** Efficeny of ln is imporved by scaling the input by a power of two and adding or subtracting a multiple of [ln 2]. *) Definition ln2 : CR := rational_ln_slow (pos_two Q_as_COrdField). Lemma ln2_correct : (ln2 == IRasCR (Log Two (pos_two IR)))%CR. Proof. unfold ln2. rewrite -> rational_ln_slow_correct'. apply IRasCR_wd. apply Log_wd. apply (inj_Q_nring IR 2). Qed. Lemma ln_scale_by_two_power_adapt : forall (n:Z) q, 0 < q -> 0 < (2^n*q). Proof. intros n q H. apply (Qlt_le_trans _ (proj1_sig (Qpos_power (2#1) n * exist _ _ H)%Qpos)). apply Qpos_ispos. apply Qle_refl. Qed. Lemma ln_scale_by_two_power : forall (n:Z) q (Hq:0 < q), (rational_ln_slow Hq + scale n ln2 == rational_ln_slow (ln_scale_by_two_power_adapt n Hq))%CR. Proof. intros n q Hq. rewrite -> ln2_correct. do 2 rewrite -> rational_ln_slow_correct'. rewrite <- CRmult_scale. rewrite <- IR_inj_Q_as_CR. rewrite <- IR_mult_as_CR. rewrite <- IR_plus_as_CR. apply IRasCR_wd. assert (X:[0][<](Two[//](two_ap_zero IR))[^^]n). apply zexp_pos. apply pos_two. stepl (Log _ (Qpos_adaptor Hq)[+]Log _ X). assert (Y:[0][<](inj_Q IR q)[*](Two[//](two_ap_zero IR))[^^]n). apply mult_resp_pos. apply (Qpos_adaptor Hq). assumption. stepl (Log _ Y). apply Log_wd. assert (Z:(inj_Q IR (2:Q))[#][0]). stepr (inj_Q IR (0:Q)). apply inj_Q_ap. discriminate. apply (inj_Q_nring IR 0). csetoid_replace ((Two[//]two_ap_zero IR)[^^](n)) (((inj_Q IR (2:Q))[//]Z)[^^]n). stepr (inj_Q IR q[*]inj_Q IR (2^n)). apply mult_wdr. apply eq_symmetric. apply inj_Q_power_Z. rstepl (inj_Q IR (2 ^ n)[*]inj_Q IR q). apply eq_symmetric. apply (inj_Q_mult IR (2^n) q). apply zexp_wd. apply eq_symmetric. apply (inj_Q_nring IR 2). apply Log_mult. apply bin_op_wd_unfolded. apply eq_reflexive. astepl ((zring n)[*]Log Two (pos_two IR)). apply mult_wdl. Transparent inj_Q. unfold inj_Q. simpl. rational. Qed. Definition ln_scale_power_factor q (Hq:0 < q) : Z. Proof. revert q Hq. intros [[|n|n] d] Hq; try abstract discriminate Hq. exact (Z.pred (Z.log2 d - Z.log2_up n))%Z. Defined. Definition rational_ln (a:Q) (p: 0 < a) : CR := let n := ln_scale_power_factor p in (rational_ln_slow (ln_scale_by_two_power_adapt n p) + scale (-n)%Z ln2)%CR. Lemma rational_ln_correct : forall (a:Q) Ha Ha0, (@rational_ln a Ha == IRasCR (Log (inj_Q IR a) Ha0))%CR. Proof. intros a Ha Ha0. unfold rational_ln. rewrite <- ln_scale_by_two_power. do 2 rewrite <- CRmult_scale. change (((- ln_scale_power_factor Ha)%Z):Q) with ((- ln_scale_power_factor Ha)%Q). rewrite <- CRopp_Qopp. ring_simplify. apply rational_ln_slow_correct. Qed. Lemma rational_ln_correct' : forall (a:Q) Ha, (@rational_ln a Ha == IRasCR (Log (inj_Q IR a) (Qpos_adaptor Ha)))%CR. Proof. intros. apply rational_ln_correct. Qed. (** [ln] is uniformly continuous on any close strictly positive interval. *) Lemma ln_uc_prf_pos : forall (c:Qpos) (x:Q), (0 < Qmax (proj1_sig c) x). Proof. intros c x. simpl. apply Qlt_le_trans with (proj1_sig c); auto with *. Qed. Definition rational_ln_modulus (c:Qpos) (e:Qpos) : QposInf := Qpos2QposInf (c*e). Lemma ln_pos_uc_prf (c:Qpos) : @is_UniformlyContinuousFunction Q_as_MetricSpace CR (fun x => rational_ln (ln_uc_prf_pos c x)) (rational_ln_modulus c). Proof. set (lnf := fun x => match (Qlt_le_dec 0 x) with | left p => rational_ln p | right _ => 0%CR end). apply (is_UniformlyContinuousFunction_wd) with (fun x : Q_as_MetricSpace => lnf (QboundBelow_uc (proj1_sig c) x)) (Qscale_modulus (proj1_sig (Qpos_inv c))). intros x. unfold lnf. destruct (Qlt_le_dec 0 (QboundBelow_uc (proj1_sig c) x)). do 2 rewrite -> rational_ln_correct'. apply IRasCR_wd. algebra. elim (Qle_not_lt _ _ q). apply: ln_uc_prf_pos. intros [[xn xd] xpos]. destruct xn as [|xn|xn]. inversion xpos. 2: inversion xpos. destruct c as [[a b] cpos]. destruct a as [|a|a]. inversion cpos. 2: inversion cpos. apply: Qle_refl. assert (Z:Derivative (closel (inj_Q IR (proj1_sig c))) I Logarithm {1/}FId). apply (Included_imp_Derivative (openl [0]) I). Deriv. intros x Hx. simpl. apply less_leEq_trans with (inj_Q IR (proj1_sig c)); try assumption. stepl (inj_Q IR 0). apply inj_Q_less. simpl; auto with *. apply (inj_Q_nring IR 0). apply (is_UniformlyContinuousD (Some (proj1_sig c)) None I _ _ Z lnf). intros q Hq Hc. unfold lnf. destruct (Qlt_le_dec 0 q). apply rational_ln_correct. elim (Qle_not_lt _ _ q0). apply Qlt_le_trans with (proj1_sig c); auto with *. apply leEq_inj_Q with IR. assumption. intros x Hx Hc. apply AbsSmall_imp_AbsIR. apply leEq_imp_AbsSmall. apply: shift_leEq_div. apply less_leEq_trans with (inj_Q IR (proj1_sig c)); try assumption. stepl (inj_Q IR 0). apply inj_Q_less. simpl; auto with *. apply (inj_Q_nring IR 0). rstepl ([0]:IR). apply less_leEq. apply pos_one. stepr ([1][/]_[//](Greater_imp_ap _ _ _ (Qpos_adaptor (Qpos_ispos c)))). apply: recip_resp_leEq; try assumption. stepl (inj_Q IR 0). apply inj_Q_less. simpl; auto with *. apply (inj_Q_nring IR 0). stepl (((inj_Q IR 1)[/]_[//] Greater_imp_ap IR (inj_Q IR (proj1_sig c)) [0] (Qpos_adaptor (Qpos_ispos c)))). clear. destruct c as [[a b] cpos]. destruct a as [|a|a]. inversion cpos. 2: inversion cpos. unfold Qpos_inv, proj1_sig. change (inj_Q IR (/ (a#b))) with (inj_Q IR (1/(a#b))). apply eq_symmetric. apply inj_Q_div. apply div_wd. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). apply eq_reflexive. Qed. Definition ln_pos_uc (c:Qpos) : Q_as_MetricSpace --> CR := Build_UniformlyContinuousFunction (@ln_pos_uc_prf c). Definition CRln_pos (c:Qpos) : CR --> CR := (Cbind QPrelengthSpace (ln_pos_uc c)). Lemma CRln_pos_correct : forall (c:Qpos) x Hx, closel (inj_Q _ (proj1_sig c)) x -> (IRasCR (Log x Hx)==CRln_pos c (IRasCR x))%CR. Proof. intros c x Hx Hx0. assert (Z:Continuous (closel (inj_Q IR (proj1_sig c))) Logarithm). apply (Included_imp_Continuous (openl [0])). Contin. clear - c. intros x Hx. simpl. apply less_leEq_trans with (inj_Q IR (proj1_sig c)); try assumption. stepl (inj_Q IR 0). apply inj_Q_less. simpl; auto with *. apply (inj_Q_nring IR 0). apply (fun x => @ContinuousCorrect _ x Logarithm Z); auto with *. constructor. intros q Hq H. change (CRln_pos c (' q) == IRasCR (Log (inj_Q IR q) Hq))%CR. transitivity (ln_pos_uc c q);[|]. unfold CRln_pos. change (' q)%CR with (Cunit_fun Q_as_MetricSpace q). pose proof (Cbind_correct QPrelengthSpace (ln_pos_uc c)). apply ucEq_equiv in H0. rewrite -> (H0 (Cunit_fun Q_as_MetricSpace q)). apply BindLaw1. simpl. rewrite -> rational_ln_correct'. apply IRasCR_wd. apply Log_wd. apply inj_Q_wd. simpl. rewrite <- Qle_max_r. apply leEq_inj_Q with IR. assumption. Qed. Definition CRln (x:CR) (Hx:(0 < x)%CR) : CR := let (c,_) := Hx in CRln_pos c x. (* begin hide *) Arguments CRln : clear implicits. (* end hide *) Lemma CRln_correct : forall x Hx Hx0, (IRasCR (Log x Hx)==CRln (IRasCR x) Hx0)%CR. Proof. intros x Hx [c Hc]. apply CRln_pos_correct. change ((inj_Q IR (proj1_sig c))[<=]x). rewrite -> IR_leEq_as_CR. rewrite -> IR_inj_Q_as_CR. setoid_replace (IRasCR x) with (IRasCR x - 0)%CR by (simpl; ring). assumption. Qed. Lemma CRln_pos_ln : forall (c:Qpos) (x:CR) Hx, ('proj1_sig c <= x -> CRln_pos c x == CRln x Hx)%CR. Proof. intros c x Hx Hc. assert (X:[0][<](CRasIR x)). apply CR_less_as_IR. apply CRltT_wd with 0%CR x; try assumption. rewrite -> IR_Zero_as_CR. reflexivity. rewrite -> CRasIRasCR_id. reflexivity. destruct Hx as [d Hd]. unfold CRln. rewrite <- (CRasIRasCR_id x). rewrite <- (CRln_pos_correct c _ X). rewrite <- (CRln_pos_correct d _ X). reflexivity. change (inj_Q IR (proj1_sig d)[<=](CRasIR x)). rewrite -> IR_leEq_as_CR. autorewrite with IRtoCR. rewrite -> CRasIRasCR_id. ring_simplify in Hd. assumption. change (inj_Q IR (proj1_sig c)[<=](CRasIR x)). rewrite -> IR_leEq_as_CR. autorewrite with IRtoCR. rewrite -> CRasIRasCR_id. assumption. Qed. Lemma CRln_wd : forall (x y:CR) Hx Hy, (x == y -> CRln x Hx == CRln y Hy)%CR. Proof. intros x y [c Hc] Hy Hxy. unfold CRln at 1. rewrite -> Hxy. apply CRln_pos_ln. rewrite <- Hxy. ring_simplify in Hc. assumption. Qed. Lemma CRln_irrelvent : forall x Hx Hx0, (CRln x Hx == CRln x Hx0)%CR. Proof. intros. apply CRln_wd. reflexivity. Qed. corn-8.20.0/reals/fast/CRpi.v000066400000000000000000000007251473720167500156510ustar00rootroot00000000000000(* CRpi_fast is better for computation, but CRpi_slow is faster to compile, and may be prefered for development. *) (* Require Export CRpi_slow. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.reals.fast.CRpi_fast. Require Import CoRN.reals.fast.CRsign. Lemma CRpi_pos : (0 < CRpi)%CR. Proof. CR_solve_pos (1#10)%Qpos. Qed. corn-8.20.0/reals/fast/CRpi_fast.v000066400000000000000000000274671473720167500167020ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.Q_in_CReals. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.reals.fast.CRarctan_small. Require Import CoRN.transc.MoreArcTan. Require Import CoRN.tactics.CornTac. Require Import MathClasses.interfaces.abstract_algebra. Require Import CoRN.stdlib_omissions.Q. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR. (** ** Pi (Please import CRpi instead) This version is faster to compute than CRpi_slow; however it is slower to compile. Pi is defined as 176*arctan(1/57) + 28*arctan(1/239) - 48*arctan(1/682) + 96*arctan(1/12943). *) Section Pi. Lemma small_per_57 : (-1 < (1#(57%positive)) < 1)%Q. Proof. split; easy. Qed. Lemma small_per_239 : (-1 < (1#(239%positive)) < 1)%Q. Proof. split; easy. Qed. Lemma small_per_682 : (-1 < (1#(682%positive)) < 1)%Q. Proof. split; easy. Qed. Lemma small_per_12943 : (-1 < (1#(12943%positive)) < 1)%Q. Proof. split; easy. Qed. Definition r_pi (r:Q) : CR := ((scale (176%Z*r) (rational_arctan_small (widen_interval small_per_57)) + scale (28%Z*r) (rational_arctan_small (widen_interval small_per_239))) + (scale (-(48%Z)*r) (rational_arctan_small (widen_interval small_per_682)) + scale (96%Z*r) (rational_arctan_small (widen_interval small_per_12943))))%CR. (** To prove that pi is is correct we repeatedly use the arctan sum law. The problem is that the arctan sum law only works for input between -1 and 1. We use reflect to show that our use of arctan sum law always satifies this restriction. *) Let f (a b:Q) : Q := let (x,y) := a in let (z,w) := b in Qred ((x*w + y*z)%Z/(y*w-x*z)%Z). Lemma f_char : forall a b, f a b == (a+b)/(1-a*b). Proof. intros [x y] [w z]. unfold f. rewrite -> Qred_correct. destruct (Z.eq_dec (y*z) (x*w)) as [H|H]. unfold Qmult. simpl ((Qnum (x # y) * Qnum (w # z) # Qden (x # y) * Qden (w # z))). repeat rewrite <- H. replace (y * z - y * z)%Z with 0%Z by ring. setoid_replace (1-(y * z # y * z)) with 0. change ((x * z + y * w)%Z * 0 == ((x # y) + (w # z)) * 0). ring. rewrite -> (Qmake_Qdiv (y*z)). change (1 - (y * z)%positive / (y * z)%positive == 0). field; discriminate. unfold Zminus. repeat rewrite -> injz_plus. change (((x * Zpos z) + (Zpos y * w)) / (Zpos y * Zpos z - x * w) == ((x # y) + (w # z)) / (1 - (x #y)*(w # z))). repeat rewrite -> Qmake_Qdiv. field. repeat split; try discriminate. cut (~(y * z)%Z == (x * w)%Z). intros X Y. apply X. replace RHS with ((x * w)%Z + 0) by simpl; ring. rewrite <- Y. change ((y * z) == (x * w) + (y * z - x * w)). ring. intros X; apply H. unfold Qeq in X. simpl in X. rewrite Pmult_1_r in X. change ((y * z)%Z = (x * w * 1)%Z) in X. rewrite X. ring. Qed. Lemma ArcTan_plus_ArcTan_Q : forall x y, -(1) <= x <= 1 -> -(1) <= y <= 1 -> ~1-x*y==0 -> (ArcTan (inj_Q _ x)[+]ArcTan (inj_Q _ y)[=]ArcTan (inj_Q _ (f x y))). Proof. intros x y [Hx0 Hx1] [Hy0 Hy1] H. assert (X:forall z, -(1) <= z -> [--][1][<=]inj_Q IR z). intros z Hz. stepl ((inj_Q IR (-(1)))). apply inj_Q_leEq; assumption. eapply eq_transitive. apply (inj_Q_inv IR (1)). apply un_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). assert (X0:forall z, z <= 1 -> inj_Q IR z[<=][1]). intros z Hz. stepr ((inj_Q IR ((1)))). apply inj_Q_leEq; assumption. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). assert ([1][-](inj_Q IR x)[*](inj_Q IR y)[#][0]). stepl (inj_Q IR (1[-]x[*]y)). (stepr (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]). apply inj_Q_ap; assumption. eapply eq_transitive. apply inj_Q_minus. apply bin_op_wd_unfolded. rstepr (nring 1:IR); apply (inj_Q_nring IR 1). apply un_op_wd_unfolded. apply inj_Q_mult. apply eq_transitive with (ArcTan (inj_Q IR x[+]inj_Q IR y[/]([1][-]inj_Q IR x[*]inj_Q IR y)[//]X1)). apply ArcTan_plus_ArcTan; first [apply X; assumption |apply X0; assumption]. apply ArcTan_wd. stepl (inj_Q IR ((x[+]y)/([1][-]x*y))). apply inj_Q_wd. simpl. symmetry. apply f_char. assert (H0:(inj_Q IR ([1][-]x * y))[#][0]). (stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]). apply inj_Q_ap; assumption. apply eq_transitive with (inj_Q IR (x[+]y)[/]inj_Q IR ([1][-]x * y)[//]H0). apply (inj_Q_div). apply div_wd. apply inj_Q_plus. eapply eq_transitive. apply inj_Q_minus. apply bin_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). apply un_op_wd_unfolded. apply inj_Q_mult. Qed. Definition ArcTan_multiple : forall x, -(1) <= x <= 1 -> forall n, sumbool True ((nring n)[*]ArcTan (inj_Q _ x)[=]ArcTan (inj_Q _ (iter_nat n _ (f x) 0))). Proof. intros x Hx. induction n. right. abstract ( rstepl ([0]:IR); (stepl (ArcTan [0]); [| now apply ArcTan_zero]); apply ArcTan_wd; apply eq_symmetric; apply (inj_Q_nring IR 0)). simpl. destruct (IHn) as [H|H]. left; constructor. set (y:=(iter_nat n Q (f x) 0)) in *. destruct (Qlt_le_dec_fast 1 y) as [_|Y0]. left; constructor. destruct (Qlt_le_dec_fast y (-(1))) as [_|Y1]. left; constructor. destruct (Qeq_dec (1-x*y) 0) as [_|Y2]. left; constructor. right. abstract ( rstepl (ArcTan (inj_Q IR x)[+](nring n[*]ArcTan (inj_Q IR x))); csetoid_rewrite H; apply ArcTan_plus_ArcTan_Q; try assumption; split; assumption). Defined. Lemma reflect_right : forall A B (x:{A}+{B}), (match x with left _ => False | right _ => True end) -> B. Proof. intros A B x. elim x. contradiction. trivial. Qed. Lemma Pi_Formula : (((nring 44)[*]ArcTan (inj_Q IR (1 / 57%Z))[-] (nring 12)[*]ArcTan (inj_Q IR (1 / 682%Z))[+] (nring 7)[*]ArcTan (inj_Q IR (1 / 239%Z))[+] (nring 24)[*]ArcTan (inj_Q IR (1 / 12943%Z)))[=] Pi[/]FourNZ). Proof. assert (H0:-(1) <= (1/(57%Z)) <= 1). split; discriminate. assert (H1:-(1) <= (1/(239%Z)) <= 1). split; discriminate. assert (H2:-(1) <= (1/(682%Z)) <= 1). split; discriminate. assert (H3:-(1) <= (1/(12943%Z)) <= 1). split; discriminate. set (y0:=(iter_nat 44 _ (f (1/57%Z)) 0)). set (y1:=(iter_nat 7 _ (f (1/239%Z)) 0)). set (y2:=(iter_nat 12 _ (f (1/682%Z)) 0)). set (y3:=(iter_nat 24 _ (f (1/12943%Z)) 0)). rstepl (nring 44[*]ArcTan (inj_Q IR (1 / 57%Z))[+] [--](nring 12[*]ArcTan (inj_Q IR (1 / 682%Z)))[+] (nring 7[*]ArcTan (inj_Q IR (1 / 239%Z))[+] nring 24[*]ArcTan (inj_Q IR (1 / 12943%Z)))). csetoid_replace ((nring 44)[*]ArcTan (inj_Q IR (1 / 57%Z))) (ArcTan (inj_Q IR y0)); [|apply: (reflect_right (ArcTan_multiple H0 44)); now vm_compute]. csetoid_replace ((nring 7)[*]ArcTan (inj_Q IR (1 / 239%Z))) (ArcTan (inj_Q IR y1)); [|apply: (reflect_right (ArcTan_multiple H1 7)); now vm_compute]. csetoid_replace ((nring 12)[*]ArcTan (inj_Q IR (1 / 682%Z))) (ArcTan (inj_Q IR y2)); [|apply: (reflect_right (ArcTan_multiple H2 12)); now vm_compute]. csetoid_replace ((nring 24)[*]ArcTan (inj_Q IR (1 / 12943%Z))) (ArcTan (inj_Q IR y3)); [|apply: (reflect_right (ArcTan_multiple H3 24)); now vm_compute]. vm_compute in y0. vm_compute in y1. vm_compute in y2. vm_compute in y3. csetoid_replace ([--](ArcTan (inj_Q IR y2))) (ArcTan (inj_Q IR (-y2))); [|csetoid_rewrite_rev (ArcTan_inv (inj_Q IR y2)); apply ArcTan_wd; apply eq_symmetric; apply (inj_Q_inv IR y2)]. csetoid_replace (ArcTan (inj_Q IR y0)[+]ArcTan (inj_Q IR (-y2))) (ArcTan (inj_Q IR (f y0 (-y2)))); [|apply ArcTan_plus_ArcTan_Q; try split; now vm_compute]. csetoid_replace (ArcTan (inj_Q IR y1)[+]ArcTan (inj_Q IR y3)) (ArcTan (inj_Q IR (f y1 y3))); [|apply ArcTan_plus_ArcTan_Q; try split; now vm_compute]. set (z0 := (f y0 (-y2))). set (z1 := (f y1 y3)). vm_compute in z0. vm_compute in z1. csetoid_replace (ArcTan (inj_Q IR z0)[+]ArcTan (inj_Q IR z1)) (ArcTan (inj_Q IR (f z0 z1))); [|apply ArcTan_plus_ArcTan_Q; try split; now vm_compute]. set (z3:= (f z0 z1)). vm_compute in z3. eapply eq_transitive;[|apply ArcTan_one]. apply ArcTan_wd. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). Qed. Lemma r_pi_correct : forall r, (r_pi r == IRasCR ((inj_Q IR r)[*]Pi))%CR. Proof. intros r. unfold r_pi. repeat rewrite <- (CRmult_scale). setoid_replace (176%Z* r) with (4%Z * r * 44%Z) by (simpl; ring). setoid_replace (28%Z * r) with (4%Z * r * 7%Z) by (simpl; ring). setoid_replace (-(48)%Z * r) with (4%Z * r * -(12)%Z) by (simpl; ring). setoid_replace (96%Z * r) with (4%Z * r * 24%Z) by (simpl; ring). repeat rewrite <- CRmult_Qmult. transitivity ('4%Z * 'r *(' 44%Z * rational_arctan_small (widen_interval small_per_57) + ' 7%Z * rational_arctan_small (widen_interval small_per_239) + (' (-12)%Z * rational_arctan_small (widen_interval small_per_682) + ' 24%Z * rational_arctan_small (widen_interval small_per_12943))))%CR. ring. repeat rewrite rational_arctan_small_correct. repeat rewrite <- IR_inj_Q_as_CR. repeat (rewrite <- IR_mult_as_CR || rewrite <- IR_plus_as_CR). apply IRasCR_wd. rstepr (Four[*]inj_Q IR r[*]Pi[/]FourNZ). apply mult_wd. apply mult_wdl. apply (inj_Q_nring IR 4). eapply eq_transitive;[|apply Pi_Formula]. rstepr (nring 44[*]ArcTan (inj_Q IR (1 / 57%Z))[+] nring 7[*]ArcTan (inj_Q IR (1 / 239%Z))[+] (([--](nring 12))[*]ArcTan (inj_Q IR (1 / 682%Z))[+] nring 24[*]ArcTan (inj_Q IR (1 / 12943%Z)))). repeat apply bin_op_wd_unfolded; try apply eq_reflexive. apply (inj_Q_nring IR 44). apply (inj_Q_nring IR 7). eapply eq_transitive. apply (inj_Q_inv IR (nring 12)). csetoid_rewrite (inj_Q_nring IR 12). apply eq_reflexive. apply (inj_Q_nring IR 24). Qed. Global Instance: Proper (Qeq ==> msp_eq) r_pi. Proof. intros ? ? E. unfold r_pi. apply ucFun2_wd. apply ucFun2_wd. apply Cmap_wd. 2: reflexivity. simpl. split. discriminate. intro q. simpl. unfold Qmetric.Qball, Qmetric.QAbsSmall. rewrite E. unfold Qminus. rewrite Qplus_opp_r. split; discriminate. apply Cmap_wd. 2: reflexivity. simpl. split. discriminate. intro q. simpl. unfold Qmetric.Qball, Qmetric.QAbsSmall. rewrite E. unfold Qminus. rewrite Qplus_opp_r. split; discriminate. apply ucFun2_wd. apply Cmap_wd. 2: reflexivity. simpl. split. discriminate. intro q. simpl. unfold Qmetric.Qball, Qmetric.QAbsSmall. rewrite E. unfold Qminus. rewrite Qplus_opp_r. split; discriminate. apply Cmap_wd. 2: reflexivity. simpl. split. discriminate. intro q. simpl. unfold Qmetric.Qball, Qmetric.QAbsSmall. rewrite E. unfold Qminus. rewrite Qplus_opp_r. split; discriminate. Qed. Definition CRpi : CR := (r_pi 1). Lemma CRpi_correct : (IRasCR Pi == CRpi)%CR. Proof. unfold CRpi. rewrite -> r_pi_correct. apply IRasCR_wd. rstepl ((nring 1)[*]Pi). apply mult_wdl. apply eq_symmetric. apply (inj_Q_nring IR 1). Qed. End Pi. (* begin hide *) #[global] Hint Rewrite CRpi_correct : IRtoCR. (* end hide *) corn-8.20.0/reals/fast/CRpi_slow.v000066400000000000000000000250361473720167500167170ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.Q_in_CReals. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.reals.fast.CRarctan_small. Require Import CoRN.transc.MoreArcTan. Require Import CoRN.tactics.CornTac. Require Import CoRN.stdlib_omissions.Q. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR. Section Pi. (** ** Pi (alternate) (Please import CRpi instead) This version is slower to compute than CRpi_fast; however it is faster to compile. Pi is defined as 68*arctan(1/23) + 32*arctan(1/182) + 40*arctan(1/5118) + 20*arctan(1/6072). *) Lemma small_per_23 : (-(1#1) < 1#23 < 1)%Q. Proof. split; reflexivity. Qed. Lemma small_per_182 : (-(1#1) < 1#182 < 1)%Q. Proof. split; reflexivity. Qed. Lemma small_per_5118 : (-(1#1) < 1#5118 < 1)%Q. Proof. split; reflexivity. Qed. Lemma small_per_6072 : (-(1#1) < 1#6072 < 1)%Q. Proof. split; reflexivity. Qed. Definition r_pi (r:Q) : CR := ((scale (68%Z*r) (rational_arctan_small (widen_interval small_per_23)) + scale (32%Z*r) (rational_arctan_small (widen_interval small_per_182))) + (scale (40%Z*r) (rational_arctan_small (widen_interval small_per_5118)) + scale (20%Z*r) (rational_arctan_small (widen_interval small_per_6072))))%CR. (** To prove that pi is is correct we repeatedly use the arctan sum law. The problem is that the arctan sum law only works for input between -1 and 1. We use reflect to show that our use of arctan sum law always satifies this restriction. *) Let f (a b:Q) : Q := let (x,y) := a in let (z,w) := b in Qred ((x*w + y*z)%Z/(y*w-x*z)%Z). Lemma f_char : forall a b, f a b == (a+b)/(1-a*b). Proof. intros [x y] [w z]. unfold f. rewrite -> Qred_correct. destruct (Z.eq_dec (y*z) (x*w)) as [H|H]. unfold Qmult. simpl ((Qnum (x # y) * Qnum (w # z) # Qden (x # y) * Qden (w # z))). repeat rewrite <- H. replace (y * z - y * z)%Z with 0%Z by ring. setoid_replace (1-(y * z # y * z)) with 0. change ((x * z + y * w)%Z * 0 == ((x # y) + (w # z)) * 0). ring. rewrite -> (Qmake_Qdiv (y*z)). change (1 - (y * z)%positive / (y * z)%positive == 0). field; discriminate. unfold Zminus. repeat rewrite -> injz_plus. change (((x * Zpos z) + (Zpos y * w)) / (Zpos y * Zpos z - x * w) == ((x # y) + (w # z)) / (1 - (x #y)*(w # z))). repeat rewrite -> Qmake_Qdiv. field. repeat split; try discriminate. cut (~(y * z)%Z == (x * w)%Z). intros X Y. apply X. replace RHS with ((x * w)%Z + 0) by simpl; ring. rewrite <- Y. change ((y * z) == (x * w) + (y * z - x * w)). ring. intros X; apply H. unfold Qeq in X. simpl in X. rewrite Pmult_1_r in X. change ((y * z)%Z = (x * w * 1)%Z) in X. rewrite X. ring. Qed. Lemma ArcTan_plus_ArcTan_Q : forall x y, -(1) <= x <= 1 -> -(1) <= y <= 1 -> ~1-x*y==0 -> (ArcTan (inj_Q _ x)[+]ArcTan (inj_Q _ y)[=]ArcTan (inj_Q _ (f x y))). Proof. intros x y [Hx0 Hx1] [Hy0 Hy1] H. assert (X:forall z, -(1) <= z -> [--][1][<=]inj_Q IR z). intros z Hz. stepl ((inj_Q IR (-(1)))). apply inj_Q_leEq; assumption. eapply eq_transitive. apply (inj_Q_inv IR (1)). apply un_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). assert (X0:forall z, z <= 1 -> inj_Q IR z[<=][1]). intros z Hz. stepr ((inj_Q IR ((1)))). apply inj_Q_leEq; assumption. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). assert ([1][-](inj_Q IR x)[*](inj_Q IR y)[#][0]). stepl (inj_Q IR (1[-]x[*]y)). (stepr (inj_Q IR [0]); [| now apply (inj_Q_nring IR 0)]). apply inj_Q_ap; assumption. eapply eq_transitive. apply inj_Q_minus. apply bin_op_wd_unfolded. rstepr (nring 1:IR); apply (inj_Q_nring IR 1). apply un_op_wd_unfolded. apply inj_Q_mult. apply eq_transitive with (ArcTan (inj_Q IR x[+]inj_Q IR y[/]([1][-]inj_Q IR x[*]inj_Q IR y)[//]X1)). apply ArcTan_plus_ArcTan; first [apply X; assumption |apply X0; assumption]. apply ArcTan_wd. stepl (inj_Q IR ((x[+]y)/([1][-]x*y))). apply inj_Q_wd. simpl. symmetry. apply f_char. assert (H0:(inj_Q IR ([1][-]x * y))[#][0]). (stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]). apply inj_Q_ap; assumption. apply eq_transitive with (inj_Q IR (x[+]y)[/]inj_Q IR ([1][-]x * y)[//]H0). apply (inj_Q_div). apply div_wd. apply inj_Q_plus. eapply eq_transitive. apply inj_Q_minus. apply bin_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). apply un_op_wd_unfolded. apply inj_Q_mult. Qed. Definition ArcTan_multiple : forall x, -(1) <= x <= 1 -> forall n, {True} + {(nring n)[*]ArcTan (inj_Q _ x)[=]ArcTan (inj_Q _ (iter_nat n _ (f x) 0))}. Proof. intros x Hx. induction n. right. abstract ( rstepl ([0]:IR); (stepl (ArcTan [0]); [| now apply ArcTan_zero]); apply ArcTan_wd; apply eq_symmetric; apply (inj_Q_nring IR 0)). simpl. destruct (IHn) as [H|H]. left; constructor. set (y:=(iter_nat n Q (f x) 0)) in *. destruct (Qlt_le_dec_fast 1 y) as [_|Y0]. left; constructor. destruct (Qlt_le_dec_fast y (-(1))) as [_|Y1]. left; constructor. destruct (Qeq_dec (1-x*y) 0) as [_|Y2]. left; constructor. right. abstract ( rstepl (ArcTan (inj_Q IR x)[+](nring n[*]ArcTan (inj_Q IR x))); csetoid_rewrite H; apply ArcTan_plus_ArcTan_Q; try assumption; split; assumption). Defined. Lemma reflect_right : forall A B (x:{A}+{B}), (match x with left _ => False | right _ => True end) -> B. Proof. intros A B x. elim x. contradiction. trivial. Qed. Lemma Pi_Formula : (((nring 17)[*]ArcTan (inj_Q IR (1 / 23%Z))[+] (nring 8)[*]ArcTan (inj_Q IR (1 / 182%Z))[+] (nring 10)[*]ArcTan (inj_Q IR (1 / 5118%Z))[+] (nring 5)[*]ArcTan (inj_Q IR (1 / 6072%Z)))[=] Pi[/]FourNZ). Proof. assert (H0:-(1) <= (1/(23%Z)) <= 1). split; discriminate. assert (H1:-(1) <= (1/(182%Z)) <= 1). split; discriminate. assert (H2:-(1) <= (1/(5118%Z)) <= 1). split; discriminate. assert (H3:-(1) <= (1/(6072%Z)) <= 1). split; discriminate. set (y0:=(iter_nat 17 _ (f (1/23%Z)) 0)). set (y1:=(iter_nat 8 _ (f (1/182%Z)) 0)). set (y2:=(iter_nat 10 _ (f (1/5118%Z)) 0)). set (y3:=(iter_nat 5 _ (f (1/6072%Z)) 0)). rstepl (nring 17[*]ArcTan (inj_Q IR (1 / 23%Z))[+] nring 8[*]ArcTan (inj_Q IR (1 / 182%Z))[+] (nring 10[*]ArcTan (inj_Q IR (1 / 5118%Z))[+] nring 5[*]ArcTan (inj_Q IR (1 / 6072%Z)))). csetoid_replace ((nring 17)[*]ArcTan (inj_Q IR (1 / 23%Z))) (ArcTan (inj_Q IR y0)); [|apply (reflect_right (ArcTan_multiple H0 17)); vm_compute; constructor]. csetoid_replace ((nring 8)[*]ArcTan (inj_Q IR (1 / 182%Z))) (ArcTan (inj_Q IR y1)); [|apply (reflect_right (ArcTan_multiple H1 8)); vm_compute; constructor]. csetoid_replace ((nring 10)[*]ArcTan (inj_Q IR (1 / 5118%Z))) (ArcTan (inj_Q IR y2)); [|apply (reflect_right (ArcTan_multiple H2 10)); vm_compute; constructor]. csetoid_replace ((nring 5)[*]ArcTan (inj_Q IR (1 / 6072%Z))) (ArcTan (inj_Q IR y3)); [|apply (reflect_right (ArcTan_multiple H3 5)); vm_compute; constructor]. vm_compute in y0. vm_compute in y1. vm_compute in y2. vm_compute in y3. csetoid_replace (ArcTan (inj_Q IR y0)[+]ArcTan (inj_Q IR y1)) (ArcTan (inj_Q IR (f y0 y1))); [|apply ArcTan_plus_ArcTan_Q; try split; vm_compute; discriminate]. csetoid_replace (ArcTan (inj_Q IR y2)[+]ArcTan (inj_Q IR y3)) (ArcTan (inj_Q IR (f y2 y3))); [|apply ArcTan_plus_ArcTan_Q; try split; vm_compute; discriminate]. set (z0 := (f y0 y1)). set (z1 := (f y2 y3)). vm_compute in z0. vm_compute in z1. csetoid_replace (ArcTan (inj_Q IR z0)[+]ArcTan (inj_Q IR z1)) (ArcTan (inj_Q IR (f z0 z1))); [|apply ArcTan_plus_ArcTan_Q; try split; vm_compute; discriminate]. set (z3:= (f z0 z1)). vm_compute in z3. eapply eq_transitive;[|apply ArcTan_one]. apply ArcTan_wd. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). Qed. Lemma r_pi_correct : forall r, (r_pi r == IRasCR ((inj_Q IR r)[*]Pi))%CR. Proof. intros r. unfold r_pi. repeat rewrite <- (CRmult_scale). setoid_replace ((68*r)) with ((4*r*17)) by (simpl; ring). setoid_replace (32*r) with (4*r*8) by (simpl; ring). setoid_replace (40*r) with (4*r*10) by (simpl; ring). setoid_replace (20*r) with (4*r*5) by (simpl; ring). repeat rewrite <- CRmult_Qmult. transitivity ('4 * 'r *(' 17 * rational_arctan_small (widen_interval small_per_23) + ' 8 * rational_arctan_small (widen_interval small_per_182) + (' 10 * rational_arctan_small (widen_interval small_per_5118) + ' 5 * rational_arctan_small (widen_interval small_per_6072))))%CR. ring. repeat rewrite rational_arctan_small_correct. repeat rewrite <- IR_inj_Q_as_CR. repeat (rewrite <- IR_mult_as_CR || rewrite <- IR_plus_as_CR). apply IRasCR_wd. rstepr (Four[*]inj_Q IR r[*]Pi[/]FourNZ). apply mult_wd. apply mult_wdl. apply (inj_Q_nring IR 4). eapply eq_transitive;[|apply Pi_Formula]. rstepr (nring 17[*]ArcTan (inj_Q IR (1 / 23%Z))[+] nring 8[*]ArcTan (inj_Q IR (1 / 182%Z))[+] (nring 10[*]ArcTan (inj_Q IR (1 / 5118%Z))[+] nring 5[*]ArcTan (inj_Q IR (1 / 6072%Z)))). repeat apply bin_op_wd_unfolded; try apply eq_reflexive. apply (inj_Q_nring IR 17). apply (inj_Q_nring IR 8). apply (inj_Q_nring IR 10). apply (inj_Q_nring IR 5). Qed. Definition CRpi : CR := (r_pi 1). Lemma CRpi_correct : (IRasCR Pi == CRpi)%CR. Proof. unfold CRpi. rewrite -> r_pi_correct. apply IRasCR_wd. rstepl ((nring 1)[*]Pi). apply mult_wdl. apply eq_symmetric. apply (inj_Q_nring IR 1). Qed. End Pi. (* begin hide *) #[global] Hint Rewrite CRpi_correct : IRtoCR. (* end hide *) corn-8.20.0/reals/fast/CRpower.v000066400000000000000000000536431473720167500164040ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.ProductMetric. Require Import CoRN.reals.fast.CRArith. From Coq Require Import Qpower. From Coq Require Import Qabs. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. Require Import MathClasses.interfaces.canonical_names. Require Import MathClasses.interfaces.additional_operations. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Local Open Scope Q_scope. Local Open Scope uc_scope. (** ** Natural Integer Powers Positive integer powers is faster than repeated multiplication. It is uniformly continuous on an interval [[-c,c]]. *) (* We first define repeated multiplication to prove correctness. *) Fixpoint CRpower_slow (x : CR) (n : nat) { struct n } := match n with | O => 1%CR | S p => (x * CRpower_slow x p)%CR end. Lemma CRpower_slow_wd : forall (x y : CR) (n : nat), msp_eq x y -> msp_eq (CRpower_slow x n) (CRpower_slow y n). Proof. induction n. - intros. reflexivity. - intros. simpl (CRpower_slow x (S n)). rewrite (IHn H). rewrite H. reflexivity. Qed. Lemma Qpower_positive_abs_le : forall (q:Q) (c : Qpos) (n : positive), Qabs q <= `c -> Qabs (Qpower_positive q n) <= Qpower_positive (` c) n. Proof. intros q c. induction n. - intros. simpl (Qpower_positive q n~1). rewrite Qabs_Qmult. simpl (Qpower_positive (` c) n~1). apply (Qle_trans _ (`c * Qabs (Qpower_positive q n * Qpower_positive q n))). apply Qmult_le_compat_r. exact H. apply Qabs_nonneg. apply Qmult_le_l. apply Qpos_ispos. rewrite Qabs_Qmult. apply (Qle_trans _ (Qpower_positive (`c) n * Qabs (Qpower_positive q n))). apply Qmult_le_compat_r. apply IHn. exact H. apply Qabs_nonneg. rewrite Qmult_comm. apply Qmult_le_compat_r. apply IHn. exact H. apply Qpower_pos_positive, Qpos_nonneg. - intros. simpl (Qpower_positive q n~0). rewrite Qabs_Qmult. simpl. apply (Qle_trans _ (Qpower_positive (`c) n * Qabs (Qpower_positive q n))). apply Qmult_le_compat_r. apply IHn. exact H. apply Qabs_nonneg. rewrite Qmult_comm. apply Qmult_le_compat_r. apply IHn. exact H. apply Qpower_pos_positive, Qpos_nonneg. - intros. exact H. Qed. (* The derivative of fun z => z^p is fun z => p * z^(p-1) which is bounded by p*c^(p-1) on [-c,c]. *) Lemma Qdiff_power : forall (n : nat) (x y : Q) (c : Qpos), (-`c <= x <= `c) -> (-`c <= y <= `c) -> Qabs (x^Z.of_nat n - y^Z.of_nat n) <= Qabs(x-y) * (Z.of_nat n#1) * (`c) ^ (Z.pred (Z.of_nat n)). Proof. induction n. - intros. apply Qmult_le_0_compat. apply Qmult_le_0_compat. apply Qabs_nonneg. discriminate. apply (Qpos_nonneg (Qpos_power c (Z.pred (Z.of_nat 0)))). - intros. change (S n) with (1 + n)%nat. rewrite Nat2Z.inj_add, Qpower_plus', Qpower_plus'. simpl (x ^ Z.of_nat 1). simpl (y ^ Z.of_nat 1). setoid_replace (x * x ^ Z.of_nat n - y * y ^ Z.of_nat n)%Q with ((x-y)*x ^ Z.of_nat n + y * (x ^ Z.of_nat n - y ^ Z.of_nat n))%Q by (unfold equiv, stdlib_rationals.Q_eq; ring). apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite Qabs_Qmult, Qabs_Qmult. apply (Qle_trans _ (Qabs (x-y) * (`c) ^ Z.of_nat n + Qabs (x - y) * (Z.of_nat n # 1) * ` c ^ Z.pred (Z.of_nat n) * Qabs y)). apply Qplus_le_compat. + rewrite Qmult_comm, (Qmult_comm (Qabs (x-y))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. destruct n. apply Qle_refl. apply Qpower_positive_abs_le. apply AbsSmall_Qabs, H. + rewrite Qmult_comm. apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply IHn. exact H. exact H0. + clear IHn. rewrite <- Qmult_assoc, <- Qmult_assoc, <- Qmult_plus_distr_r. rewrite Qmult_comm, <- Qmult_assoc, (Qmult_comm (Qabs (x-y))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. apply (Qle_trans _ (` c ^ Z.of_nat n + (Z.of_nat n # 1) * (` c ^ (Z.of_nat n)))). apply Qplus_le_r. rewrite Qmult_comm, (Qmult_comm (Z.of_nat n # 1)). apply Qmult_le_compat_r. apply (Qle_trans _ (`c ^ Z.of_nat 1 * ` c ^ Z.pred (Z.of_nat n))). rewrite Qmult_comm. apply Qmult_le_compat_r. simpl. apply AbsSmall_Qabs. exact H0. apply Qpower_pos. apply Qpos_nonneg. rewrite <- Qpower_plus. 2: apply Qpos_nonzero. replace (Z.of_nat 1 + Z.pred (Z.of_nat n))%Z with (Z.of_nat n). apply Qle_refl. rewrite Z.add_1_l. rewrite Z.succ_pred. reflexivity. unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. rewrite <- (Qmult_1_l (` c ^ Z.of_nat n)) at 1. rewrite <- Qmult_plus_distr_l. setoid_replace (1 + (Z.of_nat n # 1)) with (Z.of_nat 1 + Z.of_nat n#1). rewrite Qmult_comm. rewrite (Qmult_comm (Z.of_nat 1 + Z.of_nat n#1)). apply Qmult_le_compat_r. replace (Z.pred (Z.of_nat 1 + Z.of_nat n)) with (Z.of_nat n). apply Qle_refl. rewrite <- Nat2Z.inj_add. rewrite Nat2Z.inj_succ. rewrite <- Zpred_succ. reflexivity. rewrite <- Nat2Z.inj_add. discriminate. unfold equiv, stdlib_rationals.Q_eq, Qeq, Qplus, Qnum, Qden. simpl (1*1)%Z. rewrite Z.mul_1_r, Z.mul_1_r. simpl (1*1)%positive. rewrite Z.mul_1_r. reflexivity. + rewrite <- Nat2Z.inj_add. discriminate. + rewrite <- Nat2Z.inj_add. discriminate. Qed. Section CRpower_N. Variable n : N. (* Binary integers are faster than unary integers *) (* To compute x^n, we bound x by c and the modulus becomes fun e => e / (n * c^(n-1)) *) Definition Qpower_N_modulus (c:Qpos) (e:Qpos) : QposInf := match n with | N0 => QposInfinity | Npos p => Qpos2QposInf (e* Qpos_inv ((p#1)*Qpos_power c (Z.pred (Zpos p)))) end. Lemma Qpower_N_uc_prf (c:Qpos) : @is_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace (fun x => Qpower (QboundAbs c x) (Z_of_N n)) (Qpower_N_modulus c). Proof. unfold Qpower_N_modulus. destruct n as [|p]. - simpl. intros e x y E. apply ball_refl, Qpos_nonneg. - clear n. intros e x y E. unfold ball_ex in E. simpl (Z.of_N (N.pos p)). apply AbsSmall_Qabs. apply AbsSmall_Qabs in E. assert (-` c <= QboundAbs c x ∧ QboundAbs c x <= ` c). { split. apply Qmax_ub_l. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. } assert (- ` c <= QboundAbs c y ∧ QboundAbs c y <= ` c). { split. apply Qmax_ub_l. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. } pose proof (positive_nat_Z p). rewrite <- H1. apply (Qle_trans _ _ _ (Qdiff_power (Pos.to_nat p) _ _ c H H0)). clear H H0. rewrite <- Qmult_assoc. apply (Qle_trans _ (Qabs (x-y) * ((Z.pos p # 1) * ` c ^ Z.pred (Z.pos p)))). rewrite H1. apply Qmult_le_compat_r. apply QboundAbs_contract. apply (Qpos_nonneg ((p#1) * Qpos_power c (Z.pred (Z.pos p)))). apply (Qle_trans _ (`e * / proj1_sig ((Z.pos p # 1)%Q ↾ eq_refl * Qpos_power c (Z.pred (Z.pos p)))%Qpos * ((Z.pos p # 1) * ` c ^ Z.pred (Z.pos p)))). apply Qmult_le_compat_r. apply E. apply (Qpos_nonneg ((p#1) * Qpos_power c (Z.pred (Z.pos p)))). rewrite Qmult_comm, Qmult_assoc. apply Qle_shift_div_r. apply (Qpos_ispos ((p#1) * Qpos_power c (Z.pred (Z.pos p)))). rewrite Qmult_comm. apply Qle_refl. Qed. Definition Qpower_N_uc (c:Qpos) : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction (Qpower_N_uc_prf c). (** CRpower_positive_bounded works on [[-c,c]]. *) Definition CRpower_N_bounded (c:Qpos) : CR --> CR := Cmap QPrelengthSpace (Qpower_N_uc c). End CRpower_N. Lemma Cmap_wd_bounded : forall (Y : MetricSpace) (f g : Q_as_MetricSpace --> Y) (x : CR) (c : Qpos), (forall q:Q, -`c <= q <= `c -> msp_eq (f q) (g q)) -> (- ' (proj1_sig c) <= x /\ x <= ' (proj1_sig c))%CR -> msp_eq (Cmap_fun QPrelengthSpace f x) (Cmap_fun QPrelengthSpace g x). Proof. intros. setoid_replace x with (CRboundAbs c x). 2: symmetry; apply CRboundAbs_Eq; apply H0. pose (fun e => QposInf_min (mu f e) (mu g e)) as mufg. assert (∀ e : Qpos, QposInf_le (mufg e) (mu f e)). { intro e. unfold QposInf_le, mufg. destruct (mu f e). 2: trivial. simpl. destruct (mu g e). 2: apply Qle_refl. apply Qpos_min_lb_l. } pose proof (uc_prf_smaller f mufg H1). clear H1. setoid_replace f with (Build_UniformlyContinuousFunction H2). 2: apply ucEq_equiv; intro q; reflexivity. assert (∀ e : Qpos, QposInf_le (mufg e) (mu g e)). { intro e. unfold QposInf_le, mufg. destruct (mu g e). 2: trivial. simpl. destruct (mu f e). 2: apply Qle_refl. apply Qpos_min_lb_r. } pose proof (uc_prf_smaller g mufg H1). clear H1. setoid_replace g with (Build_UniformlyContinuousFunction H3). 2: apply ucEq_equiv; intro q; reflexivity. intros e1 e2. assert (forall y, eq (QposInf_bind (fun e : Qpos => e) y) y) as elim_bind. { intro y. destruct y; reflexivity. } simpl. rewrite elim_bind, elim_bind. clear elim_bind. assert (forall a, Qmax (- ` c) (Qmin (` c) a) <= ` c). { intro a. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. } rewrite Qplus_0_r. destruct (mufg e1) as [q|] eqn:des. - rewrite H. apply (mu_sum QPrelengthSpace e2 (cons e1 nil) (Build_UniformlyContinuousFunction H3)). simpl. rewrite des. simpl. destruct (mufg e2) eqn:des2. simpl. apply AbsSmall_Qabs. apply (Qle_trans _ (Qabs (approximate x q - approximate x q0))). apply QboundAbs_contract. apply AbsSmall_Qabs. apply (regFun_prf x). simpl. trivial. split. apply Qmax_ub_l. apply H1. - rewrite <- H. apply (mu_sum QPrelengthSpace e2 (cons e1 nil) f). simpl. unfold mufg in des. destruct (mu f e1) as [q|]. exfalso. simpl in des. destruct (mu g e1); inversion des. simpl. trivial. split. apply Qmax_ub_l. apply H1. Qed. Lemma CRpower_N_bounded_step : forall (n:N) (c:Qpos) (x : CR), (forall e, - (proj1_sig c) <= approximate x e) -> (forall e, approximate x e <= proj1_sig c) -> (CRpower_N_bounded (1+n) c x == x * CRpower_N_bounded n c x)%CR. Proof. assert (forall i j : Q, i<=j -> Qmax i j == j)%Q as elim_max. { intros. apply (Qle_max_r i j), H. } assert (forall i j : Q, j<=i -> Qmin i j == j)%Q as elim_min. { intros. apply (Qle_min_r i j), H. } intros. assert (x <= ' ` c)%CR as xupper. { intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply H0. } assert (- ' ` c <= x)%CR as xlower. { intro e. simpl. unfold Cap_raw. simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply H. } destruct n as [|n]. - setoid_replace (CRpower_N_bounded 0 c x) with 1%CR. 2: intros e1 e2; apply Qball_Reflexive; rewrite Qplus_0_r; apply (Qpos_nonneg (e1+e2)). rewrite CRmult_1_r. simpl (1+0)%N. intros e1 e2. simpl. rewrite Qplus_0_r. rewrite elim_min. 2: apply H0. rewrite elim_max. 2: apply H. setoid_replace (` e1 + ` e2)%Q with (` (e1 * Qpos_inv (1 ↾ eq_refl * Qpos_power c 0))%Qpos + ` e2). apply (regFun_prf x). apply Qplus_comp. 2: reflexivity. simpl. change (/ (1*1)) with 1. rewrite Qmult_1_r. reflexivity. - rewrite CRmult_comm. pose (Qpos_max c (Qpos_power c (Z_of_N (N.pos n)))) as b. rewrite <- (CRmult_bounded_mult c). 2: exact xlower. 2: exact xupper. rewrite (CRmult_bounded_weaken c b). 2: exact xlower. 2: exact xupper. 2: apply Qpos_max_ub_l. rewrite (CRmult_uncurry_eq b). unfold CRpower_N_bounded. transitivity (Cmap QPrelengthSpace (uc_compose (Qmult_uncurry b) (uc_compose (together (Qpower_N_uc (N.pos n) c) (uc_id Q_as_MetricSpace)) (diag Q_as_MetricSpace))) x). + apply Cmap_wd_bounded with (c:=c). intros q H1. destruct H1. apply Qball_0. change (Qpower_positive (Qmax (- ` c) (Qmin (` c) q)) (1+n) == Qmax (- ` b) (Qmin (` b) (Qpower_positive (Qmax (- ` c) (Qmin (` c) q)) n)) * Qmax (- ` b) (Qmin (` b) q)). rewrite (elim_min _ q). 2: exact H2. rewrite (elim_max _ q). 2: exact H1. 2: exact (conj xlower xupper). rewrite (elim_min _ q). rewrite (elim_max _ q). rewrite Qpower_plus_positive. simpl. rewrite Qmult_comm. apply Qmult_comp. 2: reflexivity. assert (Qabs q <= `c). { apply AbsSmall_Qabs. split. exact H1. exact H2. } pose proof (Qpower_positive_abs_le q c n H3). clear H3. apply AbsSmall_Qabs in H4. destruct H4. rewrite elim_min, elim_max. reflexivity. apply (Qle_trans _ (-(Qpower_positive (`c) n))). apply Qopp_le_compat. apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))). exact H3. apply (Qle_trans _ (Qpower_positive (`c) n)). exact H4. apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))). apply (Qle_trans _ (-`c)). apply Qopp_le_compat, Qpos_max_ub_l. exact H1. apply (Qle_trans _ (`c)). apply H2. apply Qpos_max_ub_l. + rewrite (fast_MonadLaw2 QPrelengthSpace (ProductMS_prelength QPrelengthSpace QPrelengthSpace)). apply Cmap_wd. apply ucEq_equiv. intro a; reflexivity. intros e1 e2. split. rewrite Qplus_0_r. apply (mu_sum QPrelengthSpace e2 (cons e1 nil) (Qpower_N_uc (N.pos n) c)). apply (@ball_weak_le Q_as_MetricSpace (proj1_sig (Qpos_min (e1 * Qpos_inv ((n # 1) * Qpos_power c (Z.pred (Zpos n)) )) e1 + (e2 * Qpos_inv ((n # 1) * Qpos_power c (Z.pred (Zpos n)) )))%Qpos)). apply Qplus_le_l. apply Qpos_min_lb_l. apply (regFun_prf x). apply (@ball_weak_le Q_as_MetricSpace (proj1_sig (Qpos_min (e1 * Qpos_inv ((n # 1) * Qpos_power c (Z.pred (Zpos n)) )) e1 + e2)%Qpos)). apply Qplus_le_l. rewrite Qplus_0_r. apply Qpos_min_lb_r. apply (regFun_prf x). + intro e. simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply (Qle_trans _ (-Qpower_positive (` c) n)). apply Qopp_le_compat. apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))). assert (forall i j :Q, -j <= i -> -i <= j). { intros. rewrite <- (Qopp_involutive j). apply Qopp_le_compat, H1. } apply H1. clear H1. apply (Qle_trans _ _ _ (Qle_Qabs _)). rewrite Qabs_opp. apply (Qpower_positive_abs_le (Qmax (- ` c) (Qmin (` c) (approximate x ((1 # 2) * e * Qpos_inv ((n # 1) * Qpos_power c (Z.pred (Zpos n)) ))%Qpos))) c n). apply AbsSmall_Qabs. split. apply Qmax_ub_l. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. + intro e. simpl. unfold Cap_raw; simpl. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. rewrite <- Qle_minus_iff. apply (Qle_trans _ _ _ (Qle_Qabs _)). apply (Qle_trans _ (Qpower_positive (` c) n)). apply (Qpower_positive_abs_le (Qmax (- ` c) (Qmin (` c) (approximate x ((1 # 2) * e * Qpos_inv ((n # 1) * Qpos_power c (Z.pred (Zpos n)) ))%Qpos))) c n). apply AbsSmall_Qabs. split. apply Qmax_ub_l. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. apply (Qpos_max_ub_r c (Qpower_positive (` c) n ↾ Qpos_power_ispos c (Z.pos n))). Qed. Lemma CRpower_N_bounded_correct : forall (n:N) (c:Qpos) (x : CR), (- (' (proj1_sig c)) <= x /\ x <= 'proj1_sig c)%CR -> (CRpower_slow x (N.to_nat n) == CRpower_N_bounded n c x)%CR. Proof. assert (∀ (n : nat) (c : Qpos) (x : CR), (forall e, - (proj1_sig c) <= approximate x e) -> (forall e, approximate x e <= proj1_sig c) → msp_eq (CRpower_slow x n) (CRpower_N_bounded (N.of_nat n) c x)). induction n. - intros. intros e1 e2. simpl. apply Qball_Reflexive. rewrite Qplus_0_r. apply (Qpos_nonneg (e1+e2)). - intros. change (S n) with (1+n)%nat. rewrite Nnat.Nat2N.inj_add. change (N.of_nat 1) with 1%N. rewrite CRpower_N_bounded_step. 2: exact H. change (CRpower_slow x (1 + n)) with (x * CRpower_slow x n)%CR. apply CRmult_wd. reflexivity. apply IHn. exact H. exact H0. exact H0. - intros. transitivity (CRpower_N_bounded (N.of_nat (N.to_nat n)) c x). 2: rewrite Nnat.N2Nat.id; reflexivity. transitivity (CRpower_N_bounded (N.of_nat (N.to_nat n)) c (CRboundAbs c x)). transitivity (CRpower_slow (CRboundAbs c x) (N.to_nat n)). apply CRpower_slow_wd. symmetry. apply CRboundAbs_Eq. apply H0. apply H0. apply H. intro e. simpl. apply Qmax_ub_l. intros e. apply Qmax_lub. apply (Qle_trans _ 0). apply (Qopp_le_compat 0), Qpos_nonneg. apply Qpos_nonneg. apply Qmin_lb_l. apply Cmap_wd. apply ucEq_equiv; intro a; reflexivity. apply CRboundAbs_Eq. apply H0. apply H0. Qed. Lemma CRpower_N_bounded_weaken : forall (n:N) (c1 c2:Qpos) x, ((- (' (proj1_sig c1)) <= x /\ x <= 'proj1_sig c1) -> (proj1_sig c1 <= proj1_sig c2)%Q -> CRpower_N_bounded n c1 x == CRpower_N_bounded n c2 x)%CR. Proof. intros n c1 c2 x Hx Hc. simpl in x. rewrite <- CRpower_N_bounded_correct. rewrite <- CRpower_N_bounded_correct. reflexivity. 2: exact Hx. destruct Hx. split. - apply (@CRle_trans _ (-'(proj1_sig c1))%CR). apply CRopp_le_compat, CRle_Qle, Hc. exact H. - apply (CRle_trans H0). apply CRle_Qle, Hc. Qed. (** [CRpower_positive_bounded] is should be used when a known bound on the absolute value of x is available. *) #[global] Instance CRpower_N: Pow CR N := λ x n, ucFun (CRpower_N_bounded n (CR_b (1#1) x)) x. Arguments CRpower_N x%type n%N. Lemma CRpower_N_bounded_N_power : forall (n : N) (c:Qpos) (x:CR), ((- (' (proj1_sig c)) <= x /\ x <= 'proj1_sig c) -> CRpower_N_bounded n c x == CRpower_N x n)%CR. Proof. intros n c x Hc. assert (- ('proj1_sig (CR_b (1#1) x)) <= x /\ x <= ('proj1_sig (CR_b (1#1) x)))%CR as Hx. { split. rewrite -> CRopp_Qopp. apply CR_b_lowerBound. apply CR_b_upperBound. } unfold CRpower_N. generalize (CR_b (1#1) x) Hx. clear Hx. intros d Hd. destruct (Qlt_le_dec (proj1_sig c) (proj1_sig d)). apply CRpower_N_bounded_weaken. exact Hc. apply Qlt_le_weak, q. symmetry. apply CRpower_N_bounded_weaken; assumption. Qed. Lemma CRpower_N_correct : forall (n:N) x, (CRpower_slow x (N.to_nat n) == CRpower_N x n)%CR. Proof. intros n x. rewrite <- (CRpower_N_bounded_N_power n (CR_b (1#1) x)). apply CRpower_N_bounded_correct. split. apply (CR_b_lowerBound (1#1) x). apply CR_b_upperBound. split. apply (CR_b_lowerBound (1#1) x). apply CR_b_upperBound. Qed. Lemma CRpower_N_correct' : forall (n:nat) x, (CRpower_slow x n == CRpower_N x (N_of_nat n))%CR. Proof. intros n x. etransitivity; [| apply CRpower_N_correct]. now rewrite Nnat.nat_of_N_of_nat. Qed. #[global] Hint Rewrite CRpower_N_correct' : IRtoCR. #[global] Instance: Proper (eq ==> QposEq ==> @msp_eq _) Qpower_N_uc. Proof. intros p1 p2 Ep e1 e2 Ee. apply ucEq_equiv. intro x. apply ball_closed. intros e epos. simpl. unfold QposEq in Ee. rewrite Ep, Ee. apply Qball_Reflexive. rewrite Qplus_0_l. apply Qlt_le_weak, epos. Qed. #[global] Instance: Proper (eq ==> QposEq ==> @msp_eq _) CRpower_N_bounded. Proof. intros p1 p2 Ep e1 e2 Ee. apply ucEq_equiv. intro x. simpl. rewrite Ep, Ee. reflexivity. Qed. #[global] Instance: Proper (@msp_eq _ ==> eq ==> @msp_eq _) CRpower_N. Proof. intros x1 x2 Hx ? n Hn. subst. transitivity (CRpower_N_bounded n (CR_b (1 # 1) x1) x2). change (ucFun (CRpower_N_bounded n (CR_b (1#1) x1)) x1==ucFun (CRpower_N_bounded n (CR_b (1#1) x1)) x2)%CR. apply uc_wd; assumption. apply CRpower_N_bounded_N_power. split; rewrite <- Hx. rewrite -> CRopp_Qopp. apply CR_b_lowerBound. apply CR_b_upperBound. Qed. (* end hide *) #[global] Instance: NatPowSpec CR N _. Proof. split; unfold pow. apply _. intros x. change (cast Q CR 1 = CR1). now apply rings.preserves_1. intros x n. rewrite <- CRpower_N_correct. rewrite Nnat.nat_of_Nplus. simpl. rewrite CRpower_N_correct. reflexivity. Qed. corn-8.20.0/reals/fast/CRroot.v000066400000000000000000001231541473720167500162260ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.reals.Q_in_CReals. Require Import CoRN.reals.fast.CRpower. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.reals.NRootIR. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.model.metric2.Qmetric. From Coq Require Import Qpower. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.reals.fast.Compress. Require Import CoRN.reals.fast.PowerBound. Require Import CoRN.transc.RealPowers. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.tactics.Qauto. Require Import CoRN.tactics.CornTac. Require Import MathClasses.interfaces.abstract_algebra. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Local Open Scope Q_scope. Opaque CR. Opaque Qmin Qmax. (** ** Square Root Square root is implement using Newton's method. *) Section SquareRoot. Variable a : Q. Hypothesis Ha : 1 <= a <= 4. (** Square root is first defined on [[1,4]]. Iterating this formula will converge to the square root of [a]. *) Definition root_step (b:Q) : Q := b / (2#1) + a / ((2#1) * b). Definition root_has_error (e:Qpos) (b:Q) := a <= (b+proj1_sig e)^2 /\ (b-proj1_sig e)^2 <= a. (* begin hide *) Add Morphism root_has_error with signature QposEq ==> Qeq ==> iff as root_has_error_wd. Proof. intros x1 x2 Hx y1 y2 Hy. unfold root_has_error. rewrite -> Hy. unfold QposEq in Hx. rewrite -> Hx. reflexivity. Qed. (* end hide *) Lemma root_has_error_le : forall (e1 e2:Qpos) (b:Q), proj1_sig e2 <= b -> proj1_sig e1 <= proj1_sig e2 -> root_has_error e1 b -> root_has_error e2 b. Proof. intros e1 e2 b Hb He [H0 H1]. rewrite -> Qle_minus_iff in *. split; rewrite -> Qle_minus_iff. replace RHS with (((b + proj1_sig e1) ^ 2 + - a) + (proj1_sig e2 + - proj1_sig e1)*((2#1) * (b + - proj1_sig e2 + proj1_sig e2) + proj1_sig e2 + proj1_sig e1)) by ring. Qauto_nonneg. replace RHS with ((a + - (b-proj1_sig e1)^2) + (proj1_sig e2 + -proj1_sig e1)*((proj1_sig e2 + - proj1_sig e1) + (2#1) * (b + - proj1_sig e2))) by ring. Qauto_nonneg. Qed. Lemma root_error_bnd : forall (e:Qpos) b, proj1_sig e <= 1 -> 1 <= b -> (root_has_error e b) -> b <= (2#1) + proj1_sig e. Proof. intros e b He Hb [H0 H1]. destruct Ha as [Ha0 Ha1]. rewrite -> Qle_minus_iff in *. assert (X:0 < 2 + b - proj1_sig e). apply Qlt_le_trans with 2. constructor. rewrite -> Qle_minus_iff. replace RHS with ((b + -(1)) + (1 + - proj1_sig e)) by (simpl; ring). Qauto_nonneg. replace RHS with ((((4#1) + - a) + (a + - (b - proj1_sig e)^2))/((2#1) + b - proj1_sig e)) by simpl; field; auto with *. apply Qle_shift_div_l. assumption. replace LHS with 0 by simpl; ring. Qauto_nonneg. Qed. Lemma root_has_error_ball : forall (e1 e2:Qpos) (b1 b2:Q), (proj1_sig e1 + proj1_sig e2<=1) -> (1 <= b1) -> (1 <= b2) -> root_has_error e1 b1 -> Qball (proj1_sig e2) b1 b2 -> root_has_error (e1+e2) b2. Proof. intros e1 e2 b1 b2 He Hb1 Hb2 [H0 H1] [H2 H3]. simpl in H2, H3. clear Ha. rewrite -> Qle_minus_iff in *. unfold root_has_error. autorewrite with QposElim. split; rewrite -> Qle_minus_iff. replace RHS with (((b1 + proj1_sig e1)^2 + - a) + (b2 + - (1) + proj1_sig e1 + proj1_sig e2 + (b1 + -(1)) + (2#1) + proj1_sig e1)*(proj1_sig e2 - (b1 - b2))) by simpl; ring. Qauto_nonneg. replace RHS with ((a + - (b1 - proj1_sig e1)^2) + (b1 - b2 + - - proj1_sig e2)*((b1 + -(1)) + (1 + - (proj1_sig e1 + proj1_sig e2)) + proj1_sig e2 + (b2 + -(1)) + (1 + - (proj1_sig e1 + proj1_sig e2)))) by simpl; ring. Qauto_nonneg. Qed. Lemma ball_root_has_error : forall (e1 e2:Qpos) (b1 b2:Q), ((proj1_sig e1 + proj1_sig e2)<=1) -> (1<=b1) -> (1<=b2) -> root_has_error e1 b1 -> root_has_error e2 b2 -> Qball (proj1_sig e1+proj1_sig e2) b1 b2. Proof. intros e1 e2 b1 b2 He Hb1 Hb2 [H0 H1] [H2 H3]. clear Ha. rewrite -> Qle_minus_iff in *. split; simpl; rewrite -> Qle_minus_iff. assert (A0:0 < (b1 + proj1_sig e1 + b2 - proj1_sig e2)). apply Qlt_le_trans with 1;[constructor|]. rewrite -> Qle_minus_iff. replace RHS with (b1 + - (1) + (b2 + - (1)) + (2#1) * proj1_sig e1 + (1 - (proj1_sig e1 + proj1_sig e2))) by simpl; ring. Qauto_nonneg. replace RHS with ((((b1 + proj1_sig e1)^2 + - a) + (a + - (b2 - proj1_sig e2)^2))/(b1 + proj1_sig e1 +b2 - proj1_sig e2)) by (simpl; field; auto with * ). Qauto_nonneg. assert (A0:0 < (b2 + proj1_sig e2 + b1 - proj1_sig e1)). apply Qlt_le_trans with 1;[constructor|]. rewrite -> Qle_minus_iff. replace RHS with (b2 + - (1) + (b1 + - (1)) + (2#1) * proj1_sig e2 + (1 - (proj1_sig e1 + proj1_sig e2))) by simpl; ring. Qauto_nonneg. replace RHS with (((a + -(b1 - proj1_sig e1)^2) + ((b2 + proj1_sig e2)^2 + - a))/(b2 + proj1_sig e2 + b1 - proj1_sig e1)) by (simpl; field;auto with * ). Qauto_nonneg. Qed. Lemma root_step_error : forall b (e:Qpos), (1 <= b) -> (proj1_sig e <= 1) -> root_has_error e b -> root_has_error ((1#2)*(e*e)) (root_step b). Proof. intros b e Hb He [H0 H1]. unfold root_step. assert (A0:0 < b). apply Qlt_le_trans with 1; try assumption. Qauto_pos. assert (A1:(0 <= b - proj1_sig e^2)). replace RHS with (b + - proj1_sig e^2) by simpl; ring. rewrite <- Qle_minus_iff. apply Qle_trans with ((1:Q)[^]2); try assumption. replace LHS with ((proj1_sig e)[^]2) by (simpl; ring). apply: (power_resp_leEq);simpl; try assumption. apply Qpos_nonneg. assert (A2:(0 <= a)). eapply Qle_trans;[|apply H1]. replace RHS with ((b-proj1_sig e)[^]2) by (simpl; ring). apply: sqr_nonneg. split. apply Qle_trans with ((b / (2#1) + a / ((2#1) * b))^2); [|Qauto_le]. field_simplify (b / (2#1) + a / ((2#1) * b)); auto with *. rewrite -> Qdiv_power. apply Qle_shift_div_l. Qauto_pos. rewrite -> Qle_minus_iff. replace RHS with ((b^2 - a)[^]2) by (simpl; ring). apply: sqr_nonneg. field_simplify (b / (2#1) + a / ((2#1) * b) - ((1#2)*proj1_sig (e * e)%Qpos)); auto with *. rewrite -> Qdiv_power. apply Qle_shift_div_r. Qauto_pos. replace LHS with ((a + b^2 - b*proj1_sig e^2)^2) by simpl; ring. apply Qle_trans with ((a + b^2 - proj1_sig e^2)^2). replace RHS with ((a + b ^ 2 - proj1_sig e ^ 2)[^]2) by (simpl; ring). replace LHS with ((a + b ^ 2 - b * proj1_sig e ^ 2)[^]2) by (simpl; ring). apply: (power_resp_leEq). replace RHS with (a + b*(b-proj1_sig e^2)) by simpl; ring. Qauto_nonneg. rewrite -> Qle_minus_iff;ring_simplify. replace RHS with ((b-1)*((proj1_sig e)[^]2)) by (simpl; ring). rewrite -> Qle_minus_iff in Hb. Qauto_nonneg. rewrite -> Qle_minus_iff. replace RHS with ((a-(b-proj1_sig e)^2)*((b+proj1_sig e)^2-a)) by simpl; ring. rewrite -> Qle_minus_iff in *|-. apply: mult_resp_nonneg; assumption. Qed. (** Our initial estimate is (a+1)/2 with an error of 1/2 *) Definition initial_root :Q := ((1#2)*(a+1)). Lemma initial_root_error : root_has_error (1#2) initial_root. Proof. destruct Ha as [Ha0 Ha1]. unfold initial_root, root_has_error. simpl. split. Qauto_le. rewrite -> Qle_minus_iff. assert (A0:(0<=1 + -((1#4)*a))). rewrite <- Qle_minus_iff. replace LHS with (a/(4#1)) by (simpl; field; discriminate). apply Qle_shift_div_r; try assumption. Qauto_pos. rewrite -> Qle_minus_iff in Ha0. replace RHS with ((a + -(1) + 1)*(1 +- ((1#4)*a))) by simpl; ring. Qauto_nonneg. Qed. Lemma root_step_one_le : forall b, (1 <= b)-> (1 <= root_step b). Proof. intros b Hb. assert (A0:0 Qle_minus_iff in *. field_simplify (b / (2#1) + a / ((2#1) * b) + -(1));auto with *. apply Qle_shift_div_l. Qauto_pos. ring_simplify. replace RHS with (((b -1) ^ 2 + (a + -(1)))) by simpl; ring. Qauto_nonneg. Qed. Lemma initial_root_one_le : (1 <= initial_root). Proof. destruct Ha as [Ha0 Ha1]. unfold initial_root. rewrite -> Qle_minus_iff in *. replace RHS with ((1#2)*(a + - (1))) by simpl; ring. Qauto_nonneg. Qed. (** Each step squares the error *) Fixpoint root_loop (e:Qpos) (n:nat) (b:Q) (err:positive) {struct n} : Q := match n with | O => b | S n' => match Qlt_le_dec_fast (proj1_sig e) (1#err) with | left _ => let err':= (err*err)%positive in root_loop e n' (approximateQ (root_step b) (2*err')) err' | right _ => b end end. Opaque root_step. Lemma root_loop_one_le : forall e n b err, (1 <= b)-> (1 <= root_loop e n b err). Proof. intros e n. induction n; auto with *. simpl. intros b err Hb. destruct (Qlt_le_dec_fast (proj1_sig e) (1 # err)) as [A|A]; try assumption. apply IHn. apply approximateQ_big. apply root_step_one_le. assumption. Qed. Lemma root_loop_error : forall (e:Qpos) n b err, (1 <= b) -> root_has_error (1#err) b -> (1#(iter_nat n _ (fun x => (x * x)%positive) err))<=proj1_sig e -> root_has_error (Qpos_min (1 # err) e) (root_loop e n b err). Proof. induction n. intros b err Hb0 Hb1 He. simpl in *. setoid_replace (Qpos_min (1 # err) e) with (1#err)%Qpos; try assumption. unfold QposEq. rewrite <- Qpos_le_min_l. assumption. intros b err Hb0 Hb1 He. simpl in *. destruct (Qlt_le_dec_fast (proj1_sig e) (1 # err)) as [A|A]. apply root_has_error_le with (Qpos_min (1#(err*err)) e). apply Qle_trans with 1. apply Qle_trans with (1#err); auto with *. apply Qpos_min_lb_l. apply root_loop_one_le. apply approximateQ_big. apply root_step_one_le; assumption. apply Qpos_min_glb. apply Qle_trans with (1#err*err). apply Qpos_min_lb_l. change (1*err <= err*err)%Z; auto with *. apply Qpos_min_lb_r. apply IHn; try assumption. apply approximateQ_big. apply root_step_one_le; assumption. assert (QposEq (1#err*err) ((1#(2*(err * err)))+(1#(2*(err * err))))). { unfold QposEq. simpl. ring_simplify. constructor. } rewrite H. clear H. apply root_has_error_ball with (root_step b). simpl. ring_simplify. unfold Qmult, Qle; simpl. auto with *. apply root_step_one_le; assumption. apply approximateQ_big. apply root_step_one_le; assumption. apply (root_step_error b (1#err)); try assumption. unfold Qle; simpl; auto with *. apply approximateQ_correct. replace (iter_nat n positive (fun x : positive => (x * x)%positive) (err * err)%positive) with (iter_nat n positive (fun x : positive => (x * x)%positive) err * iter_nat n positive (fun x : positive => (x * x)%positive) err)%positive. assumption. clear - n. induction n; try constructor. simpl in *. rewrite IHn. reflexivity. setoid_replace (Qpos_min (1 # err) e) with (1#err)%Qpos; try assumption. unfold QposEq. rewrite <- Qpos_le_min_l. assumption. Qed. (** Find a bound on the number of iterations we need to take. *) Lemma root_max_steps : forall (n d:positive), (1#(iter_nat (S (Psize d)) _ (fun x => (x * x)%positive) 2%positive))<= proj1_sig (n#d)%Qpos. Proof. intros n d. apply Qle_trans with (1#d). clear - d. unfold Qle; simpl. cut ((d <= iter_nat (S (Psize d)) positive (fun x : positive => (x * x)%positive) 2%positive)%Z/\(4 <= iter_nat (S (Psize d)) positive (fun x : positive => (x * x)%positive) 2%positive)%Z). tauto. induction d; split; try discriminate; destruct IHd as [A B]; set (t:=iter_nat (S (Psize d)) positive (fun x : positive => (x * x)%positive) 2%positive) in *. rewrite Zpos_xI. apply Z.le_trans with (4*d)%Z; auto with *. apply (Zmult_le_compat 4 d t t); auto with *. change (4%Z) with (2*2)%Z. apply (Zmult_le_compat 2 2 t t); auto with *. rewrite Zpos_xO. apply Z.le_trans with (4*d)%Z; auto with *. apply (Zmult_le_compat 4 d t t); auto with *. change (4%Z) with (2*2)%Z. apply (Zmult_le_compat 2 2 t t); auto with *. unfold Qle; simpl. change (1*d <= n*d)%Z. auto with *. Qed. (** Square root on [[1,4]]. *) Definition sqrt_raw (e:QposInf) : Q := match e with | QposInfinity => 1 | Qpos2QposInf e' => root_loop e' (S (Psize (Qden (proj1_sig e')))) initial_root 2 end. Lemma sqrt_regular : is_RegularFunction Qball sqrt_raw. Proof. intros e1 e2. apply ball_weak_le with (proj1_sig (Qpos_min (1#2) e1 + Qpos_min (1#2) e2)%Qpos). - simpl. do 2 rewrite Q_Qpos_min. apply: plus_resp_leEq_both; simpl; auto with *. - apply ball_root_has_error. apply (Qle_trans _ (proj1_sig ((1#2) + (1#2))%Qpos)). 2: simpl; ring_simplify; apply Qle_refl. apply: plus_resp_leEq_both; apply Qpos_min_lb_l. apply root_loop_one_le. apply initial_root_one_le. apply root_loop_one_le. apply initial_root_one_le. apply root_loop_error. apply initial_root_one_le. apply initial_root_error. revert e1. intros [[n d] epos]. destruct n as [|n|n]. inversion epos. 2: inversion epos. apply root_max_steps. apply root_loop_error. apply initial_root_one_le. apply initial_root_error. revert e2. intros [[n d] epos]. destruct n as [|n|n]. inversion epos. 2: inversion epos. apply root_max_steps. Qed. Definition rational_sqrt_mid : CR := Build_RegularFunction sqrt_regular. Lemma rational_sqrt_mid_err : forall (e:Qpos), (proj1_sig e <= 1) -> root_has_error e (approximate rational_sqrt_mid e). Proof. intros e He. change (root_has_error e (sqrt_raw e)). unfold sqrt_raw. eapply root_has_error_le;[| |apply root_loop_error]. eapply Qle_trans;[apply He|]. apply root_loop_one_le; apply initial_root_one_le. apply Qpos_min_lb_r. apply initial_root_one_le. apply initial_root_error. clear. revert e. intros [[n d] epos]. destruct n as [|n|n]. inversion epos. 2: inversion epos. apply root_max_steps. Qed. Lemma rational_sqrt_mid_one_le : forall (e:QposInf), 1 <= (approximate rational_sqrt_mid e). Proof. intros [e|];[|apply Qle_refl]. apply: root_loop_one_le. apply initial_root_one_le. Qed. Lemma rational_sqrt_mid_le_3 : forall (e:QposInf), (approximate rational_sqrt_mid e) <= 3. Proof. intros [e|];[|discriminate]. change (sqrt_raw e <= (3#1)). unfold sqrt_raw. set (n:= (S (Psize (Qden (proj1_sig e))))). assert (root_has_error (Qpos_min (1 # 2) e) (root_loop e n initial_root 2)). apply root_loop_error. apply initial_root_one_le. apply initial_root_error. subst n. clear. revert e. intros [[n d] epos]. destruct n as [|n|n]. inversion epos. 2: inversion epos. apply root_max_steps. eapply Qle_trans. apply root_error_bnd;[| |apply H]. eapply Qle_trans. apply Qpos_min_lb_l. discriminate. apply root_loop_one_le. apply initial_root_one_le. rewrite Q_Qpos_min. simpl. apply (Qle_trans _ (2 + (1#2))). apply Qplus_le_r, Qmin_lb_l. discriminate. Qed. Opaque root_loop. Lemma rational_sqrt_mid_correct0 : (CRpower_N rational_sqrt_mid 2 == ' a)%CR. Proof. assert (H:AbsSmall (R:=CRasCOrdField) (' (3 # 1))%CR rational_sqrt_mid). split; simpl. intros e. change (-proj1_sig e <= sqrt_raw (Qpos2QposInf ((1#2)*e)) + - - (3#1)). apply Qle_trans with 0. rewrite -> Qle_minus_iff. ring_simplify. auto with *. rewrite <- Qle_minus_iff. apply Qle_trans with 1. discriminate. apply rational_sqrt_mid_one_le. intros e. change (-proj1_sig e <= 3 + - sqrt_raw (Qpos2QposInf ((1#2)*e))). apply Qle_trans with 0. rewrite -> Qle_minus_iff. ring_simplify. auto with *. rewrite <- Qle_minus_iff. apply rational_sqrt_mid_le_3. rewrite <- (CRpower_N_bounded_N_power 2 (3#1));[|assumption]. apply regFunEq_equiv, (regFunEq_e_small (X:=Q_as_MetricSpace) (CRpower_N_bounded 2 (3 # 1) rational_sqrt_mid) (' a)%CR (1#1)). intros e. destruct e as [[en ed] epos]. destruct en as [|en|en]. inversion epos. 2: inversion epos. set (e := exist (Qlt 0) (en # ed) epos). intro He. set (d:= (e * Qpos_inv (6#1))%Qpos). simpl (approximate (' a)%CR (Qpos2QposInf ((en # ed) ↾ epos))). change (Qball (proj1_sig e + proj1_sig e) (approximate ((CRpower_N_bounded 2 (3 # 1)) rational_sqrt_mid) (Qpos2QposInf e)) a). assert ( (approximate ((CRpower_N_bounded 2 (3 # 1)) rational_sqrt_mid) (Qpos2QposInf e)) = ((Qmax (- (3#1)) (Qmin (3#1) (approximate rational_sqrt_mid d)))^2) ) as H0. { simpl. replace d with (Qpos_mult e (Qpos_inv ((2 # 1) * (Qpos_power (3 # 1) (2 - 1)%positive)))). reflexivity. subst e d. apply Qpos_hprop. reflexivity. } rewrite H0. clear H0. setoid_replace (Qmin (3#1) (approximate rational_sqrt_mid d)) with ((approximate rational_sqrt_mid d)) by (rewrite <- Qle_min_r;destruct H;apply rational_sqrt_mid_le_3). setoid_replace (Qmax (-3#1) (approximate rational_sqrt_mid d)) with ((approximate rational_sqrt_mid d)) by (rewrite <- Qle_max_r;destruct H;eapply Qle_trans;[|apply rational_sqrt_mid_one_le];discriminate). assert (Z:root_has_error d (approximate rational_sqrt_mid d)). apply rational_sqrt_mid_err. unfold d. autorewrite with QposElim. change ((proj1_sig e/(6#1)) <= 1). apply Qle_shift_div_r. constructor. eapply Qle_trans. apply He. discriminate. set (z:=approximate rational_sqrt_mid d) in *. assert (X:z <= 3). apply rational_sqrt_mid_le_3. assert (X0:proj1_sig d^2 <= proj1_sig e). unfold d. autorewrite with QposElim in *. change ((proj1_sig e*(1#6))^2 <= proj1_sig e). rewrite -> Qle_minus_iff in *. replace RHS with (proj1_sig e*(1 + -proj1_sig e + (35#36)* proj1_sig e)) by simpl; ring. Qauto_nonneg. destruct Z; split; simpl; rewrite -> Qle_minus_iff in *; autorewrite with QposElim in *. replace RHS with (((z+proj1_sig d)^2 + - a) + (2#1) * ((3#1) + -z) * proj1_sig d + (proj1_sig e + - proj1_sig d^2)) by (simpl; unfold d;field;discriminate). Qauto_nonneg. replace RHS with (a + - (z-proj1_sig d)^2 + (2#1) * ((3#1) + - z)*proj1_sig d + proj1_sig d^2 + proj1_sig e) by (simpl; unfold d; autorewrite with QposElim;field;discriminate). Qauto_nonneg. Qed. (* todo: clean up *) Lemma rational_sqrt_mid_correct1 : (0 <= rational_sqrt_mid)%CR. Proof. intros e. apply Qle_trans with 1. Qauto_le. change (1 <= sqrt_raw (Qpos2QposInf ((1#2)%Qpos*e)) - 0). ring_simplify. apply rational_sqrt_mid_one_le. Qed. End SquareRoot. Lemma rational_sqrt_mid_correct_aux (x : Q) (y : CR) Px : CRpower_N y 2 = 'x → 0%CR ≤ y → y = IRasCR (sqrt (inj_Q IR x) Px). Proof. intros f_sqrt f_nonneg. rewrite <- (CRasIRasCR_id y). apply IRasCR_wd. assert (X:[0][<=](CRasIR y)[^]2). { apply sqr_nonneg. } stepl (sqrt _ X). - apply sqrt_wd. rewrite -> IR_eq_as_CR. rewrite -> IR_inj_Q_as_CR. simpl. rewrite <- f_sqrt. rewrite <- (CRpower_N_correct 2). simpl. rewrite IR_mult_as_CR, IR_mult_as_CR. rewrite CRasIRasCR_id. rewrite IR_One_as_CR. ring. - apply sqrt_to_nonneg. rewrite -> IR_leEq_as_CR. rewrite -> IR_Zero_as_CR. now rewrite -> CRasIRasCR_id. Qed. Lemma rational_sqrt_mid_correct a Pa H : (rational_sqrt_mid a Pa == IRasCR (sqrt (inj_Q IR a) H))%CR. Proof. apply rational_sqrt_mid_correct_aux. now apply rational_sqrt_mid_correct0. now apply rational_sqrt_mid_correct1. Qed. (** By scaling the input the range of square root can be extened upto 4^n. *) Fixpoint rational_sqrt_big_bounded (n:nat) a (Ha:1 <= a <= (4 ^ n)%Z) { struct n } : CR. revert a Ha. destruct n as [|n]. intros _ _. exact 1%CR. intros a H. destruct (Qle_total a (4#1)). clear rational_sqrt_big_bounded. refine (@rational_sqrt_mid a _). abstract (destruct H; tauto). refine (scale (2#1) _). refine (@rational_sqrt_big_bounded n (a / (4#1)) _). clear rational_sqrt_big_bounded. abstract ( destruct H; split;[apply Qle_shift_div_l;[constructor|assumption]|]; apply Qle_shift_div_r;[constructor|]; rewrite -> Zpower_Qpower in * by auto with zarith; change (a <= ((4#1) ^ n) * (4#1)^1); rewrite <- Qpower_plus; try discriminate; change (n+1)%Z with (Z.succ n); rewrite <- inj_S; assumption). Defined. Lemma rational_sqrt_big_bounded_correct_aux a Xa4 Xa : ((scale (2#1)) (IRasCR (sqrt (inj_Q IR (a / (4#1))) Xa4)) == IRasCR (sqrt (inj_Q IR a) Xa))%CR. Proof. rewrite <- CRmult_scale. rewrite <- IR_inj_Q_as_CR. rewrite <- IR_mult_as_CR. apply IRasCR_wd. assert (X1:[0][<=](inj_Q IR (4#1))). stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. discriminate. csetoid_replace (inj_Q IR (2#1)) (sqrt _ X1). assert (X2:[0][<=](inj_Q IR (4#1)[*]inj_Q IR (a/4%positive))). apply mult_resp_nonneg;assumption. astepl (sqrt _ X2). apply sqrt_wd. csetoid_rewrite_rev (inj_Q_mult IR (4#1) (a/4%positive)). apply inj_Q_wd. simpl. field; discriminate. change (inj_Q IR (4#1)) with (inj_Q IR ((2#1)[*](2#1))). assert (X2:[0][<=](inj_Q IR (2#1))[^]2). apply sqr_nonneg. stepr (sqrt _ X2). apply eq_symmetric; apply sqrt_to_nonneg. stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. discriminate. apply sqrt_wd. rstepl ((inj_Q IR (2#1))[*](inj_Q IR (2#1))). apply eq_symmetric. apply (inj_Q_mult IR (2#1) (2#1)). Qed. Lemma rational_sqrt_big_bounded_correct : forall n a Ha H, (@rational_sqrt_big_bounded n a Ha == IRasCR (sqrt (inj_Q IR a) H))%CR. Proof. induction n. intros a Ha H. simpl. rewrite <- IR_inj_Q_as_CR. apply IRasCR_wd. assert (X:[0][<=](inj_Q IR 1:IR)[^]2) by apply sqr_nonneg. stepl (sqrt _ X). apply sqrt_wd. rstepl (inj_Q IR 1[*]inj_Q IR 1). stepl (inj_Q IR (1*1)); [| now apply (inj_Q_mult IR)]. apply inj_Q_wd. simpl. rewrite -> Qeq_le_def. assumption. apply sqrt_to_nonneg. stepr (nring 1:IR); [| now (apply eq_symmetric; apply (inj_Q_nring IR 1))]. rstepr ([1]:IR). apply less_leEq; apply pos_one. intros a Ha H. simpl. destruct (Qle_total a). apply rational_sqrt_mid_correct. change (scale 2 (rational_sqrt_big_bounded n (a / 4%positive)(rational_sqrt_big_bounded_subproof0 n a Ha q)) == IRasCR (sqrt (inj_Q IR a) H))%CR. assert (X:[0][<=]inj_Q IR (a/4%positive)). change (a/4%positive) with (a*(1#4)). stepr (inj_Q IR a[*]inj_Q IR (1#4)); [| now apply eq_symmetric; apply (inj_Q_mult IR)]. apply mult_resp_nonneg. assumption. stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. discriminate. set (X0:= (rational_sqrt_big_bounded_subproof0 n a Ha q)). rewrite -> (IHn (a/4%positive) X0 X). apply rational_sqrt_big_bounded_correct_aux. Qed. (** By scaling the other direction we can extend the range down to 4^(-n). *) Fixpoint rational_sqrt_small_bounded (n:nat) a (Ha: / (4^n)%Z <= a <= (4#1)) : CR. revert a Ha. destruct n as [|n]. clear rational_sqrt_small_bounded. refine (@rational_sqrt_mid). intros a H. destruct (Qle_total a 1). refine (scale (1#2) _). refine (@rational_sqrt_small_bounded n ((4#1) * a) _). clear rational_sqrt_small_bounded. abstract ( destruct H; split;[ rewrite -> Zpower_Qpower in *; auto with *; replace (Z_of_nat n) with ((S n) + (-1))%Z by (rewrite inj_S; ring); rewrite -> Qpower_plus; try discriminate; change (4%positive^(-1)) with (/(4#1)); rewrite -> Qinv_mult_distr; change ( / / (4#1)) with (4#1); rewrite -> Qmult_comm |replace RHS with ((4#1)*1) by constructor]; (apply: mult_resp_leEq_lft;simpl;[assumption|discriminate])). clear rational_sqrt_small_bounded. refine (@rational_sqrt_mid a _). abstract (destruct H; tauto). Defined. Lemma rational_sqrt_small_bounded_correct_aux (a:Q) X4a Xa : ((scale (1 # 2)) (IRasCR (sqrt (inj_Q IR ((4#1) * a)%Q) X4a)) == IRasCR (sqrt (inj_Q IR a) Xa))%CR. Proof. rewrite <- CRmult_scale. rewrite <- IR_inj_Q_as_CR. rewrite <- IR_mult_as_CR. apply IRasCR_wd. assert (X1:[0][<=](inj_Q IR (1#4))). stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. discriminate. csetoid_replace (inj_Q IR (1#2)) (sqrt _ X1). assert (X2:[0][<=](inj_Q IR (1#4)[*]inj_Q IR (4%positive*a))). apply mult_resp_nonneg;assumption. astepl (sqrt _ X2). apply sqrt_wd. csetoid_rewrite_rev (inj_Q_mult IR (1#4) (4%positive*a)). apply inj_Q_wd. simpl. field; discriminate. change (inj_Q IR (1#4)) with (inj_Q IR ((1#2)[*](1#2))). assert (X2:[0][<=](inj_Q IR (1#2))[^]2). apply sqr_nonneg. stepr (sqrt _ X2). apply eq_symmetric; apply sqrt_to_nonneg. stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. discriminate. apply sqrt_wd. rstepl ((inj_Q IR (1#2))[*](inj_Q IR (1#2))). apply eq_symmetric. apply (inj_Q_mult IR). Qed. Lemma rational_sqrt_small_bounded_correct : forall n a Ha H, (@rational_sqrt_small_bounded n a Ha == IRasCR (sqrt (inj_Q IR a) H))%CR. Proof. induction n; try apply rational_sqrt_mid_correct. intros a Ha H. simpl. destruct (Qle_total a 1); [| apply rational_sqrt_mid_correct]. change (scale (1#2) (rational_sqrt_small_bounded n (4%positive*a) (rational_sqrt_small_bounded_subproof n a Ha q)) == IRasCR (sqrt (inj_Q IR a) H))%CR. assert (X:[0][<=]inj_Q IR (4%positive*a)). stepr (inj_Q IR (4%positive:Q)[*]inj_Q IR a); [| now apply eq_symmetric; apply (inj_Q_mult IR)]. apply mult_resp_nonneg. stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. discriminate. assumption. set (X0:= (rational_sqrt_small_bounded_subproof n a Ha q)). rewrite -> (IHn (4%positive*a) X0 X). apply rational_sqrt_small_bounded_correct_aux. Qed. (** And hence it is defined for all postive numbers. *) Definition rational_sqrt_pos a (Ha:0 rational_sqrt_pos a H |right _ => 0%CR end. Lemma rational_sqrt_correct : forall a H, (@rational_sqrt a == IRasCR (sqrt (inj_Q IR a) H))%CR. Proof. intros a H. unfold rational_sqrt. destruct (Qlt_le_dec_fast 0 a). apply rational_sqrt_pos_correct. rewrite <- (IR_nring_as_CR 0). apply IRasCR_wd. simpl. assert (X:[0] [<=] ([0][^]2:IR)). rstepr ([0]:IR). apply leEq_reflexive. stepl (sqrt _ X). apply sqrt_wd. rstepl ([0]:IR). apply leEq_imp_eq. assumption. stepr (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_leEq. assumption. apply sqrt_to_nonneg. apply leEq_reflexive. Qed. (** Square root is uniformly continuous everywhere. *) Definition sqrt_modulus (e:Qpos) : QposInf := Qpos2QposInf (e*e). Lemma sqrt_uc_prf : @is_UniformlyContinuousFunction Q_as_MetricSpace CR rational_sqrt sqrt_modulus. Proof. intros e a. cut (forall a b, (0 <= a) -> (0 <= b) -> ball_ex (X:=Q_as_MetricSpace) (sqrt_modulus e) a b -> ball (m:=CR) (proj1_sig e) (rational_sqrt a) (rational_sqrt b)). intros X b Hab. destruct (Qle_total 0 a) as [Ha|Ha]. destruct (Qle_total 0 b) as [Hb|Hb]. apply X; assumption. unfold rational_sqrt at 2. destruct (Qlt_le_dec_fast 0 b) as [Z|_]. elim (Qle_not_lt _ _ Hb Z). change 0%CR with (rational_sqrt 0). apply X; try assumption. apply Qle_refl. destruct Hab. split; simpl in *. rewrite -> Qle_minus_iff in *. replace RHS with ((a + - 0) + proj1_sig (e*e)%Qpos) by simpl; ring. Qauto_nonneg. rewrite -> Qle_minus_iff in *. replace RHS with (proj1_sig (e*e)%Qpos + - (a - b) + (0 + - b)) by simpl; ring. Qauto_nonneg. unfold rational_sqrt at 1. destruct (Qlt_le_dec_fast 0 a) as [Z0|_]. elim (Qle_not_lt _ _ Ha Z0). change 0%CR with (rational_sqrt 0). destruct (Qle_total 0 b) as [Hb|Hb]. apply X; try assumption. apply Qle_refl. destruct Hab. split; simpl in *. rewrite -> Qle_minus_iff in *. replace RHS with ((a - b) + - - proj1_sig (e*e)%Qpos + (0 + - a)) by simpl; ring. Qauto_nonneg. rewrite -> Qle_minus_iff in *. replace RHS with (proj1_sig (e*e)%Qpos + (b + - 0)) by simpl; ring. Qauto_nonneg. unfold rational_sqrt at 2. destruct (Qlt_le_dec_fast 0 b) as [Z0|_]. elim (Qle_not_lt _ _ Hb Z0). change 0%CR with (rational_sqrt 0). apply ball_refl. apply Qpos_nonneg. clear a. intros a b Ha Hb Hab. assert (Z:[0][<=]inj_Q IR a). stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_leEq. assumption. rewrite -> (rational_sqrt_correct _ Z). assert (Z0:[0][<=]inj_Q IR b). stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_leEq. assumption. rewrite -> (rational_sqrt_correct _ Z0). rewrite <- CRAbsSmall_ball. cut (AbsSmall (R:=CRasCOrdField) (IRasCR (inj_Q IR (proj1_sig e)))%CR (IRasCR (sqrt (inj_Q IR a) Z[-](sqrt (inj_Q IR b) Z0)))). intros [A B]. unfold cg_minus. split; (simpl; rewrite <- (IR_inj_Q_as_CR (proj1_sig e)); rewrite <- (IR_opp_as_CR (sqrt _ Z0)); rewrite <- (IR_plus_as_CR); assumption). rewrite <- IR_AbsSmall_as_CR. assert (Z1:AbsSmall (inj_Q IR (proj1_sig e*proj1_sig e)) ((inj_Q IR a)[-](inj_Q IR b))). destruct Hab. split. stepl (inj_Q IR (-(proj1_sig e*proj1_sig e))); [| now apply (inj_Q_inv IR)]. stepr (inj_Q IR (a - b)); [| now apply (inj_Q_minus IR)]. apply inj_Q_leEq. assumption. stepl (inj_Q IR (a - b)); [| now apply (inj_Q_minus IR)]. apply inj_Q_leEq. assumption. clear Hab. set (e':=(inj_Q IR (proj1_sig e))). set (a':=(sqrt (inj_Q IR a) Z)). set (b':=(sqrt (inj_Q IR b) Z0)). assert (He:[0][<]e'). stepl (inj_Q IR 0); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_less. simpl; auto with *. split. refine (mult_cancel_leEq _ _ _ (e'[+]a'[+]b') _ _). rstepl ([0][+][0][+][0]:IR). do 2 (apply plus_resp_less_leEq; try apply sqrt_nonneg). assumption. rstepl (([--](e'[*]e'))[+](e')[*]([--]a'[-]b')). rstepr ((a'[^]2[-]b'[^]2)[+](e')[*](a'[-]b')). apply plus_resp_leEq_both. stepr (inj_Q IR a[-]inj_Q IR b). stepl ([--](inj_Q IR (proj1_sig e*proj1_sig e))). destruct Z1; assumption. unfold e'. csetoid_rewrite_rev (inj_Q_mult IR (proj1_sig e) (proj1_sig e)). apply eq_reflexive. unfold a', b'. unfold cg_minus. csetoid_rewrite (sqrt_sqr (inj_Q IR a) Z). csetoid_rewrite (sqrt_sqr (inj_Q IR b) Z0). apply eq_reflexive. apply mult_resp_leEq_lft;[|apply less_leEq;assumption]. apply minus_resp_leEq. apply shift_leEq_rht. rstepr (Two[*]a'). apply mult_resp_nonneg. apply less_leEq; apply pos_two. apply sqrt_nonneg. refine (mult_cancel_leEq _ _ _ (e'[+]a'[+]b') _ _). rstepl ([0][+][0][+][0]:IR). do 2 (apply plus_resp_less_leEq; try apply sqrt_nonneg). assumption. rstepr (((e'[*]e'))[+](e')[*](a'[+]b')). rstepl ((a'[^]2[-]b'[^]2)[+](e')[*](a'[-]b')). apply plus_resp_leEq_both. stepl (inj_Q IR a[-]inj_Q IR b). stepr (inj_Q IR (proj1_sig e*proj1_sig e)). destruct Z1; assumption. unfold e'. csetoid_rewrite_rev (inj_Q_mult IR (proj1_sig e) (proj1_sig e)). apply eq_reflexive. unfold a', b'. unfold cg_minus. csetoid_rewrite (sqrt_sqr (inj_Q IR a) Z). csetoid_rewrite (sqrt_sqr (inj_Q IR b) Z0). apply eq_reflexive. apply mult_resp_leEq_lft;[|apply less_leEq;assumption]. unfold cg_minus. apply plus_resp_leEq_lft. apply shift_leEq_rht. rstepr (Two[*]b'). apply mult_resp_nonneg. apply less_leEq; apply pos_two. apply sqrt_nonneg. Qed. Local Open Scope uc_scope. Definition sqrt_uc : Q_as_MetricSpace --> CR := Build_UniformlyContinuousFunction sqrt_uc_prf. Definition CRsqrt : CR --> CR := Cbind QPrelengthSpace sqrt_uc. Lemma CRsqrt_correct : forall x H, (IRasCR (sqrt x H) == CRsqrt (IRasCR x))%CR. Proof. intros x H. assert (X:Dom (FNRoot FId 2 (Nat.lt_0_succ 1)) x). simpl; split; auto. transitivity (IRasCR (FNRoot FId 2 (Nat.lt_0_succ 1) x X)). apply IRasCR_wd. apply: NRoot_wd. apply eq_reflexive. apply (ContinuousCorrect (I:proper (closel [0]))); try assumption. apply Continuous_NRoot. Contin. intros; assumption. intros q Hq Y. transitivity (rational_sqrt q);[|apply: rational_sqrt_correct]. unfold CRsqrt. pose proof (Cbind_correct QPrelengthSpace sqrt_uc). apply ucEq_equiv in H0. rewrite (H0 ('q)%CR). apply BindLaw1. Qed. (* begin hide *) #[global] Hint Rewrite CRsqrt_correct : IRtoCR. (* end hide *) Lemma CRsqrt_sqr : forall (x : CR), (0 <= x -> CRsqrt x * CRsqrt x = x)%CR. Proof. intros x xpos. rewrite <- (CRasIRasCR_id x). assert ([0] [<=] CRasIR x). { apply IR_leEq_as_CR. rewrite CRasIRasCR_id, IR_Zero_as_CR. exact xpos. } rewrite <- (CRsqrt_correct (CRasIR x) H). rewrite <- IR_mult_as_CR. apply IRasCR_wd. setoid_replace (sqrt (CRasIR x) H [*] sqrt (CRasIR x) H) with (sqrt (CRasIR x) H [^] 2). exact (sqrt_sqr (CRasIR x) H). simpl. destruct (cr_proof IR), ax_mult_mon. rewrite lunit. reflexivity. Qed. Lemma CRsquare_nonneg_cancel : forall x y : CR, (0 <= x)%CR -> (0 <= y)%CR -> msp_eq (x*x)%CR (y*y)%CR -> msp_eq x y. Proof. intros. assert (msp_eq ((x-y)*(x+y))%CR 0%CR). { rewrite (CRplus_eq_l (y*y)%CR). ring_simplify. exact H1. } apply ball_stable. intro abs. apply CRmult_eq_0_reg_l in H2. contradict abs. rewrite (CRplus_eq_l (-y)%CR x y). rewrite CRplus_opp. exact H2. intro H3. assert (msp_eq x 0%CR). { apply CRle_antisym. split. 2: exact H. rewrite <- CRplus_0_r. apply (@CRle_trans _ (x+y)%CR). apply CRplus_le_l. exact H0. rewrite H3. apply CRle_refl. } rewrite H4, CRplus_0_l in H3. contradict abs. rewrite H3, H4. reflexivity. Qed. Lemma root_loop_nonneg : forall (n:nat) q (e:Qpos) (b:Q) (err:positive), 0 <= b -> 0 <= q -> 0 <= root_loop q e n b err. Proof. induction n. - intros. exact H. - intros. simpl. destruct (Qlt_le_dec_fast (`e) (1#err)). 2: exact H. apply IHn. 2: exact H0. destruct b as [b a]. unfold Qle in H; simpl in H. rewrite Z.mul_1_r in H. destruct q as [q c]. unfold Qle in H0; simpl in H0. rewrite Z.mul_1_r in H0. unfold Qle, Qnum, Qden. rewrite Z.mul_0_l, Z.mul_1_r. rewrite Z.mul_1_r. apply Z_div_pos. reflexivity. apply Z.mul_nonneg_nonneg. 2: discriminate. apply Z.add_nonneg_nonneg. apply Z.mul_nonneg_nonneg. apply H. discriminate. apply Z.mul_nonneg_nonneg. apply Z.mul_nonneg_nonneg. exact H0. 2: discriminate. unfold Qinv, Qmult. simpl. destruct b. discriminate. discriminate. exfalso. apply (Zle_not_lt _ _ H). reflexivity. Qed. Lemma sqrt_raw_nonneg : forall a e, 0 <= a -> 0 <= sqrt_raw a e. Proof. intros. destruct e. 2: discriminate. simpl. destruct (Qlt_le_dec_fast (`q) (1#2)). apply root_loop_nonneg. rewrite Z.mul_1_r, Z.mul_1_r. destruct a as [a b]; simpl. destruct a. - simpl. unfold Qle; simpl. rewrite Z.mul_1_r. apply Z.div_pos. discriminate. reflexivity. - simpl. unfold Qle, Qnum, Qden. rewrite Z.mul_0_l, Z.mul_1_r. apply Z.div_pos. 2: reflexivity. discriminate. - exfalso. unfold Qle in H; simpl in H. apply (Zle_not_lt _ _ H). reflexivity. - exact H. - unfold initial_root. apply Qmult_le_0_compat. discriminate. apply (Qle_trans _ (0+1)). discriminate. apply Qplus_le_l, H. Qed. Lemma rational_sqrt_big_bounded_nonneg : forall n (a:Q) Ha e, 0 <= approximate (rational_sqrt_big_bounded n a Ha) e. Proof. induction n. - intros. discriminate. - intros. simpl. destruct (Qle_total a (4#1)). + simpl. apply (sqrt_raw_nonneg a e). destruct Ha. apply (Qle_trans _ 1). discriminate. exact H. + unfold Cmap_fun; simpl. rewrite <- (Qmult_0_r (2#1)). apply Qmult_le_l. reflexivity. apply IHn. Qed. Lemma rational_sqrt_small_bounded_nonneg : forall (n:nat) a (Ha: / (4^n)%Z <= a <= (4#1)) e, 0 <= approximate (rational_sqrt_small_bounded n a Ha) e. Proof. induction n. - intros. simpl. apply sqrt_raw_nonneg. destruct Ha. unfold Qinv in H. simpl in H. apply (Qle_trans _ 1). discriminate. exact H. - intros. simpl. destruct (Qle_total a 1). simpl. apply Qmult_le_0_compat. discriminate. apply IHn. simpl. apply sqrt_raw_nonneg. apply (Qle_trans _ 1). discriminate. exact q. Qed. Lemma rational_sqrt_nonneg : forall (q : Q) (e : Qpos), 0 <= approximate (rational_sqrt q) e. Proof. intros. unfold rational_sqrt. destruct (Qlt_le_dec_fast 0 q). 2: apply Qle_refl. unfold rational_sqrt_pos. destruct (Qle_total 1 q). apply rational_sqrt_big_bounded_nonneg. apply rational_sqrt_small_bounded_nonneg. Qed. Lemma CRsqrt_pos : forall x : CR, (0 <= x -> 0 <= CRsqrt x)%CR. Proof. (* This cannot be proved algebraically, because there is also a negative solution y to the equation y^2 = x. *) intros x H e1. simpl. unfold Cap_raw; simpl. unfold Cjoin_raw; simpl. rewrite Qplus_0_r. apply (Qle_trans _ 0). apply (Qopp_le_compat 0 (`e1)). apply Qpos_nonneg. apply rational_sqrt_nonneg. Qed. Lemma CRsqrt_mult : forall x y, (0 <= x -> 0 <= y -> CRsqrt (x*y) = CRsqrt x * CRsqrt y)%CR. Proof. intros x y xpos ypos. apply (CRsquare_nonneg_cancel (CRsqrt (x*y)%CR) (CRsqrt x * CRsqrt y)%CR (CRsqrt_pos _ (CRmult_le_0_compat _ _ xpos ypos))). apply CRmult_le_0_compat; apply CRsqrt_pos; assumption. rewrite CRsqrt_sqr. 2: exact (CRmult_le_0_compat _ _ xpos ypos). transitivity (CRsqrt x * CRsqrt x * (CRsqrt y * CRsqrt y))%CR. 2: ring. rewrite CRsqrt_sqr, CRsqrt_sqr. reflexivity. exact ypos. exact xpos. Qed. Lemma CRsqrt_inc : forall x y : CR, (0 <= x -> x <= y -> CRsqrt x <= CRsqrt y)%CR. Proof. (* Prove that 0 <= ARsqrt y - ARsqrt x, ie that 0 <= (ARsqrt y - ARsqrt x) * (ARsqrt y + ARsqrt x) *) intros. apply (CRplus_le_r _ _ (-CRsqrt x)%CR). rewrite CRplus_opp. apply CRle_not_lt. intro abs. assert ((0 < y)%CR -> False). { intro ypos. revert abs. apply CRle_not_lt. apply (CRmult_le_0_reg_l (CRsqrt x + CRsqrt y)%CR). - intro abs. apply CRle_not_lt in abs. assert (msp_eq 0%CR (CRsqrt y)). apply CRle_antisym. split. apply CRsqrt_pos. apply CRlt_le_weak, ypos. rewrite <- CRplus_0_l. refine (CRle_trans _ abs). apply CRplus_le_r, CRsqrt_pos, H. pose proof (CRmult_wd H1 H1) as H3. rewrite CRmult_0_r, CRsqrt_sqr in H3. apply CRle_antisym in H3. revert ypos. apply CRle_not_lt, H3. apply CRlt_le_weak, ypos. - setoid_replace ((CRsqrt x + CRsqrt y) * (CRsqrt y + (- CRsqrt x)))%CR with (CRsqrt y*CRsqrt y - (CRsqrt x*CRsqrt x))%CR by ring. rewrite (CRsqrt_sqr y). rewrite (CRsqrt_sqr x). rewrite <- (CRplus_opp x). apply CRplus_le_r, H0. exact H. exact (CRle_trans H H0). } apply CRle_not_lt in H1. revert abs. apply CRle_not_lt. setoid_replace x with 0%CR. setoid_replace y with 0%CR. rewrite CRplus_opp. apply CRle_refl. apply CRle_antisym. split. exact H1. exact (CRle_trans H H0). apply CRle_antisym. split. exact (CRle_trans H0 H1). exact H. Qed. Lemma CRsqrt_Qsqrt : forall x : Q, (CRsqrt ('x) == rational_sqrt x)%CR. Proof. intros x. unfold CRsqrt. pose proof (Cbind_correct QPrelengthSpace sqrt_uc). apply ucEq_equiv in H. rewrite (H ('x)%CR). apply BindLaw1. Qed. #[global] Instance: Proper ((=) ==> (=)) rational_sqrt. Proof. intros x1 x2 E. rewrite <-2!CRsqrt_Qsqrt. now rewrite E. Qed. Lemma rational_sqrt_nonpos (a : Q) : a ≤ 0 → rational_sqrt a = 0%CR. Proof. intros. unfold rational_sqrt. case Qlt_le_dec_fast; intros; [|reflexivity]. edestruct Qle_not_lt; eassumption. Qed. Lemma rational_sqrt_unique (a : Q) (y : CR) : 0 ≤ a → CRpower_N y 2 = 'a → 0%CR ≤ y → y = rational_sqrt a. Proof. intros. assert (Pa : [0][<=](inj_Q IR a)). stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. now apply inj_Q_leEq. rewrite (rational_sqrt_correct _ Pa). now apply rational_sqrt_mid_correct_aux. Qed. Lemma rational_sqrt_scale (n : Z) a : 0 ≤ a → scale ((2#1) ^ n) (rational_sqrt (a * (4#1) ^ (-n))) = rational_sqrt a. Proof. intros E. rewrite <-CRmult_scale. revert n. apply biinduction. solve_proper. simpl. rewrite Qmult_1_r. now ring_simplify. intros n. setoid_replace ('((2#1) ^ (1 + n)) * rational_sqrt (a * (4#1) ^ -(1 + n)))%CR with ('((2#1) ^ n) * scale (2#1) (rational_sqrt ((a * (4#1) ^ -n) / (4#1))))%CR. assert (Pa1 : [0][<=](inj_Q IR (a * (4#1) ^ (- n)))). stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. apply Qmult_le_0_compat; [assumption|]. now apply Qpower_pos. assert (Pa2 : [0][<=](inj_Q IR (a * (4#1) ^ (- n) / (4 # 1)))). stepl (inj_Q IR 0); [| now (apply (inj_Q_nring IR 0))]. apply inj_Q_leEq. apply Qmult_le_0_compat; [|easy]. apply Qmult_le_0_compat; [assumption|]. now apply Qpower_pos. rewrite (rational_sqrt_correct _ Pa1), (rational_sqrt_correct _ Pa2). split; intros E2; rewrite <-E2; now rewrite rational_sqrt_big_bounded_correct_aux. rewrite Zopp_plus_distr. rewrite <-CRmult_scale. rewrite 2!Qpower_plus by discriminate. simpl. rewrite (Qmult_comm (2#1) ((2#1) ^ n)), <-CRmult_Qmult. rewrite (Qmult_comm (/(4#1))), Qmult_assoc. symmetry. apply associativity. Qed. corn-8.20.0/reals/fast/CRsign.v000066400000000000000000000061331473720167500162000ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.CRIR. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.reals.fast.CRArith. (** ** Tactics for Inequalities This module defines tactics for automatically proving inequalities over real numbers. *) (** Automatically solve the goal [{e:Qpos | CR_epsilon_sign_dec e x = Gt}] by starting with approximating by e, and halving the allowed error until the problem is solved. (This tactic may not terminate.) *) Ltac CR_solve_pos_loop e := (exists e; vm_compute; match goal with | |- Gt = Gt => reflexivity | |- Lt = Gt => fail 2 "CR number is negative" end) || CR_solve_pos_loop ((1#2)*e)%Qpos. (** This is the main tactic for solving goal of the from [CRpos e]. It tries to clear the context to make sure that e is a closed term. Then it applies the helper lemma and runs [CR_solve_pos_loop]. *) Ltac CR_solve_pos e := repeat (match goal with | H:_ |-_ => clear H end); match goal with | H:_ |-_ => fail 1 "Context cannot be cleared" | |-_ => idtac end; apply CR_epsilon_sign_dec_pos; CR_solve_pos_loop e. (** This tactic is used to transform an inequality over IR into an problem bout CRpos over CR. Some fancy work needs to be done because autorewrite will not in CRpos, because it is in Type and not Prop. *) Ltac IR_dec_precompute := try apply less_leEq; apply CR_less_as_IR; unfold CRltT; match goal with | |- CRpos ?X => let X0 := fresh "IR_dec" in set (X0:=X); let XH := fresh "IR_dec" in assert (XH:(X==X0)%CR) by reflexivity; autorewrite with IRtoCR in XH; autorewrite with CRfast_compute in XH; apply (CRpos_wd XH); clear X0 XH end. (** This tactic solves inequalites over IR. It converts the problem into a question about positivity over CR, and then tries to solve it. *) Ltac IR_solve_ineq e := IR_dec_precompute; CR_solve_pos e. corn-8.20.0/reals/fast/CRsin.v000066400000000000000000000675621473720167500160460ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.reals.fast.CRAlternatingSum. Require Import CoRN.reals.fast.CRAlternatingSum_alg. Require Import CoRN.reals.fast.CRstreams. Require Import CoRN.reals.fast.CRexp. Require Import CoRN.reals.fast.CRpi. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. From Coq Require Import Qpower Qabs. Require Import CoRN.model.ordfields.Qordfield. From Coq Require Import Qround. Require Import CoRN.transc.Pi. Require Import CoRN.reals.fast.ModulusDerivative. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.transc.PowerSeries. Require Import CoRN.transc.SinCos. Require Import CoRN.reals.fast.Compress. Require Import CoRN.reals.fast.PowerBound. Require Import CoRN.tactics.CornTac. Require Import MathClasses.interfaces.abstract_algebra. Require Import CoRN.util.Qdlog. From Coq Require Import Lia. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". Set Implicit Arguments. Local Open Scope Q_scope. Local Open Scope uc_scope. Opaque inj_Q CR Qmin Qmax. Lemma Qmult_pos_neg : forall (a b : Q), 0 <= a -> b <= 0 -> a*b <= 0. Proof. intros. rewrite Qmult_comm. rewrite <- (Qmult_0_l a). apply Qmult_le_compat_r; assumption. Qed. Lemma Qmult_opp_1 : forall q : Q, eq (-q) (-1 * q). Proof. reflexivity. Qed. Lemma fact_inc : forall n:nat, (fact n <= fact (S n))%nat. Proof. intro n. rewrite <- (Nat.mul_1_l (fact n)). change (fact (S n)) with ((1+n)*fact n)%nat. apply Nat.mul_le_mono_nonneg_r. apply (Nat.le_trans _ 1). auto. exact (lt_O_fact n). apply le_n_S, Nat.le_0_l. Qed. Lemma fact_inc_recurse : forall p n:nat, (n <= p)%nat -> (fact n <= fact p)%nat. Proof. induction p. - intros. inversion H. apply Nat.le_refl. - intros. apply Nat.le_succ_r in H. destruct H. apply (Nat.le_trans (fact n) (fact p)). apply IHp, H. apply fact_inc. subst n. apply Nat.le_refl. Qed. (** ** Sine Sine is defined in terms of its alternating Taylor's series. *) Section SinSeries. Variable a:Q. (* (1,a) -> (3, -a^3/3!) -> ... *) Definition sinStream (px : positive*Q) : positive*Q := let d := Pos.succ (fst px) in (Pos.add 2 (fst px), - snd px * a * a * (1#(d*Pos.succ d))). Lemma sinStream_fst : forall p, fst (iterate _ sinStream p (1%positive, a)) ≡ Pos.succ (2*p). Proof. apply Pos.peano_ind. - reflexivity. - intros p H. rewrite iterate_succ. destruct (iterate (positive and Q) sinStream p (1%positive, a)). simpl in H. subst p0. transitivity (Pos.add 2 (p~1)). reflexivity. clear q a. rewrite Pos.mul_succ_r. rewrite <- Pos.add_1_l, (Pos.add_comm 1). rewrite <- Pos.add_assoc. apply f_equal. reflexivity. Qed. (* The closed formula for the sine stream. *) Lemma Str_pth_sinStream : forall (p:positive), Str_pth _ sinStream p (xH,a) == (1#Pos.of_nat (fact (1+2*Pos.to_nat p))) * ((-1)^p*a^(1+2*p))%Q. Proof. apply Pos.peano_ind. - unfold sinStream, Str_pth; simpl. rewrite Qmult_comm. apply Qmult_comp. reflexivity. rewrite Qmult_assoc, Qmult_assoc. reflexivity. - intros p pInd. unfold Str_pth. rewrite iterate_succ. unfold Str_pth in pInd. pose proof (sinStream_fst p) as H0. destruct (iterate (positive and Q) sinStream p (1%positive, a)) as [p0 q]. simpl in H0. subst p0. unfold snd in pInd. unfold sinStream, snd, fst. rewrite pInd. clear pInd q. (* Get rid of (-1)^p *) rewrite <- (Qmult_comm ((-1) ^ Pos.succ p * a ^ (1 + 2 * Pos.succ p))). rewrite <- (Pos.add_1_l p). rewrite Pos2Z.inj_add, (Qpower_plus (-1)%Q). simpl ((-1)^1). rewrite Qmult_opp_1. do 5 rewrite <- (Qmult_assoc (-1)). apply (Qmult_comp (-1)). reflexivity. rewrite (Qmult_comm (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat p)))). do 5 rewrite <- (Qmult_assoc ((-1)^p)). apply Qmult_comp. reflexivity. (* Get rid of a *) setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)). do 4 rewrite <- (Qmult_assoc (a ^ (1 + 2 * p))). apply Qmult_comp. reflexivity. rewrite <- (Qmult_assoc _ a a). rewrite (Qmult_comm (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat p)))). rewrite <- (Qmult_assoc (a*a)). apply Qmult_comp. reflexivity. (* Get rid of fact *) unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. rewrite <- (Pos2Nat.id (Pos.succ p~1 * Pos.succ (Pos.succ p~1))). rewrite <- Nat2Pos.inj_mul. 2: apply fact_neq_0. replace (fact (1 + 2 * Pos.to_nat (1 + p)))%nat with (fact (1 + 2 * Pos.to_nat p) * Pos.to_nat (Pos.succ p~1 * Pos.succ (Pos.succ p~1)))%nat. reflexivity. rewrite Nat.mul_comm. replace (1 + 2 * Pos.to_nat (1 + p))%nat with (3 + 2 * Pos.to_nat p)%nat. change (fact (3 + 2 * Pos.to_nat p))%nat with ((3 + 2 * Pos.to_nat p) * ((2 + 2 * Pos.to_nat p) * fact (1 + 2 * Pos.to_nat p)))%nat. replace (Pos.to_nat (Pos.succ p~1 * Pos.succ (Pos.succ p~1)))%nat with ((3 + 2 * Pos.to_nat p) * ((2 + 2 * Pos.to_nat p)))%nat. rewrite Nat.mul_assoc. reflexivity. (* Finish equalities *) rewrite Pos2Nat.inj_mul. rewrite Nat.mul_comm. apply f_equal2. rewrite Pos2Nat.inj_succ. apply (f_equal S). rewrite Pos2Nat.inj_xI. reflexivity. rewrite Pos2Nat.inj_succ. apply (f_equal S). rewrite Pos2Nat.inj_succ. apply (f_equal S). rewrite Pos2Nat.inj_xI. reflexivity. rewrite Pos2Nat.inj_add. simpl. rewrite Nat.add_0_r, Nat.add_succ_r. reflexivity. intro abs. pose proof (Pos2Nat.is_pos (Pos.succ p~1 * Pos.succ (Pos.succ p~1))). rewrite abs in H. inversion H. rewrite <- (Qpower_plus_positive a 1 1). rewrite <- (Qpower_plus_positive a (1+2*p)). apply Qpower_positive_comp. reflexivity. rewrite <- Pos.add_assoc. apply f_equal. rewrite (Pos.add_comm 1 p). reflexivity. intro abs. discriminate. Qed. (** Sine is first defined on [[-1,1]] by an alternating series. *) Lemma sinStream_alt : -1 <= a <= 1 -> Str_alt_decr _ sinStream (1%positive,a). Proof. intro Ha. split. - (* Replace a by Qabs a *) rewrite Str_pth_sinStream, Str_pth_sinStream. rewrite Qabs_Qmult, Qabs_Qmult, Qabs_Qmult, Qabs_Qmult. rewrite Qabs_Qpower, Qabs_Qpower. change (Qabs (-1)) with 1. rewrite Qpower_1, Qpower_1, Qmult_1_l, Qmult_1_l. rewrite (Qabs_Qpower a (1+2*Pos.succ p)), (Qabs_Qpower a (1+2*p)). (* Finish inequality *) setoid_replace (Qabs a ^ (1 + 2 * Pos.succ p)%positive) with (Qabs a * Qabs a * Qabs a ^ (1 + 2 * p)%positive). rewrite Qmult_assoc. apply Qmult_le_compat_r. 2: rewrite <- Qabs_Qpower; apply Qabs_nonneg. + rewrite Qmult_comm. apply (Qabs_Qle_condition a 1) in Ha. apply (Qle_trans _ (1* (1 # Pos.of_nat (fact (1 + 2 * Pos.to_nat (Pos.succ p)))))). apply Qmult_le_compat_r. 2: discriminate. apply (Qle_trans _ (1*Qabs a)). apply Qmult_le_compat_r. exact Ha. apply Qabs_nonneg. rewrite Qmult_1_l. exact Ha. rewrite Qmult_1_l. unfold Qabs, Z.abs. unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. 2: apply fact_neq_0. 2: apply fact_neq_0. replace (1 + 2 * Pos.to_nat (Pos.succ p))%nat with (2 + (1 + 2 * Pos.to_nat p))%nat by (rewrite Pos2Nat.inj_succ; ring). apply (Nat.le_trans _ _ _ (fact_inc _)). apply fact_inc. + replace (1 + 2 * Pos.succ p)%positive with (2 + (1 + 2 * p))%positive. generalize (1 + 2 * p)%positive. clear p. intro p. unfold Qpower. rewrite Qpower_plus_positive. reflexivity. rewrite Pos.add_comm, <- Pos.add_assoc. apply f_equal. rewrite <- Pos.add_1_l. rewrite Pos.mul_add_distr_l, Pos.mul_1_r. apply Pos.add_comm. - rewrite Str_pth_sinStream, Str_pth_sinStream. rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg. discriminate. rewrite Qmult_comm, <- Qmult_assoc. apply Qmult_pos_neg. discriminate. rewrite <- Pos.add_1_l. change ((-1) ^ (1 + p)%positive) with (Qpower_positive (-1) (1 + p)). rewrite Qpower_plus_positive. simpl (Qpower_positive (-1) 1). rewrite <- Qmult_assoc, <- Qmult_assoc. apply (Qopp_le_compat 0). rewrite (Qmult_comm (a ^ (1 + 2 * (1 + p)%positive))). rewrite Qmult_assoc, Qmult_assoc. rewrite <- Qmult_assoc. apply Qmult_le_0_compat. simpl. destruct (Qpower_positive (-1) p), Qnum; discriminate. setoid_replace (a ^ (1 + 2 * (1 + p))) with (a ^ (1 + 2 * p) * (a * a)). rewrite Qmult_assoc. apply Qmult_le_0_compat. destruct (a ^ (1 + 2 * p)), Qnum; discriminate. destruct a, Qnum; discriminate. change (a*a) with (Qpower_positive a 2). rewrite <- (Qpower_plus_positive a (1+2*p)). change (a ^ (1 + 2 * (1 + p))) with (Qpower_positive a (1 + 2 * (1 + p))). replace (1 + 2 * (1 + p))%positive with (1 + 2 * p + 2)%positive. reflexivity. rewrite <- Pos.add_assoc. apply f_equal. rewrite Pos.mul_add_distr_l, Pos.mul_1_r. apply Pos.add_comm. Qed. Lemma sinStream_zl : -1 <= a <= 1 -> Limit_zero _ sinStream (xH,a) (fun e:Qpos => Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ (proj1_sig e)))))). Proof. intro Ha. intros [e epos]. rewrite Str_pth_sinStream, Qabs_Qmult, Qabs_Qmult. rewrite Qabs_Qpower. change (Qabs (-1)) with 1. rewrite Qpower_1, Qmult_1_l. rewrite Qmult_comm. apply (Qle_trans _ (1 * Qabs (1 # Pos.of_nat (fact (1+2*(Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))))))))). apply Qmult_le_compat_r. 2: apply Qabs_nonneg. - rewrite (Qabs_Qpower a (1 + 2 * Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ ` (e ↾ epos))))))). apply Qpower_le_1. split. apply Qabs_nonneg. apply Qabs_Qle_condition, Ha. - clear Ha a. rewrite Qmult_1_l. unfold Qabs, Z.abs, proj1_sig. rewrite <- (Qinv_involutive e) at 2. assert (0 < /e) as H. { apply Qinv_lt_0_compat, epos. } apply (@Qinv_le_compat (/e) ((Pos.of_nat (fact (1+2*(Pos.to_nat (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))))))) # 1)). exact H. apply (Qle_trans _ _ _ (Qceiling_fact_le H)). generalize (Pos.succ (Z.to_pos (Z.log2_up (Qceiling (/ e))))). clear H epos e. intro p. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. 2: apply fact_neq_0. 2: apply fact_neq_0. apply fact_inc_recurse. apply (Nat.le_trans (Pos.to_nat p) (1 + Pos.to_nat p)). apply le_S, Nat.le_refl. apply le_n_S. rewrite <- (Nat.mul_1_l (Pos.to_nat p)) at 1. apply Nat.mul_le_mono_nonneg_r. apply Nat.le_0_l. apply le_S, Nat.le_refl. Qed. End SinSeries. Definition rational_sin_small (a:Q) (p: -1 <= a <= 1) : CR := (inject_Q_CR a + AltSeries _ (sinStream a) (xH,a) _ (sinStream_alt p) (sinStream_zl p))%CR. Lemma rational_sin_small_correct : forall (a:Q) (Ha : -1 <= a <= 1), (@rational_sin_small a Ha == IRasCR (Sin (inj_Q IR a)))%CR. Proof. intros a Ha. unfold rational_sin_small. simpl. generalize (fun_series_conv_imp_conv (inj_Q IR a) (inj_Q IR a) (leEq_reflexive IR (inj_Q IR a)) sin_ps (sin_conv (inj_Q IR a) (inj_Q IR a) (leEq_reflexive IR (inj_Q IR a)) (compact_single_iprop realline (inj_Q IR a) I)) (inj_Q IR a) (compact_single_prop (inj_Q IR a)) (fun_series_inc_IR realline sin_ps sin_conv (inj_Q IR a) I)). intros H. (* Replace AltSeries by IRasCR (series_sum ...) *) rewrite <- (IR_inj_Q_as_CR a). rewrite (AltSeries_correct _ _ _ _ (sinStream_alt Ha) (sinStream_zl Ha) _ (AltSeries_convergent_0 _ _ _ _ (inj_Q IR a) (sinStream_alt Ha) (sinStream_zl Ha))). apply IRasCR_wd. - (* Prove the 2 series are equal in IR. We need to sum twice as many terms in sin_seq, to get rid of the zeros at even indexes. *) unfold series_sum. apply Lim_seq_eq_Lim_subseq with (fun n => 2*n)%nat. intros; lia. intros n; exists (S n); lia. (* Prove that the partial sums until n are equal. *) intros n. induction n. apply eq_reflexive. replace (2*(S n))%nat with (S (S (2*n)))%nat by lia. set (n':=(2*n)%nat) in *. simpl in *. rstepr (seq_part_sum (fun n0 : nat => (sin_seq n0[/]nring (R:=IR) (fact n0)[//]nring_fac_ap_zero IR n0)[*] nexp IR n0 (inj_Q IR a[-][0])) n'[+]( (sin_seq n'[/]nring (R:=IR) (fact n')[//]nring_fac_ap_zero IR n')[*] nexp IR n' (inj_Q IR a[-][0])[+] (sin_seq (S n')[/]nring (R:=IR) (fact n' + n' * fact n')[//] nring_fac_ap_zero IR (S n'))[*] (nexp IR n' (inj_Q IR a[-][0])[*](inj_Q IR a[-][0])))). apply bin_op_wd_unfolded. assumption. rewrite <- cm_lft_unit. unfold sin_seq. apply bin_op_wd_unfolded. + destruct (even_or_odd_plus n') as [m [Hm|Hm]]; simpl. rational. elim (Nat.Even_Odd_False n'); [ exists n; subst n'; ring | now exists m; rewrite Hm, Nat.add_1_r; simpl; rewrite Nat.add_0_r]. + destruct (even_or_odd_plus (S n')) as [m [Hm|Hm]]; simpl. elim (Nat.Even_Odd_False (S n')). rewrite Hm. replace (m + m)%nat with (2*m)%nat by lia; now exists m. subst n'; exists n; ring. inversion Hm. unfold n' in H1. replace m with n by lia. clear Hm H1. (* Unfold sinStream *) transitivity (inj_Q IR ((1#Pos.of_nat (fact (1+2*n))) * ((-1)^n*a^(1+2*n))%Q)). clear IHn H. destruct n. simpl. apply inj_Q_wd. rewrite Qmult_1_l, Qmult_1_l. reflexivity. apply inj_Q_wd. rewrite Str_pth_sinStream. rewrite Nat2Pos.id. 2: discriminate. replace (Z.pos (Pos.of_nat (S n))) with (Z.of_nat (S n)). reflexivity. simpl. destruct n. reflexivity. rewrite <- Pos.succ_of_nat. reflexivity. discriminate. (* Get rid of (-1)^n *) transitivity (inj_Q IR ((-(1))^n) [*] (inj_Q IR (a ^ (1 + 2 * n)) [*] inj_Q IR (1 # Pos.of_nat (fact (1 + 2 * n))))). rewrite <- inj_Q_mult, <- inj_Q_mult. apply inj_Q_wd. rewrite Qmult_comm. rewrite Qmult_assoc. reflexivity. change (inj_Q IR ((- (1)) ^ n) [*] (inj_Q IR (a ^ (1 + 2 * n)) [*] inj_Q IR (1 # Pos.of_nat (fact (1 + 2 * n)))) [=] (nexp IR n [--][1][/]nring (R:=IR) (fact (S n'))[//]nring_fac_ap_zero IR (S n'))[*] (nexp IR (S n') (inj_Q IR a[-][0]))). rstepr ((nexp IR n [--][1][*](nexp IR (S n') (inj_Q IR a[-][0])[/]nring (R:=IR) (fact (S n'))[//] nring_fac_ap_zero IR (S n')))). apply mult_wd. stepr ((inj_Q IR (-(1)))[^]n). apply inj_Q_power. apply nexp_wd. stepr ([--](inj_Q IR 1)). apply inj_Q_inv. apply un_op_wd_unfolded. rstepr (nring 1:IR). apply (inj_Q_nring IR 1). stepr (inj_Q IR ((1/P_of_succ_nat (pred (fact (1+2*n))))*a^(1+2*n)%nat)). rewrite <- inj_Q_mult. apply inj_Q_wd. rewrite Qmult_comm. apply Qmult_comp. replace (1 + 2 * Z.of_nat n)%Z with (Z.of_nat (1 + 2 * n)). reflexivity. rewrite <- (Nat2Z.inj_mul 2), <- (Nat2Z.inj_add 1). reflexivity. pose proof (fact_neq_0 (1+2*n)). destruct (fact (1+2*n)). exfalso; apply H0; reflexivity. simpl. destruct n0. reflexivity. rewrite <- Pos2SuccNat.id_succ, Nat2Pos.id. reflexivity. discriminate. (* Finish equality *) rstepr ((nring 1[/]nring (R:=IR) (fact (S n'))[//] nring_fac_ap_zero IR (S n'))[*](nexp IR (S n') (inj_Q IR a[-][0]))). change (1+2*n)%nat with (S n'). stepr ((inj_Q IR (1 / Zpos (P_of_succ_nat (pred (fact (S n')))))[*](inj_Q IR (a^S n')))). apply inj_Q_mult. apply mult_wd. rewrite <- POS_anti_convert. assert (X:inj_Q IR (inject_Z (Z_of_nat (S (pred (fact (S n'))))))[#][0]). stepr (inj_Q IR [0]). assert (@cs_ap Q_as_CSetoid (inject_Z (Z_of_nat (S (pred (fact (S n')))))) 0). discriminate. destruct (ap_imp_less _ _ _ X). apply less_imp_ap. apply inj_Q_less. assumption. apply Greater_imp_ap. apply inj_Q_less. assumption. apply (inj_Q_nring IR 0). stepr ((inj_Q IR 1)[/](inj_Q IR (inject_Z (Z_of_nat (S (pred (fact (S n')))))))[//]X). apply inj_Q_div. apply div_wd. apply (inj_Q_nring IR 1). stepl (inj_Q IR (nring (fact (S n')))). apply inj_Q_nring. assert (Y:=lt_O_fact (S n')). apply inj_Q_wd. stepr ((fact (S n')):Q). clear - n'. induction (fact (S n')). simpl; reflexivity. rewrite inj_S. unfold Z.succ. simpl in *. rewrite -> IHn0. rewrite -> injz_plus. reflexivity. destruct (fact (S n')). exfalso; auto with *. simpl; reflexivity. stepr ((inj_Q IR a)[^](S n')). apply inj_Q_power. change (inj_Q IR a[^]S n'[=](inj_Q IR a[-][0])[^]S n'). apply nexp_wd. rational. - intro p. pose proof (Pos2Nat.is_pos p). destruct (Pos.to_nat p) eqn:des. exfalso; inversion H0. rewrite <- des. rewrite Pos2Nat.id. reflexivity. Qed. (** Sine's range can then be extended to [[-3^n,3^n]] by [n] applications of the identity [sin(x) = 3*sin(x/3) - 4*(sin(x/3))^3]. *) Section Sin_Poly. Definition sin_poly_fun (x:Q) :Q := x*(3 - 4*x*x). Global Instance: Proper ((=) ==> (=)) sin_poly_fun. Proof. unfold sin_poly_fun. solve_proper. Qed. Lemma sin_poly_fun_correct : forall (q:Q), inj_Q IR (sin_poly_fun q)[=]Three[*]inj_Q IR q[-]Four[*](inj_Q IR q[^]3). Proof. intros q. unfold sin_poly_fun. stepr (inj_Q IR (3*q-4*q^3)). apply inj_Q_wd. simpl; ring. rewrite inj_Q_minus. apply cg_minus_wd. stepr (inj_Q IR Three[*]inj_Q IR q). apply inj_Q_mult. apply mult_wdl. apply (inj_Q_nring IR 3). stepr (inj_Q IR Four[*]inj_Q IR (q^3)). apply inj_Q_mult. apply mult_wd. apply (inj_Q_nring IR 4). apply (inj_Q_power IR q 3). Qed. Definition sin_poly_modulus (e:Qpos) := Qpos2QposInf ((1#9)*e). Lemma DthreeXMinusFourX3 : Derivative (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))) (inj_Q_less _ (-1) 1 eq_refl) ((Three:IR){**}FId{-}(Four:IR){**}FId{^}3) ((Three:IR){**}[-C-]([1]:IR){-}(Four:IR){**}((nring 3){**}([-C-][1]{*}FId{^}2))). Proof. apply Derivative_minus. apply Derivative_scal. apply Derivative_id. apply Derivative_scal. apply Derivative_nth. apply Derivative_id. Qed. Lemma sin_poly_prf : is_UniformlyContinuousFunction (fun x => sin_poly_fun (QboundAbs (1#1) x)) sin_poly_modulus. Proof. apply (fun a => is_UniformlyContinuousD_Q (Some (-(1))%Q) (Some (1:Q)) eq_refl _ _ DthreeXMinusFourX3 sin_poly_fun a (9#1)). simpl; intros q _ _. apply sin_poly_fun_correct. simpl; intros x' _ [Hx0 Hx1]. set (x:=(inj_Q IR x')) in *. stepr (Nine:IR); [| now (apply eq_symmetric; apply (inj_Q_nring IR 9))]. stepl (ABSIR (Three[-]Twelve[*]x[*]x)); [| now (apply AbsIR_wd; rational)]. apply AbsSmall_imp_AbsIR. split. apply shift_zero_leEq_minus'. rstepr (Twelve[*]((nring 1)[-]x)[*](x[-][--](nring 1))). repeat apply mult_resp_nonneg. apply (nring_nonneg IR 12). apply shift_zero_leEq_minus. stepr (inj_Q IR (nring 1)); [| now apply inj_Q_nring]. assumption. apply shift_zero_leEq_minus. stepl (inj_Q IR (-(1))). assumption. stepr ([--](inj_Q IR 1)). apply inj_Q_inv. apply un_op_wd_unfolded. apply (inj_Q_nring IR 1). rstepr (Nine[-][0]:IR). apply minus_resp_leEq_both. apply nring_leEq. lia. rstepr (Twelve[*]x[^]2). apply mult_resp_nonneg. apply (nring_leEq IR 0 12). lia. apply sqr_nonneg. Qed. Definition sin_poly_uc : Q_as_MetricSpace --> Q_as_MetricSpace := Build_UniformlyContinuousFunction sin_poly_prf. Definition sin_poly : CR --> CR := uc_compose compress (Cmap QPrelengthSpace sin_poly_uc). Lemma sin_poly_correct : forall x, AbsSmall (inj_Q IR (1)) x -> (IRasCR (Three[*]x[-]Four[*]x[^]3)==sin_poly (IRasCR x))%CR. Proof. intros x Hx. assert (Y:Continuous (clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q))) ((Three:IR){**}FId{-}(Four:IR){**}FId{^}3)). eapply Derivative_imp_Continuous. apply DthreeXMinusFourX3. apply: (ContinuousCorrect (I:=(clcr (inj_Q IR (-(1))) (inj_Q IR (1:Q)))) (inj_Q_less _ (-1) 1 eq_refl) Y); [|repeat constructor|]. intros q Hq Hq0. transitivity (IRasCR (inj_Q IR (sin_poly_fun q)));[|apply IRasCR_wd; apply sin_poly_fun_correct]. simpl. change (' q)%CR with (Cunit_fun _ q). rewrite -> compress_fun_correct. rewrite -> Cmap_fun_correct. rewrite -> MonadLaw3. rewrite -> IR_inj_Q_as_CR. rewrite -> CReq_Qeq. simpl. unfold sin_poly_fun. setoid_replace (Qmax (- (1)) (Qmin 1 q)) with q. reflexivity. setoid_replace (Qmin 1 q) with q. rewrite <- Qle_max_r. apply leEq_inj_Q with IR. destruct Hq0; assumption. rewrite <- Qle_min_r. apply leEq_inj_Q with IR. destruct Hq0; assumption. destruct Hx; split;[stepl [--](inj_Q IR (1:Q)); [| now apply eq_symmetric; apply inj_Q_inv] |];assumption. Qed. Lemma Sin_triple_angle : forall x, (Sin(Three[*]x)[=]Three[*]Sin x[-]Four[*]Sin x[^]3). Proof. intros x. assert (H:Three[*]x[=]x[+]x[+]x) by rational. csetoid_rewrite H. csetoid_rewrite (Sin_plus (x[+]x) x). csetoid_rewrite (Sin_plus x x). csetoid_rewrite (Cos_plus x x). set (sx:=Sin x). set (cx:=Cos x). rstepl ((cx[^]2)[*](Three[*]sx)[-]sx[^]3). unfold cg_minus. csetoid_replace (cx[^]2) ([1][-]sx[^]2). rational. apply cg_inv_unique_2. rstepl ((cx[^]2[+]sx[^]2)[-][1]). apply x_minus_x. apply FFT. Qed. Lemma shrink_by_three : forall n a, -(3^(S n))%Z <= a <= (3^(S n))%Z -> -(3^n)%Z <= a/3 <= (3^n)%Z. Proof. intros n a H0. apply AbsSmall_Qabs. apply AbsSmall_Qabs in H0. apply Qmult_lt_0_le_reg_r with (Qabs 3). reflexivity. rewrite <- Qabs_Qmult. unfold Qdiv. rewrite <- Qmult_assoc. setoid_replace (/ 3 * 3) with 1 by reflexivity. rewrite Qmult_1_r. apply (Qle_trans _ _ _ H0). clear H0. change (Qabs 3) with (inject_Z 3). rewrite <- (inject_Z_mult (3^n) 3). rewrite <- Zle_Qle. change (S n) with (1+n)%nat. rewrite (Nat2Z.inj_add 1 n). rewrite ZBinary.Z.pow_add_r, Z.mul_comm. apply Z.le_refl. discriminate. apply (Nat2Z.inj_le 0), Nat.le_0_l. Qed. Fixpoint rational_sin_bounded (n:nat) (a:Q) : -(3^n)%Z <= a <= (3^n)%Z -> CR := match n return -(3^n)%Z <= a <= (3^n)%Z -> CR with | O => @rational_sin_small a | S n' => fun H => sin_poly (rational_sin_bounded n' (shrink_by_three n' H)) end. Lemma rational_sin_bounded_correct_aux a : (sin_poly (IRasCR (Sin (inj_Q IR (a / 3)))) == IRasCR (Sin (inj_Q IR a)))%CR. Proof. rewrite <- sin_poly_correct; [|apply AbsIR_imp_AbsSmall; (stepr (nring 1:IR); [| now apply eq_symmetric; apply (inj_Q_nring IR 1)]); rstepr ([1]:IR); apply AbsIR_Sin_leEq_One]. apply IRasCR_wd. stepl (Sin (inj_Q IR (a/3*3))). apply Sin_wd. apply inj_Q_wd. simpl; field; discriminate. generalize (a/3). intros b; clear -b. stepr (Sin (Three[*](inj_Q IR b))). apply Sin_wd. stepr ((inj_Q IR b)[*](inj_Q IR (3:Q))). apply inj_Q_mult. csetoid_replace (inj_Q IR (3:Q)) (Three:IR). rational. apply (inj_Q_nring IR 3). apply Sin_triple_angle. Qed. Lemma rational_sin_bounded_correct : forall (n:nat) (a:Q) (Ha : -(3^n #1) <= a <= (3^n #1)), (@rational_sin_bounded n a Ha == IRasCR (Sin (inj_Q IR a)))%CR. Proof. induction n. apply rational_sin_small_correct. intros a Ha. unfold rational_sin_bounded; fold rational_sin_bounded. rewrite -> IHn. apply rational_sin_bounded_correct_aux. Qed. End Sin_Poly. Definition sin_bound (q:Q) : nat := Z.abs_nat (1 + Qdlog 3 (Qabs q)). Lemma sin_bound_correct : forall q, -(3 ^ sin_bound q #1) ≤ q ≤ (3 ^ sin_bound q #1). Proof. intro q. apply AbsSmall_Qabs. unfold sin_bound. destruct (Qlt_le_dec (Qabs q) 1). - apply (Qle_trans _ 1). apply Qlt_le_weak, q0. rewrite Qdlog2_le1; simpl; try easy. apply Qlt_le_weak, q0. - assert (2 ≤ 3%Z) as H by discriminate. pose proof (Qdlog_spec 3 (Qabs q) H q0) as [_ H0]. clear H. unfold additional_operations.pow, stdlib_rationals.Q_pow in H0. assert (0 <= 1 + Qdlog 3 (Qabs q))%Z. { apply semirings.nonneg_plus_compat; [easy | now apply Qdlog_bounded_nonneg]. } rewrite inj_Zabs_nat, Z.abs_eq. apply Qlt_le_weak. rewrite <- Zpower_Qpower in H0. apply H0. exact H. exact H. Qed. (** Therefore sin works on all real numbers. *) Definition rational_sin (a:Q) : CR := rational_sin_bounded (sin_bound a) (sin_bound_correct a). Lemma rational_sin_correct : forall (a:Q), (rational_sin a == IRasCR (Sin (inj_Q IR a)))%CR. Proof. intros; apply rational_sin_bounded_correct. Qed. #[global] Instance: Proper ((=) ==> (=)) rational_sin. Proof. intros ? ? E. rewrite ?rational_sin_correct. now apply IRasCR_wd, Sin_wd, inj_Q_wd. Qed. Lemma rational_sin_poly (a : Q) : sin_poly (rational_sin (a / 3)) = rational_sin a. Proof. rewrite ?rational_sin_correct. apply rational_sin_bounded_correct_aux. Qed. Lemma rational_sin_correct_aux (a : Q) : (- IRasCR (Sin (inj_Q IR (- a)%Q)) == IRasCR (Sin (inj_Q IR a)))%CR. Proof. rewrite <- IR_opp_as_CR. apply IRasCR_wd. csetoid_rewrite_rev (Sin_inv (inj_Q IR (-a))). apply Sin_wd. csetoid_rewrite_rev (inj_Q_inv IR (-a)). apply inj_Q_wd. simpl. ring. Qed. Lemma rational_sin_opp (a : Q) : (-rational_sin (-a) = rational_sin a)%CR. Proof. rewrite ?rational_sin_correct. now apply rational_sin_correct_aux. Qed. (** Sine is uniformly continuous everywhere. *) Definition sin_uc_prf : is_UniformlyContinuousFunction rational_sin Qpos2QposInf. Proof. apply (is_UniformlyContinuousFunction_wd) with (fun x => rational_sin x) (Qscale_modulus (1#1)). reflexivity. intros x. simpl. autorewrite with QposElim. change (/1) with 1. replace RHS with (proj1_sig x) by simpl; ring. apply Qle_refl. apply (is_UniformlyContinuousD None None I Sine Cosine (Derivative_Sin I) rational_sin). intros q [] _. apply rational_sin_correct. intros x [] _. stepr ([1]:IR). apply: AbsIR_Cos_leEq_One. rstepl (nring 1:IR). apply eq_symmetric. apply (inj_Q_nring IR 1). Qed. Definition sin_uc : Q_as_MetricSpace --> CR := Build_UniformlyContinuousFunction sin_uc_prf. Definition sin_slow : CR --> CR := Cbind QPrelengthSpace sin_uc. Lemma sin_slow_correct : forall x, (IRasCR (Sin x) == sin_slow (IRasCR x))%CR. Proof. intros x. apply: (ContinuousCorrect (I:proper realline)); [apply Continuous_Sin | | constructor]. intros q [] _. transitivity (rational_sin q);[|apply rational_sin_correct]. unfold sin_slow. rewrite -> (Cbind_fun_correct QPrelengthSpace sin_uc). apply: BindLaw1. Qed. Definition sin (x:CR) := sin_slow (x - (compress (scale (2*Qceiling (approximate (x*(CRinv_pos (6#1) (scale 2 CRpi))) (Qpos2QposInf (1#2)) -(1#2))) CRpi)))%CR. Lemma sin_correct : forall x, (IRasCR (Sin x) == sin (IRasCR x))%CR. Proof. intros x. unfold sin. generalize (Qceiling (approximate (IRasCR x * CRinv_pos (6 # 1) (scale 2 CRpi)) (Qpos2QposInf (1 # 2)) - (1 # 2)))%CR. intros z. rewrite -> compress_correct. rewrite <- CRpi_correct, <- CRmult_scale, <- IR_inj_Q_as_CR, <- IR_mult_as_CR, <- IR_minus_as_CR, <- sin_slow_correct. apply IRasCR_wd. rewrite -> inj_Q_mult. change (2:Q) with (@nring Q_as_CRing 2). rewrite -> inj_Q_nring. rstepr (Sin (x[+]([--](inj_Q IR z))[*](Two[*]Pi))). setoid_replace (inj_Q IR z) with (zring z:IR). rewrite <- zring_inv. symmetry; apply Sin_periodic_Z. rewrite <- inj_Q_zring. apply inj_Q_wd. symmetry; apply zring_Q. Qed. (* begin hide *) #[global] Hint Rewrite sin_correct : IRtoCR. (* end hide *) corn-8.20.0/reals/fast/CRstreams.v000066400000000000000000000640451473720167500167240ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.metric2.Limit. From Coq Require Import Qabs. From Coq Require Import Arith. From Coq Require Import Qpower. Require Import CoRN.reals.fast.LazyNat. From Coq Require Import Ring. Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.streams. Require Export MathClasses.theory.series. Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.streams. Opaque Qabs. Local Open Scope Q_scope. (** ** Specific results for streams on [Q] *) (** [everyOther] preserves limits. *) Lemma everyOther_nbz : forall (s : Stream Q) (e : QposInf), (NearBy 0 e s) -> NearBy 0 e (everyOther s). Proof. cofix everyOther_nbz. intros [s [b r]] x [H [_ Hs]]. constructor;[|apply everyOther_nbz];assumption. Qed. #[global] Instance everyOther_zl `{Hx : !Limit s 0} : Limit (everyOther s) 0. Proof. intros e. assert (H:=Hx e). clear Hx. revert s H. fix everyOther_zl 2. intros x [H|H]. left. apply everyOther_nbz. assumption. case (H tt);[intros X |intros X]. right; left. clear - x X. abstract ( destruct x as [a [b x]]; destruct X; apply everyOther_nbz; assumption). right; intros _. apply everyOther_zl. apply X. constructor. Defined. (** [mult_Streams] preserves convergeing to 0. *) Lemma mult_Streams_nbz : forall {s1 s2 : Stream Q} {x : QposInf}, (NearBy 0 x s1) -> forall {y : QposInf}, NearBy 0 y s2 -> NearBy 0 (x*y) (mult_Streams s1 s2). Proof. unfold NearBy. cofix mult_Streams_nbz. intros s1 s2 x [Ha0 Hs1] y [Hb0 Hs2]. constructor. 2: apply (mult_Streams_nbz (CoqStreams.tl s1) (CoqStreams.tl s2)); assumption. destruct x as [x|];[|constructor]. destruct y as [y|];[|constructor]. simpl. unfold Qball. unfold QAbsSmall. setoid_replace ((CoqStreams.hd s1 * CoqStreams.hd s2)%mc - 0)%Q with ((CoqStreams.hd s1 - 0) * (CoqStreams.hd s2 - 0)). apply Qmult_AbsSmall; assumption. ring_simplify. reflexivity. Qed. (* The multiplication of a bounded stream b by a stream a converging to 0 converges to 0. *) Lemma mult_Streams_zl : forall (a b : Stream Q), (Limit a 0) -> forall (x:Qpos), NearBy 0 x b -> Limit (mult_Streams a b) 0. Proof. intros a b Ha x Hb e. assert (H:=Ha (e * (Qpos_inv x))%QposInf). generalize b Hb. clear b Hb. induction H; intros b Hb. left. abstract ( destruct e as [e|];[|apply ForAll_True]; assert (Heq:proj1_sig e== proj1_sig ((e*Qpos_inv x)*x)%Qpos);[ simpl; field; apply Qpos_nonzero |rewrite -> (NearBy_comp _ _ (ball_refl _ 0 (Qle_refl 0)) _ _ Heq ); apply (mult_Streams_nbz H Hb)] ). right. simpl. rename H0 into IHExists. intros. apply (IHExists tt). apply Limit_tl; assumption. destruct Hb; assumption. Defined. (** *** [StreamBounds] [StreamBounds] says that one stream pointwise bounds the absolute value of the other. *) Definition StreamBounds (a b : Stream Q) := ForAll (fun (x:Stream (Q*Q)) => let (a,b):=(CoqStreams.hd x) in QAbsSmall a b) (zipWith pair a b). (** If the bounding stream goes to 0, so does the bounded stream. *) Lemma Stream_Bound_nbz : forall a b e, (StreamBounds a b) -> NearBy 0 e a -> NearBy 0 e b. Proof. cofix Stream_Bound_nbz. intros a b e Hb Ha. constructor. destruct Hb as [[Hb1 Hb2] _]. destruct e as [e|];[|constructor]. destruct Ha as [[Ha1 Ha2] _]. simpl in *. split. apply Qle_trans with (-(CoqStreams.hd a -0)). apply Qopp_le_compat. assumption. ring_simplify. assumption. apply Qle_trans with (CoqStreams.hd a - 0). ring_simplify. assumption. assumption. eapply Stream_Bound_nbz. destruct Hb as [_ Hb]. change (StreamBounds (CoqStreams.tl a) (CoqStreams.tl b)) in Hb. apply Hb. destruct Ha as [_ Ha]. assumption. Qed. Lemma Stream_Bound_zl : forall a b, (StreamBounds a b) -> Limit a 0 -> Limit b 0. Proof. intros a b H Ha e. assert (Ha':=(Ha e)); clear Ha. generalize b H; clear b H. induction Ha'; intros b Hb. left. apply Stream_Bound_nbz with x; assumption. right. rename H0 into IHHa'. intros _. apply (IHHa' tt). destruct Hb; assumption. Defined. Section Qpowers. Variable a : Q. Hypothesis Ha : 0 <= a <= 1. (** It is decreasing and nonnegative when a is between 0 and 1. *) Lemma powers_help_dnn : forall x, (0 <= x) -> DecreasingNonNegative (powers_help a x). Proof. intros x Hx. destruct Ha as [Ha0 Ha1]. generalize x Hx; clear x Hx. cofix powers_help_dnn. intros b Hb. constructor. simpl. split. rewrite <- (Qmult_0_l a). apply Qmult_le_compat_r; assumption. rewrite Qmult_comm. rewrite <- (Qmult_1_l b) at 2. apply Qmult_le_compat_r. exact Ha1. exact Hb. apply powers_help_dnn. rewrite <- (Qmult_0_l a). apply Qmult_le_compat_r; assumption. Qed. Lemma powers_dnn : DecreasingNonNegative (powers a). Proof. apply powers_help_dnn. discriminate. Qed. Lemma powers_help_nbz : forall x, 0 <= x <= 1 -> NearBy 0 (Qpos2QposInf (1#1)) (powers_help a x). Proof. cofix powers_help_nbz. intros b [Hb0 Hb1]. destruct Ha as [Ha0 Ha1]. constructor. simpl. unfold Qball. unfold QAbsSmall. setoid_replace (b-0)%Q with b. 2: unfold Qminus; apply Qplus_0_r. split;simpl. apply Qle_trans with 0;[discriminate|assumption]. assumption. simpl. apply powers_help_nbz. split. rewrite <- (Qmult_0_l a). apply Qmult_le_compat_r; assumption. apply (Qle_trans _ (1*a)). apply Qmult_le_compat_r; assumption. rewrite Qmult_1_l. exact Ha1. Qed. Lemma powers_nbz : NearBy 0 (Qpos2QposInf (1#1)) (powers a). Proof. apply powers_help_nbz. split; discriminate. Qed. End Qpowers. (** *** [ppositives] The stream of postive numbers (as positive). We do not use [positives] because [positive] does not form a semiring. *) CoFixpoint ppositives_help (n:positive) : Stream positive := Cons n (ppositives_help (Pos.succ n)). Definition ppositives := ppositives_help 1. Lemma Str_nth_ppositives : forall n, Str_nth n ppositives ≡ P_of_succ_nat n. Proof. intros n. unfold ppositives. apply nat_of_P_inj. rewrite nat_of_P_o_P_of_succ_nat_eq_succ. change (S n) with ((nat_of_P 1) + n)%nat. generalize 1%positive. induction n. intros c. rewrite Nat.add_comm. reflexivity. intros c. unfold Str_nth in *. simpl. rewrite IHn. rewrite nat_of_P_succ_morphism. apply plus_n_Sm. Qed. Lemma Str_nth_ppositives' n : inject_Z (Zpos (Str_nth n ppositives)) = Str_nth n positives. Proof. rewrite Str_nth_ppositives, Str_nth_positives. rewrite Z.P_of_succ_nat_Zplus. rewrite <-(naturals.to_semiring_unique (Basics.compose inject_Z Z_of_nat)). unfold Basics.compose. rewrite <-(rings.preserves_1 (f:=inject_Z)). rewrite <-rings.preserves_plus. now rewrite commutativity. Qed. (** *** [Qrecip_positives] The stream of 1/n. *) Definition Qrecip_positives := CoqStreams.map (fun x => 1#x) ppositives. Lemma Str_nth_Qrecip_positives : forall n, Str_nth n Qrecip_positives = 1#(P_of_succ_nat n). Proof. intros n. unfold Qrecip_positives. rewrite Str_nth_map. rewrite Str_nth_ppositives. reflexivity. Qed. Lemma Str_nth_Qrecip_positives' n : Str_nth n Qrecip_positives = / Str_nth n positives. Proof. unfold Qrecip_positives. rewrite Str_nth_map. rewrite Qmake_Qdiv. rewrite Str_nth_ppositives'. apply (left_identity (/ Str_nth n positives)). Qed. (** The limit of [recip_positives] is 0. *) Lemma Qrecip_positives_help_nbz : forall (x: Qpos) (q:positive), (Zpos (Qden (proj1_sig x)) <= Zpos q)%Z -> NearBy 0 (Qpos2QposInf x) (CoqStreams.map (fun x => 1#x) (ppositives_help q)). Proof. assert (∀ (q n d : positive), (Zpos d <= Zpos q)%Z → NearBy 0 (Qpos2QposInf (n # d)) (CoqStreams.map (λ x : positive, 1 # x) (ppositives_help q))). { cofix Qrecip_positives_help_nbz. intros q n d Hpq. constructor. - simpl. unfold Qball, QAbsSmall, Qminus. rewrite Qplus_0_r. split. discriminate. change (1*Zpos d <= Zpos n*Zpos q)%Z. apply Zmult_le_compat. apply Pos.le_1_l. exact Hpq. discriminate. discriminate. - apply Qrecip_positives_help_nbz. clear Qrecip_positives_help_nbz. rewrite Zpos_succ_morphism. apply (Z.le_trans _ _ _ Hpq). apply Z.le_succ_diag_r. } intros. destruct x as [[n d] xpos]. destruct n as [|n|n]. inversion xpos. 2: inversion xpos. apply H. exact H0. Qed. (* Make a lazy list of LazyFurthers. *) Fixpoint Qrecip_positives_help_Exists P (n:LazyNat) (p:positive) (H : LazyExists P (CoqStreams.map (fun x => (1#x)) (ppositives_help (Pplus_LazyNat p n)))) { struct n } : LazyExists P (CoqStreams.map (fun x => (1#x)) (ppositives_help p)). Proof. destruct n. - exact H. - apply LazyFurther. exact (fun _ => Qrecip_positives_help_Exists P (l tt) (Pos.succ p) H). Defined. Lemma Qrecip_positives_nbz : forall (n : Z) (d : positive) (U : 0 < n # d), NearBy 0 (Qpos2QposInf (exist _ (n # d) U)) (map (λ x : positive, 1 # x) (ppositives_help (Pplus_LazyNat 1 (LazyPred (LazyNat_of_P d))))). Proof. intros. apply Qrecip_positives_help_nbz. induction d using Pind;[simpl;auto with *|]. autorewrite with UnLazyNat in *. rewrite nat_of_P_succ_morphism; assert (H:=lt_O_nat_of_P d); destruct (nat_of_P d);[exfalso;auto with *|]; simpl in *; replace (Pplus_LazyNat 2 (LazifyNat n0)) with (Pos.succ (Pplus_LazyNat 1 (LazifyNat n0)));[ repeat rewrite Zpos_succ_morphism; auto with * |]; clear -n0; change 2%positive with (Pos.succ 1); generalize 1%positive; induction n0;intros p;[reflexivity|]; simpl in *; rewrite IHn0; reflexivity. Qed. #[global] Instance Qrecip_positives_zl : Limit Qrecip_positives 0. intros [[[n d] U] | ]; [| left; apply ForAll_True]. unfold Qrecip_positives. unfold ppositives. apply Qrecip_positives_help_Exists with (LazyPred (LazyNat_of_P d)). left. apply Qrecip_positives_nbz. Defined. (** [recip_positives] is [DecreasingNonNegative]. *) #[global] Instance Qrecip_positives_dnn : DecreasingNonNegative Qrecip_positives. Proof. unfold Qrecip_positives. unfold ppositives. generalize (1%positive) at 2. cofix Qrecip_positives_dnn. intros p. constructor. simpl. split. discriminate. change (Zpos p <= Zpos (Pos.succ p))%Z. repeat rewrite Zpos_succ_morphism. auto with *. simpl. apply Qrecip_positives_dnn. Qed. (** *** [pfactorials] The stream of factorials as positives. Again, we do not use [factorials] because [positive] does not form a semiring. *) CoFixpoint pfactorials_help (n c:positive) : Stream positive := Cons c (pfactorials_help (Pos.succ n) (n*c)). Definition pfactorials := pfactorials_help 1 1. Lemma Str_nth_pfactorials : forall n, nat_of_P (Str_nth n pfactorials) ≡ fact n. Proof. unfold pfactorials. intros n. pose (ONE:=1%positive). replace (fact n) with ((nat_of_P 1)*fact (pred (nat_of_P ONE) + n))%nat by (simpl;auto). replace (nat_of_P (Str_nth n (pfactorials_help 1 1))) with ((fact (pred (nat_of_P ONE)))*(nat_of_P (Str_nth n (pfactorials_help ONE 1))))%nat by (simpl; auto with * ). change (pfactorials_help 1 1) with (pfactorials_help ONE 1). generalize ONE. generalize 1%positive. unfold ONE; clear ONE. induction n. intros a b. unfold Str_nth. simpl. rewrite Nat.add_comm. now rewrite Nat.mul_comm. intros a b. unfold Str_nth in *. simpl. assert (X:=IHn (b*a)%positive (Pos.succ b)). clear IHn. rewrite nat_of_P_succ_morphism in X. rewrite <- plus_n_Sm. assert (forall (n m:nat), eq (Z_of_nat n) (Z_of_nat m) -> eq n m). { intros i j H. intuition. } apply H. clear H. apply Zmult_reg_l with (Z.of_nat (nat_of_P b)); [rewrite positive_nat_Z; auto with *|]. do 2 rewrite <- (inj_mult (nat_of_P b)). apply inj_eq. rewrite (Nat.mul_assoc (nat_of_P b) (nat_of_P a)). rewrite <- Pos2Nat.inj_mul. rewrite <- pred_Sn in X. change (S (pred (nat_of_P b) + n))%nat with (S (pred (nat_of_P b)) + n)%nat. assert (Z:S (pred (nat_of_P b)) = nat_of_P b). { apply (Nat.lt_succ_pred 0). apply Pos2Nat.is_pos. } rewrite Z. rewrite <- X. replace (fact (nat_of_P b)) with (fact (S (pred (nat_of_P b)))) by congruence. change (fact (S (pred (nat_of_P b)))) with ((S (pred (nat_of_P b)))*(fact (pred (nat_of_P b))))%nat. rewrite Z. ring. Qed. Lemma Str_nth_pfactorials' n : inject_Z (Zpos (Str_nth n pfactorials)) = Str_nth n factorials. Proof. rewrite Str_nth_factorials. rewrite <-Str_nth_pfactorials. rewrite <-(naturals.to_semiring_unique (Basics.compose inject_Z Z_of_nat)). unfold Basics.compose. rewrite positive_nat_Z. reflexivity. Qed. (** *** [Qrecip_factorials] The stream of 1/n!. **) Definition Qrecip_factorials := CoqStreams.map (fun x => 1#x) pfactorials. Lemma Str_nth_Qrecip_factorials : forall n, (Str_nth n Qrecip_factorials) = 1#(P_of_succ_nat (pred (fact n))). Proof. intros n. unfold Qrecip_factorials. rewrite Str_nth_map. rewrite <- Str_nth_pfactorials. unfold equiv, stdlib_rationals.Q_eq, Qeq. simpl. apply f_equal. transitivity (Pos.of_nat (Pos.to_nat (Str_nth n pfactorials))). 2: apply Pos2Nat.id. destruct (Pos.to_nat (Str_nth n pfactorials)) eqn:des. 2: apply Pos.of_nat_succ. exfalso. pose proof (Pos2Nat.is_pos (Str_nth n pfactorials)). rewrite des in H. inversion H. Qed. Lemma Str_nth_Qrecip_factorials' n : Str_nth n Qrecip_factorials = / Str_nth n factorials. Proof. unfold Qrecip_factorials. rewrite Str_nth_map. rewrite Qmake_Qdiv. rewrite Str_nth_pfactorials'. now apply (left_identity (/ Str_nth n factorials)). Qed. (** [Qrecip_factorials] is [DecreasingNonNegative]. *) #[global] Instance Qrecip_factorials_dnn : DecreasingNonNegative Qrecip_factorials. Proof. unfold Qrecip_factorials. unfold pfactorials. generalize (1%positive) at 3. generalize (1%positive) at 2. cofix Qrecip_factorials_dnn. intros a b. constructor. simpl. split. discriminate. apply (Z.mul_le_mono_nonneg_r 1 (Zpos a) (Zpos b)). discriminate. apply Pos.le_1_l. simpl. apply Qrecip_factorials_dnn. Qed. (** The limit of [Qrecip_factorial] is 0. *) Lemma Qrecip_factorial_bounded : StreamBounds Qrecip_positives (CoqStreams.tl Qrecip_factorials). Proof. unfold Qrecip_positives, Qrecip_factorials, ppositives, pfactorials. cut (forall (p q:positive), StreamBounds (CoqStreams.map (fun x : positive => 1 # x) (ppositives_help p)) (CoqStreams.tl (CoqStreams.map (fun x : positive => 1 # x) (pfactorials_help p q)))). intros H. apply (H 1%positive 1%positive). auto with *. cofix Qrecip_factorial_bounded. constructor. simpl. split. discriminate. change (Zpos p <= Zpos p * Zpos q)%Z. rewrite Z.mul_comm. apply (Z.mul_le_mono_nonneg_r 1 (Zpos q) (Zpos p)). discriminate. apply Pos.le_1_l. simpl in *. apply Qrecip_factorial_bounded. Qed. #[global] Instance Qrecip_factorials_zl : Limit Qrecip_factorials 0. Proof. intros e. right. intros _. apply (Stream_Bound_zl _ _ Qrecip_factorial_bounded). apply Qrecip_positives_zl. Defined. Section StreamGenerators. (* Strictly speaking those are generators of streams with a state X, or stream co-algebras, rather than actual streams. Instead of using corecursion to produce actual coinductive streams, we directly call the generator functions. The type Stream Y is isomorphic the type nat -> Y. We use the former to compute series such as exp x = sum_k x^k / k! because the (k+1)-th term is quickly computed from the k-th term, rather than recomputing the power and the factorial from 0 for each k. *) Variable X : Type. Variable f : X -> X. Fixpoint iterate (p : positive) (x : X) : X := match p with | xI q => iterate q (iterate q (f x)) | xO q => iterate q (iterate q x) | xH => f x end. Lemma iterate_one : forall x:X, iterate 1 x ≡ f x. Proof. reflexivity. Qed. Lemma iterate_shift : forall (p:positive) (x : X), f (iterate p x) ≡ iterate p (f x). Proof. induction p. - intro x. simpl. rewrite IHp, IHp. reflexivity. - intro x. simpl. rewrite IHp, IHp. reflexivity. - reflexivity. Qed. Lemma iterate_succ : forall (p:positive) (x : X), iterate (Pos.succ p) x ≡ f (iterate p x). Proof. induction p. - intro x. simpl. rewrite IHp. f_equal. rewrite IHp. f_equal. rewrite iterate_shift. reflexivity. - intro x. simpl. rewrite iterate_shift, iterate_shift. reflexivity. - reflexivity. Qed. Lemma iterate_add : forall (p q:positive) (x : X), iterate (p+q)%positive x ≡ iterate p (iterate q x). Proof. apply (Pos.peano_ind (fun p => forall (q : positive) (x : X), iterate (p + q) x ≡ iterate p (iterate q x))). - intros. rewrite Pos.add_1_l, iterate_succ. reflexivity. - intros. rewrite iterate_succ. rewrite <- Pos.add_1_l, <- Pos.add_assoc, Pos.add_1_l. rewrite iterate_succ, H. reflexivity. Qed. Variable stop : X -> bool. (* iterate_stop p x = iterate q x, where q = p or q < p and q is the lowest index such as stop (iterate q) = true. Testing whether the recursive iterate_stop stops regrettably adds a logarithmic useless number of stop tests. This could be improved by returning a pair X*bool to indicate that the iteration stopped. We could also try using a LazyNat fuel. *) Fixpoint iterate_stop (p : positive) (x : X) : X := match p with | xI q => (* p = 2q+1 *) let g := f x in if stop g then g else let h := iterate_stop q g in if stop h then h else iterate_stop q h | xO q => let g := iterate_stop q x in if stop g then g else iterate_stop q g | xH => f x end. (* The q below is even unique. Because it is either p or the first index where iterate stops. *) Lemma iterate_stop_correct : forall (p:positive) (x:X), exists q:positive, iterate_stop p x ≡ iterate q x /\ (forall r, Pos.lt r q -> stop (iterate r x) ≡ false) /\ (p ≡ q \/ (Pos.lt q p /\ stop (iterate q x) ≡ true)). Proof. induction p. - intro x. simpl. destruct (stop (f x)) eqn:des1. exists xH. split. reflexivity. split. intros. exfalso; exact (Pos.nlt_1_r r H). right. split. rewrite Pos.xI_succ_xO. apply Pos.lt_1_succ. exact des1. destruct (stop (iterate_stop p (f x))) eqn:des. + (* Stopped at p+1 by the stop predicate, prove that value is the same at 2p+1. *) specialize (IHp (f x)) as [q [itereq [H H0]]]. exists (Pos.succ q). split. rewrite itereq, iterate_succ, iterate_shift. reflexivity. split. apply (Pos.peano_case (fun r => (r < Pos.succ q)%positive → stop (iterate r x) ≡ false)). intros. exact des1. intros. rewrite iterate_succ, iterate_shift. apply H. apply Pos.succ_lt_mono in H1. exact H1. right. split. rewrite Pos.xI_succ_xO. rewrite <- Pos.succ_lt_mono. destruct H0. rewrite H0. rewrite <- Pos.add_diag. apply Pos.lt_add_r. apply (Pos.lt_trans _ p). apply H0. rewrite <- Pos.add_diag. apply Pos.lt_add_r. rewrite iterate_succ, iterate_shift, <- itereq. exact des. + pose proof (IHp (f x)) as [q [itereq [H H0]]]. destruct H0. 2: exfalso; destruct H0; rewrite <- itereq, des in H1; discriminate. subst q. specialize (IHp (iterate_stop p (f x))) as [q [qeq [H0 H1]]]. exists (Pos.succ q+p)%positive. split. rewrite qeq. rewrite <- Pos.add_1_r, <- Pos.add_assoc, iterate_add. apply f_equal. rewrite Pos.add_1_l, itereq, iterate_succ, iterate_shift. reflexivity. split. apply (Pos.peano_case (fun r => (r < Pos.succ q+p)%positive → stop (iterate r x) ≡ false)). intros. exact des1. intros r H2. rewrite iterate_succ, iterate_shift. destruct (Pos.lt_total r p). apply H, H3. destruct H3. rewrite H3. rewrite <- itereq. exact des. rewrite <- (Pplus_minus r p). 2: apply Pos.lt_gt, H3. rewrite Pos.add_comm, iterate_add, <- itereq. apply (H0 (r-p)%positive). rewrite <- (Pos.add_1_l q), <- Pos.add_assoc, Pos.add_1_l in H2. apply Pos.succ_lt_mono in H2. rewrite <- (Pplus_minus r p) in H2. 2: apply Pos.lt_gt, H3. rewrite Pos.add_comm in H2. apply Pos.add_lt_mono_r in H2. exact H2. destruct H1. left. rewrite H1. rewrite Pos.xI_succ_xO. rewrite <- (Pos.add_1_l q), <- Pos.add_assoc, Pos.add_1_l. rewrite Pos.add_diag. reflexivity. right. split. rewrite Pos.xI_succ_xO. rewrite <- Pos.add_1_l, <- Pos.add_assoc, Pos.add_1_l. rewrite <- Pos.succ_lt_mono, <- Pos.add_diag. apply Pos.add_lt_mono_r, H1. rewrite <- Pos.add_1_r, <- Pos.add_assoc, iterate_add. rewrite Pos.add_1_l, iterate_succ, iterate_shift. rewrite <- itereq. apply H1. - intro x. simpl. destruct (stop (iterate_stop p x)) eqn:des. + (* Stopped at p by the stop predicate, prove that value is the same at 2p. *) specialize (IHp x) as [q [itereq [H H0]]]. exists q. split. exact itereq. split. intros. apply H, H1. right. split. destruct H0. rewrite H0. rewrite <- Pos.add_diag. apply Pos.lt_add_r. apply (Pos.lt_trans _ p). apply H0. rewrite <- Pos.add_diag. apply Pos.lt_add_r. rewrite <- itereq. exact des. + pose proof (IHp x) as [q [itereq [H H0]]]. destruct H0. 2: exfalso; destruct H0; rewrite <- itereq, des in H1; discriminate. subst q. specialize (IHp (iterate_stop p x)) as [q [qeq [H0 H1]]]. exists (q+p)%positive. split. rewrite qeq, iterate_add. apply f_equal. exact itereq. split. intros. destruct (Pos.lt_total r p). apply H, H3. destruct H3. rewrite H3. clear H3 H2 r. rewrite <- itereq. exact des. rewrite <- (Pplus_minus r p). 2: apply Pos.lt_gt, H3. rewrite Pos.add_comm, iterate_add, <- itereq. apply (H0 (r-p)%positive). rewrite <- (Pplus_minus r p) in H2. 2: apply Pos.lt_gt, H3. rewrite Pos.add_comm in H2. apply Pos.add_lt_mono_r in H2. exact H2. destruct H1. left. rewrite H1. rewrite Pos.add_diag. reflexivity. right. split. rewrite <- Pos.add_diag. apply Pos.add_lt_mono_r, H1. rewrite iterate_add, <- itereq. apply H1. - intro x. exists xH. split. reflexivity. split. intros. exfalso; exact (Pos.nlt_1_r r H). left. reflexivity. Qed. Lemma iterate_stop_one : forall (x : X), iterate_stop 1 x ≡ f x. Proof. reflexivity. Qed. Lemma iterate_stop_indep : forall (p q : positive) (x : X), stop (iterate p x) ≡ true -> stop (iterate q x) ≡ true -> iterate_stop p x ≡ iterate_stop q x. Proof. intros. pose proof (iterate_stop_correct p x) as [r [rpeq [H1 H2]]]. assert (stop (iterate r x) ≡ true) as rstop. { destruct H2. rewrite <- H2. exact H. apply H2. } rewrite rpeq. clear H2 rpeq H p. pose proof (iterate_stop_correct q x) as [s [sqeq [H H2]]]. assert (stop (iterate s x) ≡ true) as sstop. { destruct H2. rewrite <- H2. exact H0. apply H2. } rewrite sqeq. clear H2 sqeq H0 q. destruct (Pos.lt_total r s). - exfalso. specialize (H r H0). rewrite H in rstop. discriminate. - destruct H0. rewrite H0. reflexivity. exfalso. specialize (H1 s H0). rewrite H1 in sstop. discriminate. Qed. Lemma iterate_stop_unique : forall (p q : positive) (x : X), stop (iterate p x) ≡ true -> stop (iterate q x) ≡ true -> (forall i:positive, Pos.lt i q -> stop (iterate i x) ≡ false) -> iterate_stop p x ≡ iterate q x. Proof. intros. pose proof (iterate_stop_correct p x) as [r [rpeq [H2 H3]]]. rewrite rpeq. replace r with q. reflexivity. destruct (Pos.lt_total q r). - exfalso. specialize (H2 q H4). rewrite H0 in H2. discriminate. - destruct H4. exact H4. exfalso. destruct H3. + subst r. specialize (H1 p H4). rewrite H in H1. discriminate. + destruct H3. specialize (H1 r H4). rewrite H1 in H5. discriminate. Qed. Definition CRstream_opp (X:Type) (f : X*Q->X*Q) (xq : X*Q) : X*Q := let (x,q) := xq in let (y,r) := f (x,-q) in (y,-r). End StreamGenerators. Lemma CRstream_opp_pth : forall (X:Type) (f : X*Q->X*Q) (xq : X*Q) (p : positive), let (y,r) := iterate _ f p xq in let (z,s) := iterate _ (CRstream_opp X f) p (let (x,q):=xq in (x,-q)) in y ≡ z /\ s ≡ -r. Proof. intros X f xq. apply Pos.peano_ind. - simpl. destruct xq as [x q]. unfold CRstream_opp. replace (--q) with q. destruct (f (x,q)). split; reflexivity. destruct q. unfold Qopp; simpl. rewrite Z.opp_involutive. reflexivity. - intros IHp H. rewrite CRstreams.iterate_succ, CRstreams.iterate_succ. destruct (iterate _ f IHp xq), (iterate _ (CRstream_opp X f) IHp (let (x0, q0) := xq in (x0, - q0))). unfold CRstream_opp. destruct H. subst q0. subst x0. replace (--q) with q. destruct (f (x,q)). split; reflexivity. destruct q. unfold Qopp; simpl. rewrite Z.opp_involutive. reflexivity. Qed. corn-8.20.0/reals/fast/CRsum.v000066400000000000000000000227501473720167500160470ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.reals.fast.CRArith. Require Import CoRN.stdlib_omissions.List. Require Import CoRN.model.metric2.Qmetric. Local Open Scope Q_scope. (* Equi-distribute the error e on all terms, which is on average faster than dividing e by 2 for each term. *) Definition CRsum_list_raw (l:list CR) (e:QposInf) : Q := fold_left Qplus match l with | nil => nil | cons h t => let e' := QposInf_mult (Qpos2QposInf (1#(P_of_succ_nat (length t))))%Qpos e in (map (fun x => approximate x e') l) end 0. Lemma CRsum_list_prf : forall l, is_RegularFunction Qball (CRsum_list_raw l). Proof. intros [|a t] e1 e2. apply ball_refl. apply (Qpos_nonneg (e1 + e2)). unfold CRsum_list_raw. simpl. set (p:=P_of_succ_nat (@length (RegularFunction Qball) t)). set (e1':=((1 # p) * e1)%Qpos). set (e2':=((1 # p) * e2)%Qpos). simpl in e1'. fold e1'. simpl in e2'. fold e2'. assert (Qball (proj1_sig e1' + proj1_sig e2') (0 + @approximate Q Qball a e1') (0 + @approximate Q Qball a e2')) as H. { rewrite Qplus_0_l, Qplus_0_l. apply (regFun_prf a). } assert (forall e:Qpos, proj1_sig ((1 # p) * e)%Qpos * inject_Z (Z.of_nat (length t)) + proj1_sig ((1 # p) * e)%Qpos <= proj1_sig e) as X. { intros e. simpl. setoid_replace ((1 # p) * proj1_sig e * (Z.of_nat (length t) # 1) + (1 # p) * proj1_sig e)%Q with ((1#p)*((Z.of_nat (length t) #1) + (1#1))* proj1_sig e)%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- (Qmult_1_l (proj1_sig e)) at 2. apply Qmult_le_r. apply Qpos_ispos. unfold Qmult, Qplus, Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_r. rewrite Z.mul_1_l, Z.mul_1_l, Pos.mul_1_r. unfold p. rewrite Z.P_of_succ_nat_Zplus. apply Z.le_refl. } generalize (X e1) (X e2). simpl ((1 # p) * e1)%Qpos. simpl ((1 # p) * e2)%Qpos. fold e1' e2'. unfold e1' at 1 3. unfold e2' at 1 3. generalize (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Zpos xH; Qden := p |} (@eq_refl comparison Lt)) e1) (Qpos_mult (@exist Q (Qlt {| Qnum := Z0; Qden := xH |}) {| Qnum := Zpos xH; Qden := p |} (@eq_refl comparison Lt)) e2) e1' e2' (0 + @approximate Q Qball a e1') (0 + @approximate Q Qball a e2') H. clear - t. induction t; intros e1'' e2'' e1' e2' x y Hxy H1 H2. - simpl in *. ring_simplify in H1. ring_simplify in H2. apply (@ball_weak_le Q_as_MetricSpace (proj1_sig e1' + proj1_sig e2')); auto. apply Qplus_le_compat; auto. - simpl in *. change (Zpos (P_of_succ_nat (length t))) with (Z_of_nat (1+(length t))) in H1. change (Zpos (P_of_succ_nat (length t))) with (Z_of_nat (1+(length t))) in H2. rewrite -> inj_plus in *. rewrite -> Q.Zplus_Qplus in *. ring_simplify in H1. ring_simplify in H2. apply (IHt e1'' e2'' (e1'' + e1')%Qpos (e2'' + e2')%Qpos); try (autorewrite with QposElim; ring_simplify; assumption). unfold Qball. autorewrite with QposElim. unfold QAbsSmall. setoid_replace (x + approximate a e1'' - (y + approximate a e2''))%Q with ((x - y) + (approximate a e1'' - approximate a e2'')) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). simpl. setoid_replace (proj1_sig e1'' + proj1_sig e1' + (proj1_sig e2'' + proj1_sig e2'))%Q with ((proj1_sig e1' + proj1_sig e2') + (proj1_sig e1'' + proj1_sig e2''))%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). apply QAbsSmall_plus. auto. apply (regFun_prf a). simpl. rewrite Qplus_assoc. assumption. simpl. rewrite Qplus_assoc. assumption. Qed. Definition CRsum_list (l:list CR) : CR := Build_RegularFunction (CRsum_list_prf l). Lemma CRsum_correct : forall l, (CRsum_list l == fold_right (fun x y => x + y) 0 l)%CR. Proof. induction l. apply regFunEq_equiv, regFunEq_e; intros e. apply ball_refl. apply (Qpos_nonneg (e+e)). simpl (fold_right (fun x y : CR => (x + y)%CR) 0%CR (a :: l)). rewrite <- IHl. clear -l. apply regFunEq_equiv, regFunEq_e; intros e. simpl. unfold Cap_raw. simpl. unfold CRsum_list_raw. simpl. destruct l; simpl. rewrite Qplus_0_l, Qplus_0_r. setoid_replace (proj1_sig e+proj1_sig e) with (proj1_sig ((1 # 1) *e + (1 # 2) * e + (1 # 2) * e))%Qpos by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). change (Qball (proj1_sig ((1 # 1) * e + (1 # 2) * e + (1 # 2) * e)%Qpos) (approximate a ((1 # 1) * e)%Qpos) (approximate a ((1 # 2) * e)%Qpos)). apply ball_weak. apply Qpos_nonneg. apply regFun_prf. set (n:= (@length (RegularFunction Qball) l)). cut (forall (z1:Q) (e3 e5 e1 e2 e4 e6:Qpos) (z2 z3:Q), ball (proj1_sig e5) z1 z2 -> (z3 == approximate a e3 + z1) -> (proj1_sig e1*(Z.of_nat n#1) + proj1_sig e2*(Z.of_nat n#1) +proj1_sig e3 + proj1_sig e4 + proj1_sig e5 <= proj1_sig e6) -> Qball (proj1_sig e6) (fold_left Qplus (map (fun x : RegularFunction Qball => approximate x e1) l) z3) (approximate a e4 + fold_left Qplus (map (fun x : RegularFunction Qball => approximate x e2) l) z2)). { intros H. apply (H (approximate m ((1 # Pos.succ (P_of_succ_nat n)) * e)%Qpos) ((1 # Pos.succ (P_of_succ_nat n)) * e)%Qpos ((1 # Pos.succ (P_of_succ_nat n)) * e + (1 # P_of_succ_nat n) * ((1 # 2) * e))%Qpos _ _ _ (e+e)%Qpos). 2: rewrite Qplus_0_l; reflexivity. pose proof (Qplus_0_l (approximate m ((1 # Pos.of_succ_nat n) * ((1 # 2) * e))%Qpos)). apply Qball_0 in H0. rewrite H0. apply regFun_prf. simpl. apply (Qle_trans _ ((1 # Pos.succ (P_of_succ_nat n)) * ((2#1)+(Z.of_nat n#1)) *proj1_sig e + ((1 # P_of_succ_nat n) * ((1#1) + (Z.of_nat n#1)) * ((1 # 2) * proj1_sig e) + (1 # 2) * proj1_sig e))). ring_simplify; apply Qle_refl. setoid_replace ((1 # Pos.succ (Pos.of_succ_nat n)) * ((2#1) + (Z.of_nat n#1))) with (1#1)%Q. setoid_replace ((1 # Pos.of_succ_nat n) * ((1#1) + (Z.of_nat n#1))) with (1#1)%Q. field_simplify. setoid_replace (8 # 4) with (2#1) by reflexivity. apply Qle_refl. unfold Qmult, inject_Z, Qplus, Qeq, Qnum, Qden. ring_simplify. rewrite Pos.mul_1_r. unfold canonical_names.equiv, stdlib_rationals.Q_eq. rewrite Z.mul_1_l, Z.mul_1_l, Z.mul_1_r, Z.add_comm. rewrite <- Z.P_of_succ_nat_Zplus. unfold Qeq; simpl. rewrite Pos.mul_1_r. reflexivity. unfold canonical_names.equiv, stdlib_rationals.Q_eq. unfold Qmult, inject_Z, Qplus, Qeq, Qnum, Qden. ring_simplify. rewrite Pos.mul_1_r. rewrite <- SuccNat2Pos.inj_succ. rewrite Z.P_of_succ_nat_Zplus. replace (S n) with (1+n)%nat by reflexivity. rewrite Nat2Z.inj_add. rewrite (Z.add_comm 1). rewrite <- Z.add_assoc. reflexivity. } unfold n. clear n. induction l; intros z1 e3 e5 e1 e2 e4 e6 z2 z3 Hz H0 H. simpl in *. ring_simplify in H. ring_simplify. apply Qball_0 in H0. rewrite -> H0. unfold Qball. unfold QAbsSmall. setoid_replace (approximate a e3 + z1 - (approximate a e4 + z2)) with ((approximate a e3 - approximate a e4) + (z1 - z2)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). pose proof (@ball_weak_le Q_as_MetricSpace (proj1_sig e3 + proj1_sig e4 + proj1_sig e5) (proj1_sig e6) (approximate a e3 - approximate a e4 + (z1 - z2)) 0). simpl in H1. unfold Qball, QAbsSmall, Qminus in H1. rewrite Qplus_0_r in H1. apply H1. exact H. apply QAbsSmall_plus; auto. apply (regFun_prf a). simpl. apply (IHl (z1 + approximate a0 e1) e3 (e5 + (e1 + e2))%Qpos). simpl. unfold Qball. unfold QAbsSmall. setoid_replace (z1 + approximate a0 e1 - (z2 + approximate a0 e2)) with ((z1 - z2) + (approximate a0 e1 - approximate a0 e2)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). apply QAbsSmall_plus. auto. apply (regFun_prf a0). rewrite -> H0. simpl; ring. simpl. simpl in H. set (n:= (@length (RegularFunction Qball) l)) in *. change (Zpos (P_of_succ_nat n)) with (Z_of_nat (1+n)) in H. rewrite inj_plus in H. refine (Qle_trans _ _ _ _ H). clear H. setoid_replace (Z.of_nat 1 + Z.of_nat n # 1)%Q with ((1#1) + (Z.of_nat n # 1)). ring_simplify. apply Qle_refl. unfold canonical_names.equiv, stdlib_rationals.Q_eq. unfold Qeq, Qplus, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_r, Z.mul_1_r. reflexivity. Qed. corn-8.20.0/reals/fast/CRtrans.v000066400000000000000000000030051473720167500163620ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) (* This file rexports all the transcendental functions defined on CR *) Require Export CoRN.reals.fast.CRArith. Require Export CoRN.reals.fast.Compress. Require Export CoRN.reals.fast.CRpower. Require Export CoRN.reals.fast.CRroot. Require Export CoRN.reals.fast.CRexp. Require Export CoRN.reals.fast.CRln. Require Export CoRN.reals.fast.CRsin. Require Export CoRN.reals.fast.CRcos. Require Export CoRN.reals.fast.CRpi. Require Export CoRN.reals.fast.CRarctan. Require Export CoRN.reals.fast.CRabs. corn-8.20.0/reals/fast/Compress.v000066400000000000000000000155031473720167500166070ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.model.metric2.CRmetric. Require Import CoRN.model.metric2.Qmetric. From Coq Require Import Zdiv. Opaque CR. Local Open Scope Q_scope. Local Open Scope uc_scope. (** ** Compression Compress improves the computation by reducing the size of the numerator and denominator of rational numbers. It works by increasing the requested precession, but then rounding the result to a value with a small numerator and denominator. The full euclidean algortihm would find the optimial rational approximation. But for speed we simply do division to quickly find a good rational approximation. *) Definition approximateQ (x:Q) (p:positive) := let (n,d) := x in (Z.div (n*Zpos p) (Zpos d)#p). Lemma approximateQ_correct : forall x p, ball (1#p) x (approximateQ x p). Proof. intros [n d] p. split; simpl; unfold Qle; simpl. - apply Z.le_trans with 0%Z. discriminate. apply Zmult_le_0_compat; auto with *. replace (n * Zpos p + - (n * Zpos p / Zpos d) * Zpos d)%Z with (n * Zpos p - ((n * Zpos p / Zpos d) * Zpos d))%Z by ring. apply Zle_minus_le_0. rewrite Zmult_comm. apply Z_mult_div_ge; auto with *. - rewrite Zpos_mult_morphism. apply Zmult_le_compat_r; auto with *. replace (n * Zpos p + - (n * Zpos p / Zpos d) * Zpos d)%Z with ((n*Zpos p) mod (Zpos d))%Z. destruct (Z_mod_lt (n*Zpos p) (Zpos d)); auto with *. symmetry. transitivity (n * Zpos p - (Zpos d*(n * Zpos p / Zpos d)))%Z;[ring|]. symmetry. apply -> Zeq_plus_swap. rewrite Zplus_comm. symmetry. apply Z_div_mod_eq_full. Qed. Lemma approximateQ_big : forall (z:Z) a p, ((z#1) <= a) -> (z#1) <= approximateQ a p. Proof. intros z [n d] p Ha. unfold approximateQ. unfold Qle in *. simpl in *. apply Zlt_succ_le. unfold Z.succ. apply Zmult_gt_0_lt_reg_r with (Zpos d). reflexivity. replace ((n * Zpos p / Zpos d * 1 + 1) * Zpos d)%Z with (Zpos d* (n*Zpos p/ Zpos d) + (Z.modulo (n*Zpos p) (Zpos d)) - (Z.modulo (n*Zpos p) (Zpos d)) + Zpos d)%Z by ring. rewrite <- (Z_div_mod_eq_full (n*Zpos p) (Zpos d)). apply Z.le_lt_trans with (n*1*Zpos p)%Z. replace (z*Zpos p*Zpos d)%Z with (z*Zpos d*Zpos p)%Z by ring. apply Zmult_lt_0_le_compat_r; auto with *. apply Zlt_0_minus_lt. replace (n * Zpos p - (n * Zpos p) mod (Zpos d) + Zpos d - n * 1 * Zpos p)%Z with (Zpos d - (Z.modulo (n*Zpos p) (Zpos d)))%Z by ring. rewrite <- Zlt_plus_swap. ring_simplify. assert (X:(Zpos d >0)%Z) by auto with *. destruct (Z_mod_lt (n*Zpos p) _ X). assumption. Qed. (** Compress doubles the requried precision and uses the extra leway to round the rational number. *) Definition compress_raw (x:CR) (e:QposInf) : Q := match e with | QposInfinity => approximate x e | Qpos2QposInf e => let (n,d) := proj1_sig e in match (Z.succ (Z.div (2*Zpos d) n)) with Zpos p => approximateQ (approximate x (Qpos2QposInf (exist (Qlt 0) (1#p) eq_refl))) p |_ => approximate x e end end. Lemma compress_raw_prop : forall x (e:Qpos), ball (proj1_sig e) x (Cunit (compress_raw x e)). Proof. intros x. intros [[n d] dpos]. destruct n as [|n|n]. inversion dpos. 2: inversion dpos. simpl. assert (0 < Z.succ (Zpos (d~0)%positive / Zpos n))%Z as zpos. { unfold Z.succ. apply (Z.lt_le_trans _ (0+1)). reflexivity. apply Z.add_le_mono_r. apply Z_div_pos. reflexivity. discriminate. } destruct (Z.succ (Zpos (xO d) / Zpos n)) eqn:Hp. - exfalso. discriminate. - apply ball_weak_le with (2#p). unfold Qle. simpl. rewrite Zpos_mult_morphism. rewrite <- Hp. unfold Z.succ. rewrite Zmult_plus_distr_r. apply Zle_0_minus_le. replace (Zpos n * (Zpos (d~0)%positive / Zpos n) + Zpos n * 1 - Zpos (d~0)%positive)%Z with (Zpos n - (Zpos (xO d) - Zpos n * (Zpos (xO d) / Zpos n)))%Z by ring. apply Zle_minus_le_0. replace (Zpos (d~0)%positive - Zpos n * (Zpos (d~0)%positive / Zpos n))%Z with (Zpos (xO d) mod (Zpos n))%Z. destruct (Z_mod_lt (Zpos (xO d)) (Zpos n)); auto with *. symmetry. transitivity (Zpos (xO d) - (Zpos n*(Zpos (xO d) / Zpos n)))%Z;[ring|]. symmetry; apply -> Zeq_plus_swap. rewrite Zplus_comm. symmetry. apply Z_div_mod_eq_full. assert (QposEq (2#p) ((1#p)+(1#p))). { unfold QposEq. simpl. repeat rewrite -> Qmake_Qdiv. unfold Qdiv. ring. } apply (ball_wd _ H _ _ (reflexivity _) _ _ (reflexivity _)). clear H. eapply ball_triangle with (Cunit (approximate x (Qpos2QposInf (1#p)))). apply ball_approx_r. Transparent CR. change (ball (m:=Complete Q_as_MetricSpace) (1 # p) (Cunit (approximate x (Qpos2QposInf (1 # p)))) (Cunit (approximateQ (approximate x (Qpos2QposInf (1 # p))) p))). rewrite -> ball_Cunit. apply approximateQ_correct. - exfalso. discriminate. Qed. Lemma compress_raw_prf : forall x, is_RegularFunction (@ball Q_as_MetricSpace) (compress_raw x). Proof. intros x e1 e2. rewrite <- ball_Cunit. eapply ball_triangle;[|apply compress_raw_prop]. apply ball_sym. apply compress_raw_prop. Qed. Definition compress_fun (x:CR) : CR := Build_RegularFunction (compress_raw_prf x). (** Compress is equivalent to the identity function. *) Lemma compress_fun_correct : forall x, (compress_fun x==x)%CR. Proof. intros x. apply regFunEq_equiv, regFunEq_e. intros e. unfold compress_fun. unfold approximate at 1. rewrite <- ball_Cunit. eapply ball_triangle;[|apply ball_approx_r]. apply ball_sym. apply compress_raw_prop. Qed. Lemma compress_uc : is_UniformlyContinuousFunction compress_fun Qpos2QposInf. Proof. intros e x y H. do 2 rewrite -> compress_fun_correct. assumption. Qed. Definition compress : CR --> CR := Build_UniformlyContinuousFunction compress_uc. Lemma compress_correct : forall x, (compress x==x)%CR. Proof. intros x. apply compress_fun_correct. Qed. corn-8.20.0/reals/fast/ContinuousCorrect.v000066400000000000000000000135461473720167500205110ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.Q_in_CReals. Require Export CoRN.ftc.MoreIntervals. Require Export CoRN.reals.fast.CRIR. Require Import CoRN.tactics.CornTac. Require Export CoRN.model.metric2.Qmetric. Require Export CoRN.model.totalorder.QposMinMax. Opaque CR inj_Q. Set Implicit Arguments. Local Open Scope uc_scope. (** ** Correctness of continuous functions. We show that if two functions, one on IR and one on CR, agree on the rational values of some closed interval, and both functions are continuous, then the two functions agree on that entire closed interval. This is our main method of proving the corrections of functions defined on CR. *) Lemma Q_dense_in_compact : forall a b (Hab : a[<=]b) x, a[<]b -> Compact Hab x -> forall e, [0][<]e -> {q:Q | Compact Hab (inj_Q IR q) | AbsSmall e (x[-]inj_Q IR q)}. Proof. intros a b Hab x Hab0 Hx e He. set (l:=Max a (x[-]e)). set (r:=Min b (x[+]e)). assert (Hlr:l[<]r). destruct Hx as [Hx0 Hx1]. apply less_Min; apply Max_less. assumption. apply shift_minus_less. rstepl (x[+][0]). apply plus_resp_leEq_less; assumption. rstepl (a[+][0]). apply plus_resp_leEq_less; assumption. apply shift_zero_less_minus'. rstepr (e[+]e). apply plus_resp_pos; assumption. destruct (Q_dense_in_CReals' _ _ _ Hlr) as [q Hlq Hqr]. exists q; split. eapply leEq_transitive. apply lft_leEq_Max. apply less_leEq; unfold l in Hlq; apply Hlq. eapply leEq_transitive. apply less_leEq;apply Hqr. apply Min_leEq_lft. apply shift_zero_leEq_minus'. rstepr ((x[+]e)[-]inj_Q IR q). apply shift_zero_leEq_minus. eapply leEq_transitive. apply less_leEq. apply Hqr. apply Min_leEq_rht. apply shift_zero_leEq_minus'. rstepr (inj_Q IR q[-](x[-]e)). apply shift_zero_leEq_minus. eapply leEq_transitive. apply rht_leEq_Max. apply less_leEq. unfold l in Hlq; apply Hlq. Qed. Section ContinuousCorrect. Variable I : interval. Hypothesis HI : proper I. Variable f : PartFunct IR. Hypothesis Hf : Continuous I f. Variable g : CR --> CR. Hypothesis Hg : forall (q:Q) Hq, I (inj_Q IR q) -> (g (' q) == IRasCR (f (inj_Q IR q) Hq))%CR. Lemma ContinuousCorrect : forall (x:IR) Hx, I x -> (IRasCR (f x Hx) == g (IRasCR x))%CR. Proof. intros x Hx H. set (J:=compact_in_interval I HI x H). apply ball_eq. intros e epos. assert (HJ:compact_ J) by apply compact_compact_in_interval. destruct Hf as [Hf1 Hf0]. clear Hf. assert (X:Continuous_I (Lend_leEq_Rend J HJ) f). apply Hf0. eapply included_trans;[|apply included_compact_in_interval]. unfold J; apply iprop_compact_in_interval_inc1. clear Hf0. destruct X as [_ X]. assert (He : [0][<](inj_Q IR (proj1_sig ((1#2)*exist _ _ epos)%Qpos))). stepl (inj_Q IR (nring 0)); [| now apply (inj_Q_nring IR 0)]. apply inj_Q_less. apply Qpos_ispos. destruct (X _ He) as [d0 Hd0 Hf]. clear X. set (d1:=mu g ((1#2)*exist _ _ epos)). set (Hab := (Lend_leEq_Rend J HJ)) in *. set (a:= (@Lend J HJ)) in *. set (b:= (@Rend J HJ)) in *. assert (HJ':included (Compact Hab) I). eapply included_trans. unfold Hab, a, b, J; apply iprop_compact_in_interval_inc1. apply included_compact_in_interval. assert (Hab0: a[<]b). apply proper_compact_in_interval'. assert (HJx:(Compact Hab) x). apply iprop_compact_in_interval'. clearbody Hab a b. clear J HJ. pose (d:=match d1 with | Qpos2QposInf q => Min (inj_Q IR (proj1_sig q)) d0 | QposInfinity => d0 end). assert (H0d : [0][<]d). destruct d1; try assumption. apply less_Min; try assumption. stepl (inj_Q IR [0]). apply inj_Q_less. apply Qpos_ispos. apply (inj_Q_nring IR 0). destruct (Q_dense_in_compact Hab0 HJx _ H0d) as [q Hq0 Hq1]. setoid_replace e with (proj1_sig ((1#2)*exist _ _ epos+(1#2)*exist _ _ epos))%Qpos by (simpl; ring). assert (Hfq : Dom f (inj_Q IR q)). apply Hf1. apply HJ'. assumption. apply ball_triangle with (IRasCR (f (inj_Q IR q) Hfq)). rewrite <- CRAbsSmall_ball. stepr (IRasCR (f x Hx[-]f (inj_Q IR q) Hfq)); [| now (simpl; apply IR_minus_as_CR)]. stepl (IRasCR (inj_Q IR (proj1_sig ((1 # 2) * exist _ _ epos)%Qpos))); [| now (simpl; apply IR_inj_Q_as_CR)]. rewrite <- IR_AbsSmall_as_CR. apply AbsIR_imp_AbsSmall. apply Hf; try assumption. eapply leEq_transitive. apply AbsSmall_imp_AbsIR. apply Hq1. destruct d1. apply Min_leEq_rht. apply leEq_reflexive. rewrite <- Hg;[|apply HJ';assumption]. apply uc_prf. fold d1. destruct d1; try constructor. simpl. rewrite <- IR_inj_Q_as_CR. rewrite <- CRAbsSmall_ball. stepr (IRasCR (inj_Q IR q[-]x)); [| now (simpl; apply IR_minus_as_CR)]. stepl (IRasCR (inj_Q IR (proj1_sig q0))); [| now (simpl; apply IR_inj_Q_as_CR)]. rewrite <- IR_AbsSmall_as_CR. apply AbsSmall_minus. eapply AbsSmall_leEq_trans;[|apply Hq1]. apply Min_leEq_lft. Qed. End ContinuousCorrect. corn-8.20.0/reals/fast/Integration.v000066400000000000000000001123601473720167500172760ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.model.metric2.IntegrableFunction. Require Export CoRN.model.metric2.BoundedFunction. Require Export CoRN.model.metric2.CRmetric. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRIR. Require Import CoRN.ftc.Integral. Require Import CoRN.model.structures.StepQsec. Require Import CoRN.model.structures.OpenUnit. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Qabs. Require Import CoRN.tactics.Qauto. From Coq Require Import Qround. Require Import CoRN.model.metric2.L1metric. Require Import CoRN.model.metric2.LinfMetric. Require Import CoRN.model.ordfields.Qordfield. Require Import CoRN.algebra.COrdFields2. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.reals.fast.ContinuousCorrect. Require Import CoRN.ftc.IntegrationRules. Require Import CoRN.ftc.MoreIntegrals. Require Import CoRN.tactics.CornTac. Require Import CoRN.model.metric2.LinfDistMonad. Set Implicit Arguments. Opaque Qmax Qabs inj_Q. Local Open Scope Q_scope. (** * Effective Integration ** stepSample The first step in defining integration is to define the unit function on [[0,1]] as a [Bounded Function]. This is defined to be the limit of step functions approximating the unit function. For efficenty reasons we want this approximation to be as good as we can muster because the number of steps this approximation returns will be the number of samples that we will take of the function we want to integrate. Furthermore, we want the tree structure defining the step function to be as balanced as possible. First we create a step function with n steps that appoximates the identity function, [stepSample]. *) Lemma oddGluePoint (p:positive) : 0 < Pos.succ p # xI p /\ Pos.succ p # xI p < 1. Proof. split; unfold Qlt. constructor. simpl. rewrite Pmult_comm. simpl. apply Zlt_left_rev. rewrite Zpos_succ_morphism, Zpos_xI. unfold Z.succ. ring_simplify. auto with *. Qed. Local Open Scope setoid_scope. Local Open Scope sfstscope. Local Open Scope StepQ_scope. Definition stepSample : positive -> StepQ := positive_rect2 (fun _ => StepQ) (fun p rec1 rec2 => glue (Build_OpenUnit (oddGluePoint p)) (constStepF (Pos.succ p#xI p:QS) * rec1) ((constStepF (1#(xI p):QS))*(constStepF (Pos.succ p:QS) + constStepF (p:QS)*rec2))) (fun p rec => glue (ou (1#2)) (constStepF (1#2:QS) * rec) (constStepF (1#2:QS) * (constStepF (1:QS) + rec))) (constStepF (1#2:QS)). (** We want to prove that [stepSample n] is within (1/(2*n)) of the identity function, but the identity function doesn't exist yet. Instead we define the [SupDistanceToLinear] which computes what would the distance to a linear function on [[0,1]]. This distance function is transitive in the sense that if a step function x is within e1 of a linear function, and a step function y is within e2 of the same linear function, then x and y are really within (e1+e2) of each other (in Linf).*) Section id01. Lemma SupDistanceToLinearBase_pos : forall (l r:Q) (H:l Qlt_minus_iff in H0. unfold Qminus. eapply Qlt_le_trans; [|apply Qmax_ub_l]. assumption. rewrite -> Qlt_minus_iff in H. eapply Qlt_le_trans; [|apply Qmax_ub_r]. eapply Qlt_le_trans. apply H. unfold Qminus. apply: plus_resp_leEq_lft;simpl;auto with *. Qed. Definition SupDistanceToLinear := StepFfold (fun (x:QS) (l r:Q) (H:l < r) => exist (Qlt 0) _ (SupDistanceToLinearBase_pos H x)) (fun b f g l r H => (Qpos_max (f _ _ (affineCombo_gt (OpenUnitDual b) H)) (g _ _ (affineCombo_lt (OpenUnitDual b) H)))). (** Various properties of [SupDistanceToLinear] *) Lemma SupDistanceToLinear_glue : forall o l r a b (H:a < b), (proj1_sig (SupDistanceToLinear (glue o l r) H) == Qmax (proj1_sig (SupDistanceToLinear l (affineCombo_gt (OpenUnitDual o) H))) (proj1_sig (SupDistanceToLinear r (affineCombo_lt (OpenUnitDual o) H))))%Q. Proof. intros o l r a b H. unfold SupDistanceToLinear at 1. simpl. autorewrite with QposElim. reflexivity. Qed. Lemma SupDistanceToLinear_wd1 : forall x l1 r1 (H1:l1 < r1) l2 r2 (H2:l2 < r2), (l1 == l2 -> r1 == r2 -> QposEq (SupDistanceToLinear x H1) (SupDistanceToLinear x H2))%Q. Proof. induction x; intros l1 r1 H1 l2 r2 H2 Hl Hr. - unfold SupDistanceToLinear. unfold QposEq. simpl. rewrite -> Hl. rewrite -> Hr. reflexivity. - unfold QposEq. do 2 rewrite -> SupDistanceToLinear_glue. assert (X:(affineCombo (OpenUnitDual o) l1 r1==affineCombo (OpenUnitDual o) l2 r2)%Q). rewrite -> Hl. rewrite -> Hr. reflexivity. apply Qmax_compat. apply IHx1; auto. apply IHx2; auto. Qed. Lemma Qmax_affineCombo : forall x a b o, a < b -> (Qmax (Qmax (x - a) (affineCombo o a b - x)) (Qmax (x - affineCombo o a b) (b - x)) == Qmax (x - a) (b - x))%Q. Proof. intros x a b o H. rewrite <- Qmax_assoc. rewrite -> (Qmax_assoc (affineCombo o a b - x)). rewrite -> (Qmax_comm (affineCombo o a b - x)). rewrite <- (Qmax_assoc (x - affineCombo o a b)). rewrite -> Qmax_assoc. apply Qmax_compat. rewrite <- Qle_max_l. apply: plus_resp_leEq_lft;simpl; auto with *. rewrite <- Qle_max_r. apply: plus_resp_leEq;simpl;auto with *. Qed. Lemma SupDistanceToLinear_split : forall x o a b c (H0:a < c) (H1:c < b), (c == affineCombo (OpenUnitDual o) a b)%Q -> (Qmax (proj1_sig (SupDistanceToLinear (SplitL x o) H0)) (proj1_sig (SupDistanceToLinear (SplitR x o) H1)) == proj1_sig (SupDistanceToLinear x (Qlt_trans _ _ _ H0 H1)))%Q. Proof. induction x. intros o a b c H0 H1 Hc. unfold SupDistanceToLinear. simpl. autorewrite with QposElim. rewrite -> Hc. apply Qmax_affineCombo; auto with *. apply Qlt_trans with c; assumption. intros p a b c H0 H1 Hc. apply SplitLR_glue_ind; intros H. do 2 rewrite -> SupDistanceToLinear_glue. rewrite -> Qmax_assoc. rewrite -> IHx1. apply Qmax_compat; apply SupDistanceToLinear_wd1; try reflexivity; rewrite -> Hc; unfold affineCombo; simpl; field; auto with *. rewrite -> Hc. unfold affineCombo. simpl. field; auto with *. do 2 rewrite -> SupDistanceToLinear_glue. rewrite <- Qmax_assoc. rewrite -> IHx2. apply Qmax_compat; apply SupDistanceToLinear_wd1; try reflexivity; rewrite -> Hc; unfold affineCombo; simpl; field; auto with *. rewrite -> Hc. unfold affineCombo. simpl. field; auto with *. rewrite -> SupDistanceToLinear_glue. apply Qmax_compat; apply SupDistanceToLinear_wd1; try reflexivity; rewrite -> Hc; unfold affineCombo; simpl; rewrite -> H; field; auto with *. Qed. Lemma SupDistanceToLinear_wd2 : forall x1 x2 a b (H: a < b), x1 == x2 -> QposEq (SupDistanceToLinear x1 H) (SupDistanceToLinear x2 H). Proof. induction x1. induction x2. intros a b H Hx. unfold SupDistanceToLinear. simpl in *. autorewrite with QposElim. change (x == x0)%Q in Hx. unfold QposEq. simpl. rewrite -> Hx. reflexivity. intros a b H Hx. destruct Hx as [H0 H1] using (eq_glue_ind x2_1). unfold QposEq. simpl. rewrite -> SupDistanceToLinear_glue. unfold QposEq in IHx2_1. rewrite <- IHx2_1; auto with *. unfold QposEq in IHx2_2. rewrite <- IHx2_2; auto with *. unfold SupDistanceToLinear. simpl. autorewrite with QposElim. rewrite <- Qmax_assoc. rewrite -> (Qmax_assoc (affineCombo (OpenUnitDual o) a b - x)). rewrite -> (Qmax_comm (affineCombo (OpenUnitDual o) a b - x)). rewrite <- (Qmax_assoc (x - affineCombo (OpenUnitDual o) a b)). rewrite -> Qmax_assoc. symmetry. apply Qmax_compat. rewrite <- Qle_max_l. apply: plus_resp_leEq_lft;simpl;auto with *. rewrite <- Qle_max_r. apply: plus_resp_leEq;simpl; auto with *. intros x2 a b H Hx. destruct Hx as [H0 H1] using (glue_eq_ind x1_1). unfold QposEq. rewrite -> SupDistanceToLinear_glue. unfold QposEq in IHx1_1. rewrite -> (IHx1_1 _ _ _ (affineCombo_gt (OpenUnitDual o) H) H0). unfold QposEq in IHx1_2. rewrite -> (IHx1_2 _ _ _ (affineCombo_lt (OpenUnitDual o) H) H1). rewrite -> SupDistanceToLinear_split; [|reflexivity]. apply SupDistanceToLinear_wd1; try reflexivity. Qed. Lemma SupDistanceToLinear_translate : forall x c a b (H:a < b) (H0:a+c < b + c), (proj1_sig (SupDistanceToLinear x H) == proj1_sig (SupDistanceToLinear (constStepF (c:QS) + x) H0))%Q. Proof. induction x. intros; unfold SupDistanceToLinear; simpl. autorewrite with QposElim. apply Qmax_compat; ring. intros c a b H H0. change (constStepF (X:=QS) c + glue o x1 x2) with (glue o (constStepF (c:QS) + x1) (constStepF (c:QS) + x2)). do 2 rewrite -> SupDistanceToLinear_glue. set (A:=(affineCombo_gt (OpenUnitDual o) H)). apply Qmax_compat. eapply Seq_trans. apply Q_Setoid. apply (IHx1 c _ _ A (proj2 (Qplus_lt_l _ _ c) A)). apply SupDistanceToLinear_wd1; try reflexivity. unfold affineCombo; ring. set (B:=(affineCombo_lt (OpenUnitDual o) H)). eapply Seq_trans. apply Q_Setoid. apply (IHx2 c _ _ B (proj2 (Qplus_lt_l _ _ c) B)). apply SupDistanceToLinear_wd1; try reflexivity. unfold affineCombo; ring. Qed. Lemma SupDistanceToLinear_scale : forall x c a b (H:a < b) (H0:c*a < c*b), (c*proj1_sig (SupDistanceToLinear x H) == proj1_sig (SupDistanceToLinear (constStepF (c:QS) * x) H0))%Q. Proof. intros x c a b H H0. assert (X:0 < c). rewrite -> Qlt_minus_iff in *|-. apply: (mult_cancel_less _ 0 c (b + - a))%Q; simpl; auto with *. replace LHS with 0 by simpl; ring. replace RHS with (c* b + - (c*a))%Q by simpl; ring. assumption. revert c a b H H0 X. induction x. intros; unfold SupDistanceToLinear; simpl. autorewrite with QposElim. rewrite -> Qmax_mult_pos_distr_r; auto with *. apply Qmax_compat; ring. intros c a b H H0 X. change (constStepF (X:=QS) c * glue o x1 x2) with (glue o (constStepF (c:QS) * x1) (constStepF (c:QS) * x2)). do 2 rewrite -> SupDistanceToLinear_glue. eapply Seq_trans. apply Q_Setoid. apply Qmax_mult_pos_distr_r; auto with *. set (A:=(affineCombo_gt (OpenUnitDual o) H)). apply Qmax_compat. eapply Seq_trans. apply Q_Setoid. apply (IHx1 c _ _ A (mult_resp_less_lft _ _ _ _ A X)); auto with *. apply SupDistanceToLinear_wd1; try reflexivity. unfold affineCombo; ring. set (B:=(affineCombo_lt (OpenUnitDual o) H)). eapply Seq_trans. apply Q_Setoid. apply (IHx2 c _ _ B (mult_resp_less_lft _ _ _ _ B X)); auto with *. apply SupDistanceToLinear_wd1; try reflexivity. unfold affineCombo; ring. Qed. (** This is the "transitivity" of the [SupDistanceToLinear] function. *) Lemma SupDistanceToLinear_trans : forall x y a b (H:a < b), StepFSupBall (proj1_sig (SupDistanceToLinear x H + SupDistanceToLinear y H)%Qpos) x y. Proof. apply: StepF_ind2. intros s s0 t t0 Hs Ht H a b Hab. apply StepF_eq_change_base_setoid in Hs. apply StepF_eq_change_base_setoid in Ht. rewrite <- Hs, <- Ht at 2. setoid_replace (proj1_sig (SupDistanceToLinear s0 Hab + SupDistanceToLinear t0 Hab)%Qpos) with (proj1_sig (SupDistanceToLinear s Hab + SupDistanceToLinear t Hab)%Qpos). apply H. unfold QposEq. apply Qplus_wd; apply SupDistanceToLinear_wd2. apply StepF_eq_change_base_setoid in Hs. symmetry. exact Hs. apply StepF_eq_change_base_setoid in Ht. symmetry. exact Ht. intros x x0 a b H. unfold StepFSupBall, StepFfoldProp. simpl. rewrite -> Qball_Qabs. unfold SupDistanceToLinear. simpl. apply Qabs_case; intros H0. setoid_replace (x - x0)%Q with ((x - a) + (a - b) + (b - x0))%Q; [| now simpl; ring]. apply: plus_resp_leEq_both; simpl; auto with *. replace RHS with (Qmax (x-a) (b-x) + 0)%Q by simpl; ring. apply: plus_resp_leEq_both; simpl; auto with *. apply Qlt_le_weak. rewrite -> Qlt_minus_iff in *. replace RHS with (b + -a)%Q by simpl; ring. assumption. setoid_replace (-(x - x0))%Q with ((b - x) + - (b - a) + (x0 - a))%Q; [| now simpl; ring]. apply: plus_resp_leEq_both; simpl; auto with *. replace RHS with (Qmax (x-a) (b-x) + 0)%Q by simpl; ring. apply: plus_resp_leEq_both; simpl; auto with *. apply Qlt_le_weak. rewrite -> Qlt_minus_iff in *. replace RHS with (b + -a)%Q by simpl; ring. assumption. intros o s s0 t t0 H0 H1 a b H. assert (X:forall (o : OpenUnit) (l r : StepQ) (a b : Q) (H : a < b), QposEq (SupDistanceToLinear (glue o l r) H) (Qpos_max (SupDistanceToLinear l (affineCombo_gt (OpenUnitDual o) H)) (SupDistanceToLinear r (affineCombo_lt (OpenUnitDual o) H)))%Q). { intros. unfold QposEq. autorewrite with QposElim. apply SupDistanceToLinear_glue. } assert (QposEq (SupDistanceToLinear (glue o s s0) H + SupDistanceToLinear (glue o t t0) H) (Qpos_max (SupDistanceToLinear s (affineCombo_gt (OpenUnitDual o) H)) (SupDistanceToLinear s0 (affineCombo_lt (OpenUnitDual o) H)) + Qpos_max (SupDistanceToLinear t (affineCombo_gt (OpenUnitDual o) H)) (SupDistanceToLinear t0 (affineCombo_lt (OpenUnitDual o) H)))) as balleq. { unfold QposEq. unfold QposEq in X. simpl. do 2 rewrite X. reflexivity. } apply (@StepFSupBall_wd _ _ _ balleq _ _ (reflexivity _) _ _ (reflexivity _)). clear balleq. rewrite -> (StepFSupBallGlueGlue _ _ o s s0 t t0). split. - eapply ball_weak_le;[|simpl; apply H0]. simpl. do 2 rewrite Q_Qpos_max. apply Qplus_le_compat; apply Qmax_ub_l. - eapply ball_weak_le;[|simpl; apply H1]. simpl. do 2 rewrite Q_Qpos_max. apply Qplus_le_compat; apply Qmax_ub_r. Qed. (** The [stepSample p] is as close to the virtual identity function as we expect. *) Lemma stepSampleDistanceToId : (forall p, QposEq (@SupDistanceToLinear (stepSample p) 0 1 (@pos_one _)) (1#(2*p))). Proof. unfold QposEq. induction p using positive_rect2. replace (stepSample (xI p)) with (glue (Build_OpenUnit (oddGluePoint p)) (constStepF (Pos.succ p#xI p:QS) * (stepSample (Pos.succ p))) ((constStepF (1#(xI p):QS))*(constStepF (Pos.succ p:QS) + constStepF (p:QS)*(stepSample p)))) by (symmetry;apply: positive_rect2_red1). rewrite -> SupDistanceToLinear_glue. generalize (@affineCombo_gt (OpenUnitDual (Build_OpenUnit (oddGluePoint p))) 0 1 (pos_one Q_as_COrdField)) (@affineCombo_lt (OpenUnitDual (Build_OpenUnit (oddGluePoint p))) 0 1 (pos_one Q_as_COrdField)). intros A B. set (C:=(pos_one Q_as_COrdField)) in *. transitivity (Qmax (1#2*xI p) (1#2*xI p))%Q;[|apply Qmax_idem]. apply Qmax_compat. set (LHS := (SupDistanceToLinear (constStepF (X:=QS) (Pos.succ p # xI p) * stepSample (Pos.succ p)) A)). transitivity ((Pos.succ p#xI p)*proj1_sig (SupDistanceToLinear (stepSample (Pos.succ p)) C))%Q; [|rewrite -> IHp; change ((Pos.succ p * 1 * (2 * (2* p + 1)) = 2* (Pos.succ p + p * (2* (Pos.succ p))))%Z); repeat rewrite Zpos_succ_morphism; ring]. assert (X:(Pos.succ p # xI p) *0 < (Pos.succ p # xI p) *1). constructor. rewrite -> (fun a => SupDistanceToLinear_scale a C X). apply SupDistanceToLinear_wd1. simpl; ring. unfold affineCombo; simpl; ring. set (LHS := (SupDistanceToLinear (constStepF (X:=QS) (1 # xI p) * (constStepF (X:=QS) (Pos.succ p) + constStepF (X:=QS) p * stepSample p)) B)%Q). transitivity ((1#xI p)*(p*proj1_sig (SupDistanceToLinear (stepSample (p)) C)))%Q; [|rewrite -> IHp0; change ((p * 1 * (2 * (2* p + 1)) = 2* (p + p * (2* p)))%Z); ring]. assert (X0:(p *0 < p *1)). constructor. rewrite -> (fun a => SupDistanceToLinear_scale a C X0). assert (X1:(p*0 + Pos.succ p < p*1 + Pos.succ p)). apply: plus_resp_less_rht. assumption. rewrite -> (fun a => SupDistanceToLinear_translate a X0 X1). assert (X2:((1# xI p)*(p*0 + Pos.succ p) < (1#xI p)*(p*1 + Pos.succ p))). apply: mult_resp_less_lft;simpl; auto with *. rewrite -> (fun a => SupDistanceToLinear_scale a X1 X2). apply SupDistanceToLinear_wd1. unfold affineCombo; simpl. repeat rewrite -> Zpos_succ_morphism; repeat rewrite -> Qmake_Qdiv; repeat rewrite -> Zpos_xI; field; auto with *. change (2*(p*1) + 1 = ((p*1*1 + Pos.succ p*1)*1))%Z. rewrite Zpos_succ_morphism; ring. change (1#2*xO p)%Q with ((1#2)*(1#(2*p)))%Q. replace (stepSample (xO p)) with (glue (ou (1#2)) (constStepF (1#2:QS) * (stepSample p)) (constStepF (1#2:QS) * (constStepF (1:QS) + (stepSample p)))) by (symmetry;apply: positive_rect2_red2). rewrite -> SupDistanceToLinear_glue. generalize (@affineCombo_gt (OpenUnitDual (ou (1#2))) 0 1 (pos_one Q_as_COrdField)) (@affineCombo_lt (OpenUnitDual (ou (1#2))) 0 1 (pos_one Q_as_COrdField)). intros A B. set (C:=(pos_one Q_as_COrdField)) in *. transitivity (Qmax ((1#2)*(1#2 * p)) ((1#2)*(1#2 * p)))%Q;[|apply Qmax_idem]. set (D1:=(SupDistanceToLinear (constStepF (X:=QS) (1 # 2) * stepSample p) A)). set (D2:=(SupDistanceToLinear (constStepF (X:=QS) (1 # 2) * (constStepF (X:=QS) 1 + stepSample p)) B)). rewrite <- IHp. apply Qmax_compat. assert (X:((1#2) *0 < (1#2) *1)). constructor. rewrite -> (fun a c => SupDistanceToLinear_scale a c X). apply SupDistanceToLinear_wd1; constructor. assert (X0:0 + 1 < 1 +1). constructor. rewrite -> (fun a c => SupDistanceToLinear_translate a c X0). assert (X1:(1#2)*(0 + 1) < (1#2)*(1 +1)). constructor. rewrite -> (fun a => SupDistanceToLinear_scale a X0 X1). apply SupDistanceToLinear_wd1; constructor. reflexivity. Qed. (** Given a requested error of q, what is smallest n for [stepSample n] that will satifiy this error requirement. *) Definition id01_raw_help (q:QposInf) : positive := match q with |QposInfinity => 1%positive |Qpos2QposInf q => Qpos_ceiling ((1#2) * Qpos_inv q) end. Lemma id01_raw_help_le : forall (q:Qpos), ((1#2*id01_raw_help q) <= proj1_sig q)%Q. Proof with auto with *. intros q. unfold id01_raw_help, Qpos_ceiling. simpl. generalize (Qle_ceiling ((1#2)*/proj1_sig q)). generalize (Qceiling ((1#2)*/proj1_sig q)). intros [|p|p] H. elim (Qle_not_lt _ _ H). apply Q.Qmult_lt_0_compat... apply Qinv_lt_0_compat... autorewrite with QposElim in *. rewrite -> Qmake_Qdiv in *. rewrite Zpos_xO. rewrite -> Qle_minus_iff in *. change ((2%positive * p)%Z:Q) with (2%positive * p)%Q. replace RHS with (((2*proj1_sig q)/(2*p)) *(p - 1%positive/2%positive*/proj1_sig q))%Q. apply: mult_resp_nonneg; simpl; auto with *. apply Qlt_le_weak. apply Q.Qmult_lt_0_compat... simpl. field. split... elim (Qle_not_lt _ _ H). apply Qlt_trans with 0... apply Q.Qmult_lt_0_compat... apply Qinv_lt_0_compat... Qed. (** Now define id01, the identity funciton on [[0,1]] as a bounded function, to be the limit of these [stepSample] functions. *) Definition id01_raw (q:QposInf) : StepQ := stepSample (id01_raw_help q). Lemma id01_prf : is_RegularFunction (@ball LinfStepQ) (id01_raw:QposInf -> LinfStepQ). Proof. intros a b. unfold id01_raw. apply ball_weak_le with (proj1_sig ((1#2*(id01_raw_help a)) + (1#2*(id01_raw_help b)))%Qpos). apply: plus_resp_leEq_both; apply id01_raw_help_le. simpl (ball (m:=LinfStepQ)). pose proof stepSampleDistanceToId. assert (QposEq ((1 # 2 * id01_raw_help a) + (1 # 2 * id01_raw_help b)) ((SupDistanceToLinear (stepSample (id01_raw_help a)) (pos_one Q_as_COrdField)) + (SupDistanceToLinear (stepSample (id01_raw_help b)) (pos_one Q_as_COrdField)))). { unfold QposEq. simpl. unfold QposEq in H. simpl in H. do 2 rewrite H. reflexivity. } unfold QposEq in H0. rewrite H0. apply SupDistanceToLinear_trans. Qed. Definition id01 : BoundedFunction := Build_RegularFunction id01_prf. End id01. (** ** StepFunctions distribute over Completion The distribution function maps StepF (Complete X) to Complete (StepF X). *) (* approximate z e is not a morphism, so we revert to using the pre-setoid version of StepF's map *) Definition distribComplete_raw (x:StepF (msp_as_RSetoid CR)) (e:QposInf) : LinfStepQ := StepFunction.Map (fun z => approximate z e) x. Lemma distribComplete_prf : forall (x:StepF (msp_as_RSetoid CR)), is_RegularFunction (@ball LinfStepQ) (distribComplete_raw x). Proof. unfold distribComplete_raw. intros x a b. induction x. apply (@regFun_prf _ Qball). simpl (ball (m:=LinfStepQ)). set (f:=(fun z : RegularFunction (@ball Q_as_MetricSpace) => approximate z a)) in *. set (g:=(fun z : RegularFunction (@ball Q_as_MetricSpace) => approximate z b)) in *. change (Map f (glue o x1 x2)) with (glue o (Map f x1:StepQ) (Map f x2)). change (Map g (glue o x1 x2)) with (glue o (Map g x1:StepQ) (Map g x2)). rewrite -> (StepFSupBallGlueGlue _ _ o (Map f x1 : StepQ) (Map f x2) (Map g x1 : StepQ) (Map g x2)). auto. Qed. Definition distribComplete (x:StepF (msp_as_RSetoid CR)) : BoundedFunction := Build_RegularFunction (distribComplete_prf x). Local Open Scope uc_scope. (** Given a uniformly continuous function f, and a step function g, the composition f o g is a bounded function. The map from g to f o g is uniformly continuous with modulus [mu f]. The same thing does not work for integrable functions becuase The map from g to f o g may not be uniformly continuous with modulus [mu f]. However, I have not found a counter example where f o g is not uniformly continuous. In fact, when f is lipschitz, then the map from g to f o g is Lipschitz. However Lipschitz functions haven't been formalized yet. *) Definition ComposeContinuous_raw (f:Q_as_MetricSpace-->CR) (z:LinfStepQ) : BoundedFunction := dist (uc_stdFun f ^@> z). (* begin hide *) Add Parametric Morphism f : (@ComposeContinuous_raw f) with signature (@msp_eq _) ==> (@msp_eq _) as ComposeContinuous_raw_wd. Proof. intros x1 x2 Hx. unfold ComposeContinuous_raw. apply uc_wd. apply StepF_eq_equiv in Hx. apply StepF_eq_equiv. rewrite -> Hx. reflexivity. Qed. (* end hide *) Lemma ComposeContinuous_prf (f:Q_as_MetricSpace --> CR) : is_UniformlyContinuousFunction (ComposeContinuous_raw f) (mu f). Proof. intros e a b. revert a b e. apply: StepF_ind2. intros s s0 t t0 Hs Ht H e H0. apply StepF_eq_equiv in Ht. rewrite <- Ht. apply StepF_eq_equiv in Hs. rewrite <- Hs. apply H. destruct (mu f e). 2: constructor. simpl. rewrite Hs, Ht. exact H0. intros x y e H. change (ball (proj1_sig e) (f x) (f y)). apply uc_prf. destruct (mu f e); try solve [constructor]. simpl. assumption. intros o s s0 t t0 H0 H1 e H. unfold ComposeContinuous_raw in *. repeat rewrite -> MapGlue, dist_glue. intros d1 d2. apply ball_weak_le with (proj1_sig (((1#2)*((1#2)*d1)) + e + ((1#2)*((1#2)*d2)))%Qpos). simpl. Qauto_le. simpl. unfold Cap_slow_raw. simpl. rewrite -> StepFSupBallGlueGlue. split. setoid_replace ((1 # 2) * ((1 # 2) * proj1_sig d1) + proj1_sig e + (1 # 2) * ((1 # 2) * proj1_sig d2))%Q with (proj1_sig ((1 # 2) * ((1 # 2) * d1) + e + (1 # 2) * ((1 # 2) * d2))%Qpos) by (simpl; ring). apply (H0 e). destruct (mu f e); try constructor. simpl in H. rewrite -> StepFSupBallGlueGlue in H; tauto. setoid_replace ((1 # 2) * ((1 # 2) * proj1_sig d1) + proj1_sig e + (1 # 2) * ((1 # 2) * proj1_sig d2))%Q with (proj1_sig ((1 # 2) * ((1 # 2) * d1) + e + (1 # 2) * ((1 # 2) * d2))%Qpos) by (simpl; ring). apply (H1 e). destruct (mu f e); try constructor. simpl in H. rewrite -> StepFSupBallGlueGlue in H; tauto. Qed. Definition ComposeContinuous (f:Q_as_MetricSpace --> CR) : LinfStepQ --> BoundedFunction := Build_UniformlyContinuousFunction (ComposeContinuous_prf f). (** ** Riemann-Stieltjes Integral A measure on the reals is represented by the inverse of it's cumlative distribution function as a bounded function. So at the moment we can only integrate over bounded intervals. This effectively the Stieltjes integral [Integral f d(g^-1)]. *) Definition IntegrateWithMeasure (f:Q_as_MetricSpace --> CR) : BoundedFunction --> CR := (uc_compose IntegrableFunction.Integral (uc_compose BoundedAsIntegrable (Cbind (LinfStepQPrelengthSpace) (ComposeContinuous f)))). (** The Riemann Integral uses the uniform measure on [[0,1]]. The inverse of its cumlative distribution function is [id01]. *) Definition Integrate01 f := IntegrateWithMeasure f id01. Definition ContinuousSup01 f := (uc_compose sup (Cbind (LinfStepQPrelengthSpace) (ComposeContinuous f))) id01. (** Integrating a different range is just a matter of scaling and translating a little: *) Definition Integrate (f: Q_as_MetricSpace --> CR) (from width: Q): CR := (' width * Integrate01 (f ∘ Qplus_uc from ∘ Qscale_uc width))%CR. Lemma Integrate01_correct_generalize : forall (a b : Q) (F : PartFunct IR) (f : Q_as_MetricSpace --> CR) (e : Qpos), (forall (o : Q) (H : Dom F (inj_Q IR o)), a <= o <= b -> msp_eq (f o) (IRasCR (F (inj_Q IR o) H))) -> forall (H01 : inj_Q IR a [<=] inj_Q IR b) (HF : Continuous_I H01 F) (c : a < b) (s : StepQ), QposInf_le (Qpos2QposInf (SupDistanceToLinear s c)) (mu f ((1 # 2) * e)) -> @AbsSmall CRasCOrdField (' ((b - a) * proj1_sig e)%Q)%CR (IRasCR (integral (inj_Q IR a) (inj_Q IR b) H01 F HF) - (' ((b - a) * IntegralQ (dist_raw (uc_stdFun f ^@> s) ((1 # 2) * e)%Qpos))%Q))%CR. Proof. intros a b F f e Hf Hab HF Hab0 s Hs. destruct (Qpos_sub _ _ Hab0) as [ba Hba]. stepl ('proj1_sig (ba*e)%Qpos)%CR. 2: simpl; rewrite Hba; rewrite Qplus_comm; unfold Qminus; rewrite <- Qplus_assoc, Qplus_opp_r, Qplus_0_r; reflexivity. revert a b Hab0 ba Hba F Hab HF Hf Hs. induction s; intros a b Hab0 ba Hba F Hab HF Hf Hs. - change (IntegralQ (dist_raw (constStepF (uc_stdFun f) <@^ x) ((1 # 2) * e)%Qpos)) with (approximate (f x) ((1 # 2) * e)%Qpos). rewrite <- (IR_inj_Q_as_CR ((b - a) * approximate (f x) ((1 # 2) * e)%Qpos)). unfold cg_minus. simpl. eapply AbsSmall_wdr;[|apply IR_minus_as_CR]. eapply AbsSmall_wdl;[|apply IR_inj_Q_as_CR]. rewrite <- IR_AbsSmall_as_CR. unfold SupDistanceToLinear in Hs. simpl in Hs. set (a0:=inj_Q IR (approximate (f x) ((1 # 2) * e)%Qpos)). set (e':=(inj_Q IR (proj1_sig e))). assert (X:forall y : IR, Compact Hab y -> forall Hy : Dom F y, AbsSmall e' ((F y Hy)[-]a0)). intros y Hy Hyf. rewrite -> IR_AbsSmall_as_CR. unfold e'. apply AbsSmall_wdr with (IRasCR (F y Hyf) - IRasCR a0)%CR;[|apply eq_symmetric; apply IR_minus_as_CR]. rewrite IR_inj_Q_as_CR. apply (CRAbsSmall_ball (IRasCR (F y Hyf))). unfold a0; rewrite -> IR_inj_Q_as_CR. assert (X0:(forall (q : Q) (Hq : Dom F (inj_Q IR q)), clcr (inj_Q IR a) (inj_Q IR b) (inj_Q IR q) -> (Cbind QPrelengthSpace f (' q) == IRasCR (F (inj_Q IR q) Hq))%CR)). intros q Hq [Hq0 H1]. pose proof (Cbind_correct QPrelengthSpace f). apply ucEq_equiv in H. rewrite -> (H (' q))%CR. clear H. rewrite -> (BindLaw1 f). apply Hf. split. apply (leEq_inj_Q IR). auto. apply (leEq_inj_Q IR). auto. assert (X:=@ContinuousCorrect (clcr (inj_Q IR a) (inj_Q IR b)) (inj_Q_less _ _ _ Hab0) F (Continuous_Int (clcr (inj_Q IR a) (inj_Q IR b)) Hab Hab F HF) (Cbind QPrelengthSpace f) X0 y Hyf Hy). set (z:=(' approximate (f x) ((1 # 2) * e)%Qpos)%CR). rewrite -> X. setoid_replace (proj1_sig e) with (proj1_sig ((1#2)*e + (1#2)*e)%Qpos) by (simpl; ring). apply ball_triangle with (f x); [|apply ball_approx_r]. rewrite <- (BindLaw1 f). pose proof (Cbind_correct QPrelengthSpace f) as H. apply ucEq_equiv in H. rewrite <- (H (Cunit_fun Q_as_MetricSpace x)). clear H. set (z0:=(Cbind QPrelengthSpace f (Cunit_fun Q_as_MetricSpace x))). apply: uc_prf. clear z X X0 Hyf. pose (mu f ((1#2)*e)%Qpos) as z. simpl. simpl in z. simpl in Hs. fold z in Hs. fold CR z. destruct z as [z|];[|constructor]. unfold ball_ex. eapply ball_weak_le. apply Hs. change (Cunit_fun Q_as_MetricSpace x) with ('x)%CR. rewrite <- IR_inj_Q_as_CR. rewrite <- CRAbsSmall_ball. autorewrite with QposElim. unfold cg_minus; simpl. eapply AbsSmall_wdr;[|apply IR_minus_as_CR]. eapply AbsSmall_wdl;[|apply IR_inj_Q_as_CR]. rewrite <- IR_AbsSmall_as_CR. apply AbsIR_imp_AbsSmall. assert(X:=leEq_or_leEq _ (inj_Q IR x) y). rewrite -> leEq_def. intros Y. apply X. clear X. intros X. revert Y. change (Not (inj_Q IR (Qmax (x - a) (b - x))[<]AbsIR (y[-]inj_Q IR x))). rewrite <- leEq_def. apply AbsSmall_imp_AbsIR. destruct X as [X|X]. apply leEq_imp_AbsSmall. apply shift_leEq_lft; assumption. apply leEq_transitive with (inj_Q IR (b - x)%Q). stepr ((inj_Q IR b)[-](inj_Q IR x)); [| now (apply eq_symmetric; apply inj_Q_minus)]. apply minus_resp_leEq. destruct Hy; assumption. apply inj_Q_leEq. apply Qmax_ub_r. apply AbsSmall_minus. apply leEq_imp_AbsSmall. apply shift_leEq_lft; assumption. apply leEq_transitive with (inj_Q IR (x - a)%Q). stepr ((inj_Q IR x)[-](inj_Q IR a)); [| now (apply eq_symmetric; apply inj_Q_minus)]. apply minus_resp_leEq_rht. destruct Hy; assumption. apply inj_Q_leEq. apply Qmax_ub_l. split. apply shift_leEq_minus. stepl (([--]e'[+]a0)[*](inj_Q IR b[-]inj_Q IR a)). apply lb_integral. intros y Hy Hyf. apply shift_plus_leEq. destruct (X y Hy Hyf); assumption. rstepl ([--]((inj_Q IR b[-]inj_Q IR a)[*]e') [+] (inj_Q IR b[-]inj_Q IR a)[*]a0). csetoid_replace (inj_Q IR b[-]inj_Q IR a) (inj_Q IR (b-a)%Q); [|apply eq_symmetric; apply inj_Q_minus]. apply bin_op_wd_unfolded. apply un_op_wd_unfolded. unfold e'. stepl (inj_Q IR ((b-a)*proj1_sig e)%Q); [| now apply inj_Q_mult]. apply: inj_Q_wd;simpl. autorewrite with QposElim. rewrite Hba. ring. apply eq_symmetric; apply inj_Q_mult. apply shift_minus_leEq. stepr ((e'[+]a0)[*](inj_Q IR b[-]inj_Q IR a)). apply ub_integral. intros y Hy Hyf. apply shift_leEq_plus. destruct (X y Hy Hyf); assumption. rstepl (((inj_Q IR b[-]inj_Q IR a)[*]e') [+] (inj_Q IR b[-]inj_Q IR a)[*]a0). csetoid_replace (inj_Q IR b[-]inj_Q IR a) (inj_Q IR (b-a)%Q); [|apply eq_symmetric; apply inj_Q_minus]. apply bin_op_wd_unfolded. unfold e'. stepl (inj_Q IR ((b-a)*proj1_sig e)%Q); [| now apply inj_Q_mult]. apply: inj_Q_wd;simpl. rewrite Hba. ring. apply eq_symmetric; apply inj_Q_mult. - set (z:=(IntegralQ (glue o (Map (fun z : RegularFunction Qball => approximate z ((1 # 2) * e)%Qpos) (Map f s1):StepQ) (Map (fun z : RegularFunction Qball => approximate z ((1 # 2) * e)%Qpos) (Map f s2))))). change (IntegralQ (dist_raw (uc_stdFun f ^@> glue o s1 s2) ((1 # 2) * e)%Qpos)) with z. apply (CRAbsSmall_ball (IRasCR (integral (inj_Q IR a) (inj_Q IR b) Hab F HF))). set (c:=(affineCombo (OpenUnitDual o) a b:Q)). assert (Hac:inj_Q IR a[<=]inj_Q IR c). unfold c. apply inj_Q_leEq. simpl; auto with *. assert (Hcb:inj_Q IR c[<=]inj_Q IR b). unfold c. apply inj_Q_leEq. simpl; auto with *. assert (HFl :Continuous_I Hac F). revert HF. apply included_imp_contin. intros x [Hxl Hxr]. split; auto. apply leEq_transitive with (inj_Q IR c); auto. assert (HFr :Continuous_I Hcb F). revert HF. apply included_imp_contin. intros x [Hxl Hxr]. split; auto. apply leEq_transitive with (inj_Q IR c); auto. setoid_replace (IRasCR (integral _ _ Hab F HF)) with (IRasCR (integral _ _ Hac F HFl)+IRasCR (integral _ _ Hcb F HFr))%CR; [| now (rewrite <- IR_plus_as_CR;apply IRasCR_wd; apply eq_symmetric; apply integral_plus_integral)]. unfold z. rewrite -> Integral_glue. clear z. set (zl:=IntegralQ (Map (fun z : RegularFunction Qball => approximate z ((1 # 2) * e)%Qpos) (Map f s1))). set (zr:=IntegralQ (Map (fun z : RegularFunction Qball => approximate z ((1 # 2) * e)%Qpos) (Map f s2))). setoid_replace ((b - a) * (o * zl + (1 - o) * zr))%Q with ((c - a)*zl + (b - c)*zr)%Q; [| now (unfold c, affineCombo, OpenUnitDual; simpl; ring)]. assert (Hac0: a < c). unfold c; auto with*. assert (Hcb0: c < b). unfold c; auto with*. destruct (Qpos_sub _ _ Hac0) as [ca Hca]. destruct (Qpos_sub _ _ Hcb0) as [bc Hbc]. assert (Z:(QposEq ba (ca + bc))%Qpos). unfold QposEq. rewrite -> Hba in Hbc. rewrite -> Hca in Hbc. replace LHS with (- a + (a + proj1_sig ba))%Q by simpl; ring. rewrite Hbc. simpl. ring. assert (QposEq (ba*e) ((ca+bc)*e)). { unfold QposEq. simpl. unfold QposEq in Z. rewrite Z. reflexivity. } clear Z. unfold QposEq in H. rewrite H. clear H. assert (QposEq ((ca + bc)*e) (ca*e + bc*e)) by (unfold QposEq; simpl; ring). unfold QposEq in H. rewrite H. clear H. rewrite <- CRAbsSmall_ball. setoid_replace (@cg_minus CRasCGroup (IRasCR (integral (inj_Q IR a) (inj_Q IR c) Hac F HFl) + IRasCR (integral (inj_Q IR c) (inj_Q IR b) Hcb F HFr))%CR (' ((c - a) * zl + (b - c) * zr)%Q)%CR) with ((IRasCR (integral (inj_Q IR a) (inj_Q IR c) Hac F HFl) - ('((c-a)*zl))%Q)+ ((IRasCR (integral (inj_Q IR c) (inj_Q IR b) Hcb F HFr) - ('((b - c) * zr)%Q))))%CR. stepl ('proj1_sig (ca * e)%Qpos + 'proj1_sig (bc * e)%Qpos)%CR. apply: AbsSmall_plus. apply (IHs1 _ _ Hac0); auto. intros o0 H [H0 H1]. apply Hf. split; eauto with qarith. destruct (mu f ((1#2)*e)) as [q|];[|constructor]. simpl in Hs|-*. eapply Qle_trans;[|apply Hs]. rewrite -> SupDistanceToLinear_glue. replace LHS with (proj1_sig (SupDistanceToLinear s1 (affineCombo_gt (OpenUnitDual o) Hab0))). apply Qmax_ub_l. apply SupDistanceToLinear_wd1; reflexivity. apply (IHs2 _ _ Hcb0); auto. intros o0 H [H0 H1]. apply Hf. clear - H0 H1 Hac0. split; eauto with qarith. destruct (mu f ((1#2)*e)) as [q|];[|constructor]. simpl in Hs|-*. eapply Qle_trans;[|apply Hs]. rewrite -> SupDistanceToLinear_glue. replace LHS with (proj1_sig (SupDistanceToLinear s2 (affineCombo_lt (OpenUnitDual o) Hab0))). apply Qmax_ub_r. apply SupDistanceToLinear_wd1; reflexivity. change (' proj1_sig (ca * e)%Qpos + ' proj1_sig (bc * e)%Qpos ==(' proj1_sig (ca * e + bc * e)%Qpos))%CR. unfold Qpos_mult, Qpos_plus, proj1_sig. ring. generalize (IRasCR (integral (inj_Q IR a) (inj_Q IR c) Hac F HFl)) (IRasCR (integral (inj_Q IR c) (inj_Q IR b) Hcb F HFr)). intros x y. clear - x y. change (@cg_minus CRasCGroup (x + y)%CR (' ((c - a) * zl + (b - c) * zr)%Q)%CR) with (x + y - ' ((c - a) * zl + (b - c) * zr)%Q)%CR. ring. Qed. (** Our integral on [[0,1]] is correct. *) Lemma Integrate01_correct : forall F (H01:[0][<=]([1]:IR)) (HF:Continuous_I H01 F) (f:Q_as_MetricSpace --> CR), (forall (o:Q) H, (0 <= o <= 1) -> (f o == IRasCR (F (inj_Q IR o) H)))%CR -> (IRasCR (integral [0] [1] H01 F HF)==Integrate01 f)%CR. Proof. intros F H01' HF' f Hf. assert (H01:(inj_Q IR 0)[<=](inj_Q IR 1)). { apply inj_Q_leEq. discriminate. } assert (HF:Continuous_I H01 F). { apply (included_imp_contin _ _ H01'). apply included_compact. apply (compact_wd _ _ H01' [0]). apply compact_inc_lft. apply eq_symmetric; apply (inj_Q_nring IR 0). apply (compact_wd _ _ H01' [1]). apply compact_inc_rht. rstepl (nring 1:IR). apply eq_symmetric; apply (inj_Q_nring IR 1). assumption. } transitivity (IRasCR (integral _ _ H01 F HF)). apply IRasCR_wd. apply integral_wd'. apply eq_symmetric; apply (inj_Q_nring IR 0). rstepl (nring 1:IR). apply eq_symmetric; apply (inj_Q_nring IR 1). clear H01' HF'. apply ball_eq. intros e epos. setoid_replace e with (proj1_sig ((1#2)*exist _ _ epos + (1#2)*exist _ _ epos)%Qpos) by (simpl; ring). generalize ((1#2)*exist _ _ epos)%Qpos. clear epos e. intros e. eapply ball_triangle; [|apply (@ball_approx_l Q_as_MetricSpace)]. change (Cunit (approximate (Integrate01 f) e)) with ('(approximate (Integrate01 f) e))%CR. setoid_replace ('(approximate (Integrate01 f) e))%CR with ('((1-0)*(approximate (Integrate01 f) e))%Q)%CR. Focus 2. change (' approximate (Integrate01 f) e == ' ((1 - 0) * approximate (Integrate01 f) e)%Q)%CR. ring. rewrite <- CRAbsSmall_ball. stepl ('((1-0)*proj1_sig e)%Q)%CR; [| apply inject_Q_CR_wd; change ((1 - 0) * proj1_sig e == proj1_sig e)%Q; ring]. set (z:=(integral (inj_Q IR 0) (inj_Q IR 1) H01 F HF)). simpl. unfold Cjoin_raw. simpl. unfold distribComplete_raw. unfold id01_raw. assert (X:=stepSampleDistanceToId (id01_raw_help (mu f ((1 # 2) * e)))). revert X. remember (stepSample (id01_raw_help (mu f ((1 # 2) * e)))) as s. simpl in Heqs. rewrite <- Heqs. clear Heqs. intros Hs. assert (X:QposInf_le (Qpos2QposInf (SupDistanceToLinear s (pos_one Q_as_COrdField))) (mu f ((1 # 2) * e))). destruct (mu f ((1#2) *e)); try constructor. unfold QposEq in Hs. simpl. rewrite -> Hs. apply id01_raw_help_le. clear Hs. rename X into Hs. revert s Hs. generalize (pos_one Q_as_COrdField). intros c s Hs. simpl in c, Hs. revert c s Hs. unfold z. clear z. revert H01 HF. revert Hf. apply Integrate01_correct_generalize. Qed. corn-8.20.0/reals/fast/Interval.v000066400000000000000000000565401473720167500166060ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.metric2.Compact. Require Export CoRN.metric2.LocatedSubset. Require Export CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRabs. Require Export CoRN.model.metric2.Qmetric. From Coq Require Import Qround. From Coq Require Import Qabs. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.logic.Classic. Local Open Scope Q_scope. Opaque Qabs. Set Implicit Arguments. Section Interval. (** * Intervals as a Compact Set. We want to make an efficent implementation of intervals as compact sets. We want to minimize the number of sample points in the approximations of a compact interval. *) Variable (l r:Q). Hypothesis Hlr : l <= r. Let f (n:positive) (i:Z) := l + ((r-l)*(2*i+1#1))/(2*Zpos n#1). Fixpoint iterateN_succ (z:Z) (n:positive) : list Z := match n with | xI p => z :: app (iterateN_succ (Z.succ z) p) (iterateN_succ (Z.succ z + Zpos p) p) | xO p => app (iterateN_succ z p) (iterateN_succ (z + Zpos p) p) | xH => z :: nil end. Lemma iterateN_succ_example : iterateN_succ 4 3 = (4 :: 5 :: 6 :: nil)%Z. Proof. reflexivity. Qed. Lemma iterateN_succ_length : forall n z, length (iterateN_succ z n) = Pos.to_nat n. Proof. induction n. - intro z. simpl. rewrite Pos2Nat.inj_xI. apply f_equal. rewrite app_length, IHn, IHn. simpl. rewrite Nat.add_0_r. reflexivity. - intro z. simpl. rewrite app_length, IHn, IHn. rewrite Pos2Nat.inj_xO. simpl. rewrite Nat.add_0_r. reflexivity. - reflexivity. Qed. Lemma iterateN_succ_nth : forall n (j:nat) s z, (j < Pos.to_nat n)%nat -> nth j (iterateN_succ s n) z = (s + Z.of_nat j)%Z. Proof. induction n. - intros. simpl. destruct j. simpl. rewrite Z.add_0_r. reflexivity. destruct (le_lt_dec (Pos.to_nat n) j) as [l0|l0]. + rewrite <- (iterateN_succ_length n (Z.succ s)) in l0. rewrite (app_nth2 _ _ z l0). pose proof (Nat.le_exists_sub _ _ l0) as [k [H0 _]]. subst j. rewrite Nat.add_sub. rewrite IHn. rewrite iterateN_succ_length. rewrite Nat2Z.inj_succ, Nat2Z.inj_add, <- positive_nat_Z. ring. rewrite (iterateN_succ_length n (Z.succ s)), Pos2Nat.inj_xI in H. simpl in H. rewrite Nat.add_0_r in H. apply le_S_n in H. apply (Nat.add_le_mono_r _ _ (Pos.to_nat n)). exact H. + rewrite <- (iterateN_succ_length n (Z.succ s)) in l0. rewrite (app_nth1 _ _ z l0). rewrite IHn. rewrite Nat2Z.inj_succ. ring. rewrite <- (iterateN_succ_length n (Z.succ s)). exact l0. - intros. simpl. destruct (le_lt_dec (Pos.to_nat n) j) as [l0|l0]. + rewrite <- (iterateN_succ_length n s) in l0. rewrite (app_nth2 (iterateN_succ s n) (iterateN_succ (s + Z.pos n) n) z l0). pose proof (Nat.le_exists_sub _ _ l0) as [k [H0 _]]. subst j. rewrite Nat.add_sub. rewrite IHn. rewrite (iterateN_succ_length n s). rewrite Nat2Z.inj_add, <- positive_nat_Z. ring. rewrite (iterateN_succ_length n s), Pos2Nat.inj_xO in H. simpl in H. rewrite Nat.add_0_r in H. apply (Nat.add_le_mono_r _ _ (Pos.to_nat n)). exact H. + rewrite <- (iterateN_succ_length n s) in l0. rewrite (app_nth1 (iterateN_succ s n) (iterateN_succ (s + Z.pos n) n) z l0). apply IHn. rewrite <- (iterateN_succ_length n s). exact l0. - intros. simpl. destruct j. simpl. rewrite Z.add_0_r. reflexivity. exfalso. inversion H. inversion H1. Qed. (** [UniformPartition] produces a set of n points uniformly distributed inside the interval [[l, r]]. We use binary positive instead of unary nat for faster computations. *) Definition UniformPartition (n:positive) : list Q := map (f n) (iterateN_succ 0%Z n). Lemma UniformPartitionZ : forall n a z, In z (iterateN_succ a n) <-> (a <= z < a + Zpos n)%Z. Proof. split. - intro H. apply (In_nth _ _ 0%Z) in H. destruct H as [p [H H0]]. subst z. rewrite iterateN_succ_length in H. rewrite iterateN_succ_nth. 2: exact H. split. rewrite <- (Z.add_0_r a) at 1. apply Z.add_le_mono_l. apply Nat2Z.is_nonneg. apply Z.add_lt_mono_l. destruct p. reflexivity. rewrite <- (Nat2Pos.id (S p)) in H. 2: discriminate. apply Pos2Nat.inj_lt in H. simpl. rewrite Pos.of_nat_succ. exact H. - revert n z a. induction n; intros. + simpl. destruct (Z.le_gt_cases z a). left. apply Z.le_antisymm. apply H. exact H0. right. destruct (Z.le_gt_cases (Z.succ a + Z.pos n) z). apply in_app_iff. right. apply IHn. split. apply H1. rewrite <- Z.add_assoc, Z.add_diag. apply (Z.lt_le_trans _ _ _ (proj2 H)). rewrite <- Z.add_1_l, (Z.add_comm 1). rewrite <- Z.add_assoc. apply Z.le_refl. apply in_app_iff. left. apply IHn. split. apply Zlt_le_succ, H0. exact H1. + simpl. destruct (Z.le_gt_cases (a + Z.pos n) z). apply in_app_iff. right. apply IHn. split. apply H0. rewrite <- Z.add_assoc, Z.add_diag. apply H. apply in_app_iff. left. apply IHn. split. apply H. exact H0. + left. destruct H. apply Z.le_antisymm. exact H. rewrite Z.add_comm, Z.add_1_l in H0. apply Zlt_succ_le, H0. Qed. Lemma UniformPartition_inside : forall n x, In x (UniformPartition n) -> l <= x <= r. Proof. intros n x. unfold UniformPartition. assert (forall z, In z (iterateN_succ 0%Z n) -> (0 <= z < Zpos n)%Z) as H. { intros. apply UniformPartitionZ in H. exact H. } revert H. generalize (iterateN_succ 0%Z n). intros s Hs H. induction s. contradiction. destruct H as [H | H];auto with *. rewrite <- H. destruct (Hs a) as [Hz0 Hz1]; auto with *. clear - Hz0 Hz1 Hlr. split. unfold f, Qdiv. rewrite <- (Qplus_0_r l) at 1. apply Qplus_le_r. apply Qle_shift_div_l. reflexivity. rewrite Qmult_0_l. apply Qmult_le_0_compat. unfold Qminus. rewrite <- Qle_minus_iff. exact Hlr. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. apply (Z.le_trans _ (1*a+0)%Z). rewrite Z.add_0_r, Z.mul_1_l. exact Hz0. apply Z.add_le_mono. apply Z.mul_le_mono_nonneg_r. exact Hz0. discriminate. discriminate. unfold f. apply (Qplus_le_r _ _ (-l)). rewrite Qplus_assoc. rewrite (Qplus_comm (-l)), Qplus_opp_r, Qplus_0_l. apply Qle_shift_div_r. reflexivity. rewrite (Qplus_comm (-l)), Qmult_comm, (Qmult_comm (r+-l)). apply Qmult_le_compat_r. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. rewrite Z.add_comm, Z.add_1_l. apply Zlt_le_succ. apply Z.mul_lt_mono_pos_l. reflexivity. exact Hz1. rewrite <- Qle_minus_iff. exact Hlr. Qed. (** Given a point [x] in the interval [[l, r]], one can find a nearby point in our [UniformPartition]. n is the number of points in the partition, ie the step is (r-l)/n. This function computes the maximum index k such that l+k(r-l)/n <= x. *) Definition rasterize1 (n:positive) (x:Q) : Z := Qfloor (inject_Z (Zpos n)*(x-l)/(r-l)). Lemma rasterize1_close : l < r -> forall (n:positive) (x:Q), Qabs (x - f n (rasterize1 n x)) <= ((r-l)/((2#1) * inject_Z (Zpos n))). Proof. clear Hlr. intros Hlr' n x. rewrite -> Qlt_minus_iff in Hlr'. assert (A:~ r - l == 0 /\ ~ inject_Z (Zpos n) == 0) by (split;auto with *;discriminate). setoid_replace ((r - l) / ((2#1) * inject_Z (Zpos n))) with ((1#2)/(inject_Z (Zpos n)/(r - l))) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto). apply Qle_shift_div_l. apply Qlt_shift_div_l; auto with *. rewrite <- (Qabs_pos (inject_Z (Zpos n)/(r-l))); [|apply Qle_shift_div_l; auto with *]. rewrite <- Qabs_Qmult. unfold f. change (2*Zpos n # 1) with ((2#1)*inject_Z (Zpos n)). setoid_replace ((x - (l + (r - l) * (2 * rasterize1 n x + 1 # 1) / ((2#1) * inject_Z (Zpos n)))) * (inject_Z (Zpos n) / (r - l))) with (inject_Z (Zpos n)*(x-l)/(r-l) - (2*rasterize1 n x + 1 # 1)/(2#1)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto). rewrite -> Qmake_Qdiv. rewrite Q.Zplus_Qplus. unfold Qdiv. change (inject_Z 1) with 1%Q. rewrite Qmult_1_r. rewrite Q.Zmult_Qmult. change (inject_Z 2) with (2#1). setoid_replace (((2#1) * inject_Z (rasterize1 n x) + 1) / (2#1)) with (inject_Z (rasterize1 n x) + (1#2)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto). unfold rasterize1. unfold Qdiv. generalize (inject_Z (Zpos n) * (x - l) * / (r - l)). intros q. clear - q. apply Qabs_case; intros H; rewrite -> Qle_minus_iff. setoid_replace ((1 # 2) + - (q - (inject_Z (Qfloor q) + (1 # 2)))) with (inject_Z (Qfloor q) + 1 + - q) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qle_minus_iff. apply Qlt_le_weak. change 1 with (inject_Z 1). rewrite <- (Q.Zplus_Qplus (Qfloor q) 1). apply Qlt_floor. setoid_replace ((1 # 2) + - - (q - (inject_Z (Qfloor q) + (1 # 2)))) with (q + -inject_Z (Qfloor q)) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qle_minus_iff. apply Qfloor_le. Qed. Definition rasterize1_boundL : forall n (x:Q), l <= x -> (0 <= rasterize1 n x)%Z. Proof. intros n x Hx. change 0%Z with (Qfloor 0). apply Qfloor_resp_le. destruct (Qle_lt_or_eq _ _ Hlr) as [Hlr' | Hlr']. rewrite -> Qlt_minus_iff in Hlr'. rewrite -> Qle_minus_iff in Hx. apply Qle_shift_div_l; auto with *. rewrite Qmult_0_l. apply Qmult_le_0_compat; simpl; auto with *. rewrite -> Hlr'. unfold Qminus. rewrite Qplus_opp_r. unfold Qdiv. change (/0) with 0. ring_simplify. auto with *. Qed. Definition rasterize1_boundR : forall n (x:Q), x < r -> (rasterize1 n x < Zpos n)%Z. Proof. intros n x Hx. rewrite Zlt_Qlt. unfold rasterize1. apply (Qle_lt_trans _ _ _ (Qfloor_le _)). destruct (Qle_lt_or_eq _ _ Hlr) as [Hlr' | Hlr']. rewrite -> Qlt_minus_iff in Hlr'. apply Qlt_shift_div_r. auto with *. apply Qmult_lt_l;simpl; auto with *. rewrite -> Qlt_minus_iff. setoid_replace (r - l + - (x - l)) with (r + - x) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qlt_minus_iff; auto. rewrite -> Hlr'. unfold Qminus. rewrite Qplus_opp_r. unfold Qdiv. change (/0) with 0. rewrite Qmult_0_r. auto with *. Qed. (* Index of x = r in the partition. *) Lemma UniformPartition_fine_aux : forall (n : positive) (x : Q) (Hx : l <= x <= r) (q : r <= x), In (f n (Zpos n - 1)) (UniformPartition n) /\ Qabs (x - f n (Zpos n - 1)) <= (r - l) / ((2#1) * inject_Z (Zpos n)). Proof. intros. split. - apply in_map; rewrite -> UniformPartitionZ. split. apply Z.le_0_sub, Pos.le_1_l. rewrite Z.add_comm. apply Z.add_lt_mono_l. reflexivity. - destruct Hx as [_ Hx]. setoid_replace x with r by (apply Qle_antisym; assumption). unfold f. replace (2 * (Z.pos n - 1) + 1)%Z with (2 * Z.pos n - 1)%Z by ring. change (2*Zpos n #1) with ((2#1)*inject_Z (Zpos n)). change (2*Zpos n - 1#1) with (inject_Z (2*Zpos n + - 1)). rewrite Q.Zplus_Qplus. rewrite Q.Zmult_Qmult. change (inject_Z 2) with (2#1). change (inject_Z (-1)) with (-1#1). setoid_replace (r - (l + (r - l) * ((2#1) * inject_Z (Zpos n) + (-1#1)) / ((2#1) * (inject_Z (Zpos n))))) with (((r-l) / ((2#1) * (inject_Z (Zpos n))))) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; auto). rewrite -> Qabs_pos. apply Qle_refl. apply Qle_shift_div_l. reflexivity. rewrite Qmult_0_l; rewrite -> Qle_minus_iff in Hlr; auto. Qed. (* For any point x in [[l,r]], there is a point y in the uniform partition that is close to x within half the partition's step. *) Lemma UniformPartition_fine : forall (n:positive) (x:Q), l <= x <= r -> {y | In y (UniformPartition n) /\ Qabs (x - y) <= ((r-l)/((2#1)*inject_Z (Zpos n)))}. Proof. intros n x Hx. destruct (Qlt_le_dec_fast x r). - (* x < r *) exists (f n (rasterize1 n x)). abstract ( destruct Hx as [Hlx Hxr]; split; [apply in_map; rewrite -> UniformPartitionZ; split; [apply rasterize1_boundL; auto |apply rasterize1_boundR; auto] |apply rasterize1_close; apply Qle_lt_trans with x; auto]). - (* x = r *) exists (f n (Zpos n - 1)). apply UniformPartition_fine_aux; assumption. Defined. (** Construct the compact set. *) Lemma CompactIntervalQ_nat : forall (e:Qpos), (0 <= Qceiling ((r-l)/(inject_Z 2*proj1_sig e)))%Z. Proof. intros e. change (0%Z) with (Qceiling 0). apply Qceiling_resp_le. apply Qle_shift_div_l. auto with *. rewrite Qmult_0_l. unfold Qminus. rewrite <- Qle_minus_iff. exact Hlr. Qed. (* The finite approximation of real interval [l,r] by rational numbers, at precision e. *) Definition CompactIntervalQ_raw (e:QposInf) : list Q := match e with | QposInfinity => nil | Qpos2QposInf e' => UniformPartition (Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e')))) end. Lemma CompactIntervalQ_prf : is_RegularFunction (@ball (FinEnum Q_as_MetricSpace)) CompactIntervalQ_raw. Proof. cut (forall (e1 e2:Qpos), hemiMetric Q_as_MetricSpace (proj1_sig e1 + proj1_sig e2) (fun a : Q_as_MetricSpace => InFinEnumC a (CompactIntervalQ_raw e1)) (fun a : Q_as_MetricSpace => InFinEnumC a (CompactIntervalQ_raw e2))). { intros Z e1 e2. split. apply (Qpos_nonneg (e1+e2)). split. apply Z. eapply hemiMetric_wd1;[|apply Z]. unfold QposEq; simpl; ring. } intros e1 e2 a Ha. assert (l <= a <= r). { unfold CompactIntervalQ_raw in Ha. set (e1':=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e1)))) in *. assert (L:=UniformPartition_inside e1'). induction (UniformPartition e1'). exfalso; exact (FinSubset_ball_nil Ha). destruct (Qeq_dec a a0) as [A|A]. rewrite -> A. auto with *. apply IHl0; auto with *. apply FinSubset_ball_orC in Ha. destruct Ha as [G | Ha | Ha] using orC_ind. intro abs. contradict G; intro G. contradiction. elim A. apply Qball_0 in Ha. exact Ha. assumption. } unfold CompactIntervalQ_raw. set (e2':=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))). pose proof (UniformPartition_fine e2' H) as [y [Hy0 Hy1]]. apply existsWeaken. exists y. split. - apply InFinEnumC_weaken, Hy0. - simpl. rewrite -> Qball_Qabs. eapply Qle_trans;[apply Hy1|]. apply Qle_trans with (proj1_sig e2). apply Qle_shift_div_r. destruct e2'; auto with *. rewrite Qmult_comm, (Qmult_comm (2#1)), <- Qmult_assoc. rewrite <- (Qinv_involutive (inject_Z 2*proj1_sig e2)). apply Qle_shift_div_l. + apply Qinv_lt_0_compat. exact (Qpos_ispos ((2#1)*e2)). + unfold e2'. generalize (CompactIntervalQ_nat e2). unfold Qdiv. generalize ((r - l) * / (inject_Z 2 * proj1_sig e2)). intros q He. apply Qle_trans with (inject_Z (Qceiling q)). apply Qle_ceiling. destruct (Qceiling q). discriminate. rewrite Z2Pos.id. apply Z.le_refl. reflexivity. discriminate. + rewrite <- Qplus_0_l at 1. apply Qplus_le_l. apply Qpos_nonneg. Qed. Definition CompactIntervalQ : Compact Q_as_MetricSpace := Build_RegularFunction CompactIntervalQ_prf. Local Open Scope CR_scope. Opaque max. (** The compact set indeed represents the interval [[l, r]]. *) Lemma CompactIntervalQ_correct1 : forall (x:CR), inCompact x CompactIntervalQ -> ('l <= x /\ x <= 'r). Proof. intros x Hx. split. unfold CRle. assert (x - 'l == '(-l)%Q + x)%CR. ring. rewrite -> H. clear H. rewrite -> CRplus_translate. intros e. simpl. rewrite -> Qle_minus_iff. setoid_replace (- l + approximate x e + - - proj1_sig e)%Q with (proj1_sig e + - (l - approximate x e))%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qle_minus_iff. apply Qle_closed. intros e2. assert (L:=Hx e e2). simpl in L. set (a:=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))) in *. assert (L0:=UniformPartition_inside a). induction (UniformPartition a). exfalso; exact (FinSubset_ball_nil L). apply FinSubset_ball_orC in L. destruct L as [ G | L | L] using orC_ind. auto with *. rewrite -> Qball_Qabs in L. eapply Qle_trans;[|apply L]. rewrite <- Qabs_opp. eapply Qle_trans;[|apply Qle_Qabs]. rewrite -> Qle_minus_iff. setoid_replace (- (approximate x e - a0) + - (l - approximate x e))%Q with (a0 + - l)%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qle_minus_iff. destruct (L0 a0); auto with *. apply IHl0; auto with *. unfold CRle. rewrite -> CRplus_translate. intros e. simpl. rewrite -> Qle_minus_iff. setoid_replace (r + - approximate x e + - - proj1_sig e)%Q with (proj1_sig e + - (approximate x e - r))%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qle_minus_iff. apply Qle_closed. intros e2. assert (L:=Hx e e2). simpl in L. set (a:=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))) in *. assert (L0:=UniformPartition_inside a). induction (UniformPartition a). exfalso; exact (FinSubset_ball_nil L). apply FinSubset_ball_orC in L. destruct L as [ G | L | L] using orC_ind. auto with *. rewrite -> Qball_Qabs in L. eapply Qle_trans;[|apply L]. eapply Qle_trans;[|apply Qle_Qabs]. rewrite -> Qle_minus_iff. setoid_replace (approximate x e - a0 + - (approximate x e - r))%Q with (r + - a0)%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). rewrite <- Qle_minus_iff. destruct (L0 a0); auto with *. apply IHl0; auto with *. Qed. Lemma CompactIntervalQ_correct2 : forall (x:CR), ('l <= x /\ x <= 'r) -> inCompact x CompactIntervalQ. Proof. intros x [Hlx Hxr] e1 e2. simpl. set (y:= (Qmax (Qmin (approximate x e1) r) l)). apply (@FinSubset_ball_triangle_l _ (proj1_sig e1) (proj1_sig e2) (approximate x e1) y). - unfold y. apply Qmin_case. apply Qmax_case. auto with *. intros H _. split; simpl. unfold CRle in Hlx. assert (x - 'l == '(-l)%Q + x). ring. rewrite -> H0 in Hlx. clear H0. rewrite -> CRplus_translate in Hlx. assert (H0:=Hlx e1). simpl in H0. clear - H0. unfold Qminus. rewrite Qplus_comm. exact H0. apply Qle_trans with 0%Q; auto with *. clear - H. rewrite Qle_minus_iff in *. setoid_replace (0 + - (approximate x e1 - l))%Q with (l + - approximate x e1)%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). exact H. intros H. rewrite -> Qle_max_l in Hlr. simpl. rewrite -> Hlr. split; simpl. clear - H. apply Qle_trans with 0%Q. apply (Qopp_le_compat 0), Qpos_nonneg. rewrite -> Qle_minus_iff in *. rewrite Qplus_0_r. auto. unfold CRle in Hxr. rewrite -> CRplus_translate in Hxr. assert (H0:=Hxr e1). simpl in H0. clear - H0. rewrite -> Qle_minus_iff in *. setoid_replace (proj1_sig e1 + - (approximate x e1 - r))%Q with ( r + - approximate x e1 + - - proj1_sig e1)%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). exact H0. - assert (L: l <= y <= r). { unfold y. auto with *. } set (n:=Z.to_pos (Qceiling ((r - l) / (inject_Z 2 * proj1_sig e2)))). destruct (UniformPartition_fine n L) as [z Hz]. clear - Hz. destruct Hz as [Hz0 Hz1]. induction (UniformPartition n). contradiction. destruct Hz0 as [Hz0 | Hz0]. + intro abs; contradict abs. exists a. split. left. reflexivity. rewrite Hz0. simpl. rewrite -> Qball_Qabs. eapply Qle_trans;[apply Hz1|]. clear Hz1. apply Qle_shift_div_r. reflexivity. unfold Qdiv in n. unfold n. clear n. rewrite (Qmult_comm (r-l)). apply (Qmult_le_l _ _ (/(inject_Z 2 * proj1_sig e2))). apply Qinv_lt_0_compat. apply (Qpos_ispos ((2#1)*e2)). generalize (/ (inject_Z 2 * proj1_sig e2) * (r-l))%Q. intro q. rewrite Qmult_assoc, Qmult_assoc. setoid_replace (/ (inject_Z 2 * proj1_sig e2) * proj1_sig e2 * (2#1))%Q with 1%Q by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field). rewrite Qmult_1_l. apply (Qle_trans _ (inject_Z (Qceiling q)) _ (Qle_ceiling _)). rewrite <- Zle_Qle. destruct (Qceiling q). discriminate. apply Z.le_refl. discriminate. apply Qpos_nonzero. + apply FinSubset_ball_cons. apply IHl0, Hz0. Qed. Lemma CompactIntervalQ_bonus_correct : forall e x, In x (approximate CompactIntervalQ e) -> (l <= x <= r). Proof. intros [e|] x H. simpl in H. eapply UniformPartition_inside. apply H. elim H. Qed. End Interval. (* Located subsets are more general than compact subsets. *) Lemma InfiniteIntervalLocated : forall a : CR, LocatedSubset CR (fun x => a <= x)%CR. Proof. intros a d e x ltde. (* The distance between x and [a,+\infty[ is CRmax 0 (a-x). *) destruct (CRlt_linear _ (CRmax 0%CR (a-x)%CR) _ (CRlt_Qlt d e ltde)) as [far|close]. - left. intros y H abs. clear ltde e. destruct (Qlt_le_dec d 0). apply (msp_nonneg (msp CR)) in abs. exact (Qlt_not_le _ _ q abs). assert (~(('d < a - x)%CR -> False)). { intros H0. apply CRle_not_lt in H0. revert far. apply CRle_not_lt, CRmax_lub. apply CRle_Qle, q. exact H0. } clear far. contradict H0. apply CRle_not_lt. apply CRabs_ball, CRabs_AbsSmall in abs. destruct abs as [abs _]. rewrite (CRplus_le_r _ _ (y+('d)))%CR in abs. ring_simplify in abs. apply (CRle_trans H) in abs. clear H y. rewrite (CRplus_le_r _ _ x). ring_simplify. rewrite CRplus_comm. exact abs. - destruct (Qlt_le_dec d 0). left. intros y H abs. apply (msp_nonneg (msp CR)) in abs. exact (Qlt_not_le _ _ q abs). right. exists (CRmax a x). split. apply CRmax_ub_l. apply CRabs_ball, CRabs_AbsSmall. split. + rewrite (CRplus_le_r _ _ (CRmax a x + 'e))%CR. ring_simplify. apply CRmax_lub. rewrite (CRplus_le_r _ _ (-x))%CR. rewrite <- CRplus_assoc. rewrite CRplus_opp, CRplus_0_r. apply CRle_not_lt. intro abs. apply (CRlt_trans _ _ _ close) in abs. clear close. revert abs. apply CRle_not_lt. apply CRmax_ub_r. apply (@CRle_trans _ (0+x)%CR). rewrite CRplus_0_l. apply CRle_refl. apply CRplus_le_r. apply CRle_Qle, (Qle_trans _ _ _ q). apply Qlt_le_weak, ltde. + rewrite (CRplus_le_r _ _ (CRmax a x)). ring_simplify. apply (@CRle_trans _ (CRmax a x + 0)%CR). rewrite CRplus_0_r. apply CRmax_ub_r. apply CRplus_le_l, CRle_Qle. apply (Qle_trans _ _ _ q). apply Qlt_le_weak, ltde. Qed. corn-8.20.0/reals/fast/LazyNat.v000066400000000000000000000071041473720167500163740ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export Coq.PArith.BinPos. (* Backwards compatibility for Hint Rewrite locality attributes *) Set Warnings "-unsupported-attributes". (** * Lazy Nat This s a lazified version of the natural number that allow one to delay computation until demanded. This is useful for large natural numbers (often upper bounds) where only a small number of terms are actually needed for compuation. *) Inductive LazyNat : Set := | LazyO : LazyNat | LazyS : (unit -> LazyNat) -> LazyNat. (** ** Successor *) Definition lazyS (n:LazyNat) : LazyNat := LazyS (fun _ => n). (** Convert a nat to a lazy nat *) Fixpoint LazifyNat (n : nat) {struct n} : LazyNat := match n with | O => LazyO | S p => LazyS (fun _ => (LazifyNat p)) end. (** ** Predecessor *) Definition LazyPred (n:LazyNat) : LazyNat := match n with | LazyO => LazyO | LazyS n' => (n' tt) end. Lemma LazifyPred : forall n, LazifyNat (pred n) = LazyPred (LazifyNat n). Proof. induction n; reflexivity. Qed. (** ** Addition *) Fixpoint LazyPlus (n m : LazyNat) {struct n} : LazyNat := match n with | LazyO => m | LazyS p => LazyS (fun _ => LazyPlus (p tt) m) end. Lemma LazifyPlus : forall n m, (LazifyNat (n + m) = LazyPlus (LazifyNat n) (LazifyNat m))%nat. Proof. induction n. reflexivity. simpl. intros m. rewrite IHn. reflexivity. Qed. (** ** Multiplication *) Fixpoint Pmult_LazyNat (x:positive) (pow2:LazyNat) {struct x} : LazyNat := match x with | xI x' => (LazyPlus pow2 (Pmult_LazyNat x' (LazyPlus pow2 pow2)))%nat | xO x' => Pmult_LazyNat x' (LazyPlus pow2 pow2)%nat | xH => pow2 end. Lemma LazifyPmult_LazyNat : forall x pow2, LazifyNat (Pmult_nat x pow2) = Pmult_LazyNat x (LazifyNat pow2). Proof. induction x; simpl; intros pow2; repeat (rewrite LazifyPlus||rewrite IHx); reflexivity. Qed. (** Convert a positive to a lazy nat. This is the most common way of generating lazy nats. The simplest fixpoint to do this is not lazy, because the weak head normal form for x=2^k is fully computed. To get LazyS constructors sooner, we could also define a double function on LazyNat. *) Definition LazyNat_of_P (x:positive) := Pmult_LazyNat x (LazyS (fun _ => LazyO)). Lemma LazifyNat_of_P : forall x, LazifyNat (nat_of_P x) = LazyNat_of_P x. Proof. intros x. refine (LazifyPmult_LazyNat _ _). Qed. (* begin hide *) #[global] Hint Rewrite <- LazifyNat_of_P LazifyPmult_LazyNat LazifyPlus LazifyPred : UnLazyNat. (* end hide *) Fixpoint Pplus_LazyNat (p:positive)(n:LazyNat) {struct n} : positive := match n with | LazyO => p | (LazyS n') => (Pplus_LazyNat (Pos.succ p) (n' tt)) end. corn-8.20.0/reals/fast/ModulusDerivative.v000066400000000000000000000227431473720167500204730ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.Q_in_CReals. Require Export CoRN.reals.fast.CRIR. Require Export CoRN.ftc.Rolle. Require Import CoRN.tactics.CornTac. Require Export CoRN.model.metric2.Qmetric. Require Import CoRN.model.totalorder.QposMinMax. Require Export CoRN.model.totalorder.QMinMax. Opaque Qmin Qmax. Opaque CR inj_Q. Section Modulus. (** ** Modulus of continity and derivatives. If two functions, one defined on IR and the other defined on CR, agree on rational valued inside a closed non-trival interval, and the function on IR is differentiable on that interval, then the function on CR is uniformly continuous with modulus [fun e => e/M] where M is some upper bound on the absolute value of the derivative. *) Variable l r : option Q. Hypothesis Hlr : match l,r with | None, _ => True | _, None => True | Some l', Some r' => (l' realline | Some l', None => closel (inj_Q _ l') | None, Some r' => closer (inj_Q _ r') | Some l', Some r' => clcr (inj_Q _ l') (inj_Q _ r') end. Let properI : proper I. Proof. destruct l; destruct r; try constructor. simpl. apply inj_Q_less. assumption. Qed. Let clamp (q:Q) := match l,r with | None, None => q | Some l', None => QboundBelow_uc l' q | None, Some r' => QboundAbove_uc r' q | Some l', Some r' => (uc_compose (QboundBelow_uc l') (QboundAbove_uc r') q) end. Lemma ball_clamp : forall (e:Qpos) (a b : Q), @ball Q_as_MetricSpace (proj1_sig e) a b -> ball (proj1_sig e) (clamp a) (clamp b). Proof. destruct l; destruct r; unfold clamp; intros e a b Hab; try apply uc_prf; apply Hab. Qed. Variable f f' : PartFunct IR. Hypothesis Hf : Derivative I properI f f'. Section GeneralCase. Variable g : Q_as_MetricSpace -> CR. Hypothesis Hg : forall (q:Q) Hq, I (inj_Q _ q) -> (g q == IRasCR (f (inj_Q _ q) Hq))%CR. Variable c : Q. Hypothesis Hc : forall x Hx, I x -> (AbsIR (f' x Hx)[<=](inj_Q _ (c:Q))). Lemma is_UniformlyContinuousD : @is_UniformlyContinuousFunction Q_as_MetricSpace CR (fun x => g (clamp x)) (Qscale_modulus c). Proof. intros e a b Hab. assert (X:forall x, I (inj_Q _ (clamp x))). clear -I Hlr. intros x. destruct l; destruct r; try split; unfold clamp; apply: inj_Q_leEq; simpl; auto with *. assert (Y:=(fun a=> (Hg _ (Derivative_imp_inc _ _ _ _ Hf _ (X a)) (X a)))). do 2 rewrite -> Y. rewrite <- CRAbsSmall_ball. unfold cg_minus. simpl. stepl (IRasCR (inj_Q IR (proj1_sig e))); [| now simpl; apply IR_inj_Q_as_CR]. stepr (IRasCR ((f (inj_Q IR (clamp a)) (Derivative_imp_inc I properI f f' Hf (inj_Q IR (clamp a)) (X a)))[-] (f (inj_Q IR (clamp b)) (Derivative_imp_inc I properI f f' Hf (inj_Q IR (clamp b)) (X b))))) ; [| now simpl; apply IR_minus_as_CR]. rewrite <- IR_AbsSmall_as_CR. apply AbsIR_imp_AbsSmall. eapply leEq_transitive;[eapply Law_of_the_Mean_Abs_ineq;try apply Hf;try apply X|]. intros x H Hx. apply Hc. eapply included_interval;[| |apply H];apply X. revert Hab. apply Qscale_modulus_elim. intros Hc0 _. stepl (inj_Q IR (nring 0)). apply inj_Q_leEq. simpl; auto with *. setoid_replace (inj_Q IR c) with (inj_Q IR (nring 0)). rewrite -> inj_Q_nring. rational. apply inj_Q_wd. auto. intros y Hyc Hab. stepr ((inj_Q IR (proj1_sig e/proj1_sig y)%Q[*](inj_Q _ (proj1_sig y)))). apply mult_resp_leEq_both. eapply leEq_transitive. apply AbsIR_nonneg. apply (Hc _ (Derivative_imp_inc' I properI f f' Hf (inj_Q IR (clamp a)) (X a))). apply X. apply AbsIR_nonneg. apply inj_Q_leEq. destruct Hyc; auto. apply AbsSmall_imp_AbsIR. stepr (inj_Q IR (clamp a - clamp b)%Q); [| now apply inj_Q_minus]. apply inj_Q_AbsSmall. change (ball (proj1_sig y) (clamp a) (clamp b)). apply ball_clamp. auto. assert (Z:[0][<]inj_Q IR (proj1_sig y)). (stepl (inj_Q IR ([0]:Q)); [| now apply (inj_Q_nring IR 0)]); apply inj_Q_less; apply Qpos_ispos. eapply eq_transitive. apply mult_wdl. apply (inj_Q_div IR (proj1_sig e) _ (pos_ap_zero _ _ Z)). apply div_1. Qed. End GeneralCase. Lemma is_UniformlyContinuousD_Q : forall g : Q_as_MetricSpace -> Q, (forall (q : Q) (Hq : Dom f (inj_Q IR q)), I (inj_Q IR q) -> (inj_Q IR (g q) [=] (f (inj_Q IR q) Hq))) -> forall c : Q, (forall (x : Q) (Hx : Dom f' (inj_Q IR x)), I (inj_Q IR x) -> AbsIR (f' (inj_Q IR x) Hx)[<=]inj_Q IR (c:Q)) -> @is_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace (fun x : Q_as_MetricSpace => g (clamp x)) (Qscale_modulus c). Proof. intros g Hg c Hc. intros e a b Hab. rewrite <- ball_Cunit. generalize e a b Hab; clear e a b Hab. change (is_UniformlyContinuousFunction (fun x : Q_as_MetricSpace => ((fun y => '(g y)) (clamp x)))%CR (Qscale_modulus c)). apply is_UniformlyContinuousD. intros q Hq H. rewrite <- IR_inj_Q_as_CR. apply IRasCR_wd. apply Hg. assumption. intros x Hx HI. rstepr ([0][+]inj_Q IR c). apply shift_leEq_plus. apply approach_zero_weak. intros e He. assert (X:Derivative_I (proper_compact_in_interval' I properI x HI (compact_compact_in_interval I properI x HI)) f f'). apply (included_imp_Derivative) with I properI; try assumption. eapply included_trans. apply iprop_compact_in_interval_inc1. apply included_compact_in_interval. set (LI' := (Lend (compact_compact_in_interval I properI x HI))). set (RI' := (Rend (compact_compact_in_interval I properI x HI))). set (I':=(less_leEq IR LI' RI' (proper_compact_in_interval' I properI x HI (compact_compact_in_interval I properI x HI)))). assert (X':Continuous_I I' (FAbs f')). apply Continuous_I_abs. apply (deriv_imp_contin'_I _ _ _ _ _ (less_leEq _ _ _ (proper_compact_in_interval' I properI x HI (compact_compact_in_interval I properI x HI))) X). clear X. destruct (contin_prop _ _ _ _ X' _ (pos_div_two _ _ He)) as [d Hd Hd0]. destruct (iprop_compact_in_interval' _ properI x HI _ I') as [c0 c1]. assert (Z:~((LI'[<]x or x[<]RI')->False)). intro H. fold LI' in c0. fold RI' in c1. apply (leEq_less_or_equal _ _ _ c0). intros [H0|H0];[tauto|]. apply (leEq_less_or_equal _ _ _ c1). intros [H1|H1];[tauto|]. generalize (proper_compact_in_interval' I properI x HI (compact_compact_in_interval I properI x HI)). change (Not (LI'[<]RI')). rewrite <- leEq_def. rewrite -> H0, <- H1. apply leEq_reflexive. rewrite -> leEq_def. intros Z0. apply Z. intros Z'. revert Z0. change (Not (e[<]AbsIR (f' x Hx)[-]inj_Q IR c)). rewrite <- leEq_def. clear Z. assert (J:Max LI' (x[-]d)[<]Min RI' (x[+]d)). destruct Z' as [Z'|Z']. apply less_leEq_trans with x. apply Max_less; auto. rstepr (x[-][0]). apply minus_resp_less_rht. auto. apply leEq_Min; auto with *. rstepl (x[+][0]). apply plus_resp_leEq_lft. apply less_leEq. auto with *. apply leEq_less_trans with x. apply Max_leEq; auto. rstepr (x[-][0]). apply minus_resp_leEq_rht. apply less_leEq. auto. apply less_Min; auto with *. rstepl (x[+][0]). apply plus_resp_less_lft. auto with *. destruct (Q_dense_in_CReals' _ _ _ J) as [q Hq0 Hq1]. rstepr (e[/]TwoNZ [+] e[/]TwoNZ). assert (HI0 : Compact I' (inj_Q IR q)). split; apply less_leEq. eapply leEq_less_trans;[|apply Hq0]. apply lft_leEq_Max. eapply less_leEq_trans;[apply Hq1|]. apply Min_leEq_lft. assert (Hq:Dom f' (inj_Q IR q)). apply (Derivative_imp_inc' _ _ _ _ Hf). apply (included_compact_in_interval _ properI x HI). apply (iprop_compact_in_interval_inc1 _ _ _ _ _ I'). auto. rstepl ((AbsIR (f' x Hx)[-]AbsIR (f' _ Hq))[+](AbsIR (f' _ Hq)[-]inj_Q IR c)). apply plus_resp_leEq_both. eapply leEq_transitive. apply leEq_AbsIR. assert (Z : Dom (FAbs f') x). split;auto. assert (Y : Dom (FAbs f') (inj_Q IR q)). split;auto. rewrite <- (FAbs_char _ _ Z). rewrite <- (FAbs_char _ _ Y). apply Hd0; auto. apply iprop_compact_in_interval'. apply AbsSmall_imp_AbsIR. split. apply shift_leEq_minus'. rstepl (inj_Q IR q[-]d). apply shift_minus_leEq. apply less_leEq. eapply less_leEq_trans;[apply Hq1|]. apply Min_leEq_rht. apply shift_minus_leEq. apply shift_leEq_plus'. apply less_leEq. eapply leEq_less_trans;[|apply Hq0]. apply rht_leEq_Max. eapply leEq_transitive;[|apply nonneg_div_two;apply less_leEq; auto]. clear - Hc HI0. apply shift_minus_leEq. rstepr (inj_Q IR c). apply Hc. apply (included_compact_in_interval _ properI x HI). apply (iprop_compact_in_interval_inc1 _ properI x HI _ I'). auto. Qed. End Modulus. corn-8.20.0/reals/fast/MultivariatePolynomials.v000066400000000000000000001527151473720167500217200ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.algebra.Bernstein. Require Import CoRN.algebra.CRing_Homomorphisms. Require Import CoRN.algebra.COrdFields2. Require Export CoRN.model.ordfields.Qordfield. Require Import CoRN.model.totalorder.QMinMax. Require Import CoRN.tactics.CornTac. Require Import CoRN.tactics.Qauto. Require Import CoRN.model.metric2.Qmetric. From Coq Require Import Qabs. Require Import CoRN.reals.fast.CRabs. Require Import CoRN.reals.fast.ModulusDerivative. Require Import CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRArith_alg. Set Implicit Arguments. Opaque cpoly_cring. Opaque cpoly_apply_fun. Opaque polyconst. Section MultivariatePolynomial. (** ** Multivariable polynomails Here we prove that multivariable polynomials over the rationals are uniformly continuous on the unit hyperinterval. Hence they can be lifted to apply to real numbers. This allows real numbers to be used in polynomial expressions so that each variable is only approximated once. *) Variable F : CRing. (** Define the type of multivariable polynomials with [n] variables *) Fixpoint MultivariatePolynomial (n:nat) : CRing := match n with | O => F | S n' => cpoly_cring (MultivariatePolynomial n') end. (** The constant multivariable polynomial *) Fixpoint MVP_C_ (n:nat) : RingHom F (MultivariatePolynomial n) := match n return RingHom F (MultivariatePolynomial n) with | O => RHid _ | S n' => RHcompose _ _ _ _C_ (MVP_C_ n') end. (** Apply a multivariable polynomial to a vector of input values *) Fixpoint MVP_apply (n:nat) : MultivariatePolynomial n -> (Vector.t F n) -> F := match n return MultivariatePolynomial n -> Vector.t F n -> F with | O => fun x _ => x | (S n') => fun p v => (MVP_apply (p ! (MVP_C_ _ (Vector.hd v))) (Vector.tl v)) end. End MultivariatePolynomial. (* begin hide *) Add Parametric Morphism F n : (@MVP_apply F n) with signature (@st_eq (MultivariatePolynomial F n)) ==> (@eq _) ==> (@st_eq _) as MVP_apply_wd. Proof. induction n; intros x y Hxy z. assumption. simpl. apply IHn. rewrite -> Hxy. reflexivity. Qed. (* end hide *) (* Multivariable polynomial application by a constant set of inputs is a ring homomorphism. *) Lemma zero_MVP_apply : forall F n v, MVP_apply F ([0]:MultivariatePolynomial F n) v[=][0]. Proof. induction v. reflexivity. simpl. rewrite <- IHv. reflexivity. Qed. Lemma one_MVP_apply : forall F n v, MVP_apply F ([1]:MultivariatePolynomial F n) v[=][1]. Proof. induction v. reflexivity. simpl. rewrite <- IHv. rewrite -> one_apply. reflexivity. Qed. Lemma C_MVP_apply : forall F n q v, MVP_apply F (MVP_C_ F n q) v[=]q. Proof. induction v. reflexivity. simpl. rewrite -> c_apply. assumption. Qed. Lemma MVP_plus_apply: forall F n (p q : MultivariatePolynomial F n) v, MVP_apply F (p[+]q) v [=] MVP_apply F p v[+]MVP_apply F q v. Proof. induction v. reflexivity. simpl. rewrite -> plus_apply. apply IHv. Qed. Lemma MVP_mult_apply: forall F n (p q : MultivariatePolynomial F n) v, MVP_apply F (p[*]q) v [=] MVP_apply F p v[*]MVP_apply F q v. Proof. induction v. reflexivity. simpl. rewrite -> mult_apply. apply IHv. Qed. Lemma MVP_c_mult_apply: forall F n (p : MultivariatePolynomial F n) c v, MVP_apply F (MVP_C_ _ _ c[*]p) v[=]c[*]MVP_apply F p v. Proof. induction v. reflexivity. simpl. rewrite <- IHv. rewrite -> c_mult_apply. reflexivity. Qed. Lemma MVP_apply_hom_strext : forall (F:CRing) n (v:Vector.t F n), fun_strext (fun (p:MultivariatePolynomial F n) => MVP_apply _ p v). Proof. induction n. intros v x y. simpl. auto with *. intros v x y H. simpl in H. destruct (csbf_strext _ _ _ _ _ _ _ _ (IHn _ _ _ H)) as [H0 | H0]. assumption. elim (ap_irreflexive _ _ H0). Defined. Definition MVP_apply_hom_csf (F:CRing) n (v:Vector.t F n) := Build_CSetoid_fun _ _ _ (MVP_apply_hom_strext F v). Definition MVP_apply_hom (F:CRing) n (v:Vector.t F n) : RingHom (MultivariatePolynomial F n) F. Proof. exists (MVP_apply_hom_csf F v). intros x y; apply: MVP_plus_apply. intros x y; apply: MVP_mult_apply. apply: one_MVP_apply. Defined. (** [MVP_map] applies a ring homomorphism to the coefficents of a multivariable polynomial *) Fixpoint MVP_map R S (f:RingHom R S) (n:nat) : RingHom (MultivariatePolynomial R n) (MultivariatePolynomial S n) := match n return RingHom (MultivariatePolynomial R n) (MultivariatePolynomial S n) with | O => f | (S n') => cpoly_map (MVP_map f n') end. Lemma MVP_map_C_ : forall R S (f:RingHom R S) n c, MVP_map f n (MVP_C_ _ _ c)[=]MVP_C_ _ _ (f c). Proof. induction n. intros c; reflexivity. intros c. simpl. change (cpoly_map (MVP_map f n) (_C_ (MVP_C_ R n c))[=]_C_ (MVP_C_ S n (f c))). rewrite -> cpoly_map_C. rewrite -> IHn. reflexivity. Qed. (* In practice we use the Bernstein coeffecients to bound the polynomials *) (** Some upper bound on the polynomial on [0,1] *) Fixpoint MVP_upperBound (n:nat) : MultivariatePolynomial Q_as_CRing n -> Q := match n return MultivariatePolynomial Q_as_CRing n -> Q with | O => fun x => x | (S n') => fun p => let (m,b) := BernsteinCoefficents (MVP_C_ Q_as_CRing n') p in Vector.t_rec _ (fun _ _ => Q) 0%Q (fun c _ _ rec => Qmax (MVP_upperBound n' c) rec) m b end. (** Some lower bound on the polynomial on [0,1] *) Fixpoint MVP_lowerBound (n:nat) : MultivariatePolynomial Q_as_CRing n -> Q := match n return MultivariatePolynomial Q_as_CRing n -> Q with | O => fun x => x | (S n') => fun p => let (m,b) := BernsteinCoefficents (MVP_C_ Q_as_CRing n') p in Vector.t_rec _ (fun _ _ => Q) 0%Q (fun c _ _ rec => Qmin (MVP_lowerBound n' c) rec) m b end. Local Open Scope Q_scope. (** Definition of the unit hyperinterval of n dimensions *) Fixpoint UnitHyperInterval (n:nat) (v:Vector.t Q n) : Prop := match v with | Vector.nil _ => True | Vector.cons _ a _ v' => 0 <= a <= 1 /\ UnitHyperInterval v' end. (* begin hide *) Lemma BernsteinApplyRingHom : forall R F (eta: RingHom R F) n i (H:(i <= n)%nat) a, (Bernstein F H) ! (eta a)[=](eta (Bernstein R H) ! a). Proof. induction n. simpl. intros _ _ a. do 2 rewrite -> one_apply. auto with *. intros [|i] H a; simpl;[|destruct (le_lt_eq_dec (S i) (S n) H)]; autorewrite with apply ringHomPush; repeat rewrite -> IHn; reflexivity. Qed. Lemma MVP_BernsteinNonNeg : forall m n i (H:(i <= n)%nat) v (a:Q), 0 <= a -> a <= 1 -> 0 <= @MVP_apply Q_as_CRing m ((Bernstein _ H)!(MVP_C_ _ _ a)) v. Proof. intros m n i H v a Ha0 Ha1. induction v. apply: BernsteinNonNeg; auto. simpl. replace RHS with (MVP_apply Q_as_CRing (Bernstein _ H) ! (MVP_C_ Q_as_CRing n0 a) v). apply IHv. apply: MVP_apply_wd; try reflexivity. rewrite -> BernsteinApplyRingHom. auto with *. Qed. (* end hide *) (** Return the ith entry of a vector *) Fixpoint Vector_ix A (n i:nat) (H:(i < n)%nat) (v:Vector.t A n) : A := match v in Vector.t _ m return (i < m)%nat -> A with | Vector.nil _ => fun p => False_rect _ (Nat.nlt_0_r _ p) | Vector.cons _ c n' v' => fun _ => match lt_le_dec i n' with | left p => Vector_ix p v' | right _ => c end end H. (** The upper and lower bounds are correct. *) Lemma MVP_upperBound_correct : forall n p v, UnitHyperInterval v -> MVP_apply _ p v[<=]MVP_upperBound n p. Proof. induction n; intros p v H. apply Qle_refl. revert p H. dependent inversion v as [|a n0 v0]. clear H. intros p [[Ha0 Ha1] Hv]. stepl (@MVP_apply Q_as_CRing (S n) (let (n0, b) := BernsteinCoefficents (MVP_C_ Q_as_CRing n) p in evalBernsteinBasis (MultivariatePolynomial Q_as_CRing n) b) (@Vector.cons Q a n v0)); [|apply MVP_apply_wd;[apply evalBernsteinCoefficents|reflexivity]]. simpl (MVP_upperBound (S n) p). destruct (BernsteinCoefficents (MVP_C_ Q_as_CRing n) p) as [m b]. apply Qle_trans with (Vector.t_rec (MultivariatePolynomial Q_as_CRing n) (fun (n1 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n1) => Q) 0 (fun (c : MultivariatePolynomial Q_as_CRing n) (n1 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n1) (rec : Q) => Qmax (MVP_apply _ c v0) rec) m b). clear IHn Hv. destruct m as [|m]. rewrite (V0_eq b). unfold evalBernsteinBasis. simpl. rewrite -> zero_MVP_apply. apply Qle_refl. unfold evalBernsteinBasis. match goal with |- (?A <= ?B) => set (L:=A); set (R:=B) end. change (L[<=]R). rstepr (R[*][1]). rewrite <- (@one_MVP_apply Q_as_CRing _ (Vector.cons _ a _ v0)). stepr (R[*](@MVP_apply Q_as_CRing (S n) (@Sumx (cpoly_cring _) _ (fun i H => Bernstein _ (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans _ _ _ H (Nat.le_refl _))))) (Vector.cons _ a _ v0))). fold (MultivariatePolynomial Q_as_CRing n). unfold L, R; clear L R. generalize (Nat.le_refl (S m)). revert b. generalize (S m) at 1 2 5 6 7 8 11. induction b as [| a0]; intros l. simpl. rewrite -> zero_MVP_apply. apply Qle_refl. simpl (Vector.t_rec (MultivariatePolynomial Q_as_CRing n) (fun (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) => Q) 0 (fun (c : MultivariatePolynomial Q_as_CRing n) (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) (rec : Q) => Qmax (MVP_apply Q_as_CRing c v0) rec) (S n1) (Vector.cons _ a0 _ b)). simpl (evalBernsteinBasisH (MultivariatePolynomial Q_as_CRing n) (Vector.cons (MultivariatePolynomial Q_as_CRing n) a0 n1 b) l). simpl (Sumx (fun (i : nat) (H : (i < S n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) H l)))). do 2 rewrite -> MVP_plus_apply. rewrite -> (Qplus_comm (@MVP_apply Q_as_CRing (S n) (Sumx (fun (i : nat) (l0 : (i < n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 l0) l)))) (Vector.cons Q a n v0))). rewrite -> Qmult_comm. rewrite -> Qmult_plus_distr_l. apply Qplus_le_compat; rewrite -> Qmult_comm; rewrite -> Qmax_mult_pos_distr_l. replace LHS with (MVP_apply Q_as_CRing a0 v0 * @MVP_apply Q_as_CRing (S n) (Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r n1 m) (Nat.lt_le_trans n1 (S n1) (S m) (Nat.lt_succ_diag_r n1) l))) (Vector.cons _ a _ v0)). apply Qmax_ub_l. simpl. rewrite <- (MVP_mult_apply Q_as_CRing). apply: MVP_apply_wd; try reflexivity. replace (proj1 (Nat.lt_succ_r n1 m) (Nat.lt_le_trans n1 (S n1) (S m) (Nat.lt_succ_diag_r n1) l)) with (proj2 (Nat.succ_le_mono n1 m) l) by apply le_irrelevent. replace (le_S_n n1 m l) with (proj2 (Nat.succ_le_mono n1 m) l) by apply le_irrelevent. apply c_mult_apply. apply MVP_BernsteinNonNeg; auto. eapply Qle_trans;[|apply Qmax_ub_r]. set (R:=Vector.t_rec (MultivariatePolynomial Q_as_CRing n) (fun (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) => Q) 0 (fun (c : MultivariatePolynomial Q_as_CRing n) (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) (rec : Q) => Qmax (MVP_apply Q_as_CRing c v0) rec) n1 b) in *. replace RHS with (R*@MVP_apply Q_as_CRing (S n) (Sumx (fun (i : nat) (l0 : (i < n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i n1 (S m) l0 (Nat.lt_le_incl _ _ l))))) (Vector.cons _ a _ v0)). apply IHb. apply: mult_wdr. apply MVP_apply_wd; try reflexivity. apply Sumx_wd. intros i H. replace (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 H) l)) with (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i n1 (S m) H (Nat.lt_le_incl n1 (S m) l))) by apply le_irrelevent. reflexivity. clear - Ha0 Ha1. induction n1. rewrite -> zero_MVP_apply. auto with *. simpl (Sumx (fun (i : nat) (l0 : (i < S n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S (S n1)) (S m) (Nat.lt_lt_succ_r i (S n1) l0) l)))). rewrite -> MVP_plus_apply. apply: plus_resp_nonneg. stepr (@MVP_apply Q_as_CRing (S n) (Sumx (fun (i : nat) (l0 : (i < n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 l0) (Nat.lt_le_incl _ _ l))))) (Vector.cons _ a _ v0)). apply IHn1. apply MVP_apply_wd; try reflexivity. apply Sumx_wd. intros i H. replace (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 H) (Nat.lt_le_incl (S n1) (S m) l))) with (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S (S n1)) (S m) (Nat.lt_lt_succ_r i (S n1) (Nat.lt_lt_succ_r i n1 H)) l)) by apply le_irrelevent. reflexivity. apply MVP_BernsteinNonNeg; auto with *. apply mult_wdr. apply MVP_apply_wd; try reflexivity. simpl (MultivariatePolynomial Q_as_CRing (S n)). rewrite <- (fun X => partitionOfUnity X m). apply Sumx_wd. intros i H. replace (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S m) (S m) H (Nat.le_refl (S m)))) with (proj1 (Nat.lt_succ_r i m) H) by apply le_irrelevent. reflexivity. clear - IHn Hv. induction b. auto with *. apply Qmax_le_compat. apply IHn; apply Hv. auto. Qed. Lemma MVP_lowerBound_correct : forall n p v, UnitHyperInterval v -> MVP_lowerBound n p[<=]MVP_apply _ p v. Proof. induction n; intros p v H. apply Qle_refl. revert p H. dependent inversion v as [| a n0 v0 ]. clear H. intros p [[Ha0 Ha1] Hv]. stepr (@MVP_apply Q_as_CRing (S n) (let (n0, b) := BernsteinCoefficents (MVP_C_ Q_as_CRing n) p in evalBernsteinBasis (MultivariatePolynomial Q_as_CRing n) b) (Vector.cons _ a _ v0)); [|apply MVP_apply_wd;[apply evalBernsteinCoefficents|reflexivity]]. simpl (MVP_lowerBound (S n) p). destruct (BernsteinCoefficents (MVP_C_ Q_as_CRing n) p) as [m b]. apply Qle_trans with (Vector.t_rec (MultivariatePolynomial Q_as_CRing n) (fun (n1 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n1) => Q) 0 (fun (c : MultivariatePolynomial Q_as_CRing n) (n1 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n1) (rec : Q) => Qmin (MVP_apply _ c v0) rec) m b). clear - IHn Hv. induction b. auto with *. apply Qmin_le_compat. apply IHn; apply Hv. auto. clear IHn Hv. destruct m as [|m]. rewrite (V0_eq b). unfold evalBernsteinBasis. simpl. rewrite -> zero_MVP_apply. apply Qle_refl. unfold evalBernsteinBasis. match goal with |- (?A <= ?B) => set (R:=A); set (L:=B) end. change (R[<=]L). rstepl (R[*][1]). rewrite <- (@one_MVP_apply Q_as_CRing _ (Vector.cons _ a _ v0)). stepl (R[*](@MVP_apply Q_as_CRing (S n) (@Sumx (cpoly_cring _) _ (fun i H => Bernstein _ (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans _ _ _ H (Nat.le_refl _))))) (Vector.cons _ a _ v0))). fold (MultivariatePolynomial Q_as_CRing n). unfold L, R; clear L R. generalize (Nat.le_refl (S m)). revert b. generalize (S m) at 1 2 4 5 6 9 12. induction b as [| a0]; intros l. simpl. rewrite -> zero_MVP_apply. apply Qle_refl. simpl (Vector.t_rec (MultivariatePolynomial Q_as_CRing n) (fun (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) => Q) 0 (fun (c : MultivariatePolynomial Q_as_CRing n) (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) (rec : Q) => Qmin (MVP_apply Q_as_CRing c v0) rec) (S n1) (Vector.cons _ a0 _ b)). simpl (evalBernsteinBasisH (MultivariatePolynomial Q_as_CRing n) (Vector.cons _ a0 _ b) l). simpl (Sumx (fun (i : nat) (H : (i < S n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) H l)))). do 2 rewrite -> MVP_plus_apply. rewrite -> (Qplus_comm (@MVP_apply Q_as_CRing (S n) (Sumx (fun (i : nat) (l0 : (i < n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 l0) l)))) (Vector.cons _ a _ v0))). rewrite -> Qmult_comm. rewrite -> Qmult_plus_distr_l. apply Qplus_le_compat; rewrite -> Qmult_comm; rewrite -> Qmin_mult_pos_distr_l. replace RHS with (MVP_apply Q_as_CRing a0 v0 * @MVP_apply Q_as_CRing (S n) (Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r n1 m) (Nat.lt_le_trans n1 (S n1) (S m) (Nat.lt_succ_diag_r n1) l))) (Vector.cons _ a _ v0)). apply Qmin_lb_l. simpl. rewrite <- (MVP_mult_apply Q_as_CRing). apply: MVP_apply_wd; try reflexivity. replace (proj1 (Nat.lt_succ_r n1 m) (Nat.lt_le_trans n1 (S n1) (S m) (Nat.lt_succ_diag_r n1) l)) with (proj2 (Nat.succ_le_mono n1 m) l) by apply le_irrelevent. replace (le_S_n n1 m l) with (proj2 (Nat.succ_le_mono n1 m) l) by apply le_irrelevent. apply c_mult_apply. apply MVP_BernsteinNonNeg; auto. eapply Qle_trans;[apply Qmin_lb_r|]. set (R:=Vector.t_rec (MultivariatePolynomial Q_as_CRing n) (fun (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) => Q) 0 (fun (c : MultivariatePolynomial Q_as_CRing n) (n2 : nat) (_ : Vector.t (MultivariatePolynomial Q_as_CRing n) n2) (rec : Q) => Qmin (MVP_apply Q_as_CRing c v0) rec) n1 b) in *. replace LHS with (R*@MVP_apply Q_as_CRing (S n) (Sumx (fun (i : nat) (l0 : (i < n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i n1 (S m) l0 (Nat.lt_le_incl _ _ l))))) (Vector.cons _ a _ v0)). apply IHb. apply: mult_wdr. apply MVP_apply_wd; try reflexivity. apply Sumx_wd. intros i H. replace (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 H) l)) with (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i n1 (S m) H (Nat.lt_le_incl n1 (S m) l))) by apply le_irrelevent. reflexivity. clear - Ha0 Ha1. induction n1. rewrite -> zero_MVP_apply. auto with *. simpl (Sumx (fun (i : nat) (l0 : (i < S n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S (S n1)) (S m) (Nat.lt_lt_succ_r i (S n1) l0) l)))). rewrite -> MVP_plus_apply. apply: plus_resp_nonneg. stepr (@MVP_apply Q_as_CRing (S n) (Sumx (fun (i : nat) (l0 : (i < n1)%nat) => Bernstein (MultivariatePolynomial Q_as_CRing n) (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 l0) (Nat.lt_le_incl _ _ l))))) (Vector.cons _ a _ v0)). apply IHn1. apply MVP_apply_wd; try reflexivity. apply Sumx_wd. intros i H. replace (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S n1) (S m) (Nat.lt_lt_succ_r i n1 H) (Nat.lt_le_incl (S n1) (S m) l))) with (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S (S n1)) (S m) (Nat.lt_lt_succ_r i (S n1) (Nat.lt_lt_succ_r i n1 H)) l)) by apply le_irrelevent. reflexivity. apply MVP_BernsteinNonNeg; auto with *. apply mult_wdr. apply MVP_apply_wd; try reflexivity. simpl (MultivariatePolynomial Q_as_CRing (S n)). rewrite <- (fun X => partitionOfUnity X m). apply Sumx_wd. intros i H. replace (proj1 (Nat.lt_succ_r i m) (Nat.lt_le_trans i (S m) (S m) H (Nat.le_refl (S m)))) with (proj1 (Nat.lt_succ_r i m) H) by apply le_irrelevent. reflexivity. Qed. Local Open Scope Q_scope. (** Use the upper and lower bounds of the derivative of a polynomial to define its modulus of continuity. *) Definition MVP_apply_modulus n (p:MultivariatePolynomial Q_as_CRing (S n)) := let p' := (_D_ p) in Qscale_modulus (Qmax (MVP_upperBound (S n) p') (-(MVP_lowerBound (S n) p'))). Lemma MVP_apply_modulus_correct : forall n (p:MultivariatePolynomial Q_as_CRing (S n)) x y e, (0 <= x) -> (x <= 1) -> (0 <= y) -> (y <= 1) -> @ball_ex Q_as_MetricSpace (MVP_apply_modulus p e) x y -> forall (v:Vector.t Q n), UnitHyperInterval v -> @ball Q_as_MetricSpace (proj1_sig e) (MVP_apply _ p (Vector.cons _ x _ v):Q) (MVP_apply _ p (Vector.cons _ y _ v)). Proof. intros n p x y e Hx0 Hx1 Hy0 Hy1 Hxy v Hv. assert (Hx : (Qmax 0 (Qmin 1 x))==x). rewrite -> Qle_min_r in Hx1. rewrite -> Hx1. rewrite -> Qle_max_r in Hx0. rewrite -> Hx0. reflexivity. assert (Hy : (Qmax 0 (Qmin 1 y))==y). rewrite -> Qle_min_r in Hy1. rewrite -> Hy1. rewrite -> Qle_max_r in Hy0. rewrite -> Hy0. reflexivity. simpl. rewrite <- Hx. rewrite <- Hy. unfold MVP_apply_modulus in Hxy. set (c:=(Qmax (MVP_upperBound (S n) (_D_ p)) (- MVP_lowerBound (S n) (_D_ p)))) in *. set (fp:=cpoly_map (RHcompose _ _ _ (inj_Q_hom IR) (MVP_apply_hom _ v)) p). apply (fun A B e => is_UniformlyContinuousD_Q (Some 0) (Some 1) refl_equal (FPoly _ fp) (FPoly _ (_D_ fp)) (Derivative_poly _ _ _) (fun x => (MVP_apply _ p (Vector.cons _ x _ v))) A c B e x y); try assumption. unfold fp. simpl. intros q _ _. clear - p. change (inj_Q_hom IR (MVP_apply_hom Q_as_CRing v p ! (MVP_C_ Q_as_CRing n q))[=] (cpoly_map (RHcompose (MultivariatePolynomial Q_as_CRing n) Q_as_CRing IR (inj_Q_hom IR) (MVP_apply_hom Q_as_CRing v)) p) ! (inj_Q_hom IR q)). rewrite -> cpoly_map_compose. rewrite <- cpoly_map_apply. apply inj_Q_wd. rewrite -> cpoly_map_apply. apply csbf_wd; try reflexivity. apply: C_MVP_apply. simpl. clear - c Hv. intros x _ [H0x Hx1]. change (AbsIR (_D_ (cpoly_map (RHcompose (MultivariatePolynomial Q_as_CRing n) Q_as_CRing IR (inj_Q_hom IR) (MVP_apply_hom Q_as_CRing v)) p)) ! (inj_Q_hom IR x)[<=] inj_Q IR c). rewrite <- cpoly_map_diff. rewrite -> cpoly_map_compose. rewrite <- cpoly_map_apply. change (AbsIR (inj_Q IR (cpoly_map (MVP_apply_hom Q_as_CRing v) (_D_ p)) ! x)[<=]inj_Q IR c). rewrite -> AbsIR_Qabs. apply inj_Q_leEq. assert (Hx: 0 <= x <= 1). split; apply (leEq_inj_Q IR). rewrite -> inj_Q_Zero. rstepl ([0][/][0][+][1][//]den_is_nonzero IR 0); auto. rewrite -> inj_Q_One. rstepr ([1][/][0][+][1][//]den_is_nonzero IR 1); auto. setoid_replace ((cpoly_map (MVP_apply_hom Q_as_CRing v) (_D_ p)) ! x) with (@MVP_apply Q_as_CRing (S n) (_D_ p) (Vector.cons _ x _ v)). apply Qabs_case; intros H. eapply Qle_trans;[|apply Qmax_ub_l]. apply MVP_upperBound_correct. split; auto. eapply Qle_trans;[|apply Qmax_ub_r]. apply Qopp_le_compat. apply MVP_lowerBound_correct. split; auto. generalize (_D_ p). intros s; clear -s. simpl. change ((cpoly_map_fun (MultivariatePolynomial Q_as_CRing n) Q_as_CRing (MVP_apply_hom Q_as_CRing v) s) ! x == MVP_apply_hom Q_as_CRing v (s ! (MVP_C_ Q_as_CRing n x))). rewrite -> cpoly_map_apply. simpl. rewrite -> C_MVP_apply. reflexivity. Qed. Local Open Scope uc_scope. (** Clamp a value to the unit interval *) Definition Qclamp01 := QboundBelow_uc (0) ∘ QboundAbove_uc 1. Lemma Qclamp01_clamped : forall x, 0 <= Qclamp01 x <= 1. Proof. intros x. unfold Qclamp01. split; simpl. apply Qmax_ub_l. rewrite -> Qmax_min_distr_r. apply Qmin_lb_l. Qed. Lemma Qclamp01_le : forall x y, x <= y -> Qclamp01 x <= Qclamp01 y. Proof. intros x y H. simpl. apply Qmax_le_compat; auto with *. apply Qmin_le_compat; auto with *. Qed. Lemma Qclamp01_close : forall e x y, Qabs (x-y) <= e -> Qabs (Qclamp01 x - Qclamp01 y) <= e. Proof. intros e. cut (forall x y : Q, y <= x -> x - y <= e -> Qclamp01 x - Qclamp01 y <= e). intros H x y. destruct (Qle_total x y). rewrite -> Qabs_neg. intros He. rewrite -> Qabs_neg. replace LHS with (Qclamp01 y - Qclamp01 x) by simpl; ring. apply H; auto. replace LHS with (- (x-y)) by simpl; ring. auto. apply (shift_minus_leEq Q_as_COrdField). stepr (Qclamp01 y); [| now (simpl; ring)]. apply Qclamp01_le. auto. apply (shift_minus_leEq Q_as_COrdField). stepr y; [| now (simpl; ring)]. auto. rewrite -> Qabs_pos. intros He. rewrite -> Qabs_pos. apply H; auto. apply: shift_zero_leEq_minus. apply Qclamp01_le. auto. apply: shift_zero_leEq_minus. auto. intros x y Hxy He. simpl. apply (Qmin_case 1 y). intros Hy. assert (Hx:=Qle_trans _ _ _ Hy Hxy). rewrite -> Qle_min_l in Hx. rewrite -> Hx. replace LHS with 0 by simpl; ring. eapply Qle_trans;[|apply He]. apply: shift_zero_leEq_minus; auto. apply (Qmin_case 1 x). intros Hx Hy. eapply Qle_trans;[|apply He]. apply Qplus_le_compat; auto. apply Qopp_le_compat. apply Qmax_ub_r. intros _ _. apply (Qmax_case 0 x); intros Hx. assert (Hy:=Qle_trans _ _ _ Hxy Hx). rewrite -> Qle_max_l in Hy. rewrite -> Hy. eapply Qle_trans;[|apply He]. apply: shift_zero_leEq_minus; auto. apply (Qmax_case 0 y); intros Hy. eapply Qle_trans;[|apply He]. apply Qplus_le_compat; auto with *. auto. Qed. Require Import CoRN.algebra.RSetoid. (** Definition of a setoid function type of n parameters *) Fixpoint n_Function X Y (n:nat) := match n with |O => Y |S n' => extSetoid X (n_Function X Y n') end. (** Definition of a uniformly continuous function type of n parameters *) Fixpoint n_UniformlyContinuousFunction (X Y:MetricSpace) (n:nat) := match n with |O => Y |S n' => X --> (n_UniformlyContinuousFunction X Y n') end. (** [MVP_uc_sig] is a recursive type definition that is needed for part of the definition of of a multivariable polynomial as a uniformly continuous function. *) Fixpoint MVP_uc_sig (n:nat) :MultivariatePolynomial Q_as_CRing n -> n_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace n -> Type := match n return MultivariatePolynomial Q_as_CRing n -> n_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace n -> Type with | O => fun p x => p==x | (S n') => fun p f => forall v, MVP_uc_sig n' (p ! (MVP_C_ Q_as_CRing _ (Qclamp01 v))) (f v) end. Lemma MVP_uc_rec (n : nat) (IHn : forall p : MultivariatePolynomial Q_as_CRing n, {f : n_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace n & MVP_uc_sig n p f}) (p : MultivariatePolynomial Q_as_CRing (S n)) : @is_UniformlyContinuousFunction Q_as_MetricSpace (n_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace n) (fun (x:Q_as_CRing) => ProjT1 (IHn (p ! (MVP_C_ Q_as_CRing _ (Qclamp01 x))))) (MVP_apply_modulus p). Proof. intros e x y Hxy. assert (Hxy' : ball_ex (MVP_apply_modulus p e) (Qclamp01 x) (Qclamp01 y)) by (destruct (MVP_apply_modulus p e); auto; simpl; rewrite -> Qball_Qabs; apply: Qclamp01_close; rewrite <- Qball_Qabs; auto). destruct (Qclamp01_clamped x) as [Hx0 Hx1]. destruct (Qclamp01_clamped y) as [Hy0 Hy1]. assert (X:=@MVP_apply_modulus_correct _ p (Qclamp01 x) (Qclamp01 y) e Hx0 Hx1 Hy0 Hy1 Hxy'). clear Hxy Hxy'; generalize (proj2_sigT _ _ (IHn p ! (MVP_C_ Q_as_CRing n (Qclamp01 x)))) (proj2_sigT _ _ (IHn p ! (MVP_C_ Q_as_CRing n (Qclamp01 y)))). set (x':=Qclamp01 x) in *; set (y':=Qclamp01 y) in *; simpl in X; revert X. generalize (ProjT1 (IHn p ! (MVP_C_ Q_as_CRing n x'))) (ProjT1 (IHn p ! (MVP_C_ Q_as_CRing n y'))). change (Q_as_CSetoid) with (csg_crr Q_as_CRing). generalize (p ! (MVP_C_ Q_as_CRing n x')) (p ! (MVP_C_ Q_as_CRing n y')). clear - e. induction n. - simpl; intros p q s t H Hs Ht; rewrite <- Hs, <- Ht; apply (H (Vector.nil _)); constructor. - simpl. intros p q s t H Hs Ht. split. apply Qpos_nonneg. intro v; apply (fun H => IHn _ _ _ _ H (Hs v) (Ht v)); intros v0 Hv0; apply (H (Vector.cons _ (Qclamp01 v) _ v0)); split; auto; apply Qclamp01_clamped. Qed. (** Multivariable polynomials are uniformly continuous on the unit hyper interval *) Definition MVP_uc : forall n (p:MultivariatePolynomial Q_as_CRing n), {f:n_UniformlyContinuousFunction Q_as_MetricSpace Q_as_MetricSpace n |MVP_uc_sig _ p f}. Proof. induction n. intros x. exists x. simpl. reflexivity. intros p. exists (Build_UniformlyContinuousFunction (MVP_uc_rec IHn p)). simpl. intros v. exact (ProjT2 (IHn p ! (MVP_C_ Q_as_CRing n (Qclamp01 v)))). Defined. Definition MVP_uc_Q := (fun n p => ProjT1 (MVP_uc n p)). Add Parametric Morphism n : (@MVP_uc_Q n) with signature (@st_eq _) ==> (@msp_eq _) as MVP_uc_Q_wd. Proof. induction n. simpl. unfold MVP_uc_Q. simpl. intros. apply Qball_0,H. intros x y Hxy. apply ucEq_equiv. intro a. apply IHn. rewrite -> Hxy. reflexivity. Qed. Fixpoint n_Cap X Y (plX : PrelengthSpace X) n : Complete (n_UniformlyContinuousFunction X Y n) --> n_UniformlyContinuousFunction (Complete X) (Complete Y) n := match n return Complete (n_UniformlyContinuousFunction X Y n) --> n_UniformlyContinuousFunction (Complete X) (Complete Y) n with | O => uc_id _ | (S n') => (uc_compose_uc _ _ _ (@n_Cap X Y plX n')) ∘ (@Cap X _ plX) end. (** A [Cmap] for an n parameter function. *) Definition n_Cmap X Y (plX : PrelengthSpace X) n : n_UniformlyContinuousFunction X Y n --> n_UniformlyContinuousFunction (Complete X) (Complete Y) n := (@n_Cap X Y plX n) ∘ (@Cunit _). Add Parametric Morphism X Y plX n : (@n_Cap X Y plX n) with signature (@msp_eq _) ==> (@msp_eq _) as n_Cap_wd. Proof. induction n. simpl. auto. intros x y Hxy. apply ucEq_equiv. intro z. apply IHn. apply Cap_wd; auto. reflexivity. Qed. Add Parametric Morphism X Y plX n : (@n_Cmap X Y plX n) with signature (@msp_eq _) ==> (@msp_eq _) as n_Cmap_wd. Proof. intros x y Hxy. unfold n_Cmap. simpl. rewrite -> Hxy. reflexivity. Qed. (** Multivariable polynomials on the unit hyper interval can be applied to real numbers *) Definition MVP_uc_fun n (p:MultivariatePolynomial _ n) : n_UniformlyContinuousFunction CR CR n := n_Cmap _ QPrelengthSpace n (MVP_uc_Q n p). Add Parametric Morphism n : (@MVP_uc_fun n) with signature (@st_eq _) ==> (@msp_eq _) as MVP_uc_fun_wd. Proof. intros x y Hxy. unfold MVP_uc_fun. rewrite -> Hxy. reflexivity. Qed. Section MVP_correct. (** Correctness lemmas for [MVP_uc_fun]. *) Lemma MVP_uc_fun_sub_Q : forall n (p:MultivariatePolynomial _ (S n)) x, 0 <= x -> x <= 1 -> msp_eq (MVP_uc_fun (S n) p ('x)%CR) (MVP_uc_fun n (p!(MVP_C_ _ _ x))). Proof. intros n p x Hx0 Hx1. unfold MVP_uc_fun. apply: n_Cap_wd. intros e1 e2. simpl. unfold Cap_raw. simpl. rewrite Qplus_0_r. change (ball (proj1_sig e1 + proj1_sig e2) (MVP_uc_Q n p ! (MVP_C_ Q_as_CRing n (Qmax 0 (Qmin 1 x)))) (MVP_uc_Q n p ! (MVP_C_ Q_as_CRing n x))). rewrite -> Qle_min_r in Hx1. rewrite -> Hx1. rewrite -> Qle_max_r in Hx0. rewrite -> Hx0. apply ball_refl. apply (Qpos_nonneg (e1+e2)). Qed. Lemma MVP_CR_apply_prf : forall n (morph : MultivariatePolynomial CRasCRing n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n) (morph_prf : forall x1 x2 : MultivariatePolynomial CRasCRing n, x1 [=] x2 -> morph x1 [=] morph x2) p (x y : CR), msp_eq x y -> st_eq (morph (p!(MVP_C_ CRasCRing n x))) (morph (p!(MVP_C_ CRasCRing n y))). Proof. intros. apply morph_prf. apply cpoly_apply_wd. reflexivity. apply csf_wd. apply H. Qed. Lemma MVP_CR_apply_prf_2 : forall n (morph : MultivariatePolynomial CRasCRing n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n) (morph_prf : forall x1 x2 : MultivariatePolynomial CRasCRing n, x1 [=] x2 -> morph x1 [=] morph x2) (p1 p2 : cpoly_cring (MultivariatePolynomial CRasCRing n)), p1 [=] p2 -> extEq (n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n) (fun x : RegularFunction Qball => morph p1 ! (MVP_C_ CRasCRing n x)) (fun x : RegularFunction Qball => morph p2 ! (MVP_C_ CRasCRing n x)). Proof. intros. intro x. simpl. apply morph_prf, cpoly_apply_wd. exact H. apply csf_wd. reflexivity. Qed. (* The induction couples both the apply function and the proof that it is a morphism. *) Fixpoint MVP_CR_apply (n : nat) : extSetoid (MultivariatePolynomial CRasCRing n) (n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n). Proof. destruct n as [|n']. - exact id. - exact (Build_Morphism (MultivariatePolynomial CRasCRing (S n')) (n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) (S n')) (fun p => Build_Morphism _ _ (fun x => (MVP_CR_apply n') (p!(MVP_C_ CRasCRing n' x))) (MVP_CR_apply_prf n' (MVP_CR_apply n') (Morphism_prf (MVP_CR_apply n')) p)) (fun p1 p2 H => MVP_CR_apply_prf_2 n' (MVP_CR_apply n') (Morphism_prf (MVP_CR_apply n')) p1 p2 H)). Defined. Fixpoint MVP_uc_fun_correct_sig_Q n : n_UniformlyContinuousFunction CR CR n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop := match n return n_UniformlyContinuousFunction CR CR n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop with | O => fun a b => msp_eq a b | S n' => fun f g => forall x, (0 <= x)%Q -> (x <= 1)%Q -> MVP_uc_fun_correct_sig_Q n' (f ('x)%CR) (g ('x)%CR) end. Add Parametric Morphism n : (@MVP_uc_fun_correct_sig_Q n) with signature (@msp_eq _) ==> (@st_eq _) ==> iff as MVP_uc_fun_correct_sig_Q_wd. Proof. induction n; intros x y Hxy a b Hab. change (x==a <-> y==b)%CR. rewrite -> Hxy, Hab. reflexivity. simpl. split; intros H c. apply ucEq_equiv in Hxy. rewrite <- (IHn _ _ (Hxy (' c)%CR) _ _ (Hab ('c)%CR)). auto. apply ucEq_equiv in Hxy. rewrite -> (IHn _ _ (Hxy ('c)%CR) _ _ (Hab ('c)%CR)). auto. Qed. Lemma MVP_uc_fun_correct_Q : forall n (p:MultivariatePolynomial Q_as_CRing n), MVP_uc_fun_correct_sig_Q n (MVP_uc_fun n p) (MVP_CR_apply n (MVP_map inject_Q_hom n p)). Proof. induction n; intros p. change ('p=='p)%CR. reflexivity. intros x Hx0 Hx1. change (MVP_uc_fun_correct_sig_Q n (MVP_uc_fun (S n) p ('x)%CR) (MVP_CR_apply n ((MVP_map inject_Q_hom (S n) p)!(MVP_C_ CRasCRing _ ('x)%CR)))). eapply MVP_uc_fun_correct_sig_Q_wd;[apply MVP_uc_fun_sub_Q; auto| |apply IHn]. apply Morphism_prf. simpl. setoid_replace (MVP_C_ CRasCRing n (' x)%CR) with ((MVP_map inject_Q_hom n) (MVP_C_ Q_as_CRing n x)). symmetry. apply cpoly_map_apply. clear - n. induction n. reflexivity. simpl. refine (csf_wd _ _ _ _ _ _). apply IHn. Qed. Fixpoint MVP_uc_fun_close_sig n e : n_UniformlyContinuousFunction CR CR n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop := match n return n_UniformlyContinuousFunction CR CR n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop with | O => fun a b => ball e a b | S n' => fun f g => forall x, (0 <= x)%CR -> (x <= 1)%CR -> MVP_uc_fun_close_sig n' e (f x) (g x) end. Add Parametric Morphism n : (@MVP_uc_fun_close_sig n) with signature Qeq ==> (@msp_eq _) ==> (@st_eq _) ==> iff as MVP_uc_fun_close_sig_wd. Proof. induction n; intros e1 e2 He x y Hxy a b Hab. change (ball e1 x a <-> ball e2 y b). rewrite -> He, Hxy, Hab. reflexivity. simpl. split; intros H c. apply ucEq_equiv in Hxy. rewrite <- (IHn _ _ He _ _ (Hxy c) _ _ (Hab c)). auto. apply ucEq_equiv in Hxy. rewrite -> (IHn _ _ He _ _ (Hxy c) _ _ (Hab c)). auto. Qed. Lemma MVP_uc_fun_close_weaken : forall n (e1 e2:Qpos) f g, (proj1_sig e1 <= proj1_sig e2) -> MVP_uc_fun_close_sig n (proj1_sig e1) f g -> MVP_uc_fun_close_sig n (proj1_sig e2) f g. Proof. induction n; intros e1 e2 f g He H. eapply ball_weak_le. apply He. apply H. intros x Hx0 Hx1. eapply IHn. apply He. apply H; auto. Qed. Fixpoint n_Function_ball01 n e : n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop := match n return n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop with | O => ball e | S n' => fun f g => forall x, (0 <= x)%CR -> (x <= 1)%CR -> n_Function_ball01 n' e (f x) (g x) end. Add Parametric Morphism n : (@n_Function_ball01 n) with signature Qeq ==> (@st_eq _) ==> (@st_eq _) ==> iff as n_Function_ball01_wd. induction n; intros e1 e2 He x y Hxy a b Hab. Proof. change (ball e1 x a <-> ball e2 y b). rewrite -> He, Hxy, Hab. reflexivity. simpl. split; intros H c. rewrite <- (IHn _ _ He _ _ (Hxy c) _ _ (Hab c)). auto. rewrite -> (IHn _ _ He _ _ (Hxy c) _ _ (Hab c)). auto. Qed. Lemma MVP_uc_fun_close_left : forall n (e1 e2:Qpos) f1 f2 g, ball (proj1_sig e1) f1 f2 -> MVP_uc_fun_close_sig n (proj1_sig e2) f2 g -> MVP_uc_fun_close_sig n (proj1_sig e1+proj1_sig e2) f1 g. Proof. induction n; intros e1 e2 f g1 g2 H0 H1. eapply ball_triangle. apply H0. apply H1. intros x Hx0 Hx1. eapply IHn. apply H0; auto. apply H1; auto. Qed. Lemma MVP_uc_fun_close_right : forall n (e1 e2:Qpos) f g1 g2, MVP_uc_fun_close_sig n (proj1_sig e1) f g1 -> n_Function_ball01 n (proj1_sig e2) g1 g2 -> MVP_uc_fun_close_sig n (proj1_sig e1+proj1_sig e2) f g2. Proof. induction n; intros e1 e2 f g1 g2 H0 H1. eapply ball_triangle. apply H0. apply H1. intros x Hx0 Hx1. eapply IHn. apply H0; auto. apply H1; auto. Qed. Lemma n_Function_ball01_sym : forall n e f g, (n_Function_ball01 n e f g) -> (n_Function_ball01 n e g f). Proof. induction n. apply ball_sym. intros e f g H x Hx0 Hx1. apply IHn. apply H; auto. Qed. Lemma n_Function_ball01_triangle : forall n e1 e2 f g h, (n_Function_ball01 n e1 f g) -> (n_Function_ball01 n e2 g h) -> (n_Function_ball01 n (e1+e2)%Q f h). Proof. induction n. apply ball_triangle. intros e1 e2 f g h H0 H1 x Hx0 Hx1. eapply IHn. apply H0; auto. apply H1; auto. Qed. Lemma n_Function_ball01_plus : forall n e p1 p2 p3, (n_Function_ball01 n e (MVP_CR_apply n p2) (MVP_CR_apply n p3)) -> (n_Function_ball01 n e (MVP_CR_apply n (p1[+]p2)) (MVP_CR_apply n (p1[+]p3))). Proof. induction n; intros e p1 p2 p3 H. intros d1 d2. simpl. unfold Qball. unfold Cap_raw. simpl. replace RHS with ((approximate p1 ((1 # 2) * d1)%Qpos - approximate p1 ((1 # 2) * d2)%Qpos) +(approximate p2 ((1 # 2) * d1)%Qpos - approximate p3 ((1 # 2) * d2)%Qpos)) by simpl; ring. replace LHS with (((1 # 2) * proj1_sig d1 + (1 # 2) * proj1_sig d2)%Q +(proj1_sig ((1 # 2) * d1)%Qpos + e + proj1_sig ((1 # 2) * d2)%Qpos))%Q by simpl; ring. (* replace LHS with (proj1_sig ((1 # 2) * d1 + (1 # 2) * d2)%Qpos +proj1_sig ((1 # 2) * d1 + e + (1 # 2) * d2)%Qpos) by simpl; ring. *) apply AbsSmall_plus. change (ball (proj1_sig ((1 # 2) * d1 + (1 # 2) * d2)%Qpos) (approximate p1 ((1 # 2) * d1)%Qpos) (approximate p1 ((1 # 2) * d2)%Qpos)). generalize ((1#2)*d1)%Qpos ((1#2)*d2)%Qpos. change (regFunEq p1 p1). apply regFunEq_equiv. reflexivity. generalize ((1#2)*d1)%Qpos ((1#2)*d2)%Qpos. apply H. intros x Hx0 Hx1. change (n_Function_ball01 n e (MVP_CR_apply _ (p1[+]p2) ! (MVP_C_ CRasCRing _ x)) (MVP_CR_apply _ (p1[+]p3) ! (MVP_C_ CRasCRing _ x))). eapply n_Function_ball01_wd;[| | |apply IHn]. reflexivity. apply Morphism_prf. apply plus_apply. apply Morphism_prf. apply plus_apply. apply: H; auto. Qed. Lemma n_Function_ball01_mult_C : forall n (e:Qpos) c q1 q2, (0 <= c)%CR -> (c <= 1)%CR -> (n_Function_ball01 n (proj1_sig e) (MVP_CR_apply n q1) (MVP_CR_apply n q2)) -> (n_Function_ball01 n (proj1_sig e) (MVP_CR_apply n ((MVP_C_ CRasCRing _ c)[*]q1)) (MVP_CR_apply n ((MVP_C_ CRasCRing _ c)[*]q2))). Proof. induction n; intros e c q1 q2 Hc0 Hc1 H. change (ball (proj1_sig e) (c * q1)%CR (c * q2)%CR). rewrite <- CRAbsSmall_ball. (* change (AbsSmall (' proj1_sig e)%CR (c[*]q1[-]c[*]q2)). *) change (@cg_minus CRasCOrdField (c * q1)%CR (c * q2)%CR) with (c*q1 - c*q2)%CR. setoid_replace (c*q1 - c*q2)%CR with (c * (q1 - q2))%CR by ring. (* rstepr (c[*](q1[-]q2)). *) apply AbsSmall_leEq_trans with (c * 'proj1_sig e)%CR. rewrite <- (CRmult_1_l ('proj1_sig e)%CR) at 2. apply mult_resp_leEq_rht; auto. simpl. apply CRle_Qle, Qpos_nonneg. apply mult_resp_AbsSmall; auto. apply (CRAbsSmall_ball q1 q2). exact H. intros x Hx0 Hx1. change (n_Function_ball01 n (proj1_sig e) (MVP_CR_apply _ (MVP_C_ CRasCRing _ c[*]q1) ! (MVP_C_ CRasCRing _ x)) (MVP_CR_apply _ (MVP_C_ CRasCRing _ c[*]q2) ! (MVP_C_ CRasCRing _ x))). eapply n_Function_ball01_wd. reflexivity. apply Morphism_prf. eapply eq_transitive. apply mult_apply. apply mult_wdl. simpl. apply c_apply. apply Morphism_prf. eapply eq_transitive. apply mult_apply. apply mult_wdl. simpl. apply c_apply. apply IHn; auto. apply: H; auto. Qed. Fixpoint MVP_is_Bound01 n (M:CR) : MultivariatePolynomial CRasCRing n -> Prop := match n return MultivariatePolynomial CRasCRing n -> Prop with | O => fun a => @AbsSmall CRasCOrdField M a | S n' => fun p => forall x, (0 <= x)%CR -> (x <= 1)%CR -> MVP_is_Bound01 n' M (p ! (MVP_C_ CRasCRing _ x)) end. Add Parametric Morphism n : (@MVP_is_Bound01 n) with signature (@msp_eq _) ==> (@st_eq _) ==> iff as MVP_is_Bound01_wd. Proof. induction n; intros x y Hxy a b Hab. simpl. rewrite -> Hxy. rewrite -> Hab. reflexivity. split; intros H c Hc0 Hc1. change (MVP_is_Bound01 n y b ! (MVP_C_ CRasCRing n c)). rewrite <- (IHn _ _ Hxy (a!(MVP_C_ CRasCRing n c)) (b!(MVP_C_ CRasCRing n c))). apply H; auto. rewrite -> Hab. reflexivity. change (MVP_is_Bound01 n x a ! (MVP_C_ CRasCRing n c)). rewrite <- (fun A => IHn y x A (b!(MVP_C_ CRasCRing n c)) (a!(MVP_C_ CRasCRing n c))). apply H; auto. symmetry; auto. rewrite -> Hab. reflexivity. Qed. Lemma MVP_is_Bound01_plus : forall n M N p q, MVP_is_Bound01 n M p -> MVP_is_Bound01 n N q -> MVP_is_Bound01 n (M+N)%CR (p[+]q). Proof. induction n; intros M N p q Hp Hq. apply: AbsSmall_plus; auto. simpl. intros x Hx0 Hx1. rewrite -> plus_apply. auto. Qed. Lemma MVP_is_Bound01_mult01 : forall n M p x, (0 <= x)%CR -> (x <= 1)%CR -> MVP_is_Bound01 n M p -> MVP_is_Bound01 n M (MVP_C_ CRasCRing n x[*]p). Proof. induction n; intros M p x Hx0 Hx1 H. simpl. change (msp_car CR) in p. eapply AbsSmall_leEq_trans;[|apply mult_resp_AbsSmall;[|apply H]]; auto. rewrite <- (CRmult_1_l M) at 2. apply mult_resp_leEq_rht; auto. simpl in H. unfold AbsSmall in H. rewrite <- CRabs_AbsSmall in H. eapply leEq_transitive;[|apply H]. apply CRabs_nonneg. simpl. intros y Hy0 Hy1. rewrite -> mult_apply. rewrite -> c_apply. apply IHn; auto. Qed. Lemma n_Function_ball01_mult : forall n e x y p M, MVP_is_Bound01 n ('M)%CR p -> ball_ex (Qscale_modulus M e) x y -> n_Function_ball01 n (proj1_sig e) (MVP_CR_apply n (MVP_C_ CRasCRing n x[*]p)) (MVP_CR_apply n (MVP_C_ CRasCRing n y[*]p)). Proof. induction n; intros e x y p b Hb Hxy. change (ball (proj1_sig e) (x*p) (y*p))%CR. rewrite <- CRAbsSmall_ball. change (@cg_minus CRasCOrdField (x * p)%CR (y * p)%CR) with (x*p-y*p)%CR. setoid_replace (x*p-y*p)%CR with (p*(x-y))%CR by ring. simpl in Hb. case_eq (Qscale_modulus b e). intros q Hq. apply AbsSmall_leEq_trans with (CRabs p * 'proj1_sig q)%CR. destruct b as [[|nb|nb] db]. discriminate Hq. simpl in Hq. injection Hq; clear Hq; intros Hq; rewrite <- Hq. assert (' proj1_sig ((db # nb) * e)%Qpos >< 0)%CR as Z. { apply Qap_CRap, Qpos_nonzero. } apply shift_mult_leEq with Z. apply: CRlt_Qlt; auto with *. unfold AbsSmall in Hb. rewrite <- CRabs_AbsSmall in Hb. stepr ('(nb#db))%CR; auto. change ((' (nb # db)) == (' proj1_sig e)%CR * CRinvT (' proj1_sig ((db # nb) * e)%Qpos) Z)%CR. rewrite -> CRinv_Qinv. rewrite -> CRmult_Qmult. rewrite -> CReq_Qeq. simpl. rewrite -> Qinv_mult_distr. replace RHS with ((/(db#nb) * proj1_sig e) * /proj1_sig e) by simpl; ring. change (nb#db == ((nb#db)*proj1_sig e/proj1_sig e)). rewrite -> Qdiv_mult_l. reflexivity. apply Qpos_nonzero. elim (Qle_not_lt 0 (Zneg nb # db)); auto with *. rewrite <- CRle_Qle. eapply AbsSmall_nonneg. apply Hb. cut (Not (Not (@AbsSmall CRasCOrdField (CRabs p * (' proj1_sig q))%CR (p * (x - y))%CR))). { unfold Not, AbsSmall. repeat rewrite -> leEq_def. unfold Not; tauto. } generalize (leEq_or_leEq CRasCOrdField [0] p). unfold Not. intros H abs. contradict H; intro H. contradict abs. destruct H as [Hp|Hp]. - rewrite -> CRabs_pos; auto. apply mult_resp_AbsSmall;auto. rewrite Hq in Hxy. apply (CRAbsSmall_ball x y). auto. - rewrite -> CRabs_neg; auto. setoid_replace (p * (x - y))%CR with (-p * (y - x))%CR by ring. apply mult_resp_AbsSmall. rewrite <- CRopp_0. apply inv_resp_leEq. auto. rewrite Hq in Hxy. apply (CRAbsSmall_ball y x). apply ball_sym. apply Hxy. - intros Hq. destruct b as [[|nb|nb] db]; try discriminate Hq. setoid_replace p with 0%CR. rewrite CRmult_comm, CRmult_0_r. apply zero_AbsSmall. simpl. rewrite -> CRle_Qle; auto with *. destruct Hb as [Hb0 Hb1]. apply CRle_antisym. split. stepr ((' (0 # db)))%CR; auto. change ('(0#db)==0)%CR. rewrite -> CReq_Qeq. unfold Qeq; reflexivity. stepl (-(' (0 # db)))%CR; auto. rewrite -> CRopp_Qopp. change ('(0#db)==0)%CR. rewrite -> CReq_Qeq. unfold Qeq; reflexivity. - simpl. intros a Ha0 Ha1. eapply n_Function_ball01_wd. reflexivity. apply Morphism_prf. eapply eq_transitive. apply mult_apply. apply csbf_wd. apply c_apply. reflexivity. apply Morphism_prf. eapply eq_transitive. apply mult_apply. apply csbf_wd. apply c_apply. reflexivity. apply: IHn; auto. Qed. Fixpoint MVP_poor_Bound01 n : MultivariatePolynomial Q_as_CRing n -> Q := match n return MultivariatePolynomial Q_as_CRing n -> Q with | O => Qabs | S n' => fix MVP_poor_Bound01_H p : Q := match p with | cpoly_zero _ => 0 | cpoly_linear _ s p' => MVP_poor_Bound01 n' s + MVP_poor_Bound01_H p' end end. Lemma MVP_poor_Bound01_zero : forall n, MVP_poor_Bound01 n ([0])==0. Proof. induction n. reflexivity. reflexivity. Qed. Add Parametric Morphism n : (@MVP_poor_Bound01 n) with signature (@st_eq _) ==> Qeq as MVP_poor_Bound01_wd. Proof. induction n. intros x y Hxy. simpl in *. rewrite -> Hxy. reflexivity. induction x. induction y. reflexivity. intros [H0 H1]. simpl in *. change 0 with (0+0). apply Qplus_comp. rewrite <- (MVP_poor_Bound01_zero n). apply IHn. symmetry; auto. apply IHy. apply H1. intros [|t y] [H0 H1]. simpl. change 0 with (0+0). apply Qplus_comp. rewrite <- (MVP_poor_Bound01_zero n). apply IHn. auto. change (MVP_poor_Bound01 (S n) x==0). rewrite <- (MVP_poor_Bound01_zero (S n)). apply IHx. apply eq_symmetric. apply H1. simpl. apply Qplus_comp. apply IHn. auto. apply IHx. auto. Qed. Lemma MVP_poor_is_Bound01 : forall n p, MVP_is_Bound01 n ('(MVP_poor_Bound01 n p))%CR (MVP_map inject_Q_hom n p). Proof. induction n. split. change (-('Qabs p)<='p)%CR. rewrite -> CRopp_Qopp. rewrite -> CRle_Qle. simpl in p. replace RHS with (- (- p)) by simpl; ring. apply Qopp_le_compat. rewrite <- Qabs_opp. apply Qle_Qabs. change ('p<=('Qabs p))%CR. rewrite -> CRle_Qle. apply Qle_Qabs. simpl. induction p; intros x Hx0 Hx1. change (MVP_is_Bound01 n 0%CR ([0])). clear - n. induction n. apply AbsSmall_reflexive. apply leEq_reflexive. intros y _ _. apply IHn. change (MVP_is_Bound01 n (' (MVP_poor_Bound01 n s + (fix MVP_poor_Bound01_H (p0 : cpoly (MultivariatePolynomial Q_as_CRing n)) : Q := match p0 with | cpoly_zero _ => 0 | cpoly_linear _ s0 p' => (MVP_poor_Bound01 n s0 + MVP_poor_Bound01_H p')%Q end) p)%Q)%CR (MVP_map inject_Q_hom n s[+]MVP_C_ CRasCRing n x[*](cpoly_map (MVP_map inject_Q_hom n) p) ! (MVP_C_ CRasCRing n x))). rewrite <- CRplus_Qplus. apply MVP_is_Bound01_plus. apply IHn. apply MVP_is_Bound01_mult01; auto. Qed. Lemma MVP_CR_apply_cont : forall n (e : Qpos) (p:MultivariatePolynomial Q_as_CRing (S n)), {d | forall x y, (0 <= x)%CR -> (x <= 1)%CR -> (0 <= 'y)%CR -> ('y <= 1)%CR -> ball_ex d x ('y)%CR -> n_Function_ball01 n (proj1_sig e) (MVP_CR_apply _ (MVP_map inject_Q_hom _ p) x) (MVP_CR_apply _ (MVP_map inject_Q_hom _ p) ('y)%CR)}. Proof. intros n e p. revert e. induction p; intros e. exists QposInfinity. intros x y _ _ _ _ _. change (n_Function_ball01 n (proj1_sig e) (MVP_CR_apply n [0]) (MVP_CR_apply n [0])). generalize (MVP_CR_apply n [0]). induction n. intros. apply ball_refl, Qpos_nonneg. intros s a _ _. apply IHn. simpl. destruct (IHp ((1#2)*e)%Qpos) as [d0 Hd0]. set (b:=MVP_poor_Bound01 (S n) p). set (d1:=(Qscale_modulus b ((1 # 2) * e))). exists (QposInf_min d0 d1). intros x y Hx0 Hx1 Hy0 Hy1 Hxy. change (n_Function_ball01 n (proj1_sig e) (MVP_CR_apply n ((MVP_map inject_Q_hom n s)[+](MVP_C_ CRasCRing n x)[*]((cpoly_map (MVP_map inject_Q_hom n) p)) ! (MVP_C_ CRasCRing n x))) (MVP_CR_apply n ((MVP_map inject_Q_hom n s)[+](MVP_C_ CRasCRing n ('y)%CR)[*]((cpoly_map (MVP_map inject_Q_hom n) p)) ! (MVP_C_ CRasCRing n (inject_Q_hom y)%CR)))). apply n_Function_ball01_plus. setoid_replace (proj1_sig e) with (proj1_sig ((1#2)*e + (1#2)*e)%Qpos) by (simpl; ring). apply n_Function_ball01_triangle with (MVP_CR_apply n (MVP_C_ CRasCRing n x[*] (cpoly_map (MVP_map inject_Q_hom n) p) ! (MVP_C_ CRasCRing n (inject_Q_hom y)%CR))). apply n_Function_ball01_mult_C; auto. change (n_Function_ball01 n ((1 # 2) * proj1_sig e) (MVP_CR_apply (S n) (MVP_map inject_Q_hom (S n) p) x) (MVP_CR_apply (S n) (MVP_map inject_Q_hom (S n) p) ('y)%CR)). apply Hd0; auto with *. eapply ball_ex_weak_le;[|apply Hxy]. apply QposInf_min_lb_l. eapply n_Function_ball01_wd. reflexivity. apply Morphism_prf. apply mult_wdr. eapply eq_transitive. apply csbf_wd;[apply eq_reflexive|]. symmetry. apply MVP_map_C_. symmetry. apply cpoly_map_apply. apply Morphism_prf. apply mult_wdr. eapply eq_transitive. apply csbf_wd;[apply eq_reflexive|]. symmetry. apply MVP_map_C_. symmetry. apply cpoly_map_apply. apply n_Function_ball01_mult with b. assert (Z:=MVP_poor_is_Bound01 (S n) p _ Hy0 Hy1). unfold b. change (MVP_is_Bound01 n (' MVP_poor_Bound01 (S n) p)%CR (MVP_map inject_Q_hom (S n) p) ! (MVP_C_ CRasCRing n (' y)%CR)) in Z. eapply MVP_is_Bound01_wd;[| |apply Z]. reflexivity. simpl. change (MVP_map inject_Q_hom n p ! (MVP_C_ Q_as_CRing n y)[=] (cpoly_map (MVP_map inject_Q_hom n) p) ! (MVP_C_ CRasCRing n (inject_Q_hom y)%CR)). rewrite <- MVP_map_C_. apply cpoly_map_apply. eapply ball_ex_weak_le;[|apply Hxy]. apply QposInf_min_lb_r. Qed. Lemma MVP_uc_fun_close : forall n (e:Qpos) (p:MultivariatePolynomial Q_as_CRing n), MVP_uc_fun_close_sig n (proj1_sig e) (MVP_uc_fun n p) (MVP_CR_apply n (MVP_map inject_Q_hom n p)). Proof. induction n; intros e p. apply ball_refl, Qpos_nonneg. intros x Hx0 Hx1. change (MVP_uc_fun_close_sig n (proj1_sig e) (MVP_uc_fun (S n) p x) (MVP_CR_apply (S n) (MVP_map inject_Q_hom (S n) p) x)). setoid_replace (proj1_sig e) with (proj1_sig ((((1#3)*e)+(1#3)*e)+(1#3)*e)%Qpos) by (simpl; ring). set (e3:=((1#3)*e)%Qpos). destruct (MVP_CR_apply_cont e3 p) as [d0 Hd]. set (d1:=mu (MVP_uc_fun (S n) p) e3). set (d:=QposInf_min d0 d1). set (y:=Qclamp01 (approximate x d)). destruct (Qclamp01_clamped (approximate x d)) as [Hy0 Hy1]. rewrite <- CRle_Qle in Hy0. rewrite <- CRle_Qle in Hy1. pose proof (Hd _ _ Hx0 Hx1 Hy0 Hy1) as Hd0. assert (ball_ex d x (' Qclamp01 (approximate x d))%CR) as Z. { clear - Hx0 Hx1. destruct d as [d|];[|constructor]. change (ball (proj1_sig d) x (' Qclamp01 (approximate x d))%CR). rewrite <- CRAbsSmall_ball. pose proof (ball_approx_r x d) as Z. rewrite <- CRAbsSmall_ball in Z. revert Z. generalize (approximate x d). clear - Hx0 Hx1. intros s [Z0 Z1]. simpl. split. apply Qmax_case. intros _. apply leEq_transitive with 0%CR. rewrite <- CRopp_0. apply inv_resp_leEq. change (0<='proj1_sig d)%CR. rewrite -> CRle_Qle. apply Qpos_nonneg. change (@cg_minus CRasCGroup x (inject_Q_CR 0)) with (x-0)%CR. rewrite CRopp_0, CRplus_0_r. exact Hx0. intros H. apply (CRle_trans Z0). apply (minus_resp_leEq_rht CRasCOrdField (Cunit s) (' Qmin 1 s)%CR x). rewrite -> CRle_Qle. apply Qmin_lb_r. rewrite -> Qmax_min_distr_r. apply Qmin_case. intros _. apply (@CRle_trans _ (1-1)%CR). apply (CRplus_le_r x 1%CR (CRopp 1%CR)). assumption. rewrite CRplus_opp. rewrite -> CRle_Qle. exact (Qpos_nonneg d). intros H. refine (CRle_trans _ Z1). apply (minus_resp_leEq_rht CRasCOrdField _ _ x). rewrite -> CRle_Qle. apply Qmax_ub_r. } eapply MVP_uc_fun_close_right; [|apply n_Function_ball01_sym;apply Hd0]. eapply MVP_uc_fun_close_left. apply uc_prf. eapply ball_ex_weak_le;[|apply Z]. apply QposInf_min_lb_r. rewrite -> CRle_Qle in Hy0. rewrite -> CRle_Qle in Hy1. rewrite -> MVP_uc_fun_sub_Q;auto. eapply MVP_uc_fun_close_sig_wd. reflexivity. reflexivity. simpl. apply Morphism_prf. eapply eq_transitive. apply csbf_wd. reflexivity. symmetry. apply (MVP_map_C_ inject_Q_hom). symmetry. change (cpoly_map_fun (MultivariatePolynomial Q_as_CRing n) (MultivariatePolynomial CRasCRing n) (MVP_map inject_Q_hom n) p) with (cpoly_map (MVP_map inject_Q_hom n) p). apply cpoly_map_apply. apply IHn. eapply ball_ex_weak_le;[|apply Z]. apply QposInf_min_lb_l. Qed. Fixpoint MVP_uc_fun_correct_sig n : n_UniformlyContinuousFunction CR CR n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop := match n return n_UniformlyContinuousFunction CR CR n -> n_Function (msp_as_RSetoid CR) (msp_as_RSetoid CR) n -> Prop with | O => fun a b => msp_eq a b | S n' => fun f g => forall x, (0 <= x)%CR -> (x <= 1)%CR -> MVP_uc_fun_correct_sig n' (f x) (g x) end. (** Finally, the correctness lemma. *) Lemma MVP_uc_fun_correct : forall n (p:MultivariatePolynomial Q_as_CRing n), MVP_uc_fun_correct_sig n (MVP_uc_fun n p) (MVP_CR_apply n (MVP_map inject_Q_hom n p)). Proof. intros n p. generalize (fun e => MVP_uc_fun_close n e p). generalize (MVP_uc_fun n p) (MVP_CR_apply n (MVP_map inject_Q_hom n p)). clear p. induction n; intros a b H. apply ball_eq. intros. apply (H (exist _ _ H0)). intros x Hx0 Hx1. apply IHn. intros e. apply H; auto. Qed. End MVP_correct. corn-8.20.0/reals/fast/Plot.v000066400000000000000000000342151473720167500157330ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith Qround. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.ProductMetric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.RasterizeQ. Require Import CoRN.reals.fast.Interval. Require Export CoRN.metric2.Graph. Require Import CoRN.model.totalorder.QMinMax. Require Export CoRN.model.totalorder.QposMinMax. (** * Plotting Plotting a uniformly continuous function on a finite interval consists of producing the graph of a function as a compact set, approximating that graph, and finally rasterizing that approximation. A range for the plot must be provided. We choose to clamp the plotted function so that it lies inside the specified range. Thus we plot [compose (clip b t) f] rather than [f]. Afterwards we will plot more general located subsets of the plane: - Each blank pixels is correct, meaning there are no points of the subset inside the rectangular regions it represents. In other words, filled pixels cover the subset. - Each filled pixel means there exists a point of the subset inside its rectangular region, or inside one of the adjacent pixels. Thus when we zoom in the filled pixels, we will see more structure. - The pixels overlap, meaning each edge belongs to the 2 pixels that touch it, and each corner belongs to the 4 pixels that touch it. *) Local Open Scope uc_scope. Section PlotPath. Variable (from to:Q). Hypothesis Hfromto:from<=to. Variable (l r:Q). Hypothesis Hlr : l < r. Variable (b t:Q). Hypothesis Hbt : b < t. Variable n : positive. Let w := r - l. Let h := t - b. Lemma wpos : 0 < w. Proof. apply Qlt_minus_iff in Hlr. exact Hlr. Qed. Lemma hpos : 0 < h. Proof. apply Qlt_minus_iff in Hbt. exact Hbt. Qed. (* Compute the number of pixels on the Y-axis to make square pixels. *) Let m : positive := Z.to_pos (Qceiling ((t-b) * inject_Z (Z.pos n) / (r-l))). (** Half the error in the Plot example, since we need to approximate twice. *) Let err := Qpos_max ((1 # 8 * n) * (exist _ _ wpos)) ((1 # 8 * m) * (exist _ _ hpos)). Variable path:Q_as_MetricSpace --> Complete Q2. (** The actual plot function. The approximation of PathImage make a list (Complete Q2), ie a list of points in the real plane. Those points still need to be approximated by rational numbers, which map approximate does. *) Definition PlotPath : positive * positive * Q * sparse_raster n m := (n, m, 2#1, sparse_raster_data n m (map (fun x : Z => rasterize2 n m t l b r ((let (approximate, _) := path (from + (to - from) * (2 * x + 1 # 1) / (2 * Z.pos (Z.to_pos (Qceiling ((to - from) / (inject_Z 2 * proj1_sig (FinEnum_map_modulus (1 # 1) (mu path) err))))) # 1)) in approximate) err)) (iterateN_succ 0 (Z.to_pos (Qceiling ((to - from) / (inject_Z 2 * proj1_sig (FinEnum_map_modulus (1 # 1) (mu path) err)))))))). Definition PlotPath_slow : positive * positive * Q * sparse_raster n m := (n, m, 2#1, RasterizeQ2 (map (fun x : Q_as_MetricSpace => approximate (path x) err) (approximate (CompactIntervalQ Hfromto) (FinEnum_map_modulus (1 # 1) (mu path) err))) n m t l b r). Lemma PlotPath_correct : eq PlotPath PlotPath_slow. Proof. unfold PlotPath, PlotPath_slow, RasterizeQ2. rewrite map_map. unfold CompactIntervalQ, approximate. unfold CompactIntervalQ_raw, UniformPartition. rewrite map_map. reflexivity. Qed. End PlotPath. Lemma plFEQ : PrelengthSpace (FinEnum Q_as_MetricSpace). Proof. apply FinEnum_prelength. apply locatedQ. apply QPrelengthSpace. Qed. Section Plot. Variable (l b:Q). Variable w h:Qpos. Let r:=l+proj1_sig w. Let t:=b+proj1_sig h. Let clip := uc_compose (boundBelow b) (boundAbove t). Variable f : Q_as_MetricSpace --> CR. Lemma lrle : l <= r. Proof. rewrite <- (Qplus_0_r l). unfold r. apply Qplus_le_r, Qpos_nonneg. Qed. Definition graphQ f : Compact Q2 := CompactGraph_b f plFEQ (CompactIntervalQ lrle). Lemma graphQ_bonus : forall e x y, In (x, y) (approximate (graphQ (uc_compose clip f)) e) -> l <= x <= r /\ b <= y <= t. Proof. intros [e|] x y;[|intros; contradiction]. simpl. unfold Cjoin_raw. Opaque CompactIntervalQ. simpl. unfold FinCompact_raw. rewrite map_map. rewrite -> in_map_iff. unfold graphPoint_b_raw; simpl. unfold Couple_raw; simpl. intros [z [Hz0 Hz1]]. inversion Hz0. subst x. subst y. clear Hz0. split. eapply CompactIntervalQ_bonus_correct. apply Hz1. split. apply Qmax_ub_l. apply Qmax_lub. rewrite <- (Qplus_0_r b). unfold t. apply Qplus_le_r, Qpos_nonneg. apply Qmin_lb_l. Qed. Variable n m : positive. (* Number of horizontal and vertical pixels *) Let err := Qpos_max ((1 # 4 * n) * w) ((1 # 4 * m) * h). (** [PlotQ] is the function that computes the pixels. *) Definition PlotQ : sparse_raster n m := RasterizeQ2 (approximate (graphQ (uc_compose clip f)) err) n m t l b r. Local Open Scope raster. (** The resulting plot is close to the graph of [f] *) Theorem Plot_correct : @ball (Compact Q2) (proj1_sig (err + Qpos_max ((1 # 2 * n) * w) ((1 # 2 * m) * h))%Qpos) (graphQ (uc_compose clip f)) (Cunit (CentersOfPixels (PixelizeQ2 PlotQ) (l,t) (r,b))). Proof. apply ball_triangle with (Cunit (approximate (graphQ (uc_compose clip f)) err)). apply ball_approx_r. unfold Compact. rewrite -> ball_Cunit. apply ball_sym. split. apply Qpos_nonneg. apply RasterizeQ2_correct. intros. destruct (InStrengthen H) as [[zx xy] [Hz0 [Hz1 Hz2]]]. simpl in Hz1, Hz2. apply Qball_0 in Hz1. apply Qball_0 in Hz2. rewrite -> Hz1, Hz2. eapply graphQ_bonus. apply Hz0. Qed. End Plot. (** Some nice notation for the graph of f. *) Notation "'graphCR' f [ l '..' r ]" := (graphQ l r (refl_equal _) f) (f at level 0) : raster. (* (* Some graph examples *) Local Open Scope raster. (* enables pretty printing of rasters *) Definition id_raster : raster _ _ := PlotQ 0 1 eq_refl 0 1 eq_refl (@Cunit Q_as_MetricSpace) 30 30. Compute id_raster. Require Import CoRN.reals.fast.CRexp. Definition exp_raster := PlotQ (-2) 1 eq_refl 0 3 eq_refl (exp_bound_uc 3) 30 30. Compute exp_raster. *) (* Difficult to make tail-recursive, because the current vector has no clear size to declare. Vector.map is not tail-recursive either. *) Fixpoint PlotLine (A : CR*CR -> Prop) (i:nat) (r step:Q) (y : CR) (d e:Q) (ltde : d < e) (loc : LocatedSubset (ProductMS CR CR) A) { struct i } : list bool := match i with | O => nil | S p => cons (let xi := inject_Q_CR (r - inject_Z (Z.of_nat i) * step)%Q in if loc d e (xi,y) ltde then false else true) (PlotLine A p r step y d e ltde loc) end. Fixpoint PlotSubset_fix (A : CR*CR -> Prop) (n j:nat) (b r stepX stepY:Q) (d e:Q) (ltde : d < e) (loc : LocatedSubset (ProductMS CR CR) A) { struct j } : list (list bool) := match j with | O => nil | S p => let yj := inject_Q_CR (b + inject_Z (Z.of_nat j) * stepY)%Q in cons (PlotLine A n r stepX yj d e ltde loc) (PlotSubset_fix A n p b r stepX stepY d e ltde loc) end. Definition PlotRadius (n m : positive) (t l b r : Q) : Q := Qmax ((r-l) * (1#n))%Q ((t-b) * (1#m))%Q. Lemma PlotRadiusInc : forall n m t l b r, l < r -> (1#2) * PlotRadius n m t l b r < PlotRadius n m t l b r. Proof. intros. rewrite <- (Qmult_1_l (PlotRadius n m t l b r)) at 2. apply Qmult_lt_r. 2: reflexivity. apply (Qlt_le_trans _ ((r-l) * (1#n))%Q). apply Qlt_minus_iff in H. apply (Qpos_ispos (exist _ _ H * (1 # n))). apply Qmax_ub_l. Qed. Definition PlotSubset {A : CR*CR -> Prop} (n m : positive) (t l b r : Q) (ltlr : l < r) (loc : LocatedSubset (ProductMS CR CR) A) : raster n m := let stepX := ((r-l) * (1#n))%Q in let stepY := ((t-b) * (1#m))%Q in (* A pixel is a square ball and its radius it half its side. *) raster_data _ _ (PlotSubset_fix A (Pos.to_nat n) (Pos.to_nat m) (b-(1#2)*stepY) (r+(1#2)*stepX) stepX stepY _ _ (PlotRadiusInc n m t l b r ltlr) loc). (* Definition PlotDiagLocated := (PlotSubset 10 10 (1#1) (0#1) (0#1) (1#1) eq_refl (undistrib_Located (CompactIsLocated _ (graphQ 0 1 eq_refl (@Cunit Q_as_MetricSpace)) (ProductMS_located locatedQ locatedQ)))). Local Open Scope raster. (* enables pretty printing of rasters *) Time Eval vm_compute in PlotDiagLocated. *) (* The blank pixels have no points of the subset, in other words the filled pixels cover the subset. *) Lemma PlotLine_blank : forall (A : CR*CR -> Prop) (n i:nat) (ltni : (n < i)%nat) (r step:Q) (x y z : CR) (d e:Q) (ltde : d < e) (loc : LocatedSubset (ProductMS CR CR) A), ball d x (inject_Q_CR (r - inject_Z (Z.of_nat (i-n)) * step)%Q) -> ball d y z -> nth n (PlotLine A i r step y d e ltde loc) false = false -> ~A (x,z). Proof. induction n. - intros. intro abs. destruct i. exfalso; inversion ltni. simpl in H1. destruct (loc d e (@pair (@RegularFunction Q Qball) (@RegularFunction Q Qball) (inject_Q_CR (Qminus r (Qmult (inject_Z (Zpos (Pos.of_succ_nat i))) step))) y) ltde). 2: discriminate. clear H1. specialize (n (x,z) abs). contradict n. split. + unfold fst. apply ball_sym. exact H. + exact H0. - intros. intro abs. destruct i. inversion ltni. simpl in H1. revert abs. refine (IHn i (proj2 (Nat.succ_lt_mono n i) ltni) r step x y z d e ltde loc _ H0 H1). replace (i-n)%nat with (S i - S n)%nat by reflexivity. exact H. Qed. Lemma PlotSubset_fix_blank : forall (A : CR*CR -> Prop) (x y : CR) (i j n m:nat) (ltin : (i < n)%nat) (ltjm : (j < m)%nat) (b r stepX stepY:Q) (d e:Q) (ltde : d < e) (loc : LocatedSubset (ProductMS CR CR) A), ball d x (inject_Q_CR (r - inject_Z (Z.of_nat (n-i)) * stepX)%Q) -> ball d y (inject_Q_CR (b + inject_Z (Z.of_nat (m-j)) * stepY)%Q) -> nth i (nth j (PlotSubset_fix A n m b r stepX stepY d e ltde loc) nil) false = false -> ~A (x,y). Proof. induction j. - intros. intro abs. destruct m. exfalso; inversion ltjm. simpl in H1. refine (PlotLine_blank A i n ltin r stepX x (' (b + inject_Z (Z.pos (Pos.of_succ_nat m)) * stepY)%Q)%CR y d e ltde loc H _ H1 abs). apply ball_sym. exact H0. - intros. intro abs. destruct m. inversion ltjm. simpl in H1. apply (IHj n m ltin (proj2 (Nat.succ_lt_mono j m) ltjm) b r stepX stepY d e ltde loc H H0 H1 abs). Qed. Lemma PlotSubset_blank : forall {A : CR*CR -> Prop} (i j : nat) (n m : positive) (t l b r : Q) (x y : CR) (ltin : (i < Pos.to_nat n)%nat) (ltjm : (j < Pos.to_nat m)%nat) (ltlr : l < r) (loc : LocatedSubset (ProductMS CR CR) A), RasterIndex (PlotSubset n m t l b r ltlr loc) j i = false -> let stepX := ((r-l) * (1#n))%Q in let stepY := ((t-b) * (1#m))%Q in ball ((1#2)*(Qmax stepX stepY)) x (inject_Q_CR (l + (inject_Z (Z.of_nat i) + (1#2)) * stepX)%Q) -> ball ((1#2)*(Qmax stepX stepY)) y (inject_Q_CR (t - (inject_Z (Z.of_nat j) + (1#2)) * stepY)%Q) -> ~A (x,y). Proof. intros. setoid_replace (l + (inject_Z (Z.of_nat i)+(1#2)) * stepX)%Q with ((r + (1#2)*stepX) - inject_Z (Z.of_nat (Pos.to_nat n - i)) * stepX)%Q in H0. setoid_replace (t - (inject_Z (Z.of_nat j) + (1#2)) * stepY)%Q with ((b-(1#2)*stepY) + inject_Z (Z.of_nat (Pos.to_nat m - j)) * stepY)%Q in H1. exact (PlotSubset_fix_blank A x y i j (Pos.to_nat n) (Pos.to_nat m) ltin ltjm _ _ stepX stepY ((1#2)*(Qmax stepX stepY)) (Qmax stepX stepY) (PlotRadiusInc n m t l b r ltlr) loc H0 H1 H). - unfold canonical_names.equiv, stdlib_rationals.Q_eq. rewrite Nat2Z.inj_sub. unfold Zminus. rewrite Q.Zplus_Qplus, inject_Z_opp. rewrite <- (Qplus_inj_r _ _ ((inject_Z (Z.of_nat j)+(1#2)) * stepY)). ring_simplify. rewrite positive_nat_Z. unfold stepY. rewrite <- Qmult_assoc. setoid_replace ((1 # m) * inject_Z (Z.pos m)) with 1%Q by reflexivity. rewrite Qmult_1_r. ring. apply (Nat.le_trans _ (S j)). apply le_S, Nat.le_refl. exact ltjm. - unfold canonical_names.equiv, stdlib_rationals.Q_eq. rewrite Nat2Z.inj_sub. unfold Zminus. rewrite Q.Zplus_Qplus, inject_Z_opp. rewrite positive_nat_Z. rewrite <- (Qplus_inj_r _ _ (stepX * inject_Z (Z.pos n) -inject_Z (Z.of_nat i) * stepX - (1#2)*stepX)). ring_simplify. unfold stepX. rewrite <- Qmult_assoc. setoid_replace ((1 # n) * inject_Z (Z.pos n)) with 1%Q by reflexivity. rewrite Qmult_1_r. ring. apply (Nat.le_trans _ (S i)). apply le_S, Nat.le_refl. exact ltin. Qed. corn-8.20.0/reals/fast/PowerBound.v000066400000000000000000000105531473720167500171000ustar00rootroot00000000000000(* Copyright © 2006-2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import ZArith. From Coq Require Import Basics. From Coq Require Import Qpower. Require Import CoRN.stdlib_omissions.Z. Lemma Psize_Zlog2 (p: positive) : Zpos (Pos.size p) = Z.succ (Z.log2 (Zpos p)). Proof. destruct p; simpl; rewrite ?Pos.add_1_r; reflexivity. Qed. Local Open Scope Q_scope. (** These functions effiecently find bounds on rational numbers of the form 3^z or 4^z. *) Lemma power3bound : forall (q:Q), (q <= (3^(Z_of_nat (let (n,_):= q in match n with Zpos p => Psize p | _ => O end)))%Z #1). Proof. intros [[|n|n] d]; try discriminate. unfold Qle. simpl. Open Scope Z_scope. rewrite Zpos_mult_morphism. apply Zmult_le_compat. 2: apply Pos.le_1_l. 2: discriminate. 2: discriminate. clear - n. apply Z.le_trans with (two_p (Z.succ (Z.log2 (Zpos n)))-1)%Z. - rewrite <- Zle_plus_swap. apply Zlt_succ_le. change (Zpos n+1) with (Z.succ (Zpos n)). apply Zsucc_lt_compat. destruct (Z.log2_spec (Zpos n)); auto with zarith. rewrite two_p_correct. assumption. - replace (Z.succ (Z.log2 (Zpos n))) with (Z_of_nat (Psize n)). + apply Z.le_trans with (two_p (Z_of_nat (Psize n))). auto with *. induction (Psize n); auto with *. rewrite inj_S. simpl. unfold Z.succ. rewrite two_p_is_exp; auto with *. change (two_p 1) with 2. rewrite Zpower_exp. 2: apply Z.le_ge, Zle_0_nat. 2: discriminate. apply Zmult_le_compat. exact IHn0. discriminate. induction (Z_of_nat n0). discriminate. discriminate. discriminate. discriminate. + rewrite <- Psize_Zlog2. induction n as [ p ih | p ih | ]. simpl; rewrite Pos2Z.inj_succ, <- ih; apply Z.P_of_succ_nat_Zplus. simpl; rewrite Pos2Z.inj_succ, <- ih; apply Z.P_of_succ_nat_Zplus. reflexivity. Close Scope Z_scope. Qed. Lemma power4bound : forall (q:Q), (q <= inject_Z (4^(Z_of_nat (let (n,_):= q in match n with Zpos p => Psize p | _ => O end)))%Z). Proof. intros q. eapply Qle_trans. apply power3bound. generalize (let (n, _) := q in match n with | 0 => 0%nat | Zpos p => Psize p | Zneg _ => 0%nat end)%Z. intros n. unfold Qle. simpl. ring_simplify. induction n. apply Z.le_refl. rewrite inj_S. unfold Z.succ. do 2 rewrite Zpower_exp by auto with zarith. ring_simplify. apply Zmult_le_compat. 1, 3: discriminate. assumption. clear -n. induction n. discriminate. rewrite inj_S. unfold Z.succ. rewrite Zpower_exp; auto with *. Qed. Lemma power4bound' : forall (q:Q), (0 < q) -> ((/inject_Z((4^(Z_of_nat (let (_,d):= q in Psize d)))%Z)) <= q). Proof. intros [[|n|n] d] H. elim (Qlt_not_eq _ _ H); constructor. 2: elim (Qlt_not_le _ _ H); discriminate. assert (X:=power4bound (Zpos d#n)). simpl in X. rewrite -> Zpower_Qpower by auto with zarith. apply Qle_shift_inv_r. clear - d. induction (Psize d). constructor. rewrite inj_S. unfold Z.succ. rewrite -> Qpower_plus;[|discriminate]. rewrite <- (Qmult_0_r ((4%Z#1) ^ Z.of_nat n)). apply Qmult_lt_l. exact IHn. constructor. rewrite <- Zpower_Qpower by auto with zarith. destruct (inject_Z (Zpos 4%positive ^ Z.of_nat (Psize d))%Z). change ((1 * Zpos (d * Qden)%positive <= Zpos n * Qnum * 1)%Z). ring_simplify. unfold Qle in *. simpl in X. rewrite Zmult_comm. assumption. Qed. corn-8.20.0/reals/fast/RasterQ.v000066400000000000000000000257421473720167500164030ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.raster.Raster. Require Import CoRN.reals.fast.Interval. Require Export CoRN.metric2.FinEnum. Require Export CoRN.metric2.ProductMetric. Require Import CoRN.logic.Classic. Set Implicit Arguments. (** ** Rasters on Planes By attaching coordinates to the top-left and bottom-right corners of a raster, it can be interpreted as a finite set in [Q]^2. *) Definition Q2 := (ProductMS Q_as_MetricSpace Q_as_MetricSpace). (** For [Q2], classical membership in a finite enumeration is the same as a constructive membership. *) Lemma InStrengthen : forall x (l:FinEnum Q2), InFinEnumC x l -> exists y : Q2, In y l /\ msp_eq x y. Proof. induction l. intro abs. exfalso; exact (FinSubset_ball_nil abs). intros H. assert (L:msp_eq x a \/ ~msp_eq x a). destruct (Qeq_dec (fst x) (fst a)). destruct (Qeq_dec (snd x) (snd a)). left. split; apply Qball_0; auto. right; intros [_ B]. apply Qball_0 in B. contradiction. right; intros [B _]. apply Qball_0 in B. contradiction. destruct L. exists a. split; auto with *. destruct (IHl) as [y [Hy0 Hy1]]. apply FinSubset_ball_orC in H. destruct H as [G | H | H] using orC_ind. intro abs. contradict G; intro G. contradiction. elim H0; auto. exact H. exists y. split; auto with *. Qed. Definition InterpRow (up : list Q) (v:list bool) : list Q := map (@fst _ _ ) (filter (@snd _ _) (combine up v)). (* TODO define on sparse rasters directly. *) Definition CentersOfPixels (n m:positive) (pixels : raster n m) (tl br:Q2) : FinEnum Q2 := let (l,t) := tl in let (r,b) := br in let up := (UniformPartition l r n) in flat_map (fun (p:Q*list bool) => let (y,r):=p in map (fun x => (x,y)) (InterpRow up r)) (combine (UniformPartition t b m) (let (d):=pixels in d)). (** Notation for the interpretation of a raster. *) Notation "a ⇱ b ⇲ c" := (CentersOfPixels b a c) (at level 1, format "a ⇱ '[v' '/' b ']' '[v' '/' ⇲ c ']'") : raster. (* Local Open Scope raster. Local Open Scope raster_parsing. Example ex5 := (0, 1)⇱ ⎥█░█⎢ ⎥░█░⎢ ⎥░░█⎢ ⇲(1, 0). Eval compute in (ex5). *) Lemma In_map_snd_const : forall A (v : list A) f (a b : Q), In a (map f v) -> In (a,b) (map (fun x => (f x, b)) v). Proof. induction v. - intros. contradiction H. - intros. simpl. destruct H. subst a0. left. reflexivity. right. apply IHv, H. Qed. Lemma In_filtered_list : forall (l : list Q) (q : Q) (filterList : list bool) (j : nat), (length filterList <= length l)%nat -> Is_true (nth j filterList false) -> In (nth j l q) (map fst (filter snd (combine l filterList))). Proof. induction l. - intros. destruct filterList. 2: exfalso; inversion H. exfalso. simpl in H0. destruct j; contradiction. - intros. destruct filterList. destruct j; contradiction. simpl in H. apply le_S_n in H. simpl. destruct j. + simpl in H0. destruct b. 2: contradiction. left. reflexivity. + destruct b. right. exact (IHl q _ _ H H0). exact (IHl q _ _ H H0). Qed. Lemma In_filter_list : forall (filterList : list bool) (j : nat), Is_true (nth j filterList false) -> (j < length filterList)%nat. Proof. induction filterList. - intros. destruct j; contradiction. - intros. destruct j. simpl. apply le_n_S, Nat.le_0_l. simpl. apply le_n_S. apply IHfilterList, H. Qed. Lemma Vector_bool_in : forall (v : list bool) j, Is_true (nth j v false) -> (j < length v)%nat. Proof. induction v. - intros j H. destruct j; contradiction H. - intros j H. simpl in H. destruct j. apply le_n_S, Nat.le_0_l. simpl. apply le_n_S, IHv, H. Qed. Lemma RasterIndex_in : forall m n i j (r : raster n m), raster_well_formed r -> Is_true (RasterIndex r i j) -> (i < Pos.to_nat m /\ j < Pos.to_nat n)%nat. Proof. intros. destruct r as [l]. destruct H. rewrite <- H. simpl in H0. clear H m. simpl in H0. revert H0. revert i j. induction l as [|a l]. - intros. exfalso. simpl in H0. destruct i; destruct j; contradiction. - intros. inversion H1. subst l0. subst x. clear H1. specialize (IHl H4). destruct i. + split. apply le_n_S, Nat.le_0_l. apply Vector_bool_in in H0. rewrite <- H3. exact H0. + specialize (IHl i j H0). split. apply le_n_S, IHl. apply IHl. Qed. (** Correctness properties of our interpretation. *) Section InterpRasterCorrect. Let f := fun l r (n:positive) (i:Z) => l + (r - l) * (2 * i + 1 # 1) / (2 * Zpos n # 1). Lemma InterpRaster_correct1 : forall n m (t l b r:Q) (bitmap: raster n m) i j, raster_well_formed bitmap -> Is_true (RasterIndex bitmap i j) -> In (f l r n (Z.of_nat j), f t b m (Z.of_nat i)) (CentersOfPixels bitmap (l,t) (r,b)). Proof. intros n m t l b r bitmap. unfold CentersOfPixels, InterpRow, UniformPartition. fold (f l r n). fold (f t b m). generalize (f l r n) (f t b m). clear t l b r f. unfold RasterIndex. intros. pose proof (RasterIndex_in i j _ H H0) as [iin jin]. destruct bitmap as [bitmap], H. apply in_flat_map. exists (nth i (map q0 (iterateN_succ 0 m)) (q0 0%Z), nth i bitmap nil). split. - rewrite <- (combine_nth (map q0 (iterateN_succ 0 m)) bitmap i (q0 0%Z) nil). apply nth_In. rewrite combine_length, map_length, iterateN_succ_length. apply Nat.min_case. exact iin. rewrite H. exact iin. rewrite map_length, iterateN_succ_length, H. reflexivity. - rewrite map_map. replace (q0 (Z.of_nat i)) with (nth i (map q0 (iterateN_succ 0 m)) (q0 0%Z)). apply In_map_snd_const. replace (q (Z.of_nat j)) with (nth j (map q (iterateN_succ 0 n)) (q 0%Z)). apply In_filtered_list. 2: exact H0. rewrite map_length, iterateN_succ_length. rewrite Forall_forall in H1. rewrite (H1 (nth i bitmap nil)). apply Nat.le_refl. apply nth_In. rewrite H. exact iin. rewrite map_nth. apply f_equal. apply iterateN_succ_nth, jin. rewrite map_nth. apply f_equal. apply iterateN_succ_nth, iin. Qed. Lemma InterpRaster_correct2 : forall n m (t l b r:Q) x y (bitmap: raster n m), raster_well_formed bitmap -> In (x,y) (CentersOfPixels bitmap (l,t) (r,b)) -> exists p, Is_true (RasterIndex bitmap (fst p) (snd p)) /\ x=f l r n (Z.of_nat (snd p)) /\ y=f t b m (Z.of_nat (fst p)). Proof. intros n m t l b r x y bitmap. unfold CentersOfPixels, InterpRow, UniformPartition. fold (f l r n). fold (f t b m). generalize (f l r n) (f t b m). clear t l b r f. intros q q0 wf H. apply in_flat_map in H. destruct H as [[s v] [H H0]]. destruct bitmap as [bitmap]. simpl. destruct wf. apply In_nth with (d:=(q0 0%Z, nth 0 bitmap nil)) in H. destruct H as [i [ilt H]]. rewrite combine_length, map_length, iterateN_succ_length in ilt. assert (i < Pos.to_nat m)%nat. { apply (Nat.lt_le_trans _ _ _ ilt), Nat.le_min_l. } clear ilt. rewrite combine_nth in H. 2: rewrite map_length, iterateN_succ_length, H1; reflexivity. inversion H. clear H. subst s. subst v. simpl in H0. rewrite map_map in H0. apply in_map_iff in H0. destruct H0 as [[s b] [H H0]]. unfold fst in H. inversion H. clear H. subst s. clear H6 y. apply filter_In in H0. destruct H0. unfold snd in H0. subst b. apply In_nth with (d:= (q 0%Z,true)) in H. destruct H as [j [jlt H]]. rewrite Forall_forall in H2. rewrite combine_nth in H. inversion H. clear H H4 x. rewrite combine_length, map_length, iterateN_succ_length in jlt. assert (j < Pos.to_nat n)%nat. { apply (Nat.lt_le_trans _ _ _ jlt). apply Nat.le_min_l. } clear jlt. exists (i,j). split. - simpl. rewrite (nth_indep _ false true). rewrite (nth_indep _ nil (nth 0 bitmap nil)). unfold Is_true. rewrite H5. trivial. rewrite H1. exact H3. rewrite H2. exact H. apply nth_In. rewrite H1. exact H3. - simpl. split. rewrite map_nth. apply f_equal. apply iterateN_succ_nth. exact H. rewrite map_nth. apply f_equal. apply iterateN_succ_nth, H3. - rewrite map_length, iterateN_succ_length. rewrite H2. reflexivity. apply nth_In. rewrite H1. exact H3. Qed. End InterpRasterCorrect. (* begin hide *) Add Parametric Morphism n m (bm:raster n m) (bmWf : raster_well_formed bm) : (@CentersOfPixels n m bm) with signature (@msp_eq _) ==> (@msp_eq _) ==> (@msp_eq _) as InterpRaster_wd. Proof. cut (forall (x1 x2 : Q2), msp_eq x1 x2 -> forall x3 x4 : Q2, msp_eq x3 x4 -> forall y, InFinEnumC y (CentersOfPixels bm x1 x3) -> InFinEnumC y (CentersOfPixels bm x2 x4)). { intro L. split. discriminate. split. intros q H1 abs. contradiction (abs q). split. exact (L x y H x0 y0 H0 q H1). reflexivity. intros q H1 abs. contradiction (abs q). split. symmetry in H, H0. exact (L y x H y0 x0 H0 q H1). reflexivity. } intros [x1l x1r] x2 Hx [y1l y1r] y2 Hy z Hz. destruct (@InStrengthen _ _ Hz) as [[ax ay] [Ha0 Ha1]]. destruct (InterpRaster_correct2 _ _ _ _ _ _ _ bmWf Ha0) as [[bx by'] [Hb0 [Hb1 Hb2]]]. rewrite Hb1 in Ha1. rewrite Hb2 in Ha1. unfold snd, fst in Ha1. destruct x2 as [x2l x2r]. destruct y2 as [y2l y2r]. assert (L0:msp_eq z ((x2l + (y2l - x2l) * (2 * Z.of_nat by' + 1 # 1) / (2 * Zpos n # 1)), (x2r + (y2r - x2r) * (2 * Z.of_nat bx + 1 # 1) / (2 * Zpos m # 1)))). transitivity ((x1l + (y1l - x1l) * (2 * Z.of_nat by' + 1 # 1) / (2 * Zpos n # 1)), (x1r + (y1r - x1r) * (2 * Z.of_nat bx + 1 # 1) / (2 * Zpos m # 1))). auto. clear - Hx Hy. destruct Hx as [Hx1 Hx2]. destruct Hy as [Hy1 Hy2]. split; unfold fst,snd in *. apply Qball_0 in Hx1. apply Qball_0 in Hy1. rewrite -> Hx1, Hy1. reflexivity. apply Qball_0 in Hx2. apply Qball_0 in Hy2. rewrite -> Hx2, Hy2. reflexivity. unfold InFinEnumC. rewrite -> (@FinSubset_ball_wd _ z _ 0 0 (CentersOfPixels bm (x2l, x2r) (y2l, y2r)) (reflexivity _) L0). apply InFinEnumC_weaken. auto using InterpRaster_correct1. Qed. (* end hide *) corn-8.20.0/reals/fast/RasterizeQ.v000066400000000000000000000505311473720167500171050ustar00rootroot00000000000000(* Copyright © 2008 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Export CoRN.reals.fast.RasterQ. Require Import CoRN.reals.fast.Interval. Require Import CoRN.logic.Classic. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import Qabs. From Coq Require Import Qround. Local Open Scope Q_scope. Set Implicit Arguments. (** ** Rasterization Rasterization takes finite enumeration of points in [Q2] and moves them around a little so that they lie on a raster. Thus rasterization produces a raster object that when interpreted as a finite enumeration of [Q2] is close to the original enumeration of points. How close depends on how fine a raster is chosen. There is a choice as to how to treat points that lie outside of the bound of a chosen rectangle for rasterization. In this implemenation I choose to push all points inside the raster. In typical applications a rectangle is chosen that contains all the points, so that this doesn't matter. *) (* [Rasterize Point] adds a single point [p] into a raster. The raster is inside the rectanle t l b r, meaning top, left, bottom and right. It has n points horizontally and m points vertically. The indexes (0,0) correspond to the point (l,t) ie the top left corner. That yields the correct printing order of the raster, which is a vector of lines. *) Definition rasterize2 (n m:positive) (t l b r:Q) (p:Q*Q) : Z*Z := pair (Zpos m -1 - (Z.min (Zpos m -1) (Z.max 0 (rasterize1 b t m (snd p)))))%Z (Z.min (Zpos n -1) (Z.max 0 (rasterize1 l r n (fst p)))). Lemma rasterize2_bound : forall n z, (0 <= Z.min (Zpos n -1) (Z.max 0 z) < Zpos n)%Z. Proof. split. - apply Z.min_case. apply Z.le_0_sub, Pos.le_1_l. apply Z.le_max_l. - apply (Z.le_lt_trans _ _ _ (Z.le_min_l _ _)). rewrite <- (Z.add_0_r (Z.pos n)) at 2. apply Z.add_lt_mono_l. reflexivity. Qed. Lemma rasterize1_origin : forall l r n, rasterize1 l r n l = 0%Z. Proof. intros. unfold rasterize1. unfold Qminus. rewrite Qplus_opp_r, Qmult_0_r. unfold Qdiv. rewrite Qmult_0_l. reflexivity. Qed. Lemma rasterize2_origin : forall n m (t l b r : Q), b < t -> rasterize2 n m t l b r (pair l t) = pair 0%Z 0%Z. Proof. assert (forall n:positive, 0 <= Zpos n -1)%Z. { intro n. change 0%Z with (1-1)%Z. apply Z.add_le_mono_r. apply Pos.le_1_l. } intros. unfold rasterize2, fst, snd. rewrite rasterize1_origin. replace (rasterize1 b t m t) with (Zpos m)%Z. change (Z.max 0 0) with 0%Z. rewrite Z.max_r. 2: discriminate. rewrite Z.min_l. rewrite Z.min_r. rewrite Z.sub_diag. reflexivity. apply H. rewrite <- (Z.add_0_r (Zpos m)) at 2. apply Z.add_le_mono_l. discriminate. unfold rasterize1. unfold Qdiv. rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. rewrite Qfloor_Z. reflexivity. intro abs. apply Qlt_minus_iff in H0. unfold Qminus in abs. rewrite abs in H0. exact (Qlt_irrefl 0 H0). Qed. (* Adding a point to a raster preserves all the points that were already in it. *) Lemma setRaster_carry : forall l r n m (bm:raster n m) i j, raster_well_formed bm -> Is_true (RasterIndex bm i j) -> Is_true (RasterIndex (setRaster bm true l r) i j). Proof. intros l r m n bm i j rWf H. destruct (le_lt_dec (Pos.to_nat n) l). rewrite setRaster_overflow; auto. destruct (le_lt_dec (Pos.to_nat m) r). rewrite setRaster_overflow; auto. destruct (eq_nat_dec i l). destruct (eq_nat_dec j r). rewrite e, e0. rewrite setRaster_correct1; try constructor; congruence. rewrite setRaster_correct2; auto. rewrite setRaster_correct2; auto. Qed. Lemma setRaster_uncarry : forall n m (r:raster n m) i j ax ay, raster_well_formed r -> Is_true (RasterIndex (setRaster r true ax ay) i j) -> (Is_true (RasterIndex r i j) \/ (ax, ay) = (i,j)). Proof. intros. destruct (Nat.eq_dec ax i). - destruct (Nat.eq_dec ay j). right. f_equal; assumption. left. rewrite (setRaster_correct2 r) in H0. exact H0. exact H. right. intro abs. subst j. contradiction. - left. rewrite (setRaster_correct2 r) in H0. exact H0. exact H. left. intro abs. subst i. contradiction. Qed. (* Sparse rasters are faster than boolean matrices when the number of points to plot is small with respect to the total number of pixels. Each lit pixel of a sparse raster stores 2 positive numbers. For a 1000x1000 image that's 20 allocations per pixel instead of 1 allocation for boolean matrices. *) Variant sparse_raster (columns lines : positive) : Set := | sparse_raster_data : list (Z*Z) -> sparse_raster columns lines. (** This function is slow to compute in Coq. It is faster to plot a sparse raster with DumpGrayMap. *) Definition PixelizeQ2 {columns lines:positive} (points:sparse_raster columns lines) : raster columns lines := fold_left (fun (rast:raster columns lines) (p:Z*Z) => setRaster rast true (Z.to_nat (fst p)) (Z.to_nat (snd p))) (let (p) := points in p) (emptyRaster columns lines). Definition RasterizeQ2 (points:list Q2) (n m:positive) (t l b r:Q) : sparse_raster n m := sparse_raster_data n m (map (fun p => rasterize2 n m t l b r p) points). Lemma RasterizeQ2_wf : forall points n m t l b r, raster_well_formed (PixelizeQ2 (RasterizeQ2 points n m t l b r)). Proof. intros. unfold PixelizeQ2, RasterizeQ2. pose proof (emptyRaster_wf n m). revert H. generalize (emptyRaster n m). induction points. - intros. exact H. - intros. simpl. apply IHpoints. apply setRaster_wf, H. Qed. Lemma RasterizeQ2_in : forall points (i j : Z) n m (r:raster n m), In (i,j) points -> raster_well_formed r -> (Z.to_nat i < Pos.to_nat m)%nat -> (Z.to_nat j < Pos.to_nat n)%nat -> Is_true (RasterIndex (fold_left (fun (rast:raster n m) (p:Z*Z) => setRaster rast true (Z.to_nat (fst p)) (Z.to_nat (snd p))) points r) (Z.to_nat i) (Z.to_nat j)). Proof. assert (forall points i j n m (r:raster n m), Is_true (RasterIndex r (Z.to_nat i) (Z.to_nat j)) -> raster_well_formed r -> Is_true (RasterIndex (fold_left (fun (rast:raster n m) (p:Z*Z) => setRaster rast true (Z.to_nat (fst p)) (Z.to_nat (snd p))) points r) (Z.to_nat i) (Z.to_nat j))). { induction points. - intros. exact H. - intros. simpl. apply IHpoints. apply setRaster_carry. exact H0. exact H. apply setRaster_wf, H0. } induction points. - intros. exfalso. inversion H0. - intros. simpl. destruct H0. + subst a. simpl. apply H. apply Is_true_eq_left, setRaster_correct1. exact H1. exact H2. exact H3. apply setRaster_wf, H1. + apply IHpoints. exact H0. apply setRaster_wf, H1. exact H2. exact H3. Qed. Lemma RasterizeQ2_in_recip : forall (points : list (Z*Z)) (i j : nat) n m (r:raster n m), raster_well_formed r -> Is_true (RasterIndex (fold_left (fun (rast:raster n m) (p:Z*Z) => setRaster rast true (Z.to_nat (fst p)) (Z.to_nat (snd p))) points r) i j) -> (In (i, j) (map (fun p => (Z.to_nat (fst p), Z.to_nat (snd p))) points) \/ Is_true (RasterIndex r i j)). Proof. induction points as [|[ax ay] points]. - intros. right. exact H0. - intros. simpl in H0. destruct (RasterIndex r i j) eqn:des. right. reflexivity. left. destruct (IHpoints i j n m (setRaster r true (Z.to_nat ax) (Z.to_nat ay)) ). apply setRaster_wf, H. exact H0. right. exact H1. destruct (Nat.eq_dec (Z.to_nat ax) i). + destruct (Nat.eq_dec (Z.to_nat ay) j). left. f_equal; assumption. exfalso. apply setRaster_uncarry in H1. destruct H1. unfold Is_true in H1. rewrite des in H1. contradiction. inversion H1. contradiction. exact H. + exfalso. apply setRaster_uncarry in H1. destruct H1. unfold Is_true in H1. rewrite des in H1. contradiction. inversion H1. contradiction. exact H. Qed. Lemma InFinEnumC_Qepsilon : forall (x y : Q) points, @InFinEnumC (ProductMS _ _) (x,y) points -> exists q, In q points /\ msp_eq q (x,y). Proof. intros. induction points as [|[i j] points]. - exfalso. unfold InFinEnumC, FinSubset_ball in H. contradict H; intros [z [H _]]. inversion H. - destruct (Qeq_dec x i). + destruct (Qeq_dec y j). exists (i,j). split. left. reflexivity. split; apply Qball_0; symmetry; assumption. destruct IHpoints. intro abs. unfold InFinEnumC, FinSubset_ball in H. contradict H; intros [z [zin H0]]. destruct zin. subst z. destruct H0. simpl in H0. apply Qball_0 in H0. contradiction. contradict abs. exists z. split. exact H. exact H0. exists x0. split. right. apply H0. apply H0. + destruct IHpoints. intro abs. unfold InFinEnumC, FinSubset_ball in H. contradict H; intros [z [zin H0]]. destruct zin. subst z. destruct H0. simpl in H. apply Qball_0 in H. contradiction. contradict abs. exists z. split. exact H. exact H0. exists x0. split. right. apply H0. apply H0. Qed. (* end hide *) Section RasterizeCorrect. (* Middles of the horizontal subdivision of the segment [[l, r]]. Instead of l, l + (r-l)/n, ... it is l + (r-l)/2n, l + (r-l)*3/2n, ... *) Let C : Q -> Q -> positive -> Z -> Q := fun l r (n:positive) (i:Z) => l + (r - l) * (2 * i + 1 # 1) / (2 * Z.pos n # 1). (* rasterize1 is used in both horizontally and vertically, so it will be called for left,width and also for bottom,height. *) Lemma rasterize1_error : forall l (w:Qpos) n x, (l <= x <= l + proj1_sig w) -> Qball ((1 #2*n) * proj1_sig w) (C l (l + proj1_sig w) n (Z.min (Z.pos n -1) (Z.max 0 (rasterize1 l (l+proj1_sig w) n x)))) x. Proof. clear - C. intros l w n x H0. destruct (Qlt_le_dec x (l+proj1_sig w)). - replace (Z.min (Z.pos n -1) (Z.max 0 (rasterize1 l (l + proj1_sig w) n x))) with (rasterize1 l (l + proj1_sig w) n x). + apply ball_sym. simpl. rewrite -> Qball_Qabs. assert (l < l + proj1_sig w). { rewrite -> Qlt_minus_iff. ring_simplify. exact (Qpos_ispos w). } eapply Qle_trans. unfold C. apply (rasterize1_close H). setoid_replace (l + proj1_sig w - l) with (proj1_sig w) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). unfold Qdiv. rewrite Qmult_comm. apply Qmult_le_compat_r. apply Qle_refl. apply Qpos_nonneg. + rewrite Z.max_r. apply Z.min_case_strong. intros H. apply Zle_antisym; auto. apply Zlt_succ_le. rewrite <- Z.add_1_r. replace (Z.pos n - 1 + 1)%Z with (Z.pos n) by ring. apply rasterize1_boundR; auto. rewrite -> Qle_minus_iff. ring_simplify. exact (Qpos_nonneg w). reflexivity. destruct H0. apply rasterize1_boundL; auto. apply Qle_trans with x; auto. - rewrite Z.min_l. setoid_replace x with (l + proj1_sig w). apply ball_sym. rewrite -> Qball_Qabs. unfold C. rewrite <- (Qmult_comm (proj1_sig w)). change (1 # 2*n) with (/((2#1)*inject_Z (Z.pos n))). change (2*Z.pos n #1) with ((2#1)*inject_Z (Z.pos n)). replace (2 * (Z.pos n - 1) + 1)%Z with (2*Z.pos n + - 1)%Z by ring. change (2*Z.pos n + -1#1) with (inject_Z (2*Z.pos n + - 1)). rewrite -> Q.Zplus_Qplus. rewrite -> Q.Zmult_Qmult. change (inject_Z 2) with (2#1). change (inject_Z (-1)) with (-1#1)%Q. setoid_replace (l + proj1_sig w - (l + (l + proj1_sig w - l) * ((2#1) * inject_Z (Z.pos n) + (-1#1)) / ((2#1) * (inject_Z (Z.pos n))))) with ((proj1_sig w / ((2#1) * (inject_Z (Z.pos n))))) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; field; unfold Qeq; simpl; auto with *). rewrite -> Qabs_pos;[apply Qle_refl|]. apply Qle_shift_div_l. rewrite <- (Qmult_0_r (2#1)). apply Qmult_lt_l. reflexivity. simpl; auto with *; unfold Qlt; simpl; auto with *. rewrite Qmult_0_l. exact (Qpos_nonneg w). destruct H0. apply Qle_antisym; auto. eapply Z.le_trans;[|apply Z.le_max_r]. unfold rasterize1. rewrite <- (Qfloor_Z (Z.pos n -1)). apply Qfloor_resp_le. setoid_replace x with (l+proj1_sig w). setoid_replace (l + proj1_sig w - l) with (proj1_sig w) by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; simpl; ring). unfold Qdiv. rewrite <- Qmult_assoc, Qmult_inv_r, Qmult_1_r. 2: apply Qpos_nonzero. rewrite <- Zle_Qle. rewrite <- (Z.add_0_r (Z.pos n)) at 2. apply Z.add_le_mono_l. discriminate. apply Qle_antisym. apply H0. exact q. Qed. (* Strange, we should always have b <= t in rasterize1. *) Lemma switch_line_interp : forall (t b : Q) (m : positive) (j : Z), (j < Z.pos m)%Z -> C t b m (Z.pos m - 1- j) == C b t m j. Proof. intros t b m j H. unfold C. replace (2 * (Z.pos m -1 - j) + 1)%Z with (2 * (Z.pos m - j) - 1)%Z by ring. change (2 * (Z.pos m - j) - 1 # 1) with (inject_Z (2 * (Z.pos m - j) + - 1)%Z). change (2*Z.pos m#1) with ((2#1)*inject_Z (Z.pos m)). change ((2*j +1)#1) with (inject_Z (2*j+1)%Z). do 2 rewrite -> Q.Zplus_Qplus. rewrite -> Q.Zmult_Qmult. change (inject_Z (-1)) with (-1#1). rewrite -> Q.Zmult_Qmult. change (inject_Z 2) with (2#1). unfold Zminus. rewrite -> Q.Zplus_Qplus. change (inject_Z (-j)) with (-inject_Z j). field. apply Q.positive_nonzero_in_Q. Qed. Variable b l:Q. Variable w h:Qpos. Let r:=l+proj1_sig w. Let t:=b+proj1_sig h. Variable points:FinEnum Q2. Variable n m : positive. Let errX : Qpos := ((1#2*n)*w)%Qpos. Let errY : Qpos := ((1#2*m)*h)%Qpos. Let err : Qpos := Qpos_max errX errY. Hypothesis Hf : forall (x y : Q), InFinEnumC ((x,y):ProductMS _ _) points -> (l<= x <= r) /\ (b <= y <= t). (** The Rasterization is close to the original enumeration, ie each one is approximately included in the other, within error err (Hausdorff distance). To measure closeness, we use the product metric on Q2, which has square balls aligned with the 2 axes. *) Lemma RasterizeQ2_correct1 : forall (x y:Q), @InFinEnumC (ProductMS _ _) (x,y) points -> exists p, In p (CentersOfPixels (PixelizeQ2 (RasterizeQ2 points n m t l b r)) (l,t) (r,b)) /\ ball (proj1_sig err) p (x,y). Proof. intros x y H. pose proof (Hf H) as xybound. apply InFinEnumC_Qepsilon in H. destruct H as [q [H H0]]. assert (let (i,j) := rasterize2 n m t l b r q in Is_true (RasterIndex (PixelizeQ2 (RasterizeQ2 points n m t l b r)) (Z.to_nat i) (Z.to_nat j))). { apply RasterizeQ2_in. apply (in_map (fun p : Q * Q => rasterize2 n m t l b r p) points). exact H. apply emptyRaster_wf. apply Nat2Z.inj_lt. rewrite positive_nat_Z, Z2Nat.id. apply Z.lt_0_sub. ring_simplify. apply (Z.lt_le_trans _ (0+1)). reflexivity. apply Z.add_le_mono_r. apply rasterize2_bound. apply Z.le_0_sub. apply Z.le_min_l. apply Nat2Z.inj_lt. rewrite positive_nat_Z, Z2Nat.id. apply rasterize2_bound. apply rasterize2_bound. } pose (Z.pos m - 1 - Z.min (Z.pos m - 1) (Z.max 0 (rasterize1 b t m (snd q))))%Z as i. pose (Z.min (Z.pos n - 1) (Z.max 0 (rasterize1 l r n (fst q)))) as j. exists ((fun (l r : Q) (n : positive) (i : Z) => l + (r - l) * (2 * i + 1 # 1) / (2 * Z.pos n # 1)) l r n (Z.of_nat (Z.to_nat j)), (fun (l r : Q) (n : positive) (i : Z) => l + (r - l) * (2 * i + 1 # 1) / (2 * Z.pos n # 1)) t b m (Z.of_nat (Z.to_nat i))). split. apply InterpRaster_correct1. apply RasterizeQ2_wf. exact H1. rewrite Z2Nat.id. rewrite Z2Nat.id. destruct H0, q. split. - unfold fst. destruct xybound. apply Qball_0 in H0. unfold fst in H0. clear H2. rewrite <- H0 in H3. unfold j, r. rewrite <- H0. unfold fst. apply ball_weak_le with (e:=((1 # 2 * n) * proj1_sig w)). apply (Qpos_max_ub_l errX errY). apply (@rasterize1_error l w n _ H3). - unfold snd. destruct xybound. apply Qball_0 in H2. unfold snd in H2. clear H0. rewrite <- H2 in H4. unfold i, t. rewrite <- H2. unfold snd. apply ball_weak_le with (e:=((1 # 2 * m) * proj1_sig h)). apply (Qpos_max_ub_r errX errY). pose proof (@rasterize1_error b h m _ H4). rewrite <- switch_line_interp in H0. apply H0. apply rasterize2_bound. - unfold i. apply Z.le_0_sub. apply Z.le_min_l. - apply rasterize2_bound. Qed. Lemma RasterizeQ2_correct2 : forall (x y : Q), @InFinEnumC (ProductMS _ _) (x,y) (CentersOfPixels (PixelizeQ2 (RasterizeQ2 points n m t l b r)) (l,t) (r,b)) -> exists p, In p points /\ ball (proj1_sig err) p (x,y). Proof. intros x y H. apply InFinEnumC_Qepsilon in H. destruct H as [q [qin qeq]]. destruct q as [qx qy]. destruct (InterpRaster_correct2 _ _ _ _ _ _ _ (RasterizeQ2_wf points n m t l b r) qin) as [[j i] [Hij [Hx' Hy']]]. unfold fst, snd in Hij. apply RasterizeQ2_in_recip in Hij. 2: apply emptyRaster_wf. destruct Hij. 2: unfold Is_true in H; rewrite (emptyRasterEmpty n m j i) in H; contradiction. unfold RasterizeQ2 in H. rewrite map_map in H. apply In_nth with (d:=(fun x : Q * Q => (Z.to_nat (fst (rasterize2 n m t l b r x)), Z.to_nat (snd (rasterize2 n m t l b r x))))(0,0)) in H. destruct H as [k [kin H]]. rewrite map_length in kin. rewrite (map_nth (fun x : Q * Q => (Z.to_nat (fst (rasterize2 n m t l b r x)), Z.to_nat (snd (rasterize2 n m t l b r x))))) in H. exists (nth k points (0,0)). split. apply nth_In. exact kin. unfold snd in Hx'. unfold fst in Hy'. assert (Z.to_nat (fst (rasterize2 n m t l b r (nth k points (0, 0)))) = j /\ Z.to_nat (snd (rasterize2 n m t l b r (nth k points (0, 0)))) = i). { inversion H. split; reflexivity. } clear H. destruct H0. rewrite <- qeq. clear qeq x y. specialize (@Hf (fst (nth k points (0,0))) (snd (nth k points (0,0)))). rewrite <- surjective_pairing in Hf. specialize (@Hf (InFinEnumC_weaken _ _ points (nth_In _ _ kin))). split. - unfold rasterize2, snd in H0. clear H. simpl (fst (qx,qy)). rewrite Hx', <- H0. rewrite Z2Nat.id. apply ball_weak_le with (e:=((1 # 2 * n) * proj1_sig w)). apply (Qpos_max_ub_l errX errY). apply ball_sym. apply rasterize1_error. apply Hf. apply rasterize2_bound. - unfold rasterize2, fst in H. clear H0 Hx'. simpl (snd (qx,qy)). rewrite Hy', <- H. apply ball_weak_le with (e:=((1 # 2 * m) * proj1_sig h)). apply (Qpos_max_ub_r errX errY). pose proof (@rasterize1_error b h m _ (proj2 Hf)). rewrite <- switch_line_interp in H0. apply ball_sym. rewrite Z2Nat.id. apply H0. apply Z.le_0_sub, Z.le_min_l. apply (Z.le_lt_trans _ _ _ (Z.le_min_l _ _)). rewrite <- (Z.add_0_r (Z.pos m)) at 2. apply Z.add_lt_mono_l. reflexivity. Qed. Lemma RasterizeQ2_correct : ball (proj1_sig err) (CentersOfPixels (PixelizeQ2 (RasterizeQ2 points n m t l b r)) (l,t) (r,b)) points. Proof. split. apply Qpos_nonneg. split; intros [x y] Hx. - pose proof (RasterizeQ2_correct2 Hx). intro abs. contradict H; intros [z [Hz0 Hz1]]. specialize (abs z). contradict abs. split. apply InFinEnumC_weaken, Hz0. apply ball_sym, Hz1. - intro abs. pose proof (RasterizeQ2_correct1 Hx). contradict H; intros [z [Hz0 Hz1]]. specialize (abs z). contradict abs. split. apply InFinEnumC_weaken, Hz0. apply ball_sym, Hz1. Qed. End RasterizeCorrect. corn-8.20.0/reals/fast/uneven_CRplus.v000066400000000000000000000057121473720167500176050ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import QArith. Require Import CoRN.model.totalorder.QposMinMax CoRN.model.metric2.Qmetric CoRN.reals.fast.CRArith. (** The approximation function for CRplus results distributes a given error evenly among its two operands. This is a perfectly reasonable implementation choice, but it is conceptually arbitrary: any ratio works fine. Furthermore, when reasoning about particular uses of CRplus, different ratios can be more natural fits to the proof at hand. For instance, in the additivity proof for the Riemann integral implementation, having the error for the sum of two integrals distributed proportionally to the widths of the two contiguous ranges makes it nicely match the error for the full integral on both sides. For situations like these, we now do a very ad-hoc redefinition of addition with a user-specified error distribution ratio, and show that it is equivalent to the normal CRplus. *) Section uneven_CRplus. Variables (l r: Qpos) (* These are the error weights for x and y. *) (x y: CR). Let ll: Qpos := (l * Qpos_inv (l + r))%Qpos. Let rr: Qpos := (r * Qpos_inv (l + r))%Qpos. Let llrr: QposEq (ll + rr) (1#1). Proof. unfold ll, rr. simpl. unfold QposEq; simpl; field. intro. apply (Qpos_nonzero (l+r)%Qpos). assumption. Qed. Definition uneven_CRplus_approx (e: Qpos): Q_as_MetricSpace := approximate x (Qpos2QposInf (e * ll)) + approximate y (Qpos2QposInf (e * rr)). Lemma uneven_CRplus_is_RegularFunction: is_RegularFunction_noInf _ uneven_CRplus_approx. Proof with auto. intros e1 e2. unfold uneven_CRplus_approx. simpl. assert (QposEq (e1 + e2) ((e1 * ll + e2 * ll) + (e1 * rr + e2 * rr))). { unfold QposEq. transitivity (proj1_sig (e1 + e2)%Qpos * proj1_sig (ll + rr)%Qpos). unfold QposEq in llrr. rewrite llrr. simpl. ring. simpl. ring. } apply (ball_wd _ H _ _ (reflexivity _) _ _ (reflexivity _)). clear H. apply Qball_plus. apply (regFun_prf x (e1*ll)%Qpos (e2*ll)%Qpos). apply (regFun_prf y (e1*rr)%Qpos (e2*rr)%Qpos). Qed. Definition uneven_CRplus: CR := @mkRegularFunction Q_as_MetricSpace 0 _ uneven_CRplus_is_RegularFunction. Lemma uneven_CRplus_correct: (uneven_CRplus == x + y)%CR. Proof. simpl. apply regFunEq_equiv, regFunEq_e. intro e. unfold ball, Q_as_MetricSpace, Qball, QAbsSmall. rewrite approximate_CRplus... unfold uneven_CRplus_approx. setoid_replace (proj1_sig e + proj1_sig e) with (proj1_sig ((e * ll + (1#2) * e) + (e * rr + (1#2) * e)))%Qpos. apply Qball_plus; apply regFun_prf. simpl in llrr. transitivity (proj1_sig e + proj1_sig e * proj1_sig (ll + rr)%Qpos)... unfold QposEq in llrr. simpl in llrr. simpl. rewrite llrr. unfold canonical_names.equiv, stdlib_rationals.Q_eq. ring. unfold canonical_names.equiv, stdlib_rationals.Q_eq. simpl. ring. Qed. End uneven_CRplus. corn-8.20.0/reals/faster/000077500000000000000000000000001473720167500151505ustar00rootroot00000000000000corn-8.20.0/reals/faster/ACarith.v000066400000000000000000000132051473720167500166530ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Qabs. Require Import CoRN.model.metric2.Qmetric CoRN.metric2.ProductMetric CoRN.model.totalorder.QposMinMax CoRN.model.totalorder.QMinMax CoRN.reals.faster.ARabs CoRN.reals.faster.ARroot CoRN.reals.faster.ARArith. (** Basic definitions for the complex numbers. *) Section ACcomplex. Context `{AppRationals AQ}. (* The instance of Setoid AR*AR is already in scope, with u = v iff (fst u = fst v /\ snd u = snd v). *) Definition ACball (u v : AR*AR) (e : Q) : Prop := 0 <= e /\ ARle ((fst u - fst v)*(fst u - fst v) + (snd u - snd v)*(snd u - snd v)) (inject_Q_AR (e*e)). (* TODO the distance of ACball would be better. *) Definition AC : MetricSpace := ProductMS AR AR. Instance: Plus AC := fun xy uv => pair (fst xy + fst uv) (snd xy + snd uv). Instance: Mult AC := fun xy uv => pair (fst xy*fst uv - snd xy*snd uv) (fst xy*snd uv + snd xy*fst uv). (* The square root of -1, imaginary number i. *) Definition ACi : AC := pair 0 1. Definition ACmodulus : AC -> AR := fun z => ARsqrt (fst z*fst z + snd z*snd z). Lemma ACplus_comm : forall u v : AC, u + v = v + u. Proof. intros u v. split; apply ARplus_comm. Qed. Lemma ACplus_assoc : forall u v w : AC, (u + v) + w = u + (v + w). Proof. intros u v w. split; apply ARplus_assoc. Qed. Definition ACsqrt (z : AC) (yDec : {ARle 0 (snd z)} + {ARle (snd z) 0}) : AC := pair (ARsqrt ((ACmodulus z + fst z) * inject_Q_AR (1#2))) ((if yDec then 1 else -1) * (ARsqrt ((ACmodulus z - fst z) * inject_Q_AR (1#2)))). Add Ring AR : (rings.stdlib_ring_theory AR). Lemma ARdouble : forall x : AR, x + x = 2*x. Proof. intro x. ring. Qed. Lemma ARmult_neg_one : forall x : AR, -1 * x = -x. Proof. intros. ring. Qed. Lemma ACsqrt_correct : forall (z : AC) (yDec : {ARle 0 (snd z)} + {ARle (snd z) 0}), ACsqrt z yDec * ACsqrt z yDec = z. Proof. intros [x y] yDec. assert (2 * inject_Q_AR (1 # 2) = 1) as twoHalf. { unfold one. pose proof inject_Q_AR_1. unfold one in H5. rewrite <- H5. rewrite <- inject_Q_AR_plus, <- inject_Q_AR_mult. apply inject_Q_AR_wd. reflexivity. } assert (ARle 0 (ACmodulus (x, y) - x)) as modMinus. { unfold ACmodulus, fst, snd. rewrite <- (ARplus_opp_r x). apply ARplus_le_compat_r. apply (ARle_trans _ (ARsqrt (x*x))). rewrite (ARsqrt_srq_abs x). apply ARle_abs. apply ARsqrt_inc. apply ARsquare_pos. rewrite <- (ARplus_0_r (x*x)) at 1. apply ARplus_le_compat_l. apply ARsquare_pos. } assert (ARle 0 (ACmodulus (x, y) + x)) as modPlus. { unfold ACmodulus, fst, snd. rewrite <- (ARplus_opp_r x). rewrite ARplus_comm. apply ARplus_le_compat_r. apply (ARle_trans _ (ARsqrt (x*x))). rewrite (ARsqrt_srq_abs x). rewrite <- ARabs_opp. apply ARle_abs. apply ARsqrt_inc. apply ARsquare_pos. rewrite <- (ARplus_0_r (x*x)) at 1. apply ARplus_le_compat_l. apply ARsquare_pos. } assert (ARle 0 (inject_Q_AR (1 # 2))) as halfPos. { rewrite <- inject_Q_AR_0. apply inject_Q_AR_le. discriminate. } split. - unfold mult, Mult_instance_0, ACsqrt, fst, snd. rewrite (ARsqrt_correct ((ACmodulus (x, y) + x) * inject_Q_AR (1 # 2))). rewrite (ARmult_comm (if yDec then 1 else -1) (ARsqrt ((ACmodulus (x, y) - x) * inject_Q_AR (1 # 2)))). rewrite ARmult_assoc. rewrite <- (ARmult_comm (if yDec then 1 else -1)). rewrite <- (ARmult_assoc (if yDec then 1 else -1)). setoid_replace (ARmult (if yDec then 1 else -1) (if yDec then 1 else -1)) with AR1. rewrite ARmult_1_l. rewrite (ARsqrt_correct ((ACmodulus (x, y) - x) * inject_Q_AR (1 # 2))). + setoid_replace ((ACmodulus (x, y) + x) * inject_Q_AR (1 # 2) - (ACmodulus (x, y) - x) * inject_Q_AR (1 # 2)) with (x*(2*inject_Q_AR (1#2))) by ring. rewrite twoHalf. apply ARmult_1_r. + apply AR_mult_0_le_compat. exact modMinus. exact halfPos. + destruct yDec. exact (ARmult_1_l AR1). pose proof (ARmult_neg_one (-1)). simpl in H5. rewrite H5. clear H5. apply ARopp_involutive. + apply AR_mult_0_le_compat. exact modPlus. exact halfPos. - unfold mult, Mult_instance_0, ACsqrt, fst, snd. rewrite ARmult_comm, ARmult_assoc, ARdouble. rewrite ARsqrt_mult, ARsqrt_mult. assert (forall a b c : AR, a * c * (b * c) = c * c * (a * b)). { intros. ring. } rewrite H5. clear H5. pose proof (ARsqrt_correct (inject_Q_AR (1 # 2))). simpl in H5. rewrite H5. clear H5. rewrite <- (ARsqrt_mult (ACmodulus (x, y) - x)). setoid_replace ((ACmodulus (x, y) - x) * (ACmodulus (x, y) + x)) with (ACmodulus (x, y) * ACmodulus (x, y) - x*x) by ring. unfold ACmodulus, fst, snd. rewrite (ARsqrt_correct (x*x+y*y)). setoid_replace (x * x + y * y - x * x) with (y*y) by ring. rewrite ARsqrt_srq_abs. setoid_replace (2 * ((if yDec then 1 else -1) * (inject_Q_AR (1 # 2) * ARabs y))) with (2 * inject_Q_AR (1 # 2) * ((if yDec then 1 else -1) * ARabs y)) by ring. rewrite twoHalf, ARmult_1_l. simpl in yDec. destruct yDec. rewrite ARmult_1_l. rewrite ARabs_pos. reflexivity. exact a. rewrite ARabs_neg. rewrite ARmult_neg_one. apply ARopp_involutive. exact a. apply (ARle_trans _ (x*x + 0)). rewrite ARplus_0_r. apply ARsquare_pos. apply ARplus_le_compat_l, ARsquare_pos. exact modMinus. exact modPlus. exact halfPos. exact modPlus. exact halfPos. exact modMinus. exact halfPos. Qed. End ACcomplex. corn-8.20.0/reals/faster/AQmetric.v000066400000000000000000000137131473720167500170510ustar00rootroot00000000000000Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Program Ring. Require Import CoRN.util.Qdlog CoRN.model.totalorder.QposMinMax CoRN.metric2.Complete CoRN.metric2.Prelength CoRN.model.metric2.Qmetric CoRN.model.metric2.CRmetric CoRN.metric2.MetricMorphisms. Require Export CoRN.reals.faster.ApproximateRationals. Section AQmetric. Context `{AppRationals AQ}. Add Ring AQ : (rings.stdlib_ring_theory AQ). Local Open Scope uc_scope. (* To ensure the definitions below don't use sg_setoid instead *) Existing Instance strong_setoids.Setoid_instance_0. Definition AQ_as_MetricSpace := Emetric (cast AQ Q_as_MetricSpace). Definition AQPrelengthSpace := EPrelengthSpace QPrelengthSpace (cast AQ Q_as_MetricSpace). Definition AQLocated : locatedMetric AQ_as_MetricSpace. Proof. intros e1 e2 x y lte. apply (@locatedQ e1 e2 (AQtoQ x) (AQtoQ y) lte). Defined. Definition AR := Complete AQ_as_MetricSpace. Definition AQtoQ_uc : AQ_as_MetricSpace --> Q_as_MetricSpace := metric_embed_uc (cast AQ Q_as_MetricSpace). Definition ARtoCR_uc : AR --> CR := Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace). Global Instance ARtoCR: Cast AR CR := ARtoCR_uc. Definition CRtoAR_uc : CR --> AR := Eembed_inverse QPrelengthSpace (cast AQ Q_as_MetricSpace). Global Instance CRtoAR: Cast CR AR := CRtoAR_uc. Global Instance inject_AQ_AR: Cast AQ AR := (@Cunit AQ_as_MetricSpace). Global Instance: Proper ((=) ==> (@msp_eq _)) inject_AQ_AR. Proof. intros x y xyeq. apply (uc_wd (@Cunit AQ_as_MetricSpace)). simpl. rewrite xyeq. reflexivity. Qed. Lemma ARtoCR_approx : forall (d : QposInf) (x : AR), approximate (ARtoCR x) d ≡ AQtoQ (approximate x d). Proof. intros. destruct d; reflexivity. Qed. Lemma inject_Q_AR_prf : forall (q:Q), is_RegularFunction (@ball AQ_as_MetricSpace) (fun e:QposInf => match e with | Qpos2QposInf d => app_inverse (cast AQ Q) q d | QposInfinity => 0 end). Proof. intros q e1 e2. simpl. destruct aq_dense_embedding. simpl in dense_inverse. unfold cast. apply (ball_triangle _ _ _ _ q). apply dense_inverse. apply ball_sym, dense_inverse. Qed. Definition inject_Q_AR (q : Q) : AR := Build_RegularFunction (inject_Q_AR_prf q). (* inject_Q_AR is twice faster than the cast *) Lemma inject_Q_AR_CR : forall (q : Q), inject_Q_AR q = cast CR AR (inject_Q_CR q). Proof. intro q. rewrite <- doubleSpeed_Eq. intros e1 e2. rewrite Qplus_0_r. pose proof (regFun_prf (cast CR AR (inject_Q_CR q)) e1 e2) as H5. apply H5. Qed. Lemma inject_Q_AR_uc : is_UniformlyContinuousFunction inject_Q_AR Qpos2QposInf. Proof. intros d e1 e2 bd x y. simpl. unfold cast. unfold MetricMorphisms.app_inverse. destruct aq_dense_embedding. unfold MetricMorphisms.app_inverse in dense_inverse. rewrite <- (Qplus_assoc (`x) (`d) (`y)). apply ball_triangle with (b:=e1). apply dense_inverse. apply ball_triangle with (b:=e2). apply bd. apply ball_sym, dense_inverse. Qed. Lemma CRAR_id : forall x : CR, msp_eq (cast AR CR (cast CR AR x)) x. Proof. intro x. apply (surjective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace)) x x). reflexivity. Qed. Lemma AQball_fold ε (x y : AQ_as_MetricSpace) : ball ε x y → Qball ε ('x) ('y). Proof. easy. Qed. Lemma AQball_abs (ε : Q) (x y : AQ_as_MetricSpace) : ball ε x y ↔ 'abs (x - y) ≤ ε. Proof. simpl. rewrite Qball_Qabs. now rewrite abs.preserves_abs, rings.preserves_minus. Qed. Definition AQball_bool (k : Z) (x y : AQ) : bool := bool_decide_rel (≤) (abs (x - y)) (1 ≪ k). Lemma AQball_bool_true (k : Z) (x y : AQ_as_MetricSpace) : AQball_bool k x y ≡ true ↔ ball (2 ^ k) x y. Proof. rewrite AQball_abs. unfold AQball_bool. rewrite bool_decide_rel_true. transitivity ('abs (x - y) ≤ ('(1 ≪ k) : Q)). split; intros. now apply (order_preserving _). now apply (order_reflecting (cast AQ Q)). now rewrite aq_shift_correct, rings.preserves_1, left_identity. Qed. Global Instance: Proper ((=) ==> (=) ==> (=) ==> (≡)) AQball_bool | 1. Proof. intros ε1 ε2 E1 x1 x2 E2 y1 y2 E3. case_eq (AQball_bool ε2 x2 y2). intro. apply AQball_bool_true. rewrite E1, E2, E3. now apply AQball_bool_true. rewrite <-2!not_true_iff_false. intros E4 ?. apply E4. apply AQball_bool_true. rewrite <-E1, <-E2, <-E3. now apply AQball_bool_true. Qed. Lemma AQball_bool_true_eps (ε : Qpos) (x y : AQ_as_MetricSpace) : AQball_bool (Qdlog2 (proj1_sig ε)) x y ≡ true → ball (proj1_sig ε) x y. Proof. intros E. apply AQball_abs. transitivity (2 ^ (Qdlog2 (proj1_sig ε)) : Q). apply AQball_bool_true in E. now apply AQball_abs in E. now apply (Qpos_dlog2_spec ε). Qed. Lemma AQball_plus (ε1 ε2 : Qpos) (x1 x2 y1 y2 : AQ_as_MetricSpace) : ball (proj1_sig ε1) x1 y1 → ball (proj1_sig ε2) x2 y2 → ball (proj1_sig ε1 + proj1_sig ε2) (x1 + x2) (y1 + y2). Proof. intros. apply ball_triangle with (x2 + y1); apply AQball_abs. setoid_replace (x1 + x2 - (x2 + y1)) with (x1 - y1) by (simpl; ring). now apply AQball_abs. setoid_replace (x2 + y1 - (y1 + y2)) with (x2 - y2) by (simpl; ring). now apply AQball_abs. Qed. Lemma AQball_plus_l (ε : Qpos) (x y z : AQ_as_MetricSpace) : ball (proj1_sig ε) x y → ball (proj1_sig ε) (z + x) (z + y). Proof. intros E. apply AQball_abs. setoid_replace (z + x - (z + y)) with (x - y) by (simpl; ring). now apply AQball_abs. Qed. Lemma AQball_plus_r (ε : Qpos) (x y z : AQ_as_MetricSpace) : ball (proj1_sig ε) x y → ball (proj1_sig ε) (x + z) (y + z). Proof. intros E. apply AQball_abs. setoid_replace (x + z - (y + z)) with (x - y) by (simpl; ring). now apply AQball_abs. Qed. Lemma AQball_opp (ε : Qpos) (x y : AQ_as_MetricSpace) : ball (proj1_sig ε) x y → ball (proj1_sig ε) (-x) (-y). Proof. intros. apply AQball_abs. setoid_replace (-x - -y) with (y - x) by (simpl; ring). apply AQball_abs. now apply ball_sym. Qed. End AQmetric. corn-8.20.0/reals/faster/ARAlternatingSum.v000066400000000000000000000446671473720167500205400ustar00rootroot00000000000000From Coq Require Import Qabs. Require Import CoRN.util.Qdlog CoRN.algebra.RSetoid CoRN.model.totalorder.QposMinMax CoRN.model.metric2.Qmetric CoRN.model.reals.CRreal CoRN.metric2.Metric CoRN.metric2.UniformContinuity CoRN.reals.fast.CRAlternatingSum CoRN.reals.fast.CRstreams CoRN.reals.faster.ApproximateRationals CoRN.reals.faster.ARArith. (** The goal of this section is to compute the infinite alternating sum. Since we do not have a precise division operation, we want to postpone divisions as long as possible. Hence we parametrize our infinite sum by a stream [sN] of numerators and a stream [sD] of denominators. To compute an infinite series at precision epsilon, the finite number n of terms to sum can be computed exactly, because sN n / sD n < epsilon/2 is equivalent to sN n < (sD n) * epsilon/2, which does not involve the approximate division. In the other epsilon/2, we can approximate the n divisions at precision 2^k such as n*2^k < epsilon/2. *) Section RationalStreamSum. Context `{AppRationals AQ}. (* For exponential, f p n d := (n*a, d*p). We might need to generalize positive to a more complicated state type later. *) Variable f : positive*(AQ*AQ) -> AQ*AQ. Definition fS x : positive*(AQ*AQ) := (Pos.succ (fst x), f x). Definition fSsum (k:Z) (x : positive*(AQ*AQ)*AQ) : positive*(AQ*AQ)*AQ := let (y,s) := x in let (a,b) := fS y in (a, b, s + app_div (fst b) (snd b) k). Hypothesis denomPos : forall x, 0 < snd (snd x) -> 0 < snd (f x). Lemma denomPos_iter : forall p x, 0 < snd (snd x) -> 0 < snd (snd (CRstreams.iterate _ fS p x)). Proof. apply (Pos.peano_ind (fun p => forall x, 0 < snd (snd x) -> 0 < snd (snd (CRstreams.iterate _ fS p x)))). - intros. simpl. apply denomPos, H5. - intros. rewrite iterate_succ, iterate_shift. apply H5. simpl. apply denomPos, H6. Qed. (* Find first index where num/denom <= e. *) Definition IsStopIndex x (e : AQ) (candidate : positive) : Prop := let (_,v) := CRstreams.iterate _ fS candidate (xH,x) in le (abs (fst v)) (snd v * e). Definition StopIndex x (e : AQ) (candidate : positive) : positive := Pos.pred (fst (iterate_stop _ fS (fun y : positive*(AQ*AQ) => bool_decide_rel le (abs (fst (snd y))) ((snd (snd y))*e)) candidate (xH, x))). Lemma fS_fst : forall (p:positive) x, fst (CRstreams.iterate (positive and AQ and AQ) fS p (1%positive, x)) ≡ Pos.succ p. Proof. apply (Pos.peano_ind (fun p => forall (x : AQ and AQ), fst (CRstreams.iterate (positive and AQ and AQ) fS p (1%positive, x)) ≡ Pos.succ p)). - reflexivity. - intros. rewrite iterate_succ. simpl. apply f_equal, H5. Qed. Lemma StopIndex_correct : forall x (e:AQ) (p r : positive), IsStopIndex x e p -> (forall q:positive, Pos.lt q p -> ~IsStopIndex x e q) -> Pos.le p r -> StopIndex x e r ≡ p. Proof. unfold IsStopIndex. intros. unfold StopIndex. destruct (iterate_stop_correct _ fS (fun y : positive and AQ and AQ => bool_decide_rel le (abs (fst (snd y))) (snd (snd y) * e0)) r (xH,x)) as [s [req [H8 H9]]]. rewrite req, fS_fst, Pos.pred_succ. clear req. destruct H9. - subst r. apply Pos.le_lteq in H7. destruct H7. 2: symmetry; exact H7. exfalso. specialize (H8 p H7). apply bool_decide_rel_false in H8. contradict H8. destruct (CRstreams.iterate _ fS p (1%positive, x)). exact H5. - destruct H9. apply bool_decide_rel_true in H10. clear H7 H9 r. destruct (Pos.lt_total s p). + exfalso. specialize (H6 s H7). contradict H6. destruct (CRstreams.iterate _ fS s (1%positive, x)). exact H10. + destruct H7. exact H7. exfalso. specialize (H8 p H7). apply bool_decide_rel_false in H8. contradict H8. destruct (CRstreams.iterate _ fS p (1%positive, x)). exact H5. Qed. Lemma StopIndex_stop_fuel : forall x (e:AQ) (candidate : positive), (forall p:positive, Pos.lt p candidate -> ~IsStopIndex x e p) -> StopIndex x e candidate ≡ candidate. Proof. intros. unfold StopIndex. destruct (iterate_stop_correct _ fS (fun y : positive and AQ and AQ => bool_decide_rel le (abs (fst (snd y))) (snd (snd y) * e0)) candidate (xH,x)) as [r [req [H6 H7]]]. rewrite req, fS_fst, Pos.pred_succ. clear req. destruct H7. symmetry. exact H7. destruct H7. exfalso. clear H6. specialize (H5 r H7). apply bool_decide_rel_true in H8. contradict H5. unfold IsStopIndex. destruct (CRstreams.iterate _ fS r (1%positive, x)). exact H8. Qed. (* Approximate the infinite series at precision e. The precision i:Z in fSum satisfies n*2^i <= e/2. *) Definition app_inverse_below (q : Qpos) : AQ := AppInverse0 ((3#4)*proj1_sig q) ((1#4)*q)%Qpos. Lemma app_inverse_below_pos : forall q:Qpos, 0 < app_inverse_below q. Proof. intros. unfold app_inverse_below. destruct aq_dense_embedding. specialize (dense_inverse ((3 # 4) * ` q)%Q ((1#4)*q)%Qpos). apply AbsSmall_Qabs, Qabs_Qle_condition in dense_inverse. destruct dense_inverse as [H5 _]. simpl in H5. apply (Qplus_le_r _ _ ((3 # 4) * ` q)) in H5. ring_simplify in H5. destruct aq_strict_order_embed. apply strict_order_embedding_reflecting. refine (Qlt_le_trans _ ((8 # 16) * ` q) _ _ H5). rewrite rings.preserves_0. apply (Qpos_ispos ((8#16)*q)). Qed. Lemma app_inverse_below_correct : forall q:Qpos, AQtoQ (app_inverse_below q) <= proj1_sig q. Proof. intros. unfold app_inverse_below. destruct aq_dense_embedding. specialize (dense_inverse ((3 # 4) * ` q)%Q ((1#4)*q)%Qpos). apply AbsSmall_Qabs, Qabs_Qle_condition in dense_inverse. destruct dense_inverse as [_ H5]. simpl in H5. apply (Qplus_le_r _ _ ((3 # 4) * ` q)) in H5. ring_simplify in H5. exact H5. Qed. (* cvmod : AQ->positive would not improve this definition, because an AQtoQ would be almost inevitable to produce a boxed positive. Besides, Q will allow an easier interaction with fast reals streams. *) Definition AltSeries_raw (x : AQ*AQ) (cvmod : Qpos -> positive) (e:QposInf) : AQ := match e with | Qpos2QposInf d => let ae := app_inverse_below (d*(1#2)) in let n := StopIndex x ae (cvmod (d * (1#2))%Qpos) in snd (CRstreams.iterate _ (fSsum (Qdlog2 (proj1_sig d * (1#2*n)))) n (xH,x,0)) | QposInfinity => 0 end. (* To prove the correctness of the limit, convert the stream f into a stream g of exact rationals. g could be defined as the zip of f with the exact divisions, but it's more flexible to take g from outside, so that in addition we prove the equality of series. *) Variable X : Type. Variable g : X*Q -> X*Q. Variable fInit : AQ*AQ. Variable gInit : X*Q. Hypothesis g_pth : forall p:positive, Str_pth _ g p gInit == let (y,r) := CRstreams.iterate _ fS p (xH, fInit) in AQtoQ (fst r) / AQtoQ (snd r). Lemma abs_div_aqtoq_shift : forall (q r s : AQ), 0 < r -> (Qabs (AQtoQ q / AQtoQ r) <= AQtoQ s <-> le (abs q) (r * s)). Proof. assert (forall q:AQ, Qabs (AQtoQ q) == AQtoQ (abs q)) as preserves_abs. { intros. rewrite abs.preserves_abs. reflexivity. } assert (forall q r:AQ, AQtoQ (q*r) == AQtoQ q*AQtoQ r) as preserves_mult. { intros. rewrite rings.preserves_mult. reflexivity. } intros. assert (0 < AQtoQ r). { rewrite <- rings.preserves_0. destruct aq_strict_order_embed. apply strict_order_embedding_preserving. exact H5. } split. - intros. unfold Qdiv in H7. rewrite Qabs_Qmult, Q.Qabs_Qinv in H7. rewrite (Qabs_pos (AQtoQ r)) in H7. rewrite preserves_abs, Qmult_comm in H7. apply (Qmult_le_l _ _ (AQtoQ r)) in H7. 2: exact H6. rewrite Qmult_assoc, Qmult_inv_r, Qmult_1_l in H7. rewrite <- preserves_mult in H7. destruct aq_order_embed, order_embedding_reflecting. apply order_reflecting in H7. exact H7. intro abs. rewrite abs in H6. exact (Qlt_irrefl 0 H6). apply Qlt_le_weak, H6. - intros. unfold Qdiv. rewrite Qabs_Qmult, Q.Qabs_Qinv. rewrite (Qabs_pos (AQtoQ r)). rewrite preserves_abs. rewrite Qmult_comm. apply (Qmult_le_l _ _ (AQtoQ r)). exact H6. rewrite Qmult_assoc, Qmult_inv_r, Qmult_1_l. rewrite <- preserves_mult. destruct aq_order_embed. apply order_embedding_preserving. exact H7. intro abs. rewrite abs in H6. exact (Qlt_irrefl 0 H6). apply Qlt_le_weak, H6. Qed. Lemma fSsum_fst : forall p k, fst (CRstreams.iterate _ (fSsum k) p (1%positive, fInit, 0)) ≡ CRstreams.iterate _ fS p (xH,fInit). Proof. apply (Pos.peano_ind (fun p => forall k, fst (CRstreams.iterate _ (fSsum k) p (1%positive, fInit, 0)) ≡ CRstreams.iterate _ fS p (xH,fInit))). - reflexivity. - intros. rewrite iterate_succ, iterate_succ. rewrite <- (H5 k). unfold fSsum at 1. destruct (CRstreams.iterate ((positive and AQ and AQ) and AQ) (fSsum k) p (1%positive, fInit, 0)). reflexivity. Qed. (* Sum p terms, the error between each is below e. *) Lemma div_approx_error : ∀ (p:positive) (e:Qpos), Qball (` e * inject_Z (Zpos p)) (AQtoQ (snd (CRstreams.iterate _ (fSsum (Qdlog2 (` e))) p (1%positive, fInit, 0)))) (snd (CRstreams.iterate _ (fun y : X*Q*Q => let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) p (gInit, 0))). Proof. apply (Pos.peano_ind (fun p => forall (e:Qpos), Qball (` e * inject_Z (Zpos p)) (AQtoQ (snd (CRstreams.iterate _ (fSsum (Qdlog2 (` e))) p (1%positive, fInit, 0)))) (snd (CRstreams.iterate _ (fun y : X*Q*Q => let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) p (gInit, 0))))). - intros. rewrite iterate_one, iterate_one. rewrite Qmult_1_r. unfold fSsum, fS. unfold snd at 1. unfold fst at 2. pose proof (g_pth 1). unfold Str_pth in H5. simpl in H5. unfold snd at 3. replace (snd (let (z, r) := g gInit in (z, r, Qred (r + zero)))) with (Qred (snd (g gInit) + 0)) by (destruct (g gInit); reflexivity). rewrite Qred_correct, Qplus_0_r, H5. clear H5. destruct (f (1%positive, fInit)) as [u v]. unfold snd, fst. rewrite rings.plus_0_l. apply ball_weak_le with (e:= (2 ^ Qdlog2 (` e0))%Q). apply Qdlog2_spec, Qpos_ispos. apply aq_div. - intros. rewrite iterate_succ. unfold fSsum at 1. specialize (H5 e0). pose proof (fSsum_fst p (Qdlog2 (` e0))). destruct (CRstreams.iterate _ (fSsum (Qdlog2 (` e0))) p (1%positive, fInit, 0)) as [u approx_sum]. unfold snd in H5 at 1. unfold fst in H6. change (snd (let (a, b) := fS u in (a, b, approx_sum + app_div (fst b) (snd b) (Qdlog2 (` e0))))) with (approx_sum + app_div (fst (snd (fS u))) (snd (snd (fS u))) (Qdlog2 (` e0))). rewrite iterate_succ, SumStream_fst_red. unfold fst at 2. rewrite <- iterate_succ. pose proof (g_pth (Pos.succ p)) as H7. unfold Str_pth in H7. destruct (CRstreams.iterate (X and Q) g (Pos.succ p) gInit). unfold snd at 4. unfold snd in H7 at 1. rewrite Qred_correct, H7. clear H7 q x. rewrite iterate_succ. rewrite <- H6. clear H6. destruct (fS u) as [v w]. change (snd (v,w)) with w. clear v. destruct (CRstreams.iterate _ (fun y : (X and Q) and Q => let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) p (gInit, 0)) as [v exact_sum]. unfold snd in H5. unfold snd at 3. clear v. destruct w as [v w]. unfold fst, snd. rewrite rings.preserves_plus. apply AbsSmall_Qabs. apply AbsSmall_Qabs in H5. setoid_replace ((AQtoQ approx_sum + AQtoQ (app_div v w (Qdlog2 (` e0)))) - (AQtoQ v / AQtoQ w + exact_sum))%Q with (AQtoQ approx_sum - exact_sum + (AQtoQ (app_div v w (Qdlog2 (` e0))) - (AQtoQ v / AQtoQ w)))%Q by ring. apply (Qle_trans _ _ _ (Qabs_triangle _ _)). rewrite <- Pos.add_1_r, Pos2Z.inj_add, inject_Z_plus. rewrite Qmult_plus_distr_r, Qmult_1_r. apply Qplus_le_compat. exact H5. apply AbsSmall_Qabs. change (Qball (` e0) (AQtoQ (app_div v w (Qdlog2 (` e0)))) (AQtoQ v / AQtoQ w)). apply ball_weak_le with (e:= (2 ^ Qdlog2 (` e0))%Q). apply Qdlog2_spec, Qpos_ispos. apply aq_div. Qed. (* SumStream is the implementation of CRAlternatingSum.AltSeries_raw. Errors only come from approximate divisions here. *) Lemma AltSeries_raw_correct : forall (e:Qpos) (cvmod : Qpos -> positive), 0 < snd fInit -> Qball (` e * (1 # 2)) (AQtoQ (AltSeries_raw fInit cvmod (Qpos2QposInf e))) (SumStream _ g gInit (cvmod (e * (1 # 2))%Qpos) (* fuel *) (AQposAsQpos (exist _ _ (app_inverse_below_pos (e * (1 # 2))%Qpos)))). Proof. intros e0 cvmod xpos. unfold SumStream. change (` (AQposAsQpos (app_inverse_below (e0 * (1 # 2))%Qpos ↾ app_inverse_below_pos (e0 * (1 # 2))%Qpos))) with (AQtoQ (app_inverse_below (e0 * (1 # 2))%Qpos)). pose proof (iterate_stop_correct _ (fun y : (X and Q) and Q => let (z, r) := g (fst y) in (z, r, Qred (r + snd y))) (fun y : (X and Q) and Q => Qle_bool (Qabs (snd (fst y))) (AQtoQ (app_inverse_below (e0 * (1 # 2) ↾ eq_refl)))) (cvmod (e0 * (1 # 2))%Qpos) (gInit,0)) as [p [qeq [H5 H6]]]. rewrite qeq. clear qeq. unfold AltSeries_raw. replace (StopIndex fInit (app_inverse_below (e0 * (1 # 2) ↾ eq_refl)) (cvmod (e0 * (1 # 2))%Qpos)) with p. setoid_replace (` e0 * (1 # 2))%Q with (` e0 * (1 # 2 * p) * inject_Z (Zpos p))%Q. apply (div_approx_error p (e0*(1#2*p))). rewrite <- Qmult_assoc. apply Qmult_comp. reflexivity. unfold Qmult, Qeq; simpl. rewrite Pos.mul_1_r, Pos.mul_comm. reflexivity. rewrite SumStream_fst_red in H6. destruct H6 as [fuel | predicate]. - (* The sum consumes all the fuel. *) subst p. symmetry. apply StopIndex_stop_fuel. intros. specialize (H5 p H6). rewrite SumStream_fst_red in H5. unfold fst in H5. unfold IsStopIndex. intro abs. pose proof (g_pth p). unfold Str_pth in H7. rewrite H7 in H5. clear H7. pose proof (denomPos_iter p (xH,fInit) xpos). destruct (CRstreams.iterate _ fS p (1%positive, fInit)) as [u v]. apply abs_div_aqtoq_shift in abs. apply Qle_bool_iff in abs. rewrite abs in H5. discriminate. exact H7. - (* The sum stops before the fuel, because of the predicate. *) assert (IsStopIndex fInit (app_inverse_below (e0 * (1 # 2))%Qpos) p) as pstop. { destruct predicate as [_ predicate]. unfold IsStopIndex. apply Qle_bool_iff in predicate. simpl in predicate. pose proof (g_pth p). unfold Str_pth in H6. rewrite H6 in predicate. clear H6. pose proof (denomPos_iter p (xH,fInit) xpos). destruct (CRstreams.iterate _ fS p (1%positive, fInit)). apply abs_div_aqtoq_shift. exact H6. exact predicate. } symmetry. apply StopIndex_correct. exact pstop. intros. unfold IsStopIndex. specialize (H5 q H6). rewrite SumStream_fst_red in H5. unfold fst in H5. pose proof (g_pth q). unfold Str_pth in H7. rewrite H7 in H5. clear H7. pose proof (denomPos_iter q (xH,fInit) xpos). destruct (CRstreams.iterate _ fS q (1%positive, fInit)). intro abs. apply abs_div_aqtoq_shift in abs. apply Qle_bool_iff in abs. rewrite abs in H5. discriminate. exact H7. apply Pos.lt_le_incl, predicate. Qed. Lemma AltSeries_raw_prf : forall (cvmod : Qpos -> positive), Str_alt_decr _ g gInit -> 0 < snd fInit -> Limit_zero _ g gInit cvmod -> is_RegularFunction (@ball AQ_as_MetricSpace) (AltSeries_raw fInit cvmod). Proof. intros cvmod g_decr xpos lz e1 e2. setoid_replace (`e1 + `e2)%Q with (`e1*(1#2) + (`e1*(1#2) + `e2*(1#2) + `e2*(1#2)))%Q by ring. apply (ball_triangle Q_as_MetricSpace _ _ _ (SumStream _ g gInit (cvmod (e1 * (1 # 2))%Qpos) (AQposAsQpos (exist _ _ (app_inverse_below_pos (e1 * (1 # 2))%Qpos))))). 2: apply (ball_triangle Q_as_MetricSpace _ _ _ (SumStream _ g gInit (cvmod (e2 * (1 # 2))%Qpos) (AQposAsQpos (exist _ _ (app_inverse_below_pos (e2 * (1 # 2))%Qpos))))). - exact (AltSeries_raw_correct _ _ xpos). - apply (AltSeries_further _ g gInit _ _ _ _ (e1 * (1 # 2))%Qpos (e2 * (1 # 2))%Qpos g_decr). apply lz. apply lz. apply app_inverse_below_correct. apply app_inverse_below_correct. - apply ball_sym, (AltSeries_raw_correct _ _ xpos). Qed. Definition AltSeries (cvmod : Qpos -> positive) (decr : Str_alt_decr _ g gInit) (xpos : 0 < snd fInit) (lz : Limit_zero _ g gInit cvmod) : msp_car AR := Build_RegularFunction (AltSeries_raw_prf cvmod decr xpos lz). Lemma AltSeries_correct : forall (cvmod : Qpos -> positive) (decr : Str_alt_decr _ g gInit) (xpos : 0 < snd fInit) (lz : Limit_zero _ g gInit cvmod), (ARtoCR (AltSeries cvmod decr xpos lz) == CRAlternatingSum.AltSeries _ g gInit cvmod decr lz)%CR. Proof. intros. apply regFunEq_equiv, regFunEq_e. intro d. setoid_replace (` d + ` d)%Q with (`d*(1#2) + (`d*(1#2)+` d))%Q by ring. apply (ball_triangle _ _ _ _ _ _ (AltSeries_raw_correct d cvmod xpos)). apply (AltSeries_further _ g gInit (cvmod (d * (1 # 2))%Qpos) (cvmod d) _ _ (d*(1#2))%Qpos d decr). apply lz. apply lz. apply app_inverse_below_correct. apply Qle_refl. Qed. End RationalStreamSum. corn-8.20.0/reals/faster/ARArith.v000066400000000000000000001124661473720167500166430ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Program Ring Qabs. Require Import CoRN.stdlib_omissions.Q MathClasses.misc.workaround_tactics CoRN.model.totalorder.QMinMax CoRN.model.totalorder.QposMinMax CoRN.util.Qdlog CoRN.metric2.Complete CoRN.metric2.Prelength CoRN.model.metric2.Qmetric CoRN.metric2.MetricMorphisms CoRN.reals.fast.CRArith CoRN.reals.fast.CRpower MathClasses.implementations.stdlib_binary_naturals MathClasses.orders.minmax MathClasses.implementations.positive_semiring_elements. Require Export CoRN.reals.faster.ApproximateRationals CoRN.reals.faster.AQmetric. Section ARarith. Context `{AppRationals AQ}. Add Ring AQ : (rings.stdlib_ring_theory AQ). Add Ring Z : (rings.stdlib_ring_theory Z). Local Open Scope uc_scope. Local Opaque regFunEq. Hint Rewrite (rings.preserves_0 (f:=cast AQ Q)) : aq_preservation. Hint Rewrite (rings.preserves_1 (f:=cast AQ Q)) : aq_preservation. Hint Rewrite (rings.preserves_plus (f:=cast AQ Q)) : aq_preservation. Hint Rewrite (rings.preserves_mult (f:=cast AQ Q)) : aq_preservation. Hint Rewrite (rings.preserves_negate (f:=cast AQ Q)) : aq_preservation. Hint Rewrite aq_preserves_max : aq_preservation. Hint Rewrite aq_preserves_min : aq_preservation. Hint Rewrite (abs.preserves_abs (f:=cast AQ Q)): aq_preservation. Ltac aq_preservation := autorewrite with aq_preservation; try reflexivity. Local Obligation Tactic := program_simpl; aq_preservation. (* Compress *) Lemma aq_approx_regular_prf (x : AQ) : is_RegularFunction_noInf _ (λ ε : Qpos, app_approx x (Qdlog2 (proj1_sig ε)) : AQ_as_MetricSpace). Proof. intros ε1 ε2. simpl. eapply ball_triangle. apply aq_approx_dlog2. apply ball_sym, aq_approx_dlog2. Qed. Definition AQcompress (x : AQ_as_MetricSpace) : AR := mkRegularFunction (0 : AQ_as_MetricSpace) (aq_approx_regular_prf x). Lemma AQcompress_uc_prf : is_UniformlyContinuousFunction AQcompress Qpos2QposInf. Proof. intros ε x y E δ1 δ2. simpl in *. eapply ball_triangle. 2: apply ball_sym, aq_approx_dlog2. eapply ball_triangle; eauto. apply aq_approx_dlog2. Qed. Definition AQcompress_uc := Build_UniformlyContinuousFunction AQcompress_uc_prf. Definition ARcompress : AR --> AR := Cbind AQPrelengthSpace AQcompress_uc. Lemma ARcompress_correct (x : AR) : ARcompress x = x. Proof. apply regFunEq_equiv, regFunEq_e. intros ε. assert (QposEq (ε + ε) ((1#2) * ε + ((1#2) * ε + ε))) by (unfold QposEq; simpl; ring). apply (ball_wd _ H5 _ _ (reflexivity _) _ _ (reflexivity _)). clear H5. eapply ball_triangle. apply_simplified (aq_approx_dlog2 (approximate x ((1 # 2) * ε)%Qpos) ((1#2) * ε)%Qpos). apply regFun_prf. Qed. (* Constants *) Global Instance inject_PosAQ_AR: Cast (AQ₊) AR := (cast AQ AR ∘ cast (AQ₊) AQ)%prg. Global Instance inject_Z_AR: Cast Z AR := (cast AQ AR ∘ cast Z AQ)%prg. Lemma ARtoCR_inject (x : AQ) : cast AR CR (cast AQ AR x) = cast Q CR (cast AQ Q x). Proof. apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl. apply (Qpos_nonneg (ε + ε)). Qed. Global Instance AR0: Zero AR := cast AQ AR 0. Lemma ARtoCR_preserves_0 : cast AR CR 0 = 0. Proof. unfold "0", AR0. rewrite ARtoCR_inject. aq_preservation. Qed. Hint Rewrite ARtoCR_preserves_0 : ARtoCR. Global Instance AR1: One AR := cast AQ AR 1. Lemma ARtoCR_preserves_1 : cast AR CR 1 = 1. Proof. unfold "1", AR1. rewrite ARtoCR_inject. aq_preservation. Qed. Hint Rewrite ARtoCR_preserves_1 : ARtoCR. (* Plus *) Program Definition AQtranslate_uc (x : AQ_as_MetricSpace) := unary_uc (cast AQ Q_as_MetricSpace) ((x +) : AQ_as_MetricSpace → AQ_as_MetricSpace) (Qtranslate_uc ('x)) _. Next Obligation. apply Qball_0. apply preserves_sg_op. Qed. Definition ARtranslate (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQtranslate_uc x). Lemma ARtoCR_preserves_translate x y : 'ARtranslate x y = translate ('x) ('y). Proof. apply preserves_unary_fun. Qed. Hint Rewrite ARtoCR_preserves_translate : ARtoCR. Program Definition AQplus_uc := binary_uc (cast AQ Q_as_MetricSpace) ((+) : AQ_as_MetricSpace → AQ_as_MetricSpace → AQ_as_MetricSpace) Qplus_uc _. Next Obligation. apply Qball_0. apply preserves_sg_op. Qed. Definition ARplus_uc : AR --> AR --> AR := Cmap2 AQPrelengthSpace AQPrelengthSpace AQplus_uc. Global Instance ARplus: Plus AR := ucFun2 ARplus_uc. Lemma ARtoCR_preserves_plus x y : cast AR CR (x + y) = 'x + 'y. Proof. apply preserves_binary_fun. Qed. Hint Rewrite ARtoCR_preserves_plus : ARtoCR. (* Inverse *) Program Definition AQopp_uc := unary_uc (cast AQ Q_as_MetricSpace) ((-) : AQ → AQ) Qopp_uc _. Next Obligation. apply Qball_0. aq_preservation. Qed. Definition ARopp_uc : AR --> AR := Cmap AQPrelengthSpace AQopp_uc. Global Instance ARopp: Negate AR := ARopp_uc. Lemma ARtoCR_preserves_opp x : cast AR CR (-x) = -'x. Proof. apply preserves_unary_fun. Qed. Hint Rewrite ARtoCR_preserves_opp : ARtoCR. (* Mult *) Program Definition AQboundBelow_uc (x : AQ_as_MetricSpace) : AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc (cast AQ Q_as_MetricSpace) ((x ⊔) : AQ_as_MetricSpace → AQ_as_MetricSpace) (QboundBelow_uc ('x)) _. Next Obligation. apply Qball_0. aq_preservation. Qed. Definition ARboundBelow (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQboundBelow_uc x). Lemma ARtoCR_preserves_boundBelow x y : 'ARboundBelow x y = boundBelow ('x) ('y). Proof. apply preserves_unary_fun. Qed. Hint Rewrite ARtoCR_preserves_boundBelow : ARtoCR. Program Definition AQboundAbove_uc (x : AQ_as_MetricSpace) : AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc (cast AQ Q_as_MetricSpace) ((x ⊓) : AQ_as_MetricSpace → AQ_as_MetricSpace) (QboundAbove_uc ('x)) _. Next Obligation. apply Qball_0. aq_preservation. Qed. Definition ARboundAbove (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQboundAbove_uc x). Lemma ARtoCR_preserves_boundAbove x y : 'ARboundAbove x y = boundAbove ('x) ('y). Proof. apply preserves_unary_fun. Qed. Hint Rewrite ARtoCR_preserves_boundAbove : ARtoCR. Program Definition AQboundAbs_uc (c : AQ₊) : AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc (cast AQ Q_as_MetricSpace) (λ x : AQ_as_MetricSpace, (-'c) ⊔ (('c) ⊓ x) : AQ_as_MetricSpace) (QboundAbs ('c)) _. Next Obligation. apply Qball_0. aq_preservation. Qed. Definition ARboundAbs (c : AQ₊) : AR --> AR := Cmap AQPrelengthSpace (AQboundAbs_uc c). Lemma ARtoCR_preserves_bound_abs c x : 'ARboundAbs c x = CRboundAbs ('c) ('x). Proof. apply preserves_unary_fun. Qed. Hint Rewrite ARtoCR_preserves_bound_abs : ARtoCR. Program Definition AQscale_uc (x : AQ_as_MetricSpace) : AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc (cast AQ Q_as_MetricSpace) ((x *.) : AQ_as_MetricSpace → AQ_as_MetricSpace) (Qscale_uc ('x)) _. Next Obligation. apply Qball_0. aq_preservation. Qed. Definition ARscale (x : AQ_as_MetricSpace) : AR --> AR := Cmap AQPrelengthSpace (AQscale_uc x). Lemma ARtoCR_preserves_scale x y : 'ARscale x y = scale ('x) ('y). Proof. apply preserves_unary_fun. Qed. Hint Rewrite ARtoCR_preserves_scale : ARtoCR. Program Definition AQmult_uc (c : AQ₊) : AQ_as_MetricSpace --> AQ_as_MetricSpace --> AQ_as_MetricSpace := binary_uc (cast AQ Q_as_MetricSpace) (λ x y : AQ_as_MetricSpace, x * AQboundAbs_uc c y : AQ_as_MetricSpace) (Qmult_uc ('c)) _. Next Obligation. apply Qball_0. aq_preservation. Qed. Definition ARmult_bounded (c : AQ₊) : AR --> AR --> AR := Cmap2 AQPrelengthSpace AQPrelengthSpace (AQmult_uc c). Lemma ARtoCR_preserves_mult_bounded x y c : 'ARmult_bounded c x y = CRmult_bounded ('c) ('x) ('y). Proof. apply @preserves_binary_fun. Qed. Hint Rewrite ARtoCR_preserves_mult_bounded : ARtoCR. Lemma ARtoCR_approximate (x : AR) (ε : Qpos) : '(approximate x ε) = approximate ('x) ε. Proof. reflexivity. Qed. Lemma AR_b_correct (x : AR) : cast AQ Q (abs (approximate x (Qpos2QposInf (1#1))) + 1) = Qabs (approximate (cast AR CR x) (Qpos2QposInf (1#1))) + (1#1). Proof. aq_preservation. Qed. Program Definition AR_b (x : AR) : AQ₊ := exist _ (abs (approximate x (Qpos2QposInf (1#1))) + 1) _. Next Obligation. apply (strictly_order_reflecting (cast AQ Q)). rewrite AR_b_correct. aq_preservation. apply CR_b_pos. Qed. Global Instance ARmult: Mult AR := λ x y, ARmult_bounded (AR_b y) x y. Lemma ARtoCR_preserves_mult x y : cast AR CR (x * y) = 'x * 'y. Proof. unfold "*", ARmult at 1. rewrite ARtoCR_preserves_mult_bounded. assert (QposEq ('AR_b y : Qpos) (CR_b (1 # 1) ('y))). { unfold QposEq. simpl. now rewrite ARtoCR_approximate, <-AR_b_correct. } apply (CRmult_bounded_wd H5). Qed. Lemma ARmult_scale (x : AQ) (y : AR) : 'x * y = ARscale x y. Proof. apply (injective (cast AR CR)). rewrite ARtoCR_preserves_mult, ARtoCR_preserves_scale, ARtoCR_inject. now apply CRmult_scale. Qed. Hint Rewrite ARtoCR_preserves_mult : ARtoCR. (* The approximate reals form a ring *) Instance ARring: Ring AR. Proof. apply (rings.projected_ring (cast AR CR)). exact ARtoCR_preserves_plus. exact ARtoCR_preserves_0. exact ARtoCR_preserves_mult. exact ARtoCR_preserves_1. exact ARtoCR_preserves_opp. Qed. Instance: SemiRing_Morphism (cast AR CR). Proof. split. apply _. apply _. split. apply _. apply _. split. apply _. apply _. split. apply _. apply _. apply _. exact ARtoCR_preserves_plus. exact ARtoCR_preserves_0. split. apply _. apply _. split. apply _. apply _. split. apply _. apply _. apply _. exact ARtoCR_preserves_mult. exact ARtoCR_preserves_1. Qed. Instance: SemiRing_Morphism (cast CR AR). Proof. change (SemiRing_Morphism (inverse (cast AR CR))). split; apply _. Qed. Instance: SemiRing_Morphism (cast AQ AR). Proof. split. apply _. apply _. split. apply _. apply _. split. apply _. apply _. split. apply _. apply _. apply _. intros. apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl. apply (Qpos_nonneg (ε + ε)). apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl. apply (Qpos_nonneg (ε + ε)). split. apply _. apply _. split. apply _. apply _. split. apply _. apply _. apply _. intros. rewrite ARmult_scale. apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl. apply (Qpos_nonneg (ε + ε)). apply regFunEq_equiv, regFunEq_e. intros ε. apply ball_refl. apply (Qpos_nonneg (ε + ε)). Qed. Add Ring CR : (rings.stdlib_ring_theory CR). Add Ring AR : (rings.stdlib_ring_theory AR). Lemma ARplus_comm : forall x y : AR, x + y = y + x. Proof. intros. ring. Qed. Lemma ARplus_assoc : forall u v w : AR, (u + v) + w = u + (v + w). Proof. intros. ring. Qed. Lemma ARplus_opp_r : forall x : AR, x - x = 0. Proof. intros. ring. Qed. Lemma ARmult_comm : forall x y : AR, x * y = y * x. Proof. intros. ring. Qed. Lemma ARmult_assoc : forall u v w : AR, (u * v) * w = u * (v * w). Proof. intros. ring. Qed. Lemma ARmult_1_l : forall x : AR, 1 * x = x. Proof. intros. ring. Qed. Lemma ARmult_1_r : forall x : AR, x * 1 = x. Proof. intros. ring. Qed. Lemma ARopp_mult_distr_r : forall (r1 r2 : AR), - (r1 * r2) = r1 * (- r2). Proof. intros. ring. Qed. Lemma ARopp_involutive : forall (r1 : AR), - - r1 = r1. Proof. intros. ring. Qed. Lemma ARplus_0_r : forall x : AR, x + 0 = x. Proof. intros. ring. Qed. (* Non strict order *) Definition ARnonNeg (x : AR) : Prop := ∀ ε : Qpos, -cast Qpos Q ε ≤ cast AQ Q (approximate x ε). Lemma ARtoCR_preserves_nonNeg x : ARnonNeg x ↔ CRnonNeg ('x). Proof. reflexivity. Qed. Hint Resolve ARtoCR_preserves_nonNeg. Global Instance: Proper ((=) ==> iff) ARnonNeg. Proof. intros x1 x2 E. split; intros; apply ARtoCR_preserves_nonNeg; [rewrite <-E | rewrite E]; auto. Qed. Global Instance ARle: Le AR := λ x y, ARnonNeg (y - x). Global Instance ARle_wd: Proper ((=) ==> (=) ==> iff) ARle. Proof. unfold ARle. solve_proper. Qed. Lemma ARtoCR_preserves_le (x y : AR) : x ≤ y ↔ ' x ≤ ' y. Proof. unfold le, ARle, CRle. now rewrite ARtoCR_preserves_nonNeg, rings.preserves_minus. Qed. Instance: PartialOrder ARle. Proof. apply (maps.projected_partial_order (cast AR CR)). apply ARtoCR_preserves_le. Qed. Lemma ARle_trans : forall x y z : AR, ARle x y -> ARle y z -> ARle x z. Proof. intros. apply ARtoCR_preserves_le. apply (@CRle_trans _ ('y)). apply ARtoCR_preserves_le, H5. apply ARtoCR_preserves_le, H6. Qed. Lemma ARsquare_pos : forall x : AR, ARle 0 (x*x). Proof. intros x. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_mult. rewrite ARtoCR_preserves_0. apply CRsquare_pos. Qed. Lemma ARplus_le_compat_l : forall x y z : AR, ARle x y -> ARle (z+x) (z+y). Proof. intros. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_plus. rewrite ARtoCR_preserves_plus. apply CRArith.CRplus_le_l. apply ARtoCR_preserves_le in H5. exact H5. Qed. Lemma ARplus_le_compat_r : forall x y z : AR, ARle x y -> ARle (x+z) (y+z). Proof. intros. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_plus. rewrite ARtoCR_preserves_plus. apply CRArith.CRplus_le_r. apply ARtoCR_preserves_le in H5. exact H5. Qed. Global Instance: OrderEmbedding ARtoCR. Proof. repeat (split; try apply _); apply ARtoCR_preserves_le. Qed. (* Strict order in Type *) Global Instance: OrderEmbedding (cast AQ AR). Proof. repeat (split; try apply _); intros x y E. apply (order_reflecting (cast AR CR)). rewrite 2!ARtoCR_inject. now do 2 apply (order_preserving _). apply (order_reflecting (cast AQ Q)). apply (order_reflecting (cast Q CR)). rewrite <-2!ARtoCR_inject. now apply (order_preserving _). Qed. Definition ARpos (x : AR) : Type := sig (λ y : AQ₊, 'y ≤ x). Program Definition ARpos_char (ε : AQ₊) (x : AR) (Pε : 'ε ≤ approximate x ((1#2) * 'ε)%Qpos) : ARpos x := Pos_shiftl ε (-1 : Z) ↾ _. Next Obligation. intros δ. change (-('δ : Q) ≤ '(approximate x ((1 # 2) * δ)%Qpos - ('ε : AQ) ≪ (-1))). transitivity (-'((1 # 2) * δ)%Qpos). apply rings.flip_le_negate. change ((1 # 2) * proj1_sig δ ≤ proj1_sig δ). rewrite <-(rings.mult_1_l (proj1_sig δ)) at 2. now apply (order_preserving (.* (proj1_sig δ))). apply rings.flip_nonneg_minus. transitivity (('approximate x ((1#2) * 'ε)%Qpos - 'ε)%mc : Q). apply (order_preserving (cast AQ Q)) in Pε. now apply rings.flip_nonneg_minus. apply rings.flip_le_minus_l. transitivity (((1 # 2) * 'ε + (1 # 2) * proj1_sig δ) + 'approximate x ((1 # 2) * δ)%Qpos). apply rings.flip_le_minus_l. now destruct (regFun_prf x ((1#2) * 'ε)%Qpos ((1#2) * δ)%Qpos). rewrite rings.preserves_minus, aq_shift_opp_1. apply orders.eq_le. change ((1 # 2) * 'ε + (1 # 2) * proj1_sig δ + 'approximate x ((1 # 2) * δ)%Qpos == 'approximate x ((1 # 2) * δ)%Qpos - 'ε * (1#2) - - ((1 # 2) * proj1_sig δ) + 'ε)%Q. ring. Qed. Lemma ARtoCR_preserves_pos x : prod (ARpos x -> CRpos ('x)) (CRpos ('x) -> ARpos x). Proof with auto with qarith. split; intros [y E]. exists (cast (AQ₊) (Q₊) y). change (cast Q CR (cast AQ Q (cast (AQ₊) AQ y)) ≤ cast AR CR x). rewrite <-ARtoCR_inject. now apply (order_preserving _). destruct (aq_lt_mid 0 (proj1_sig y)) as [z [Ez1 Ez2]]... assert (0 < z) as F. apply (strictly_order_reflecting (cast AQ Q)). now aq_preservation... exists (exist _ z F). simpl. change (cast AQ AR (cast (AQ₊) AQ (z ↾ F)) ≤ x). apply (order_reflecting (cast AR CR)). rewrite ARtoCR_inject. transitivity (cast Q CR (cast Qpos Q y)); trivial. apply CRle_Qle... Defined. Lemma ARpos_wd : ∀ x1 x2, x1 = x2 → ARpos x1 → ARpos x2. Proof. intros x1 x2 E G. destruct G. exists x. rewrite <- E. exact l. Defined. Definition ARltT: AR → AR → Type := λ x y, ARpos (y - x). Lemma ARtoCR_preserves_ltT x y : prod (ARltT x y -> CRltT ('x) ('y)) (CRltT ('x) ('y) -> ARltT x y). Proof. split; intros. - apply ARtoCR_preserves_pos in X. eapply CRpos_wd; eauto. now autorewrite with ARtoCR. - apply ARtoCR_preserves_pos. eapply CRpos_wd; eauto. now autorewrite with ARtoCR. Defined. Lemma CRtoAR_preserves_ltT : forall x y, prod (CRltT x y -> ARltT (cast CR AR x) (cast CR AR y)) (ARltT (cast CR AR x) (cast CR AR y) -> CRltT x y). Proof. intros x y. pose proof (CRAR_id x) as H6. pose proof (CRAR_id y) as H7. split. - intros. symmetry in H6. symmetry in H7. pose proof (CRltT_wd H6 H7 H5). apply ARtoCR_preserves_ltT in H8. exact H8. - intros H5. apply (CRltT_wd H6 H7). apply ARtoCR_preserves_ltT. exact H5. Qed. Lemma ARltT_wd : ∀ x1 x2 : AR, x1 = x2 → ∀ y1 y2, y1 = y2 → ARltT x1 y1 → ARltT x2 y2. Proof. intros x1 x2 E y1 y2 F G. apply (ARpos_wd (y1 + - x1)). 2: exact G. rewrite E, F. reflexivity. Defined. (* Apartness in Type *) Definition ARapartT: AR → AR → Type := λ x y, sum (ARltT x y) (ARltT y x). Lemma ARapartT_wd : forall x y z t : AR, msp_eq x y -> msp_eq z t -> ARapartT x z -> ARapartT y t. Proof. intros. destruct X. - left. apply (ARltT_wd _ _ H5 _ _ H6), a. - right. apply (ARltT_wd _ _ H6 _ _ H5), a. Defined. Lemma ARtoCR_preserves_apartT x y : prod (ARapartT x y -> CRapartT ('x) ('y)) (CRapartT ('x) ('y) -> ARapartT x y). Proof. split; (intros [|]; [left|right]; now apply ARtoCR_preserves_ltT). Defined. Lemma ARtoCR_preserves_apartT_0 x : prod (ARapartT x 0 -> CRapartT ('x) 0) (CRapartT ('x) 0 -> ARapartT x 0). Proof. split; intros. - apply (@CRapartT_wd ('x)%mc _ (reflexivity _) (cast AR CR 0)). apply ARtoCR_preserves_0. apply ARtoCR_preserves_apartT, X. - apply (@CRapartT_wd ('x)%mc _ (reflexivity _) _ (cast AR CR 0)) in H5. apply ARtoCR_preserves_apartT in H5. exact H5. symmetry; apply ARtoCR_preserves_0. Defined. (* Strict order in Prop *) (* Yields Gt if x is certainly greater than 2 ^ k, Lt if x is certainly greater than -2 ^ k, Eq otherwise. *) Definition AR_epsilon_sign_dec (k : Z) (x : AR) : comparison := let ε : AQ₊ := Pos_shiftl 1 k in let z : AQ := approximate x ((1#2) * 'ε)%Qpos in if decide_rel (≤) ('ε) z then Gt else if decide_rel (≤) z (-'ε) then Datatypes.Lt else Eq. Program Definition AR_epsilon_sign_dec_pos (x : AR) (k : Z) (Pk : AR_epsilon_sign_dec k x ≡ Gt) : ARpos x := ARpos_char (Pos_shiftl 1 k) x _. Next Obligation. revert Pk. unfold AR_epsilon_sign_dec. case (decide_rel (≤)); [ intros; assumption |]. case (decide_rel (≤)); discriminate. Qed. Program Definition AR_epsilon_sign_dec_neg (x : AR) (k : Z) (Pk : AR_epsilon_sign_dec k x ≡ Datatypes.Lt) : ARpos (-x) := ARpos_char (Pos_shiftl 1 k) (-x) _. Next Obligation. revert Pk. unfold AR_epsilon_sign_dec. case (decide_rel (≤)); [discriminate |]. case (decide_rel (≤)); [| discriminate]. intros. apply rings.flip_le_negate. now rewrite rings.negate_involutive. Qed. Definition AR_epsilon_sign_dec_apartT (x y : AR) (k : Z) (Pk : ¬AR_epsilon_sign_dec k (x - y) ≡ Eq) : ARapartT x y. Proof. revert Pk. case_eq (AR_epsilon_sign_dec k (x - y)); intros E ?. now destruct Pk. left. apply ARpos_wd with (-(x - y)). ring. now apply AR_epsilon_sign_dec_neg with k. right. now apply AR_epsilon_sign_dec_pos with k. Defined. Lemma AR_epsilon_sign_dec_Gt (k : Z) (x : AR) : 1 ≪ k ≤ approximate x (Qpos_mult (1#2) ('Pos_shiftl (1:AQ₊) k)) → AR_epsilon_sign_dec k x ≡ Gt. Proof. intros. unfold AR_epsilon_sign_dec. case (decide_rel _); intuition. Qed. Lemma AR_epsilon_sign_dec_pos_rev (x : AR) (k : Z) : cast AQ AR (1 ≪ (1 + k)) ≤ x → AR_epsilon_sign_dec k x ≡ Gt. Proof. intros E. apply AR_epsilon_sign_dec_Gt. apply (order_reflecting (+ -1 ≪ (1 + k))). transitivity (-1 ≪ k). apply orders.eq_le. rewrite (commutativity _ k), shiftl.shiftl_exp_plus, shiftl.shiftl_1. rewrite rings.plus_mult_distr_r, rings.mult_1_l. rewrite rings.negate_plus_distr, associativity, rings.plus_negate_r. simpl. ring. apply (order_reflecting (cast AQ Q)). rewrite rings.preserves_negate. exact (E ('Pos_shiftl (1 : AQ₊) k)). Qed. (* Hack: we write [-1 - cast nat Z n] instead of [cast nat Z n] because approximate is not Proper. *) Global Instance ARlt: Lt AR := λ x y, ∃ n : nat, AR_epsilon_sign_dec (-1 - cast nat Z n) (y - x) ≡ Gt. Lemma AR_lt_ltT x y : prod (x < y -> ARltT x y) (ARltT x y -> x < y). Proof. split. - intros E. apply ConstructiveEpsilon.constructive_indefinite_description_nat in E. destruct E as [n En]. now apply AR_epsilon_sign_dec_pos with (-1 - cast nat Z n). intros. now apply comparison_eq_dec. - intros [ε Eε]. exists (Z.nat_of_Z (-Qdlog2 ('ε))). apply AR_epsilon_sign_dec_pos_rev. transitivity ('ε : AR); [| assumption]. rapply (order_preserving (cast AQ AR)). apply (order_reflecting (cast AQ Q)). rewrite aq_shift_correct, rings.preserves_1, rings.mult_1_l. destruct (decide (('ε : Q) ≤ 1)). rewrite Z.nat_of_Z_nonneg. mc_setoid_replace (1 + (-1 - - Qdlog2 ('ε))) with (Qdlog2 ('ε)) by ring. apply Qdlog2_spec. apply semirings.preserves_pos. now destruct ε. change (0 ≤ -Qdlog2 ('ε)). apply rings.flip_nonpos_negate. now apply Qdlog2_nonpos. rewrite Z.nat_of_Z_nonpos. now apply orders.le_flip. change (-Qdlog2 ('ε) ≤ 0). apply rings.flip_nonneg_negate. apply Qdlog2_nonneg. now apply orders.le_flip. Qed. Instance: Proper ((=) ==> (=) ==> iff) ARlt. Proof. split; intro E; apply AR_lt_ltT; apply AR_lt_ltT in E; eapply ARltT_wd; eauto; now symmetry. Qed. (* Apartness in Prop *) Global Instance ARapart: Apart AR := λ x y, x < y ∨ y < x. Lemma ARtoCR_preserves_lt (x y : AR) : x < y ↔ 'x < 'y. Proof. split; intros E. now apply CR_lt_ltT, ARtoCR_preserves_ltT, AR_lt_ltT. now apply AR_lt_ltT, ARtoCR_preserves_ltT, CR_lt_ltT. Qed. Lemma AR_apart_apartT x y : prod (x ≶ y -> ARapartT x y) (ARapartT x y -> x ≶ y). Proof. split. - intros E. set (f (n : nat) := AR_epsilon_sign_dec (-1 - cast nat Z n)). assert (∃ n, f n (y - x) ≡ Gt ∨ f n (x - y) ≡ Gt) as E2. now destruct E as [[n En] | [n En]]; exists n; [left | right]. apply ConstructiveEpsilon.constructive_indefinite_description_nat in E2. destruct E2 as [n E2]. destruct (comparison_eq_dec (f n (y - x)) Gt) as [En|En]. left. now apply AR_epsilon_sign_dec_pos with (-1 - cast nat Z n). right. apply AR_epsilon_sign_dec_pos with (-1 - cast nat Z n). destruct E2; tauto. intros n. destruct (comparison_eq_dec (f n (y - x)) Gt); auto. destruct (comparison_eq_dec (f n (x - y)) Gt); tauto. - intros [E|E]. left. now apply AR_lt_ltT. right. now apply AR_lt_ltT. Qed. Let ARtoCR_preserves_apart x y : x ≶ y ↔ cast AR CR x ≶ cast AR CR y. Proof. unfold apart, ARapart, CRapart. now rewrite !ARtoCR_preserves_lt. Qed. Instance: StrongSetoid AR. Proof. apply (strong_setoids.projected_strong_setoid (cast AR CR)). split; intros E; [now rewrite E | now apply (injective (cast AR CR))]. now apply ARtoCR_preserves_apart. Qed. Instance: StrongSetoid_Morphism (cast AR CR). Proof. split; try apply _; now apply ARtoCR_preserves_apart. Qed. Global Instance: StrongInjective (cast AR CR). Proof. split; try apply _; now apply ARtoCR_preserves_apart. Qed. Global Instance: StrongSemiRing_Morphism (cast AR CR). Proof. split; try apply _. Qed. Global Instance: StrongSemiRing_Morphism (cast AQ AR). Proof. repeat (split; try apply _). intros. apply (strong_extensionality (cast AQ Q)). apply (strong_extensionality (cast Q CR)). rewrite <-2!ARtoCR_inject. now apply (strong_injective _). Qed. Global Instance: StrongInjective (cast AQ AR). Proof. repeat (split; try apply _). intros. apply (strong_extensionality (cast AR CR)). rewrite 2!ARtoCR_inject. apply (strong_injective _). now apply (strong_injective _). Qed. Global Instance ARfpsro: FullPseudoSemiRingOrder ARle ARlt. Proof. apply (rings.projected_full_pseudo_ring_order (cast AR CR)). apply ARtoCR_preserves_le. apply ARtoCR_preserves_lt. Qed. Lemma ARle_not_lt (x y: AR): ARle x y <-> (ARltT y x -> False). Proof. destruct ARfpsro as [_ flip]. specialize (flip x y). destruct flip. split. - intros. apply H5. exact H7. apply AR_lt_ltT, X. - intros. apply H6. intro abs. apply H7. apply AR_lt_ltT, abs. Qed. Global Instance: StrictOrderEmbedding (cast AR CR). Proof. repeat (split; try apply _); apply ARtoCR_preserves_lt. Qed. (* Division *) Lemma aq_mult_inv_regular_prf (x : AQ) : is_RegularFunction_noInf _ (λ ε : Qpos, app_div 1 x (Qdlog2 (proj1_sig ε)) : AQ_as_MetricSpace). Proof. intros ε1 ε2. simpl. eapply ball_triangle. now eapply aq_div_dlog2. now eapply ball_sym, aq_div_dlog2. Qed. Definition AQinv (x : AQ) : AR := mkRegularFunction (0 : AQ_as_MetricSpace) (aq_mult_inv_regular_prf x). Definition AQinv_bounded (c : AQ₊) (x : AQ_as_MetricSpace) : AR := AQinv (('c) ⊔ x). Lemma AQinv_pos_uc_prf (c : AQ₊) : is_UniformlyContinuousFunction (AQinv_bounded c) (Qinv_modulus ('c)). Proof. intros ε x y E δ1 δ2. simpl in *. eapply ball_triangle. 2: now eapply ball_sym, aq_div_dlog2. eapply ball_triangle. now eapply aq_div_dlog2. simpl. aq_preservation. rewrite 2!left_identity. pose proof (Qinv_pos_uc_prf (' c) ε (' x) (' y)) as H5. simpl in H5. apply H5. exact E. Qed. Definition AQinv_pos_uc (c : AQ₊) := Build_UniformlyContinuousFunction (AQinv_pos_uc_prf c). Definition ARinv_pos (c : AQ₊) : AR --> AR := Cbind AQPrelengthSpace (AQinv_pos_uc c). Lemma ARtoCR_preserves_inv_pos_aux c (x : AR) : is_RegularFunction_noInf _ (λ γ, / Qmax (''c) ('approximate x (Qinv_modulus ('c) γ)) : Q_as_MetricSpace). Proof. intros ε1 ε2. apply_simplified (Qinv_pos_uc_prf ('c) (ε1 + ε2)%Qpos). apply AQball_fold. setoid_replace (' c * ' c * (` ε1 + ` ε2))%Q with (proj1_sig (Qinv_modulus ('c) ε1 + Qinv_modulus ('c) ε2)%Qpos) by (unfold equiv, stdlib_rationals.Q_eq; simpl; ring). apply regFun_prf. Qed. Lemma ARtoCR_preserves_inv_pos x c : 'ARinv_pos c x = CRinv_pos ('c) ('x). Proof. apply regFunEq_equiv, regFunEq_e. intros ε. simpl. unfold Cjoin_raw. simpl. setoid_replace (proj1_sig ε + proj1_sig ε)%Q with (proj1_sig ((1#2) * ε + ((1#2) * ε + ε)))%Qpos by (unfold equiv, stdlib_rationals.Q_eq; simpl; ring). eapply ball_triangle. now apply aq_div_dlog2. simpl. rewrite aq_preserves_max. rewrite rings.preserves_1. rewrite Qmult_1_l. change (Qball ( (1 # 2) * ` ε + ` ε) (/ Qmax (' (' c)) (' approximate x (Qinv_modulus (' c) ((1 # 2) ↾ eq_refl * ε))))%mc ( / Qmax (' c) (' approximate x (Qinv_modulus (' c) ε)))). apply (ARtoCR_preserves_inv_pos_aux c x ((1 # 2) * ε)%Qpos). Qed. Hint Rewrite ARtoCR_preserves_inv_pos : ARtoCR. Definition ARinvT (x : AR) (x_ : ARapartT x 0) : AR := match x_ with | inl (exist _ c _) => - ARinv_pos c (- x) | inr (exist _ c _) => ARinv_pos c x end. Lemma ARtoCR_preserves_invT x x_ x__: 'ARinvT x x_ = CRinvT ('x) x__. Proof with auto with qarith; try reflexivity. unfold ARinvT. destruct x_ as [Ec | Ec]. assert (CRltT ('x) 0) as Px. apply CRltT_wd with ('x) (cast AR CR 0). reflexivity. now apply rings.preserves_0. now apply ARtoCR_preserves_ltT. rewrite (CRinvT_irrelevant _ (inl Px)). unfold CRinvT. destruct Ec as [c Ec], Px as [d Ed]. autorewrite with ARtoCR. destruct (Qlt_le_dec (proj1_sig d) (proj1_sig ('c : Qpos))). rewrite (CRinv_pos_weaken d ('c))... change (cast Q CR (cast AQ Q (cast (AQ₊) AQ c)) ≤ -cast AR CR x). rewrite <-ARtoCR_inject, <-rings.preserves_negate. apply (order_preserving _). rewrite <-(rings.plus_0_l (-x))... rewrite (CRinv_pos_weaken ('c) d)... rewrite <-(rings.plus_0_l (-cast AR CR x))... assert (CRltT 0 ('x)) as Px. apply CRltT_wd with (cast AR CR 0) ('x). now apply rings.preserves_0. reflexivity. now apply ARtoCR_preserves_ltT. rewrite (CRinvT_irrelevant _ (inr Px)). unfold CRinvT. destruct Ec as [c Ec], Px as [d Ed]. autorewrite with ARtoCR. destruct (Qlt_le_dec (proj1_sig d) (proj1_sig ('c : Qpos))). rewrite (CRinv_pos_weaken d ('c))... change (cast Q CR (cast AQ Q (cast (AQ₊) AQ c)) ≤ cast AR CR x). rewrite <-ARtoCR_inject. apply (order_preserving _). setoid_replace x with (x - 0) by ring... rewrite (CRinv_pos_weaken ('c) d)... rewrite <-(rings.plus_0_r (cast AR CR x))... Qed. Lemma ARtoCR_preserves_invT_l x x_ : {x__ | 'ARinvT x x_ = CRinvT ('x) x__}. Proof. exists (fst (ARtoCR_preserves_apartT_0 x) x_). apply ARtoCR_preserves_invT. Qed. Lemma ARtoCR_preserves_invT_r x x__ : {x_ | 'ARinvT x x_ = CRinvT ('x) x__}. Proof. exists (snd (ARtoCR_preserves_apartT_0 x) x__). apply ARtoCR_preserves_invT. Qed. Lemma AR_inverseT (x : AR) x_ : x * ARinvT x x_ = 1. Proof. apply (injective (cast AR CR)). rewrite rings.preserves_mult, rings.preserves_1. destruct (ARtoCR_preserves_invT_l x x_) as [x__ E]. rewrite E. apply CRmult_inv_r. Qed. Lemma ARinvT_wd x y x_ y_ : x = y → ARinvT x x_ = ARinvT y y_. Proof. intros E. apply (injective (cast AR CR)). destruct (ARtoCR_preserves_invT_l x x_) as [x__ Ex], (ARtoCR_preserves_invT_l y y_) as [y__ Ey]. rewrite Ex, Ey. now apply CRinvT_wd. Qed. Lemma ARinvT_irrelevant x x_ x__ : ARinvT x x_ = ARinvT x x__. Proof. now apply ARinvT_wd. Qed. (* Division with apartness in Prop *) Program Instance ARinv: Recip AR := λ x, ARinvT x _. Next Obligation. apply AR_apart_apartT. now destruct x. Qed. Global Instance: Field AR. Proof. split. apply _. apply _. apply _. apply _. apply (strong_injective (cast AQ AR)). solve_propholds. split. apply _. apply _. intros [x Px] [y Py] E. now refine (ARinvT_wd _ _ _ _ _). intros x. now apply AR_inverseT. Qed. (* Nat pow *) Program Definition AQpower_N_uc (n : N) (c : AQ₊) : AQ_as_MetricSpace --> AQ_as_MetricSpace := unary_uc (cast AQ Q_as_MetricSpace) (λ x : AQ_as_MetricSpace, (AQboundAbs_uc c x) ^ n : AQ_as_MetricSpace) (Qpower_N_uc n ('c)) _. Next Obligation. assert (∀ y : AQ, cast AQ Q (y ^ n) = 'y ^ 'n) as preserves_pow_pos. intros y. rewrite nat_pow.preserves_nat_pow. now rewrite (int_pow.int_pow_nat_pow (f:=cast N Z)). apply Qball_0. rewrite preserves_pow_pos. aq_preservation. Qed. Definition ARpower_N_bounded (n : N) (c : AQ₊) : AR --> AR := Cmap AQPrelengthSpace (AQpower_N_uc n c). Lemma ARtoCR_preserves_power_N_bounded x n c : 'ARpower_N_bounded n c x = CRpower_N_bounded n ('c) ('x). Proof. apply preserves_unary_fun. Qed. Global Instance ARpower_N: Pow AR N := λ x n, ucFun (ARpower_N_bounded n (AR_b x)) x. Lemma ARtoCR_preserves_power_N (x : AR) (n : N) : cast AR CR (x ^ n) = ('x) ^ n. Proof. unfold pow, CRpower_N, ARpower_N. rewrite ARtoCR_preserves_power_N_bounded. apply Cmap_wd. 2: reflexivity. assert (QposEq (cast (AQ₊) (Q₊) (AR_b x)) (CR_b (1#1) ('x))). { unfold QposEq. simpl. now rewrite ARtoCR_approximate, <-AR_b_correct. } rewrite H5. reflexivity. Qed. Hint Rewrite ARtoCR_preserves_power_N : ARtoCR. Global Instance: NatPowSpec AR N _. Proof. split. intros ? ? Ex ? ? En. apply (injective (cast AR CR)). autorewrite with ARtoCR. now rewrite Ex, En. intros. apply (injective (cast AR CR)). autorewrite with ARtoCR. now rewrite nat_pow_0. intros. apply (injective (cast AR CR)). autorewrite with ARtoCR. now rewrite nat_pow_S. Qed. (* Misc properties *) Lemma ARmult_bounded_mult (x y : AR) c : -'c ≤ y ≤ 'c → ARmult_bounded c x y = x * y. Proof. intros. apply (injective (cast AR CR)). rewrite ARtoCR_preserves_mult, ARtoCR_preserves_mult_bounded. destruct c as [c Pc]. apply CRmult_bounded_mult. change (cast Q CR (-cast AQ Q c) ≤ cast AR CR y). rewrite <-rings.preserves_negate. rewrite <-ARtoCR_inject. apply (order_preserving _). intuition. change (cast AR CR y ≤ cast Q CR (cast AQ Q c)). rewrite <-ARtoCR_inject. apply (order_preserving _). intuition. Qed. Lemma ARpower_N_bounded_N_power (n : N) (x : AR) (c : AQ₊) : -'c ≤ x ≤ 'c → ARpower_N_bounded n c x = x ^ n. Proof. intros. apply (injective (cast AR CR)). rewrite ARtoCR_preserves_power_N, ARtoCR_preserves_power_N_bounded. destruct c as [c Pc]. apply CRpower_N_bounded_N_power. split. change (cast Q CR (-cast AQ Q c) ≤ cast AR CR x). rewrite <-rings.preserves_negate. rewrite <-ARtoCR_inject. apply (order_preserving _). intuition. change (cast AR CR x ≤ cast Q CR (cast AQ Q c)). rewrite <-ARtoCR_inject. apply (order_preserving _). intuition. Qed. Lemma inject_Q_AR_lt : ∀ q r : Q, q < r → ARltT (inject_Q_AR q) (inject_Q_AR r). Proof. intros. destruct (ARtoCR_preserves_ltT (' (' q)%CR) (' (' r)%CR)) as [_ a]. pose proof (inject_Q_AR_CR q). pose proof (inject_Q_AR_CR r). symmetry in H6. symmetry in H7. apply (ARltT_wd _ _ H6 _ _ H7). apply a. clear a H6 H7. pose proof (CRAR_id ('q)%CR). pose proof (CRAR_id ('r)%CR). symmetry in H6. symmetry in H7. apply (@CRltT_wd _ _ H6 _ _ H7). apply CRlt_Qlt, H5. Qed. Lemma inject_Q_AR_lt_rev : ∀ q r : Q, ARltT (inject_Q_AR q) (inject_Q_AR r) → q < r. Proof. intros. destruct (ARtoCR_preserves_ltT (' (' q)%CR) (' (' r)%CR)) as [c _]. pose proof (inject_Q_AR_CR q) as H6. pose proof (inject_Q_AR_CR r) as H7. apply (ARltT_wd _ _ H6 _ _ H7) in X. apply c in X. clear c H6 H7. pose proof (CRAR_id ('q)%CR). pose proof (CRAR_id ('r)%CR). apply (@CRltT_wd _ _ H5 _ _ H6) in X. apply Qlt_from_CRlt, X. Qed. Lemma inject_Q_AR_le : ∀ q r : Q, q <= r → ARle (inject_Q_AR q) (inject_Q_AR r). Proof. intros. apply ARle_not_lt. intro abs. apply inject_Q_AR_lt_rev in abs. exact (Qlt_not_le _ _ abs H5). Qed. Lemma inject_Q_AR_plus : ∀ q r : Q, inject_Q_AR (q + r) = inject_Q_AR q + inject_Q_AR r. Proof. intros. apply (injective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace))). pose proof CRAR_id as H5. unfold cast in H5. unfold ARtoCR, ARtoCR_uc in H5. unfold cast. rewrite (inject_Q_AR_CR (q+r)). rewrite (inject_Q_AR_CR q). rewrite (inject_Q_AR_CR r). unfold cast. unfold cast in H5. rewrite H5. pose proof (ARtoCR_preserves_plus (CRtoAR (' q)%CR) (CRtoAR (' r)%CR)) as H6. rewrite H6. rewrite <- CRplus_Qplus. apply ucFun2_wd. rewrite (H5 ('q)%CR). reflexivity. rewrite (H5 ('r)%CR). reflexivity. Qed. Lemma inject_Q_AR_mult : ∀ q r : Q, inject_Q_AR (q * r) = inject_Q_AR q * inject_Q_AR r. Proof. intros. apply (injective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace))). pose proof CRAR_id as H5. unfold cast in H5. unfold ARtoCR, ARtoCR_uc in H5. rewrite (inject_Q_AR_CR (q*r)). rewrite (inject_Q_AR_CR q). rewrite (inject_Q_AR_CR r). unfold cast. unfold cast in H5. rewrite H5. pose proof (ARtoCR_preserves_mult (CRtoAR (' q)%CR) (CRtoAR (' r)%CR)) as H6. rewrite H6. rewrite <- CRmult_Qmult. apply CRmult_wd. rewrite (H5 ('q)%CR). reflexivity. rewrite (H5 ('r)%CR). reflexivity. Qed. Lemma inject_Q_AR_1 : inject_Q_AR (1#1) = 1. Proof. Local Transparent regFunEq. intros e1 e2. simpl. destruct aq_dense_embedding. specialize (dense_inverse 1 e1). simpl in dense_inverse. rewrite Qplus_0_r. apply (@ball_weak_le Q_as_MetricSpace (`e1) (`e1+`e2)). apply (Qle_trans _ (`e1 + 0)). rewrite Qplus_0_r. apply Qle_refl. apply Qplus_le_r, Qpos_nonneg. simpl. unfold cast. destruct aq_ring_morphism, semiringmor_mult_mor. rewrite preserves_mon_unit. exact dense_inverse. Qed. Lemma inject_Q_AR_0 : inject_Q_AR (0#1) = 0. Proof. intros e1 e2. simpl. destruct aq_dense_embedding. simpl in dense_inverse. rewrite Qplus_0_r. apply (@ball_weak_le Q_as_MetricSpace (`e1) (`e1+`e2)). apply (Qle_trans _ (`e1 + 0)). rewrite Qplus_0_r. apply Qle_refl. apply Qplus_le_r, Qpos_nonneg. simpl. unfold cast. destruct aq_ring_morphism, semiringmor_plus_mor. rewrite preserves_mon_unit. apply dense_inverse. Qed. Lemma inject_Q_AR_wd : forall q r : Q, q == r -> inject_Q_AR q = inject_Q_AR r. Proof. intros q r qreq e1 e2. simpl. destruct aq_dense_embedding. unfold cast. rewrite Qplus_0_r. apply ball_triangle with (b:=q). apply dense_inverse. simpl. rewrite qreq. change (Qball (` e2) r (AQtoQ (app_inverse AQtoQ r e2))). apply ball_sym. apply dense_inverse. Qed. Lemma AR_mult_0_lt_compat : ∀ x y : AR, ARltT (inject_Q_AR 0) x → ARltT (inject_Q_AR 0) y → ARltT (inject_Q_AR 0) (ARmult x y). Proof. intros x y X X0. destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) (ARmult x y)) as [_ a]. apply a. clear a. pose proof (ARtoCR_preserves_mult x y) as H5. unfold mult in H5. symmetry in H5. assert (0 = ARtoCR (inject_Q_AR 0))%CR as H7. { rewrite <- (CRAR_id 0%CR). unfold cast. rewrite (inject_Q_AR_CR 0). reflexivity. } pose proof (ARtoCR_preserves_mult x y) as H8. symmetry in H8. apply (CRltT_wd H7 H8). clear H8 H5. apply CRmult_lt_0_compat. - destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) x). apply c in X. clear a c. symmetry in H7. apply (CRltT_wd H7 (reflexivity _)). exact X. - destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) y). apply c in X0. clear a c. symmetry in H7. apply (CRltT_wd H7 (reflexivity _)). exact X0. Qed. Lemma AR_mult_0_le_compat : ∀ x y : AR, ARle 0 x → ARle 0 y → ARle 0 (x*y). Proof. intros. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_mult. rewrite ARtoCR_preserves_0. apply (CRmult_le_0_compat ('x) ('y)). rewrite <- ARtoCR_preserves_0. apply ARtoCR_preserves_le, H5. rewrite <- ARtoCR_preserves_0. apply ARtoCR_preserves_le, H6. Qed. End ARarith. corn-8.20.0/reals/faster/ARQ.v000066400000000000000000000042421473720167500157640ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import QArith. Require Import CoRN.util.Qdlog. From Coq Require Import ZArith. Require Import CoRN.reals.fast.Compress CoRN.metric2.MetricMorphisms CoRN.model.metric2.Qmetric CoRN.reals.faster.ARArith CoRN.model.totalorder.QposMinMax. #[global] Instance Q_approx: AppApprox Q := λ (x : Q) (k : Z), match k with | Zneg p => approximateQ x (2 ^ p) | _ => x end. Lemma Q_approx_correct (x : Q) (k : Z) : Qball (2 ^ k) (app_approx x k) x. Proof. destruct k as [|p|]. - apply ball_refl. discriminate. - apply ball_refl. apply Qpower.Qpower_pos_positive. discriminate. - unfold app_approx, Q_approx. setoid_replace (2 ^ Zneg p)%Q with (1 # (2 ^ p))%Q. now apply ball_sym, approximateQ_correct. change (/ Qpower (inject_Z 2%Z) (Zpos p) == 1 # 2 ^ p). rewrite <-Qpower.Zpower_Qpower; auto with zarith. now rewrite <- Zpower_Ppow. Qed. #[global] Instance Q_approx_div: AppDiv Q := λ x y k, app_approx (x / y) k. #[global] Instance inject_Q_Q: Cast Q Q_as_MetricSpace := Datatypes.id. #[global] Instance inverse_Q_Q: AppInverse inject_Q_Q := λ x ε, app_approx x (Qdlog2 (proj1_sig ε)). #[global] Instance: AppRationals Q. Proof. repeat (split; try apply _). intros; assumption. intros; assumption. intros; assumption. intros; assumption. - intros. apply Qball_0. assumption. - unfold inject_Q_Q, Datatypes.id. rewrite H. ring_simplify. discriminate. - unfold inject_Q_Q, Datatypes.id. rewrite H. ring_simplify. discriminate. - unfold inject_Q_Q, Datatypes.id. unfold app_inverse, inverse_Q_Q. pose proof (Q_approx_correct x (Qdlog2 (` ε))) as [H _]. refine (Qle_trans _ _ _ _ H). apply Qopp_le_compat. apply (Qpos_dlog2_spec ε). - unfold inject_Q_Q, Datatypes.id. unfold app_inverse, inverse_Q_Q. pose proof (Q_approx_correct x (Qdlog2 (` ε))) as [_ H]. apply (Qle_trans _ _ _ H). apply (Qpos_dlog2_spec ε). - intros. apply Q_approx_correct. - intros. apply Q_approx_correct. - apply Q_approx_correct. - apply Q_approx_correct. Qed. Notation ARQ := (AR (AQ:=Q)). corn-8.20.0/reals/faster/ARSpeedTests.v000066400000000000000000000006061473720167500176470ustar00rootroot00000000000000Require Import CoRN.model.totalorder.QposMinMax CoRN.metric2.Metric CoRN.metric2.Complete CoRN.reals.faster.ARexp CoRN.reals.faster.ARbigD. (* Resolve type classes *) Definition AQexpBigD : bigD -> msp_car ARbigD := AQexp. (* Some time measures on a 5000 bogomips CPU *) Time Eval vm_compute in (approximate (AQexpBigD (cast _ _ 300%Z)) (Qpos2QposInf (1#1))). (* 0.1 secs *) corn-8.20.0/reals/faster/ARabs.v000066400000000000000000000116541473720167500163360ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Qabs. Require Import CoRN.model.metric2.Qmetric CoRN.model.totalorder.QposMinMax CoRN.model.totalorder.QMinMax CoRN.reals.fast.CRabs CoRN.reals.faster.ARArith. (** Absolute Value *) Section ARabs. Context `{AppRationals AQ}. Definition AQabs : AQ -> AQ := fun q => proj1_sig (abs_sig q). Lemma aq_abs : forall q:AQ, '(proj1_sig (abs_sig q)) == Qabs ('q). Proof. intro q. destruct (abs_sig q). unfold proj1_sig. destruct a. destruct aq_ring_morphism. destruct aq_order_embed. destruct semiringmor_plus_mor. destruct monmor_sgmor. destruct sgmor_setmor. assert (AQtoQ 0 == 0) by (apply rings.preserves_0). destruct (Qlt_le_dec ('q) 0). - rewrite Qabs_neg. rewrite <- aq_opp. apply sm_proper, H6. apply order_embedding_reflecting. rewrite H7. apply Qlt_le_weak, q0. apply Qlt_le_weak, q0. - rewrite Qabs_pos. 2: exact q0. apply sm_proper, H5. apply order_embedding_reflecting. rewrite H7. exact q0. Qed. Lemma AQabs_triangle_reverse : forall a b : AQ, Qabs (' AQabs a - ' AQabs b) <= Qabs ('a - 'b). Proof. intros a b. unfold AQabs. rewrite aq_abs, aq_abs. apply Qabs_case. - intros _. apply Qabs_triangle_reverse. - intros. apply (Qle_trans _ (Qabs ('b) - Qabs ('a))). ring_simplify; apply Qle_refl. rewrite <- (Qabs_opp (' a - ' b)). setoid_replace (- (' a - ' b))%Q with (' b - ' a)%Q. apply Qabs_triangle_reverse. unfold equiv, stdlib_rationals.Q_eq. ring. Qed. Lemma AQabs_uc_prf : is_UniformlyContinuousFunction (AQabs : AQ_as_MetricSpace -> AQ_as_MetricSpace) Qpos2QposInf. Proof. intros d a b Hab. simpl in Hab. unfold Qball in Hab. rewrite <- AbsSmall_Qabs in Hab. simpl. unfold Qball. rewrite <- AbsSmall_Qabs. exact (Qle_trans _ _ _ (AQabs_triangle_reverse _ _) Hab). Qed. Local Open Scope uc_scope. Definition AQabs_uc : AQ_as_MetricSpace --> AQ_as_MetricSpace := Build_UniformlyContinuousFunction AQabs_uc_prf. Definition ARabs : AR --> AR := Cmap AQPrelengthSpace AQabs_uc. (* The approximations of the absolute value are what we expect. *) Lemma ARabs_approx : forall (e:Qpos) (x:AR), approximate (ARabs x) e = AQabs (approximate x e). Proof. reflexivity. Qed. Lemma ARtoCR_preserves_abs : forall x : AR, cast AR CR (ARabs x) = CRabs (cast AR CR x). Proof. intro x. unfold cast, ARtoCR, ARtoCR_uc. unfold MetricMorphisms.Eembed. unfold ARabs, CRabs. rewrite <- (fast_MonadLaw2 AQPrelengthSpace (MetricMorphisms.EPrelengthSpace QPrelengthSpace (cast AQ Q_as_MetricSpace)) (MetricMorphisms.metric_embed_uc (cast AQ Q_as_MetricSpace)) AQabs_uc). rewrite <- (fast_MonadLaw2 (MetricMorphisms.EPrelengthSpace QPrelengthSpace (cast AQ Q_as_MetricSpace)) QPrelengthSpace Qabs_uc (MetricMorphisms.metric_embed_uc (cast AQ Q_as_MetricSpace)) x). apply Cmap_wd. 2: reflexivity. apply ucEq_equiv. intro d. simpl. apply Qball_0, aq_abs. Qed. Lemma ARabs_AbsSmall : forall a b : AR, ARle (ARabs b) a <-> (ARle (-a) b /\ ARle b a). Proof. intros a b. pose proof CRabs_AbsSmall. split. - intro H6. assert ((CRabs (cast AR CR b) <= (cast AR CR a))%CR). { apply ARtoCR_preserves_le in H6. rewrite ARtoCR_preserves_abs in H6. exact H6. } specialize (H5 ('a) ('b)) as [H5 _]. specialize (H5 H7). split; apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_opp. apply H5. apply H5. - intros [H6 H7]. apply (ARtoCR_preserves_le (-a) b) in H6. apply (ARtoCR_preserves_le b a) in H7. specialize (H5 ('a) ('b)) as [_ H5]. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_abs. apply H5. split. rewrite <- ARtoCR_preserves_opp. exact H6. exact H7. Qed. Lemma ARle_abs : forall x:AR, ARle x (ARabs x). Proof. intro x. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_abs. apply CRle_abs. Qed. Lemma ARabs_opp : forall x:AR, ARabs (-x) = ARabs x. Proof. intro x. apply (injective ARtoCR). pose proof (ARtoCR_preserves_abs (-x)). unfold cast in H5. rewrite H5. clear H5. pose proof (ARtoCR_preserves_abs x). unfold cast in H5. rewrite H5. rewrite (ARtoCR_preserves_opp x). apply CRabs_opp. Qed. Lemma ARabs_pos : forall x:AR, ARle 0 x -> ARabs x = x. Proof. intros x xpos. apply (injective ARtoCR). pose proof (ARtoCR_preserves_abs x). unfold cast in H5. rewrite H5. clear H5. apply CRabs_pos. rewrite <- ARtoCR_preserves_0. apply (ARtoCR_preserves_le AR0 x), xpos. Qed. Lemma ARabs_neg : forall x:AR, ARle x 0 -> ARabs x = -x. Proof. intros x xneg. apply (injective ARtoCR). pose proof (ARtoCR_preserves_abs x). unfold cast in H5. rewrite H5. clear H5. rewrite CRabs_neg. symmetry. apply ARtoCR_preserves_opp. rewrite <- ARtoCR_preserves_0. apply (ARtoCR_preserves_le x AR0), xneg. Qed. End ARabs. corn-8.20.0/reals/faster/ARarctan.v000066400000000000000000000135361473720167500170420ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid CoRN.metric2.Metric CoRN.metric2.UniformContinuity CoRN.metric2.MetricMorphisms CoRN.reals.fast.CRarctan_small CoRN.reals.fast.CRarctan CoRN.reals.fast.CRpi_fast CoRN.reals.faster.ARpi CoRN.reals.faster.ARarctan_small. Require Export CoRN.reals.faster.ARArith. Section ARarctan. Context `{AppRationals AQ}. Lemma AQarctan_big_pos_prf (a : AQ) : 1 < a → 0 < a. Proof. intros. apply (orders.le_lt_trans _ 1). 2: exact H5. apply semirings.le_0_1. Qed. Lemma AQarctan_big_prf (a : AQ) : 1 < a → -a < 1 < a. Proof. split. 2: exact H5. transitivity 0. 2: apply semirings.lt_0_1. rewrite <- rings.negate_0. apply (rings.flip_lt_negate 0 a). transitivity 1. 2: exact H5. apply semirings.lt_0_1. Qed. Definition AQarctan_big_pos {a : AQ} (Pa : 1 < a) : msp_car AR := AQpi (1 ≪ (-1)) - AQarctan_small (AQarctan_big_prf a Pa) (AQarctan_big_pos_prf a Pa). Lemma AQarctan_big_pos_correct {a : AQ} `(Pa : 1 < a) : 'AQarctan_big_pos Pa = rational_arctan ('a). Proof. unfold AQarctan_big_pos. rewrite rings.preserves_minus. rewrite ARtoCR_preserves_AQpi. rewrite aq_shift_opp_1, rings.preserves_1. transitivity (r_pi (1 / 2)%mc - rational_arctan (/ ' a)). apply ucFun2_wd. reflexivity. rewrite AQarctan_small_correct. rewrite rational_arctan_small_correct. rewrite rational_arctan_correct. apply Cmap_wd. reflexivity. apply CRIR.IRasCR_wd, InvTrigonom.ArcTan_wd, Q_in_CReals.inj_Q_wd. now rewrite rings.preserves_1, rings.mult_1_l. apply rational_arctan_half_pi. transitivity (1:Q). now apply (semirings.lt_0_1 (R:=Q)). now apply semirings.preserves_gt_1. Qed. Lemma AQarctan_mid_prf (a : AQ) : 0 < a → -(a+1) < a-1 < a+1. Proof. split. - rewrite rings.negate_plus_distr. apply (strictly_order_preserving (+ _)). now apply rings.between_pos. - apply (strictly_order_preserving (_ +)). apply rings.between_pos. apply semirings.lt_0_1. Qed. Program Definition AQarctan_mid_pos {a : AQ} (Ha : 0 < a) : msp_car AR := AQpi (1 ≪ (-2)) + AQarctan_small (AQarctan_mid_prf a Ha) _. Next Obligation. transitivity (0+1). rewrite rings.plus_0_l. apply semirings.lt_0_1. apply (strictly_order_preserving (+ _)), Ha. Qed. Lemma AQarctan_mid_pos_correct {a : AQ} `(Pa : 0 < a) : 'AQarctan_mid_pos Pa = rational_arctan ('a). Proof. unfold AQarctan_mid_pos. rewrite rings.preserves_plus. rewrite ARtoCR_preserves_AQpi. transitivity (r_pi (' (1 ≪ (-2))) + rational_arctan (('a - 1) / ('a + 1) : Q)). apply ucFun2_wd. reflexivity. rewrite AQarctan_small_correct. rewrite rational_arctan_small_correct. rewrite rational_arctan_correct. apply CRIR.IRasCR_wd, InvTrigonom.ArcTan_wd, Q_in_CReals.inj_Q_wd. mc_setoid_replace ('(a - 1) / '(a + 1) : Q) with (('a - 1) / ('a + 1) : Q). reflexivity. rewrite rings.preserves_minus, rings.preserves_plus. now rewrite rings.preserves_1. rewrite aq_shift_opp_2, rings.preserves_1. apply rational_arctan_fourth_pi. now apply semirings.preserves_pos. Qed. Lemma AQarctan_pos_prf1 {a : AQ} : 0 ≤ a → a ≤ 1 ≪ (-1) → -1 < a < 1. Proof. split. - apply (orders.lt_le_trans _ 0). 2: exact H5. rewrite <- rings.negate_0. apply (rings.flip_lt_negate 0 1). apply semirings.lt_0_1. - apply orders.le_lt_trans with (1 ≪ (-1)); [easy |]. apply (strictly_order_reflecting (cast AQ Q)). rewrite aq_shift_opp_1, rings.preserves_1. split; easy. Qed. Lemma AQarctan_pos_prf2 {a : AQ} : ¬a ≤ 1 ≪ (-1) → 0 < a. Proof. intros. apply orders.lt_le_trans with (1 ≪ (-1)). apply (strictly_order_reflecting (cast AQ Q)). rewrite aq_shift_opp_1, rings.preserves_0, rings.preserves_1. split; easy. now apply orders.le_flip. Qed. Lemma AQarctan_pos_prf3 {a : AQ} : ¬a ≤ 2 → 1 < a. Proof. intros. apply orders.lt_le_trans with 2. apply semirings.lt_1_2. now apply orders.le_flip. Qed. Definition AQarctan_pos {a : AQ} (Pa1 : 0 ≤ a) : msp_car AR := match decide_rel (≤) a (1 ≪ (-1)) with | left Pa2 => AQarctan_small (AQarctan_pos_prf1 Pa1 Pa2) semirings.lt_0_1 | right Pa2 => match decide_rel (≤) a 2 with | left Pa3 => AQarctan_mid_pos (AQarctan_pos_prf2 Pa2) | right Pa3 => AQarctan_big_pos (AQarctan_pos_prf3 Pa3) end end. Lemma AQarctan_pos_correct {a : AQ} `(Pa : 0 ≤ a) : 'AQarctan_pos Pa = rational_arctan ('a). Proof. unfold AQarctan_pos. case (decide_rel _); intros. rewrite AQarctan_small_correct. rewrite rational_arctan_small_correct. rewrite rational_arctan_correct. apply CRIR.IRasCR_wd, InvTrigonom.ArcTan_wd, Q_in_CReals.inj_Q_wd. mc_setoid_replace (('a / '1)%mc : Q) with ('a). reflexivity. rewrite rings.preserves_1. rewrite dec_fields.dec_recip_1. now apply rings.mult_1_r. case (decide_rel _); intros. apply AQarctan_mid_pos_correct. apply AQarctan_big_pos_correct. Qed. Lemma AQarctan_prf {a : AQ} : ¬0 ≤ a → 0 ≤ - a. Proof. intros. apply rings.flip_nonpos_negate. now apply orders.le_flip. Qed. Definition AQarctan (a : AQ) : msp_car AR := match decide_rel (≤) 0 a with | left Pa => AQarctan_pos Pa | right Pa => -AQarctan_pos (AQarctan_prf Pa) end. Lemma AQarctan_correct (a : AQ) : 'AQarctan a = rational_arctan ('a). Proof. unfold AQarctan. case (decide_rel _); intros. apply AQarctan_pos_correct. rewrite rings.preserves_negate. rewrite AQarctan_pos_correct. rewrite rings.preserves_negate. apply rational_arctan_opp. Qed. Definition ARarctan_uc := unary_complete_uc Qmetric.QPrelengthSpace (cast AQ (msp_car Qmetric.Q_as_MetricSpace)) AQarctan arctan_uc AQarctan_correct. Definition ARarctan := Cbind AQPrelengthSpace ARarctan_uc. Lemma ARtoCR_preserves_arctan x : ' ucFun ARarctan x = ucFun arctan ('x). Proof. apply preserves_unary_complete_fun. Qed. End ARarctan. corn-8.20.0/reals/faster/ARarctan_small.v000066400000000000000000000141231473720167500202230ustar00rootroot00000000000000Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.nat_pow MathClasses.theory.int_pow CoRN.algebra.RSetoid CoRN.stdlib_omissions.Q CoRN.metric2.Metric CoRN.metric2.UniformContinuity CoRN.reals.fast.CRarctan_small CoRN.reals.fast.CRarctan CoRN.reals.fast.CRstreams CoRN.reals.fast.CRAlternatingSum CoRN.reals.faster.ARAlternatingSum CoRN.reals.faster.ARsin. Require Export CoRN.reals.faster.ARArith. Section ARarctan_small. Context `{AppRationals AQ} {num den : AQ} (Pnd : -den < num < den) (dpos : 0 < den). (* Split the stream (-1)^i a^(2i+1) / (2i+1) up into the streams (-1)^i a^(2i+1) and (2i+1) because we do not have exact division *) Definition ARarctanStream (px : positive*(AQ*AQ)) : AQ*AQ := (- fst (snd px) * num * num * ZtoAQ (Zpos (Pos.pred (fst px)~0)), snd (snd px) * den * den * ZtoAQ (Zpos (fst px)~1)). Lemma arctanStream_pos : ∀ x : positive * (AQ * AQ), 0 < snd (snd x) → 0 < snd (ARarctanStream x). Proof. assert (0 = ZtoAQ 0) as zero_int. { destruct H4. destruct aq_ints_mor, semiringmor_plus_mor. rewrite preserves_mon_unit. reflexivity. } intros. destruct x; simpl. simpl in H5. apply AQmult_lt_0_compat. apply AQmult_lt_0_compat. apply AQmult_lt_0_compat. exact H5. exact dpos. exact dpos. rewrite zero_int. apply (strictly_order_preserving (cast Z AQ)). reflexivity. Qed. Lemma arctanStream_correct : ∀ p : positive, Str_pth _ (arctanStream (AQtoQ num / AQtoQ den)) p (1%positive, AQtoQ num / AQtoQ den) == let (_, r) := iterate _ (fS ARarctanStream) p (1%positive, (num, den)) in AQtoQ (fst r) / AQtoQ (snd r). Proof. assert (forall n:Z, AQtoQ (ZtoAQ n) == (n#1)). { intro n. destruct n as [|n|n]. pose proof (rings.preserves_0 (f:=cast Z AQ)). rewrite H5. clear H5. rewrite rings.preserves_0. reflexivity. apply ZtoQ. change (Z.neg n) with (-Z.pos n)%Z. pose proof (rings.preserves_negate (f:=cast Z AQ)). rewrite H5. clear H5. rewrite rings.preserves_negate. rewrite ZtoQ. reflexivity. } apply Pos.peano_ind. - unfold Str_pth, iterate, arctanStream, snd. rewrite Qred_correct. simpl. do 6 rewrite rings.preserves_mult. rewrite rings.preserves_negate. rewrite H5, H5. unfold dec_recip, stdlib_rationals.Q_recip. unfold mult, stdlib_rationals.Q_mult. unfold negate, stdlib_rationals.Q_opp. rewrite Qmult_1_r. change (1#3) with (/3)%Q. unfold Qdiv. do 3 rewrite Qinv_mult_distr. do 3 rewrite Qmult_assoc. apply Qmult_comp. 2: reflexivity. do 2 rewrite Qmult_assoc. apply Qmult_comp. 2: reflexivity. ring. - intros p IHp. unfold Str_pth. unfold Str_pth in IHp. rewrite iterate_succ, iterate_succ. pose proof (arctanStream_fst (AQtoQ num / AQtoQ den) p) as H7. unfold dec_recip, stdlib_rationals.Q_recip. unfold dec_recip, stdlib_rationals.Q_recip in IHp. unfold mult, stdlib_rationals.Q_mult. unfold mult, stdlib_rationals.Q_mult in IHp. unfold Qdiv in H7. unfold Qdiv. unfold Qdiv in IHp. unfold Q_as_MetricSpace, msp_car. unfold Q_as_MetricSpace, msp_car in IHp. destruct (iterate _ (arctanStream (AQtoQ num * / AQtoQ den)%Q) p (1%positive, (AQtoQ num * / AQtoQ den)%Q)). simpl in H7. simpl in IHp. subst p0. unfold arctanStream, snd, fst. rewrite Qred_correct. rewrite IHp. clear IHp. pose proof (fS_fst ARarctanStream p (num, den)) as H6. destruct (iterate _ (fS ARarctanStream) p (1%positive, (num, den))) as [p0 p1]. simpl in H6. subst p0. unfold ARarctanStream, fS. simpl (fst (Pos.succ p, p1)). simpl (snd (Pos.succ p, p1)). replace (Pos.pred (Pos.succ p)~0) with (p~1)%positive. do 6 rewrite rings.preserves_mult. rewrite rings.preserves_negate. unfold mult, stdlib_rationals.Q_mult. unfold negate, stdlib_rationals.Q_opp. rewrite ZtoQ, ZtoQ. do 3 rewrite Qinv_mult_distr. setoid_replace (Z.pos p~1 # 2 + p~1)%Q with ((Z.pos p~1 # 1) * / (Z.pos (Pos.succ p)~1 # 1))%Q. ring. unfold Qinv, Qeq, Qmult, Qnum, Qden. rewrite Pos.mul_1_l, Z.mul_1_r. replace (2 + p~1)%positive with ((Pos.succ p)~1)%positive. reflexivity. change (p~1)%positive with (2*p+1)%positive. change ((Pos.succ p)~1)%positive with (2*Pos.succ p+1)%positive. rewrite Pplus_one_succ_l. rewrite Pos.mul_add_distr_l. reflexivity. rewrite Pplus_one_succ_l. change (p~1)%positive with (2*p+1)%positive. change ((1+p)~0)%positive with (2*(1+p))%positive. rewrite Pos.mul_add_distr_l. rewrite Pos.pred_sub. rewrite (Pos.add_comm (2*1)). rewrite <- Pos.add_sub_assoc. reflexivity. reflexivity. Qed. Lemma AQarctan_small_Qprf : -1 < AQtoQ num / AQtoQ den < 1. Proof. split. - apply Qlt_shift_div_l. pose proof (rings.preserves_0 (f:=cast AQ Q)). rewrite <- H5. apply (strictly_order_preserving (cast AQ Q)), dpos. setoid_replace (-1 * AQtoQ den) with (-AQtoQ den) by reflexivity. rewrite <- rings.preserves_negate. apply (strictly_order_preserving (cast AQ Q)), Pnd. - apply Qlt_shift_div_r. pose proof (rings.preserves_0 (f:=cast AQ Q)). rewrite <- H5. apply (strictly_order_preserving (cast AQ Q)), dpos. rewrite Qmult_1_l. apply (strictly_order_preserving (cast AQ Q)), Pnd. Qed. Definition AQarctan_small : msp_car AR := CRtoAR (inject_Q_CR (AQtoQ num / AQtoQ den)) + AltSeries ARarctanStream arctanStream_pos positive (arctanStream (AQtoQ num / AQtoQ den)) (num,den) (xH,AQtoQ num / AQtoQ den) arctanStream_correct _ (arctanStream_alt (widen_interval AQarctan_small_Qprf)) dpos (arctanStream_zl (widen_interval AQarctan_small_Qprf)). Lemma AQarctan_small_correct : 'AQarctan_small = rational_arctan_small (widen_interval AQarctan_small_Qprf). Proof. unfold AQarctan_small, rational_arctan_small. rewrite ARtoCR_preserves_plus. apply ucFun2_wd. pose proof CRAR_id. unfold cast. unfold cast in H5. rewrite H5. reflexivity. apply AltSeries_correct. Qed. End ARarctan_small. corn-8.20.0/reals/faster/ARbigD.v000066400000000000000000000244131473720167500164330ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Program QArith ZArith. Require Import Bignums.BigZ.BigZ CoRN.model.totalorder.QposMinMax CoRN.metric2.MetricMorphisms CoRN.model.metric2.Qmetric CoRN.util.Qdlog CoRN.reals.faster.ARArith MathClasses.theory.int_pow MathClasses.theory.nat_pow MathClasses.interfaces.rationals MathClasses.implementations.stdlib_rationals MathClasses.interfaces.integers MathClasses.implementations.stdlib_binary_integers MathClasses.implementations.fast_integers MathClasses.implementations.dyadics. Add Field Q : (dec_fields.stdlib_field_theory Q). Notation bigD := (Dyadic bigZ). #[global] Instance inject_bigZ_Q: Cast bigZ Q_as_MetricSpace := inject_Z ∘ BigZ.to_Z. #[global] Instance inject_Z_bigD: Cast Z bigD := dy_inject ∘ BigZ.of_Z. #[global] Instance inject_N_bigZ: Cast N bigZ := BigZ.of_Z ∘ Z_of_N. #[global] Instance inject_bigD_Q: Cast bigD Q_as_MetricSpace := DtoQ inject_bigZ_Q. (* these casts ^^ are semiring (and thus setoid) morphims *) #[global] Instance: SemiRing_Morphism inject_bigZ_Q. Proof. unfold inject_bigZ_Q. apply _. Qed. #[global] Instance: SemiRing_Morphism inject_Z_bigD. Proof. unfold inject_Z_bigD. apply _. Qed. #[global] Instance: SemiRing_Morphism inject_N_bigZ. Proof. unfold inject_N_bigZ. apply _. Qed. #[global] Instance: SemiRing_Morphism inject_bigD_Q. Proof. unfold inject_bigD_Q. apply _. Qed. Lemma inject_bigD_Q_correct : forall x : bigD, cast bigD Q x = 'mant x * 2 ^ (cast bigZ Z (expo x)). Proof. intro x. unfold cast at 1, inject_bigD_Q. unfold inject_bigZ_Q. rewrite (DtoQ_correct _ _ (reflexivity x)). unfold DtoQ_slow. now rewrite (preserves_int_pow_exp (f:=cast bigZ Z)). Qed. (* We use BigZ.div and BigZ.shiftl because we don't have any theory on euclid and shiftr in math-classes yet. Moreover, BigZ.shiftl behaves as shiftr on its negative domain, which is quite convenient here. *) #[global] Program Instance bigD_div: AppDiv bigD := λ x y k, BigZ.div (BigZ.shiftl (mant x) (-('k - 1) + expo x - expo y)) (mant y) ▼ ('k - 1). Lemma Qdiv_bounded_Zdiv (x y : Z) : 'Z.div x y ≤ ('x / 'y : Q) < 'Z.div x y + 1. Proof. rewrite Qround.Zdiv_Qdiv. split. now apply Qround.Qfloor_le. rewrite <-(rings.preserves_1 (f:=cast Z Q)). rewrite <-rings.preserves_plus. now apply Qround.Qlt_floor. Qed. Lemma Qpow_bounded_Zshiftl (x n : Z) : 'Z.shiftl x n ≤ cast Z Q x * 2 ^ n < 'Z.shiftl x n + 1. Proof. destruct (total (≤) 0 n) as [En | En]. rewrite Z.shiftl_mul_pow2 by trivial. rewrite inject_Z_mult. rewrite Qpower.Zpower_Qpower by trivial. split; try reflexivity. apply semirings.pos_plus_lt_compat_r. now apply (semirings.lt_0_1 (R:=Q)). rewrite Z.shiftl_div_pow2 by trivial. assert (('x * 2 ^ n : Q) = 'x / 'Zpower 2 (-n)). rewrite Qpower.Zpower_Qpower. rewrite <-Qpower.Qpower_opp, Z.opp_involutive. reflexivity. now apply rings.flip_nonpos_negate in En. split. transitivity ('x / 'Zpower 2 (-n) : Q). now apply Qdiv_bounded_Zdiv. apply orders.eq_le. now symmetry. apply orders.le_lt_trans with ('x / 'Zpower 2 (-n) : Q). now apply orders.eq_le. now apply Qdiv_bounded_Zdiv. Qed. Lemma bigD_div_correct (x y : bigD) (k : Z) : Qball (2 ^ k) ('app_div x y k) ('x / 'y). Proof. assert (∀ xm xe ym ye : Z, (('xm * 2 ^ xe)%mc : Q) / (('ym * 2 ^ ye)%mc : Q) = ('xm * 2 ^ (-(k - 1) + xe - ye)) / 'ym * 2 ^ (k - 1)) as E1. intros. rewrite 2!int_pow_exp_plus by solve_propholds. rewrite dec_fields.dec_recip_distr. rewrite 2!int_pow_negate. transitivity (('xm / 'ym * 2 ^ xe / 2 ^ ye * (2 ^ (k - 1) / 2 ^ (k - 1)))%mc : Q); [| ring]. rewrite dec_recip_inverse by solve_propholds. ring. assert (∀ xm xe ym ye : Z, 'Z.div (Z.shiftl xm (-(k - 1) + xe - ye)) ym * 2 ^ (k - 1) - 2 ^ k ≤ ('xm * 2 ^ xe) / ('ym * 2 ^ ye : Q)) as Pleft. clear x y. assert (∀ z : Q, z * 2 ^ (k - 1) - 2 ^ k = ((z - 1) - 1) * 2 ^ (k - 1)) as E2. intros. mc_setoid_replace k with ((k - 1) + 1) at 2 by ring. rewrite (int_pow_exp_plus (k - 1)) by solve_propholds. ring_simplify. apply sm_proper. now rewrite commutativity. intros. rewrite E1, E2. apply (order_preserving (.* _)). apply rings.flip_le_minus_l. apply semirings.plus_le_compat_r; [easy |]. transitivity (('Z.shiftl xm (-(k - 1) + xe - ye) / 'ym - 1)%mc : Q). apply (order_preserving (+ -1)). now apply Qdiv_bounded_Zdiv. destruct (orders.le_or_lt 0 ym) as [E | E]. apply rings.flip_le_minus_l. apply semirings.plus_le_compat_r; [easy |]. apply (maps.order_preserving_flip_nonneg (.*.) (/ 'ym : Q)). apply dec_fields.nonneg_dec_recip_compat. now apply semirings.preserves_nonneg. now apply Qpow_bounded_Zshiftl. transitivity ((('Z.shiftl xm (-(k - 1) + xe - ye) + 1) / 'ym)%mc : Q). rewrite rings.plus_mult_distr_r. apply semirings.plus_le_compat; [reflexivity |]. rewrite rings.mult_1_l. apply rings.flip_le_negate. rewrite rings.negate_involutive, dec_fields.dec_recip_negate. apply dec_fields.flip_le_dec_recip_l; [solve_propholds |]. rewrite <-rings.preserves_negate. apply semirings.preserves_ge_1. apply rings.flip_le_negate. rewrite rings.negate_involutive. now apply nat_int.le_iff_lt_plus_1. apply semirings.flip_nonpos_mult_r. apply dec_fields.nonpos_dec_recip_compat. apply semirings.preserves_nonpos. now apply orders.lt_le. now apply orders.lt_le, Qpow_bounded_Zshiftl. assert (∀ xm xe ym ye : Z, ('xm * 2 ^ xe) / ('ym * 2 ^ ye : Q) ≤ '(Z.div (Z.shiftl xm (-(k - 1) + xe - ye)) ym) * 2 ^ (k - 1) + 2 ^ k) as Pright. clear x y. assert (∀ z : Q, z * 2 ^ (k - 1) + 2 ^ k = ((z + 1) + 1) * 2 ^ (k - 1)) as E2. intros. mc_setoid_replace k with ((k - 1) + 1) at 2 by ring. rewrite (int_pow_exp_plus (k - 1)) by solve_propholds. ring_simplify. apply sm_proper. now apply commutativity. intros. rewrite E1, E2. apply (order_preserving (.* _)). transitivity (('Z.shiftl xm (-(k - 1) + xe - ye) / 'ym + 1)%mc : Q). 2: now apply (order_preserving (+1)); apply orders.lt_le, Qdiv_bounded_Zdiv. destruct (orders.le_or_lt ym 0) as [E3 | E3]. apply semirings.plus_le_compat_r; [easy |]. apply semirings.flip_nonpos_mult_r. apply dec_fields.nonpos_dec_recip_compat. now apply semirings.preserves_nonpos. now apply Qpow_bounded_Zshiftl. transitivity ((('Z.shiftl xm (-(k - 1) + xe - ye) + 1) / ' ym)%mc : Q). apply (maps.order_preserving_flip_nonneg (.*.) ((/ 'ym)%mc : Q)). apply dec_fields.nonneg_dec_recip_compat. apply semirings.preserves_nonneg. now apply orders.lt_le. now apply orders.lt_le, Qpow_bounded_Zshiftl. rewrite rings.plus_mult_distr_r. apply semirings.plus_le_compat; [reflexivity |]. rewrite rings.mult_1_l. apply dec_fields.flip_le_dec_recip_l; [solve_propholds |]. apply semirings.preserves_ge_1. now apply nat_int.lt_iff_plus_1_le in E3. unfold cast. rewrite 3!inject_bigD_Q_correct. destruct x as [xm xe], y as [ym ye]. simpl. unfold cast, inject_bigZ_Q, cast, "∘". simpl. BigZ.zify. apply in_Qball. split. apply Pleft. apply Pright. Qed. #[global] Instance inverse_Q_bigD: AppInverse inject_bigD_Q := λ x ε, app_div ('Qnum x) ('(Zpos (Qden x))) (Qdlog2 (proj1_sig ε)). #[global] Instance bigD_approx : AppApprox bigD := λ x k, BigZ.shiftl (mant x) (-('k - 1) + expo x) ▼ ('k - 1). Lemma bigD_approx_correct (x : bigD) (k : Z) : Qball (2 ^ k) ('app_approx x k) ('x). Proof. setoid_replace (app_approx x k) with (app_div x 1 k). setoid_replace ('x : Q) with (('x / '1)%mc : Q). now apply bigD_div_correct. rewrite rings.preserves_1, dec_fields.dec_recip_1. now rewrite rings.mult_1_r. unfold app_div, bigD_div. simpl. rewrite BigZ.div_1_r. setoid_replace (-('k - 1) + expo x - 0) with (-('k - 1) + expo x); [reflexivity |]. now rewrite rings.negate_0, rings.plus_0_r. Qed. #[global] Instance: DenseEmbedding inject_bigD_Q. Proof. split; try apply _. - assert (@Injective bigD Q_as_MetricSpace _ Qeq inject_bigD_Q). { apply _. } destruct H. split. intros. apply Qball_0 in H. apply injective, H. split. apply _. apply _. intros x y xyeq. apply Qball_0. destruct injective_mor. apply sm_proper, xyeq. - intros [n d] ε. unfold app_inverse, inverse_Q_bigD. apply ball_weak_le with (proj1_sig (Qpos_power 2 (Qdlog2 (proj1_sig ε)))). now apply (Qpos_dlog2_spec ε). simpl. rewrite (Qmake_Qdiv n d). rewrite 2!(integers.to_ring_unique_alt inject_Z (inject_bigD_Q ∘ dy_inject ∘ BigZ.of_Z)). apply bigD_div_correct. Qed. #[global] Instance bigD_Zshiftl: ShiftL bigD Z := λ x n, x ≪ 'n. #[global] Instance: Proper ((=) ==> (=) ==> (=)) bigD_Zshiftl. Proof. unfold bigD_Zshiftl. solve_proper. Qed. #[global] Instance: ShiftLSpec bigD Z bigD_Zshiftl. Proof. split; try apply _; unfold shiftl, bigD_Zshiftl. intros x. rewrite rings.preserves_0. now apply shiftl_0. intros x n. rewrite rings.preserves_plus. now apply shiftl_S. Qed. (* This function is more or less a copy of dy_pow, but uses [N] instead of [BigZ⁺] for the exponent. An alternative definition would have been bigD_Npow x n = dy_pow x (N_to_BigZ_NonNeg n). However, then the exponent would be translated from [N] into [BigZ] and back again, due to the definition of [BigZ.pow]. *) #[global] Instance bigD_Npow: Pow bigD N := λ x n, (mant x) ^ n ▼ 'n * expo x. #[global] Instance: NatPowSpec bigD N bigD_Npow. Proof. split; unfold "^", bigD_Npow, equiv, dy_equiv, DtoQ_slow. intros [xm xe] [ym ye] E1 e1 e2 E2. simpl in *. rewrite E2. clear e1 E2. rewrite 2!(preserves_nat_pow (f:=integers.integers_to_ring bigZ Q)). rewrite 2!(commutativity ('e2 : bigZ)). rewrite 2!int_pow_exp_mult. rewrite 2!(int_pow_nat_pow (f:=cast N bigZ)). rewrite <-2!nat_pow_base_mult. now rewrite E1. intros [xm xe]. simpl. rewrite rings.preserves_0, left_absorb. now rewrite nat_pow_0. intros [xm xe] n. simpl. rewrite nat_pow_S. rewrite rings.preserves_plus, rings.preserves_1. now rewrite distribute_r, left_identity. Qed. #[global] Instance bigD_appRat : AppRationals bigD. Proof. split; try apply _; intros. split; apply _. now apply bigD_div_correct. now apply bigD_approx_correct. Qed. Notation ARbigD := (AR (AQ:=bigD)). corn-8.20.0/reals/faster/ARbigQ.v000066400000000000000000000072131473720167500164470ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Program QArith ZArith. Require Import Bignums.BigZ.BigZ Bignums.BigQ.BigQ CoRN.reals.fast.Compress CoRN.reals.faster.ARQ CoRN.metric2.MetricMorphisms CoRN.model.metric2.Qmetric CoRN.reals.faster.ARArith MathClasses.implementations.stdlib_rationals MathClasses.implementations.stdlib_binary_integers MathClasses.implementations.field_of_fractions MathClasses.implementations.fast_rationals MathClasses.implementations.fast_integers. #[global] Instance inject_Z_bigQ: Cast Z bigQ := cast bigZ bigQ ∘ cast Z bigZ. #[global] Instance bigQ_approx: AppApprox bigQ := λ x k, match k with | Zneg p => let k' := BigN.of_N (Npos p) in match x with | BigQ.Qz z => BigQ.Qz z | BigQ.Qq n d => BigQ.Qq (BigZ.div (BigZ.shiftl n (BigZ.Pos k')) (BigZ.Pos d)) (BigN.shiftl 1 k') end | _ => x end. Lemma bigQ_approx_Q_approx (x : bigQ) (k : Z) : 'app_approx x k = app_approx ('x) k. Proof. unfold app_approx, Q_approx, approximateQ, bigQ_approx. destruct k as [|p|]; try reflexivity. destruct x as [n|n d]; simpl. rewrite Z.div_1_r, Qmake_Qdiv. simpl. now rewrite Q.Zmult_Qmult, Qdiv_mult_l by auto with zarith. unfold cast, BigQ_Rationals.inject_QType_Q, BigQ.to_Q. case_eq (BigN.shiftl 1 (BigN.of_pos p) =? BigN.zero)%bigN; intros Ep. apply BigNeqb_correct, BigN.shiftl_eq_0_iff in Ep. discriminate. case_eq (d =? BigN.zero)%bigN; intros Ed. apply BigNeqb_correct in Ed. setoid_replace (BigZ.Pos d) with 0%bigZ by assumption. now rewrite BigZ.spec_div, Zdiv_0_r, Zmult_0_l. rewrite BigZ.spec_div, BigZ.spec_shiftl, Z.shiftl_mul_pow2 by apply BigN.spec_pos. rewrite BigN.spec_shiftl, Z.shiftl_1_l. replace (BigZ.to_Z (BigZ.Pos (BigN.of_pos p))) with (Zpos p) by (symmetry; apply BigN.spec_of_pos). rewrite BigN.spec_of_pos. replace (Z2P (2 ^ Zpos p)) with (2 ^ p)%positive by now rewrite <- Zpower_Ppow. rewrite <-Zpower_Ppow. rewrite Z2P_correct. reflexivity. apply orders.lt_iff_le_ne. split. now apply BigN.spec_pos. intros E. symmetry in E. change (d == BigN.zero)%bigN in E. apply BigN.eqb_eq in E. rewrite E in Ed. discriminate. Qed. Lemma bigQ_approx_correct (x : bigQ) (k : Z) : Qball (2 ^ k) ('app_approx x k) ('x). Proof. rewrite bigQ_approx_Q_approx. now apply Q_approx_correct. Qed. #[global] Instance bigQ_div: AppDiv bigQ := λ x y, app_approx (x / y). Lemma bigQ_div_correct (x y : bigQ) (k : Z) : Qball (2 ^ k) ('app_div x y k) ('x / 'y). Proof. mc_setoid_replace ('x / 'y : Q) with ('(x / y) : Q). now apply bigQ_approx_correct. now rewrite rings.preserves_mult, dec_fields.preserves_dec_recip. Qed. #[global] Instance inverse_Q_bigQ: AppInverse (cast bigQ Q_as_MetricSpace) := λ x ε, 'x. #[global] Instance: DenseEmbedding (cast bigQ Q_as_MetricSpace). Proof. split; try apply _. - Set Printing Implicit. assert ( @Injective bigQ Q_as_MetricSpace BigQ_Rationals.QType_equiv Qeq (@cast bigQ Q_as_MetricSpace BigQ_Rationals.inject_QType_Q)). { apply _. } destruct H. split. intros. apply Qball_0 in H. apply injective, H. split. apply _. apply _. intros x y xyeq. apply Qball_0. destruct injective_mor. apply sm_proper, xyeq. - intros. unfold app_inverse, inverse_Q_bigQ. rewrite (rationals.morphisms_involutive _ _). apply ball_refl. apply QposMinMax.Qpos_nonneg. Qed. #[global] Instance: AppRationals bigQ. Proof. split; try apply _. split; try apply _. intros. now apply bigQ_div_correct. intros. now apply bigQ_approx_correct. Qed. Notation ARbigQ := (AR (AQ:=bigQ)). corn-8.20.0/reals/faster/ARcos.v000066400000000000000000000052001473720167500163430ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require Import CoRN.model.metric2.Qmetric. Require Import MathClasses.misc.workaround_tactics CoRN.reals.fast.CRsin CoRN.reals.fast.CRcos CoRN.metric2.MetricMorphisms CoRN.metric2.Complete CoRN.reals.faster.ARsin MathClasses.interfaces.abstract_algebra. Require Export CoRN.reals.faster.ARArith. (** ** Cosine Cosine is defined in terms of Sine. [cos x = 1 - 2*(sin(x/2))^2]. But cosine is still first defined on the rational numbers, and lifted to the real numbers. *) Section ARcos. Context `{AppRationals AQ}. Local Open Scope uc_scope. Add Field Q : (dec_fields.stdlib_field_theory Q). Definition AQcos_poly_fun (x : AQ) : AQ := 1 - 2 * x ^ (2%mc:N). Lemma AQcos_poly_fun_correct (x : AQ) : 'AQcos_poly_fun x = cos_poly_fun ('x). Proof. unfold AQcos_poly_fun, cos_poly_fun. rewrite nat_pow.nat_pow_2. rewrite rings.preserves_minus, ?rings.preserves_mult. rewrite rings.preserves_1, rings.preserves_2. now rewrite associativity. Qed. Lemma AQcos_poly_uc_correct : forall q : AQ, msp_eq (' AQcos_poly_fun (AQboundAbs_uc 1 q)) (cos_poly_fun (QMinMax.Qmax (- (1)) (QMinMax.Qmin 1 (' q)))). Proof. intro q. apply Qball_0. rewrite AQcos_poly_fun_correct. f_equiv. unfold AQboundAbs_uc. simpl. change ('1) with (1:AQ). rewrite ?aq_preserves_max, ?aq_preserves_min. now rewrite ?rings.preserves_negate, ?rings.preserves_1. Qed. Definition AQcos_poly_uc := unary_uc (cast AQ Q_as_MetricSpace) (λ x : AQ, AQcos_poly_fun (AQboundAbs_uc 1 x)) cos_poly_uc AQcos_poly_uc_correct. Definition ARcos_poly := uc_compose ARcompress (Cmap AQPrelengthSpace AQcos_poly_uc). Lemma ARtoCR_preserves_cos_poly x : 'ARcos_poly x = cos_poly ('x). Proof. change ('ARcompress (Cmap AQPrelengthSpace AQcos_poly_uc x) = cos_poly ('x)). rewrite ARcompress_correct. now apply preserves_unary_fun. Qed. Definition AQcos (x : AQ) : AR := ARcos_poly (AQsin (x ≪ (-1))). Lemma AQcos_correct a : 'AQcos a = rational_cos ('a). Proof. unfold AQcos. rewrite ARtoCR_preserves_cos_poly. posed_rewrite AQsin_correct. rewrite aq_shift_opp_1. now apply rational_cos_sin. Qed. Definition ARcos_uc : AQ_as_MetricSpace --> AR := unary_complete_uc QPrelengthSpace AQtoQ AQcos cos_uc AQcos_correct. Lemma ARcos_uc_eval : forall q : AQ_as_MetricSpace, ARcos_uc q ≡ AQcos q. Proof. reflexivity. Qed. Definition ARcos : AR --> AR := Cbind AQPrelengthSpace ARcos_uc. Lemma ARtoCR_preserves_cos x : 'ARcos x = cos_slow ('x). Proof. apply preserves_unary_complete_fun. Qed. End ARcos. corn-8.20.0/reals/faster/ARexp.v000066400000000000000000000274041473720167500163650ustar00rootroot00000000000000From Coq Require Import ZArith. Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Program. Require Import MathClasses.misc.workaround_tactics CoRN.model.totalorder.QposMinMax CoRN.model.totalorder.QMinMax. From Coq Require Import Qround Qabs. Require Import CoRN.util.Qdlog CoRN.stdlib_omissions.Q CoRN.reals.fast.CRexp CoRN.reals.fast.CRstreams CoRN.reals.fast.CRAlternatingSum CoRN.reals.fast.Compress CoRN.reals.fast.CRpower CoRN.metric2.MetricMorphisms CoRN.reals.faster.ARAlternatingSum MathClasses.interfaces.abstract_algebra MathClasses.orders.minmax MathClasses.theory.nat_pow MathClasses.theory.int_pow. Require Export CoRN.reals.faster.ARArith. Section ARexp. Context `{AppRationals AQ}. Section exp_small_neg. Context {a : AQ} (Pa : -1 ≤ a ≤ 0). (* Split the stream (-a)^i / i! up into the streams (-a)^i and i! because we do not have exact division *) Definition ARexpStream (px : positive*(AQ*AQ)) : AQ*AQ := (fst (snd px) * a, snd (snd px) * ZtoAQ (Zpos (fst px))). Lemma AQexp_small_neg_prf : -1 ≤ ('a : Q) ≤ 0. Proof. split. now apply rings.preserves_ge_negate1. now apply semirings.preserves_nonpos. Qed. (* The ARInfAltSum function computes the infinite alternating sum and takes care of: - Computing the length of the partial sum - Computing the precision of the approximate division *) Lemma expStream_pos : ∀ x : positive * (AQ * AQ), 0 < snd (snd x) → 0 < snd (ARexpStream x). Proof. intros. unfold ARexpStream. simpl. assert (AQtoQ 0 == 0). apply rings.preserves_0. destruct aq_strict_order_embed. apply strict_order_embedding_reflecting. rewrite rings.preserves_mult, rings.preserves_0. apply (Qle_lt_trans _ (AQtoQ (snd (snd x)) * 0)). rewrite Qmult_0_r. apply Qle_refl. apply Qmult_lt_l. rewrite <- H6. apply strict_order_embedding_preserving, H5. pose proof AQtoQ_ZtoAQ. unfold cast in H7. rewrite H7. reflexivity. Qed. Lemma AQ0_lt_1 : 0 < 1. Proof. destruct aq_strict_order_embed. apply strict_order_embedding_reflecting. rewrite rings.preserves_0, rings.preserves_1. reflexivity. Qed. Lemma expStream_correct : ∀ p : positive, Str_pth _ (CRexp.expStream (AQtoQ a)) p (1%positive, 1%Q) == let (_, r) := iterate _ (fS ARexpStream) p (1%positive, (1, 1)) in AQtoQ (fst r) / AQtoQ (snd r). Proof. apply Pos.peano_ind. - unfold Str_pth. simpl. rewrite Qmult_1_l, Qmult_1_r. rewrite rings.mult_1_l, rings.mult_1_l. pose proof (AQtoQ_ZtoAQ 1). unfold cast in H5. rewrite H5. unfold stdlib_rationals.inject_Z_Q, inject_Z. unfold Qdiv. rewrite Qmult_1_r. reflexivity. - intros. unfold Str_pth. rewrite iterate_succ, iterate_succ. unfold Str_pth in H5. pose proof (fS_fst ARexpStream p (1,1)). pose proof (expStream_fst (AQtoQ a) p). destruct (iterate _ (CRexp.expStream (AQtoQ a)) p (1%positive, 1%Q)) as [u v]. destruct (iterate (positive * (AQ * AQ)) (fS ARexpStream) p (1%positive, (1, 1))). unfold snd in H5 at 1. simpl. unfold fst in H6. subst p0. rewrite H5. unfold fst in H7. clear H5 v. subst u. assert (forall i j : AQ, AQtoQ (i*j) == AQtoQ i * AQtoQ j). { intros. rewrite rings.preserves_mult. reflexivity. } rewrite H5, H5. unfold Qdiv. rewrite Qinv_mult_distr. pose proof (AQtoQ_ZtoAQ). unfold cast in H6. rewrite H6. unfold stdlib_rationals.inject_Z_Q, inject_Z. setoid_replace (/ (Z.pos (Pos.succ p) # 1))%Q with (1#Pos.succ p). ring. reflexivity. Qed. Definition AQexp_small_neg : AR := 1+ AltSeries ARexpStream expStream_pos positive (CRexp.expStream (AQtoQ a)) (1,1) (xH,1) expStream_correct _ (expStream_alt AQexp_small_neg_prf) AQ0_lt_1 (expStream_zl AQexp_small_neg_prf). Lemma AQexp_small_neg_correct : 'AQexp_small_neg = rational_exp_small_neg AQexp_small_neg_prf. Proof. unfold AQexp_small_neg, rational_exp_small_neg. rewrite ARtoCR_preserves_plus. rewrite ARtoCR_preserves_1. rewrite <- CRplus_translate. apply ucFun2_wd. reflexivity. apply AltSeries_correct. Qed. End exp_small_neg. (* Implement the range reduction exp(x) = exp(x/2) ^ 2 *) Fixpoint ARpower_2_iter (n : nat) (x : AR) : AR := match n with | O => x | S p => ARpower_N_bounded 2 1 (ARcompress (ARpower_2_iter p x)) end. Lemma ARpower_2_iter_wd : forall (n : nat) (x y : AR), x = y -> ARpower_2_iter n x = ARpower_2_iter n y. Proof. induction n. - intros. exact H5. - intros. simpl. apply Cmap_wd. reflexivity. pose proof ARcompress_correct. simpl in H6. rewrite H6, H6. apply IHn, H5. Qed. Lemma AQexp_neg_bounded_correct : ∀ (n : nat) a (abound : -1 ≤ a * (1 ≪ (-1)) ^ n ≤ 0), a ≤ 0 -> ' ARpower_2_iter n (AQexp_small_neg abound) = rational_exp (' a). Proof. induction n. - intros. simpl. rewrite AQexp_small_neg_correct. rewrite rational_exp_small_neg_correct. rewrite rational_exp_correct. apply CRIR.IRasCR_wd, Exponential.Exp_wd. apply Q_in_CReals.inj_Q_wd. rewrite rings.preserves_mult. unfold pow. simpl. rewrite rings.preserves_1, Qmult_1_r. reflexivity. - intros a abound aneg. change (ARpower_2_iter (S n) (AQexp_small_neg abound)) with (ARpower_N_bounded 2 1 (ARcompress (ARpower_2_iter n (AQexp_small_neg abound)))). rewrite ARcompress_correct. rewrite ARtoCR_preserves_power_N_bounded. assert (-1 ≤ a * (1 ≪ (-1)) * (1 ≪ (-1)) ^ n ≤ 0) as abound_shift. { setoid_replace (a * 1 ≪ (-1) * (1 ≪ (-1)) ^ n ) with (a * (1 ≪ (-1)) ^ S n). exact abound. unfold pow at 2. simpl. rewrite (rings.mult_assoc a). reflexivity. } specialize (IHn _ abound_shift). setoid_replace (' ARpower_2_iter n (AQexp_small_neg abound)) with (' ARpower_2_iter n (AQexp_small_neg abound_shift)). rewrite IHn. clear IHn. transitivity (CRpower_N_bounded 2 (1#1)%Qpos (rational_exp (' (a ≪ (-1))))). + apply Cmap_wd. setoid_replace ('1 : Qpos) with (1#1)%Qpos. reflexivity. rewrite AQposAsQpos_preserves_1. reflexivity. setoid_replace (' (a * 1 ≪ (-1))) with (' (a ≪ (-1))). reflexivity. rewrite aq_shift_opp_1. rewrite rings.preserves_mult. rewrite aq_shift_opp_1. apply Qmult_comp. reflexivity. rewrite rings.preserves_1. reflexivity. + rewrite aq_shift_opp_1. apply rational_exp_square. now apply semirings.preserves_nonpos. + apply (order_reflecting (cast AQ Q)). rewrite rings.preserves_mult. rewrite rings.preserves_0. rewrite <- (Qmult_0_l (' (1 ≪ (-1)))). apply Qmult_le_compat_r. apply (order_preserving (cast AQ Q)) in aneg. rewrite rings.preserves_0 in aneg. exact aneg. rewrite aq_shift_opp_1. rewrite rings.preserves_1. discriminate. + apply ARpower_2_iter_wd. apply (injective (cast AR CR)). rewrite AQexp_small_neg_correct, AQexp_small_neg_correct. apply rational_exp_small_neg_wd. setoid_replace (' (a * (1 ≪ (-1)) ^ S n)) with (' (a * 1 ≪ (-1) * (1 ≪ (-1)) ^ n)). reflexivity. unfold pow at 1. simpl. rewrite (rings.mult_assoc a). reflexivity. Qed. Section exp_neg. Context {a : AQ} (Pa : a ≤ 0). Lemma AQexp_neg_bound_correct : -2 ^ Z.to_nat (Z.log2_up (Qceiling(-'a))) ≤ a. Proof. apply (order_reflecting (cast AQ Q)). rewrite rings.preserves_negate. rewrite preserves_nat_pow. rewrite rings.preserves_2. rewrite <-(int_pow_nat_pow (f:=Z_of_nat)). assert ('a <= 0)%Q as H5. { apply (order_preserving (cast AQ Q)) in Pa. rewrite rings.preserves_0 in Pa. exact Pa. } pose proof (rational_exp_bound_power_2 H5). rewrite Qpower.Zpower_Qpower in H6. apply H6. apply Nat2Z.is_nonneg. Qed. Lemma power_2_improve_bound_correct : forall (n:nat), -2 ^ n ≤ a -> -1 ≤ a*(1 ≪ (-1))^n ≤ 0. Proof. intros. assert ('a <= 0)%Q as aneg. { apply (order_preserving (cast AQ Q)) in Pa. rewrite rings.preserves_0 in Pa. exact Pa. } pose proof (CRexp.power_2_improve_bound_correct n aneg) as H6. assert ('(-1) <= '(a * (1 ≪ (-1)) ^ n) <= '0 -> -1 ≤ a * (1 ≪ (-1)) ^ n ≤ 0). { intros. split; apply (order_reflecting (cast AQ Q)); apply H7. } apply H7. clear H7. rewrite rings.preserves_mult. rewrite rings.preserves_negate. rewrite rings.preserves_1. rewrite rings.preserves_0. rewrite preserves_nat_pow. rewrite <-(int_pow_nat_pow (f:=Z_of_nat)). rewrite (aq_shift_correct 1 (-1)). rewrite rings.preserves_1. rewrite Qmult_1_l. apply H6. clear H6. apply (order_preserving (cast AQ Q)) in H5. refine (Qle_trans _ _ _ _ H5). rewrite rings.preserves_negate. rewrite preserves_nat_pow. rewrite <-(int_pow_nat_pow (f:=Z_of_nat)). rewrite Qpower.Zpower_Qpower. rewrite rings.preserves_2. apply Qle_refl. apply Nat2Z.is_nonneg. Qed. Definition AQexp_neg : AR := ARpower_2_iter (Z.to_nat (Z.log2_up (Qceiling(-'a)))) (AQexp_small_neg (power_2_improve_bound_correct _ (AQexp_neg_bound_correct))). Lemma AQexp_neg_correct: 'AQexp_neg = rational_exp ('a). Proof. apply AQexp_neg_bounded_correct, Pa. Qed. (* We could use a number closer to 1/exp 1, for example 11 $ -5, but in practice this seems to make it slower. *) Program Definition AQexp_inv_pos_bound : AQ₊ := ((1 ≪ (-2)) ^ Z.abs_N (Qfloor ('a)))↾_. Next Obligation. solve_propholds. Qed. Lemma AQexp_inv_pos_bound_correct : '(cast (AQ₊) Q AQexp_inv_pos_bound) ≤ rational_exp ('a). Proof. change (cast Q CR (cast AQ Q ((1 ≪ (-2)) ^ Z.abs_N (Qfloor ('a)))) ≤ rational_exp ('a)). rewrite preserves_nat_pow. rewrite aq_shift_opp_2. rewrite rings.preserves_1, rings.mult_1_l. rewrite <-(int_pow_nat_pow (f:=cast N Z)). rewrite Z_of_N_abs, Z.abs_neq. apply (rational_exp_lower_bound (1#4)). now apply semirings.preserves_nonpos. apply CRpos_nonNeg. now CRsign.CR_solve_pos (1#1)%Qpos. change (Qfloor ('a) ≤ 0). apply (order_reflecting (cast Z Q)). transitivity ('a : Q). now apply Qfloor_le. now apply semirings.preserves_nonpos. Qed. End exp_neg. Lemma AQexp_prf1 {a : AQ} (pA : 0 ≤ a) : -a ≤ 0. Proof. now apply rings.flip_nonneg_negate. Qed. Lemma AQexp_prf2 {a : AQ} (pA : ¬0 ≤ a) : a ≤ 0. Proof. now apply orders.le_flip. Qed. (* Extend it to the full domain. *) Definition AQexp (a : AQ) : AR := match decide_rel (≤) 0 a with | left Pa => ARinv_pos (AQexp_inv_pos_bound (a:=-a)) (AQexp_neg (AQexp_prf1 Pa)) | right Pa => AQexp_neg (AQexp_prf2 Pa) end. Lemma AQexp_correct a : 'AQexp a = rational_exp ('a). Proof. unfold AQexp. case (decide_rel _); intros. rewrite ARtoCR_preserves_inv_pos. rewrite AQexp_neg_correct. rewrite rings.preserves_negate. apply rational_exp_opp. now apply semirings.preserves_nonneg. posed_rewrite <-(rings.preserves_negate (f:=cast AQ Q)). apply (AQexp_inv_pos_bound_correct (a:=-a)). now apply rings.flip_nonneg_negate. apply AQexp_neg_correct. Qed. Local Obligation Tactic := idtac. Program Definition ARexp_bounded_uc (z : Z) := unary_complete_uc QPrelengthSpace (cast AQ Q_as_MetricSpace) (λ x, AQexp (('z) ⊓ x)) (exp_bound_uc z) _. Next Obligation. intros. change ('AQexp ((' z) ⊓ x) = exp_bound_uc z (' x)). rewrite AQexp_correct, aq_preserves_min, AQtoQ_ZtoAQ. reflexivity. Qed. Definition ARexp_bounded (z : Z) := Cbind AQPrelengthSpace (ARexp_bounded_uc z). Lemma ARtoCR_preserves_exp_bounded z x : 'ARexp_bounded z x = exp_bounded z ('x). Proof. apply (preserves_unary_complete_fun QPrelengthSpace _ (λ x, AQexp (('z) ⊓ x))). Qed. Definition ARexp (x : AR) : AR := ARexp_bounded (Qceiling ('approximate x (Qpos2QposInf (1#1)) + (1#1))) x. Lemma ARtoCR_preserves_exp x : 'ARexp x = exp ('x). Proof. unfold ARexp. apply ARtoCR_preserves_exp_bounded. Qed. End ARexp. corn-8.20.0/reals/faster/ARinterval.v000066400000000000000000000040631473720167500174110ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Qabs Qround. Require Import CoRN.model.metric2.Qmetric CoRN.metric2.ProductMetric CoRN.metric2.Prelength CoRN.metric2.Compact CoRN.model.totalorder.QposMinMax CoRN.model.totalorder.QMinMax CoRN.reals.faster.ARArith CoRN.reals.fast.Interval. (** Proof that intervals are compact. *) Local Open Scope uc_scope. Section ARintervalRational. Context `{AppRationals AQ}. (* The computations of the subdivisions are faster when the bounds are rational numbers, and this is what we'll use to plot graphs, by slightly extending the domains to get rational end points. *) Variable a b : Q. Hypothesis leab : a <= b. Lemma plFEQ : PrelengthSpace (FinEnum Q_as_MetricSpace). Proof. apply FinEnum_prelength. apply locatedQ. apply QPrelengthSpace. Qed. (* TODO this has twice as many points as CompactIntervalQ, fine tune the subdivision. *) Lemma Iab_reg_prf : is_RegularFunction (FinEnum_ball AQ_as_MetricSpace) (fun d0:QposInf => match d0 with | Qpos2QposInf d => map (λ x : Q, AppInverse0 x ((1 # 2) * d)%Qpos) (UniformPartition a b (Z.to_pos (Qround.Qceiling ((b - a) / (inject_Z 2 * ((1 # 2) * ` d)))))) | QposInfinity => nil end). Proof. pose (CompactCompleteCompact _ (CompactImage (1#1)%Qpos plFEQ (Build_UniformlyContinuousFunction inject_Q_AR_uc) (CompactIntervalQ leab))) as K. apply (@is_RegularFunction_wd _ (approximate K)). 2: apply (regFun_prf K). intro d. simpl. unfold Cjoin_raw; simpl. unfold FinCompact_raw; simpl. rewrite map_map; simpl. unfold MetricMorphisms.app_inverse. unfold canonical_names.equiv. unfold FinEnum_eq. simpl. apply (@ball_refl (FinEnum AQ_as_MetricSpace) 0). discriminate. Qed. Definition IabCompact : Compact AQ_as_MetricSpace := Build_RegularFunction Iab_reg_prf. End ARintervalRational. corn-8.20.0/reals/faster/ARpi.v000066400000000000000000000051561473720167500162010ustar00rootroot00000000000000Require Import MathClasses.interfaces.abstract_algebra CoRN.stdlib_omissions.Q CoRN.algebra.RSetoid CoRN.metric2.Metric CoRN.metric2.UniformContinuity CoRN.reals.fast.CRpi_fast CoRN.reals.fast.CRarctan_small CoRN.reals.faster.ARarctan_small. Section ARpi. Context `{AppRationals AQ}. Lemma AQpi_prf (x : Z) : 1 < x → -('x : AQ) < 1 < ('x : AQ). Proof. split. 2: apply semirings.preserves_gt_1, H5. rewrite <- (rings.preserves_1 (f:=cast Z AQ)). rewrite <- (rings.preserves_negate (f:=cast Z AQ)). apply (strictly_order_preserving (cast Z AQ)). unfold one, stdlib_binary_integers.Z_1. rewrite <- (Z.opp_involutive 1). apply Z.gt_lt, CornBasics.Zlt_opp. apply (Z.lt_trans _ 1). reflexivity. exact H5. Qed. Lemma ZtoAQ_pos : forall (z:Z), 0 < z -> 0 < ('z : AQ). Proof. intros z zpos. pose proof (rings.preserves_0 (f:=cast Z AQ)). rewrite <- H5. exact (strictly_order_preserving (cast Z AQ) 0 z zpos). Qed. Definition AQpi (x : AQ) : msp_car AR := ucFun (ARscale (' 176%Z * x)) (AQarctan_small (AQpi_prf 57 eq_refl) (ZtoAQ_pos 57 eq_refl)) + ucFun (ARscale (' 28%Z * x)) (AQarctan_small (AQpi_prf 239 eq_refl) (ZtoAQ_pos 239 eq_refl)) + (ucFun (ARscale (' (-48)%Z * x)) (AQarctan_small (AQpi_prf 682 eq_refl) (ZtoAQ_pos 682 eq_refl)) + ucFun (ARscale (' 96%Z * x)) (AQarctan_small (AQpi_prf 12943 eq_refl) (ZtoAQ_pos 12943 eq_refl))). Lemma ARtoCR_preserves_AQpi x : 'AQpi x = r_pi ('x). Proof. unfold AQpi, r_pi. assert (∀ (k : Z) (d : positive) (Pnd: -(cast Z AQ (Zpos d)) < 1 < cast Z AQ (Zpos d)) (dpos : 0 < cast Z AQ (Zpos d)) (Pa : (-1 <= 1#d <= 1)%Q), ' ucFun (ARscale ('k * x)) (AQarctan_small Pnd dpos) = ucFun (scale (inject_Z k * 'x)) (rational_arctan_small Pa)) as PP. { intros. rewrite ARtoCR_preserves_scale. apply Cmap_wd. rewrite rings.preserves_mult, AQtoQ_ZtoAQ. reflexivity. rewrite AQarctan_small_correct. rewrite rational_arctan_small_wd. reflexivity. rewrite rings.preserves_1. pose proof (AQtoQ_ZtoAQ (Zpos d)). rewrite H5. reflexivity. } assert (forall x y : msp_car AR, ARtoCR (x+y) = 'x + 'y) as plusMorph. { intros x0 y. apply (rings.preserves_plus x0 y). } unfold cast. unfold cast in plusMorph. rewrite plusMorph. apply ucFun2_wd. rewrite plusMorph. apply ucFun2_wd. apply PP. apply PP. rewrite plusMorph. apply ucFun2_wd. apply PP. apply PP. Qed. Definition ARpi := AQpi 1. Lemma ARtoCR_preserves_pi : 'ARpi = CRpi. Proof. unfold ARpi, CRpi. rewrite ARtoCR_preserves_AQpi. rewrite rings.preserves_1. reflexivity. Qed. End ARpi. corn-8.20.0/reals/faster/ARplot.v000066400000000000000000000053321473720167500165430ustar00rootroot00000000000000From Coq Require Import Qround. Require Import CoRN.reals.fast.Plot. Require Import CoRN.reals.faster.ARArith. Require Import CoRN.reals.faster.ARinterval. Require Import CoRN.model.metric2.Qmetric. Local Open Scope uc_scope. Section PlotPath. Context `{AppRationals AQ}. Variable (from to:Q). Hypothesis Hfromto:from<=to. Variable (l r:Q). Hypothesis Hlr : l < r. Variable (b t:Q). Hypothesis Hbt : b < t. (* Number of pixels on the X-axis. *) Variable n : positive. Lemma wpos : 0 < r - l. Proof. apply Qlt_minus_iff in Hlr. exact Hlr. Qed. Lemma hpos : 0 < t - b. Proof. apply Qlt_minus_iff in Hbt. exact Hbt. Qed. (* Compute the number of pixels on the Y-axis to make square pixels. *) Let m : positive := Z.to_pos (Qceiling ((t-b) * inject_Z (Z.pos n) / (r-l))). (** Half the error in the Plot example, since we need to approximate twice. *) Let err := Qpos_max ((1 # 8 * n) * (exist _ _ wpos)) ((1 # 8 * m) * (exist _ _ hpos)). Variable path:AQ_as_MetricSpace --> Complete (ProductMS AQ_as_MetricSpace AQ_as_MetricSpace). (** The actual plot function *) Definition PlotPath : positive * positive * Q * sparse_raster n m := (n, m, 2, let num := (Z.to_pos (Qceiling ((to - from) / (inject_Z 2 * ((1 # 2) * ` (FinEnum_map_modulus (1 # 1)%Qpos (mu path) err)))))) in sparse_raster_data n m (map (λ x : Z, rasterize2 n m t l b r (let (a, b0) := approximate (path (AppInverse0 (from + (to - from) * (2 * x + 1 # 1) / (2 * Z.pos num # 1)) ((1 # 2)%Qpos * FinEnum_map_modulus (1#1)%Qpos (mu path) err)%Qpos)) err in (AQtoQ a, AQtoQ b0))) (* TODO rasterize2AQ *) (Interval.iterateN_succ 0 num))). Definition PlotPath_slow : positive * positive * Q * sparse_raster n m := (n, m, 2#1, sparse_raster_data n m (map (λ x : AQ_as_MetricSpace, rasterize2 n m t l b r (let (a, b0) := approximate (path x) err in (AQtoQ a, AQtoQ b0))) (approximate (IabCompact from to Hfromto) (FinEnum_map_modulus (1 # 1) (mu path) err)))). Lemma PlotPath_correct : eq PlotPath PlotPath_slow. Proof. unfold PlotPath_slow. unfold IabCompact, approximate. rewrite map_map. unfold Interval.UniformPartition. rewrite map_map. reflexivity. Qed. End PlotPath. corn-8.20.0/reals/faster/ARroot.v000066400000000000000000000506221473720167500165520ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import Ring. Require Import CoRN.stdlib_omissions.Z CoRN.model.totalorder.QposMinMax CoRN.metric2.Complete CoRN.model.metric2.Qmetric. From Coq Require Import ZArith. Require Import CoRN.util.Qdlog CoRN.reals.fast.CRroot CoRN.reals.faster.ARabs MathClasses.interfaces.abstract_algebra MathClasses.theory.shiftl MathClasses.theory.nat_pow MathClasses.theory.int_pow. Require Export CoRN.reals.faster.ARArith. Section ARsqrt. Context `{AppRationals AQ}. Add Ring AQ : (rings.stdlib_ring_theory AQ). Add Ring Q : (rings.stdlib_ring_theory Q). Add Ring Z : (rings.stdlib_ring_theory Z). Add Ring AR : (rings.stdlib_ring_theory AR). Section sqrt_mid. Context `(Pa : 1 ≤ a ≤ 4). Fixpoint AQsqrt_loop (n : nat) : AQ * AQ := match n with | O => (a, 0) | S n => let (r, s) := AQsqrt_loop n in if decide_rel (≤) (s + 1) r then ((r - (s + 1)) ≪ (2%mc:Z), (s + 2) ≪ (1%mc:Z)) else (r ≪ (2%mc:Z), s ≪ (1%mc:Z)) end. Instance: Proper (=) AQsqrt_loop. Proof. intros x y E. change (x ≡ y) in E. now rewrite E. Qed. Lemma AQsqrt_loop_invariant1 (n : nat) : snd (AQsqrt_loop n) ^ (2%mc:N) + 4 * fst (AQsqrt_loop n) = 4 * 4 ^ n * a. Proof. rewrite nat_pow_2. induction n; unfold pow; simpl. ring. revert IHn; case (AQsqrt_loop n); intros r s IHn. case (decide_rel (≤) (s + 1) r); intros; simpl in *; rewrite shiftl_1, shiftl_2, <-(associativity 4), <-IHn; ring. Qed. Lemma AQsqrt_loop_invariant2 (n : nat) : fst (AQsqrt_loop n) ≤ 2 * snd (AQsqrt_loop n) + 4. Proof. induction n; simpl. now setoid_replace (2 * 0 + 4) with 4 by ring. revert IHn; case (AQsqrt_loop n); intros r s IHn. case (decide_rel (≤) (s + 1) r); intros; simpl in *. rewrite shiftl_1, shiftl_2. setoid_replace (2 * (2 * (s + 2)) + 4) with (4 * ((2 * s + 4) - (s + 1))) by ring. apply (order_preserving (4 *.)). now apply (order_preserving (+ _)). rewrite shiftl_1, shiftl_2. setoid_replace (2 * (2 * s) + 4) with (4 * (s + 1)) by ring. apply (order_preserving (4 *.)). now apply orders.le_flip. Qed. Lemma AQsqrt_loop_snd_lower_bound (n z : nat) : snd (AQsqrt_loop n) * 2 ^ z ≤ snd (AQsqrt_loop (z + n)). Proof. induction z; unfold pow; simpl. apply orders.eq_le. ring. revert IHz. case (AQsqrt_loop (z + n)); intros r s IHz. case (decide_rel (≤) _); intros; simpl in *. rewrite shiftl_1. setoid_replace (snd (AQsqrt_loop n) * (2 * 2 ^ z)) with (2 * (snd (AQsqrt_loop n) * 2 ^ z)) by ring. apply (order_preserving (2 *.)). apply semirings.plus_le_compat_r; [solve_propholds | assumption]. rewrite shiftl_1. setoid_replace (snd (AQsqrt_loop n) * (2 * 2 ^ z)) with (2 * (snd (AQsqrt_loop n) * 2 ^ z)) by ring. now apply (order_preserving (2 *.)). Qed. Lemma AQsqrt_loop_snd_upper_bound (n z : nat) : snd (AQsqrt_loop (z + n)) ≤ (snd (AQsqrt_loop n) + 4) * 2 ^ z - 4. Proof. induction z; unfold pow; simpl. apply orders.eq_le. ring. revert IHz. case (AQsqrt_loop (z + n)); intros r s IHz. case (decide_rel (≤)); simpl; intros E. rewrite shiftl_1. setoid_replace ((snd (AQsqrt_loop n) + 4) * (2 * 2 ^ z) - 4) with (2 * ((snd (AQsqrt_loop n) + 4) * 2 ^ z - 4 + 2)) by ring. apply (order_preserving (2 *.)). now apply (order_preserving (+2)). rewrite shiftl_1. setoid_replace ((snd (AQsqrt_loop n) + 4) * (2 * 2 ^ z) - 4) with (2 * ((snd (AQsqrt_loop n) + 4) * 2 ^ z - 4 + 2)) by ring. apply (order_preserving (2 *.)). apply semirings.plus_le_compat_r; [solve_propholds | assumption]. Qed. Lemma AQsqrt_loop_snd_nonneg (n : nat) : 0 ≤ snd (AQsqrt_loop n). Proof. rewrite <-(rings.plus_0_r n) at 1. etransitivity. 2: apply AQsqrt_loop_snd_lower_bound. simpl. apply orders.eq_le. ring. Qed. Lemma AQsqrt_loop_fst_nonneg (n : nat) : 0 ≤ fst (AQsqrt_loop n). Proof. induction n; simpl. transitivity 1; [solve_propholds | easy]. revert IHn; case (AQsqrt_loop n); intros r s IHn. case (decide_rel (≤) (s + 1) r); intros; simpl in *. rewrite shiftl_2. apply nonneg_mult_compat; [solve_propholds |]. now apply rings.flip_nonneg_minus. rewrite shiftl_2. now apply (nonneg_mult_compat _ _ _). Qed. Lemma AQsqrt_loop_fst_upper_bound (n : nat) : fst (AQsqrt_loop n) ≤ 2 ^ (3 + n). Proof with auto. transitivity (2 * snd (AQsqrt_loop n) + 4). apply AQsqrt_loop_invariant2. change (2 ^ (3 + n)) with (2 * (2 * (2 * 2 ^ n))). setoid_replace (2 * snd (AQsqrt_loop n) + 4) with (2 * (snd (AQsqrt_loop n) + 2)) by ring. apply (order_preserving (2 *.)). setoid_replace (2 * (2 * 2 ^ n)) with ((4 * 2 ^ n - 2) + 2) by ring. apply (order_preserving (+ 2)). transitivity (4 * 2 ^ n - 4). rewrite <-(rings.plus_0_r n) at 1. rewrite <-(rings.plus_0_l 4) at 1. now apply AQsqrt_loop_snd_upper_bound. apply semirings.plus_le_compat. now rewrite commutativity. now apply rings.flip_le_negate, semirings.le_2_4. Qed. Definition AQsqrt_mid_bounded_raw (n : N) := snd (AQsqrt_loop ('n)) ≪ -((1 + 'n)%mc : Z). Instance AQsqrt_mid_bounded_raw_proper: Proper ((=) ==> (=)) AQsqrt_mid_bounded_raw. Proof. intros x y E. change (x ≡ y) in E. now subst. Qed. Lemma AQsqrt_mid_bounded_raw_lower_bound (n : N) : 0 ≤ AQsqrt_mid_bounded_raw n. Proof. unfold AQsqrt_mid_bounded_raw. apply shiftl_nonneg, AQsqrt_loop_snd_nonneg. Qed. Lemma AQsqrt_mid_bounded_raw_upper_bound (n : N) : AQsqrt_mid_bounded_raw n ≤ 4. Proof. unfold AQsqrt_mid_bounded_raw. apply (order_reflecting (≪ 1 + 'n)). rewrite shiftl_reverse by ring. etransitivity. rewrite <-(rings.plus_0_r ('n)). now apply AQsqrt_loop_snd_upper_bound. simpl. apply rings.nonneg_minus_compat; [solve_propholds|]. rewrite rings.plus_0_l, shiftl_S. apply semirings.ge_1_mult_le_compat_l. now apply semirings.le_1_2. solve_propholds. apply orders.eq_le. now rewrite shiftl_nat_pow_alt, preserves_nat_pow_exp. Qed. Lemma AQsqrt_mid_bounded_regular_aux1 (n m : N) : m ≤ n → AQsqrt_mid_bounded_raw n - AQsqrt_mid_bounded_raw m ≤ 1 ≪ (1 - 'm : Z). Proof. intros E. apply naturals.nat_le_plus in E. destruct E as [z E]. rewrite commutativity in E. change (n ≡ z + m) in E. subst. unfold AQsqrt_mid_bounded_raw. rewrite rings.preserves_plus. etransitivity. apply semirings.plus_le_compat; [| reflexivity]. apply (order_preserving (≪ _)). etransitivity. now apply AQsqrt_loop_snd_upper_bound. apply rings.nonneg_minus_compat; [solve_propholds | reflexivity]. apply orders.eq_le. rewrite <-(shiftl_nat_pow_alt (f:=cast nat Z)). rewrite (naturals.to_semiring_twice _ _ (cast N Z)). rewrite <-shiftl_exp_plus, rings.preserves_plus. mc_setoid_replace (('z - (1 + ('z + 'm)))%mc : Z) with ((-(1 + 'm))%mc : Z) by ring. rewrite shiftl_base_plus. ring_simplify. mc_setoid_replace ((1 - ' m)%mc : Z) with ((2 - (1 + 'm))%mc : Z) by ring. now rewrite shiftl_exp_plus, shiftl_2, rings.mult_1_r. Qed. Lemma AQsqrt_mid_bounded_regular_aux2 (n m : N) : n ≤ m → AQsqrt_mid_bounded_raw n ≤ AQsqrt_mid_bounded_raw m. Proof. intros E. apply naturals.nat_le_plus in E. destruct E as [z E]. rewrite commutativity in E. change (m ≡ z + n) in E. subst. unfold AQsqrt_mid_bounded_raw. rewrite 2!rings.preserves_plus. mc_setoid_replace ((-(1 + 'n))%mc : Z) with (('z - (1 + ('z + 'n)))%mc : Z) by ring. rewrite shiftl_exp_plus. apply (order_preserving (≪ _)). rewrite shiftl_nat_pow_alt, <-(preserves_nat_pow_exp (f:=cast N nat)). now apply AQsqrt_loop_snd_lower_bound. Qed. Lemma AQsqrt_mid_bounded_spec (n : N) : (AQsqrt_mid_bounded_raw n ^ (2%mc:N)) = a - fst (AQsqrt_loop ('n)) ≪ -(2 * 'n). Proof. unfold AQsqrt_mid_bounded_raw. rewrite shiftl_base_nat_pow, rings.preserves_2. apply (injective (≪ (2 + 2 * 'n))). rewrite shiftl_reverse by ring. rewrite shiftl_base_plus, shiftl_negate, <-shiftl_exp_plus. mc_setoid_replace ((-(2 * 'n) + (2 + 2 * 'n))%mc : Z) with (2%mc : Z) by ring. rewrite shiftl_exp_plus, ?shiftl_2, <-shiftl_mult_l. rewrite <-(rings.preserves_2 (f:=cast N Z)), <-rings.preserves_mult. rewrite shiftl_nat_pow_alt, nat_pow_exp_mult. rewrite (commutativity a), associativity. rewrite <-(preserves_nat_pow_exp (f:=cast N nat) _ n). setoid_replace (2 ^ 2) with 4 by (rewrite nat_pow_2; ring). apply (right_cancellation (+) (4 * fst (AQsqrt_loop (' n)))). rewrite AQsqrt_loop_invariant1. ring. Qed. Lemma AQsqrt_mid_bounded_raw_square_upper_bound (n : N) : AQsqrt_mid_bounded_raw n ^ (2:N) ≤ a. Proof. rewrite AQsqrt_mid_bounded_spec. apply rings.nonneg_minus_compat; [| reflexivity]. now apply shiftl_nonneg, AQsqrt_loop_fst_nonneg. Qed. Definition AQsqrt_mid_raw (ε : Qpos) := AQsqrt_mid_bounded_raw (plus (N_of_Z (-Qdlog2 (proj1_sig ε))) 3). Instance: Proper (QposEq ==> (=)) AQsqrt_mid_raw. Proof. unfold AQsqrt_mid_raw. intros [x?] [y?] E. change (x = y) in E. simpl. now rewrite E. Qed. Lemma AQsqrt_mid_bounded_prf: is_RegularFunction_noInf _ (AQsqrt_mid_raw : Qpos → AQ_as_MetricSpace). Proof. assert (∀ n m, m ≤ n → ball (2 ^ (-cast N Z m - 2)) (AQsqrt_mid_bounded_raw (n + 3) : AQ_as_MetricSpace) (AQsqrt_mid_bounded_raw (m + 3))). intros n m E. simpl. apply Qball_Qabs. rewrite Qabs.Qabs_pos. change ('AQsqrt_mid_bounded_raw (n + 3) - 'AQsqrt_mid_bounded_raw (m + 3) ≤ ((2 ^ (-'m - 2))%mc : Q)). rewrite <-rings.preserves_minus, <-(rings.mult_1_l (2 ^ (-'m - 2))). rewrite <-shiftl_int_pow. rewrite <-(rings.preserves_1 (f:=cast AQ Q)), <-(preserves_shiftl (f:=cast AQ Q)). apply (order_preserving _). mc_setoid_replace ((-'m - 2)%mc : Z) with ((1 - '(m + 3))%mc : Z). apply AQsqrt_mid_bounded_regular_aux1. now refine (order_preserving (+ (3%mc:N)) _ _ _). rewrite rings.preserves_plus, rings.preserves_3. ring. change (0 ≤ (('AQsqrt_mid_bounded_raw (n + 3) - 'AQsqrt_mid_bounded_raw (m + 3))%mc : Q)). apply rings.flip_nonneg_minus. apply (order_preserving _). apply AQsqrt_mid_bounded_regular_aux2. now refine (order_preserving (+ (3:N)) _ _ _). assert (∀ ε1 ε2 : Qpos, N_of_Z (-Qdlog2 (proj1_sig ε2)) ≤ N_of_Z (-Qdlog2 (proj1_sig ε1)) → ball (proj1_sig ε1 + proj1_sig ε2) (AQsqrt_mid_raw ε1 : AQ_as_MetricSpace) (AQsqrt_mid_raw ε2)). { intros ε1 ε2 E. unfold AQsqrt_mid_raw. eapply ball_weak_le; auto. change ((2%mc:Q) ^ (-'N_of_Z (-Qdlog2 (proj1_sig ε2)) - 2) ≤ proj1_sig ε1 + proj1_sig ε2). apply semirings.plus_le_compat_l. now apply orders.lt_le, Qpos_ispos. destruct (total (≤) (proj1_sig ε2) 1). rewrite N_of_Z_nonneg. change (- (-Qdlog2 (proj1_sig ε2))%Z) with (- -Qdlog2 (proj1_sig ε2)). rewrite rings.negate_involutive. rewrite int_pow_exp_plus by solve_propholds. transitivity ((2 ^ Qdlog2 (proj1_sig ε2))%mc : Q). 2: now apply Qdlog2_spec, Qpos_ispos. rewrite <-(rings.mult_1_r (2 ^ Qdlog2 (proj1_sig ε2) : Q)) at 2. now apply (order_preserving (_ *.)). change (0 ≤ -Qdlog2 (proj1_sig ε2)). now apply rings.flip_nonpos_negate, Qdlog2_nonpos. transitivity (1:Q); auto. rewrite N_of_Z_nonpos; [easy|]. change (-Qdlog2 (proj1_sig ε2) ≤ 0). now apply rings.flip_nonneg_negate, Qdlog2_nonneg. } intros ε1 ε2. destruct (total (≤) (N_of_Z (-Qdlog2 (proj1_sig ε1))) (N_of_Z (-Qdlog2 (proj1_sig ε2)))); auto. apply ball_sym. rewrite Qplus_comm. auto. Qed. Definition AQsqrt_mid : AR := mkRegularFunction (0 : AQ_as_MetricSpace) AQsqrt_mid_bounded_prf. Lemma AQsqrt_mid_upper_bound : AQsqrt_mid ≤ 4. Proof. intros ε. transitivity (0 : Q). apply rings.flip_nonneg_negate. now apply orders.lt_le, Qpos_ispos. change ((0:Q) ≤ '(4 - AQsqrt_mid_raw ((1#2) * ε))). apply semirings.preserves_nonneg, rings.flip_nonneg_minus. now apply AQsqrt_mid_bounded_raw_upper_bound. Qed. Lemma AQsqrt_mid_nonneg : 0 ≤ AQsqrt_mid. Proof. intros ε. transitivity (0 : Q). apply rings.flip_nonneg_negate. now apply orders.lt_le, Qpos_ispos. change ((0:Q) ≤ '(AQsqrt_mid_raw ((1#2) * ε) - 0)). apply semirings.preserves_nonneg, rings.flip_nonneg_minus. now apply AQsqrt_mid_bounded_raw_lower_bound. Qed. Lemma AQsqrt_mid_spec : AQsqrt_mid ^ (2:N)= 'a. Proof. assert (∀ ε, Qball (proj1_sig ε) ('(AQsqrt_mid_raw ε ^ (2:N))) ('a)) as P. { intros ε. apply Qball_Qabs. rewrite Qabs.Qabs_neg. eapply Qle_trans. 2: now apply Qpos_dlog2_spec. change (-( '(AQsqrt_mid_raw ε ^ 2) - 'a) ≤ ((2 ^ Qdlog2 (proj1_sig ε))%mc : Q)). rewrite <-rings.negate_swap_r. unfold AQsqrt_mid_raw. rewrite AQsqrt_mid_bounded_spec. rewrite rings.preserves_minus, preserves_shiftl. ring_simplify. apply shiftl_le_flip_l. etransitivity. apply (order_preserving _). now apply AQsqrt_loop_fst_upper_bound. rewrite preserves_nat_pow, rings.preserves_2. rewrite <-(int_pow_nat_pow (f:=cast nat Z)). rewrite shiftl_int_pow, <-int_pow_exp_plus by solve_propholds. apply int_pow_exp_le; [apply semirings.le_1_2|]. rewrite rings.preserves_plus, (naturals.to_semiring_twice _ _ (cast N Z)). rewrite (rings.preserves_plus _ 3), !rings.preserves_3. apply (order_reflecting (+ -(3 + 3))). ring_simplify. destruct (total (≤) (proj1_sig ε) 1). rewrite N_of_Z_nonneg. apply orders.eq_le. change (-Qdlog2 (proj1_sig ε) = 2 * -Qdlog2 (proj1_sig ε) + Qdlog2 (proj1_sig ε)). ring. change (0 ≤ -Qdlog2 (proj1_sig ε)). now apply rings.flip_nonpos_negate, Qdlog2_nonpos. rewrite N_of_Z_nonpos. now apply Qdlog2_nonneg. change (-Qdlog2 (proj1_sig ε) ≤ 0). now apply rings.flip_nonneg_negate, Qdlog2_nonneg. change ('(AQsqrt_mid_raw ε ^ 2) - 'a ≤ (0:Q)). apply rings.flip_nonpos_minus. apply (order_preserving _). now apply AQsqrt_mid_bounded_raw_square_upper_bound. } rewrite <-(ARpower_N_bounded_N_power _ _ 4). - intros ε1 ε2. rewrite Qplus_0_r. simpl. rewrite lattices.meet_r, lattices.join_r. + apply ball_weak. apply Qpos_nonneg. apply ball_weak_le with (proj1_sig (ε1 * Qpos_inv (8 # 1))%Qpos). change ('ε1 / (8#1) ≤ 'ε1). rewrite <-(rings.mult_1_r ('ε1)) at 2. apply Qmult_le_l. apply Qpos_ispos. discriminate. assert (QposEq (ε1 * Qpos_inv ((2#1) * Qpos_power (' 4) 1)) (ε1 * Qpos_inv (8#1))). unfold QposEq. simpl. pose proof AQposAsQpos_preserves_4. unfold equiv, sig_equiv, equiv, stdlib_rationals.Q_eq in H5. simpl. rewrite H5. reflexivity. rewrite H5. apply P. + transitivity (0:AQ). apply rings.flip_nonneg_negate. now apply semirings.le_0_4. now apply AQsqrt_mid_bounded_raw_lower_bound. + now apply AQsqrt_mid_bounded_raw_upper_bound. - split. transitivity (0:AR). apply rings.flip_nonneg_negate. apply (semirings.preserves_nonneg (f:=cast AQ AR)). now apply semirings.le_0_4. now apply AQsqrt_mid_nonneg. now apply AQsqrt_mid_upper_bound. Qed. Lemma AQsqrt_mid_correct : 'AQsqrt_mid = rational_sqrt ('a). Proof. apply rational_sqrt_unique. apply semirings.preserves_nonneg. red. transitivity 1; [solve_propholds | intuition]. change ('AQsqrt_mid ^ (2 : N) = cast Q CR (cast AQ Q a)). rewrite <-preserves_nat_pow. rewrite AQsqrt_mid_spec. now apply ARtoCR_inject. change (0%CR) with (0%mc : CR). rewrite <-(rings.preserves_0 (f:=cast AR CR)). apply (order_preserving _). now apply AQsqrt_mid_nonneg. Qed. End sqrt_mid. Section sqrt_pos. Context `(Pa : 0 < a). Local Obligation Tactic := idtac. Program Definition AQsqrt_pos := let n := Qdlog4 ('a) in ARscale (1 ≪ n) (AQsqrt_mid (a:=a ≪ (2 * -n)) _). Next Obligation. simpl. split. apply (order_reflecting (cast AQ Q)). rewrite rings.preserves_1, aq_shift_correct. rewrite int_pow_exp_mult. change (2 ^ 2 : Q) with (4 : Q). apply (order_reflecting (.* 4 ^ Qdlog4 ('a))). rewrite <-associativity, <-int_pow_exp_plus by (compute; discriminate). rewrite rings.mult_1_l, rings.plus_negate_l, int_pow_0, rings.mult_1_r. apply Qdlog4_spec. now apply semirings.preserves_pos. apply (order_reflecting (cast AQ Q)). rewrite aq_shift_correct, rings.preserves_4. rewrite int_pow_exp_mult. change (2 ^ 2 : Q) with (4 : Q). apply (order_reflecting (.* 4 ^ Qdlog4 ('a))). rewrite <-associativity, <-int_pow_exp_plus by (compute; discriminate). rewrite rings.plus_negate_l, int_pow_0, rings.mult_1_r. rewrite <-int_pow_S by (compute; discriminate). apply orders.lt_le, Qdlog4_spec. now apply semirings.preserves_pos. Qed. Lemma AQsqrt_pos_correct : 'AQsqrt_pos = rational_sqrt ('a). Proof. unfold AQsqrt_pos. rewrite ARtoCR_preserves_scale, AQsqrt_mid_correct. transitivity (scale (2 ^ Qdlog4 (' a)) (rational_sqrt (' (a ≪ (2 * - Qdlog4 (' a)))))). apply Cmap_wd. rewrite aq_shift_correct, rings.preserves_1, rings.mult_1_l. reflexivity. reflexivity. rewrite aq_shift_correct. rewrite int_pow_exp_mult. apply rational_sqrt_scale. apply semirings.preserves_nonneg. now apply orders.lt_le. Qed. End sqrt_pos. Program Definition AQsqrt (a : AQ) : AR := if decide_rel (≤) a 0 then 0 else AQsqrt_pos (a:=a) _. Next Obligation. now apply orders.not_le_lt_flip. Qed. Lemma AQsqrt_correct (a : AQ) : 'AQsqrt a = rational_sqrt ('a). Proof. unfold AQsqrt. case (decide_rel _); intros E. rewrite rational_sqrt_nonpos. now apply rings.preserves_0. now apply semirings.preserves_nonpos. now apply AQsqrt_pos_correct. Qed. Local Obligation Tactic := idtac. Require Import CoRN.metric2.MetricMorphisms. Program Definition ARsqrt_uc := unary_complete_uc QPrelengthSpace (cast AQ Q_as_MetricSpace) AQsqrt sqrt_uc _. Next Obligation. intros a. apply AQsqrt_correct. Qed. Definition ARsqrt := Cbind AQPrelengthSpace ARsqrt_uc. Lemma ARtoCR_preserves_sqrt (x : AR) : 'ARsqrt x = CRsqrt ('x). Proof. apply preserves_unary_complete_fun. Qed. Lemma ARsqrt_correct : forall (x : AR), ARle 0 x -> ARsqrt x * ARsqrt x = x. Proof. intros x xpos. apply (injective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace))). change (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace) x) with ('x). change (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace) (ARsqrt x * ARsqrt x)) with ('(ARsqrt x * ARsqrt x)). rewrite (ARtoCR_preserves_mult (ARsqrt x) (ARsqrt x)). rewrite ARtoCR_preserves_sqrt. apply CRsqrt_sqr. rewrite <- ARtoCR_preserves_0. apply (ARtoCR_preserves_le 0 x), xpos. Qed. Lemma ARsqrt_mult : forall (x y : AR), ARle 0 x -> ARle 0 y -> ARsqrt (x*y) = ARsqrt x * ARsqrt y. Proof. intros. apply (injective (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace))). change (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace) (ARsqrt (x*y))) with ('(ARsqrt (x*y))). change (Eembed QPrelengthSpace (cast AQ Q_as_MetricSpace) (ARsqrt x * ARsqrt y)) with ('(ARsqrt x * ARsqrt y)). rewrite (ARtoCR_preserves_mult (ARsqrt x) (ARsqrt y)). rewrite ARtoCR_preserves_sqrt. rewrite ARtoCR_preserves_sqrt. rewrite ARtoCR_preserves_sqrt. rewrite <- CRsqrt_mult. rewrite ARtoCR_preserves_mult. reflexivity. rewrite <- ARtoCR_preserves_0. apply (ARtoCR_preserves_le 0 x), H5. rewrite <- ARtoCR_preserves_0. apply (ARtoCR_preserves_le 0 y), H6. Qed. Lemma ARsqrt_srq_abs : forall x : AR, ARsqrt (x*x) = ARabs x. Proof. (* Goal is a negation, use excluded middle x is positive or not. When positive, ARsqrt(x*x) = ARsqrt x*ARsqrt x = x. *) assert (forall x : AR, ARle 0 x -> ARsqrt (x*x) = ARabs x) as posCase. { intros. rewrite ARsqrt_mult, ARsqrt_correct. rewrite ARabs_pos. reflexivity. exact H5. exact H5. exact H5. exact H5. } intros. apply ball_stable. intro abs. assert (~(ARle 0 x)). - intro H5. contradict abs. apply posCase, H5. - contradict H5. apply ARle_not_lt. intro H5. contradict abs. change (ARsqrt (x*x) = ARabs x). rewrite <- ARabs_opp. setoid_replace (x * x) with (-x * -x) by ring. apply posCase. destruct (ARtoCR_preserves_ltT x 0) as [c _]. specialize (c H5). apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_0. rewrite <- CRopp_0. rewrite ARtoCR_preserves_opp. apply CRopp_le_compat. rewrite <- ARtoCR_preserves_0. apply CRlt_le_weak, c. Qed. Lemma ARsqrt_inc : forall x y : AR, ARle 0 x -> ARle x y -> ARle (ARsqrt x) (ARsqrt y). Proof. intros. apply ARtoCR_preserves_le. rewrite ARtoCR_preserves_sqrt. rewrite ARtoCR_preserves_sqrt. apply CRsqrt_inc. rewrite <- ARtoCR_preserves_0. apply (ARtoCR_preserves_le 0 x), H5. apply (ARtoCR_preserves_le x y), H6. Qed. End ARsqrt. corn-8.20.0/reals/faster/ARsign.v000066400000000000000000000017371473720167500165320ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. From Coq Require Import ZArith. Require Import CoRN.reals.faster.ARArith. Ltac AR_solve_pos_loop k := (apply AR_epsilon_sign_dec_pos with k; vm_compute; match goal with | |- Gt ≡ Gt => reflexivity | |- Lt ≡ Gt => fail 2 "AR number is negative" end) || AR_solve_pos_loop (k - 8)%Z. Tactic Notation "AR_solve_pos" constr(k) := AR_solve_pos_loop k. Tactic Notation "AR_solve_pos" := AR_solve_pos 0%Z. Tactic Notation "AR_solve_ltT" constr(k) := match goal with | |- ARltT ?X ?Y => change (ARpos (Y - X)); AR_solve_pos_loop k end. Tactic Notation "AR_solve_ltT" := AR_solve_ltT 0%Z. Ltac AR_solve_apartT_loop k := (apply AR_epsilon_sign_dec_apartT with k; vm_compute; discriminate) || AR_solve_apartT_loop (k - 8)%Z. Tactic Notation "AR_solve_apartT" constr(k) := AR_solve_apartT_loop k. Tactic Notation "AR_solve_apartT" := AR_solve_apartT 0%Z. corn-8.20.0/reals/faster/ARsin.v000066400000000000000000000323311473720167500163550ustar00rootroot00000000000000From Coq Require Import ZArith Qround Qpower. Require Import MathClasses.interfaces.abstract_algebra MathClasses.theory.nat_pow MathClasses.theory.int_pow CoRN.algebra.RSetoid CoRN.metric2.Metric CoRN.metric2.MetricMorphisms CoRN.metric2.UniformContinuity CoRN.model.totalorder.QMinMax CoRN.util.Qdlog CoRN.stdlib_omissions.Q CoRN.reals.fast.CRsin CoRN.reals.fast.CRstreams CoRN.reals.fast.CRAlternatingSum CoRN.reals.fast.Compress CoRN.reals.faster.ARAlternatingSum. Require Export CoRN.reals.faster.ARArith. Local Open Scope mc_scope. Section ARsin. Context `{AppRationals AQ}. Lemma AQmult_lt_0_compat : forall a b : AQ, 0 < a -> 0 < b -> 0 < a*b. Proof. intros. apply (strictly_order_reflecting (cast AQ Q)). pose proof (rings.preserves_0 (f:=cast AQ Q)). rewrite H7. rewrite rings.preserves_mult. rewrite <- (Qmult_0_l ('b)). apply Qmult_lt_compat_r. rewrite <- H7. apply (strictly_order_preserving (cast AQ Q)), H6. rewrite <- H7. apply (strictly_order_preserving (cast AQ Q)), H5. Qed. Lemma ZtoQ : forall n:positive, AQtoQ (ZtoAQ (Zpos n)) == (Zpos n#1). Proof. induction n. - change (Z.pos n~1) with (1+2*Z.pos n)%Z. pose proof (rings.preserves_plus (f:=cast Z AQ) 1 (2*Z.pos n)). rewrite H5. clear H5. rewrite rings.preserves_plus, rings.preserves_1. rewrite rings.preserves_1. pose proof (rings.preserves_mult (f:=cast Z AQ) 2 (Z.pos n)). rewrite H5. clear H5. rewrite rings.preserves_mult, IHn. rewrite rings.preserves_2, rings.preserves_2. unfold Qeq; simpl. rewrite Pos.mul_1_r. reflexivity. - change (Z.pos n~0) with (2*Z.pos n)%Z. pose proof (rings.preserves_mult (f:=cast Z AQ) 2 (Z.pos n)). rewrite H5. rewrite rings.preserves_mult, IHn. rewrite rings.preserves_2. pose proof (rings.preserves_2 (f:=cast AQ Q)). rewrite H6. reflexivity. - pose proof (rings.preserves_1 (f:=cast Z AQ)). rewrite H5. rewrite rings.preserves_1. reflexivity. Qed. Local Open Scope uc_scope. Section sin_small. (* First define (sin a) as a decreasing alternating series on the segment [-1,1]. a = num/den and -1 <= a <= 1. *) Context {num den : AQ} (Pnd : -den ≤ num ≤ den) (dpos : 0 < den). (* Split the stream (-1)^i a^(2i+1) / (2i+1)! up into the streams (-1)^i a^(2i+1) and (2i+1)! because we do not have exact division *) Definition ARsinStream (px : positive*(AQ*AQ)) : AQ*AQ := (- fst (snd px) * num * num, snd (snd px) * den * den * ZtoAQ (Zpos (fst px)~0) * ZtoAQ (Zpos (fst px)~1)). Lemma sinStream_pos : ∀ x : positive * (AQ * AQ), 0 < snd (snd x) → 0 < snd (ARsinStream x). Proof. assert (0 = ZtoAQ 0) as zero_int. { destruct H4. destruct aq_ints_mor, semiringmor_plus_mor. rewrite preserves_mon_unit. reflexivity. } intros. destruct x; simpl. simpl in H5. apply AQmult_lt_0_compat. apply AQmult_lt_0_compat. apply AQmult_lt_0_compat. apply AQmult_lt_0_compat. exact H5. exact dpos. exact dpos. rewrite zero_int. apply (strictly_order_preserving (cast Z AQ)). reflexivity. rewrite zero_int. apply (strictly_order_preserving (cast Z AQ)). reflexivity. Qed. Lemma sinStream_correct : ∀ p : positive, Str_pth _ (sinStream (AQtoQ num / AQtoQ den)) p (1%positive, AQtoQ num / AQtoQ den) == let (_, r) := iterate _ (fS ARsinStream) p (1%positive, (num, den)) in AQtoQ (fst r) / AQtoQ (snd r). Proof. assert (forall n:Z, AQtoQ (ZtoAQ n) == (n#1)). { intro n. destruct n as [|n|n]. pose proof (rings.preserves_0 (f:=cast Z AQ)). rewrite H5. clear H5. rewrite rings.preserves_0. reflexivity. apply ZtoQ. change (Z.neg n) with (-Z.pos n)%Z. pose proof (rings.preserves_negate (f:=cast Z AQ)). rewrite H5. clear H5. rewrite rings.preserves_negate. rewrite ZtoQ. reflexivity. } apply Pos.peano_ind. - unfold Str_pth. simpl. do 6 rewrite rings.preserves_mult. rewrite rings.preserves_negate. rewrite H5, H5. unfold dec_recip, stdlib_rationals.Q_recip. unfold mult, stdlib_rationals.Q_mult. unfold negate, stdlib_rationals.Q_opp. field. intro abs. apply (strictly_order_preserving (cast AQ Q)) in dpos. rewrite rings.preserves_0, abs in dpos. exact (Qlt_irrefl 0 dpos). - intros p IHp. unfold Str_pth. unfold Str_pth in IHp. rewrite iterate_succ, iterate_succ. pose proof (sinStream_fst (AQtoQ num / AQtoQ den) p) as H7. unfold dec_recip, stdlib_rationals.Q_recip. unfold dec_recip, stdlib_rationals.Q_recip in IHp. unfold mult, stdlib_rationals.Q_mult. unfold mult, stdlib_rationals.Q_mult in IHp. unfold Qdiv in H7. unfold Qdiv. unfold Qdiv in IHp. unfold Q_as_MetricSpace, msp_car. unfold Q_as_MetricSpace, msp_car in IHp. destruct (iterate _ (sinStream (AQtoQ num * / AQtoQ den)%Q) p (1%positive, (AQtoQ num * / AQtoQ den)%Q)). simpl in H7. simpl in IHp. subst p0. unfold sinStream, snd, fst. rewrite IHp. clear IHp. pose proof (fS_fst ARsinStream p (num, den)). destruct (iterate _ (fS ARsinStream) p (1%positive, (num, den))) as [p0 p1]. simpl in H6. simpl. subst p0. do 6 rewrite rings.preserves_mult. rewrite rings.preserves_negate. unfold mult, stdlib_rationals.Q_mult. unfold negate, stdlib_rationals.Q_opp. rewrite ZtoQ, ZtoQ. rewrite <- (Qmult_assoc (AQtoQ (snd p1) * AQtoQ den * AQtoQ den)). rewrite Qinv_mult_distr. setoid_replace (/ ((Z.pos (Pos.succ p)~0 # 1) * (Z.pos (Pos.succ p)~1 # 1))) with (1 # (Pos.succ p * (Pos.succ p)~1)~0) by reflexivity. do 2 rewrite Qinv_mult_distr. ring. Qed. Lemma AQsin_small_Qprf : -1 ≤ AQtoQ num / AQtoQ den ≤ 1. Proof. split. - apply Qle_shift_div_l. pose proof (rings.preserves_0 (f:=cast AQ Q)). rewrite <- H5. apply (strictly_order_preserving (cast AQ Q)), dpos. setoid_replace (-1 * AQtoQ den) with (-AQtoQ den) by reflexivity. rewrite <- rings.preserves_negate. apply (order_preserving (cast AQ Q)), Pnd. - apply Qle_shift_div_r. pose proof (rings.preserves_0 (f:=cast AQ Q)). rewrite <- H5. apply (strictly_order_preserving (cast AQ Q)), dpos. rewrite Qmult_1_l. apply (order_preserving (cast AQ Q)), Pnd. Qed. Definition AQsin_small : msp_car AR := CRtoAR (inject_Q_CR (AQtoQ num / AQtoQ den)) + AltSeries ARsinStream sinStream_pos positive (CRsin.sinStream (AQtoQ num / AQtoQ den)) (num,den) (xH,AQtoQ num / AQtoQ den) sinStream_correct _ (sinStream_alt AQsin_small_Qprf) dpos (sinStream_zl AQsin_small_Qprf). Lemma AQsin_small_correct : 'AQsin_small = rational_sin (AQtoQ num / AQtoQ den). Proof. rewrite rational_sin_correct, <- (rational_sin_small_correct AQsin_small_Qprf). unfold AQsin_small, rational_sin_small. rewrite ARtoCR_preserves_plus. apply ucFun2_wd. pose proof CRAR_id. unfold cast in H5. unfold cast. rewrite H5. reflexivity. apply AltSeries_correct. Qed. End sin_small. Lemma AQsin_small_pos_wd : forall (n1 n2 d1 d2 : AQ) (p1 : -d1 ≤ n1 ≤ d1) (p2 : -d2 ≤ n2 ≤ d2) (d1pos : 0 < d1) (d2pos : 0 < d2), n1 = n2 -> d1 = d2 -> AQsin_small p1 d1pos = AQsin_small p2 d2pos. Proof. assert (forall x y, ARtoCR x = ARtoCR y -> x = y) as H5. { intros x y H5. exact H5. } intros. apply H5. rewrite (AQsin_small_correct p1 d1pos). rewrite (AQsin_small_correct p2 d2pos). rewrite H6, H7. reflexivity. Qed. (** Sine's range can then be extended to [[0,3^n]] by [n] applications of the identity [sin(x) = 3*sin(x/3) - 4*(sin(x/3))^3]. *) Definition AQsin_poly_fun (x : AQ) : AQ := x * (3 - 4 * x ^ (2%mc:N)). Lemma AQsin_poly_fun_correct (q : AQ) : 'AQsin_poly_fun q = sin_poly_fun ('q). Proof. unfold AQsin_poly_fun, sin_poly_fun. rewrite nat_pow_2. rewrite rings.preserves_mult, rings.preserves_minus, ?rings.preserves_mult. rewrite rings.preserves_3, rings.preserves_4. now rewrite <-(associativity _ ('q) ('q : Q)). Qed. (* AQsin_poly_fun is not uniformly continuous because of x^3, but it will only be applied to sine values in [-1,1], a range on which it is uniformly continuous. *) Lemma AQsin_poly_fun_bound_correct : forall q : AQ, msp_eq (' AQsin_poly_fun (ucFun (AQboundAbs_uc 1) q)) (sin_poly_fun (Qmax (- (1)) (Qmin 1 (' q)))). Proof. intro q. apply Qball_0. rewrite AQsin_poly_fun_correct. f_equiv. unfold AQboundAbs_uc. simpl. change ('1) with (1:AQ). rewrite ?aq_preserves_max, ?aq_preserves_min. now rewrite ?rings.preserves_negate, ?rings.preserves_1. Qed. Definition AQsin_poly_uc : msp_car (AQ_as_MetricSpace --> AQ_as_MetricSpace) := unary_uc (cast AQ (msp_car Q_as_MetricSpace)) (λ q : AQ, AQsin_poly_fun (ucFun (AQboundAbs_uc 1) q)) sin_poly_uc AQsin_poly_fun_bound_correct. Definition ARsin_poly : msp_car (AR --> AR) := uc_compose ARcompress (Cmap AQPrelengthSpace AQsin_poly_uc). Lemma ARtoCR_preserves_sin_poly (x : msp_car AR) : 'ucFun ARsin_poly x = ucFun sin_poly ('x). Proof. change ('ucFun ARcompress (ucFun (Cmap AQPrelengthSpace AQsin_poly_uc) x) = ucFun compress (ucFun (Cmap QPrelengthSpace sin_poly_uc) ('x))). rewrite ARcompress_correct, compress_correct. now apply preserves_unary_fun. Qed. (* When x = sin y, this function computes sin (y*3^n). *) Fixpoint ARsin_poly_iter (n : nat) (x : msp_car AR) : msp_car AR := match n with | O => x | S n' => ucFun ARsin_poly (ARsin_poly_iter n' x) end. Definition AQsin_bounded {n : nat} {num den : AQ} (Pnd : - (den * 3^n) ≤ num ≤ den * 3^n) (dpos : 0 < den * 3^n) : msp_car AR := ARsin_poly_iter n (AQsin_small Pnd dpos). Lemma ARsin_poly_iter_wd : forall n x y, x = y -> ARsin_poly_iter n x = ARsin_poly_iter n y. Proof. induction n. - intros. exact H5. - intros. change (ucFun ARsin_poly (ARsin_poly_iter n x) = ucFun ARsin_poly (ARsin_poly_iter n y)). rewrite (IHn x y H5). reflexivity. Qed. Lemma AQsin_bounded_correct {n : nat} {num den : AQ} (Pnd : -(den * 3^n) ≤ num ≤ den * 3^n) (dpos : 0 < den * 3^n) : 'AQsin_bounded Pnd dpos = rational_sin ('num / 'den). Proof. revert num den dpos Pnd. induction n; intros. - unfold AQsin_bounded. simpl. rewrite AQsin_small_correct. change (3^0%nat) with 1. rewrite rings.mult_1_r. reflexivity. - unfold AQsin_bounded. change (' ucFun ARsin_poly (ARsin_poly_iter n (AQsin_small Pnd dpos)) = rational_sin (' num / ' den)). rewrite ARtoCR_preserves_sin_poly. unfold AQsin_bounded in IHn. assert (le (-(den * 3 * 3 ^ n)) num /\ num ≤ den * 3 * 3 ^ n) as H5. { rewrite <- (associativity den 3). exact Pnd. } assert (0 < den * 3 * 3 ^ n) as H6. { rewrite <- (associativity den 3). exact dpos. } setoid_replace (ARsin_poly_iter n (AQsin_small Pnd dpos)) with (ARsin_poly_iter n (AQsin_small H5 H6)). rewrite IHn. change (Qdiv ('num) ('(den * 3))) with (('num : Q) / '(den * 3)). rewrite rings.preserves_mult, rings.preserves_3. rewrite dec_fields.dec_recip_distr, associativity. apply rational_sin_poly. apply ARsin_poly_iter_wd. apply AQsin_small_pos_wd. reflexivity. rewrite <- (associativity den 3). reflexivity. Qed. Definition AQsin_bound (a : AQ) : nat := CRsin.sin_bound ('a). Lemma AQsin_bound_correct : forall (a:AQ), -(1 * 3 ^ AQsin_bound a) ≤ a ≤ 1 * 3 ^ AQsin_bound a. Proof. intro a. unfold AQsin_bound. pose proof (CRsin.sin_bound_correct ('a)). split; apply (order_reflecting (cast AQ Q)). - rewrite rings.preserves_negate. destruct H4, aq_ring, ring_monoid. destruct commonoid_mon. rewrite monoid_left_id. rewrite preserves_nat_pow. rewrite rings.preserves_3. rewrite <-(int_pow_nat_pow (f:=cast nat Z)). rewrite <- (Zpower_Qpower 3). apply H5. apply (Nat2Z.inj_le 0), Nat.le_0_l. - destruct H4, aq_ring, ring_monoid. destruct commonoid_mon. rewrite monoid_left_id. rewrite preserves_nat_pow. rewrite rings.preserves_3. rewrite <-(int_pow_nat_pow (f:=cast nat Z)). rewrite <- (Zpower_Qpower 3). apply H5. apply (Nat2Z.inj_le 0), Nat.le_0_l. Qed. Lemma AQsin_bound_pos : forall a, 0 < 1 * 3 ^ AQsin_bound a. Proof. intro a. destruct H4, aq_ring, ring_monoid. destruct commonoid_mon. rewrite monoid_left_id. apply (strictly_order_reflecting (cast AQ Q)). rewrite preserves_nat_pow. rewrite rings.preserves_3. rewrite <- (int_pow_nat_pow (f:=cast nat Z)). rewrite rings.preserves_0. apply (Qpower_0_lt 3 (Z.of_nat (AQsin_bound a))). reflexivity. Qed. Definition AQsin (a:AQ) : msp_car AR := AQsin_bounded (AQsin_bound_correct a) (AQsin_bound_pos a). Lemma AQsin_correct : forall a, 'AQsin a = rational_sin ('a). Proof. intro a. mc_setoid_replace ('a : Q) with (('a / '1)%mc : Q). now apply AQsin_bounded_correct. rewrite rings.preserves_1, dec_fields.dec_recip_1. rewrite Qmult_1_r. reflexivity. Qed. Lemma AQsin_prf {a : AQ} (pA : ¬0 ≤ a) : 0 ≤ -a. Proof. apply rings.flip_nonpos_negate. now apply orders.le_flip. Qed. Definition ARsin_uc : msp_car (AQ_as_MetricSpace --> AR) := unary_complete_uc QPrelengthSpace (cast AQ (msp_car Q_as_MetricSpace)) AQsin sin_uc AQsin_correct. Definition ARsin : msp_car (AR --> AR) := Cbind AQPrelengthSpace ARsin_uc. Lemma ARtoCR_preserves_sin x : ' ucFun ARsin x = ucFun sin_slow ('x). Proof. apply preserves_unary_complete_fun. Qed. End ARsin. corn-8.20.0/reals/faster/ARtrans.v000066400000000000000000000004351473720167500167130ustar00rootroot00000000000000Require Export CoRN.reals.faster.ARArith. Require Export CoRN.reals.faster.ARroot. Require Export CoRN.reals.faster.ARexp. Require Export CoRN.reals.faster.ARsin. Require Export CoRN.reals.faster.ARcos. Require Export CoRN.reals.faster.ARpi. Require Export CoRN.reals.faster.ARarctan. corn-8.20.0/reals/faster/ApproximateRationals.v000066400000000000000000000177371473720167500215240ustar00rootroot00000000000000Require Import CoRN.algebra.RSetoid. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.UniformContinuity. Require MathClasses.implementations.stdlib_rationals MathClasses.implementations.positive_semiring_elements. From Coq Require Import Program. Require Import CoRN.model.totalorder.QposMinMax MathClasses.misc.workaround_tactics CoRN.stdlib_omissions.Q CoRN.util.Qdlog CoRN.model.metric2.Qmetric. From Coq Require Import Qabs. Require Import CoRN.classes.Qclasses CoRN.model.totalorder.QMinMax CoRN.algebra.RSetoid CoRN.metric2.MetricMorphisms MathClasses.orders.minmax MathClasses.orders.dec_fields MathClasses.theory.abs MathClasses.theory.shiftl MathClasses.theory.int_pow. Require Export MathClasses.interfaces.abstract_algebra MathClasses.interfaces.additional_operations MathClasses.interfaces.orders. (* We describe the approximate rationals as a ring that is dense in the rationals *) (* Because [Q] is ``hard-wired'' nearly everywhere in CoRN, we take the easy way and require all operations to be sound with respect to [Q]. *) Class AppDiv AQ := app_div : AQ → AQ → Z → AQ. Class AppApprox AQ := app_approx : AQ → Z → AQ. Class AppRationals AQ {e plus mult zero one inv} `{Apart AQ} `{Le AQ} `{Lt AQ} {AQtoQ : Cast AQ Q_as_MetricSpace} `{!AppInverse AQtoQ} {ZtoAQ : Cast Z AQ} `{!AppDiv AQ} `{!AppApprox AQ} `{!Abs AQ} `{!Pow AQ N} `{!ShiftL AQ Z} `{∀ x y : AQ, Decision (x = y)} `{∀ x y : AQ, Decision (x ≤ y)} : Prop := { aq_ring :: @Ring AQ e plus mult zero one inv ; aq_trivial_apart :: TrivialApart AQ ; aq_order_embed :: OrderEmbedding AQtoQ ; aq_strict_order_embed :: StrictOrderEmbedding AQtoQ ; aq_ring_morphism :: SemiRing_Morphism AQtoQ ; aq_dense_embedding :: DenseEmbedding AQtoQ ; aq_div : ∀ x y k, ball (2 ^ k) ('app_div x y k) ('x / 'y) ; aq_compress : ∀ x k, ball (2 ^ k) ('app_approx x k) ('x) ; aq_shift :: ShiftLSpec AQ Z (≪) ; aq_nat_pow :: NatPowSpec AQ N (^) ; aq_ints_mor :: SemiRing_Morphism ZtoAQ }. Lemma order_embedding_iff `{OrderEmbedding A B f} x y : x ≤ y ↔ f x ≤ f y. Proof. firstorder. Qed. Lemma strict_order_embedding_iff `{StrictOrderEmbedding A B f} x y : x < y ↔ f x < f y. Proof. firstorder. Qed. Section approximate_rationals_more. Context `{AppRationals AQ}. Lemma AQtoQ_ZtoAQ (x : Z) : cast AQ Q (cast Z AQ x) = cast Z Q x. Proof. now apply (integers.to_ring_twice _ _ _). Qed. Global Instance: Injective (cast AQ Q). Proof. destruct dense_injective. split. 2: apply _. intros. apply (injective x y). unfold equiv. simpl. rewrite H5. reflexivity. Qed. Global Instance: StrongSetoid AQ. Proof strong_setoids.dec_strong_setoid. Global Instance: StrongSetoid_Morphism (cast AQ Q). Proof strong_setoids.dec_strong_morphism (cast AQ Q). Global Instance: StrongInjective (cast AQ Q). Proof strong_setoids.dec_strong_injective (cast AQ Q). Global Instance: Injective (cast Z AQ). Proof. split; try apply _. intros x y E. apply (injective (cast Z Q)). rewrite <-2!AQtoQ_ZtoAQ. now rewrite E. Qed. Global Instance: FullPseudoSemiRingOrder (_ : Le AQ) (_ : Lt AQ). Proof. apply (projected_full_pseudo_ring_order (cast AQ Q)). apply order_embedding_iff. apply strict_order_embedding_iff. Qed. Lemma aq_opp : forall (x : AQ), '(-x) = -'x. Proof. intro x. apply (Qplus_inj_l _ _ ('x)). rewrite Qplus_opp_r. assert ('zero0 = 0%Q) by (apply rings.preserves_0). rewrite <- H5. destruct aq_ring_morphism. destruct semiringmor_plus_mor. destruct monmor_sgmor. rewrite <- preserves_sg_op. destruct sgmor_setmor. apply sm_proper. unfold equiv. destruct aq_ring, ring_group. destruct abgroup_group. apply negate_r. Qed. Lemma aq_shift_correct (x : AQ) (k : Z) : '(x ≪ k) = 'x * 2 ^ k. Proof. rewrite preserves_shiftl. apply shiftl_int_pow. Qed. Lemma aq_shift_1_correct (k : Z) : '((1:AQ) ≪ k) = 2 ^ k. Proof. now rewrite aq_shift_correct, rings.preserves_1, rings.mult_1_l. Qed. Lemma aq_shift_opp_1 (x : AQ) : '(x ≪ (-1 : Z)) = 'x / 2. Proof. now rewrite aq_shift_correct. Qed. Lemma aq_shift_opp_2 (x : AQ) : '(x ≪ (-2 : Z)) = 'x / 4. Proof. now rewrite aq_shift_correct. Qed. Lemma aq_div_dlog2 (x y : AQ) (ε : Q₊) : ball (proj1_sig ε) ('app_div x y (Qdlog2 ('ε))) ('x / 'y). Proof. eapply ball_weak_le. now apply Qpos_dlog2_spec. now apply aq_div. Qed. Lemma aq_approx_dlog2 (x : AQ) (ε : Q₊) : ball (proj1_sig ε) ('app_approx x (Qdlog2 ('ε))) ('x). Proof. eapply ball_weak_le. now apply Qpos_dlog2_spec. now apply aq_compress. Qed. Definition app_div_above (x y : AQ) (k : Z) : AQ := app_div x y k + 1 ≪ k. Lemma aq_div_above (x y : AQ) (k : Z) : ('x / 'y : Q) ≤ 'app_div_above x y k. Proof. unfold app_div_above. pose proof (aq_div x y k) as P. apply in_Qball in P. destruct P as [_ P]. rewrite rings.preserves_plus. rewrite aq_shift_correct. now rewrite rings.preserves_1, left_identity. Qed. Global Instance: IntegralDomain AQ. Proof. split; try apply _. intros E. destruct (rings.is_ne_0 (1%mc:Q)). rewrite <-(rings.preserves_1 (f:=cast AQ Q)). rewrite <-(rings.preserves_0 (f:=cast AQ Q)). now rewrite E. intros x [? [y [? E]]]. destruct (no_zero_divisors ('x : Q)). split. now apply rings.injective_ne_0. exists ('y : Q). split. now apply rings.injective_ne_0. rewrite <-rings.preserves_mult, E. apply rings.preserves_0. Qed. Lemma aq_lt_mid (x y : Q) : (x < y)%Q → { z : AQ | (x < 'z ∧ 'z < y)%Q }. Proof with auto with qarith. intros E. destruct (Qpos_sub _ _ E) as [γ Eγ]. (* We need to pick a rational [x] such that [x < 1#2]. Since we do not use this lemma for computations yet, we just pick [1#3]. However, whenever we will it might be worth to reconsider. *) exists (app_inverse (cast AQ Q) ((1#2) * (x + y)) ((1#3) * γ)%Qpos)%Q. split. apply Qlt_le_trans with (x + (1#6) * proj1_sig γ)%Q. rewrite <-(rings.plus_0_r x) at 1. apply Qplus_lt_r... assert (Qeq (x + (1 # 6) * ` γ) ((1 # 2) * (x + y) - proj1_sig ((1 # 3) * γ)%Qpos)%Q). { rewrite Eγ. simpl. ring. } rewrite H5. clear H5. simpl. apply (in_Qball (proj1_sig ((1#3)*γ)%Qpos)), ball_sym, dense_inverse. apply Qle_lt_trans with (y - (1#6) * proj1_sig γ)%Q. assert (Qeq (y - (1 # 6) * ` γ) ((1 # 2) * (x + y) + proj1_sig ((1 # 3) * γ)%Qpos)). { rewrite Eγ. simpl. ring. } rewrite H5. clear H5. simpl. apply (in_Qball (proj1_sig ((1#3)*γ)%Qpos)), ball_sym, dense_inverse. apply (Qlt_le_trans _ (y-0)). apply Qplus_lt_r. apply Qopp_Qlt_0_r... unfold Qminus. rewrite Qplus_0_r. apply Qle_refl. Defined. Instance: MeetSemiLattice_Morphism (cast AQ Q). Proof. split; try apply _; apply lattices.order_preserving_meet_sl_mor. Qed. Instance: JoinSemiLattice_Morphism (cast AQ Q). Proof. split; try apply _; apply lattices.order_preserving_join_sl_mor. Qed. Lemma aq_preserves_min x y : '(x ⊓ y) = Qmin ('x) ('y). Proof. rewrite lattices.preserves_meet; symmetry; apply Qmin_coincides. Qed. Lemma aq_preserves_max x y : '(x ⊔ y) = Qmax ('x) ('y). Proof. rewrite lattices.preserves_join; symmetry; apply Qmax_coincides. Qed. Global Program Instance AQposAsQ: Cast (AQ₊) Q := cast AQ Q ∘ cast (AQ₊) AQ. Global Program Instance AQposAsQpos: Cast (AQ₊) (Q₊) := λ x, ('x : Q). Next Obligation. destruct x as [x Ex]. simpl. posed_rewrite <-(rings.preserves_0 (f:=cast AQ Q)). now apply (strictly_order_preserving (cast AQ Q)). Qed. Lemma AQposAsQpos_preserves_1 : cast (AQ₊) (Q₊) 1 = 1. Proof. change (cast AQ Q 1 = 1). apply rings.preserves_1. Qed. Lemma AQposAsQpos_preserves_4 : cast (AQ₊) (Q₊) 4 = 4. Proof. change (cast AQ Q 4 = 4). apply rings.preserves_4. Qed. End approximate_rationals_more. corn-8.20.0/reals/faster/README.md000066400000000000000000000004661473720167500164350ustar00rootroot00000000000000The files in this directory correspond to the formalization presented in: Robbert Krebbers and Bas Spitters, _Type classes for efficient exact real arithmetic in Coq_ LMCS 9(1:1), 2013. 10.2168/LMCS-9(1:01)2013. [arXiv 1106.3448](http://arxiv.org/abs/1106.3448/) The code is available under the MIT license. corn-8.20.0/reals/iso_CReals.v000066400000000000000000001475401473720167500161110ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) (* in this file the concrete canonical isomorphism -in te sense of R_morphisms.v - between two arbitrary model of real numbers is built *) Require Export CoRN.reals.Q_dense. Require Export CoRN.reals.R_morphism. Lemma less_pres_Lim : forall (IR : CReals) (g h : R_COrdField IR), Lim g[<]Lim h -> g[<]h. Proof. do 3 intro. intro H. simpl in |- *. red in |- *. cut (SeqLimit (CS_seq IR g) (Lim g)). intro H0. cut (SeqLimit (CS_seq IR h) (Lim h)). intro H1. red in H0. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((Lim h[-]Lim g) [/]ThreeNZ) (CS_seq IR g m[-]Lim g)}. intro H2. case H2. intro N1. intro H3. red in H1. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((Lim h[-]Lim g) [/]ThreeNZ) (CS_seq IR h m[-]Lim h)}. intro H4. case H4. intro N2. intro H5. exists (N1 + N2). exists ((Lim h[-]Lim g) [/]FourNZ). apply pos_div_four. apply shift_zero_less_minus. assumption. intros. cut (AbsSmall ((Lim h[-]Lim g) [/]ThreeNZ) (CS_seq IR h n[-]Lim h)). intro. cut (AbsSmall ((Lim h[-]Lim g) [/]ThreeNZ) (CS_seq IR g n[-]Lim g)). intro. elim H7. intros H9 H10. elim H8. intros H11 H12. apply leEq_transitive with ((Lim h[-]Lim g) [/]ThreeNZ). apply mult_cancel_leEq with (Twelve:IR). astepl (nring (R:=IR) 0); apply nring_less; auto with arith. rstepl ([0][+]Three[*](Lim h[-]Lim g)). rstepr (Lim h[-]Lim g[+]Three[*](Lim h[-]Lim g)). apply plus_resp_leEq. apply shift_zero_leEq_minus; apply less_leEq; auto. apply plus_cancel_leEq_rht with (z := Lim g[-]Lim h). rstepr (CS_seq IR h n[-]Lim h[+](Lim g[-]CS_seq IR g n)). rstepl ([--]((Lim h[-]Lim g) [/]ThreeNZ)[+][--]((Lim h[-]Lim g) [/]ThreeNZ)). apply plus_resp_leEq_both. assumption. rstepr ([--](CS_seq IR g n[-]Lim g)). apply inv_resp_leEq. assumption. apply H3. apply Nat.le_trans with (m := N1 + N2). apply Nat.le_add_r. assumption. apply H5. apply Nat.le_trans with (m := N1 + N2). rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply H1. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. assumption. apply H0. apply div_resp_pos. apply pos_three. apply shift_zero_less_minus. assumption. apply Lim_Cauchy. apply Lim_Cauchy. Qed. Lemma Lim_pres_less : forall (IR : CReals) (g h : R_COrdField IR), g[<]h -> Lim g[<]Lim h. Proof. do 3 intro. intro H. apply plus_cancel_less with (z := [--](Lim g)). astepl ([0]:IR). astepr (Lim h[-]Lim g). simpl in H. red in H. case H. intro N. intro H0. case H0. intros e H1 H3. set (H2 := True) in *. (* dummy *) cut (SeqLimit (CS_seq IR g) (Lim g)). intro H4. cut (SeqLimit (CS_seq IR h) (Lim h)). intro H5. red in H4. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]ThreeNZ) (CS_seq IR g m[-]Lim g)}. intro H6. red in H5. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]ThreeNZ) (CS_seq IR h m[-]Lim h)}. intro H7. case H6. intro N1. intro H8. case H7. intro N2. intro H9. cut (AbsSmall (e [/]ThreeNZ) (CS_seq IR g (N + (N1 + N2))[-]Lim g)). intro H10. cut (AbsSmall (e [/]ThreeNZ) (CS_seq IR h (N + (N1 + N2))[-]Lim h)). intro H11. elim H10. intros H12 H13. elim H11. intros H14 H15. apply less_leEq_trans with (y := e [/]ThreeNZ). apply pos_div_three. assumption. rstepr (Lim h[-]CS_seq IR h (N + (N1 + N2))[+] (CS_seq IR h (N + (N1 + N2))[-]CS_seq IR g (N + (N1 + N2)))[+] (CS_seq IR g (N + (N1 + N2))[-]Lim g)). rstepl ([--](e [/]ThreeNZ)[+]e[+][--](e [/]ThreeNZ)). apply plus_resp_leEq_both. apply plus_resp_leEq_both. rstepr ([--](CS_seq IR h (N + (N1 + N2))[-]Lim h)). apply inv_resp_leEq. assumption. apply H3. apply Nat.le_add_r. assumption. apply H9. rewrite -> Nat.add_comm with (m := N2). rewrite -> Nat.add_shuffle3 with (m := N2). apply Nat.le_add_r. apply H8. rewrite -> Nat.add_shuffle3 with (m := N1). apply Nat.le_add_r. apply H5. apply pos_div_three. assumption. apply H4. apply pos_div_three. assumption. apply Lim_Cauchy. apply Lim_Cauchy. Qed. Lemma inj_seq_less : forall (IR : CReals) (g h : R_COrdField Q_as_COrdField), g[<]h -> (Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField g m)) (inj_Q_Cauchy IR g) :R_COrdField IR)[<] Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField h m)) (inj_Q_Cauchy IR h). Proof. do 3 intro. intro H. simpl in |- *. red in |- *. simpl in H. red in H. case H. intros N H2. case H2. intros e H1 H3. set (H0 := True) in *. (* dummy *) exists N. exists (inj_Q IR e). apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. assumption. simpl in |- *. rational. intros. simpl in |- *. apply leEq_wdr with (y := inj_Q IR (CS_seq Q_as_COrdField h n[-]CS_seq Q_as_COrdField g n)). apply inj_Q_leEq. apply H3. assumption. apply inj_Q_minus. Qed. Lemma less_inj_seq : forall (IR : CReals) (g h : R_COrdField Q_as_COrdField), (Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField g m)) (inj_Q_Cauchy IR g) :R_COrdField IR)[<] Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField h m)) (inj_Q_Cauchy IR h) -> g[<]h. Proof. do 3 intro. intro H. simpl in |- *. red in |- *. simpl in H. red in H. simpl in H. case H. intros N H2. case H2. intros e H1 H6. set (H0 := True) in *. (* dummy *) case (Q_dense_in_CReals IR e). assumption. intro q. set (H3 := True) in *. (* dummy *) intros H4 H5. exists N. exists q. apply less_inj_Q with (R1 := IR). simpl in |- *. rstepl ([0]:IR). assumption. intros. apply leEq_inj_Q with (R1 := IR). apply leEq_transitive with (y := e). apply less_leEq; assumption. apply leEq_wdr with (y := inj_Q IR (CS_seq Q_as_COrdField h n)[-] inj_Q IR (CS_seq Q_as_COrdField g n)). apply H6. assumption. apply eq_symmetric_unfolded. apply inj_Q_minus. Qed. Theorem SeqLimit_unique : forall (IR : CReals) (g : CauchySeq IR) (y : IR), SeqLimit g y -> y[=]Lim g. Proof. do 3 intro. intro H. apply not_ap_imp_eq. intro H0. case (ap_imp_less IR y (Lim g) H0). intro H1. red in H. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((Lim g[-]y) [/]ThreeNZ) (CS_seq IR g m[-]y)}. intro H2. case H2. intro N1. intro H3. cut (SeqLimit g (Lim g)). intro H4. red in H4. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((Lim g[-]y) [/]ThreeNZ) (CS_seq IR g m[-]Lim g)}. intro H5. case H5. intro N2. intro H6. apply less_irreflexive_unfolded with (x := y[-]Lim g). rstepr ([0][+](CS_seq _ g (N1 + N2)[-]Lim g)[+](y[-]CS_seq _ g (N1 + N2))). rstepl ((y[-]Lim g) [/]ThreeNZ[+](y[-]Lim g) [/]ThreeNZ[+](y[-]Lim g) [/]ThreeNZ). apply plus_resp_less_leEq. apply plus_resp_less_leEq. apply shift_div_less. apply pos_three. apply shift_minus_less; rstepr (Lim g); auto. elim (H6 (N1 + N2)); intros. rstepl ([--]((Lim g[-]y) [/]ThreeNZ)); auto. rewrite Nat.add_comm; apply Nat.le_add_r. elim (H3 (N1 + N2)); intros. apply inv_cancel_leEq. rstepr ((Lim g[-]y) [/]ThreeNZ); rstepl (g (N1 + N2)[-]y); auto. apply Nat.le_add_r. apply H4. apply pos_div_three. apply shift_zero_less_minus. assumption. apply Lim_Cauchy. apply H. apply pos_div_three. apply shift_zero_less_minus. assumption. intro. red in H. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((y[-]Lim g) [/]ThreeNZ) (CS_seq IR g m[-]y)}. intro H2. case H2. intro N1. intro H3. cut (SeqLimit g (Lim g)). intro H4. red in H4. cut {N : nat | forall m : nat, N <= m -> AbsSmall ((y[-]Lim g) [/]ThreeNZ) (CS_seq IR g m[-]Lim g)}. intro H5. case H5. intro N2. intros. apply less_irreflexive_unfolded with (x := Lim g[-]y). rstepr ([0][+](Lim g[-]CS_seq _ g (N1 + N2))[+](CS_seq _ g (N1 + N2)[-]y)). rstepl ((Lim g[-]y) [/]ThreeNZ[+](Lim g[-]y) [/]ThreeNZ[+](Lim g[-]y) [/]ThreeNZ). apply plus_resp_less_leEq. apply plus_resp_less_leEq. apply shift_div_less. apply pos_three. apply shift_minus_less; rstepr y; auto. elim (a (N1 + N2)); intros. apply inv_cancel_leEq. rstepr ((y[-]Lim g) [/]ThreeNZ); rstepl (g (N1 + N2)[-]Lim g); auto. rewrite Nat.add_comm; apply Nat.le_add_r. elim (H3 (N1 + N2)); intros. rstepl ([--]((y[-]Lim g) [/]ThreeNZ)); auto. apply Nat.le_add_r. apply H4. apply pos_div_three. apply shift_zero_less_minus. assumption. apply Lim_Cauchy. apply H. apply pos_div_three. apply shift_zero_less_minus. assumption. Qed. Lemma Lim_well_def : forall (IR : CReals) (g h : R_COrdField IR), g[=]h -> Lim g[=]Lim h. Proof. intros. apply SeqLimit_unique with (y := Lim g). red in |- *. intros e H0. cut (Not (g[#]h)). intro. cut (forall e : IR, [0][<]e -> {N : nat | forall m : nat, N <= m -> AbsSmall e (CS_seq IR g m[-]CS_seq IR h m)}). intro H2. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (CS_seq IR g m[-]CS_seq IR h m)}. intro H3. cut (SeqLimit (CS_seq IR g) (Lim g)). intro H4. red in H4. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (CS_seq IR g m[-]Lim g)}. intro H5. case H3. intro N1. intro H6. case H5. intro N2. intro H7. exists (N1 + N2). intros. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). rstepr (CS_seq IR h m[-]CS_seq IR g m[+](CS_seq IR g m[-]Lim g)). apply AbsSmall_plus. apply AbsSmall_minus. apply H6. apply Nat.le_trans with (m := N1 + N2). apply Nat.le_add_r. assumption. apply H7. apply Nat.le_trans with (m := N1 + N2). rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply H4. apply pos_div_two. assumption. apply Lim_Cauchy. apply H2. apply pos_div_two. assumption. intros. apply Eq_alt_2_1. assumption. assumption. apply eq_imp_not_ap. assumption. Qed. Lemma Lim_one_one : forall (IR : CReals) (g h : R_COrdField IR), Lim g[=]Lim h -> g[=]h. Proof. intros. apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := g) (y := h). intros. cut (SeqLimit (CS_seq IR g) (Lim g)). intro H1. red in H1. cut (SeqLimit (CS_seq IR h) (Lim h)). intro H2. red in H2. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (CS_seq IR g m[-]Lim g)}. intro H3. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (CS_seq IR h m[-]Lim h)}. intro H4. case H3. intro N1. intro H5. case H4. intro N2. intro H6. exists (N1 + N2). intros m H7. rstepl (e [/]TwoNZ[+]e [/]TwoNZ). astepr (CS_seq IR g m[-]Lim g[+](Lim h[-]CS_seq IR h m)). apply AbsSmall_plus. apply H5. apply Nat.le_trans with (m := N1 + N2). apply Nat.le_add_r. assumption. apply AbsSmall_minus. apply H6. apply Nat.le_trans with (m := N1 + N2). rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply eq_transitive_unfolded with (y := CS_seq IR g m[-]CS_seq IR h m[+](Lim h[-]Lim g)). rational. astepr (CS_seq IR g m[-]CS_seq IR h m[+][0]). apply bin_op_wd_unfolded. apply eq_reflexive_unfolded. apply cg_cancel_rht with (x := Lim g). apply eq_transitive_unfolded with (y := Lim h). apply eq_symmetric_unfolded. apply cg_cancel_mixed. astepr (Lim g). apply eq_symmetric_unfolded. assumption. apply H2. apply pos_div_two. assumption. apply H1. apply pos_div_two. assumption. apply Lim_Cauchy. apply Lim_Cauchy. Qed. Lemma inj_seq_well_def : forall (IR : CReals) (g h : R_COrdField Q_as_COrdField), g[=]h -> (Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq _ g m)) (inj_Q_Cauchy IR g) :R_COrdField IR)[=] Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq _ h m)) (inj_Q_Cauchy IR h). Proof. intros. apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq _ g m)) (inj_Q_Cauchy IR g)) (y := Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField h m)) (inj_Q_Cauchy IR h)). intros. simpl in |- *. case (Q_dense_in_CReals IR (e [/]TwoNZ)). apply pos_div_two. assumption. intro q. set (H1 := True) in *. (* dummy *) intros H2 H3. cut {N : nat | forall m : nat, N <= m -> AbsSmall q (CS_seq Q_as_COrdField g m[-]CS_seq Q_as_COrdField h m)}. intro H4. case H4. intro N. intro H5. exists N. intros. apply AbsSmall_wdr_unfolded with (y := inj_Q IR (CS_seq Q_as_COrdField g m[-]CS_seq Q_as_COrdField h m)). apply AbsSmall_leEq_trans with (inj_Q IR q). apply less_leEq; apply less_transitive_unfolded with (e [/]TwoNZ). assumption. apply pos_div_two'; auto. apply inj_Q_AbsSmall. apply H5. assumption. apply inj_Q_minus. apply Eq_alt_2_1. change (Not (g[#]h)) in |- *. apply eq_imp_not_ap. assumption. apply less_inj_Q with (R1 := IR). apply less_wdl with ([0]:IR). assumption. simpl in |- *. rational. Qed. Lemma inj_Q_one_one : forall (IR : CReals) (g h : R_COrdField Q_as_COrdField), (Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq _ g m)) (inj_Q_Cauchy IR g) :R_COrdField IR)[=] Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq _ h m)) (inj_Q_Cauchy IR h) -> g[=]h. Proof. intros. apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := g) (y := h). intros. cut {N : nat | forall m : nat, N <= m -> AbsSmall (inj_Q IR e) (CS_seq IR (Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField g m)) (inj_Q_Cauchy IR g)) m[-] CS_seq IR (Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField h m)) (inj_Q_Cauchy IR h)) m)}. intro H1. case H1. intro N. intros. exists N. intros. cut (AbsSmall (inj_Q IR e) (CS_seq IR (Build_CauchySeq IR (fun m0 : nat => inj_Q IR (CS_seq Q_as_COrdField g m0)) (inj_Q_Cauchy IR g)) m[-] CS_seq IR (Build_CauchySeq IR (fun m0 : nat => inj_Q IR (CS_seq Q_as_COrdField h m0)) (inj_Q_Cauchy IR h)) m)). intro. cut (AbsSmall (inj_Q IR e) (inj_Q IR (CS_seq Q_as_COrdField g m[-]CS_seq Q_as_COrdField h m))). intro H5. apply AbsSmall_inj_Q with IR. auto. apply AbsSmall_wdr_unfolded with (inj_Q IR (CS_seq Q_as_COrdField g m)[-] inj_Q IR (CS_seq Q_as_COrdField h m)). assumption. apply eq_symmetric_unfolded. apply inj_Q_minus. apply a. assumption. apply Eq_alt_2_1. change (Not ((Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField g m)) (inj_Q_Cauchy IR g) :R_COrdField IR)[#] Build_CauchySeq IR (fun m : nat => inj_Q IR (CS_seq Q_as_COrdField h m)) (inj_Q_Cauchy IR h))) in |- *. apply eq_imp_not_ap. assumption. apply less_wdl with (inj_Q IR [0]). apply inj_Q_less. assumption. simpl in |- *. rational. Qed. Lemma Lim_pres_plus : forall (IR : CReals) (g h : R_COrdField IR), Lim (g[+]h)[=]Lim g[+]Lim h. Proof. intros. apply eq_symmetric_unfolded. apply SeqLimit_unique with (g := g[+]h). red in |- *. simpl in |- *. intros. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (CS_seq IR g m[-]Lim g)}. intro H2. case H2. intro N1. intro H3. cut {N : nat | forall m : nat, N <= m -> AbsSmall (e [/]TwoNZ) (CS_seq IR h m[-]Lim h)}. intro H4. case H4. intro N2. intro H5. exists (N1 + N2). intros. rstepr (CS_seq IR g m[-]Lim g[+](CS_seq IR h m[-]Lim h)). rstepl (e [/]TwoNZ[+]e [/]TwoNZ). apply AbsSmall_plus. apply H3. apply Nat.le_trans with (m := N1 + N2). apply Nat.le_add_r. assumption. apply H5. apply Nat.le_trans with (m := N1 + N2). rewrite Nat.add_comm; apply Nat.le_add_r. assumption. apply (ax_Lim _ _ (crl_proof IR) h). apply pos_div_two. assumption. apply (ax_Lim _ _ (crl_proof IR) g). apply pos_div_two. assumption. Qed. Lemma G_pres_plus : forall (IR : CReals) (x y : IR), (Build_CauchySeq Q_as_COrdField (fun m : nat => G IR (x[+]y) m) (CS_seq_G IR (x[+]y)) :R_COrdField Q_as_COrdField)[=] Build_CauchySeq Q_as_COrdField (fun m : nat => G IR x m[+]G IR y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G IR x n) (fun n : nat => G IR y n) (CS_seq_G IR x) (CS_seq_G IR y)). Proof. intros. apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := Build_CauchySeq Q_as_COrdField (fun m : nat => G IR (x[+]y) m) (CS_seq_G IR (x[+]y))) (y := Build_CauchySeq Q_as_COrdField (fun m : nat => G IR x m[+]G IR y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G IR x n) (fun n : nat => G IR y n) (CS_seq_G IR x) ( CS_seq_G IR y))). intros e H. unfold CS_seq at 1 in |- *. unfold CS_seq in |- *. cut (SeqLimit (inj_Q_G_as_CauchySeq IR x) x). intro H0. cut (SeqLimit (inj_Q_G_as_CauchySeq IR y) y). intro H1. red in H0. cut {N : nat | forall m : nat, N <= m -> AbsSmall (inj_Q IR (e [/]ThreeNZ)) (CS_seq IR (inj_Q_G_as_CauchySeq IR x) m[-]x)}. intro H2. case H2. intro N1. intros. red in H1. cut {N : nat | forall m : nat, N <= m -> AbsSmall (inj_Q IR (e [/]ThreeNZ)) (CS_seq IR (inj_Q_G_as_CauchySeq IR y) m[-]y)}. intro H4. case H4. intro N2. intro H5. cut (SeqLimit (inj_Q_G_as_CauchySeq IR (x[+]y)) (x[+]y)). intro H6. red in H6. cut {N : nat | forall m : nat, N <= m -> AbsSmall (inj_Q IR (e [/]ThreeNZ)) (CS_seq IR (inj_Q_G_as_CauchySeq IR (x[+]y)) m[-](x[+]y))}. intro H7. case H7. intro K. intro H8. exists (K + (N1 + N2)). intros. apply AbsSmall_inj_Q with (R1 := IR). apply AbsSmall_wdr_unfolded with (y := inj_Q IR (G IR (x[+]y) m)[-] (inj_Q _ (G IR x m)[+]inj_Q _ (G IR y m))). rstepr (inj_Q _ (G IR (x[+]y) m)[-](x[+]y)[+](x[-]inj_Q _ (G IR x m))[+] (y[-]inj_Q _ (G IR y m))). apply AbsSmall_wdl_unfolded with (x := inj_Q IR (e [/]ThreeNZ)[+]inj_Q IR (e [/]ThreeNZ)[+] inj_Q IR (e [/]ThreeNZ)). apply AbsSmall_plus. apply AbsSmall_plus. change (AbsSmall (inj_Q IR (e [/]ThreeNZ)) (CS_seq IR (inj_Q_G_as_CauchySeq IR (x[+]y)) m[-](x[+]y))) in |- *. apply H8. apply Nat.le_trans with (m := K + (N1 + N2)). apply Nat.le_add_r. assumption. apply AbsSmall_minus. change (AbsSmall (inj_Q IR (e [/]ThreeNZ)) (CS_seq IR (inj_Q_G_as_CauchySeq IR x) m[-]x)) in |- *. apply a. apply Nat.le_trans with (m := K + (N1 + N2)). rewrite -> Nat.add_shuffle3 with (m := N1). apply Nat.le_add_r. assumption. apply AbsSmall_minus. change (AbsSmall (inj_Q IR (e [/]ThreeNZ)) (CS_seq IR (inj_Q_G_as_CauchySeq IR y) m[-]y)) in |- *. apply H5. apply Nat.le_trans with (m := K + (N1 + N2)). rewrite -> Nat.add_comm with (m := N2). rewrite -> Nat.add_shuffle3 with (m := N2). apply Nat.le_add_r. assumption. apply eq_transitive_unfolded with (y := inj_Q IR (e [/]ThreeNZ[+]e [/]ThreeNZ[+]e [/]ThreeNZ)). apply eq_transitive_unfolded with (y := inj_Q _ (e [/]ThreeNZ[+]e [/]ThreeNZ)[+]inj_Q IR (e [/]ThreeNZ)). apply bin_op_wd_unfolded. apply eq_symmetric_unfolded. apply inj_Q_plus. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply inj_Q_plus. apply inj_Q_wd. rational. apply eq_transitive_unfolded with (y := inj_Q IR (G IR (x[+]y) m)[-]inj_Q IR (G IR x m[+]G IR y m)). apply cg_minus_wd. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply inj_Q_plus. apply eq_symmetric_unfolded. apply inj_Q_minus. apply H6. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. apply div_resp_pos. apply pos_three. assumption. simpl in |- *. rational. apply x_is_SeqLimit_G. apply H1. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. apply div_resp_pos. apply pos_three. assumption. simpl in |- *. rational. apply H0. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. apply div_resp_pos. apply pos_three. assumption. simpl in |- *. rational. apply x_is_SeqLimit_G. apply x_is_SeqLimit_G. Qed. (* This theorem can be avoided but it is interesting *) Theorem nonarchemaedian_bound_for_Lim : forall (IR : CReals) (g : CauchySeq IR), {H : IR | [0][<]H | AbsSmall H (Lim g)}. Proof. intros. case (CS_seq_bounded IR (CS_seq IR g) (CS_proof IR g)). intro K. set (H := True) in *. (* dummy *) intros H0 H1. case H1. intro M. intro H2. exists ([1][+]K). apply plus_resp_pos. apply pos_one. apply leEq_not_eq. apply (AbsSmall_nonneg IR K (CS_seq IR g M)). apply H2. constructor. apply ap_symmetric_unfolded; apply pos_ap_zero; auto. cut (SeqLimit g (Lim g)). intro H3. red in H3. case (H3 [1]). apply pos_one. intro N. intros. rstepr (Lim g[-]CS_seq IR g (N + M)[+]CS_seq IR g (N + M)). apply AbsSmall_plus. apply AbsSmall_minus. apply a. apply Nat.le_add_r. apply H2. rewrite Nat.add_comm; apply Nat.le_add_r. apply Lim_Cauchy. Qed. Lemma Lim_pres_mult : forall (IR : CReals) (g h : R_COrdField IR), Lim (g[*]h)[=]Lim g[*]Lim h. Proof. intros. apply eq_symmetric_unfolded. apply SeqLimit_unique with (g := g[*]h). red in |- *. simpl in |- *. intros. case (CS_seq_bounded IR (CS_seq IR g) (CS_proof IR g)). intro K. set (H2 := True) in *. (* dummy *) intros H3 H4. case H4. intro M1. intro H5. case (nonarchemaedian_bound_for_Lim _ h). intro L. set (H6 := True) in *. (* dummy *) intros H7 H8. cut (Six[*]K[#][0]). intro H9. cut (Six[*]L[#][0]). intro H10. case (ax_Lim _ _ (crl_proof IR) g (e[/] Six[*]L[//]H10)). apply div_resp_pos. apply mult_resp_pos. apply pos_nring_S. assumption. assumption. intro N1. intro H11. case (ax_Lim _ _ (crl_proof IR) h (e[/] Six[*]K[//]H9)). apply div_resp_pos. apply mult_resp_pos. apply pos_nring_S. apply leEq_not_eq. apply (AbsSmall_nonneg IR K (CS_seq IR g M1)). apply H5. constructor. apply less_imp_ap; auto. assumption. intro N2. intro H12. exists (N1 + (N2 + M1)). intros m H13. rstepr (CS_seq IR g m[*](CS_seq IR h m[-]Lim h)[+]Lim h[*](CS_seq IR g m[-]Lim g)). rstepl (Three[*](K[*](e[/] Six[*]K[//]H9))[+]Three[*](L[*](e[/] Six[*]L[//]H10))). apply AbsSmall_plus. apply AbsSmall_mult. apply H5. apply Nat.le_trans with (m := N1 + (N2 + M1)). rewrite -> Nat.add_comm with (m := M1). rewrite -> Nat.add_shuffle3 with (m := M1). apply Nat.le_add_r. assumption. apply H12. apply Nat.le_trans with (m := N1 + (N2 + M1)). rewrite -> Nat.add_shuffle3 with (m := N2). apply Nat.le_add_r. assumption. apply AbsSmall_mult. assumption. apply H11. apply Nat.le_trans with (m := N1 + (N2 + M1)). apply Nat.le_add_r. assumption. apply Greater_imp_ap. apply mult_resp_pos. apply pos_nring_S. assumption. apply Greater_imp_ap. apply mult_resp_pos. apply pos_nring_S. apply leEq_not_eq. apply (AbsSmall_nonneg IR K (CS_seq IR g M1)). apply H5. constructor. apply less_imp_ap; auto. Qed. Lemma G_pres_mult : forall (IR : CReals) (x y : IR), (Build_CauchySeq Q_as_COrdField (fun m : nat => G IR (x[*]y) m) (CS_seq_G IR (x[*]y)) :R_COrdField Q_as_COrdField)[=] Build_CauchySeq Q_as_COrdField (fun m : nat => G IR x m[*]G IR y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq IR x)) (CS_proof _ (G_as_CauchySeq IR y))). Proof. intros. apply not_ap_imp_eq. simpl in |- *. apply Eq_alt_2_2. intros. unfold CS_seq at 1 in |- *. unfold CS_seq in |- *. cut (SeqLimit (inj_Q_G_as_CauchySeq IR x) x). intro H0. cut (SeqLimit (inj_Q_G_as_CauchySeq IR y) y). intro H1. cut (SeqLimit (inj_Q_G_as_CauchySeq IR (x[*]y)) (x[*]y)). intro H2. case (CS_seq_bounded Q_as_COrdField (G IR y) (CS_seq_G IR y)). intro K. set (H3 := True) in *. (* dummy *) intros H4 H5. case H5. intro M1. intro H6. case (nonarchemaedian_bound_for_Lim _ (inj_Q_G_as_CauchySeq IR x)). intro L. set (H7 := True) in *. (* dummy *) intros H8 H9. cut (Twelve[*]inj_Q IR K[#][0]). intro H10. cut (Twelve[*]L[#][0]). intro H11. red in H0. case (H0 (inj_Q IR e[/] Twelve[*]inj_Q IR K[//]H10)). apply div_resp_pos. apply mult_resp_pos. apply pos_nring_S. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. apply leEq_not_eq. apply (AbsSmall_nonneg Q_as_COrdField K (G IR y M1)). apply H6. constructor. apply less_imp_ap; auto. simpl in |- *. rational. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. assumption. simpl in |- *. rational. intro N1. intro H12. red in H1. case (H1 (inj_Q IR e[/] Twelve[*]L[//]H11)). apply div_resp_pos. apply mult_resp_pos. apply pos_nring_S. assumption. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. assumption. simpl in |- *. rational. intro N2. intro H13. red in H2. case (H2 (inj_Q IR e [/]TwoNZ)). apply div_resp_pos. apply pos_two. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. assumption. simpl in |- *. rational. intro N3. intro H14. exists (N1 + (N2 + (N3 + M1))). intros. apply (AbsSmall_inj_Q IR). apply AbsSmall_wdr_unfolded with (y := inj_Q IR (G IR (x[*]y) m)[-] inj_Q IR (G IR x m)[*]inj_Q IR (G IR y m)). rstepr (inj_Q IR (G IR (x[*]y) m)[-]x[*]y[+]x[*](y[-]inj_Q IR (G IR y m))[+] inj_Q IR (G IR y m)[*](x[-]inj_Q IR (G IR x m))). rstepl (inj_Q IR e [/]TwoNZ[+]Three[*](L[*](inj_Q IR e[/] Twelve[*]L[//]H11))[+] Three[*](inj_Q IR K[*](inj_Q IR e[/] Twelve[*]inj_Q IR K[//]H10))). apply AbsSmall_plus. apply AbsSmall_plus. unfold inj_Q_G_as_CauchySeq in H14. unfold CS_seq at 1 in H14. apply H14. apply Nat.le_trans with (m := N1 + (N2 + (N3 + M1))). rewrite -> Nat.add_shuffle3 with (m := N3). rewrite -> Nat.add_shuffle3 with (m := N3). apply Nat.le_add_r. assumption. apply AbsSmall_mult. apply AbsSmall_wdr_unfolded with (y := Lim (inj_Q_G_as_CauchySeq IR x)). assumption. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply AbsSmall_minus. unfold inj_Q_G_as_CauchySeq in H13. unfold CS_seq at 1 in H13. apply H13. apply Nat.le_trans with (m := N1 + (N2 + (N3 + M1))). rewrite -> Nat.add_shuffle3 with (m := N2). apply Nat.le_add_r. assumption. apply AbsSmall_mult. apply inj_Q_AbsSmall. apply H6. apply Nat.le_trans with (m := N1 + (N2 + (N3 + M1))). rewrite -> Nat.add_comm with (m := M1). rewrite -> Nat.add_shuffle3 with (m := M1). rewrite -> Nat.add_shuffle3 with (m := M1). apply Nat.le_add_r. assumption. apply AbsSmall_minus. unfold inj_Q_G_as_CauchySeq in H12. unfold CS_seq at 1 in H12. apply H12. apply Nat.le_trans with (m := N1 + (N2 + (N3 + M1))). apply Nat.le_add_r. assumption. apply eq_transitive_unfolded with (y := inj_Q IR (G IR (x[*]y) m)[-]inj_Q IR (G IR x m[*]G IR y m)). apply cg_minus_wd. apply eq_reflexive_unfolded. apply eq_symmetric_unfolded. apply inj_Q_mult. apply eq_symmetric_unfolded. apply inj_Q_minus. apply Greater_imp_ap. apply mult_resp_pos. apply pos_nring_S. assumption. apply Greater_imp_ap. apply mult_resp_pos. apply pos_nring_S. apply less_wdl with (x := inj_Q IR [0]). apply inj_Q_less. apply leEq_not_eq. apply (AbsSmall_nonneg Q_as_COrdField K (G IR y M1)). apply H6. constructor. apply less_imp_ap; auto. simpl in |- *. rational. apply x_is_SeqLimit_G. apply x_is_SeqLimit_G. apply x_is_SeqLimit_G. Qed. Section Concrete_iso_between_Creals. Variables R1 R2 : CReals. Lemma image_Cauchy12 : forall x : R1, Cauchy_prop (fun n : nat => inj_Q R2 (G R1 x n)). Proof. intros. change (Cauchy_prop (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 x) n))) in |- *. apply inj_Q_Cauchy. Qed. Lemma image_Cauchy21 : forall y : R2, Cauchy_prop (fun n : nat => inj_Q R1 (G R2 y n)). Proof. intros. change (Cauchy_prop (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 y) n))) in |- *. apply inj_Q_Cauchy. Qed. Definition image_G_as_CauchySeq12 (x : R1) := Build_CauchySeq R2 (fun n : nat => inj_Q R2 (G R1 x n)) (image_Cauchy12 x). Definition image_G_as_CauchySeq21 (y : R2) := Build_CauchySeq R1 (fun n : nat => inj_Q R1 (G R2 y n)) (image_Cauchy21 y). Definition f12 (x : R1) := Lim (image_G_as_CauchySeq12 x). Definition g21 (y : R2) := Lim (image_G_as_CauchySeq21 y). (*------- ISO FROM R1 TO R2 -------*) Theorem f12_is_inverse_g21 : forall y : R2, y[=]f12 (g21 y). Proof. intro. unfold f12 in |- *. cut (y[=]Lim (inj_Q_G_as_CauchySeq R2 y)). intro. apply eq_transitive_unfolded with (y := Lim (inj_Q_G_as_CauchySeq R2 y)). assumption. apply Lim_well_def. unfold inj_Q_G_as_CauchySeq in |- *. unfold image_G_as_CauchySeq12 in |- *. change ((Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 y) m)) (CS_seq_inj_Q_G R2 y) :R_COrdField R2)[=] Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 (g21 y)) n)) (image_Cauchy12 (g21 y))) in |- *. change ((Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 y) m)) (inj_Q_Cauchy R2 (G_as_CauchySeq R2 y)) :R_COrdField R2)[=] Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 (g21 y)) n)) (inj_Q_Cauchy R2 (G_as_CauchySeq R1 (g21 y)))) in |- *. apply inj_seq_well_def with (g := G_as_CauchySeq R2 y) (h := G_as_CauchySeq R1 (g21 y)). apply inj_Q_one_one with (IR := R1). change ((Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 y m)) (image_Cauchy21 y) :R_COrdField R1)[=] Build_CauchySeq R1 (fun n : nat => inj_Q R1 (G R1 (g21 y) n)) (CS_seq_inj_Q_G R1 (g21 y))) in |- *. change ((image_G_as_CauchySeq21 y:R_COrdField R1)[=] inj_Q_G_as_CauchySeq R1 (g21 y)) in |- *. apply Lim_one_one with (IR := R1). apply eq_transitive_unfolded with (y := g21 y). apply eq_reflexive_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply SeqLimit_unique. apply x_is_SeqLimit_G. Qed. Theorem f12_is_surjective : map_is_surjective R1 R2 f12. Proof. intro. exists (g21 y). apply f12_is_inverse_g21. Qed. Theorem f12_strong_ext : fun_strext f12. Proof. intros. red in |- *. unfold f12 in |- *. intros x y H. case (ap_imp_less R2 (Lim (image_G_as_CauchySeq12 x)) (Lim (image_G_as_CauchySeq12 y)) H). intro. apply less_imp_ap. apply less_wdl with (x := Lim (inj_Q_G_as_CauchySeq R1 x)). apply less_wdr with (y := Lim (inj_Q_G_as_CauchySeq R1 y)). apply Lim_pres_less. unfold inj_Q_G_as_CauchySeq in |- *. change ((Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 x) m)) (inj_Q_Cauchy R1 (G_as_CauchySeq R1 x)) :R_COrdField R1)[<] Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 y) n)) (inj_Q_Cauchy R1 (G_as_CauchySeq R1 y))) in |- *. apply inj_seq_less. apply less_inj_seq with (IR := R2). change ((image_G_as_CauchySeq12 x:R_COrdField R2)[<] (image_G_as_CauchySeq12 y:R_COrdField R2)) in |- *. apply less_pres_Lim. assumption. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. intro. apply Greater_imp_ap. apply less_wdl with (x := Lim (inj_Q_G_as_CauchySeq R1 y)). apply less_wdr with (y := Lim (inj_Q_G_as_CauchySeq R1 x)). apply Lim_pres_less. unfold inj_Q_G_as_CauchySeq in |- *. change ((Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 y) m)) (inj_Q_Cauchy R1 (G_as_CauchySeq R1 y)) :R_COrdField R1)[<] Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 x) n)) (inj_Q_Cauchy R1 (G_as_CauchySeq R1 x))) in |- *. apply inj_seq_less. apply less_inj_seq with (IR := R2). change ((image_G_as_CauchySeq12 y:R_COrdField R2)[<] (image_G_as_CauchySeq12 x:R_COrdField R2)) in |- *. apply less_pres_Lim. assumption. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. Qed. Theorem f12_pres_less : fun_pres_relation R1 R2 f12 (cof_less (c:=R1)) (cof_less (c:=R2)). Proof. red in |- *. intros. unfold f12 in |- *. apply Lim_pres_less. unfold image_G_as_CauchySeq12 in |- *. change ((Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 x) m)) (inj_Q_Cauchy R2 (G_as_CauchySeq R1 x)) :R_COrdField R2)[<] Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 y) n)) (inj_Q_Cauchy R2 (G_as_CauchySeq R1 y))) in |- *. apply inj_seq_less. apply less_inj_seq with (IR := R1). change ((inj_Q_G_as_CauchySeq R1 x:R_COrdField R1)[<] (inj_Q_G_as_CauchySeq R1 y:R_COrdField R1)) in |- *. apply less_pres_Lim. apply less_wdl with (x := x). apply less_wdr with (y := y). assumption. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply SeqLimit_unique. apply x_is_SeqLimit_G. Qed. Theorem f12_pres_plus : fun_pres_bin_fun R1 R2 f12 (csg_op (c:=R1)) (csg_op (c:=R2)). Proof. red in |- *. intros. unfold f12 in |- *. apply eq_transitive_unfolded with (y := Lim ((image_G_as_CauchySeq12 x:R_COrdField R2)[+] image_G_as_CauchySeq12 y)). apply Lim_well_def. unfold image_G_as_CauchySeq12 in |- *. apply eq_transitive_unfolded with (S := R_COrdField R2:CSetoid) (y := Build_CauchySeq R2 (fun m : nat => inj_Q R2 (G R1 x m[+]G R1 y m)) (inj_Q_Cauchy R2 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[+]G R1 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R1 x n) (fun n : nat => G R1 y n) (CS_seq_G R1 x) (CS_seq_G R1 y)))) :R_COrdField R2). change ((Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 (x[+]y)) n)) (inj_Q_Cauchy R2 (G_as_CauchySeq R1 (x[+]y))) :R_COrdField R2)[=] Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[+]G R1 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R1 x n) (fun n : nat => G R1 y n) (CS_seq_G R1 x) ( CS_seq_G R1 y))) m)) (inj_Q_Cauchy R2 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[+]G R1 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R1 x n) (fun n : nat => G R1 y n) (CS_seq_G R1 x) ( CS_seq_G R1 y))))) in |- *. apply inj_seq_well_def. unfold G_as_CauchySeq in |- *. apply G_pres_plus. (* Cauchy inj_Q plus *) apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := Build_CauchySeq R2 (fun m : nat => inj_Q R2 (G R1 x m[+]G R1 y m)) (inj_Q_Cauchy R2 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[+]G R1 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R1 x n) (fun n : nat => G R1 y n) (CS_seq_G R1 x) (CS_seq_G R1 y)))) :R_COrdField R2) (y := Build_CauchySeq R2 (fun m : nat => inj_Q R2 (G R1 x m)[+]inj_Q R2 (G R1 y m)) (CS_seq_plus R2 (fun n : nat => inj_Q R2 (G R1 x n)) (fun n : nat => inj_Q R2 (G R1 y n)) ( image_Cauchy12 x) (image_Cauchy12 y)) :R_COrdField R2). intros. exists 0. intros. unfold CS_seq in |- *. apply AbsSmall_wdr_unfolded with (y := [0]:R2). split. rstepr ([--]([0]:R2)). apply inv_resp_leEq. apply less_leEq. assumption. apply less_leEq. assumption. apply cg_cancel_rht with (x := inj_Q R2 (G R1 x m)[+]inj_Q R2 (G R1 y m)). astepl (inj_Q R2 (G R1 x m)[+]inj_Q R2 (G R1 y m)). apply eq_transitive_unfolded with (y := inj_Q R2 (G R1 x m[+]G R1 y m)). apply eq_symmetric_unfolded. apply inj_Q_plus. apply cg_cancel_mixed. (* End of Cauchy inj_Q plus *) apply Lim_pres_plus. Qed. Theorem f12_pres_mult : fun_pres_bin_fun R1 R2 f12 (cr_mult (c:=R1)) (cr_mult (c:=R2)). Proof. red in |- *. intros. unfold f12 in |- *. apply eq_transitive_unfolded with (y := Lim ((image_G_as_CauchySeq12 x:R_COrdField R2)[*] image_G_as_CauchySeq12 y)). apply Lim_well_def. unfold image_G_as_CauchySeq12 in |- *. apply eq_transitive_unfolded with (S := R_COrdField R2:CSetoid) (y := Build_CauchySeq R2 (fun m : nat => inj_Q R2 (G R1 x m[*]G R1 y m)) (inj_Q_Cauchy R2 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[*]G R1 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R1 x)) (CS_proof _ (G_as_CauchySeq R1 y))))) :R_COrdField R2). change ((Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 (x[*]y)) n)) (inj_Q_Cauchy R2 (G_as_CauchySeq R1 (x[*]y))) :R_COrdField R2)[=] Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[*]G R1 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R1 x)) (CS_proof _ (G_as_CauchySeq R1 y)))) m)) (inj_Q_Cauchy R2 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[*]G R1 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R1 x)) (CS_proof _ (G_as_CauchySeq R1 y)))))) in |- *. apply inj_seq_well_def. unfold G_as_CauchySeq in |- *. change ((Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 (x[*]y) m) (CS_seq_G R1 (x[*]y)) :R_COrdField Q_as_COrdField)[=] Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[*]G R1 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R1 x)) (CS_proof _ (G_as_CauchySeq R1 y)))) in |- *. apply G_pres_mult. (* Cauchy inj_Q mult *) apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := Build_CauchySeq R2 (fun m : nat => inj_Q R2 (G R1 x m[*]G R1 y m)) (inj_Q_Cauchy R2 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R1 x m[*]G R1 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof Q_as_COrdField (G_as_CauchySeq R1 x)) (CS_proof Q_as_COrdField (G_as_CauchySeq R1 y)))))) (y := Build_CauchySeq R2 (fun m : nat => inj_Q R2 (G R1 x m)[*]inj_Q R2 (G R1 y m)) (CS_seq_mult R2 _ _ (CS_proof R2 (image_G_as_CauchySeq12 x)) (CS_proof R2 (image_G_as_CauchySeq12 y)))). intros. exists 0. intros. unfold CS_seq in |- *. apply AbsSmall_wdr_unfolded with (y := [0]:R2). split. rstepr ([--]([0]:R2)). apply inv_resp_leEq. apply less_leEq. assumption. apply less_leEq. assumption. apply cg_cancel_rht with (x := inj_Q R2 (G R1 x m)[*]inj_Q R2 (G R1 y m)). astepl (inj_Q R2 (G R1 x m)[*]inj_Q R2 (G R1 y m)). apply eq_transitive_unfolded with (y := inj_Q R2 (G R1 x m[*]G R1 y m)). apply eq_symmetric_unfolded. apply inj_Q_mult. apply cg_cancel_mixed. (* End of Cauchy inj_Q mult *) apply Lim_pres_mult. Qed. (*--------- ISO FROM R2 TO R1 ---------*) Theorem g21_is_inverse_f12 : forall y : R1, y[=]g21 (f12 y). Proof. intro. unfold g21 in |- *. cut (y[=]Lim (inj_Q_G_as_CauchySeq R1 y)). intro. apply eq_transitive_unfolded with (y := Lim (inj_Q_G_as_CauchySeq R1 y)). assumption. apply Lim_well_def. unfold inj_Q_G_as_CauchySeq in |- *. unfold image_G_as_CauchySeq21 in |- *. change ((Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 y) m)) (CS_seq_inj_Q_G R1 y) :R_COrdField R1)[=] Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 (f12 y)) n)) (image_Cauchy21 (f12 y))) in |- *. change ((Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R1 y) m)) (inj_Q_Cauchy R1 (G_as_CauchySeq R1 y)) :R_COrdField R1)[=] Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 (f12 y)) n)) (inj_Q_Cauchy R1 (G_as_CauchySeq R2 (f12 y)))) in |- *. apply inj_seq_well_def with (g := G_as_CauchySeq R1 y) (h := G_as_CauchySeq R2 (f12 y)). apply inj_Q_one_one with (IR := R2). change ((image_G_as_CauchySeq12 y:R_COrdField R2)[=] inj_Q_G_as_CauchySeq R2 (f12 y)) in |- *. apply Lim_one_one with (IR := R2). apply eq_transitive_unfolded with (y := f12 y). change (f12 y[=]f12 y) in |- *. apply eq_reflexive_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply SeqLimit_unique. apply x_is_SeqLimit_G. Qed. Theorem g21_is_surjective : map_is_surjective R2 R1 g21. Proof. intro. exists (f12 y). apply g21_is_inverse_f12. Qed. Theorem g21_strong_ext : fun_strext g21. Proof. intros. red in |- *. unfold g21 in |- *. intros x y H. case (ap_imp_less R1 (Lim (image_G_as_CauchySeq21 x)) (Lim (image_G_as_CauchySeq21 y)) H). intro. apply less_imp_ap. apply less_wdl with (x := Lim (inj_Q_G_as_CauchySeq R2 x)). apply less_wdr with (y := Lim (inj_Q_G_as_CauchySeq R2 y)). apply Lim_pres_less. unfold inj_Q_G_as_CauchySeq in |- *. change ((Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 x) m)) (inj_Q_Cauchy R2 (G_as_CauchySeq R2 x)) :R_COrdField R2)[<] Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 y) n)) (inj_Q_Cauchy R2 (G_as_CauchySeq R2 y))) in |- *. apply inj_seq_less. apply less_inj_seq with (IR := R1). change ((image_G_as_CauchySeq21 x:R_COrdField R1)[<] (image_G_as_CauchySeq21 y:R_COrdField R1)) in |- *. apply less_pres_Lim. assumption. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. intro. apply Greater_imp_ap. apply less_wdl with (x := Lim (inj_Q_G_as_CauchySeq R2 y)). apply less_wdr with (y := Lim (inj_Q_G_as_CauchySeq R2 x)). apply Lim_pres_less. unfold inj_Q_G_as_CauchySeq in |- *. change ((Build_CauchySeq R2 (fun m : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 y) m)) (inj_Q_Cauchy R2 (G_as_CauchySeq R2 y)) :R_COrdField R2)[<] Build_CauchySeq R2 (fun n : nat => inj_Q R2 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 x) n)) (inj_Q_Cauchy R2 (G_as_CauchySeq R2 x))) in |- *. apply inj_seq_less. apply less_inj_seq with (IR := R1). change ((image_G_as_CauchySeq21 y:R_COrdField R1)[<] (image_G_as_CauchySeq21 x:R_COrdField R1)) in |- *. apply less_pres_Lim. assumption. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply eq_symmetric_unfolded. apply SeqLimit_unique. apply x_is_SeqLimit_G. Qed. Theorem g21_pres_less : fun_pres_relation R2 R1 g21 (cof_less (c:=R2)) (cof_less (c:=R1)). Proof. red in |- *. intros. unfold g21 in |- *. apply Lim_pres_less. unfold image_G_as_CauchySeq21 in |- *. change ((Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 x) m)) (inj_Q_Cauchy R1 (G_as_CauchySeq R2 x)) :R_COrdField R1)[<] Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 y) n)) (inj_Q_Cauchy R1 (G_as_CauchySeq R2 y))) in |- *. apply inj_seq_less. apply less_inj_seq with (IR := R2). change ((inj_Q_G_as_CauchySeq R2 x:R_COrdField R2)[<] (inj_Q_G_as_CauchySeq R2 y:R_COrdField R2)) in |- *. apply less_pres_Lim. apply less_wdl with (x := x). apply less_wdr with (y := y). assumption. apply SeqLimit_unique. apply x_is_SeqLimit_G. apply SeqLimit_unique. apply x_is_SeqLimit_G. Qed. Theorem g21_pres_plus : fun_pres_bin_fun R2 R1 g21 (csg_op (c:=R2)) (csg_op (c:=R1)). Proof. red in |- *. intros. unfold g21 in |- *. apply eq_transitive_unfolded with (y := Lim ((image_G_as_CauchySeq21 x:R_COrdField R1)[+] image_G_as_CauchySeq21 y)). apply Lim_well_def. unfold image_G_as_CauchySeq21 in |- *. apply eq_transitive_unfolded with (S := R_COrdField R1:CSetoid) (y := Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 x m[+]G R2 y m)) (inj_Q_Cauchy R1 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[+]G R2 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R2 x n) (fun n : nat => G R2 y n) (CS_seq_G R2 x) (CS_seq_G R2 y)))) :R_COrdField R1). change ((Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 (x[+]y)) n)) (inj_Q_Cauchy R1 (G_as_CauchySeq R2 (x[+]y))) :R_COrdField R1)[=] Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[+]G R2 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R2 x n) (fun n : nat => G R2 y n) (CS_seq_G R2 x) ( CS_seq_G R2 y))) m)) (inj_Q_Cauchy R1 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[+]G R2 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R2 x n) (fun n : nat => G R2 y n) (CS_seq_G R2 x) ( CS_seq_G R2 y))))) in |- *. apply inj_seq_well_def. unfold G_as_CauchySeq in |- *. apply G_pres_plus. (* Cauchy inj_Q plus *) apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 x m[+]G R2 y m)) (inj_Q_Cauchy R1 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[+]G R2 y m) (CS_seq_plus Q_as_COrdField (fun n : nat => G R2 x n) (fun n : nat => G R2 y n) (CS_seq_G R2 x) (CS_seq_G R2 y)))) :R_COrdField R1) (y := Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 x m)[+]inj_Q R1 (G R2 y m)) (CS_seq_plus R1 (fun n : nat => inj_Q R1 (G R2 x n)) (fun n : nat => inj_Q R1 (G R2 y n)) ( image_Cauchy21 x) (image_Cauchy21 y)) :R_COrdField R1). intros. exists 0. intros. unfold CS_seq in |- *. apply AbsSmall_wdr_unfolded with (y := [0]:R1). split. rstepr ([--]([0]:R1)). apply inv_resp_leEq. apply less_leEq. assumption. apply less_leEq. assumption. apply cg_cancel_rht with (x := inj_Q R1 (G R2 x m)[+]inj_Q R1 (G R2 y m)). astepl (inj_Q R1 (G R2 x m)[+]inj_Q R1 (G R2 y m)). apply eq_transitive_unfolded with (y := inj_Q R1 (G R2 x m[+]G R2 y m)). apply eq_symmetric_unfolded. apply inj_Q_plus. apply cg_cancel_mixed. (* End of Cauchy inj_Q plus *) apply Lim_pres_plus. Qed. Theorem g21_pres_mult : fun_pres_bin_fun R2 R1 g21 (cr_mult (c:=R2)) (cr_mult (c:=R1)). Proof. red in |- *. intros. unfold g21 in |- *. apply eq_transitive_unfolded with (y := Lim ((image_G_as_CauchySeq21 x:R_COrdField R1)[*] image_G_as_CauchySeq21 y)). apply Lim_well_def. unfold image_G_as_CauchySeq21 in |- *. apply eq_transitive_unfolded with (S := R_COrdField R1:CSetoid) (y := Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 x m[*]G R2 y m)) (inj_Q_Cauchy R1 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[*]G R2 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R2 x)) (CS_proof _ (G_as_CauchySeq R2 y))))) :R_COrdField R1). change ((Build_CauchySeq R1 (fun n : nat => inj_Q R1 (CS_seq Q_as_COrdField (G_as_CauchySeq R2 (x[*]y)) n)) (inj_Q_Cauchy R1 (G_as_CauchySeq R2 (x[*]y))) :R_COrdField R1)[=] Build_CauchySeq R1 (fun m : nat => inj_Q R1 (CS_seq Q_as_COrdField (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[*]G R2 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R2 x)) (CS_proof _ (G_as_CauchySeq R2 y)))) m)) (inj_Q_Cauchy R1 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[*]G R2 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R2 x)) (CS_proof _ (G_as_CauchySeq R2 y)))))) in |- *. apply inj_seq_well_def. unfold G_as_CauchySeq in |- *. change ((Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 (x[*]y) m) (CS_seq_G R2 (x[*]y)) :R_COrdField Q_as_COrdField)[=] Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[*]G R2 y m) (CS_seq_mult Q_as_COrdField _ _ (CS_proof _ (G_as_CauchySeq R2 x)) (CS_proof _ (G_as_CauchySeq R2 y)))) in |- *. apply G_pres_mult. (* Cauchy inj_Q mult *) apply not_ap_imp_eq. apply Eq_alt_2_2 with (x := Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 x m[*]G R2 y m)) (inj_Q_Cauchy R1 (Build_CauchySeq Q_as_COrdField (fun m : nat => G R2 x m[*]G R2 y m) (CS_seq_mult Q_as_COrdField (G_as_CauchySeq R2 x) (G_as_CauchySeq R2 y) (CS_proof Q_as_COrdField (G_as_CauchySeq R2 x)) (CS_proof Q_as_COrdField (G_as_CauchySeq R2 y)))))) (y := Build_CauchySeq R1 (fun m : nat => inj_Q R1 (G R2 x m)[*]inj_Q R1 (G R2 y m)) (CS_seq_mult R1 (image_G_as_CauchySeq21 x) (image_G_as_CauchySeq21 y) (CS_proof R1 (image_G_as_CauchySeq21 x)) (CS_proof R1 (image_G_as_CauchySeq21 y)))). intros. exists 0. intros. unfold CS_seq in |- *. apply AbsSmall_wdr_unfolded with (y := [0]:R1). split. rstepr ([--]([0]:R1)). apply inv_resp_leEq. apply less_leEq. assumption. apply less_leEq. assumption. apply cg_cancel_rht with (x := inj_Q R1 (G R2 x m)[*]inj_Q R1 (G R2 y m)). astepl (inj_Q R1 (G R2 x m)[*]inj_Q R1 (G R2 y m)). apply eq_transitive_unfolded with (y := inj_Q R1 (G R2 x m[*]G R2 y m)). apply eq_symmetric_unfolded. apply inj_Q_mult. apply cg_cancel_mixed. (* End of Cauchy inj_Q mult *) apply Lim_pres_mult. Qed. (* Building Homomorphisms out of f12 and g21 *) Definition f12_as_Homomorphism := simplified_Homomorphism R1 R2 f12 f12_strong_ext f12_pres_less f12_pres_plus f12_pres_mult f12_is_surjective. Definition g21_as_Homomorphism := simplified_Homomorphism R2 R1 g21 g21_strong_ext g21_pres_less g21_pres_plus g21_pres_mult g21_is_surjective. Lemma f12_inverse_lft : map_is_id R2 (Compose R2 R1 R2 g21_as_Homomorphism f12_as_Homomorphism). Proof. red in |- *. intros. simpl in |- *. apply eq_symmetric_unfolded. apply f12_is_inverse_g21. Qed. Lemma g21_inverse_rht : map_is_id R1 (Compose R1 R2 R1 f12_as_Homomorphism g21_as_Homomorphism). Proof. red in |- *. intros. simpl in |- *. apply eq_symmetric_unfolded. apply g21_is_inverse_f12. Qed. Definition Canonic_Isomorphism_between_CReals := Build_Isomorphism R1 R2 f12_as_Homomorphism g21_as_Homomorphism f12_inverse_lft g21_inverse_rht. End Concrete_iso_between_Creals. (* end hide *) corn-8.20.0/reals/stdlib/000077500000000000000000000000001473720167500151455ustar00rootroot00000000000000corn-8.20.0/reals/stdlib/CMTDirac.v000066400000000000000000000070541473720167500167300ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Dirac measure at zero. *) From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveLimits. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. Require Import ConstructivePartialFunctions. Require Import CMTbase. Local Open Scope ConstructiveReals. (* The elementary functions for the Dirac measure are the functions defined at 0. *) Definition DiracElemFunc {R : ConstructiveReals} : FunctionRieszSpace. Proof. apply (Build_FunctionRieszSpace (CRcarrier R) R (fun f => Domain f 0)). - intros. destruct H, p. exact (d _ H0). - intros. split; assumption. - intros. exact H. - intros. exact H. - intros. exact H. Defined. Definition DiracOneFunc {R : ConstructiveReals} : @PartialFunction R (CRcarrier R) := Build_PartialFunctionXY (CRcarrier R) (CRcarrier R) (CReq R) (fun x => x == 0) (fun x xD => 1) (fun x p q => CReq_refl _). Definition DiracIntegrationSpace {R : ConstructiveReals} : IntegrationSpace. Proof. apply (Build_IntegrationSpace DiracElemFunc (fun f fL => partialApply f 0 fL) (* Dirac elementary integral *) (fun f g fL gL => CReq_refl _) (fun a f fL => CReq_refl _) DiracOneFunc (@CReq_refl R _)). - reflexivity. - intros f fn fL fnL fnNonNeg H. exists (Build_CommonPointFunSeq R _ f fn 0 fL fnL). simpl. exact H. - split. + intros p. destruct (CRup_nat (partialApply f 0 fL)) as [n H]. exists n. intros. unfold XminConst, Xop, partialApply. rewrite (DomainProp _ _ _ fL), CRmin_left. rewrite CRabs_right. unfold CRminus. rewrite CRplus_opp_r. apply CR_of_Q_le. discriminate. unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl. apply (CRle_trans _ (CR_of_Q R (Z.of_nat n # 1))). apply CRlt_asym, H. apply CR_of_Q_le. unfold Qle. simpl. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, H0. + intros p. exists (Pos.to_nat p). intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. apply (CRle_trans _ (CR_of_Q R (1 # Pos.of_nat (S i)))). apply CRmin_r. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (Nat.le_trans _ _ _ H). apply le_S, Nat.le_refl. discriminate. apply CRmin_glb. apply CRabs_pos. apply CR_of_Q_le. discriminate. Defined. corn-8.20.0/reals/stdlib/CMTFullSets.v000066400000000000000000002553451473720167500174570ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* Following the invariance of the integral with respect to the representation, we now precisely define full sets, and prove that 2 functions equal on a full set have the same integral. *) From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveCauchyAbs. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Require Import ConstructiveDiagonal. Require Import ConstructivePartialFunctions. Require Import CMTbase. Require Import CMTIntegrableFunctions. Local Open Scope ConstructiveReals. (* A full set of the integration space IS is a subset of X (ElemFunc IS) that contains the domain of an integrable function. In other words, a property P of an integration space IS holds almost everywhere when there is an integrable function h on which domain P holds. *) Definition almost_everywhere {IS : IntegrationSpace} (P : X (ElemFunc IS) -> Type) : Type := { h : PartialFunction (X (ElemFunc IS)) & prod (IntegrableFunction h) (forall (x:X (ElemFunc IS)), Domain h x -> P x) }. (* We start with a lemma to help prove that sets are full : it suffices that they contain a countable intersection of domains of integrable functions. This is the complement of the usual property about Lebesgue null sets : a countable union of null sets is null. *) Definition diagSeqL : forall (IS : IntegrationSpace) (fnk : nat -> nat -> PartialFunction (X (ElemFunc IS))) (fnkL : forall n k: nat, L (ElemFunc IS) (fnk n k)) (p : nat), L (ElemFunc IS) (diagSeq fnk p). Proof. intros. unfold diagSeq. destruct (diagPlaneInv p). apply fnkL. Defined. Definition diagSeqDomain {R : ConstructiveReals} (X : Set) (fnk : nat -> nat -> @PartialFunction R X) (x : X) (xn : forall p:nat, Domain (diagSeq fnk p) x) (n k : nat) : Domain (fnk n k) x. Proof. unfold diagSeq in xn. pose (xn (diagPlane n k)). rewrite diagPlaneInject in d. exact d. Defined. Definition countable_representation (IS : IntegrationSpace) (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (n : nat) : { intRepres : IntegralRepresentation & prod (DomainInclusion (XinfiniteSumAbs (IntFn intRepres)) f) (IntAbsSum intRepres <= CRpow (CR_of_Q _ (1#2)) n) }. Proof. destruct fInt as [[fnk fnkL sumAbsIFnk] [injF restrict]]. unfold IntFn in restrict, injF. assert (0 < (1 + sumAbsIFnk)) as denomPos. { apply (CRlt_le_trans 0 (1+0)). rewrite CRplus_0_r. apply CRzero_lt_one. apply CRplus_le_compat_l. apply (series_cv_nonneg (fun k : nat => Iabs (fnk k) (fnkL k))). intro n0. apply integralPositive. intros x xdf. rewrite applyXabs. apply CRabs_pos. assumption. } assert (series_cv (fun k : nat => Iabs (Xscale (CRpow (CR_of_Q _ (1#2)) n * CRinv _ (1 + sumAbsIFnk) (inr denomPos)) (fnk k)) (LscaleStable (ElemFunc IS) _ (fnk k) (fnkL k))) (sumAbsIFnk * (CRpow (CR_of_Q _ (1#2)) n * CRinv _ (1 + sumAbsIFnk) (inr denomPos)))) as H. { apply (series_cv_eq (fun b : nat => Iabs (fnk b) (fnkL b) * (CRpow (CR_of_Q _ (1#2)) n * CRinv _ (1 + sumAbsIFnk) (inr denomPos)))). intro k. rewrite IabsHomogeneous. rewrite CRmult_comm. apply CRmult_morph. 2: reflexivity. rewrite CRabs_right. reflexivity. apply CRlt_asym. apply CRmult_lt_0_compat. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. apply CRinv_0_lt_compat. exact denomPos. apply series_cv_scale. assumption. } exists (Build_IntegralRepresentation IS (fun k : nat => Xscale (CRpow (CR_of_Q _ (1#2)) n * CRinv _ (1 + sumAbsIFnk) (inr denomPos)) (fnk k)) (fun k => LscaleStable _ _ (fnk k) (fnkL k)) (sumAbsIFnk * (CRpow (CR_of_Q _ (1#2)) n * CRinv _ (1 + sumAbsIFnk) (inr denomPos))) H). assert (CRapart _ (1 + sumAbsIFnk) 0) as denomNonZero. { right. exact denomPos. } split. - (* Inclusion of domains *) intros x xdf. unfold IntFn in xdf. assert (CRapart _ (CRpow (CR_of_Q _ (1#2)) n * CRinv _ (1 + sumAbsIFnk) (inr denomPos)) 0) as ddenomNonZero. { right. apply CRmult_lt_0_compat. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. apply CRinv_0_lt_compat. exact denomPos. } destruct (domainInfiniteSumAbsScaleIncReverse _ _ _ x xdf ddenomNonZero) as [y _]. exact (injF x y). - (* Majoration of the abs integral *) unfold IntAbsSum. rewrite CRmult_comm. rewrite <- (CRmult_1_r (CRpow (CR_of_Q _ (1 # 2)) n)). do 2 rewrite CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. rewrite CRmult_1_l. apply CRlt_asym. apply (CRmult_lt_reg_l (1+sumAbsIFnk)). assumption. rewrite <- CRmult_assoc. rewrite CRinv_r. rewrite CRmult_1_r. rewrite CRmult_1_l. rewrite <- (CRplus_0_l sumAbsIFnk). rewrite <- CRplus_assoc. apply CRplus_lt_compat_r. rewrite CRplus_0_r. apply CRzero_lt_one. Qed. Lemma partialApplyEq : forall {R : ConstructiveReals} (X : Set) (f g : @PartialFunction R X) (x : X) (xD : Domain f x) (xG : Domain g x), f = g -> (partialApply f x xD == partialApply g x xG). Proof. intros. subst g. apply DomainProp. Qed. Definition domainInfiniteSumAbsDiag {R : ConstructiveReals } (X : Set) (fnk : nat -> nat -> @PartialFunction R X) (n : nat) : DomainInclusion (XinfiniteSumAbs (diagSeq fnk)) (XinfiniteSumAbs (fnk n)). Proof. intros x xdf. assert (forall k, (let (n, k) := diagPlaneInv (diagPlane n k) in fnk n k) = (fnk n k)) as H. { intro k. rewrite diagPlaneInject. reflexivity. } assert (forall k:nat, Domain (fnk n k) x) as xLine. { intro k. destruct xdf as [xn _]. unfold diagSeq in xn. specialize (H k). specialize (xn (diagPlane n k)). rewrite H in xn. exact xn. } destruct xdf as [xnDiag cvDiag]. assert (forall a b:nat, lt a b -> lt (diagPlane n a) (diagPlane n b)). { intros. unfold diagPlane. apply Nat.add_lt_le_mono. assumption. apply Nat.div_le_mono. auto. apply Nat.mul_le_mono. apply Nat.add_le_mono. apply Nat.le_refl. unfold lt in H0. apply (Nat.le_trans _ (S a)). apply le_S. apply Nat.le_refl. assumption. apply le_n_S. apply Nat.add_le_mono. apply Nat.le_refl. unfold lt in H0. apply (Nat.le_trans _ (S a)). apply le_S. apply Nat.le_refl. assumption. } pose proof (CR_complete R _ cvDiag) as [lim cvlim]. destruct (SubSeriesCv (fun k : nat => CRabs _ (partialApply (diagSeq fnk k) x (xnDiag k))) (exist _ (fun k => diagPlane n k) H0) lim) as [y i]. apply cvlim. intros. apply CRabs_pos. simpl in i. apply (domainInfiniteSumAbsInc _ x xLine y). apply (series_cv_eq (fun n0 : nat => CRabs _ (partialApply (diagSeq fnk (diagPlane n n0)) x (xnDiag (diagPlane n n0))))). - intros. apply CRabs_morph. apply partialApplyEq. unfold diagSeq. rewrite (diagPlaneInject n n0). reflexivity. - exact i. Qed. Lemma InfiniteDiagApply : forall {R : ConstructiveReals } (X : Set) (fnk : nat -> nat -> @PartialFunction R X) (x : X) (xD : Domain (XinfiniteSumAbs (diagSeq fnk)) x), series_cv (diagSeq (fun n k : nat => CRabs _ (partialApply (fnk n k) x (domainInfiniteSumAbsIncReverse (fnk n) x (domainInfiniteSumAbsDiag X fnk n x xD) k)))) (let (xn,a) := xD in let (lim,_) := CR_complete R _ a in lim). Proof. intros. destruct xD as [xn cv]. destruct (CR_complete R (CRsum (fun k : nat => CRabs _ (partialApply (diagSeq fnk k) x (xn k)))) cv). apply (series_cv_eq (fun k : nat => CRabs _ (partialApply (diagSeq fnk k) x (xn k)))). 2: apply c. intro n. transitivity (let (n0,k) := diagPlaneInv n in CRabs _ (partialApply (diagSeq fnk (diagPlane n0 k)) x (xn (diagPlane n0 k)))). - destruct (diagPlaneInv n) eqn:desN. apply CRabs_morph. apply partialApplyEq. unfold diagSeq. rewrite diagPlaneInject. rewrite desN. reflexivity. - assert (forall unk vnk : nat -> nat -> CRcarrier R, (forall n k : nat, unk n k == vnk n k) -> forall n:nat, diagSeq unk n == diagSeq vnk n). { intros. unfold diagSeq. destruct (diagPlaneInv n0). apply H. } apply H. clear n. intros. apply CRabs_morph. apply partialApplyEq. unfold diagSeq. rewrite diagPlaneInject. reflexivity. Qed. (* The infinite sum of lines is equal to the infinite diagonal sum *) Lemma applyInfiniteSumAbsDiag : forall {R : ConstructiveReals } (X : Set) (fnk : nat -> nat -> @PartialFunction R X) (x : X) (xD : Domain (XinfiniteSumAbs (diagSeq fnk)) x), series_cv (fun n:nat => let (ln,a) := domainInfiniteSumAbsDiag X fnk n x xD in let (lim,_) := CR_complete R _ a in lim) (let (xn,a) := xD in let (lim,_) := CR_complete R _ a in lim). Proof. intros. destruct (DiagSeqInfiniteSum (fun n k => CRabs _ (partialApply (fnk n k) x (domainInfiniteSumAbsIncReverse _ x (domainInfiniteSumAbsDiag X fnk n x xD) k))) (fun n : nat => let (ln, a) := domainInfiniteSumAbsDiag X fnk n x xD in let (lim, _) := CR_complete R (CRsum (fun n0 : nat => CRabs _ (partialApply (fnk n n0) x (ln n0)))) a in lim) (let (xn,a) := xD in let (lim,_) := CR_complete R _ a in lim)). - apply (series_cv_eq (diagSeq (fun n k : nat => CRabs _ (partialApply (fnk n k) x (domainInfiniteSumAbsIncReverse (fnk n) x (domainInfiniteSumAbsDiag X fnk n x xD) k))))). intro n. unfold diagSeq. destruct (diagPlaneInv n). symmetry. rewrite CRabs_right. reflexivity. apply CRabs_pos. apply InfiniteDiagApply. - (* The sum on each line *) intro n. destruct (domainInfiniteSumAbsDiag X fnk n); simpl. destruct (CR_complete R (CRsum (fun k : nat => CRabs _ (partialApply (fnk n k) x (x0 k)))) c). exact c0. - destruct p, p. apply (CR_cv_proper _ _ _ s). symmetry. apply (series_cv_unique _ _ _ (InfiniteDiagApply _ _ x xD) s0). Qed. (* If a subset A contains a countable intersection of domains of integrable functions, then it is full. *) Lemma CountableIntersectionIsFull : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (A : X (ElemFunc IS) -> Type), (forall x : X (ElemFunc IS), (forall n:nat, Domain (fn n) x) -> A x) -> almost_everywhere A. Proof. intros IS fn fnInt A inc. pose (fun n => IntFn (let (df,_) := countable_representation IS (fn n) (fnInt n) n in df)) as fnk. exists (XinfiniteSumAbs (diagSeq fnk)). split. - pose (fun n => IntFnL (let (df,_) := countable_representation IS (fn n) (fnInt n) n in df)) as fnkL. destruct (series_cv_maj (fun n => IntAbsSum (let (df,_) := countable_representation IS (fn n) (fnInt n) n in df)) (fun n => (CRpow (CR_of_Q _ (1#2)) n)) (CR_of_Q _ 2)) as [sumI cvI]. + intro n. destruct (countable_representation IS (fn n) (fnInt n) n). simpl. destruct p. rewrite CRabs_right. assumption. destruct x. simpl. apply (series_cv_nonneg (fun k : nat => Iabs (IntFn k) (IntFnL k))). intros. apply integralPositive. intros x xdf. rewrite applyXabs. apply CRabs_pos. assumption. + apply GeoHalfTwo. + assert (series_cv (fun k : nat => Iabs (diagSeq fnk k) (diagSeqL IS fnk fnkL k)) sumI) as H. apply (series_cv_eq (diagSeq (fun n k => let (fInt,g) := countable_representation IS (fn n) (fnInt n) n in Iabs (IntFn fInt k) (IntFnL fInt k)))). intro n. unfold diagSeq, diagSeqL. destruct (diagPlaneInv n). unfold fnk, fnkL. destruct (countable_representation IS (fn n0) (fnInt n0) n0). reflexivity. apply (DiagSeqInfiniteSumColPos _ (fun n => IntAbsSum (let (df,_) := countable_representation IS (fn n) (fnInt n) n in df))). intros. destruct (countable_representation IS (fn n) (fnInt n) n). apply integralPositive. intros y ydf. rewrite applyXabs. apply CRabs_pos. intro n. destruct (countable_representation IS (fn n) (fnInt n) n). destruct x. assumption. apply cvI. exists (Build_IntegralRepresentation IS (diagSeq fnk) (diagSeqL IS fnk fnkL) sumI H). apply PartialRestriction_refl. - (* Inclusion of domains *) intros xDiag xdf. apply inc. clear inc. intro n. simpl. pose proof (domainInfiniteSumAbsDiag _ fnk n xDiag xdf) as H. unfold fnk in H. destruct (countable_representation IS (fn n) (fnInt n) n) as [[fnn] [i _]]. unfold IntFn in i. apply i, H. Qed. Lemma IntegralNonDecreasingAE : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), almost_everywhere (fun x : X (ElemFunc IS) => forall (dF : Domain f x) (dG : Domain g x), partialApply _ _ dF <= partialApply _ _ dG) -> Integral fInt <= Integral gInt. Proof. intros. destruct X as [h [hInt inc]]. pose proof (IntegralNonDecreasing (Xplus f (Xminus h h)) (Xplus g (Xminus h h)) (IntegrablePlus f (Xminus h h) fInt (IntegrableMinus hInt hInt)) (IntegrablePlus g (Xminus h h) gInt (IntegrableMinus hInt hInt))). rewrite IntegralPlus in H. rewrite IntegralPlus in H. rewrite IntegralMinus in H. unfold CRminus in H. rewrite CRplus_opp_r, CRplus_0_r, CRplus_0_r in H. apply H. intros x xdf xdg. destruct xdf, xdg. rewrite (applyXplus f (Xminus h h)), (applyXplus g (Xminus h h)). destruct d0, d2. rewrite (applyXminus h h), (applyXminus h h). destruct f,g,h; simpl; clear H gInt fInt. simpl in inc. rewrite (DomainProp1 _ d3 d0), (DomainProp1 _ d2 d0), (DomainProp1 _ d4 d0). unfold CRminus. rewrite CRplus_opp_r, CRplus_0_r, CRplus_0_r. apply inc. apply d2. Qed. Lemma IntegrableExtensionalAE : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))), almost_everywhere (Domain g) -> almost_everywhere (fun x : X (ElemFunc IS) => forall (dF : Domain f x) (dG : Domain g x), partialApply _ _ dF == partialApply _ _ dG) -> IntegrableFunction f -> IntegrableFunction g. Proof. intros. destruct X as [h [i c]]. destruct X0 as [k [H H0]]. apply (IntegrableFunctionExtensional (Xplus f (Xplus (Xscale 0 h) (Xscale 0 k)))). - split. + intros x xD. apply c. apply xD. + intros. simpl. destruct xD, d0. rewrite CRmult_0_l, CRmult_0_l, CRplus_0_l, CRplus_0_r. exact (H0 x d1 d xG). - apply (IntegrablePlus _ _ X1). apply IntegrablePlus. apply IntegrableScale, i. apply IntegrableScale, H. Qed. Lemma IntegralExtensionalAE : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), almost_everywhere (fun x : X (ElemFunc IS) => forall (dF : Domain f x) (dG : Domain g x), partialApply _ _ dF == partialApply _ _ dG) -> Integral fInt == Integral gInt. Proof. intros. split. - apply IntegralNonDecreasingAE. destruct X as [h [hInt p]]. exists h. split. exact hInt. intros x dfull dG dF. rewrite (p x dfull dF dG). apply CRle_refl. - apply IntegralNonDecreasingAE. destruct X as [h [hInt p]]. exists h. split. exact hInt. intros x dfull dF dG. rewrite (p x dfull dF dG). apply CRle_refl. Qed. Definition PackFirstFunctions {R : ConstructiveReals } (X : Set) (fn : nat -> @PartialFunction R X) (n p : nat) : PartialFunction X := match p with | O => Xsum fn n | _ => fn (n + p)%nat end. Lemma PackFirstFunctionsL : forall (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (n p : nat), L (ElemFunc IS) (PackFirstFunctions (X (ElemFunc IS)) fn n p). Proof. intros. unfold PackFirstFunctions. destruct p. - apply LsumStable. apply fnL. - apply fnL. Defined. Lemma applyPackFirstSum : forall {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (n N : nat) (x : X) (pxDn : forall n:nat, Domain (fn n) x) (pxDnP : forall n:nat, Domain (PackFirstFunctions X fn N n) x), (CRsum (fun k => partialApply (PackFirstFunctions X fn N k) x (pxDnP k)) n == CRsum (fun k => partialApply (fn k) x (pxDn k)) (n+N)). Proof. induction n. - intros. simpl. rewrite (applyXsum _ _ _ (pxDnP O) pxDn). reflexivity. - intros. simpl. rewrite (IHn N x pxDn). clear IHn. apply CRplus_morph. reflexivity. replace (S (n + N)) with (N + S n)%nat. apply DomainProp. rewrite Nat.add_comm. reflexivity. Qed. Lemma IabsMinusMaj : forall (IS : IntegrationSpace) (f g : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) (gL : L (ElemFunc IS) g), - Iabs f fL + Iabs g gL <= Iabs (Xminus f g) (LminusStable f g fL gL). Proof. intros. rewrite CRplus_comm. unfold Iabs. pose proof (@Iminus IS). unfold CRminus in H. rewrite <- H. clear H. apply INonDecreasing. intros. destruct y. rewrite applyXabs. rewrite (applyXminus f g). destruct xF. rewrite (applyXminus (Xabs g) (Xabs f)). unfold Xabs, Xop, partialApply. destruct f,g. rewrite (DomainProp0 x d0 d1), (DomainProp x d2 d). rewrite CRabs_minus_sym. apply CRabs_triang_inv. Qed. Lemma PackSeriesCV : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (N : nat) (a s : CRcarrier R), series_cv un s -> series_cv (fun n => match n with | O => a | _ => un (N + n)%nat end) (s - CRsum un N + a). Proof. intros. intros n. specialize (H n) as [k maj]. exists k. (* same modulus of convergence *) intros i H. destruct i. - inversion H. subst k. simpl. clear H. rewrite <- (CRplus_comm a). unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_l. rewrite CRabs_opp. specialize (maj N (Nat.le_0_l N)). rewrite CRabs_minus_sym in maj. exact maj. - rewrite decomp_sum. simpl. unfold CRminus. rewrite CRplus_comm. rewrite CRopp_plus_distr. rewrite CRplus_assoc. rewrite <- (CRplus_assoc (-a)). rewrite CRplus_opp_l. rewrite CRplus_0_l. rewrite CRopp_plus_distr. rewrite CRopp_involutive. rewrite (CRsum_eq (fun i : nat => un (N + S i)%nat) (fun i : nat => un (S N + i)%nat)). rewrite CRplus_assoc. rewrite <- sum_assoc. rewrite CRplus_comm. simpl in maj. apply maj. apply (Nat.le_trans k (S i)). assumption. simpl. apply le_n_S. rewrite Nat.add_comm. rewrite <- (Nat.add_0_r i). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. intros. rewrite Nat.add_succ_r. reflexivity. apply le_n_S. apply Nat.le_0_l. Qed. Lemma PackSeriesCVReverse : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (N : nat) (a s : CRcarrier R), series_cv (fun n => match n with | O => a | _ => un (N + n)%nat end) s -> series_cv un (s - a + CRsum un N). Proof. intros. intros eps. specialize (H eps) as [k maj]. exists (S N + k)%nat. (* translated same modulus of convergence *) intros n kLen. destruct (Nat.le_exists_sub (S N) n) as [m [inf _]]. apply (Nat.le_trans _ (S N + k)). rewrite <- (Nat.add_0_r (S N)). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. assumption. subst n. replace (m + S N)%nat with (S N + m)%nat. rewrite sum_assoc. specialize (maj (S m)). rewrite decomp_sum in maj. simpl in maj. unfold CRminus. simpl. rewrite CRplus_comm. rewrite CRopp_plus_distr, CRplus_assoc. simpl. rewrite <- (CRplus_assoc (-CRsum un N)). rewrite CRplus_opp_l. rewrite CRplus_0_l. rewrite (CRplus_comm s). rewrite CRopp_plus_distr. rewrite CRopp_involutive. rewrite CRplus_assoc. rewrite (CRplus_comm (-s)). rewrite <- CRplus_assoc. rewrite (CRsum_eq _ (fun i : nat => un (N + S i)%nat)). apply maj. rewrite Nat.add_comm in kLen. apply Nat.add_le_mono_r in kLen. apply (Nat.le_trans k m). assumption. apply le_S. apply Nat.le_refl. intros. rewrite Nat.add_succ_r. reflexivity. apply le_n_S. apply Nat.le_0_l. rewrite Nat.add_comm. reflexivity. Qed. Definition domainSumPackIncReverse {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (N : nat) (x : X) (xn : forall n:nat, Domain (PackFirstFunctions X fn N n) x) : forall n:nat, Domain (fn n) x. Proof. intros. destruct (le_lt_dec n N). - exact (domainXsumIncReverse fn n N x (xn O) l). - pose (xn (n - N)%nat). unfold PackFirstFunctions in d. destruct (n - N)%nat eqn:des. exfalso. apply (Nat.sub_gt n N); assumption. rewrite <- (Nat.sub_add N n). rewrite des. rewrite Nat.add_comm. exact d. subst d. apply (Nat.le_trans N (S N)). apply le_S. apply Nat.le_refl. assumption. Qed. Definition domainInfiniteSumPackInc {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (N : nat) : PartialRestriction (XinfiniteSumAbs (PackFirstFunctions X fn N)) (XinfiniteSumAbs fn). Proof. split. - intros x xD. (* The absolute convergence, to the adjusted limit *) apply (domainInfiniteSumAbsInc fn x (fun k => domainSumPackIncReverse X fn N x (fun n => domainInfiniteSumAbsIncReverse _ x xD n) k) (let (xn,a) := xD in let (lim,_) := CR_complete R _ a in lim - CRabs _ (partialApply _ x (domainInfiniteSumAbsIncReverse _ x xD 0)) + CRsum (fun k => CRabs _ (partialApply _ x (domainSumPackIncReverse X fn N x (fun n => domainInfiniteSumAbsIncReverse _ x xD n) k))) N )). destruct xD as [xn cv2]; simpl. destruct (CR_complete R (CRsum (fun n : nat => CRabs _ (partialApply (PackFirstFunctions X fn N n) x (xn n)))) cv2) as [sumAbsXn cv]. apply PackSeriesCVReverse. apply (series_cv_eq (fun n : nat => CRabs _ (partialApply _ x (xn n)))). 2: apply cv. intro n. unfold PackFirstFunctions. destruct n. reflexivity. apply CRabs_morph. apply DomainProp. - intros. (* The direct convergence, to the same limit *) destruct xD,xG; simpl. destruct (series_cv_abs (fun n : nat => partialApply (PackFirstFunctions X fn N n) x (x0 n)) c). destruct (series_cv_abs (fun n : nat => partialApply (fn n) x (x1 n)) c0). apply (series_cv_unique (fun k : nat => partialApply (fn k) x (x1 k))). 2: apply s0. intros eps. specialize (s eps) as [k maj]. exists (S N + k)%nat. (* translated modulus of convergence *) intros n H0. destruct (Nat.le_exists_sub N n) as [m [inf _]]. apply (Nat.le_trans _ (S N + k)). simpl. apply le_S. rewrite <- (Nat.add_0_r N). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. assumption. subst n. rewrite <- (applyPackFirstSum X fn m N x x1 x0). apply maj. apply (Nat.add_le_mono_l k m (S N)). apply (Nat.le_trans _ (m + N)). assumption. rewrite Nat.add_comm. apply Nat.add_le_mono_r. apply le_S. apply Nat.le_refl. Qed. (* Lemma 1.15 in Bishop's article, a representation that fits the absolute integral better. *) Lemma AbsRepresentation : forall (IS : IntegrationSpace) (f : PartialFunction (X (ElemFunc IS))) (eps : CRcarrier (RealT (ElemFunc IS))) (fInt : IntegrableFunction f), 0 < eps -> { intRepres : IntegralRepresentation & prod (PartialRestriction (XinfiniteSumAbs (IntFn intRepres)) f) (IntAbsSum intRepres <= Integral (IntegrableAbs fInt) + eps) }. Proof. intros. pose proof (IntegralAbsLimit f fInt) as IabsLimit. destruct fInt as [[fn fnL sumIAbsFn lim] [inj restr]] eqn:desFint. unfold IntFn, IntFnL in IabsLimit. unfold IntFn in inj, restr. assert (forall N:nat, series_cv (fun k : nat => Iabs (PackFirstFunctions (X (ElemFunc IS)) fn N k) (PackFirstFunctionsL IS fn fnL N k)) (sumIAbsFn - CRsum (fun n : nat => Iabs (fn n) (fnL n)) N + Iabs (Xsum fn N) (LsumStable fn fnL N))) as limPack. { intro N. apply (series_cv_eq (fun n => match n with | O => Iabs (Xsum fn N) (LsumStable fn fnL N) | _ => Iabs (fn (N+n)%nat) (fnL (N+n)%nat) end)). intro n. destruct n; reflexivity. apply (PackSeriesCV (fun n : nat => Iabs (fn n) (fnL n))). assumption. } pose (fun N:nat => Build_IntegralRepresentation IS (PackFirstFunctions (X (ElemFunc IS)) fn N) (PackFirstFunctionsL IS fn fnL N) (sumIAbsFn - CRsum (fun n => Iabs (fn n) (fnL n)) N + Iabs (Xsum fn N) (LsumStable fn fnL N)) (limPack N)) as represPack. assert (forall N:nat, PartialRestriction (XinfiniteSumAbs (IntFn (represPack N))) f) as IsRepresPack. { intro N. unfold represPack, IntFn. destruct (domainInfiniteSumPackInc (X (ElemFunc IS)) fn N) as [inc app]. split. intros x xdf. apply inj, inc. exact xdf. intros. specialize (app x xD (inc x xD)). rewrite app. apply restr. } destruct (CRup_nat (CR_of_Q _ 2 * CRinv _ eps (inr H))) as [epsN majEpsN]. pose proof (lim (Pos.of_nat epsN)) as [N limN]. exists (represPack N). split. apply IsRepresPack. (* Prove the epsilon majoration *) apply (CRle_trans _ (Iabs (Xsum fn N) (LsumStable fn fnL N) + eps * CR_of_Q _ (1#2))). - simpl. specialize (limN N (Nat.le_refl N)). rewrite <- (CRplus_comm (eps * CR_of_Q _ (1#2))). apply CRplus_le_compat. 2: apply CRle_refl. rewrite CRabs_minus_sym in limN. apply (CRle_trans _ (CRabs _ (sumIAbsFn - CRsum (fun k : nat => Iabs (fn k) (fnL k)) N))). apply CRle_abs. apply (CRle_trans _ (CR_of_Q _ (1# Pos.of_nat epsN))). assumption. apply (CRmult_lt_compat_r eps) in majEpsN. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in majEpsN. 2: exact H. apply CRlt_asym. apply (CRmult_lt_reg_r (CR_of_Q _ 2)). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- (CR_of_Q_mult _ (1#2)). setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite CRmult_1_r. apply (CRmult_lt_reg_l (CR_of_Q _ (Z.pos (Pos.of_nat epsN) #1))). apply CR_of_Q_lt; reflexivity. rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.pos (Pos.of_nat epsN) # 1) * (1 # Pos.of_nat epsN))%Q with 1%Q. rewrite CRmult_1_l. apply (CRlt_le_trans _ _ _ majEpsN). apply CRmult_le_compat_r. apply CRlt_asym, H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct epsN. discriminate. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite SuccNat2Pos.id_succ, Nat2Pos.id. apply Nat.le_refl. discriminate. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. reflexivity. - (* Replace the limit at infinity by a finite m > N *) apply (CR_cv_bound_down (fun m => Iabs (Xsum fn m) (LsumStable fn fnL m) + eps) _ _ (S N)). intros m maj. apply (CRplus_le_reg_l (- Iabs (Xsum fn m) (LsumStable fn fnL m))). rewrite <- CRplus_assoc. rewrite <- CRplus_assoc. rewrite CRplus_opp_l. rewrite CRplus_0_l. apply (CRplus_le_reg_r (- (eps * CR_of_Q _ (1#2)))). rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. apply (CRle_trans _ (Iabs (Xminus (Xsum fn m) (Xsum fn N)) (LminusStable _ _ (LsumStable fn fnL m) (LsumStable fn fnL N)))). apply IabsMinusMaj. destruct (Nat.le_exists_sub N m) as [k [add _]]. apply le_S in maj. apply le_S_n in maj. assumption. subst m. destruct k. exfalso. exact (Nat.lt_irrefl N maj). apply (CRle_trans _ (Iabs (Xsum (fun a => fn (S N + a)%nat) k) (LsumStable (fun a => fn (S N + a)%nat) (fun a => fnL (S N + a)%nat) k))). apply INonDecreasing. intros. rewrite applyXabs. rewrite applyXabs. remember (S k + N)%nat. rewrite Nat.add_comm in Heqn. replace (N + S k)%nat with (S N + k)%nat in Heqn. subst n. rewrite (Xsum_assocMinus fn N k x _ y). apply CRle_refl. rewrite Nat.add_succ_r. reflexivity. apply (CRle_trans _ (I IS (Xsum (fun a : nat => Xabs (fn (S N + a)%nat)) k) (LsumStable _ (fun a => LabsStable (ElemFunc IS) (fn (S N + a)%nat) (fnL (S N + a)%nat)) k))). apply INonDecreasing. intros. apply XmultiTriangleIneg. rewrite IadditiveIterate. rewrite <- (CRsum_eq (fun n0 : nat => I IS (Xabs (fn (N + S n0)%nat)) (LabsStable (ElemFunc IS) (fn (N + S n0)%nat) (fnL (N + S n0)%nat)))). apply (series_cv_remainder_maj (fun n0 : nat => I IS (Xabs (fn n0)) (LabsStable (ElemFunc IS) (fn n0) (fnL n0))) sumIAbsFn). apply lim. rewrite <- (CRplus_opp_r (eps * CR_of_Q _ (1 # 2))). apply CRplus_lt_compat_r. rewrite <- (CRmult_1_r eps). rewrite CRmult_assoc. apply CRmult_lt_compat_l. assumption. rewrite CRmult_1_l. apply (CRmult_lt_reg_l (CR_of_Q _ 2)). apply CR_of_Q_lt; reflexivity. rewrite <- CR_of_Q_mult. rewrite CRmult_1_r. apply CR_of_Q_lt. reflexivity. intro n. apply integralPositive. intros x xdf. rewrite applyXabs. apply CRabs_pos. apply CRlt_asym. setoid_replace (eps + - (eps * CR_of_Q _ (1 # 2))) with (eps * CR_of_Q _ (1 # 2)). apply (CRmult_lt_compat_r eps) in majEpsN. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in majEpsN. 2: exact H. apply (CRle_lt_trans _ (CR_of_Q _ (1 # Pos.of_nat epsN))). apply limN. apply Nat.le_refl. apply (CRmult_lt_reg_r (CR_of_Q _ 2)). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- (CR_of_Q_mult _ (1#2)). setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite CRmult_1_r. apply (CRmult_lt_reg_l (CR_of_Q _ (Z.pos (Pos.of_nat epsN) #1))). apply CR_of_Q_lt; reflexivity. rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.pos (Pos.of_nat epsN) # 1) * (1 # Pos.of_nat epsN))%Q with 1%Q. rewrite CRmult_1_l. apply (CRlt_le_trans _ _ _ majEpsN). apply CRmult_le_compat_r. apply CRlt_asym, H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct epsN. discriminate. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite SuccNat2Pos.id_succ, Nat2Pos.id. apply Nat.le_refl. discriminate. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. reflexivity. rewrite <- (CRmult_1_r eps), CRopp_mult_distr_r. rewrite CRmult_assoc, <- CRmult_plus_distr_l. apply CRmult_morph. rewrite CRmult_1_r. reflexivity. rewrite CRmult_1_l. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_morph. reflexivity. intros. rewrite Nat.add_succ_r. reflexivity. apply CR_cv_plus. assumption. apply CR_cv_const. Qed. (* We now state the completeness theorem of integrable functions of an integration space IS : they behave as the L-functions of a bigger integration space, which integrable functions are already integrable in IS. *) Definition CompleteRepresentation (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) : { intRepresN : nat -> IntegralRepresentation & forall n:nat, prod (PartialRestriction (XinfiniteSumAbs (IntFn (intRepresN n))) (fn n)) (IntAbsSum (intRepresN n) <= Integral (IntegrableAbs (fnInt n)) + CRpow (CR_of_Q _ (1#2)) n) }. Proof. assert (0 < CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) as halfPos. { apply CR_of_Q_lt. reflexivity. } exists (fun n:nat => let (df,_) := AbsRepresentation IS (fn n) (CRpow (CR_of_Q _ (1#2)) n) (fnInt n) (CRpow_gt_zero (CR_of_Q _ (1 # 2)) n halfPos) in df). intro n. destruct (AbsRepresentation IS (fn n) _ (fnInt n) (CRpow_gt_zero (CR_of_Q _ (1 # 2)) n halfPos)). simpl. split; apply p. Qed. Lemma CompleteRepresentationDoubleSum : forall (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)), let (intRepresN, _) := CompleteRepresentation IS fn fnInt in forall (x : X (ElemFunc IS)) (xD : Domain (XinfiniteSumAbs (diagSeq (fun n k : nat => IntFn (intRepresN n) k))) x) (pxF : forall n : nat, Domain (fn n) x), series_cv (fun n : nat => partialApply (fn n) x (pxF n)) (partialApply (XinfiniteSumAbs (diagSeq (fun n k : nat => IntFn (intRepresN n) k))) x xD). Proof. intros. destruct (CompleteRepresentation IS fn fnInt) as [cfnInt represN]. intros. destruct (DiagSeqInfiniteSum (fun n k => partialApply _ _ (domainInfiniteSumAbsIncReverse _ x (domainInfiniteSumAbsDiag _ _ n x xD) k)) (fun n : nat => partialApply (fn n) x (pxF n)) (let (xn,a) := xD in let (l,_) := CR_complete _ _ a in l)). - apply InfiniteDiagApply. - (* The limit on each line *) intro n. apply represApply. apply represN. - setoid_replace (partialApply (XinfiniteSumAbs (diagSeq (fun n k : nat => IntFn (cfnInt n) k))) x xD) with x0. apply p. destruct p,p. apply (series_cv_unique (diagSeq (fun n k : nat => partialApply (IntFn (cfnInt n) k) x (domainInfiniteSumAbsIncReverse (fun k0 : nat => IntFn (cfnInt n) k0) x (domainInfiniteSumAbsDiag (X (ElemFunc IS)) (fun n0 k0 : nat => IntFn (cfnInt n0) k0) n x xD) k)))). 2: exact s0. apply (series_cv_eq (fun k : nat => partialApply (diagSeq (fun n k0 : nat => IntFn (cfnInt n) k0) k) x (let (xn,_) := xD in xn k))). + intro n. transitivity (let (n0,k) := diagPlaneInv n in partialApply (IntFn (cfnInt n0) k) x (domainInfiniteSumAbsIncReverse (fun k0 : nat => IntFn (cfnInt n0) k0) x (domainInfiniteSumAbsDiag (X (ElemFunc IS)) (fun n1 k0 : nat => IntFn (cfnInt n1) k0) n0 x xD) k)). 2: reflexivity. destruct (diagPlaneInv n) eqn:desN. apply partialApplyEq. unfold diagSeq. rewrite desN. reflexivity. + destruct xD as [xn cv]; simpl. apply series_cv_abs_cv. Qed. Lemma partialInfiniteTriangle : forall {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (x : X) (xD : Domain (XinfiniteSumAbs fn) x), CRle _ (CRabs _ (partialApply _ x xD)) (let (xn, cv) := xD in let (l,_) := CR_complete R _ cv in l). Proof. intros. destruct xD as [xn limAbs]; simpl. destruct (series_cv_abs (fun n : nat => partialApply (fn n) x (xn n)) limAbs). apply (series_cv_triangle (fun k : nat => partialApply (fn k) x (xn k))). exact s. destruct (CR_complete R (CRsum (fun n : nat => CRabs _ (partialApply (fn n) x (xn n)))) limAbs). exact c. Qed. Lemma CompleteRepresentationRestrict : forall (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)), let (intRepresN, _) := CompleteRepresentation IS fn fnInt in PartialRestriction (XinfiniteSumAbs (diagSeq (fun n k => IntFn (intRepresN n) k))) (XinfiniteSumAbs fn). Proof. intros. pose proof (CompleteRepresentationDoubleSum IS fn fnInt) as dsum. destruct (CompleteRepresentation IS fn fnInt) as [intRepresN restrN]. split. intros x xdf. pose (domainInfiniteSumAbsDiag _ (fun n k => IntFn (intRepresN n) k)) as lineInj. destruct (series_cv_maj (fun n : nat => CRabs _ (partialApply (XinfiniteSumAbs (fun k : nat => IntFn (intRepresN n) k)) x (lineInj n x xdf))) (fun n => let (_,a) := lineInj n x xdf in let (l,_) := CR_complete _ _ a in l) (let (_,a) := xdf in let (l,_) := CR_complete _ _ a in l)). - intro n. simpl. rewrite CRabs_right. apply partialInfiniteTriangle. apply CRabs_pos. - apply applyInfiniteSumAbsDiag. - destruct p. apply (domainInfiniteSumAbsInc fn x (fun n:nat => fst (fst (restrN n)) x (lineInj n x xdf)) x0). + apply (series_cv_eq (fun n : nat => CRabs _ (partialApply (XinfiniteSumAbs (fun k : nat => IntFn (intRepresN n) k)) x (lineInj n x xdf)))). 2: exact s. intro n. destruct (restrN n) as [[j a0] maj]. unfold fst. specialize (a0 x (lineInj n x xdf)). apply CRabs_morph. apply a0. - intros. symmetry. apply applyInfiniteSumAbs. apply dsum. Qed. (* Theorem 1.16 of Bishop *) Lemma IntegrableFunctionsComplete : forall (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (sumIAbsFn : CRcarrier (RealT (ElemFunc IS))), (series_cv (fun k:nat => Integral (IntegrableAbs (fnInt k))) sumIAbsFn) -> { represInt : IntegralRepresentation & prod (PartialRestriction (XinfiniteSumAbs (IntFn represInt)) (XinfiniteSumAbs fn)) (series_cv (fun n => Integral (fnInt n)) (IntegralSeries represInt)) }. Proof. intros. pose proof (CompleteRepresentationRestrict IS fn fnInt) as complRestrict. destruct (CompleteRepresentation IS fn fnInt) as [intRepresN restrN]. destruct (series_cv_maj (fun n => IntAbsSum (intRepresN n)) (fun n => Integral (IntegrableAbs (fnInt n)) + CRpow (CR_of_Q _ (1#2)) n) (sumIAbsFn + CR_of_Q _ 2)) as [s [cvs majS]]. - intro n. rewrite CRabs_right. apply (restrN n). destruct (intRepresN n); simpl. apply (series_cv_nonneg (fun k : nat => Iabs (IntFn k) (IntFnL k))). intro n0. apply integralPositive. intros x xdf. rewrite applyXabs. apply CRabs_pos. assumption. - apply series_cv_plus. apply H. apply GeoHalfTwo. - assert (series_cv (fun k : nat => Iabs (diagSeq (fun n k0 : nat => IntFn (intRepresN n) k0) k) (diagSeqL IS (fun n k0 : nat => IntFn (intRepresN n) k0) (fun n k0 : nat => IntFnL (intRepresN n) k0) k)) s). { apply (series_cv_eq (diagSeq (fun n k => Iabs (IntFn (intRepresN n) k) (IntFnL (intRepresN n) k)))). intro n. unfold diagSeq, diagSeqL. destruct (diagPlaneInv n). reflexivity. apply (DiagSeqInfiniteSumColPos _ (fun n : nat => IntAbsSum (intRepresN n))). intros n k. apply integralPositive. intros x xdf. rewrite applyXabs. apply CRabs_pos. intro n. apply (intRepresN n). assumption. } exists (Build_IntegralRepresentation IS (diagSeq (fun n k => IntFn (intRepresN n) k)) (diagSeqL IS _ (fun n k => IntFnL (intRepresN n) k)) s H0). split. + exact complRestrict. + pose proof (IntegralCv {| IntFn := diagSeq (fun n k : nat => IntFn (intRepresN n) k); IntFnL := diagSeqL IS (fun n k : nat => IntFn (intRepresN n) k) (fun n k : nat => IntFnL (intRepresN n) k); IntAbsSum := s; IntAbsSumCv := H0 |}); simpl. simpl in H1. destruct (series_cv_maj (diagSeq (fun n k : nat => CRabs _ (I IS _ (IntFnL (intRepresN n) k)))) (fun k : nat => Iabs _ (diagSeqL IS (fun n k0 : nat => IntFn (intRepresN n) k0) (fun n k0 : nat => IntFnL (intRepresN n) k0) k)) s). intro n. rewrite CRabs_right. unfold diagSeq, diagSeqL. destruct (diagPlaneInv n). apply integralAbsMaj. unfold diagSeq. destruct (diagPlaneInv n). apply CRabs_pos. assumption. destruct (DiagSeqInfiniteSum (fun n k => I IS _ (IntFnL (intRepresN n) k)) (fun n : nat => Integral (fnInt n)) x). apply p. (* Limit on each line *) intro n. clear p. clear x. pose proof (IntegralRepresentationInvariant (fn n) (existT _ (intRepresN n) (fst (restrN n))) (fnInt n)). rewrite <- H2. apply (IntegralCv (intRepresN n)). destruct (series_cv_maj (fun n : nat => I IS _ (diagSeqL IS (fun n0 k : nat => IntFn (intRepresN n0) k) (fun n0 k : nat => IntFnL (intRepresN n0) k) n)) (fun k : nat => Iabs _ (diagSeqL IS (fun n k0 : nat => IntFn (intRepresN n) k0) (fun n k0 : nat => IntFnL (intRepresN n) k0) k)) s (fun n : nat => integralAbsMaj _ (diagSeqL IS (fun n0 k : nat => IntFn (intRepresN n0) k) (fun n0 k : nat => IntFnL (intRepresN n0) k) n)) H0). setoid_replace x1 with x0. apply p0. apply (series_cv_unique (diagSeq (fun n k : nat => I IS (IntFn (intRepresN n) k) (IntFnL (intRepresN n) k)))). 2: apply p0. apply (series_cv_eq (fun n : nat => I IS _ (diagSeqL IS (fun n0 k : nat => IntFn (intRepresN n0) k) (fun n0 k : nat => IntFnL (intRepresN n0) k) n))). intro n. unfold diagSeq, diagSeqL. destruct (diagPlaneInv n). reflexivity. assumption. Qed. (* Now that we have proved the completeness theorem, we can forget L-functions and use integrable functions everywhere instead. *) Definition DiscrDeriv {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (n : nat) := match n with | O => fn O | S p => Xminus (fn n) (fn p) end. Lemma DiscrDerivDomainIncReverse : forall {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (x : X) (xn : forall n : nat, Domain (DiscrDeriv X fn n) x) (n : nat), Domain (fn n) x. Proof. intros. pose (xn n). unfold DiscrDeriv in d. destruct n. exact d. unfold Xminus, Xplus in d. exact (fst d). Qed. Lemma DiscrDerivApply : forall {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (x : X) (pxn : forall n: nat, Domain (DiscrDeriv X fn n) x) (n : nat) (px : Domain (fn n) x), (CRsum (fun k : nat => partialApply (DiscrDeriv X fn k) x (pxn k)) n == partialApply (fn n) x px). Proof. induction n. - intros. simpl. apply DomainProp. - intros. transitivity (CRsum (fun k : nat => partialApply (DiscrDeriv X fn k) x (pxn k)) n + partialApply (DiscrDeriv X fn (S n)) x (pxn (S n))). reflexivity. pose proof (DiscrDerivDomainIncReverse X fn x pxn n) as H. specialize (IHn H). rewrite IHn. clear IHn. unfold DiscrDeriv. destruct (pxn (S n)). rewrite (applyXminus (fn (S n)) (fn n)). rewrite (DomainProp (fn (S n)) x d px). rewrite (DomainProp (fn n) x d0 H). rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_r. reflexivity. Qed. Definition IntegrableDiscrDeriv (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (n : nat) : IntegrableFunction (DiscrDeriv (X (ElemFunc IS)) fn n). Proof. intros. destruct n. apply fnInt. apply IntegrableMinus; apply fnInt. Defined. (* The converse is not true : it is harder for series to converge absolutely. *) Lemma DiscrDerivInfiniteSum : forall {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X), PartialRestriction (XinfiniteSumAbs (DiscrDeriv X fn)) (XpointwiseLimit fn). Proof. split. - intros x H. simpl. destruct H as [xn xcv]. exists (DiscrDerivDomainIncReverse X fn x xn). (* An absolutely convergent series converges without the absolute values. *) assert (CR_cauchy _ (CRsum (fun n : nat => CRabs _ (partialApply (DiscrDeriv X fn n) x (xn n))))). { intro p. specialize (xcv p) as [n nmaj]. exists n. simpl. exact nmaj. } clear xcv. apply series_cv_abs in H. destruct H as [l xcv]. apply (Rcv_cauchy_mod _ l). apply (CR_cv_eq _ (CRsum (fun n : nat => partialApply (DiscrDeriv X fn n) x (xn n)))). 2: exact xcv. intro n. apply DiscrDerivApply. - intros. apply applyInfiniteSumAbs. destruct xG as [xn xcv]. apply (CR_cv_eq _ (fun n : nat => partialApply (fn n) x (xn n))). intro n. symmetry. apply DiscrDerivApply. clear xD. simpl. destruct (CR_complete R (fun n : nat => partialApply (fn n) x (xn n)) xcv). exact c. Qed. Lemma IntegrableXpointwiseLimit : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (sumAbsInt : CRcarrier (RealT (ElemFunc IS))), series_cv (fun n:nat => Integral (IntegrableAbs (IntegrableMinus (fnInt (S n)) (fnInt n)))) sumAbsInt -> { i : IntegrableFunction (XpointwiseLimit fn) & CR_cv _ (fun n => Integral (fnInt n)) (Integral i) }. Proof. intros. destruct (IntegrableFunctionsComplete IS _ (IntegrableDiscrDeriv IS fn fnInt) (sumAbsInt + Integral (IntegrableAbs (IntegrableDiscrDeriv IS fn fnInt O)))) as [rep repcv]. - apply (series_cv_shift (fun k : nat => Integral (IntegrableAbs (IntegrableDiscrDeriv IS fn fnInt k))) O sumAbsInt). simpl. apply (series_cv_eq (fun n : nat => Integral (IntegrableAbs (IntegrableMinus (fnInt (S n)) (fnInt n))))). 2: exact H. intro n. apply IntegralExtensional. intros. apply DomainProp. - destruct repcv. assert (PartialRestriction (XinfiniteSumAbs (IntFn rep)) (XpointwiseLimit fn)) as res. { apply (PartialRestriction_trans _ _ _ _ p). apply DiscrDerivInfiniteSum. } exists (IntegrableFunctionExtensional _ _ res (existT _ rep (PartialRestriction_refl _ _))). apply (CR_cv_eq (fun n : nat => Integral (fnInt n))) in s. + apply (CR_cv_proper _ _ _ s). clear s. rewrite IntegralRestrict. reflexivity. + induction n. apply IntegralExtensional. intros. apply DomainProp. simpl. rewrite IHn. clear IHn. rewrite <- (CRplus_0_l (Integral (fnInt (S n)))). rewrite <- (CRplus_opp_r (Integral (fnInt n))), CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm. pose proof (IntegralMinus (fn (S n))). unfold CRminus in H0. rewrite <- H0. clear H0. apply IntegralExtensional. intros. apply DomainProp. Qed. (* Now the famous monotone convergence theorem for integrals. Unlike the classical Beppo Levi's formulation, this theorem requires a convergence, to avoid infinite integrals. Also, constructively the convergence of non-decreasing sequences is not automatic ; this theorem proves that the restriction to the domain of convergence does not lose integral mass. *) Definition IntegralMonotoneConvergence (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (a : CRcarrier (RealT (ElemFunc IS))) : (forall n:nat, partialFuncLe (fn n) (fn (S n))) -> CR_cv _ (fun n:nat => Integral (fnInt n)) a -> { limInt : IntegrableFunction (XpointwiseLimit fn) | Integral limInt == a }. Proof. intros. destruct (IntegrableXpointwiseLimit fn fnInt (a - Integral (fnInt O))). - apply (CR_cv_eq _ (fun n => Integral (fnInt (S n)) - Integral (fnInt O))). induction n. simpl. rewrite <- IntegralMinus. apply IntegralExtensional. intros. rewrite applyXabs, CRabs_right. apply DomainProp. destruct xdg. rewrite (applyXminus (fn 1%nat) (fn O)). rewrite <- (CRplus_opp_r (partialApply (fn O) x d0)). apply CRplus_le_compat_r. apply H. simpl. rewrite <- IHn. unfold CRminus. rewrite CRplus_comm. rewrite (CRplus_comm (Integral (fnInt (S n)))), CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_0_l, <- (CRplus_opp_r (Integral (fnInt (S n)))). rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm. pose proof (IntegralMinus (fn (S (S n)))). unfold CRminus in H1. rewrite <- H1. apply IntegralExtensional. intros. rewrite applyXabs, CRabs_right. apply DomainProp. destruct xdg. rewrite (applyXminus (fn (S (S n))) (fn (S n))). rewrite <- (CRplus_opp_r (partialApply (fn (S n)) x d0)). apply CRplus_le_compat_r. apply H. apply CR_cv_minus. 2: apply CR_cv_const. apply (CR_cv_shift' _ 1) in H0. apply (CR_cv_eq _ (fun n : nat => Integral (fnInt (n + 1)%nat))). 2: exact H0. intro n. rewrite Nat.add_comm. reflexivity. - exists x. exact (CR_cv_unique _ _ _ c H0). Qed. Lemma IntegralMonotoneConvergenceDecr (IS : IntegrationSpace) (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (a : CRcarrier (RealT (ElemFunc IS))) : (forall n:nat, partialFuncLe (fn (S n)) (fn n)) -> CR_cv _ (fun n:nat => Integral (fnInt n)) a -> { limInt : IntegrableFunction (XpointwiseLimit fn) | Integral limInt == a }. Proof. intros. destruct (IntegrableXpointwiseLimit fn fnInt (Integral (fnInt O) - a)). - apply (CR_cv_eq _ (fun n => Integral (fnInt O) - Integral (fnInt (S n)))). induction n. simpl. rewrite <- IntegralMinus. apply IntegralExtensional. intros. rewrite applyXabs, CRabs_left. simpl. destruct xdf, xdg. rewrite CRopp_plus_distr. rewrite <- CRopp_mult_distr_l, <- CRopp_mult_distr_l. rewrite CRmult_1_l, CRmult_1_l, CRopp_involutive, CRplus_comm. rewrite (DomainProp _ x d1 d0), (DomainProp _ x d d2). reflexivity. destruct xdg. rewrite (applyXminus (fn 1%nat) (fn O)). rewrite <- (CRplus_opp_r (partialApply (fn O) x d0)). apply CRplus_le_compat_r. apply H. simpl. rewrite <- IHn. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_0_l, <- (CRplus_opp_l (Integral (fnInt (S n)))). rewrite CRplus_assoc. apply CRplus_morph. reflexivity. pose proof (IntegralMinus (fn (S n))). unfold CRminus in H1. rewrite <- H1. apply IntegralExtensional. intros. rewrite applyXabs, CRabs_left. simpl. destruct xdf, xdg. rewrite CRopp_plus_distr. rewrite <- CRopp_mult_distr_l, <- CRopp_mult_distr_l. rewrite CRmult_1_l, CRmult_1_l, CRopp_involutive, CRplus_comm. rewrite (DomainProp _ x d1 d0), (DomainProp _ x d d2). reflexivity. destruct xdg. rewrite (applyXminus (fn (S (S n))) (fn (S n))). rewrite <- (CRplus_opp_r (partialApply (fn (S n)) x d0)). apply CRplus_le_compat_r. apply H. apply CR_cv_minus. apply CR_cv_const. apply (CR_cv_shift' _ 1) in H0. apply (CR_cv_eq _ (fun n : nat => Integral (fnInt (n + 1)%nat))). 2: exact H0. intro n. rewrite Nat.add_comm. reflexivity. - exists x. exact (CR_cv_unique _ _ _ c H0). Qed. Definition IntegralRepresentationShift {IS : IntegrationSpace} (fInt : @IntegralRepresentation IS) (n : nat) : @IntegralRepresentation IS. Proof. apply (Build_IntegralRepresentation IS (fun k => IntFn fInt (S n + k)) (fun k => IntFnL fInt (S n + k)) (IntAbsSum fInt - CRsum (fun k => Iabs _ (IntFnL fInt k)) n)). apply (CR_cv_eq _ (fun i => CRsum (fun k : nat => Iabs _ (IntFnL fInt k)) (S n+i) - CRsum (fun k : nat => Iabs _ (IntFnL fInt k)) n)). intros i. rewrite sum_assoc. simpl. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_l. reflexivity. apply CR_cv_plus. 2: apply CR_cv_const. intro p. destruct fInt; unfold CMTIntegrableFunctions.IntFn, CMTIntegrableFunctions.IntAbsSum, CMTIntegrableFunctions.IntFnL. specialize (IntAbsSumCv p) as [j jmaj]. exists j. intros. apply jmaj. apply (Nat.le_trans _ (0+i) _ H). apply Nat.add_le_mono_r, Nat.le_0_l. Defined. Lemma IntegralRepresentationShiftVal : forall {IS : IntegrationSpace} (fInt : @IntegralRepresentation IS) (n : nat), IntegralSeries (IntegralRepresentationShift fInt n) == IntegralSeries fInt - CRsum (fun k => I IS _ (IntFnL fInt k)) n. Proof. intros. apply (series_cv_unique (fun n0 : nat => I IS (IntFn (IntegralRepresentationShift fInt n) n0) (IntFnL (IntegralRepresentationShift fInt n) n0))). exact (IntegralCv (IntegralRepresentationShift fInt n)). simpl. apply (CR_cv_eq _ (fun k => CRsum (fun n0 : nat => I IS _ (IntFnL fInt n0)) (S n + k) - CRsum (fun k : nat => I IS (IntFn fInt k) (IntFnL fInt k)) n)). intros. rewrite sum_assoc. simpl. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. apply CR_cv_minus. 2: apply CR_cv_const. intro p. pose proof (IntegralCv fInt p) as [k kmaj]. exists k. intros. apply kmaj. apply (Nat.le_trans _ (0+i) _ H). apply Nat.add_le_mono_r, Nat.le_0_l. Qed. (* The integrable functions were defined as pointwise limits of L-functions, which is already a notion of density. Here we prove that integrable functions are also limits for the integral distance. This is corollary 1.17 of Bishop. *) Lemma IntegralDense : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), Un_integral_cv _ f (IntegrableSum _ (fun n => IntegrableL _ (IntFnL (let (intRepres,_) := fInt in intRepres) n))) fInt. Proof. intros. destruct fInt as [intRepres lim]. intro p. pose proof (IntAbsSumCv intRepres p) as [n nmaj]. exists n. intros i H. apply (CRle_trans _ (Integral (IntegrableSelf (IntegralRepresentationShift (IntegralRepresentationAbs intRepres) i)))). - apply IntegralNonDecreasing. intros x xdf [xnlim cau]. destruct xdf. rewrite applyXabs, (applyXminus (Xsum (IntFn intRepres) i) f). simpl. assert (forall n0:nat, Domain (IntFn intRepres n0) x) as xdn. { intro j. destruct (le_lt_dec j i). exact (domainXsumIncReverse (IntFn intRepres) j i _ d l). unfold lt in l. simpl in xnlim. pose proof (xnlim (j - S i)%nat) as H0. replace (S (i + (j - S i)))%nat with j in H0. exact H0. symmetry. rewrite Nat.add_comm. rewrite <- Nat.add_succ_r. exact (Nat.sub_add (S i) j l). } destruct (series_cv_abs (fun n0 : nat => CRabs _ (partialApply (IntFn intRepres (S (i + n0))) x (xnlim n0))) cau) as [x0 s]. apply (series_cv_eq _ (fun n0 => CRabs _ (partialApply (IntFn intRepres (S (i + n0))) x (xdn (S i + n0)%nat)))) in s. apply (series_cv_shift (fun n0 : nat => CRabs _ (partialApply (IntFn intRepres n0) x (xdn n0))) i x0) in s. rewrite (applyXsum _ _ x _ xdn). rewrite <- (CRplus_0_r x0), <- (CRplus_opp_r (CRsum (fun n0 : nat => CRabs _ (partialApply (IntFn intRepres n0) x (xdn n0))) i)), <- CRplus_assoc. apply (series_cv_abs_remainder (fun n0 : nat => (partialApply (IntFn intRepres n0) x (xdn n0))) (partialApply f x d0) (x0 + CRsum (fun n0 : nat => CRabs _ (partialApply (IntFn intRepres n0) x (xdn n0))) i) i). 2: exact s. destruct lim. assert (Domain (XinfiniteSumAbs (IntFn intRepres)) x) as H0. { exists xdn. apply Rcv_cauchy_mod in s. exact s. } rewrite <- (c x H0). apply (series_cv_eq (fun n : nat => partialApply (IntFn intRepres n) x (domainInfiniteSumAbsIncReverse (IntFn intRepres) x H0 n))). 2: apply applyInfiniteSumAbs; reflexivity. intros. apply DomainProp. intros. apply CRabs_morph, DomainProp. - unfold Integral, IntegrableSelf. rewrite IntegralRepresentationShiftVal. rewrite IntegralRepresentationAbsVal. simpl. specialize (nmaj i H). rewrite CRabs_minus_sym in nmaj. apply (CRle_trans _ _ _ (CRle_abs _) nmaj). Qed. Lemma CR_cv_growing : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (l : CRcarrier R), (forall n:nat, un n <= un (S n)) -> (forall n:nat, un n <= l) -> (forall p : positive, { n : nat | l - un n <= CR_of_Q R (1#p) }) -> CR_cv R un l. Proof. intros. intro p. specialize (H1 p) as [n nmaj]. exists n. intros. rewrite CRabs_minus_sym, CRabs_right. apply (CRle_trans _ (l - un n)). apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. exact (growing_transit _ H n i H1). exact nmaj. rewrite <- (CRplus_opp_r (un i)). apply CRplus_le_compat. apply H0. apply CRle_refl. Qed. Lemma IntegralTruncateLimit : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), CR_cv _ (fun n : nat => Integral (IntegrableMinInt f n fInt)) (Integral fInt). Proof. (* Fallback to the L-version of this theorem via the L-representation fn of f. *) intros IS f fInt. apply CR_cv_growing. - intro n. apply IntegralNonDecreasing. intros x xdf xdg. assert (Domain f x). { destruct f; exact xdf. } apply CRmin_glb. unfold XminConst, Xop, partialApply. rewrite (DomainProp f x xdf xdg). apply CRmin_l. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. - intro n. apply IntegralNonDecreasing. intros x xdf xdg. unfold XminConst, Xop, partialApply. rewrite (DomainProp f x xdf xdg). apply CRmin_l. - intro p. assert ({ g : PartialFunction (X (ElemFunc IS)) & { gL : L (ElemFunc IS) g | IntegralDistance fInt (IntegrableL g gL) <= CR_of_Q _ (1#3*p) } }). { pose proof (IntegralDense f fInt (3*p)%positive) as [n nmaj]. specialize (nmaj n (Nat.le_refl n)). exists (Xsum (IntFn (let (intRepres, _) := fInt in intRepres)) n). exists (LsumStable _ (IntFnL (let (intRepres, _) := fInt in intRepres)) n). rewrite IntegralDistance_sym. apply (CRle_trans _ (IntegralDistance (IntegrableSum (IntFn (let (intRepres, _) := fInt in intRepres)) (fun n : nat => IntegrableL (IntFn (let (intRepres, _) := fInt in intRepres) n) (IntFnL (let (intRepres, _) := fInt in intRepres) n)) n) fInt)). 2: exact nmaj. clear nmaj. apply IntegralNonDecreasing. intros x xdf xdg. rewrite (DomainProp _ _ xdf xdg). apply CRle_refl. } destruct X as [g [gL gdist]]. pose proof (Ilimit IS g gL) as [glim _]. specialize (glim (3*p)%positive) as [n nmaj]. exists n. apply (CRle_trans _ (I IS g gL + CR_of_Q _ (1#3*p) - Integral (IntegrableMinInt f n fInt))). apply CRplus_le_compat. 2: apply CRle_refl. apply (CRplus_le_reg_l (-I IS g gL)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite CRplus_comm. apply (CRle_trans _ _ _ (CRle_abs _)). fold (Integral fInt - I IS g gL). rewrite <- IntegralLstable. rewrite <- IntegralMinus. exact (CRle_trans _ _ _ (IntegralTriangle _ _) gdist). apply (CRle_trans _ (I IS g gL + CR_of_Q _ (1 # 3 * p) - I IS _ (LminIntStable n g gL) + CR_of_Q _ (1#3*p))). unfold CRminus. rewrite (CRplus_assoc (I IS g gL + CR_of_Q _ (1 # 3 * p))). apply CRplus_le_compat. apply CRle_refl. apply (CRplus_le_reg_l (I IS _ (LminIntStable n g gL))). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. fold (I IS _ (LminIntStable n g gL) - Integral (IntegrableMinInt f n fInt)). rewrite <- IntegralLstable, <- IntegralMinus. apply (CRle_trans _ _ _ (CRle_abs _)). apply (CRle_trans _ _ _ (IntegralTriangle _ _)). apply (CRle_trans _ (IntegralDistance fInt (IntegrableL g gL))). 2: exact gdist. rewrite IntegralDistance_sym. apply IntegralNonDecreasing. intros x xdf xdg. destruct xdf, xdg. rewrite applyXabs, applyXabs, (applyXminus (XminConst g (INR n)) (XminConst f (INR n))), (applyXminus g f), applyXminConst, applyXminConst. assert (0 <= @INR (RealT (ElemFunc IS)) n) as nPos. { apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. } apply (CRle_trans _ _ _ (CRmin_contract _ _ _)). rewrite (DomainProp g x d d1). rewrite (DomainProp f x d0 d2). apply CRle_refl. apply (CRle_trans _ (CR_of_Q _ (1 # 3 * p) + CR_of_Q _ (1 # 3 * p) + CR_of_Q _ (1 # 3 * p))). apply CRplus_le_compat. 2: apply CRle_refl. unfold CRminus. rewrite (CRplus_comm (I IS g gL)), CRplus_assoc. apply CRplus_le_compat_l. specialize (nmaj n (Nat.le_refl n)). rewrite CRabs_minus_sym in nmaj. exact (CRle_trans _ _ _ (CRle_abs _) nmaj). rewrite <- CR_of_Q_plus, <- CR_of_Q_plus. apply CR_of_Q_le. rewrite Qinv_plus_distr, Qinv_plus_distr. unfold Qle, Qnum, Qden. rewrite Z.mul_1_l. rewrite Pos2Z.inj_mul. reflexivity. Qed. Lemma Break_lt_3_eps : forall {R : ConstructiveReals} (a b : CRcarrier R), a < b -> { eps : CRcarrier R & prod (0 < eps) (a + CR_of_Q R 3 * eps < b) }. Proof. intros. exists ((b-a) * CR_of_Q R (1#4)). split. - rewrite <- (CRmult_0_l (CR_of_Q R (1#4))). apply CRmult_lt_compat_r. apply CR_of_Q_lt. reflexivity. rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r. exact H. - rewrite (CRmult_comm (b-a)), <- CRmult_assoc, <- CR_of_Q_mult. apply (CRplus_lt_reg_l _ (-a)). rewrite <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l, (CRplus_comm (-a)). rewrite <- (CRmult_1_l (b + - a)). apply CRmult_lt_compat_r. rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r. exact H. apply CR_of_Q_lt. reflexivity. Qed. Lemma DiagNonNeg : forall {R : ConstructiveReals} {X : Set} (fnk : nat -> nat -> @PartialFunction R X), (forall n k:nat, nonNegFunc (fnk n k)) -> forall n:nat, nonNegFunc (diagSeq fnk n). Proof. intros. intros x xdf. unfold diagSeq. unfold diagSeq in xdf. destruct (diagPlaneInv n). apply H. Qed. Lemma applyDiagAbs : forall {R : ConstructiveReals} {X : Set} (fnk : nat -> nat -> PartialFunction X) (x : X) (cpxDdiag : forall k : nat, Domain (diagSeq (fun n k0 : nat => Xabs (fnk n k0)) k) x) (cpxDdiagBis : forall k : nat, Domain (diagSeq fnk k) x) (k : nat), partialApply _ x (cpxDdiag k) == CRabs R (partialApply _ x (cpxDdiagBis k)). Proof. intros. unfold diagSeq. generalize (cpxDdiag k). intro d. generalize (cpxDdiagBis k). intro d0. clear cpxDdiagBis cpxDdiag. unfold diagSeq in d, d0. destruct (diagPlaneInv k). apply CRabs_morph. apply DomainProp. Qed. Definition series_cv_two_lim_lt {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (a : CRcarrier R) : Set := { xy : CRcarrier R * CRcarrier R & (series_cv un (fst xy)) * (series_cv vn (snd xy)) * (fst xy + snd xy < a)%ConstructiveReals }%type. Record CommonPointFunTwoSeq {R : ConstructiveReals} {X : Set} {f : @PartialFunction R X} {fn : nat -> @PartialFunction R X} {gn : nat -> @PartialFunction R X} : Set := { cpx2 : X; cpxF2 : Domain f cpx2; cpxFn2 : forall n:nat, Domain (fn n) cpx2; cpxGn2 : forall n:nat, Domain (gn n) cpx2; }. (* Icontinuous with 2 approching sequences, instead of 1. *) Lemma IcontinuousWeave : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fn : nat -> PartialFunction (X (ElemFunc IS))) (gn : nat -> PartialFunction (X (ElemFunc IS))) (fL : (L (ElemFunc IS)) f) (fnL : forall n:nat, (L (ElemFunc IS)) (fn n)) (gnL : forall n:nat, (L (ElemFunc IS)) (gn n)), (forall n:nat, nonNegFunc (fn n)) -> (forall n:nat, nonNegFunc (gn n)) -> series_cv_two_lim_lt (fun n => I IS (fn n) (fnL n)) (fun n => I IS (gn n) (gnL n)) (I IS f fL) -> { x : @CommonPointFunTwoSeq _ _ f fn gn & series_cv_two_lim_lt (fun n => partialApply (fn n) _ (cpxFn2 x n)) (fun n => partialApply (gn n) _ (cpxGn2 x n)) (partialApply f _ (cpxF2 x)) }. Proof. intros. assert (forall n:nat, L (ElemFunc IS) (weaveSequences _ fn gn n)) as wL. { apply weaveSequencesL; assumption. } destruct (Icontinuous IS f (weaveSequences _ fn gn) fL wL). - intro n. unfold weaveSequences. destruct (Nat.even n). apply H. apply H0. - destruct H1, x. simpl in p. destruct p, p. exists (c+c0). split. 2: exact c1. apply (series_cv_eq (weaveSequences _ (fun n => I IS (fn n) (fnL n)) (fun n => I IS (gn n) (gnL n)))). intro n. unfold weaveSequences. generalize (wL n). intros. unfold weaveSequences in l. destruct (Nat.even n). apply IExtensional. intros. apply DomainProp. apply IExtensional. intros. apply DomainProp. apply weaveInfiniteSums; assumption. - destruct x; simpl in s. destruct s, p. assert (forall k:nat, Domain (fn k) cpx) as cpxDf. { intro k. exact (domainWeaveEvenInc _ _ _ k cpx (cpxFn (k*2)%nat)). } assert (forall k:nat, Domain (gn k) cpx) as cpxDg. { intro k. exact (domainWeaveOddInc _ _ _ k cpx (cpxFn (1+k*2)%nat)). } apply (series_cv_eq _ (weaveSequences _ (fun n => partialApply _ cpx (cpxDf n)) (fun n => partialApply _ cpx (cpxDg n)))) in s. assert ({ l : CRcarrier _ & series_cv (fun n => partialApply _ cpx (cpxDg n)) l}). { apply (halfWeavedSumOdd (fun n => partialApply _ cpx (cpxDf n)) _ x). intro k. apply H. intro k. apply H0. exact s. } destruct H2. assert ({ l : CRcarrier _ & series_cv (fun k => partialApply _ cpx (cpxDf k)) l}). { apply (halfWeavedSumEven _ (fun k => partialApply _ cpx (cpxDg k)) x). intro k. apply H. intro k. apply H0. exact s. } destruct H2. exists (Build_CommonPointFunTwoSeq _ _ _ _ _ cpx cpxF cpxDf cpxDg). simpl. exists (x1,x0). split. split. exact s1. exact s0. simpl. setoid_replace (x1+x0) with x. exact c. apply (series_cv_unique (weaveSequences _ (fun n : nat => partialApply (fn n) cpx (cpxDf n)) (fun n : nat => partialApply (gn n) cpx (cpxDg n)))). 2: exact s. apply weaveInfiniteSums; assumption. intro k. rewrite (partialApplyWeave _ fn gn k cpx (cpxDf (k/2)%nat) (cpxDg (k/2)%nat) (cpxFn k)). unfold weaveSequences. destruct (Nat.even k); reflexivity. Qed. Lemma series_cv_remainder_cv : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (l eps : CRcarrier R), series_cv un l -> 0 < eps -> { k : nat & forall i:nat, le k i -> series_cv_lim_lt (fun n => un (n + i)%nat) eps }. Proof. intros. destruct (Un_cv_nat_real (CRsum un) l H eps H0) as [k kmaj]. exists (S k). intros. pose proof (series_cv_shift' un l i H). destruct i. exfalso; inversion H1. exists (l - CRsum un i). split. exact H2. apply le_S_n in H1. specialize (kmaj i H1). rewrite CRabs_minus_sym in kmaj. exact (CRle_lt_trans _ _ _ (CRle_abs _) kmaj). Qed. (* The completed space of integrable function is an integration space. *) Lemma IntegrableContinuous : forall {IS : IntegrationSpace} (h : PartialFunction (X (ElemFunc IS))) (hn : nat -> PartialFunction (X (ElemFunc IS))) (hL : IntegrableFunction h) (hnL : forall n:nat, IntegrableFunction (hn n)), (forall n:nat, nonNegFunc (hn n)) -> series_cv_lim_lt (fun n => Integral (hnL n)) (Integral hL) -> { x : CommonPointFunSeq _ h hn & series_cv_lim_lt (fun n => partialApply (hn n) _ (cpxFn _ _ _ x n)) (partialApply h _ (cpxF _ _ _ x)) }. Proof. intros. destruct H0, p. destruct (Break_lt_3_eps _ _ c) as [eps [epsPos epsMaj]]. assert (forall n:nat, 0 < eps * CR_of_Q _ (1#2) * CRpow (CR_of_Q _ (1#2)) n). { intro n. rewrite <- (CRmult_0_r eps). rewrite CRmult_assoc. apply CRmult_lt_compat_l. exact epsPos. rewrite <- (CRmult_0_r (CR_of_Q _ (1#2))). apply CRmult_lt_compat_l. apply CR_of_Q_lt. reflexivity. apply CRpow_gt_zero. apply CR_of_Q_lt. reflexivity. } pose (fun n => IntFn (let (r,_) := AbsRepresentation IS (hn n) (eps*CR_of_Q _ (1#2)*CRpow (CR_of_Q _ (1#2)) n) (hnL n) (H0 n) in r)) as phink. pose ( fun n k : nat => let s1 := AbsRepresentation IS (hn n) (eps * CR_of_Q _ (1#2) * CRpow (CR_of_Q _ (1 # 2)) n) (hnL n) (H0 n) in let (x0, _) as s2 return (L (ElemFunc IS) (IntFn (let (r, _) := s2 in r) k)) := s1 in let X := IntFnL x0 in X k) as phinkL. assert (forall n:nat, { l : CRcarrier _ & (series_cv (fun k => I IS (Xabs (phink n k)) (LabsStable _ _ (phinkL n k))) l) * (l <= Integral (hnL n) + eps * CR_of_Q _ (1#2)* CRpow (CR_of_Q _ (1#2)) n)%ConstructiveReals }%type) as phinkAbsCv. { intro n. unfold phink, phinkL. destruct (AbsRepresentation IS (hn n) (eps * CR_of_Q _ (1#2) * CRpow (CR_of_Q _ (1 # 2)) n) (hnL n) (H0 n)). exists (IntAbsSum x0). split. exact (IntAbsSumCv x0). destruct p. setoid_replace (Integral (hnL n)) with (Integral (IntegrableAbs (hnL n))). exact c0. apply IntegralExtensional. intros. simpl. rewrite CRabs_right. apply DomainProp. apply H. } assert (forall n:nat, PartialRestriction (XinfiniteSumAbs (phink n)) (hn n)) as phinkRes. { intros n. unfold phink. destruct (AbsRepresentation IS (hn n) (eps * CR_of_Q _ (1#2)*CRpow (CR_of_Q _ (1 # 2)) n) (hnL n) (H0 n)). apply p. } destruct hL as [x0 psiRes], x0 as [psik psikL IntAbsSum IntAbsSumCv]. unfold Integral in epsMaj, c. unfold IntFn in psiRes. assert (CR_cv _ (fun K => I IS (Xsum psik K) (LsumStable psik psikL K)) (IntegralSeries {| IntFn := psik; IntFnL := psikL; IntAbsSum := IntAbsSum; IntAbsSumCv := IntAbsSumCv |})) as psiInt. { apply (CR_cv_eq _ (CRsum (fun K => I IS (psik K) (psikL K)))). intro n. rewrite IadditiveIterate. reflexivity. unfold IntegralSeries. destruct ( series_cv_maj (fun n : nat => I IS (psik n) (psikL n)) (fun k : nat => Iabs (psik k) (psikL k)) IntAbsSum (fun n : nat => integralAbsMaj (psik n) (psikL n)) IntAbsSumCv). destruct p. exact s0. } assert ({K : nat & prod (IntegralSeries {| IntFn := psik; IntFnL := psikL; IntAbsSum := IntAbsSum; IntAbsSumCv := IntAbsSumCv |} < I IS (Xsum psik K) (LsumStable psik psikL K) + eps) (series_cv_lim_lt (fun k => I IS (Xabs (psik (k+S K)%nat)) (LabsStable _ _ (psikL _))) eps) }). { pose proof (Un_cv_nat_real _ _ psiInt eps epsPos) as [i imaj]. destruct (series_cv_remainder_cv _ _ eps IntAbsSumCv epsPos) as [j jmaj]. exists (max i j). split. specialize (imaj (max i j) (Nat.le_max_l _ _)). rewrite CRabs_minus_sym in imaj. apply (CRplus_lt_reg_l _ (- I IS (Xsum psik (Init.Nat.max i j)) (LsumStable psik psikL (Init.Nat.max i j)))). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm. apply (CRle_lt_trans _ _ _ (CRle_abs _)). exact imaj. apply jmaj. apply le_S, Nat.le_max_r. } destruct H1 as [K kmaj]. assert (forall n:nat, L (ElemFunc IS) (diagSeq (fun n k => Xabs (phink n k)) n)) as L1. { apply diagSeqL. intros n k. apply LabsStable. apply phinkL. } assert (forall k:nat, L (ElemFunc IS) (Xabs (psik (k+S K)%nat))) as L2. { intro k. apply LabsStable. apply psikL. } destruct (IcontinuousWeave (Xsum psik K) (diagSeq (fun n k => Xabs (phink n k))) (fun k => Xabs (psik (k+S K)%nat)) (LsumStable psik psikL K) L1 L2) as [x0 xcv]. - intro n. unfold diagSeq. destruct (diagPlaneInv n). intros y ydf. apply CRabs_pos. - intros n y ydf. apply CRabs_pos. - destruct kmaj, s0, p. destruct (series_cv_maj (fun n => let (l,_):=phinkAbsCv n in l) (fun n => Integral (hnL n) + eps * CR_of_Q _ (1#2) * CRpow (CR_of_Q _ (1 # 2)) n) (x + eps)). intro n. destruct (phinkAbsCv n). simpl. destruct p. rewrite CRabs_right. exact c2. apply (series_cv_nonneg (fun k : nat => I IS (Xabs (phink n k)) (LabsStable _ _ (phinkL n k)))). intros. apply integralPositive. intros y ydf. apply CRabs_pos. exact s1. apply series_cv_plus. exact s. apply (series_cv_eq (fun n : nat => CRpow (CR_of_Q _ (1 # 2)) n * (eps*CR_of_Q _ (1#2)))). intro n. apply CRmult_comm. apply (CR_cv_proper _ (CR_of_Q _ 2*(eps*CR_of_Q _ (1#2)))). apply series_cv_scale. apply GeoHalfTwo. rewrite CRmult_comm, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1#2) * 2)%Q with 1%Q. rewrite CRmult_1_r. reflexivity. reflexivity. destruct p. exists (x1, x0). unfold fst, snd. split. split. apply (series_cv_eq (diagSeq (fun n k : nat => I IS (Xabs (phink n k)) (LabsStable _ _ (phinkL n k))))). intro n. unfold diagSeq. generalize (L1 n). intros. unfold diagSeq in l. destruct (diagPlaneInv n). apply IExtensional. intros. apply DomainProp. apply (DiagSeqInfiniteSumColPos _ (fun n : nat => let (l, _) := phinkAbsCv n in l)). intros n k. apply integralPositive. intros y ydf. apply CRabs_pos. intro n. destruct (phinkAbsCv n). apply p. exact s1. apply (series_cv_eq (fun k : nat => I IS (Xabs (psik (k + S K)%nat)) (LabsStable (ElemFunc IS) (psik (k + S K)%nat) (psikL (k + S K)%nat)))). intro n. apply IExtensional. intros. apply DomainProp. exact s0. apply (CRplus_le_compat_l (eps+eps)) in c2. do 2 rewrite (CRplus_comm (eps+eps)) in c2. rewrite CRplus_assoc in c2. setoid_replace (eps + (eps+eps)) with (CR_of_Q _ 3 * eps) in c2. pose proof (CRle_lt_trans _ _ _ c2 epsMaj). clear c2. pose proof (CRlt_trans _ _ _ H1 c0). clear H1. rewrite <- CRplus_assoc in H2. apply CRplus_lt_reg_r in H2. apply (CRlt_trans _ (x1 + eps)). apply CRplus_lt_compat_l. exact c1. exact H2. setoid_replace (CR_of_Q (RealT (ElemFunc IS)) 3) with (1+1+CR_of_Q (RealT (ElemFunc IS)) 1). do 2 rewrite CRmult_plus_distr_r. rewrite CRmult_1_l, CRplus_assoc. reflexivity. do 2 rewrite <- CR_of_Q_plus. reflexivity. - destruct x0 as [cpx cpxF cpxFn cpxGn]. simpl in xcv. destruct xcv, p, x0. simpl in p. destruct p. simpl in c0. (* Prove that cpx is in Domain h, because it is in Domain (XinfinitesumAbs psik) *) assert (forall k:nat, Domain (psik k) cpx) as cpxDpsik. { intro k. destruct (le_lt_dec k K). apply (domainXsumIncReverse _ _ K). exact cpxF. exact l. rewrite <- (Nat.sub_add (S K) k). apply cpxGn. exact l. } assert (forall k:nat, Domain (diagSeq phink k) cpx) as cpxDdiagBis. { intro k. unfold diagSeq. destruct (diagPlaneInv k). apply (diagSeqDomain _ (fun n k => Xabs (phink n k)) _ cpxFn). } assert (Domain (XinfiniteSumAbs psik) cpx). { exists cpxDpsik. apply (Rcv_cauchy_mod _ (c2 + CRsum (fun k => partialApply (Xabs (psik k)) cpx (cpxDpsik k)) K)). apply series_cv_shift. apply (series_cv_eq (fun n : nat => CRabs _ (partialApply (psik (n + S K)%nat) cpx (cpxGn n)))). intros. apply CRabs_morph. rewrite (Nat.add_comm (S K)). apply DomainProp. exact s1. } assert (forall n:nat, Domain (XinfiniteSumAbs (phink n)) cpx). { intro n. apply (domainInfiniteSumAbsDiag _ (fun n0 k : nat => phink n0 k) n). exists cpxDdiagBis. apply (Rcv_cauchy_mod _ c1). apply (series_cv_eq (fun n : nat => partialApply (diagSeq (fun n0 k : nat => Xabs (phink n0 k)) n) cpx (cpxFn n))). 2: exact s0. apply applyDiagAbs. } assert (forall n:nat, Domain (hn n) cpx) as cpxDhn. { intro n. apply phinkRes. apply H2. } destruct psiRes. exists (Build_CommonPointFunSeq _ _ _ _ cpx (d _ H1) cpxDhn). simpl. assert ({ l : CRcarrier _ & prod (series_cv (fun n => partialApply _ cpx (cpxDhn n)) l) (l <= c1) }). { destruct (DiagSeqInfiniteSum (fun n k => partialApply (phink n k) cpx (diagSeqDomain _ phink cpx cpxDdiagBis n k)) (fun n => partialApply (hn n) cpx (cpxDhn n)) c1). apply (series_cv_eq (fun n : nat => partialApply (diagSeq (fun n0 k : nat => Xabs (phink n0 k)) n) cpx (cpxFn n))). intro n. rewrite (applyDiagAbs phink cpx cpxFn cpxDdiagBis). unfold diagSeq. generalize (cpxDdiagBis n). intros. unfold diagSeq in d0. destruct (diagPlaneInv n). apply CRabs_morph. apply DomainProp. exact s0. intro n. apply (series_cv_eq (fun k => partialApply (phink n k) cpx (domainInfiniteSumAbsIncReverse (phink n) cpx (H2 n) k))). intro i. apply DomainProp. apply applyInfiniteSumAbs. apply phinkRes. exists x0. split; apply p. } destruct H3, p. assert ({ l : CRcarrier _ & prod (series_cv (fun n => partialApply _ cpx (cpxDpsik (n+S K)%nat)) l) (CRabs _ l <= c2) }). { destruct (series_cv_abs (fun n => partialApply _ cpx (cpxDpsik (n+S K)%nat))). apply (Rcv_cauchy_mod _ c2). apply (series_cv_eq (fun n : nat => CRabs _ (partialApply (psik (n + S K)%nat) cpx (cpxGn n)))). intro n. apply CRabs_morph. apply DomainProp. exact s1. exists x1. split. exact s3. apply (series_cv_triangle (fun n => partialApply _ cpx (cpxDpsik (n+S K)%nat))). exact s3. apply (series_cv_eq (fun n : nat => CRabs _ (partialApply (psik (n + S K)%nat) cpx (cpxGn n)))). intro n. apply CRabs_morph. apply DomainProp. exact s1. } destruct H3. assert (x0 - x1 < partialApply (Xsum psik K) cpx cpxF). { apply (CRle_lt_trans _ (c1 + c2)). 2: exact c0. apply CRplus_le_compat. exact c4. apply (CRle_trans _ (CRabs _ x1)). rewrite <- CRabs_opp. apply CRle_abs. apply p. } destruct p. clear c1 s0 c0 c4. clear c2 s1 c5. apply (CRplus_lt_compat_r x1) in H3. unfold CRminus in H3. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r in H3. exists x0. split. exact s2. rewrite (applyXsum _ K cpx _ cpxDpsik), CRplus_comm in H3. rewrite <- (c3 cpx H1). setoid_replace (partialApply (XinfiniteSumAbs psik) cpx H1) with (x1 + CRsum (fun k : nat => partialApply (psik k) cpx (cpxDpsik k)) K). exact H3. apply applyInfiniteSumAbs. apply (series_cv_eq (fun n : nat => partialApply (psik n) cpx (cpxDpsik n))). intro n. apply DomainProp. apply series_cv_shift. apply (series_cv_eq (fun n : nat => partialApply (psik (n + S K)%nat) cpx (cpxDpsik (n + S K)%nat))). intro n. rewrite Nat.add_comm. reflexivity. exact s3. Qed. Lemma IntegralTruncateLimitZero : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), CR_cv _ (fun n : nat => Integral (IntegrableMinConst (Xabs f) (CR_of_Q _ (1 # Pos.of_nat (S n))) (IntegrableAbs fInt) (invSuccRealPositive n))) 0. Proof. intros. intro p. destruct (IntegralDense f fInt (2*p)%positive) as [n nmaj]. destruct (Ilimit IS (Xsum (IntFn (let (intRepres, _) := fInt in intRepres)) n) (LsumStable (IntFn (let (intRepres, _) := fInt in intRepres)) (IntFnL (let (intRepres, _) := fInt in intRepres)) n)) as [_ cv]. specialize (cv (2*p)%positive) as [k kmaj]. exists (max n k). intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. apply (CRle_trans _ (Integral (IntegrableMinConst (Xabs f) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S (max n k)))) (IntegrableAbs fInt) (invSuccRealPositive (max n k))))). - apply IntegralNonDecreasing. intros y ydf ydg. apply CRmin_glb. rewrite applyXminConst, (DomainProp _ y ydf ydg). apply CRmin_l. apply (CRle_trans _ (CR_of_Q _ (1 # Pos.of_nat (S i)))). apply CRmin_r. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. apply le_n_S, H. discriminate. discriminate. - clear H i. specialize (nmaj n (Nat.le_refl n)). specialize (kmaj (max n k) (Nat.le_max_r _ _)). unfold IntegralDistance in nmaj. rewrite <- CRplus_0_r. rewrite <- (CRplus_opp_l (CRabs (RealT (ElemFunc IS)) (I IS _ (LminConstStable (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S (Init.Nat.max n k)))) (Xabs (Xsum (IntFn (let (intRepres, _) := fInt in intRepres)) n)) (invSuccRealPositive (Init.Nat.max n k)) (LabsStable (ElemFunc IS) (Xsum (IntFn (let (intRepres, _) := fInt in intRepres)) n) (LsumStable (IntFn (let (intRepres, _) := fInt in intRepres)) (IntFnL (let (intRepres, _) := fInt in intRepres)) n))) - 0))). rewrite <- CRplus_assoc. setoid_replace (CR_of_Q (RealT (ElemFunc IS)) (1 # p)) with (CR_of_Q (RealT (ElemFunc IS)) (1 # (2*p)) + CR_of_Q _ (1 # (2*p))). apply CRplus_le_compat. 2: exact kmaj. clear kmaj. unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. rewrite <- IntegralLstable. pose proof (@IntegralMinus IS). unfold CRminus in H. rewrite <- H. clear H. refine (CRle_trans _ _ _ _ nmaj). clear nmaj. apply IntegralNonDecreasing. intros y ydf ydg. destruct ydf, ydg. rewrite applyXabs. rewrite (applyXminus _ f y d1 d2), CRabs_minus_sym. rewrite (applyXminus _ (XminConst (Xabs (Xsum (IntFn (let (intRepres, _) := fInt in intRepres)) n)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S (Init.Nat.max n k))))) y d d0). rewrite applyXminConst, applyXminConst. apply (CRle_trans _ _ _ (CRle_abs _)). apply (CRle_trans _ _ _ (CRmin_contract _ _ _)). rewrite (DomainProp f y d2 d), applyXabs. rewrite (DomainProp _ y d1 d0), applyXabs. apply CRabs_triang_inv2. apply integralPositive. intros y ydf. apply CRmin_glb. apply CRabs_pos. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. reflexivity. - apply IntegralNonNeg. intros y ydf. apply CRmin_glb. apply CRabs_pos. apply CR_of_Q_le. discriminate. Qed. (* Theorem 1.18 of Bishop *) Definition IntegrationSpaceCompletion (IS : IntegrationSpace) : IntegrationSpace := Build_IntegrationSpace (FunctionRieszSpaceCompletion IS) (fun f fInt => Integral fInt) IntegralPlus (fun a f fInt => CReq_trans _ ((Integral fInt) * a) _ (IntegralScale f fInt a) (CRmult_comm _ _)) (Ione IS) (IntegrableL (Ione IS) (IoneL IS)) (CReq_trans _ (I IS (Ione IS) (IoneL IS)) _ (IntegralLstable _ _) (IoneInt IS)) IntegrableContinuous (fun f fL => pair (IntegralTruncateLimit f fL) (IntegralTruncateLimitZero f fL)). (* There is no need to consider integrable functions on IntegrationSpaceCompletion, it is only its L functions. *) Lemma IntegrationSpaceComplete : forall (IS : IntegrationSpace) (f : PartialFunction (X (ElemFunc IS))), @IntegrableFunction (IntegrationSpaceCompletion IS) f -> L (ElemFunc (IntegrationSpaceCompletion IS)) f. Proof. intros IS f fInt. simpl. destruct fInt, x. destruct (IntegrableFunctionsComplete IS IntFn IntFnL IntAbsSum IntAbsSumCv). exists x. destruct x. simpl. simpl in p0. apply (PartialRestriction_trans _ _ (XinfiniteSumAbs IntFn)). apply p0. exact p. Qed. corn-8.20.0/reals/stdlib/CMTIntegrableFunctions.v000066400000000000000000003047721473720167500216620ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* We complete an integration space IS by countable limits of L-functions. Those limit functions are called integrable functions and the integral I extends to them. Hence we obtain a bigger integration space IScomplete, which L-functions are the integrable functions of IS. IScomplete is complete, in the sense that its integrable functions are already integrable functions of IS : no new functions are added. *) From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructiveLimits. Require Import ConstructivePartialFunctions. Require Import CMTbase. Local Open Scope ConstructiveReals. (* A function f is integrable iif it is the pointwise limit almost everywhere of a sequence of L-functions, which integrals converge. Keep the convergence proof in sort Prop at the moment, so that it is unique. *) (* A series of elementary integrals, that converges absolutely. *) Record IntegralRepresentation {IS : IntegrationSpace} : Type := { IntFn : nat -> PartialFunction (X (ElemFunc IS)); IntFnL : forall n:nat, L (ElemFunc IS) (IntFn n); IntAbsSum : CRcarrier (RealT (ElemFunc IS)); (* Convergence with computable modulus, we want to extract it. *) IntAbsSumCv : series_cv (fun k:nat => Iabs (IntFn k) (IntFnL k)) IntAbsSum }. (* A function f is integrable when it is the limit almost everywhere of the L-series fn. Here "almost everywhere" is encoded as where the series fn converges absolutely. It is equivalent to Daniell's definition of null sets. *) Lemma IntAbsSumPos : forall {IS : IntegrationSpace} (fInt : @IntegralRepresentation IS), 0 <= IntAbsSum fInt. Proof. intros. destruct fInt; simpl. apply (series_cv_nonneg ((fun k : nat => Iabs (IntFn0 k) (IntFnL0 k)))). intros. apply integralPositive. intros. intros x xdf. rewrite applyXabs. apply CRabs_pos. assumption. Qed. Lemma represApply : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegralRepresentation) (isFInt : PartialRestriction (XinfiniteSumAbs (IntFn fInt)) f) (x : X (ElemFunc IS)) (xS : Domain (XinfiniteSumAbs (IntFn fInt)) x) (y : Domain f x), series_cv (fun n : nat => partialApply (IntFn fInt n) x (domainInfiniteSumAbsIncReverse (IntFn fInt) x xS n)) (partialApply f x y). Proof. intros. destruct isFInt as [i appX]. specialize (appX x xS y). apply (CR_cv_proper _ (partialApply (XinfiniteSumAbs (IntFn fInt)) x xS)). 2: exact appX. clear appX. simpl. destruct xS; simpl. destruct (series_cv_abs (fun n : nat => partialApply (IntFn fInt n) x (x0 n))). exact s. Qed. Definition IntegrableFunction {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) : Type := { fInt : IntegralRepresentation & PartialRestriction (XinfiniteSumAbs (IntFn fInt)) f }. (* As proven by INonDecreasing, L-functions on X are defined almost everywhere on X. So the previous definition can be summarized : the infinite sum of fn converges almost everywhere to f and the integral of f is the infinite sum of the integrals of fn. *) Definition IntegrableFunctionExtensional {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) : PartialRestriction f g -> IntegrableFunction f -> IntegrableFunction g. Proof. intros [inj restr] [rep [injF isrep]]. exists rep. split. - exact (fun x xS => inj x (injF x xS)). - intros. rewrite (isrep x _ (injF x xD)). apply restr. Defined. (* This will be redefined shortly after as the integral of XinfiniteSumAbs (IntFn fInt). This definition is rarely used directly. *) Definition IntegralSeries {IS : IntegrationSpace} (fInt : @IntegralRepresentation IS) : CRcarrier (RealT (ElemFunc IS)). Proof. destruct fInt; simpl. destruct (series_cv_maj (fun n : nat => I IS (IntFn0 n) (IntFnL0 n)) (fun k : nat => Iabs (IntFn0 k) (IntFnL0 k)) IntAbsSum0). intro n. apply integralAbsMaj. assumption. exact x. Defined. Definition Integral {IS : IntegrationSpace} {f : PartialFunction (X (ElemFunc IS))} (fInt : IntegrableFunction f) := IntegralSeries (let (i,_) := fInt in i). Definition IntegralCv {IS : IntegrationSpace} (fInt : IntegralRepresentation) : series_cv (fun n : nat => (I IS (IntFn fInt n) (IntFnL fInt n))) (IntegralSeries fInt). Proof. destruct fInt; simpl. destruct (series_cv_maj (fun n : nat => I IS (IntFn0 n) (IntFnL0 n)) (fun k : nat => Iabs (IntFn0 k) (IntFnL0 k)) IntAbsSum0). apply p. Qed. (* An extension of an integrable function has the same integral. In particular, if the domain of an L-function g is included in the domain of a function f, and if f equals zero on the domain of g, then f is integrable with integral 0. Multiply g by 0 and apply this lemma to demonstrate it. In other words, L-functions are defined almost everywhere. *) Lemma IntegralRestrict : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (restrict : PartialRestriction f g), Integral (IntegrableFunctionExtensional f g restrict fInt) = Integral fInt. Proof. intros. destruct fInt, restrict, p; simpl. reflexivity. Qed. (* We now prove that the integral of f does not depend on the representation fn. If gn is another representation of f, we will prove that the sequence f0, -g0, f1, -g1, f2, -g2, ... is a representation of the zero function, with integral 0. Note that the sequence f0-g0, f1-g1, ... does not work, because the convergence of Sum_n |fn - gn| does not imply the convergence of Sum_n |fn|. So we first need to combine two sequences into one. Of course, we can iterate this to combine any finite number of sequences into one. *) Definition weaveSequences (X : Type) (fn gn : nat -> X) : nat -> X := fun n => if Nat.even n then fn (n / 2)%nat else gn (n / 2)%nat. Definition weaveSequencesL (E : FunctionRieszSpace) (fn : nat -> PartialFunction (X E)) (fnL : forall n:nat, L E (fn n)) (gn : nat -> PartialFunction (X E)) (gnL : forall n:nat, L E (gn n)) : forall n:nat, L E (weaveSequences (PartialFunction (X E)) fn gn n). Proof. intros. unfold weaveSequences. destruct (Nat.even n). apply fnL. apply gnL. Defined. Lemma evenSuccessor : forall n:nat, Nat.even (S n) = negb (Nat.even n). Proof. induction n. reflexivity. rewrite IHn. simpl. destruct (Nat.even n); reflexivity. Qed. Lemma weaveSequencesEven : forall (X : Set) (fn gn : nat -> X) (n : nat), weaveSequences X fn gn (n*2) = fn n. Proof. intros. unfold weaveSequences. destruct (Nat.even (n * 2)) eqn:even. rewrite Nat.div_mul. reflexivity. discriminate. exfalso. assert (Nat.even (n * 2) = true). apply Nat.even_spec. exists n. rewrite Nat.mul_comm. reflexivity. rewrite even in H. discriminate. Qed. Lemma weaveSequencesOdd : forall (X : Set) (fn gn : nat -> X) (n : nat), weaveSequences X fn gn (1 + n*2) = gn n. Proof. intros. unfold weaveSequences. destruct (Nat.even (1 + n * 2)) eqn:even. exfalso. rewrite evenSuccessor in even. assert (Nat.even (n * 2) = true). apply Nat.even_spec. exists n. rewrite Nat.mul_comm. reflexivity. rewrite H in even. discriminate. rewrite Nat.div_add. simpl. reflexivity. auto. Qed. Lemma divModSucc : forall n p q : nat, fst (Nat.divmod n 1 (S q) p) = S (fst (Nat.divmod n 1 q p)). Proof. induction n. - intros. reflexivity. - intros. simpl. destruct p. rewrite IHn. reflexivity. rewrite IHn. reflexivity. Qed. Lemma weaveSequencesSum : forall {R : ConstructiveReals} (fn gn : nat -> CRcarrier R) (n : nat), CRsum (fun k:nat => (weaveSequences (CRcarrier R) fn gn k)) n == CRsum fn (n / 2) + match n with | O => 0 | _ => CRsum gn (if Nat.even n then pred (n / 2) else n / 2) end. Proof. induction n. - unfold weaveSequences. simpl. rewrite CRplus_0_r. reflexivity. - simpl. rewrite IHn. clear IHn. destruct n. unfold weaveSequences. simpl. rewrite CRplus_0_r. reflexivity. assert (fst (Nat.divmod n 1 0 1) = n/2 )%nat. { reflexivity. } assert (fst (Nat.divmod n 1 0 0) = (1+n)/2 )%nat. { reflexivity. } unfold weaveSequences. simpl. destruct (Nat.even n) eqn:nEven. + destruct n. simpl. rewrite CRplus_assoc, (CRplus_comm (gn 0%nat)). rewrite <- CRplus_assoc. reflexivity. destruct (Nat.even n) eqn:snEven. rewrite evenSuccessor in nEven. rewrite snEven in nEven. inversion nEven. rewrite divModSucc. rewrite H. rewrite H0. pose proof (Nat.even_spec (S n)) as [H1 _]. destruct (H1 nEven). rewrite Nat.mul_comm in H2. rewrite H2. rewrite Nat.div_add. rewrite Nat.div_mul. simpl. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. apply CRplus_comm. auto. auto. + destruct n. exfalso. inversion nEven. destruct (Nat.even n) eqn:snEven. rewrite divModSucc. rewrite H. rewrite H0. pose proof (Nat.odd_spec (S n)) as [H1 _]. destruct H1. unfold Nat.odd. rewrite nEven. trivial. rewrite Nat.mul_comm in H1. rewrite Nat.add_comm in H1. rewrite H1. rewrite Nat.div_add. assert ((1 + (1 + x * 2)) / 2 = (2 + x * 2) / 2)%nat. reflexivity. rewrite H2. rewrite Nat.div_add. simpl. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. apply CRplus_morph. reflexivity. reflexivity. auto. auto. exfalso. rewrite <- nEven in snEven. rewrite evenSuccessor in snEven. destruct (Nat.even n); discriminate. Qed. Lemma partialApplyWeave : forall {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (n : nat) (x : X) (xH : Domain (fn (n/2)%nat) x) (y : Domain (gn (n/2)%nat) x) (z : Domain (weaveSequences (PartialFunction X) fn gn n) x), partialApply (weaveSequences (PartialFunction X) fn gn n) x z == if Nat.even n then partialApply (fn (n/2)%nat) x xH else partialApply (gn (n/2)%nat) x y. Proof. intros. unfold weaveSequences. unfold weaveSequences in z. unfold weaveSequences in xH. destruct (Nat.even n); apply DomainProp. Qed. Definition domainWeaveEvenInc {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (weaveSequences _ fn gn (n*2)) x) : Domain (fn n) x. Proof. unfold weaveSequences. unfold weaveSequences in xD. destruct (Nat.even (n*2)) eqn:des. - remember (n*2/2)%nat. rewrite Nat.div_mul in Heqn0. subst n0. exact xD. auto. - exfalso. assert (Nat.even (n * 2) = true). apply Nat.even_spec. exists n. rewrite Nat.mul_comm. reflexivity. rewrite des in H. discriminate. Qed. Lemma partialApplyWeaveEven : forall {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (fn n) x) (y : Domain (weaveSequences (PartialFunction X) fn gn (n*2)) x), partialApply (fn n) x xD == partialApply (weaveSequences (PartialFunction X) fn gn (n * 2)) x y. Proof. intros. unfold weaveSequences. unfold weaveSequences in y. destruct (Nat.even (n * 2)) eqn:des. (* Hide 2 * n / 2 in a single variable, to substitute it *) remember ((n * 2) / 2)%nat as doubleN. rewrite Nat.div_mul in HeqdoubleN. subst doubleN. apply DomainProp. auto. exfalso. assert (Nat.even (n * 2) = true). apply Nat.even_spec. exists n. rewrite Nat.mul_comm. reflexivity. rewrite des in H. discriminate. Qed. Definition domainWeaveOddInc {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (weaveSequences _ fn gn (1+n*2)) x) : Domain (gn n) x. Proof. unfold weaveSequences. unfold weaveSequences in xD. destruct (Nat.even (1+n*2)) eqn:des. - exfalso. assert (Nat.odd (1+ n * 2) = true). apply Nat.odd_spec. exists n. rewrite Nat.mul_comm. rewrite Nat.add_comm. reflexivity. unfold Nat.odd in H. rewrite des in H. discriminate. - remember ((1+n*2)/2)%nat. rewrite Nat.div_add in Heqn0. subst n0. exact xD. auto. Qed. Lemma partialApplyWeaveOdd : forall {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (gn n) x) (y : Domain (weaveSequences (PartialFunction X) fn gn (1 + (n*2))) x), partialApply (gn n) x xD == partialApply (weaveSequences (PartialFunction X) fn gn (1 + (n * 2))) x y. Proof. intros. unfold weaveSequences. unfold weaveSequences in y. destruct (Nat.even (1+(n * 2))) eqn:even. exfalso. assert (Nat.even (n * 2) = true). apply Nat.even_spec. exists n. rewrite Nat.mul_comm. reflexivity. rewrite evenSuccessor in even. rewrite H in even. discriminate. (* Hide 2 * n / 2 in a single variable, to substitute it *) remember ((1 + (n * 2)) / 2)%nat as doubleN. rewrite Nat.div_add in HeqdoubleN. simpl in HeqdoubleN. subst doubleN. apply DomainProp. auto. Qed. Lemma halfWeavedSumEven : forall {R : ConstructiveReals} (fn gn : nat -> CRcarrier R) (a : CRcarrier R), (forall k:nat, 0 <= fn k) -> (forall k:nat, 0 <= gn k) -> series_cv (weaveSequences (CRcarrier R) fn gn) a -> { l : CRcarrier R & series_cv fn l }. Proof. intros. destruct (series_cv_maj (weaveSequences (CRcarrier R) fn (fun n => 0)) (weaveSequences (CRcarrier R) fn gn) a) as [l [cv _]]. - intro n. unfold weaveSequences. destruct (Nat.even n). rewrite CRabs_right. apply CRle_refl. apply H. rewrite CRabs_right. apply H0. apply CRle_refl. - assumption. - exists l. intros n. specialize (cv n) as [N cv]. exists N. intros. specialize (cv (i*2)%nat). rewrite weaveSequencesSum in cv. rewrite Nat.div_mul in cv. setoid_replace (match (i * 2)%nat with | 0%nat => CR_of_Q R 0 | S _ => CRsum (fun _ : nat => 0) (if Nat.even (i * 2) then Init.Nat.pred i else i) end) with (CR_of_Q R 0) in cv. rewrite CRplus_0_r in cv. apply cv. apply (Nat.le_trans _ i). assumption. rewrite Nat.mul_comm. simpl. rewrite <- (Nat.add_0_r i). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. destruct (i*2)%nat eqn:des. reflexivity. rewrite sum_const. rewrite CRmult_0_l. reflexivity. auto. Qed. Lemma halfWeavedSumOdd : forall {R : ConstructiveReals} (fn gn : nat -> CRcarrier R) (a : CRcarrier R), (forall k:nat, 0 <= fn k) -> (forall k:nat, 0 <= gn k) -> series_cv (weaveSequences (CRcarrier R) fn gn) a -> { l : CRcarrier R & series_cv gn l }. Proof. intros. destruct (series_cv_maj (weaveSequences (CRcarrier R) (fun n => 0) gn) (weaveSequences (CRcarrier R) fn gn) a) as [l [cv _]]. - intro n. unfold weaveSequences. destruct (Nat.even n). rewrite CRabs_right. apply H. apply CRle_refl. rewrite CRabs_right. apply CRle_refl. apply H0. - assumption. - exists l. intros p. specialize (cv p) as [N cv]. exists N. intros n H2. specialize (cv (1+n*2)%nat). rewrite weaveSequencesSum in cv. rewrite Nat.div_add in cv. rewrite sum_const in cv. rewrite CRmult_0_l in cv. rewrite CRplus_0_l in cv. destruct (1 + n*2)%nat eqn:des. + exfalso. inversion des. + rewrite <- des in cv. clear des. destruct (Nat.even (1+n*2)) eqn:des. exfalso. assert (Nat.Odd (1+n*2)). exists n. rewrite Nat.add_comm. rewrite Nat.mul_comm. reflexivity. apply Nat.odd_spec in H3. unfold Nat.odd in H3. rewrite des in H3. inversion H3. apply cv. apply (Nat.le_trans N n). assumption. apply (Nat.le_trans n (n*2)). rewrite <- (Nat.mul_1_r n). rewrite <- Nat.mul_assoc. apply Nat.mul_le_mono_nonneg_l. apply Nat.le_0_l. apply le_S. apply Nat.le_refl. rewrite <- (Nat.add_0_l (n*2)). rewrite Nat.add_assoc. apply Nat.add_le_mono_r. auto. + auto. Qed. Lemma weaveInfiniteSums : forall {R : ConstructiveReals} (u v : nat -> CRcarrier R) (su sv : CRcarrier R), series_cv u su -> series_cv v sv -> series_cv (weaveSequences (CRcarrier R) u v) (su + sv). Proof. intros. intros n. specialize (H (2*n)%positive). specialize (H0 (2*n)%positive). destruct H as [N H], H0 as [N0 H0]. exists (S(N*2 + (S N0)*2)). intros. rewrite weaveSequencesSum. destruct i. exfalso; inversion H1. destruct (Nat.even (S i)) eqn:snEven. + setoid_replace (CRsum u (S i / 2) + CRsum v (Init.Nat.pred (S i / 2)) - (su + sv)) with (CRsum u (S i / 2) - su + (CRsum v (Init.Nat.pred (S i / 2)) - sv)). apply (CRle_trans _ _ _ (CRabs_triang _ _)). setoid_replace (1 # n)%Q with ((1 # (2*n)) + (1 # (2*n)))%Q. apply le_S_n in H1. rewrite CR_of_Q_plus. apply CRplus_le_compat. apply H. rewrite <- (Nat.div_mul N 2). apply Nat.div_le_mono. auto. apply (Nat.le_trans (N*2) (N*2 + (S N0)*2)). apply Nat.le_add_r. apply (Nat.le_trans _ i). assumption. apply le_S. apply Nat.le_refl. auto. apply H0. assert (N0 = pred (S N0)). reflexivity. rewrite H2. apply Nat.pred_le_mono. rewrite <- (Nat.div_mul (S N0) 2). apply Nat.div_le_mono. auto. apply (Nat.le_trans _ (N*2 + (S N0)*2)). rewrite Nat.add_comm. apply Nat.le_add_r. apply (Nat.le_trans (N*2 + (S N0)*2) i). assumption. apply le_S. apply Nat.le_refl. auto. rewrite Qinv_plus_distr. reflexivity. unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr, CRplus_comm. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. apply CRplus_comm. + setoid_replace (CRsum u (S i / 2) + CRsum v (S i / 2) - (su + sv)) with (CRsum u (S i / 2) - su + (CRsum v (S i / 2) - sv)). apply (CRle_trans _ _ _ (CRabs_triang _ _)). setoid_replace (1 # n)%Q with ((1 # (2*n)) + (1 # (2*n)))%Q. apply le_S_n in H1. rewrite CR_of_Q_plus. apply CRplus_le_compat. apply H. rewrite <- (Nat.div_mul N 2). apply Nat.div_le_mono. auto. apply (Nat.le_trans (N*2) (N*2 + (S N0)*2)). apply Nat.le_add_r. apply (Nat.le_trans _ i). assumption. apply le_S. apply Nat.le_refl. auto. apply H0. rewrite <- (Nat.div_mul N0 2). apply Nat.div_le_mono. auto. apply (Nat.le_trans (N0*2) (N*2 + (S N0)*2)). rewrite Nat.add_comm. apply (Nat.le_trans (N0 * 2) (S N0 * 2)). apply Nat.mul_le_mono_r. apply le_S. apply Nat.le_refl. apply Nat.le_add_r. apply (Nat.le_trans _ i). assumption. apply le_S. apply Nat.le_refl. auto. rewrite Qinv_plus_distr. reflexivity. unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr, CRplus_comm. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. apply CRplus_comm. Qed. Lemma sum_truncate_above : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (N n : nat), le N n -> CRsum (fun n0 : nat => if le_dec n0 N then u n0 else 0) n == CRsum u N. Proof. intros. destruct (Nat.eq_dec N n). - subst N. apply CRsum_eq. intros. destruct (le_dec i n). reflexivity. contradiction. - (* N < n so we can split the sum in 2 and use sum_assoc. *) destruct (Nat.le_exists_sub (S N) n) as [p [H0 _]]. + pose proof (Nat.lt_ge_cases N n) as [H0|H1]. apply H0. exfalso. exact (n0 (Nat.le_antisymm N n H H1)). + subst n. rewrite Nat.add_comm. rewrite sum_assoc. assert (CRsum (fun k : nat => if le_dec (S N + k) N then u (S N + k)%nat else 0) p == 0). { rewrite <- (CRsum_eq (fun k => 0)). rewrite sum_const. apply CRmult_0_l. intros. destruct (le_dec (S N + i)). exfalso. assert (S N <= N)%nat. apply (Nat.le_trans (S N) (S N + i)). apply Nat.le_add_r. assumption. exact (Nat.nle_succ_diag_l N H1). reflexivity. } rewrite H0. rewrite CRplus_0_r. rewrite (CRsum_eq u (fun n1 : nat => if le_dec n1 N then u n1 else 0)). reflexivity. intros. destruct (le_dec i N). reflexivity. contradiction. Qed. Lemma infinite_sum_truncate_below : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (s : CRcarrier R) (N : nat), series_cv u s -> series_cv (fun n : nat => if le_dec n N then 0 else u n) (s - CRsum u N). Proof. intros. apply (series_cv_eq (fun n : nat => u n + (if le_dec n N then (-u n) else 0))). intros. destruct (le_dec n N). rewrite CRplus_opp_r. reflexivity. rewrite CRplus_0_r. reflexivity. apply series_cv_plus. assumption. intros n. exists N. intros. rewrite sum_truncate_above. rewrite <- (CRsum_eq (fun n0 : nat => u n0 * (CRopp R 1))). rewrite sum_scale, CRmult_comm. rewrite <- (CRopp_mult_distr_l 1). unfold CRminus. rewrite <- CRopp_plus_distr. rewrite CRabs_opp. rewrite CRmult_1_l. rewrite CRplus_opp_r. rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. intros. rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. assumption. Qed. Lemma partialApplyWeaveInfiniteSum : forall {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (x : X) (xD : Domain (XinfiniteSumAbs fn) x) (y : Domain (XinfiniteSumAbs gn) x) (pxDn : forall n:nat, Domain (weaveSequences (PartialFunction X) fn gn n) x), series_cv (fun n : nat => partialApply (weaveSequences (PartialFunction X) fn gn n) x (pxDn n)) (partialApply (XinfiniteSumAbs fn) x xD + partialApply (XinfiniteSumAbs gn) x y). Proof. intros. apply (series_cv_eq (weaveSequences (CRcarrier R) (fun n => partialApply (fn n) x (domainInfiniteSumAbsIncReverse _ x xD n)) (fun n => partialApply (gn n) x (domainInfiniteSumAbsIncReverse _ x y n)))). intro n. destruct (Nat.even n) eqn:nEven. - pose proof (Nat.even_spec n) as [H2 _]. destruct (H2 nEven) as [m H3]. subst n. rewrite Nat.mul_comm. rewrite <- (partialApplyWeaveEven X fn gn m x (domainInfiniteSumAbsIncReverse _ x xD m)). + rewrite weaveSequencesEven. reflexivity. - pose proof (Nat.odd_spec n) as [H2 _]. destruct H2 as [m H3]. unfold Nat.odd. rewrite nEven. trivial. subst n. rewrite Nat.add_comm. rewrite Nat.mul_comm. rewrite <- (partialApplyWeaveOdd X fn gn m x (domainInfiniteSumAbsIncReverse _ x y m)). + rewrite weaveSequencesOdd. reflexivity. - apply weaveInfiniteSums. apply applyInfiniteSumAbs. reflexivity. apply applyInfiniteSumAbs. reflexivity. Qed. (* The Prop part, hidden behind a Qed. The exposed part in sort Type comes right after. *) Definition IntegralRepresentationZero {IS : IntegrationSpace} : @IntegralRepresentation IS. Proof. apply (Build_IntegralRepresentation IS (fun _ : nat => Izero IS) (fun _ : nat => Izero_is_L IS) 0). apply (series_cv_eq (fun n => 0)). intro n. unfold Iabs. rewrite <- (Izero_is_zero IS). apply IExtensional. intros. unfold Izero. rewrite applyXscale. rewrite CRmult_0_l. rewrite applyXabs. rewrite applyXscale. rewrite CRmult_0_l. rewrite CRabs_right. reflexivity. apply CRle_refl. intros n. exists O. intros. rewrite sum_const. rewrite CRmult_0_l. unfold CRminus. rewrite CRplus_0_l, CRopp_0. rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. Defined. Lemma IntegrableZeroMaj : forall {IS : IntegrationSpace}, PartialRestriction (XinfiniteSumAbs (IntFn (IntegralRepresentationZero))) (Xconst (X (ElemFunc IS)) 0). Proof. split. - intros x [xn cv]. simpl. trivial. - intros. destruct xD as [xn cv]. transitivity (CR_of_Q (RealT (ElemFunc IS)) 0). apply applyInfiniteSumAbs. apply (series_cv_eq (fun _ => 0)). intro n. unfold IntegralRepresentationZero, IntFn. rewrite applyIzero. reflexivity. intros p. exists O. intros. rewrite sum_const. rewrite CRmult_0_l. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. reflexivity. Qed. Definition IntegrableZero {IS : IntegrationSpace} : IntegrableFunction (Xconst (X (ElemFunc IS)) 0). Proof. exists (IntegralRepresentationZero). apply IntegrableZeroMaj. Defined. Lemma IntegralZeroIsZero : forall {IS : IntegrationSpace}, Integral (@IntegrableZero IS) == 0. Proof. intros IS; unfold Integral. pose proof (IntegralCv (@IntegralRepresentationZero IS)). apply (series_cv_unique (fun _ : nat => I IS (Izero IS) (Izero_is_L IS))). assumption. apply (CR_cv_eq _ (fun _ => 0)). 2: apply CR_cv_const. intros. rewrite sum_const. unfold Izero. unfold Izero_is_L. rewrite Ihomogeneous. rewrite CRmult_0_l. rewrite CRmult_0_l. reflexivity. Qed. Definition domainInfinSumWeaveL {R : ConstructiveReals} (X : Set) (fn gn : nat -> @PartialFunction R X) (x : X) (xD : Domain (XinfiniteSumAbs (weaveSequences _ fn gn)) x) : Domain (@XinfiniteSumAbs R _ fn) x. Proof. pose (fun n => domainWeaveEvenInc X fn gn n x (domainInfiniteSumAbsIncReverse _ x xD (n*2))) as pxDFn. pose (fun n => domainWeaveOddInc X fn gn n x (domainInfiniteSumAbsIncReverse _ x xD (1+n*2))) as pxDGn. destruct xD as [xn cv]; simpl in pxDFn, pxDGn. pose proof (CR_complete R _ cv) as [lim cv2]. destruct (halfWeavedSumEven (fun n => CRabs _ (partialApply (fn n) x (pxDFn n))) (fun n => CRabs _ (partialApply (gn n) x (pxDGn n))) lim) as [l cvl]. intro k. apply CRabs_pos. intro k. apply CRabs_pos. apply (CR_cv_eq _ (CRsum (fun k : nat => CRabs _ (partialApply (weaveSequences (PartialFunction X) fn gn k) x (xn k))))). 2: apply cv2. intro n. apply CRsum_eq. intros. rewrite (partialApplyWeave X fn gn i x (pxDFn (i/2)%nat) (pxDGn (i/2)%nat)). - unfold weaveSequences. destruct (Nat.even i); reflexivity. - exists pxDFn. exact (Rcv_cauchy_mod _ l cvl). Qed. Definition domainInfinSumWeaveR {R : ConstructiveReals} (X : Set) (fn gn : nat -> PartialFunction X) (x : X) (xD : Domain (XinfiniteSumAbs (weaveSequences _ fn gn)) x) : Domain (@XinfiniteSumAbs R _ gn) x. Proof. pose (fun n => domainWeaveEvenInc X fn gn n x (domainInfiniteSumAbsIncReverse _ x xD (n*2))) as pxDFn. pose (fun n => domainWeaveOddInc X fn gn n x (domainInfiniteSumAbsIncReverse _ x xD (1+n*2))) as pxDGn. destruct xD as [xn cv]; simpl in pxDFn, pxDGn. pose proof (CR_complete R _ cv) as [lim cv2]. destruct (halfWeavedSumOdd (fun n => CRabs _ (partialApply (fn n) x (pxDFn n))) (fun n => CRabs _ (partialApply (gn n) x (pxDGn n))) lim) as [l cvl]. intro k. apply CRabs_pos. intro k. apply CRabs_pos. apply (CR_cv_eq _ (CRsum (fun k : nat => CRabs _ (partialApply (weaveSequences (PartialFunction X) fn gn k) x (xn k))))). 2: apply cv2. intro n. apply CRsum_eq. intros. rewrite (partialApplyWeave X fn gn i x (pxDFn (i/2)%nat) (pxDGn (i/2)%nat)). - unfold weaveSequences. destruct (Nat.even i); reflexivity. - exists pxDGn. exact (Rcv_cauchy_mod _ l cvl). Qed. Definition IntegralRepresentationPlus {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (g : PartialFunction (X (ElemFunc IS))) (gInt : IntegrableFunction g) : @IntegralRepresentation IS. Proof. destruct fInt as [fInt injF], gInt as [gInt injG]. apply (Build_IntegralRepresentation IS _ (weaveSequencesL (ElemFunc IS) (IntFn fInt) (IntFnL fInt) (IntFn gInt) (IntFnL gInt)) (IntAbsSum fInt + IntAbsSum gInt)). (* Limit of sum of integrals of absolute values *) destruct fInt, gInt; simpl. apply (series_cv_eq (weaveSequences (CRcarrier (RealT (ElemFunc IS))) (fun n => Iabs (IntFn0 n) (IntFnL0 n)) (fun n => Iabs (IntFn1 n) (IntFnL1 n)))). intro n. unfold weaveSequences. unfold weaveSequencesL. destruct (Nat.even n); reflexivity. apply weaveInfiniteSums; assumption. Defined. Definition IntegralRepresentationPlusInj {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (g : PartialFunction (X (ElemFunc IS))) (gInt : IntegrableFunction g) (x : X (ElemFunc IS)) (xD : Domain (XinfiniteSumAbs (IntFn (IntegralRepresentationPlus f fInt g gInt))) x) : Domain (Xplus f g) x. Proof. destruct fInt as [[fn fnL] [fInj resF]]. destruct gInt as [[gn gnL] [gInj resG]]. unfold IntegralRepresentationPlus, IntFn in x. pose proof (domainInfinSumWeaveL _ fn gn x) as ixf. pose proof (domainInfinSumWeaveR _ fn gn x) as ixg. simpl in resF. pose proof (resF x (ixf xD)) as yf. exact (pair (fInj x (ixf xD)) (gInj x (ixg xD))). Qed. Lemma IntegrablePlusMaj : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (g : PartialFunction (X (ElemFunc IS))) (gInt : IntegrableFunction g), PartialRestriction (XinfiniteSumAbs (IntFn (IntegralRepresentationPlus f fInt g gInt))) (Xplus f g). Proof. (* The weaved absolute convergence implies both that of fn and of gn. *) split. - intros x xd. exact (IntegralRepresentationPlusInj f fInt g gInt x xd). - intros. apply applyInfiniteSumAbs. destruct fInt as [[fn fnL] [fInj resF]]; destruct gInt as [[gn gnL] [gInj resG]]; unfold IntegralRepresentationPlus, IntFn. unfold IntegralRepresentationPlus, IntFn in xD. pose proof (domainInfinSumWeaveL _ fn gn x xD) as ixf. pose proof (domainInfinSumWeaveR _ fn gn x xD) as ixg. specialize (resF x ixf) as appF. specialize (resG x ixg) as appG. simpl in appG, appF. destruct xG. rewrite (applyXplus f g). rewrite <- appG. rewrite <- appF. apply partialApplyWeaveInfiniteSum. Qed. Definition IntegrablePlus {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (g : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction g -> IntegrableFunction (Xplus f g). Proof. intros fInt gInt. exists (IntegralRepresentationPlus f fInt g gInt). apply IntegrablePlusMaj. Defined. Definition domainInfiniteSumAbsScaleInc {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (a : CRcarrier R) (x : X) (xD : Domain (XinfiniteSumAbs fn) x) : { y : Domain (XinfiniteSumAbs (fun n : nat => Xscale a (fn n))) x | partialApply _ x y == (partialApply _ x xD) * a }. Proof. destruct xD as [xn cv]; simpl. pose proof (CR_complete R _ cv) as [l cvl]. destruct (domainInfiniteSumAbsInc (fun n => Xscale a (fn n)) x xn (l * CRabs _ a)) as [y e]. - apply (series_cv_eq (fun n : nat => CRabs _ (partialApply (fn n) x (xn n)) * CRabs _ a)). intro n. rewrite applyXscale. rewrite CRabs_mult. apply CRmult_comm. apply series_cv_scale. apply cvl. - exists (existT _ y e). destruct (series_cv_abs (fun n : nat => a * partialApply (fn n) x (y n)) e). destruct (series_cv_abs (fun n : nat => partialApply (fn n) x (xn n)) cv). apply (series_cv_unique (fun n : nat => (a * partialApply (fn n) x (y n))) _ _ s). apply (series_cv_eq (fun n : nat => (partialApply (fn n) x (xn n)) * a)). intro n. rewrite CRmult_comm. apply CRmult_morph. reflexivity. apply DomainProp. apply series_cv_scale. exact s0. Qed. Definition domainInfiniteSumAbsScaleIncReverse {R : ConstructiveReals} (X : Set) (fn : nat -> @PartialFunction R X) (a : CRcarrier R) (x : X) (xD : Domain (XinfiniteSumAbs (fun n : nat => Xscale a (fn n))) x) (aNZ : CRapart R a 0) : { y : Domain (XinfiniteSumAbs fn) x | partialApply _ x y == (partialApply _ x xD) * (CRinv R a aNZ) }. Proof. intros. destruct xD as [xn cv]; simpl. pose proof (CR_complete R _ cv) as [l cvl]. destruct (domainInfiniteSumAbsInc fn x xn (l * CRabs _ (CRinv R a aNZ))) as [y e]. - apply (series_cv_eq (fun n : nat => (CRabs _ (partialApply (Xscale a (fn n)) x (xn n)) * CRabs _ (CRinv R a aNZ)))). intro n. rewrite applyXscale. rewrite CRabs_mult. rewrite CRmult_comm, <- CRmult_assoc, <- CRabs_mult, CRinv_l. rewrite CRabs_right. rewrite CRmult_1_l. reflexivity. apply CRlt_asym, CRzero_lt_one. apply series_cv_scale. apply cvl. - exists (existT _ y e). apply (applyInfiniteSumAbs _ fn x (existT _ y e)). apply (series_cv_eq (fun n : nat => partialApply (Xscale a (fn n)) x (xn n) * CRinv R a aNZ)). intro n. rewrite CRmult_comm. rewrite applyXscale. rewrite <- CRmult_assoc. rewrite CRinv_l. rewrite CRmult_1_l. apply DomainProp. apply series_cv_scale. destruct (series_cv_abs (fun n : nat => a * partialApply (fn n) x (xn n)) cv). exact s. Qed. Definition IntegralRepresentationWeave {IS : IntegrationSpace} (a b : @IntegralRepresentation IS) : @IntegralRepresentation IS. Proof. apply (Build_IntegralRepresentation IS (weaveSequences _ (IntFn a) (IntFn b)) (weaveSequencesL (ElemFunc IS) _ (IntFnL a) _ (IntFnL b)) (IntAbsSum a + IntAbsSum b)). apply (series_cv_eq (weaveSequences (CRcarrier (RealT (ElemFunc IS))) (fun k => (Iabs (IntFn a k) (IntFnL a k))) (fun k => (Iabs (IntFn b k) (IntFnL b k))))). - intro n. unfold weaveSequences, weaveSequencesL. destruct (Nat.even n). reflexivity. reflexivity. - apply weaveInfiniteSums; apply IntAbsSumCv. Defined. Lemma IntegralRepresentationWeaveSum : forall {IS : IntegrationSpace} (a b : @IntegralRepresentation IS), IntegralSeries (IntegralRepresentationWeave a b) == IntegralSeries a + IntegralSeries b. Proof. intros. apply (series_cv_unique (fun n => I IS (IntFn (IntegralRepresentationWeave a b) n) (IntFnL (IntegralRepresentationWeave a b) n) )). apply IntegralCv. simpl. apply (series_cv_eq (weaveSequences (CRcarrier (RealT (ElemFunc IS))) (fun n => I IS (IntFn a n) (IntFnL a n)) (fun n => I IS (IntFn b n) (IntFnL b n)))). intro n. unfold weaveSequences, weaveSequencesL. destruct (Nat.even n); reflexivity. apply weaveInfiniteSums; apply IntegralCv. Qed. Definition IntegralRepresentationScaleHalf {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (a : CRcarrier (RealT (ElemFunc IS))) : IntegrableFunction f -> @IntegralRepresentation IS. Proof. intros. destruct X. apply (Build_IntegralRepresentation IS (fun n:nat => Xscale a (IntFn x n)) (fun n:nat => LscaleStable _ a (IntFn x n) (IntFnL x n)) (IntAbsSum x * CRabs _ a)). apply (series_cv_eq (fun n => (Iabs (IntFn x n) (IntFnL x n)) * CRabs _ a)). intro n. rewrite IabsHomogeneous. apply CRmult_comm. apply series_cv_scale. apply x. Defined. (* If f : X -> R is integrable with representation fn, then a*f is integrable with representation a*fn. This works even if a is zero, but in this case we must restrict the domain of the representation, so that it is that of f : we weave fn, -fn with the scaled representation. *) Definition IntegralRepresentationScale {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (a : CRcarrier (RealT (ElemFunc IS))) : IntegrableFunction f -> @IntegralRepresentation IS := fun X => IntegralRepresentationWeave (IntegralRepresentationScaleHalf f a X) (IntegralRepresentationWeave (let (x,_) := X in x) (IntegralRepresentationScaleHalf f (-(1)) X)). Definition IntegralRepresentationScaleInj {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (a : CRcarrier (RealT (ElemFunc IS))) (fInt : IntegrableFunction f) : PartialRestriction (XinfiniteSumAbs (IntFn (IntegralRepresentationScale f a fInt))) (Xscale a f). Proof. split. - (* Domain inclusion *) intros x xd. destruct fInt as [[fn fnL] [injF resF]]; unfold IntegralRepresentationScale, IntFn in x; unfold IntegralRepresentationScale, IntFn; simpl in injF, resF. (* By subsequence, x is in the domain of abs fn. *) pose proof (domainInfinSumWeaveR _ _ _ x xd) as y. pose proof (domainInfinSumWeaveL _ _ _ x y) as z. exact (injF x z). - intros. apply (applyInfiniteSumAbs _ _ x). destruct fInt as [[fn fnL] [injF resF]]; unfold IntegralRepresentationScale, IntFn in x; unfold IntegralRepresentationScale, IntFn; simpl in injF, resF. pose proof (domainInfinSumWeaveR _ _ _ x xD) as y. pose proof (domainInfinSumWeaveL _ _ _ x y) as z. apply (series_cv_eq (weaveSequences _ (fun n : nat => (partialApply (fn n) x (domainInfiniteSumAbsIncReverse _ x z n)) * a) (weaveSequences _ (fun n : nat => partialApply (fn n) x (domainInfiniteSumAbsIncReverse _ x z n)) (fun n : nat => CRopp _ (partialApply (fn n) x (domainInfiniteSumAbsIncReverse _ x z n)))))). + intro n. pose proof (domainInfinSumWeaveL _ _ _ x xD) as t. rewrite (partialApplyWeave _ _ _ n x (domainInfiniteSumAbsIncReverse _ x t (n/2)) (domainInfiniteSumAbsIncReverse _ x y (n/2))). unfold weaveSequences. destruct (Nat.even n). rewrite CRmult_comm. rewrite <- applyXscale. apply DomainProp. pose proof (partialApplyWeave _ fn (fun n => Xscale (CRopp _ 1) (fn n)) (n/2) x (domainInfiniteSumAbsIncReverse fn x z (n / 2 / 2)) (domainInfiniteSumAbsIncReverse fn x z (n / 2 / 2))). rewrite H. destruct (Nat.even (n / 2)). reflexivity. rewrite applyXscale. rewrite <- CRopp_mult_distr_l. rewrite CRmult_1_l. unfold IntFn. reflexivity. + rewrite <- (CRplus_0_r (partialApply (Xscale a f) x xG)). rewrite <- (CRplus_opp_r (partialApply (XinfiniteSumAbs fn) x z)). apply weaveInfiniteSums. rewrite applyXscale. rewrite CRmult_comm. apply series_cv_scale. apply applyInfiniteSumAbs. apply resF. apply weaveInfiniteSums. apply applyInfiniteSumAbs. reflexivity. apply series_cv_opp. apply applyInfiniteSumAbs. reflexivity. Qed. Definition IntegrableScale {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (a : CRcarrier (RealT (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction (Xscale a f). Proof. intros fInt. exists (IntegralRepresentationScale f a fInt). exact (IntegralRepresentationScaleInj f a fInt). Defined. Lemma minusOneNotZero : forall {R : ConstructiveReals}, CRopp R 1 <> 0. Proof. intros R absurd. pose proof (CRzero_lt_one R). apply (CRplus_lt_compat_l _ (CRopp R 1)) in H. rewrite CRplus_opp_l, CRplus_0_r in H. rewrite absurd in H. exact (CRlt_asym _ _ H H). Qed. Definition IntegrableMinus {IS : IntegrationSpace} {f : PartialFunction (X (ElemFunc IS))} {g : PartialFunction (X (ElemFunc IS))} : IntegrableFunction f -> IntegrableFunction g -> IntegrableFunction (Xminus f g). Proof. intros fInt gInt. exact (IntegrablePlus f (Xscale (-(1)) g) fInt (IntegrableScale g (-(1)) gInt)). Defined. Lemma splitInfiniteSumMaj : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a s : CRcarrier R), series_cv u s -> a < s -> { N : nat | CRltProp R (a + s - CRsum u N) (CRsum u N) }. Proof. intros. destruct (Un_cv_nat_real _ s H ((s - a) * CR_of_Q R (1 # 2))) as [N H1]. + apply CRmult_lt_0_compat. rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r. exact H0. apply CR_of_Q_lt. reflexivity. + exists N. specialize (H1 N (Nat.le_refl N)). rewrite CRabs_minus_sym in H1. apply (CRle_lt_trans (s - CRsum u N)) in H1. apply (CRmult_lt_compat_r (CR_of_Q R 2)) in H1. rewrite CRmult_assoc in H1. rewrite <- CR_of_Q_mult in H1. setoid_replace ((1 # 2) * 2)%Q with 1%Q in H1. 2: reflexivity. rewrite CRmult_1_r in H1. assert ((s - CRsum u N) * CR_of_Q R 2 == s + s - CRsum u N -CRsum u N). { rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. unfold CRminus. do 3 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRplus_assoc. reflexivity. } rewrite H2 in H1. unfold CRminus in H1. apply (CRplus_lt_compat_l _ (-s)) in H1. rewrite <- CRplus_assoc, <- CRplus_assoc in H1. rewrite <- CRplus_assoc in H1. rewrite CRplus_opp_l in H1. rewrite CRplus_0_l in H1. rewrite <- CRplus_assoc in H1. rewrite CRplus_opp_l in H1. rewrite CRplus_0_l in H1. apply (CRplus_lt_compat_l _ a) in H1. rewrite CRplus_opp_r in H1. apply (CRplus_lt_compat_r (CRsum u N)) in H1. rewrite CRplus_assoc in H1. rewrite CRplus_assoc in H1. rewrite CRplus_opp_l in H1. rewrite CRplus_0_r in H1. rewrite CRplus_0_l in H1. rewrite <- CRplus_assoc in H1. apply CRltForget. assumption. apply CR_of_Q_lt. reflexivity. apply CRle_abs. Qed. Lemma sumPosNegPart : forall {R : ConstructiveReals} (x : CRcarrier R), CRabs _ x == (CRmax 0 x) + CRmax 0 (-x). Proof. split. - apply (CRplus_le_reg_l (-CRmax 0 x)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply CRmax_lub. apply (CRplus_le_reg_l (CRmax 0 x)). rewrite CRplus_0_r, <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRmax_lub. apply CRabs_pos. apply CRle_abs. apply (CRplus_le_reg_l (CRmax 0 x + x)). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. rewrite (CRplus_comm (CRmax 0 x)), CRplus_assoc. rewrite <- (CRplus_assoc (CRmax 0 x)), CRplus_opp_r, CRplus_0_l. apply CRmax_lub. apply (CRplus_le_reg_l (-x)). rewrite CRplus_0_r, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- CRabs_opp. apply CRle_abs. rewrite <- (CRplus_0_r x). rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_0_l. apply CRabs_pos. - apply CRabs_le. split. + apply (CRplus_le_reg_l (CRmax 0 (-x) - x)). unfold CRminus. rewrite CRplus_assoc, CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_r. rewrite <- CRplus_assoc, (CRplus_comm), CRopp_plus_distr. rewrite CRplus_assoc, <- (CRplus_assoc (-CRmax 0 (-x))). rewrite CRplus_opp_l, CRplus_0_l. apply (CRle_trans _ (-x)). 2: apply CRmax_r. apply (CRplus_le_reg_l (CRmax 0 x)). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. rewrite <- (CRplus_0_l (-x)), <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_0_r. apply CRmax_l. + apply (CRle_trans _ (x + CRmax 0 (-x))). rewrite <- (CRplus_0_r x). rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_0_l. apply CRmax_l. apply CRplus_le_compat. apply CRmax_r. apply CRle_refl. Qed. Lemma minusPosNegPart : forall {R : ConstructiveReals} (x : CRcarrier R), x == (CRmax 0 x) - (CRmax 0 (-x)). Proof. split. - apply (CRplus_le_reg_l (CRmax 0 (-x))). rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRmax_lub. apply (CRplus_le_reg_l (-x)). rewrite CRplus_0_r, CRplus_comm, CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply CRmax_r. apply (CRplus_le_reg_l (-x)). rewrite CRplus_opp_l, CRplus_comm, CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply CRmax_l. - apply (CRplus_le_reg_l (CRmax 0 (-x) - x)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm, CRplus_assoc, <- (CRplus_assoc (-CRmax 0 (-x))). rewrite CRplus_opp_l, CRplus_0_l. apply CRmax_lub. apply (CRplus_le_reg_l x). rewrite CRplus_0_r, CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRmax_r. rewrite <- (CRplus_0_l (-x)). rewrite <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_0_r. apply CRmax_l. Qed. Lemma infiniteSumPosNegParts : forall {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (x : X) (xn : forall n:nat, Domain (fn n) x) (pos neg : CRcarrier R), series_cv (fun n => CRmax 0 (partialApply (fn n) x (xn n))) pos -> series_cv (fun n => CRmax 0 (- partialApply (fn n) x (xn n))) neg -> series_cv (fun n => partialApply (fn n) x (xn n)) (pos - neg). Proof. intros. apply (series_cv_scale (-(1)) neg) in H0. apply (series_cv_plus (fun n : nat => CRmax 0 (partialApply (fn n) x (xn n))) (fun n : nat => (CRmax 0 (- partialApply (fn n) x (xn n)) * -(1))) pos (neg * -(1)) H) in H0. assert (pos + neg * -(1) == pos - neg). rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. rewrite H1 in H0. apply (series_cv_eq (fun n : nat => (CRmax 0 (partialApply (fn n) x (xn n)) + CRmax 0 (- partialApply (fn n) x (xn n)) * -(1))) (fun n : nat => partialApply (fn n) x (xn n))). intro n. rewrite <- (CRopp_mult_distr_r _ 1). rewrite CRmult_1_r. symmetry. apply minusPosNegPart. apply H0. Qed. Lemma splitSumAbsPosNeg : forall {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (x : X) (xn : forall n:nat, Domain (fn n) x) (A : CRcarrier R), series_cv (fun n => CRabs _ (partialApply (fn n) x (xn n))) A -> prod { pos : CRcarrier R & prod (pos <= A) (series_cv (fun n => CRmax 0 (partialApply (fn n) x (xn n))) pos) } { neg : CRcarrier R & prod (neg <= A) (series_cv (fun n => CRmax 0 (- partialApply (fn n) x (xn n))) neg) }. Proof. intros. split. - destruct (series_cv_maj (fun n => CRmax 0 (partialApply (fn n) x (xn n))) (fun n : nat => CRabs _ (partialApply (fn n) x (xn n))) A) as [l cvl]. intro n. simpl. rewrite CRabs_right. apply CRmax_lub. apply CRabs_pos. apply CRle_abs. apply CRmax_l. assumption. exists l. split; apply cvl. - destruct (series_cv_maj (fun n => CRmax 0 (- partialApply (fn n) x (xn n))) (fun n : nat => CRabs _ (partialApply (fn n) x (xn n))) A) as [l cvl]. intro n. simpl. rewrite CRabs_right. apply CRmax_lub. apply CRabs_pos. rewrite <- CRabs_opp. apply CRle_abs. apply CRmax_l. assumption. exists l. split; apply cvl. Qed. Lemma applyPlusTruncated : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (n M : nat) (x : X (ElemFunc IS)) (pF : Domain f x) (pS : Domain (Xplus (XposPart f) (if le_dec n M then Izero IS else XnegPart f)) x), partialApply _ x pS == (CRmax 0 (partialApply f x pF) + (if le_dec n M then 0 else CRmax 0 (- partialApply f x pF))). Proof. intros. destruct (le_dec n M). - rewrite CRplus_0_r. destruct pS. rewrite (applyXplus (XposPart f) (Izero IS)). unfold Izero. rewrite applyXscale, CRmult_0_l. rewrite <- (DomainProp (XposPart f) x (pF, pF)). rewrite applyXposPart. rewrite CRplus_0_r. reflexivity. - destruct pS. rewrite (applyXplus (XposPart f) (XnegPart f)). apply CRplus_morph. rewrite <- (DomainProp (XposPart f) x (pF, pF)). rewrite applyXposPart. reflexivity. rewrite <- (DomainProp (XnegPart f) x (pF, pF)). rewrite applyXnegPart. reflexivity. Qed. Lemma splitIntegralPosNeg : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f), I IS f fL == (I IS (XposPart f) (LposPartStable f fL)) - (I IS (XnegPart f) (LnegPartStable f fL)). Proof. intros. rewrite <- (CRmult_1_l (I IS (XnegPart f) (LnegPartStable f fL))). unfold CRminus. rewrite CRopp_mult_distr_l. rewrite <- Ihomogeneous. rewrite <- Iadditive. apply IExtensional. intros. destruct y. rewrite (applyXplus (XposPart f) (Xscale (- (1)) (XnegPart f))). rewrite applyXscale. unfold XposPart, XnegPart. do 2 rewrite applyXscale. destruct d. rewrite (applyXplus f (Xabs f) x). destruct d0. rewrite (applyXminus (Xabs f) f). do 2 rewrite applyXabs. rewrite (DomainProp f x d1 d), (DomainProp f x d2 d), (DomainProp f x d0 d), (DomainProp f x xF d). generalize (partialApply f x d). intros. rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. setoid_replace (c + CRabs _ c + - (CRabs _ c + - c)) with (CR_of_Q _ 2 * c). rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. rewrite CRmult_1_l. reflexivity. reflexivity. rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_r. rewrite CRmult_1_l, CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr, <- CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_l, CRopp_involutive. reflexivity. Qed. Lemma splitIntegralSumPosNeg : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (sumAbsIFn : CRcarrier (RealT (ElemFunc IS))), (series_cv (fun n => Iabs (fn n) (fnL n)) sumAbsIFn) -> { sumIPosFn : CRcarrier _ & { sumINegFn : CRcarrier _ & series_cv (fun n0 : nat => I IS (XposPart (fn n0)) (LposPartStable (fn n0) (fnL n0))) sumIPosFn * series_cv (fun n0 : nat => I IS (XnegPart (fn n0)) (LnegPartStable (fn n0) (fnL n0))) sumINegFn * series_cv (fun n => I IS (fn n) (fnL n)) (sumIPosFn - sumINegFn) }}%type. Proof. intros. (* The sum of I fn+ converges *) destruct (series_cv_maj (fun n0 : nat => I IS (XposPart (fn n0)) (LposPartStable (fn n0) (fnL n0))) (fun n0 : nat => Iabs (fn n0) (fnL n0)) sumAbsIFn) as [sumIPosFn [limPos _]]. { intro n. apply (CRle_trans _ (Iabs (XposPart (fn n)) (LposPartStable (fn n) (fnL n)))). apply integralAbsMaj. apply INonDecreasing. intros. rewrite applyXabs, CRabs_right. 2: apply applyXposPartNonNeg. rewrite <- (DomainProp (XposPart (fn n)) x (y, y)). rewrite (applyXposPart (fn n)). rewrite applyXabs. apply CRmax_lub. apply CRabs_pos. apply CRle_abs. } assumption. (* The sum of I fn- converges *) destruct (series_cv_maj (fun n0 : nat => I IS (XnegPart (fn n0)) (LnegPartStable (fn n0) (fnL n0))) (fun n0 : nat => Iabs (fn n0) (fnL n0)) sumAbsIFn) as [sumINegFn [limNeg _]]. { intro n. apply (CRle_trans _ (Iabs (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n)))). apply integralAbsMaj. apply INonDecreasing. intros. rewrite applyXabs, CRabs_right. 2: apply XnegPartNonNeg. rewrite <- (DomainProp (XnegPart (fn n)) x (y,y)). rewrite (applyXnegPart (fn n)). rewrite applyXabs. apply CRmax_lub. apply CRabs_pos. rewrite <- CRabs_opp. apply CRle_abs. } apply H. exists sumIPosFn. exists sumINegFn. repeat split. assumption. assumption. apply (series_cv_scale (-(1)) sumINegFn) in limNeg. apply (series_cv_plus (fun n0 : nat => I IS (XposPart (fn n0)) (LposPartStable (fn n0) (fnL n0))) (fun n : nat => (I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n)) * -(1))) sumIPosFn (sumINegFn * -(1)) limPos) in limNeg. apply (series_cv_eq (fun n : nat => (I IS (XposPart (fn n)) (LposPartStable (fn n) (fnL n)) + I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n)) * -(1))) (fun n : nat => I IS (fn n) (fnL n))) in limNeg. apply (CR_cv_proper _ (sumIPosFn + sumINegFn * - (1))). exact limNeg. rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. intro n. assert ((I IS (XposPart (fn n)) (LposPartStable (fn n) (fnL n)) + I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n)) * -(1)) == (I IS (XposPart (fn n)) (LposPartStable (fn n) (fnL n)) - I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n)))). rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. rewrite H0. clear H0. rewrite <- splitIntegralPosNeg. reflexivity. Qed. Definition domainPlusPosPartInc {R : ConstructiveReals} (X : Set) (f g : @PartialFunction R X) (x : X) (xD : Domain (Xplus (XposPart f) g) x) : Domain f x. Proof. destruct f,g,xD; simpl. exact (fst d). Qed. (* Workaround destruct that no longer works *) Lemma series_cv_abs_le : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (a : CRcarrier R) (cau : CR_cauchy R (CRsum (fun n => CRabs R (un n)))), CRle R a (let (c,_) := series_cv_abs un cau in c) -> { l : CRcarrier R & prod (CRle R a l) (series_cv un l) }. Proof. intros. destruct (series_cv_abs un cau). exists x. split; assumption. Qed. (* This is the generalization of INonDecreasing from L-functions to integrable functions. *) Lemma representationPositive : forall {IS : IntegrationSpace} (fInt : @IntegralRepresentation IS), nonNegFunc (XinfiniteSumAbs (IntFn fInt)) -> 0 <= IntegralSeries fInt. Proof. (* To use Icontinuity, we fallback to positive functions by taking XposParts and XnegParts. *) intros IS [fn fnL sumAbsIFn H] H0. destruct (splitIntegralSumPosNeg fn fnL sumAbsIFn H) as [sumIPosFn [sumINegFn [[limPos limNeg] splitIntegral]]]. setoid_replace (IntegralSeries {| IntFn := fn; IntFnL := fnL; IntAbsSum := sumAbsIFn; IntAbsSumCv := H |}) with (sumIPosFn - sumINegFn). rewrite <- (CRplus_opp_r sumINegFn). apply CRplus_le_compat. 2: apply CRle_refl. intro absurd. (* Truncate XinfiniteSumAbs _ (fun n:nat => XnegPart _ (fn n)) to a finite sum, to keep an L-function. *) destruct (splitInfiniteSumMaj (fun n : nat => I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n))) sumIPosFn sumINegFn limNeg) as [M H1]. assumption. destruct (Icontinuous IS (Xsum (fun n:nat => XnegPart (fn n)) M) (fun n:nat => Xplus (XposPart (fn n)) match le_dec n M with | left _ => Izero IS | _ => XnegPart (fn n) end) (LsumStable (fun n : nat => XnegPart (fn n)) (fun n => LnegPartStable (fn n) (fnL n)) M) (fun n:nat => LplusStable (ElemFunc IS) (XposPart (fn n)) (match le_dec n M with | left _ => Izero IS | _ => XnegPart (fn n) end) (LposPartStable (fn n) (fnL n)) (if le_dec n M as s return (L (ElemFunc IS) (if s then Izero IS else XnegPart (fn n))) then Izero_is_L IS else LnegPartStable (fn n) (fnL n))) ) as [[x xS xdfn] [sumPosNegFX [H2 H3]]]. - (* non neg func *) intros. intros z xdf. destruct (le_dec n M). destruct xdf. rewrite (applyXplus (XposPart (fn n)) (Izero IS)), <- (CRplus_0_r 0). apply CRplus_le_compat. apply applyXposPartNonNeg. rewrite applyIzero. apply CRle_refl. destruct xdf. rewrite (applyXplus (XposPart (fn n)) (XnegPart (fn n))), <- (CRplus_0_r 0). apply CRplus_le_compat. apply applyXposPartNonNeg. apply XnegPartNonNeg. - (* limit lt *) exists (sumIPosFn + (sumINegFn - CRsum (fun n : nat => I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n))) M)). split. + apply (series_cv_eq (fun n : nat => I IS (XposPart (fn n)) (LposPartStable (fn n) (fnL n)) + (I IS (if le_dec n M then Izero IS else XnegPart (fn n)) (if le_dec n M as s return (L (ElemFunc IS) (if s then Izero IS else XnegPart (fn n))) then Izero_is_L IS else LnegPartStable (fn n) (fnL n))))). intros. rewrite Iadditive. reflexivity. apply series_cv_plus. assumption. apply (series_cv_eq (fun n : nat => if le_dec n M then 0 else I IS (XnegPart (fn n)) (LnegPartStable (fn n) (fnL n)))). intros. destruct (le_dec n M). rewrite Izero_is_zero. reflexivity. reflexivity. apply infinite_sum_truncate_below. assumption. + rewrite IadditiveIterate. unfold CRminus. rewrite <- CRplus_assoc. apply CRltEpsilon. assumption. - (* Now we have x, prove that sum |fn x| converges. *) pose proof (fun n:nat => domainPlusPosPartInc _ _ _ x (xdfn n)) as pxn. (* Simplify H2 *) apply (series_cv_eq (fun n : nat => partialApply (Xplus (XposPart (fn n)) (if le_dec n M then Izero IS else XnegPart (fn n))) x (xdfn n)) (fun n : nat => CRmax 0 (partialApply (fn n) x (pxn n)) + (if le_dec n M then 0 else CRmax 0 (- partialApply (fn n) x (pxn n))))) in H2. assert (series_cv (fun n : nat => (if le_dec n M then CRmax 0 (- partialApply (fn n) x (pxn n)) else 0)) (CRsum (fun k => CRmax 0 (- partialApply (fn k) x (pxn k))) M)). { intros eps. exists M. intros. rewrite sum_truncate_above. unfold CRminus. rewrite CRplus_opp_r. rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. exact H4. } apply (series_cv_plus (fun n : nat => (CRmax 0 (partialApply (fn n) x (pxn n)) + (if le_dec n M then 0 else CRmax 0 (- partialApply (fn n) x (pxn n))))) (fun n : nat => if le_dec n M then CRmax 0 (- partialApply (fn n) x (pxn n)) else 0) sumPosNegFX (CRsum (fun k => CRmax 0 (- partialApply (fn k) x (pxn k))) M) H2) in H4. apply (series_cv_eq (fun n : nat => (CRmax 0 (partialApply (fn n) x (pxn n)) + (if le_dec n M then 0 else CRmax 0 (- partialApply (fn n) x (pxn n))) + (if le_dec n M then CRmax 0 (- partialApply (fn n) x (pxn n)) else 0))) (fun n : nat => CRabs _ (partialApply (fn n) x (pxn n)))) in H4. (* Deduce that sum fn x >= 0 *) unfold nonNegFunc in H0. pose proof (domainInfiniteSumAbsInc fn x pxn (sumPosNegFX + CRsum (fun k : nat => CRmax 0 (- partialApply (fn k) x (pxn k))) M) H4) as y. specialize (H0 x y). destruct y as [yn ycv]; simpl in H0. apply series_cv_abs_le in H0. destruct H0 as [sumFX [H0 i]]. destruct (splitSumAbsPosNeg _ fn x pxn (sumPosNegFX + CRsum (fun k : nat => CRmax 0 (- partialApply (fn k) x (pxn k))) M) H4) as [H6 H7]. destruct H6 as [sumPosFnX [H6 limPosX]]. destruct H7 as [sumNegFnX [H7 limNegX]]. assert (sumPosFnX < sumNegFnX). { apply (CRle_lt_trans sumPosFnX sumPosNegFX). apply (series_cv_scale (-(1)) sumPosFnX) in limPosX. apply (series_cv_plus (fun n : nat => (CRmax 0 (partialApply (fn n) x (pxn n)) + (if le_dec n M then 0 else CRmax 0 (- partialApply (fn n) x (pxn n))))) (fun n : nat => (CRmax 0 (partialApply (fn n) x (pxn n)) * -(1))) sumPosNegFX (sumPosFnX * -(1))) in limPosX. apply series_cv_nonneg in limPosX. assert (sumPosFnX * (-(1)) == - sumPosFnX) as H8. rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. rewrite H8 in limPosX. apply (CRplus_le_compat_l sumPosFnX) in limPosX. simpl in limPosX. unfold CRminus in limPosX. rewrite CRplus_0_r, CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r in limPosX. exact limPosX. intro n. assert (CRmax 0 (partialApply (fn n) x (pxn n)) + (if le_dec n M then 0 else CRmax 0 (- partialApply (fn n) x (pxn n))) + CRmax 0 (partialApply (fn n) x (pxn n)) * -(1) == (if le_dec n M then 0 else CRmax 0 (- partialApply (fn n) x (pxn n)))) as H8. rewrite <- CRopp_mult_distr_r, CRmult_1_r, CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. rewrite H8. destruct (le_dec n M). apply CRle_refl. apply CRmax_l. assumption. apply (CRlt_le_trans sumPosNegFX (partialApply (Xsum (fun n : nat => XnegPart (fn n)) M) x xS)). assumption. pose proof (fun n:nat => pair (pxn n) (pxn n)) as pxnn. rewrite (applyXsum (fun n : nat => XnegPart (fn n)) M x _ pxnn). rewrite <- (CRsum_eq (fun n:nat => CRmax 0 (- partialApply (fn n) x (pxn n)))). apply growing_ineq. intros p. simpl. rewrite <- CRplus_0_r, CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_0_l. apply CRmax_l. assumption. intros. rewrite <- (applyXnegPart (fn i0)). apply DomainProp. } assert (sumFX == sumPosFnX - sumNegFnX). { apply (CR_cv_unique (CRsum (fun k : nat => partialApply (fn k) x (pxn k)))). apply (series_cv_eq (fun k : nat => partialApply (fn k) x (yn k))). intro n. apply DomainProp. apply i. apply infiniteSumPosNegParts. assumption. assumption. } rewrite H8 in H0. apply (CRplus_le_compat_l sumNegFnX) in H0. unfold CRminus in H0. rewrite CRplus_0_r, CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r in H0. apply H0. assumption. intros. destruct (le_dec n M). rewrite sumPosNegPart. rewrite CRplus_0_r. reflexivity. rewrite sumPosNegPart. rewrite CRplus_0_r. reflexivity. intro n. apply applyPlusTruncated. - apply (CR_cv_unique (CRsum (fun n : nat => I IS (fn n) (fnL n)))). simpl. destruct (series_cv_maj (fun n : nat => I IS (fn n) (fnL n)) (fun k : nat => Iabs (fn k) (fnL k)) sumAbsIFn (fun n : nat => integralAbsMaj (fn n) (fnL n)) H). apply p. assumption. Qed. Lemma IntegralNonNeg : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), nonNegFunc f -> 0 <= Integral fInt. Proof. intros. apply representationPositive. destruct fInt, p. intros y ydf. rewrite (c y ydf (d y ydf)). apply H. Qed. Lemma IntegralHomogeneousHalf : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a : CRcarrier (RealT (ElemFunc IS))), IntegralSeries (IntegralRepresentationScaleHalf f a fInt) == (Integral fInt) * a. Proof. intros. destruct fInt. apply (series_cv_unique (fun n0 : nat => (I IS (IntFn x n0) (IntFnL x n0)) * a)). - apply (series_cv_eq (fun n:nat => I IS (Xscale a (IntFn x n)) (LscaleStable _ a _ (IntFnL x n)))). intro n. rewrite Ihomogeneous. apply CRmult_comm. apply (IntegralCv (IntegralRepresentationScaleHalf f a (existT (fun fInt : IntegralRepresentation => PartialRestriction (XinfiniteSumAbs (IntFn fInt)) f) x p))). - apply series_cv_scale. simpl. apply (IntegralCv x). Qed. Lemma IntegralScale : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a : CRcarrier (RealT (ElemFunc IS))), Integral (IntegrableScale f a fInt) == (Integral fInt) * a. Proof. intros. unfold IntegrableScale, IntegralRepresentationScale, Integral. do 2 rewrite IntegralRepresentationWeaveSum. do 2 rewrite IntegralHomogeneousHalf. unfold Integral. rewrite <- CRopp_mult_distr_r, CRmult_1_r, CRplus_opp_r. rewrite CRplus_0_r. reflexivity. Qed. (* Base result to prove that integral is extensional *) Lemma IntegralRepresentationInvariantZero : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), (forall (x : X (ElemFunc IS)) (xD : Domain f x), partialApply f x xD == 0) -> Integral fInt == 0. Proof. intros. split. - apply representationPositive. intros x xdf. destruct fInt,p. rewrite (c x _ (d x xdf)). rewrite H. apply CRle_refl. - setoid_replace (Integral fInt) with (CRopp _ (IntegralSeries (IntegralRepresentationScale _ (-(1)) fInt))). rewrite <- CRopp_0. apply CRopp_ge_le_contravar. apply representationPositive. intros x xdf. destruct (IntegralRepresentationScaleInj f (-(1)) fInt). rewrite (c x xdf (d x xdf)). rewrite applyXscale, H. rewrite CRmult_0_r. apply CRle_refl. pose proof (IntegralScale f fInt (-(1))). rewrite H0. rewrite <- CRopp_mult_distr_r, CRmult_1_r, CRopp_involutive. reflexivity. Qed. Lemma IntegralOpp : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), Integral (IntegrableScale f (-(1)) fInt) == - Integral fInt. Proof. intros. rewrite IntegralScale. rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. Qed. Lemma IntegralPlus : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), Integral (IntegrablePlus f g fInt gInt) == Integral fInt + Integral gInt. Proof. intros. destruct (IntegrablePlus f g fInt gInt) as [[pn pnL IsumP majP] restrictP] eqn:desP. destruct fInt as [[fn fnL IsumF majF] restrictF]. destruct gInt as [[gn gnL IsumG majG] restrictG]. simpl. apply (series_cv_unique (weaveSequences _ (fun n0 : nat => I IS (fn n0) (fnL n0)) (fun n0 : nat => I IS (gn n0) (gnL n0)))). simpl in desP. - (* Prove that weaved sequences converges to IntegrablePlus *) apply (series_cv_eq (fun n : nat => I IS (pn n) (pnL n))). + intro n. unfold IntegrablePlus in desP; simpl in desP. inversion desP. inversion H1. unfold weaveSequences, weaveSequencesL. destruct (Nat.even n); reflexivity. + pose proof (IntegralCv {| IntFn := pn; IntFnL := pnL; IntAbsSum := IsumP; IntAbsSumCv := majP |}). assumption. - apply weaveInfiniteSums. + pose proof (IntegralCv {| IntFn := fn; IntFnL := fnL; IntAbsSum := IsumF; IntAbsSumCv := majF |}). assumption. + pose proof (IntegralCv {| IntFn := gn; IntFnL := gnL; IntAbsSum := IsumG; IntAbsSumCv := majG |}). assumption. Qed. Lemma IntegralMinus : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), Integral (IntegrableMinus fInt gInt) == Integral fInt - Integral gInt. Proof. intros. unfold Xminus. unfold IntegrableMinus. rewrite IntegralPlus. rewrite IntegralScale. apply CRplus_morph. reflexivity. rewrite <- CRopp_mult_distr_r, CRmult_1_r. reflexivity. Qed. (* We now come to the invariance of the integral with respect to the representation of a function f. In addition, this shows that a countable intersection of L-functions is also defined almost everywhere : otherwise another representation defined at more points could change the integral. *) Lemma IntegralRepresentationInvariant : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fnInt gnInt : IntegrableFunction f), Integral fnInt == Integral gnInt. Proof. intros. assert (forall (x : X (ElemFunc IS)) (xD : Domain (Xplus f (Xscale (-(1)) f)) x), partialApply (Xplus f (Xscale (-(1)) f)) x xD == 0). { intros. destruct xD. rewrite (applyXplus f (Xscale (- (1)) f)), applyXscale. rewrite (DomainProp f x d d0), <- CRopp_mult_distr_l, CRmult_1_l. apply CRplus_opp_r. } pose proof (IntegralRepresentationInvariantZero (Xminus f f) (IntegrableMinus fnInt gnInt) H) as invZero. rewrite IntegralMinus in invZero. apply (CRplus_eq_reg_l (-Integral gnInt)). rewrite CRplus_opp_l, CRplus_comm. exact invZero. Qed. Lemma IntegrableMinusMaj : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (g : PartialFunction (X (ElemFunc IS))) (gInt : IntegrableFunction g), PartialRestriction (XinfiniteSumAbs (IntFn (let (i,_) := IntegrableMinus fInt gInt in i))) (Xminus f g). Proof. intros. apply IntegrablePlusMaj. Qed. Lemma IntegralNonDecreasing : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), partialFuncLe f g -> Integral fInt <= Integral gInt. Proof. intros. pose proof (IntegralMinus g f gInt fInt) as intAdd. apply (CRplus_le_reg_r (- Integral fInt)). rewrite CRplus_opp_r, <- intAdd. clear intAdd. apply representationPositive. intros x xdf. destruct (IntegrableMinusMaj g gInt f fInt). rewrite (c x xdf (d x xdf)). destruct (d x xdf). rewrite (applyXminus g f). rewrite <- (CRplus_opp_r (partialApply f x d1)). apply CRplus_le_compat. apply H. apply CRle_refl. Qed. Lemma IntegralExtensional : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), (forall (x : X (ElemFunc IS)) (xdf : Domain f x) (xdg : Domain g x), partialApply f x xdf == partialApply g x xdg) -> Integral fInt == Integral gInt. Proof. split. - apply IntegralNonDecreasing. intros x xdf xdg. rewrite (H x xdg xdf). apply CRle_refl. - apply IntegralNonDecreasing. intros x xdf xdg. rewrite (H x xdf xdg). apply CRle_refl. Qed. Definition telescopicOp {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (op : CRcarrier R -> CRcarrier R) (opEq : forall x y : CRcarrier R, x == y -> op x == op y) := fun n:nat => match n with | O => Xop X (fn O) op opEq | S p => Xminus (Xop X (Xsum fn n) op opEq) (Xop X (Xsum fn p) op opEq) end. Lemma telescopicOpL : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (op : CRcarrier (RealT (ElemFunc IS)) -> CRcarrier (RealT (ElemFunc IS))) (opEq : forall x y : CRcarrier (RealT (ElemFunc IS)), x == y -> op x == op y) (opL : forall f : PartialFunction (X (ElemFunc IS)), L (ElemFunc IS) f -> L (ElemFunc IS) (Xop _ f op opEq)) (n : nat), L (ElemFunc IS) (telescopicOp (X (ElemFunc IS)) fn op opEq n). Proof. intros. unfold telescopicOp. destruct n. apply (*LabsStable*) opL. apply fnL. unfold Xminus. apply LplusStable. apply opL. apply LsumStable. apply fnL. apply LscaleStable. apply opL. apply LsumStable. apply fnL. Defined. Lemma applyTelescopicOpMaj : forall {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (op : CRcarrier R -> CRcarrier R) (opEq : forall x y : CRcarrier R, x == y -> op x == op y) (contract : forall x y : CRcarrier R, (CRabs _ (op x - op y)) <= (CRabs _ (x - y))) (zeroFix : op 0 == 0) (n : nat) (x : X) (pF : Domain (fn n) x) (pXT : Domain (telescopicOp X fn op opEq n) x), CRabs _ (partialApply (telescopicOp X fn op opEq n) x pXT) <= CRabs _ (partialApply (fn n) x pF). Proof. intros. unfold telescopicOp. unfold telescopicOp in pXT. destruct n. - destruct (fn O); simpl. rewrite <- (CRplus_0_r (partialApply x pF)). rewrite <- CRopp_0. rewrite <- (DomainProp x pXT pF). setoid_replace (op (partialApply x pXT)) with (op (partialApply x pXT) - op 0). apply contract. rewrite zeroFix. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. - simpl in pXT. destruct pXT. rewrite (applyXminus (Xop X (Xsum fn (S n)) op opEq) (Xop X (Xsum fn n) op opEq)). simpl. apply (CRle_trans _ _ _ (contract _ _)). destruct p. simpl. destruct (Xsum fn n), (fn (S n)); simpl. rewrite (DomainProp x d0 d), (DomainProp0 x pF d1). apply (CRle_trans _ (CRabs _ ((partialApply x d + partialApply0 x d1) - partialApply x d))). apply CRle_refl. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. apply CRle_refl. Qed. Lemma applyTelescopicOp : forall {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (op : CRcarrier R -> CRcarrier R) (opEq : forall x y : CRcarrier R, x == y -> op x == op y) (n : nat) (x : X) (pF : forall n:nat, Domain (fn n) x) (pXT : forall n:nat, Domain (telescopicOp X fn op opEq n) x), partialApply (telescopicOp X fn op opEq (S n)) x (pXT (S n)) == op (CRsum (fun n=> partialApply (fn n) x (pF n)) (S n)) - op (CRsum (fun n=> partialApply (fn n) x (pF n)) n). Proof. intros. unfold telescopicOp. destruct (pXT (S n)). rewrite (applyXminus (Xop X (Xsum fn (S n)) op opEq) (Xop X (Xsum fn n) op opEq)). destruct d; simpl. apply CRplus_morph. apply opEq. rewrite (applyXsum fn n x _ pF). rewrite (DomainProp _ x (pF (S n)) d1). reflexivity. apply CRopp_morph, opEq. rewrite (applyXsum fn n x _ pF). reflexivity. Qed. Lemma applyTelescopicOpInfSum : forall {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (op : CRcarrier R -> CRcarrier R) (opEq : forall x y : CRcarrier R, x == y -> op x == op y) (contract : forall x y : CRcarrier R, CRabs _ (op x - op y) <= CRabs _ (x - y)) (x : X) (pF : forall n:nat, Domain (fn n) x) (pXT : forall n:nat, Domain (telescopicOp X fn op opEq n) x) (s : CRcarrier R), series_cv (fun n : nat => partialApply (fn n) x (pF n)) s -> series_cv (fun n : nat => partialApply (telescopicOp X fn op opEq n) x (pXT n)) (op s). Proof. intros. intros p. specialize (H p) as [N H0]. exists N. intros n H. specialize (H0 n H). assert (forall (p:nat) (u : nat -> CRcarrier R), CRsum u (S p) == CRsum u p + u (S p)) as sum_shift. { intros. reflexivity. } assert (forall p0:nat, CRsum (fun k : nat => partialApply (telescopicOp X fn op opEq k) x (pXT k)) p0 == op (CRsum (fun k : nat => partialApply (fn k) x (pF k)) p0)). { induction p0. - simpl. apply opEq. apply DomainProp. - rewrite sum_shift. rewrite IHp0. rewrite (applyTelescopicOp X fn op opEq p0 x pF). unfold CRminus. rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_r. reflexivity. } rewrite H1. apply (CRle_trans _ (CRabs _ (CRsum (fun n : nat => partialApply (fn n) x (pF n)) n - s))). apply contract. assumption. Qed. Definition IabsOpContract {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (op : CRcarrier (RealT (ElemFunc IS)) -> CRcarrier (RealT (ElemFunc IS))) (opEq : forall x y : CRcarrier (RealT (ElemFunc IS)), x == y -> op x == op y) (opL : forall f : PartialFunction (X (ElemFunc IS)), L (ElemFunc IS) f -> L (ElemFunc IS) (Xop (X (ElemFunc IS)) f op opEq)) (contract : forall x y : CRcarrier (RealT (ElemFunc IS)), CRabs _ (op x - op y) <= CRabs _ (x - y)) (zeroFix : op 0 == 0) (sumIAbsFn : CRcarrier (RealT (ElemFunc IS))) : series_cv (fun k : nat => Iabs (fn k) (fnL k)) sumIAbsFn -> { l : CRcarrier (RealT (ElemFunc IS)) & series_cv (fun k => Iabs (telescopicOp _ fn op opEq k) (telescopicOpL fn fnL op opEq opL k)) l }. Proof. intros. destruct (series_cv_maj (fun k => Iabs (telescopicOp _ fn op opEq k) (telescopicOpL fn fnL op opEq opL k)) (fun k => Iabs (fn k) (fnL k)) sumIAbsFn) as [sumOps cvOps]. intro n. rewrite CRabs_right. apply INonDecreasing. intros. rewrite applyXabs. rewrite applyXabs. apply applyTelescopicOpMaj. assumption. assumption. apply (CRle_trans _ (CRabs _ (I IS (telescopicOp (X (ElemFunc IS)) fn op opEq n) (telescopicOpL fn fnL op opEq opL n)))). apply CRabs_pos. apply integralAbsMaj. assumption. exists sumOps. apply cvOps. Qed. Definition IntegralRepresentationOpContract {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (op : CRcarrier (RealT (ElemFunc IS)) -> CRcarrier (RealT (ElemFunc IS))) (opEq : forall x y : CRcarrier (RealT (ElemFunc IS)), x == y -> op x == op y) (opL : forall f : PartialFunction (X (ElemFunc IS)), L (ElemFunc IS) f -> L (ElemFunc IS) (Xop (X (ElemFunc IS)) f op opEq)) (contract : forall x y : CRcarrier (RealT (ElemFunc IS)), CRabs _ (op x - op y) <= CRabs _ (x - y)) (zeroFix : op 0 == 0) : IntegrableFunction f -> @IntegralRepresentation IS. Proof. intros. destruct X. destruct (IabsOpContract _ _ op opEq opL contract zeroFix (IntAbsSum x) (IntAbsSumCv x)) as [sumOp cvOps]. (* Weave the telescopic abs with the representation itself, to stay in the domain of f. *) exact (IntegralRepresentationWeave (Build_IntegralRepresentation IS (telescopicOp _ (IntFn x) op opEq) (telescopicOpL (IntFn x) (IntFnL x) op opEq opL) sumOp cvOps) (IntegralRepresentationWeave x (IntegralRepresentationScaleHalf f (-(1)) (existT _ x p)))). Defined. Definition IntegrableOpContract {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (op : CRcarrier (RealT (ElemFunc IS)) -> CRcarrier (RealT (ElemFunc IS))) (opEq : forall x y : CRcarrier (RealT (ElemFunc IS)), x == y -> op x == op y) (opL : forall f : PartialFunction (X (ElemFunc IS)), L (ElemFunc IS) f -> L (ElemFunc IS) (Xop (X (ElemFunc IS)) f op opEq)) (contract : forall x y : CRcarrier (RealT (ElemFunc IS)), CRabs _ (op x - op y) <= CRabs _ (x - y)) (zeroFix : op 0 == 0) : IntegrableFunction f -> IntegrableFunction (Xop (X (ElemFunc IS)) f op opEq). Proof. intros. exists (IntegralRepresentationOpContract f op opEq opL contract zeroFix X). (* Prove partial restriction *) split. - (* Domain inclusion *) intros x xdf. simpl. unfold IntegralRepresentationOpContract in xdf; destruct X; destruct (IabsOpContract (IntFn x0) (IntFnL x0) op opEq opL contract zeroFix (IntAbsSum x0) (IntAbsSumCv x0)). unfold IntegralRepresentationWeave, IntFn in xdf. pose proof (domainInfinSumWeaveR _ _ _ x xdf) as d0. pose proof (domainInfinSumWeaveL _ _ _ x d0) as pxDFn. destruct p. exact (d x pxDFn). - intros. unfold IntegralRepresentationOpContract, IntegralRepresentationWeave, IntFn, IntFnL, IntAbsSum, IntAbsSumCv in xD; unfold IntegralRepresentationOpContract, IntegralRepresentationWeave, IntFn, IntFnL, IntAbsSum, IntAbsSumCv ; destruct X as [[fn fnL sumIAbsFn H] [injF restr]]; destruct (IabsOpContract _ _ op opEq opL contract zeroFix sumIAbsFn H) as [sumOp cvOps]. pose proof (domainInfinSumWeaveL _ _ _ x xD) as pxDTn. pose proof (domainInfinSumWeaveR _ _ _ x xD) as x0. pose proof (domainInfinSumWeaveL _ _ _ x x0) as pxDFn. unfold IntFn in restr. apply applyInfiniteSumAbs. simpl (partialApply (Xop (X (ElemFunc IS)) f op opEq) x xG). apply (series_cv_eq (weaveSequences _ (fun n : nat => partialApply (telescopicOp _ fn op opEq n) x (domainInfiniteSumAbsIncReverse _ x pxDTn n)) (weaveSequences _ (fun n : nat => partialApply (fn n) x (domainInfiniteSumAbsIncReverse _ x pxDFn n)) (fun n : nat => CRopp _ (partialApply (fn n) x (domainInfiniteSumAbsIncReverse _ x pxDFn n)))))). + intro n. rewrite (partialApplyWeave _ _ _ n x (domainInfiniteSumAbsIncReverse _ x pxDTn (n/2)) (domainInfiniteSumAbsIncReverse _ x x0 (n/2))). unfold weaveSequences. destruct (Nat.even n). reflexivity. pose proof (partialApplyWeave _ fn (fun n => Xscale (-(1)) (fn n)) (n/2) x (domainInfiniteSumAbsIncReverse fn x pxDFn (n / 2 / 2)) (domainInfiniteSumAbsIncReverse fn x pxDFn (n / 2 / 2))). rewrite H0. destruct (Nat.even (n/2)). reflexivity. rewrite applyXscale. rewrite <- CRopp_mult_distr_l. rewrite CRmult_1_l. reflexivity. + rewrite <- CRplus_0_r. rewrite <- (CRplus_opp_r (partialApply (XinfiniteSumAbs fn) x pxDFn)). apply weaveInfiniteSums. apply (applyTelescopicOpInfSum _ _ _ _ contract x (domainInfiniteSumAbsIncReverse _ x pxDFn)). apply applyInfiniteSumAbs. apply restr. apply weaveInfiniteSums. apply applyInfiniteSumAbs. reflexivity. apply series_cv_opp. apply applyInfiniteSumAbs. reflexivity. Defined. (* Like the Lebesgue integral, a function f is integrable when its absolute value is. *) Definition IntegrableAbs {IS : IntegrationSpace} {f : PartialFunction (X (ElemFunc IS))} : IntegrableFunction f -> IntegrableFunction (Xabs f) := fun fInt => IntegrableOpContract f (CRabs _) (CRabs_morph_prop _) (LabsStable (ElemFunc IS)) CRabs_triang_inv2 (CRabs_right 0 (CRle_refl 0)) fInt. (* The triangular inequality for integrals. *) Lemma IntegralTriangle : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), CRabs _ (Integral fInt) <= Integral (IntegrableAbs fInt). Proof. intros. apply CRabs_le. split. - rewrite <- IntegralOpp. apply IntegralNonDecreasing. intros x xdf xdg. rewrite applyXscale, applyXabs. rewrite (DomainProp f x xdf xdg). rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- (CRopp_involutive (partialApply f x xdg)). apply CRopp_ge_le_contravar. rewrite CRopp_involutive. rewrite <- CRabs_opp. apply CRle_abs. - apply IntegralNonDecreasing. intros x xdf xdg. rewrite applyXabs. rewrite (DomainProp f x xdg xdf). apply CRle_abs. Qed. (* The integral of the absolute value of the function difference is a distance on the integrable functions. It is symmetric, satisfies the triangular inequality, but not exactly separated. When the integral distance between f and g is 0, then f and g are equal almost-everywhere, as defined in CMTFullSets. *) Definition IntegralDistance {IS : IntegrationSpace} {f g : PartialFunction (X (ElemFunc IS))} (fInt : IntegrableFunction f) (gInt : IntegrableFunction g) : CRcarrier _ := Integral (IntegrableAbs (IntegrableMinus fInt gInt)). Lemma IntegralDistance_sym : forall { IS : IntegrationSpace } (f g : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g), IntegralDistance fInt gInt == IntegralDistance gInt fInt. Proof. intros. apply IntegralExtensional. intros. do 2 rewrite applyXabs. destruct xdf, xdg. rewrite (applyXminus f g), (applyXminus g f). rewrite CRabs_minus_sym. apply CRabs_morph, CRplus_morph. apply DomainProp. apply CRopp_morph. apply DomainProp. Qed. Lemma IntegralDistance_triang : forall { IS : IntegrationSpace } (f g h : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (gInt : IntegrableFunction g) (hInt : IntegrableFunction h), IntegralDistance fInt hInt <= IntegralDistance gInt fInt + IntegralDistance gInt hInt. Proof. intros. unfold IntegralDistance. rewrite <- IntegralPlus. apply IntegralNonDecreasing. intros x xdf xdg. destruct xdf, xdg. rewrite applyXabs, (applyXplus _ _ x d1 d2). rewrite (applyXminus f h x d d0). setoid_replace (partialApply f x d - partialApply h x d0) with (partialApply f x d - partialApply g x (fst d2) + (partialApply g x (fst d2) - partialApply h x d0)). apply (CRle_trans _ _ _ (CRabs_triang _ _)). apply CRplus_le_compat. rewrite CRabs_minus_sym. rewrite applyXabs. destruct d1. rewrite (applyXminus g f x d1 d3), (DomainProp g x (fst d2) d1). rewrite (DomainProp f x d3 d). apply CRle_refl. rewrite applyXabs. destruct d2. rewrite (applyXminus g h x d2 d3), (DomainProp h x d3 d0). apply CRle_refl. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Definition Un_integral_cv { IS : IntegrationSpace } (fn : nat -> PartialFunction (X (ElemFunc IS))) (f : PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (fInt : IntegrableFunction f) := forall p : positive, { n : nat | forall i:nat, le n i -> IntegralDistance (fnInt i) fInt <= CR_of_Q _ (1#p) }. Definition IntegrableMinOne {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction (XminConst f 1). Proof. intros fInt. apply IntegrableOpContract. intros g gL. apply LminConstStable. exact (CRzero_lt_one _). exact gL. intros. apply CRmin_contract. apply CRmin_left. apply CRlt_asym, CRzero_lt_one. exact fInt. Defined. Definition FunctionRieszSpaceCompletion (IS : IntegrationSpace) : FunctionRieszSpace. Proof. apply (Build_FunctionRieszSpace (X (ElemFunc IS)) (RealT (ElemFunc IS)) IntegrableFunction). - intros f g H fInt. apply (IntegrableFunctionExtensional f g). destruct H. split. apply p. apply c. exact fInt. - exact IntegrablePlus. - intros f fInt. apply (IntegrableAbs fInt). - intros. exact (IntegrableMinOne f X). - intros a f fInt. exact (IntegrableScale f a fInt). Defined. Definition IntegrableMinConst {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (a : CRcarrier _) : IntegrableFunction f -> 0 < a -> IntegrableFunction (XminConst f a) := fun fInt aPos => @LminConstStable (FunctionRieszSpaceCompletion IS) a f aPos fInt. Definition IntegrableMaxConst {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (a : CRcarrier _) : IntegrableFunction f -> a < 0 -> IntegrableFunction (XmaxConst f a). Proof. intros fInt aPos. apply IntegrableOpContract. intros g gL. apply (Lext _ (Xscale (CRopp _ 1) (XminConst (Xscale (CRopp _ 1) g) ((CRopp _ 1)*a)))). split. split. intros x xdg. exact xdg. intros x xdg. exact xdg. intros. simpl. rewrite CRmin_max_mult_neg. do 2 rewrite <- CRopp_mult_distr_l. rewrite CRmult_1_l, CRmult_1_l, CRopp_involutive. apply CRmax_morph. apply DomainProp. reflexivity. apply (CRplus_le_reg_l 1). rewrite CRplus_opp_r, CRplus_0_r. apply CRlt_asym, CRzero_lt_one. apply LscaleStable. apply LminConstStable. rewrite <- CRopp_mult_distr_l, CRmult_1_l. apply (CRplus_lt_reg_l _ a). rewrite CRplus_opp_r, CRplus_0_r. exact aPos. apply LscaleStable, gL. intros. apply CRmax_contract. apply CRmax_left. apply CRlt_asym, aPos. exact fInt. Defined. Definition IntegrablePosPart {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction (XposPart f). Proof. intros fInt. exact (IntegrableScale (Xplus f (Xabs f)) (CR_of_Q _ (1#2)) (IntegrablePlus f (Xabs f) fInt (IntegrableAbs fInt))). Defined. Definition IntegrableNegPart {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction (XnegPart f). Proof. intros fInt. exact (IntegrableScale (Xminus (Xabs f) f) (CR_of_Q _ (1#2)) (IntegrableMinus (IntegrableAbs fInt) fInt)). Defined. Definition IntegrableMinInt {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (n : nat) : IntegrableFunction f -> IntegrableFunction (XminConst f (INR n)) := fun fInt => @LminIntStable (FunctionRieszSpaceCompletion IS) n f fInt. Definition IntegrableMin {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction g -> IntegrableFunction (Xmin f g). Proof. intros fInt gInt. apply IntegrableMinus. assumption. apply IntegrableNegPart. apply IntegrableMinus; assumption. Defined. Definition IntegrableMax {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> IntegrableFunction g -> IntegrableFunction (Xmax f g). Proof. intros fInt gInt. apply IntegrablePlus. assumption. apply IntegrablePosPart. apply IntegrableMinus; assumption. Defined. Lemma intTelescopicAbs : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (n : nat), CRsum (fun n : nat => I IS (telescopicOp (X (ElemFunc IS)) fn (CRabs _) (CRabs_morph_prop _) n) (telescopicOpL fn fnL (CRabs _) (CRabs_morph_prop _) (fun f => LabsStable (ElemFunc IS) f) n)) n == Iabs (Xsum fn n) (LsumStable fn fnL n). Proof. induction n. - reflexivity. - unfold CRsum. rewrite IHn. clear IHn. unfold telescopicOp, telescopicOpL, Xminus. rewrite Iadditive. rewrite Ihomogeneous. rewrite <- (CRopp_mult_distr_l 1), CRmult_1_l. unfold Iabs, Xabs. rewrite <- CRplus_assoc, CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. Qed. (* If function f is the limit of the series fn, then the integral of |f| is the limit of the integrals of the partial sums |f1 + ... + fn| *) Lemma IntegralAbsLimit : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), CR_cv _ (fun n : nat => (Iabs _ (LsumStable (IntFn (let (i,_) := fInt in i)) (IntFnL (let (i,_) := fInt in i)) n))) (Integral (IntegrableAbs fInt)). Proof. intros IS. assert (CRabs (RealT (ElemFunc IS)) 0 == 0) as CReal_abs_R0. { rewrite CRabs_right. reflexivity. apply CRle_refl. } intros. unfold Integral, IntegrableAbs, IntegrableOpContract, IntegralRepresentationOpContract. destruct fInt as [x p], (IabsOpContract (IntFn x) (IntFnL x) (CRabs _) (CRabs_morph_prop _) (LabsStable (ElemFunc IS)) CRabs_triang_inv2 (CRabs_right 0 (CRle_refl 0)) (IntAbsSum x) (IntAbsSumCv x)). do 2 rewrite IntegralRepresentationWeaveSum. rewrite IntegralHomogeneousHalf, <- CRopp_mult_distr_r, CRmult_1_r, CRplus_opp_r, CRplus_0_r. destruct x as [fn fnL sumIAbsFn H]; unfold IntFn, IntFnL. apply (CR_cv_eq _ (CRsum (fun n : nat => I IS (telescopicOp (X (ElemFunc IS)) fn (CRabs _) (CRabs_morph_prop _) n) (telescopicOpL fn fnL (CRabs _) (CRabs_morph_prop _) (fun (g : PartialFunction (X (ElemFunc IS))) (gL : L (ElemFunc IS) g) => LabsStable (ElemFunc IS) g gL) n)))). 2: apply (IntegralCv {| IntFn := telescopicOp (X (ElemFunc IS)) fn (CRabs _) (CRabs_morph_prop _); IntFnL := telescopicOpL fn fnL (CRabs _) (CRabs_morph_prop _) (fun (g : PartialFunction (X (ElemFunc IS))) (gL : L (ElemFunc IS) g) => LabsStable (ElemFunc IS) g gL); IntAbsSum := x0; IntAbsSumCv := s |}). intro n. rewrite intTelescopicAbs. reflexivity. Qed. Definition IntegralRepresentationL {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) : @IntegralRepresentation IS. Proof. pose (fun n:nat => match n with | O => f | _ => Izero IS end) as fn. assert (forall n:nat, L (ElemFunc IS) (fn n)) as fnL. { intro n. unfold fn. destruct n. exact fL. apply Izero_is_L. } apply (Build_IntegralRepresentation IS fn fnL (Iabs f fL)). apply (CR_cv_eq _ (fun _:nat => Iabs f fL)). 2: apply CR_cv_const. intro n. destruct n. apply IExtensional. intros. apply DomainProp. rewrite <- CRplus_0_r, decomp_sum. apply CRplus_morph. apply IExtensional. intros. apply DomainProp. rewrite (CRsum_eq _ (fun _ => 0)). rewrite sum_eq_R0. reflexivity. intros _. reflexivity. intros. unfold fn, Iabs. rewrite (IExtensional _ (Izero IS) _ (Izero_is_L IS)). apply Izero_is_zero. intros. rewrite applyXabs, applyIzero, applyIzero, CRabs_right. reflexivity. apply CRle_refl. apply le_n_S, Nat.le_0_l. Defined. Definition IntegrableL {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) : IntegrableFunction f. Proof. exists (IntegralRepresentationL f fL). split. - intros x xd. destruct xd as [xn lim]. exact (xn O). - intros. apply applyInfiniteSumAbs. apply (CR_cv_eq _ (fun _:nat => partialApply f x xG)). 2: apply CR_cv_const. intro n. destruct n. apply DomainProp. rewrite <- CRplus_0_r, decomp_sum. apply CRplus_morph. apply DomainProp. rewrite (CRsum_eq _ (fun _ => 0)). rewrite sum_eq_R0. reflexivity. intros _. reflexivity. intros. unfold IntegralRepresentationL, IntFn. apply applyIzero. apply le_n_S, Nat.le_0_l. Defined. Lemma IntegralLstable : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f), Integral (IntegrableL f fL) == I IS f fL. Proof. intros. unfold IntegrableL. pose proof (IntegralCv (IntegralRepresentationL f fL)). apply (CR_cv_unique (fun n => I IS f fL)). 2: apply CR_cv_const. apply (CR_cv_eq _ (CRsum (fun n : nat => I IS (IntFn (IntegralRepresentationL f fL) n) (IntFnL (IntegralRepresentationL f fL) n)))). 2: exact H. intro n. destruct n. reflexivity. symmetry. rewrite <- CRplus_0_r, decomp_sum. apply CRplus_morph. apply IExtensional. intros. apply DomainProp. rewrite (CRsum_eq _ (fun _ => 0)). rewrite sum_eq_R0. reflexivity. intros _. reflexivity. intros. simpl. apply Izero_is_zero. apply le_n_S, Nat.le_0_l. Qed. Fixpoint IntegrableSum {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (n : nat) : IntegrableFunction (Xsum fn n). Proof. destruct n. - apply fnInt. - simpl. apply IntegrablePlus. apply IntegrableSum. exact fnInt. apply fnInt. Defined. Definition IntegralRepresentationAbs { IS : IntegrationSpace } : @IntegralRepresentation IS -> @IntegralRepresentation IS. Proof. intro fInt. pose (fun n:nat => Xabs (IntFn fInt n)) as fn. assert (forall n:nat, L (ElemFunc IS) (fn n)) as fnL. { intro n. unfold fn. apply (LabsStable (ElemFunc IS)), IntFnL. } apply (Build_IntegralRepresentation IS fn fnL (IntAbsSum fInt)). apply (series_cv_eq (fun n : nat => Iabs (IntFn fInt n) (IntFnL fInt n))). 2: apply fInt. intro n. apply IExtensional. intros. unfold fn. rewrite (applyXabs (Xabs (IntFn fInt n))), CRabs_right. apply DomainProp. rewrite applyXabs. apply CRabs_pos. Defined. Lemma IntegralRepresentationAbsVal : forall {IS : IntegrationSpace} (fInt : @IntegralRepresentation IS), IntegralSeries (IntegralRepresentationAbs fInt) == IntAbsSum fInt. Proof. intros. apply (CR_cv_unique (CRsum (fun n => Iabs (IntFn fInt n) (IntFnL fInt n)))). exact (IntegralCv (IntegralRepresentationAbs fInt)). apply fInt. Qed. Definition IntegrableSelf { IS : IntegrationSpace } (fInt : @IntegralRepresentation IS) : IntegrableFunction (XinfiniteSumAbs (IntFn fInt)). Proof. exists fInt. apply PartialRestriction_refl. Defined. corn-8.20.0/reals/stdlib/CMTIntegrableSets.v000066400000000000000000001374301473720167500206230ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* We now move from functions to integrable sets, ie measures. We will prove the properties of measures up to monotonous continuity. Given an integration space IS on a base type X, a subset A : X -> Prop is declared integrable when it is almost everywhere decidable, i.e. when there is an integrable function f : X -> {0, 1} such as A x when f x == 1 and ~A x when f x == 0. The integral of f will be called the measure of A. Because integrable functions are stable under extensions, this definition is equivalent to requiring that the biggest characteristic function with domain { x : X & { A x } + { ~A x } } is integrable. This simplifies the theory of Bishop and Cheng, by avoiding the unnecessary concept of complemented set. *) From Coq Require Import ConstructiveEpsilon. From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Require Import ConstructiveDiagonal. Require Import ConstructivePartialFunctions. Require Import CMTbase. Require Import CMTIntegrableFunctions. Require Import CMTFullSets. Require Import CMTPositivity. Local Open Scope ConstructiveReals. Definition CharacFunc {R : ConstructiveReals} {X : Set} (A : X -> Prop) : @PartialFunction R X. Proof. apply (Build_PartialFunctionXY X (CRcarrier R) (CReq R) (fun x:X => { A x } + { ~A x }) (fun x dec => if dec then CR_of_Q R 1 else CR_of_Q R 0) ). intros. destruct p,q. reflexivity. contradiction. contradiction. reflexivity. Defined. Definition IntegrableSet {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop) : Type := IntegrableFunction (CharacFunc A). Definition MeasureSet {IS : IntegrationSpace} {A : X (ElemFunc IS) -> Prop} : IntegrableSet A -> CRcarrier (RealT (ElemFunc IS)) := Integral. (*********************************************************) (** * Integration of complemented sets *) (*********************************************************) Definition PartialFunctionBoolR {X : Set} {R : ConstructiveReals} (f : @PartialFunctionXY X bool eq) : @PartialFunction R X. Proof. apply (Build_PartialFunctionXY X (CRcarrier R) (CReq R) (Domain f) (fun x dec => if partialApply f x dec then CR_of_Q R 1 else CR_of_Q R 0)). intros. rewrite (DomainProp f x p q). reflexivity. Defined. (* As announced, we prove that Definition IntegrableSet is equivalent to the more general formulation that the subset is almost everywhere decidable. *) Lemma IntegrableSetAEdecidable : forall {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop) (f : @PartialFunctionXY (X (ElemFunc IS)) bool eq), IntegrableFunction (PartialFunctionBoolR f) -> (forall (x : X (ElemFunc IS)) (dec : Domain f x), if partialApply f x dec then A x else ~A x) -> IntegrableSet A. Proof. intros IS A f fInt. destruct fInt. exists x. apply (PartialRestriction_trans _ _ (PartialFunctionBoolR f) _ p). split. - intros y yD. simpl in yD. specialize (H y yD). destruct (partialApply f y yD). left. exact H. right. exact H. - intros. simpl. specialize (H x0 xD). destruct (partialApply f x0 xD), xG. reflexivity. 3: reflexivity. contradiction. contradiction. Qed. Definition IntegrableSetExtensional {IS : IntegrationSpace} (A B : (X (ElemFunc IS)) -> Prop) : (forall x:X (ElemFunc IS), { A x } + { ~A x } -> (A x <-> B x)) -> IntegrableSet A -> IntegrableSet B. Proof. intros H Aint. apply (IntegrableFunctionExtensional (CharacFunc A)). 2: exact Aint. split. - intros x xdf. destruct xdf. left. apply H. left. exact a. exact a. right. intro abs. apply H in abs. contradiction. right. exact n. - intros. simpl. destruct xD, xG. reflexivity. apply H in a. contradiction. left. exact a. apply H in b. contradiction. right. exact n. reflexivity. Qed. (* ~~A can constructively be bigger than A, but when A is integrable then so is ~~A, with same measure. *) Definition IntegrableSetNotNot {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop) : IntegrableSet A -> IntegrableSet (fun x => ~~A x). Proof. intro Aint. apply (IntegrableSetExtensional A). split. intros H0 abs. contradiction. intro abs. destruct H. exact a. contradiction. exact Aint. Qed. Lemma MeasureExtensional : forall {IS : IntegrationSpace} (A B : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (Bint : IntegrableSet B), (forall x:X (ElemFunc IS), { A x } + { ~A x } -> { B x } + { ~B x } -> (A x <-> B x)) -> MeasureSet Aint == MeasureSet Bint. Proof. intros. apply IntegralExtensional. intros. simpl. destruct xdf, xdg. reflexivity. 3: reflexivity. exfalso. rewrite H in a. contradiction. left. exact a. right. exact n. exfalso. rewrite <- H in b. contradiction. right. exact n. left. exact b. Qed. Lemma MeasureEmptyZero : forall {IS : IntegrationSpace} (A : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A), (forall x:X (ElemFunc IS), { A x } + { ~A x } -> ~A x) -> MeasureSet aInt == 0. Proof. intros. transitivity (Integral (@IntegrableZero IS)). apply IntegralExtensional. intros. simpl. destruct xdf. 2: reflexivity. exfalso. specialize (H x (left a)). contradiction. apply IntegralZeroIsZero. Qed. Lemma MeasureNonNeg : forall {IS : IntegrationSpace} (A : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A), 0 <= MeasureSet aInt. Proof. intros. apply (CRle_trans _ (Integral (@IntegrableZero IS))). rewrite IntegralZeroIsZero. apply CRle_refl. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. Qed. Lemma MeasureNonDecreasing : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), (forall x : X (ElemFunc IS), A x -> B x) -> MeasureSet aInt <= MeasureSet bInt. Proof. intros. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg. apply CRle_refl. exfalso. specialize (H x a). contradiction. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. Qed. Lemma MeasureZeroAE : forall {IS : IntegrationSpace} (Z : X (ElemFunc IS) -> Prop) (zInt : IntegrableSet Z), MeasureSet zInt == 0 -> almost_everywhere (fun x => ~Z x). Proof. intros. destruct (IntegrableFunctionsComplete IS (fun _:nat => CharacFunc Z) (fun _ => zInt) 0) as [rep [p s]]. - apply (CR_cv_eq _ (fun _:nat => 0)). 2: apply CR_cv_const. intro n. rewrite sum_const. unfold MeasureSet in H. rewrite <- (CRmult_0_l (INR (S n))). apply CRmult_morph. 2: reflexivity. rewrite <- H. apply IntegralExtensional. intros. rewrite applyXabs. rewrite (DomainProp _ x xdf xdg). rewrite CRabs_right. reflexivity. simpl. destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. - exists (XinfiniteSumAbs (IntFn rep)). split. + exists rep. apply PartialRestriction_refl. + intros x H0 abs. destruct p. specialize (d x H0) as [xn xncv]. apply CR_complete in xncv. destruct xncv as [l lcv]. apply (CR_cv_eq (fun n:nat => CR_of_Q _ (Z.of_nat (S n) # 1))) in lcv. specialize (lcv 1%positive) as [n ncv]. destruct (CRup_nat (1+l)) as [k kup]. specialize (ncv (max n k) (Nat.le_max_l _ _)). apply (CRle_trans _ _ _ (CRle_abs _)) in ncv. apply (CRplus_le_compat_r l) in ncv. unfold CRminus in ncv. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r in ncv. apply ncv. apply (CRlt_le_trans _ _ _ kup). apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_max_r. intro n. rewrite <- (CRsum_eq (fun _ => 1)). rewrite sum_const, CRmult_1_l. reflexivity. intros. simpl. destruct (xn i). rewrite CRabs_right. reflexivity. apply CRlt_asym, CRzero_lt_one. contradiction. Qed. Lemma domainXinfinitePosNeg : forall {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) (x : X), (Domain (XinfiniteSumAbs (fun n => XposPart (fn n))) x) -> (Domain (XinfiniteSumAbs (fun n => XnegPart (fn n))) x) -> Domain (XinfiniteSumAbs fn) x. Proof. intros. destruct H, H0. exists (fun n => fst (x0 n)). apply CR_complete in c. apply CR_complete in c0. destruct c,c0. apply (Rcv_cauchy_mod _ (x2+x3)). pose proof (series_cv_plus _ _ _ _ c c0). apply (series_cv_eq (fun n : nat => (fun n0 : nat => CRabs R (partialApply (XposPart (fn n0)) x (x0 n0))) n + (fun n0 : nat => CRabs R (partialApply (XnegPart (fn n0)) x (x1 n0))) n)). intro n. rewrite CRabs_right, CRabs_right. simpl. destruct (x0 n), (x1 n). rewrite <- CRmult_plus_distr_l. rewrite <- CRopp_mult_distr_l, CRmult_1_l, CRplus_comm, CRplus_assoc. rewrite <- (CRplus_assoc (- partialApply (fn n) x d2)). rewrite (DomainProp (fn n) x d2 d), CRplus_opp_l, CRplus_0_l. apply (CRmult_eq_reg_l (CR_of_Q R 2)). right. apply CR_of_Q_pos. reflexivity. rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_l. rewrite CRmult_plus_distr_r, CRmult_1_l. rewrite (DomainProp (fn n) x (fst (d,d0)) d0), (DomainProp (fn n) x d1 d0). reflexivity. apply applyXnegPartNonNeg. apply applyXposPartNonNeg. exact H. Qed. (* This will provide a very nice proof that the Cauchy reals are uncountable. *) Lemma PositiveMeasureInhabited : forall {IS : IntegrationSpace} (A : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A), 0 < MeasureSet aInt -> { x : X (ElemFunc IS) | A x }. Proof. intros. destruct aInt. destruct (splitIntegralSumPosNeg (IntFn x) (IntFnL x) (IntAbsSum x) (IntAbsSumCv x)), s, p0, p0. assert (series_cv (fun k : nat => Iabs (XposPart (IntFn x k)) (LposPartStable (IntFn x k) (IntFnL x k))) x0). { apply (series_cv_eq (fun n0 : nat => I IS (XposPart (IntFn x n0)) (LposPartStable (IntFn x n0) (IntFnL x n0)))). 2: exact s0. intro n. apply IExtensional. intros. rewrite applyXabs, CRabs_right, (DomainProp _ x2 xF y). reflexivity. apply applyXposPartNonNeg. } destruct (IntegrableContinuous (XinfiniteSumAbs (fun n : nat => XposPart (IntFn x n))) (fun n => XnegPart (IntFn x n)) (existT _ (Build_IntegralRepresentation IS (fun n => XposPart (IntFn x n)) (fun n => LposPartStable _ (IntFnL x n)) x0 H0) (pair (fun y yD => yD) (fun x2 xD xG => DomainProp _ x2 xD xG))) (fun n => IntegrableL _ (LnegPartStable (IntFn x n) (IntFnL x n)))). - intro n. apply applyXnegPartNonNeg. - exists x1. split. apply (series_cv_eq (fun n0 : nat => I IS (XnegPart (IntFn x n0)) (LnegPartStable (IntFn x n0) (IntFnL x n0)))). 2: exact s1. intro n. rewrite IntegralLstable. reflexivity. unfold Integral. apply (CRlt_le_trans _ x0). apply (CRplus_lt_reg_r (-x1)). rewrite CRplus_opp_r. pose proof (IntegralCv x). setoid_replace (x0 + - x1) with (IntegralSeries x). exact H. apply (series_cv_unique (fun n : nat => I IS (IntFn x n) (IntFnL x n))). 2: exact H1. unfold CRminus in s. exact s. unfold IntegralSeries. destruct (series_cv_maj _ _ x0 (fun n : nat => integralAbsMaj (XposPart (IntFn x n)) (LposPartStable (IntFn x n) (IntFnL x n))) H0), p0. setoid_replace x0 with x2. apply CRle_refl. apply (series_cv_unique (fun k : nat => Iabs (XposPart (IntFn x k)) (LposPartStable (IntFn x k) (IntFnL x k))) _ _ H0). apply (series_cv_eq (fun n : nat => I IS (XposPart (IntFn x n)) (LposPartStable (IntFn x n) (IntFnL x n)))). 2: exact s2. intro n. apply IExtensional. intros. rewrite applyXabs, CRabs_right. apply DomainProp. apply applyXposPartNonNeg. - clear H. destruct x2; unfold ConstructivePartialFunctions.cpx, ConstructivePartialFunctions.cpxF, ConstructivePartialFunctions.cpxFn in s2. exists cpx. destruct s2, p0, p. assert (Domain (XinfiniteSumAbs (IntFn x)) cpx). { apply (domainXinfinitePosNeg _ _ cpxF). exists cpxFn. apply (Rcv_cauchy_mod _ x2). apply (series_cv_eq (fun n : nat => partialApply (XnegPart (IntFn x n)) cpx (cpxFn n))). 2: exact s2. intro n. rewrite CRabs_right. reflexivity. apply applyXnegPartNonNeg. } pose proof (c0 cpx H (d _ H)). simpl (partialApply (CharacFunc A) cpx (d cpx H)) in H1. destruct (d cpx H). exact a. exfalso. clear n. apply applyInfiniteSumAbs in H1. pose proof (series_cv_unique _ 0 (partialApply (XinfiniteSumAbs (fun n : nat => XposPart (IntFn x n))) cpx cpxF-x2) H1). clear H1. apply CRlt_minus in c. destruct H2. 2: contradiction. destruct cpxF. apply (series_cv_eq (fun n : nat => partialApply (XposPart (IntFn x n)) cpx (x3 n) - partialApply (XnegPart (IntFn x n)) cpx (cpxFn n))). intro n. apply SplitPosNegParts. apply series_cv_minus. 2: exact s2. apply (series_cv_eq (fun n => partialApply (XposPart (IntFn x n)) cpx (domainInfiniteSumAbsIncReverse _ cpx (existT _ x3 c1) n))). intro n. apply DomainProp. apply applyInfiniteSumAbs. reflexivity. Qed. Definition IntegrableSetIntersect {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B) : IntegrableSet (fun x => A x /\ B x). Proof. apply (IntegrableFunctionExtensional (Xmin (CharacFunc A) (CharacFunc B))). - split. + intros x xdf. simpl. destruct xdf, d0, d0. destruct d. destruct d0. left. split; assumption. right. intros [abs _]. contradiction. right. intros [_ abs]. contradiction. + intros. assert (Domain (@CharacFunc (RealT (ElemFunc IS)) _ A) x) as H. { destruct (CharacFunc A), (CharacFunc B); simpl; apply xD. } assert (Domain (@CharacFunc (RealT (ElemFunc IS)) _ B) x) as H0. { destruct (CharacFunc A), (CharacFunc B); simpl; apply xD. } rewrite (applyXmin _ _ _ H H0). destruct H. destruct H0. (* In intersection *) rewrite CRmin_left. simpl. destruct xG. reflexivity. exfalso. apply n. split; assumption. apply CRle_refl. (* Not in intersection *) destruct xG. exfalso. apply n; apply a0. rewrite CRmin_right. reflexivity. apply CRlt_asym, CRzero_lt_one. destruct H0. destruct xG. exfalso. apply n, a. rewrite CRmin_left. reflexivity. apply CRlt_asym, CRzero_lt_one. rewrite CRmin_left. destruct xG. exfalso. apply n, a. reflexivity. apply CRle_refl. - apply IntegrableMin; assumption. Defined. Lemma MeasureIntersectSym : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), MeasureSet (IntegrableSetIntersect A B aInt bInt) == MeasureSet (IntegrableSetIntersect B A bInt aInt). Proof. intros. unfold MeasureSet. apply IntegralExtensional. intros. destruct xdf,xdg; simpl. reflexivity. exfalso. apply n. split; apply a. exfalso. apply n. split; apply a. reflexivity. Qed. Definition IntegrableSetUnion {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B) : IntegrableSet (fun x => A x \/ B x). Proof. apply (IntegrableFunctionExtensional (Xmax (CharacFunc A) (CharacFunc B))). - split. + intros x xdf. simpl. destruct xdf, d0, d0. clear d2 d1. destruct d. left. right. exact b. destruct d0. left. left. exact a. right. intro abs. destruct abs; contradiction. + intros. assert (Domain (@CharacFunc (RealT (ElemFunc IS)) _ A) x) as H. { destruct (CharacFunc A), (CharacFunc B); simpl; apply xD. } assert (Domain (@CharacFunc (RealT (ElemFunc IS)) _ B) x) as H0. { destruct (CharacFunc A), (CharacFunc B); simpl; apply xD. } rewrite (applyXmax _ _ _ H H0). destruct xG. (* In union *) destruct H, H0. rewrite CRmax_right. reflexivity. apply CRle_refl. rewrite CRmax_left. reflexivity. apply CRlt_asym, CRzero_lt_one. rewrite CRmax_right. reflexivity. apply CRlt_asym, CRzero_lt_one. exfalso. destruct o; contradiction. (* Not in union *) destruct H. exfalso. apply n. left. exact a. destruct H0. exfalso. apply n. right. exact b. rewrite CRmax_right. reflexivity. apply CRle_refl. - apply IntegrableMax; assumption. Defined. Lemma MeasureAdditive : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), MeasureSet aInt + MeasureSet bInt == MeasureSet (IntegrableSetUnion A B aInt bInt) + MeasureSet (IntegrableSetIntersect A B aInt bInt). Proof. intros. setoid_replace (MeasureSet aInt + MeasureSet bInt) with (Integral (IntegrablePlus _ _ aInt bInt)). setoid_replace (MeasureSet (IntegrableSetUnion A B aInt bInt) + MeasureSet (IntegrableSetIntersect A B aInt bInt)) with (Integral (IntegrablePlus _ _ (IntegrableSetUnion A B aInt bInt) (IntegrableSetIntersect A B aInt bInt))). - apply IntegralExtensional. intros. destruct xdf,xdg; simpl. destruct d. destruct d1. 2: exfalso; apply n; left; exact a. destruct d0. destruct d2. reflexivity. exfalso; apply n; split; assumption. destruct d2. exfalso. destruct a0. contradiction. reflexivity. destruct d0, d1, d2. exfalso. apply n, a. apply CRplus_comm. reflexivity. exfalso. apply n0. right. exact b. exfalso. apply n, a. exfalso. destruct o; contradiction. exfalso. apply n, a. reflexivity. - rewrite IntegralPlus. reflexivity. - rewrite IntegralPlus. reflexivity. Qed. Fixpoint UnionIterate {X : Set} (An : nat -> X -> Prop) (n : nat) : X -> Prop := match n with | O => An O | S p => fun x => UnionIterate An p x \/ An n x end. Fixpoint IntersectIterate {X : Set} (An : nat -> X -> Prop) (n : nat) : X -> Prop := match n with | O => An O | S p => fun x => IntersectIterate An p x /\ An n x end. Lemma applyUnionIterate : forall (X : Set) (An : nat -> X -> Prop) (n : nat) (x : X), UnionIterate An n x <-> exists (p:nat), le p n /\ An p x. Proof. induction n. - split. intros. exists O. split. reflexivity. apply H. intros. simpl. destruct H as [p [pneg pxp]]. inversion pneg. subst p. apply pxp. - split. + intros. simpl in H. destruct H. specialize (IHn x) as [H0 _]. destruct (H0 H). exists x0. split. apply (Nat.le_trans _ n). apply H1. apply le_S, Nat.le_refl. apply H1. exists (S n). split. apply Nat.le_refl. apply H. + intros. destruct H as [p [pxp H]]. apply Nat.le_succ_r in pxp. destruct pxp. (* p <= n *) left. specialize (IHn x) as [_ H3]. apply H3. exists p. split; assumption. subst p. right. exact H. Qed. Lemma applyIntersectIterate : forall (X : Set) (An : nat -> X -> Prop) (n : nat) (x : X), IntersectIterate An n x <-> forall (p:nat), le p n -> An p x. Proof. induction n. - split. intros. simpl in H. inversion H0. subst p. exact H. intros. simpl. apply H. apply Nat.le_refl. - split. + intros. apply Nat.le_succ_r in H0. destruct H0. apply IHn. apply H. exact H0. subst p. apply H. + intros. split. apply IHn. intros. apply H. apply (Nat.le_trans _ _ _ H0). apply le_S, Nat.le_refl. apply H. apply Nat.le_refl. Qed. Definition IntegrableSetUnionIterate {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (aInt : forall n:nat, IntegrableSet (An n)) : forall n:nat, IntegrableSet (UnionIterate An n). Proof. induction n. - apply aInt. - simpl. apply IntegrableSetUnion. apply IHn. apply aInt. Defined. Definition IntegrableSetIntersectIterate {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (aInt : forall n:nat, IntegrableSet (An n)) : forall n:nat, IntegrableSet (IntersectIterate An n). Proof. induction n. - apply aInt. - simpl. apply IntegrableSetIntersect. apply IHn. apply aInt. Defined. Lemma MeasureIntersectSeqDecr : forall {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (AnInt : forall n:nat, IntegrableSet (An n)), (forall (n : nat) (x : X (ElemFunc IS)), An (S n) x -> An n x) -> forall n : nat, MeasureSet (IntegrableSetIntersectIterate An AnInt n) == MeasureSet (AnInt n). Proof. intros IS An AnInt H. (* The characteristic function of the decreasing intersection is equal to the last characteristic function. *) assert (forall (n : nat) (x : X (ElemFunc IS)) (xIntersect : Domain (@CharacFunc (RealT (ElemFunc IS)) _ (IntersectIterate An n)) x) (xLast : Domain (CharacFunc (An n)) x), partialApply _ _ xIntersect = partialApply _ _ xLast). { induction n. - intros. simpl. destruct xIntersect, xLast. reflexivity. contradiction. contradiction. reflexivity. - intros. specialize (H n). (* Extract point in dAn *) destruct n. + clear IHn. simpl. destruct xIntersect, xLast. reflexivity. destruct i. contradiction. 2: reflexivity. exfalso. apply n. split. apply H, a. exact a. + simpl. simpl in IHn, xIntersect. destruct xIntersect. destruct a. destruct xLast. reflexivity. contradiction. destruct xLast. 2: reflexivity. assert (~ (IntersectIterate An n x /\ An (S n) x)). intro abs. apply n0. split; assumption. specialize (H x a). specialize (IHn x (right H0) (left H)). exact IHn. } intros. apply IntegralExtensional. intros. rewrite (H0 _ _ _ xdg). reflexivity. Qed. Definition IntegrableSetDifference {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B) : IntegrableSet (fun x => A x /\ ~B x). Proof. apply (IntegrableFunctionExtensional (Xminus (CharacFunc A) (CharacFunc (fun x => A x /\ B x)))). - split. + intros x xdf. destruct xdf. simpl. destruct d, d0. right. intro abs. destruct a0, abs; contradiction. left. split. exact a. intro abs. apply n. split; assumption. destruct a; contradiction. right. intro abs. destruct abs; contradiction. + intros. destruct xD. rewrite (applyXminus (CharacFunc A) (CharacFunc (fun x0 : X (ElemFunc IS) => A x0 /\ B x0))). destruct xG; simpl. destruct d0. destruct d. 2: destruct a0; contradiction. destruct a0, a; contradiction. destruct d. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. destruct a; contradiction. destruct d0. destruct d. unfold CRminus. rewrite CRplus_opp_r. reflexivity. destruct a; contradiction. destruct d. exfalso. apply n. split. exact a. intro abs. apply n0. split; assumption. unfold CRminus. rewrite CRplus_opp_r. reflexivity. - apply (IntegrableMinus aInt (IntegrableSetIntersect A B aInt bInt)). Defined. Lemma MeasureDifference : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), MeasureSet (IntegrableSetDifference A B aInt bInt) == MeasureSet aInt - MeasureSet (IntegrableSetIntersect A B aInt bInt). Proof. intros. unfold MeasureSet. rewrite <- IntegralMinus. apply IntegralExtensional. intros. destruct xdg. rewrite (applyXminus (CharacFunc A) (CharacFunc (fun x0 : X (ElemFunc IS) => A x0 /\ B x0))). destruct xdf; simpl. destruct d0. destruct d. destruct a,a0; contradiction. destruct a0; contradiction. destruct d. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. destruct a; contradiction. destruct d0. destruct d. unfold CRminus. rewrite CRplus_opp_r. reflexivity. destruct a; contradiction. destruct d. 2: unfold CRminus; rewrite CRplus_opp_r; reflexivity. exfalso. apply n. split. exact a. intro abs. apply n0. split; assumption. Qed. Lemma MeasureDifferenceIncluded : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), (forall x:X (ElemFunc IS), B x -> A x) -> MeasureSet (IntegrableSetDifference A B aInt bInt) == MeasureSet aInt - MeasureSet bInt. Proof. intros. rewrite MeasureDifference. apply CRplus_morph. reflexivity. apply CRopp_morph. apply IntegralExtensional. intros. simpl. destruct xdf, xdg. reflexivity. 3: reflexivity. destruct a. contradiction. exfalso. apply n. split. apply H, b. exact b. Qed. Lemma MeasureDifferenceInvolutive : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), MeasureSet (IntegrableSetDifference A _ aInt (IntegrableSetDifference A B aInt bInt)) == MeasureSet (IntegrableSetIntersect A B aInt bInt). Proof. intros. apply IntegralExtensional. intros. destruct xdf,xdg; simpl. reflexivity. exfalso. destruct a. apply H0. split. exact H. intro abs. apply n. split; assumption. exfalso. apply n. split. apply a. intro abs. destruct a, abs; contradiction. reflexivity. Qed. Lemma CharacFuncStationary : forall {R : ConstructiveReals} (X : Set) (An : nat -> X -> Prop) (x : X) (xn : forall n:nat, Domain (CharacFunc (An n)) x), CR_cauchy R (fun n => partialApply (CharacFunc (An n)) x (xn n)) -> { p : nat | forall n:nat, le p n -> partialApply (CharacFunc (An p)) x (xn p) = partialApply (CharacFunc (An n)) x (xn n) }. Proof. intros. destruct (H 2%positive) as [p pcv]. auto. exists p. intros. simpl. simpl in pcv. specialize (pcv p n (Nat.le_refl _) H0). assert (CR_of_Q R (1 # 2) < 1). { apply CR_of_Q_lt. reflexivity. } destruct (xn p), (xn n). reflexivity. 3: reflexivity. - exfalso. unfold CRminus in pcv. rewrite CRopp_0, CRplus_0_r, CRabs_right in pcv. contradiction. apply CRlt_asym, CRzero_lt_one. - exfalso. unfold CRminus in pcv. rewrite CRplus_0_l, CRabs_opp, CRabs_right in pcv. contradiction. apply CRlt_asym, CRzero_lt_one. Qed. Definition IntegrableSetCountableUnion {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (AnInt : forall n:nat, IntegrableSet (An n)) (a : CRcarrier (RealT (ElemFunc IS))) : CR_cv _ (fun n => MeasureSet (IntegrableSetUnionIterate An AnInt n)) a -> { intUnion : IntegrableSet (fun x => exists n:nat, An n x) | MeasureSet intUnion == a }. Proof. intros. destruct (IntegralMonotoneConvergence IS _ (IntegrableSetUnionIterate An AnInt) a) as [[i restr] cv]. - intros n x xdf xdg. simpl. clear H. destruct xdf, xdg. apply CRle_refl. exfalso. apply n0. left. exact u. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. - apply H. - assert (PartialRestriction (XinfiniteSumAbs (IntFn i)) (CharacFunc (fun x => exists n:nat, An n x))) as H0. apply (PartialRestriction_trans (X (ElemFunc IS)) _ (XpointwiseLimit (fun n : nat => CharacFunc (UnionIterate An n)))). split. apply restr. apply restr. clear i restr cv. split. + intros x xdf. simpl. destruct xdf as [xn xncv]. apply CharacFuncStationary in xncv. destruct xncv as [p pcv]. simpl in pcv. destruct (xn p). left. apply applyUnionIterate in u. destruct u. exists x0. apply H0. right. intros [k abs]. destruct (le_lt_dec p k). specialize (pcv k l). destruct (xn k). pose proof CRzero_lt_one. specialize (X (RealT (ElemFunc IS))). rewrite pcv in X. exact (CRlt_asym _ _ X X). destruct k. contradiction. simpl in n0. apply n0. right. exact abs. apply n. apply applyUnionIterate. exists k. split. unfold lt in l. apply (Nat.le_trans _ (S k)). apply le_S, Nat.le_refl. exact l. exact abs. + intros. apply applyPointwiseLimit. simpl. destruct xD as [xn xcv]. destruct xG. simpl in xn. destruct (constructive_indefinite_ground_description_nat (fun n => (if xn n then 1 else 0) == CR_of_Q (RealT (ElemFunc IS)) 1)) as [n ncv]. intro n. destruct (xn n). left. reflexivity. right. intros [abs _]. apply abs, CRzero_lt_one. destruct e as [n ncv]. exists n. destruct (xn n). reflexivity. exfalso. destruct n. contradiction. apply n0. right. exact ncv. exists n. intros. destruct (xn i). unfold CRminus. rewrite CRplus_opp_r, CRabs_right. 2: apply CRle_refl. apply CR_of_Q_le; discriminate. exfalso. apply n0. apply applyUnionIterate. exists n. split. exact H0. destruct (xn n). exfalso. apply n0. apply applyUnionIterate in u. destruct u. apply applyUnionIterate. exists x0. split. apply (Nat.le_trans _ n). apply H1. exact H0. apply H1. exfalso. destruct ncv. apply H1, CRzero_lt_one. exists O. intros n0 _. destruct (xn n0). exfalso. apply n. apply applyUnionIterate in u. destruct u. exists x0. apply H0. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le; discriminate. apply CRle_refl. + exists (existT _ i H0). exact cv. Defined. Definition IntegrableSetCountableIntersect {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (AnInt : forall n:nat, IntegrableSet (An n)) (a : CRcarrier (RealT (ElemFunc IS))) : CR_cv _ (fun n => MeasureSet (IntegrableSetIntersectIterate An AnInt n)) a -> { intIntersect : IntegrableSet (fun x => forall n:nat, An n x) | MeasureSet intIntersect == a }. Proof. intros. destruct (IntegralMonotoneConvergenceDecr IS _ (IntegrableSetIntersectIterate An AnInt) a) as [[i restr] cv]. - intros n x xdf xdg. simpl. clear H. destruct xdf, xdg. apply CRle_refl. exfalso. apply n0. apply i. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. - apply H. - assert (PartialRestriction (XinfiniteSumAbs (IntFn i)) (CharacFunc (fun x => forall n:nat, An n x))) as H0. apply (PartialRestriction_trans (X (ElemFunc IS)) _ (XpointwiseLimit (fun n : nat => CharacFunc (IntersectIterate An n)))). split. apply restr. apply restr. clear i restr cv. split. + intros x xdf. simpl. destruct xdf as [xn xncv]. apply CharacFuncStationary in xncv. destruct xncv as [p pcv]. simpl in pcv. destruct (xn p). left. intros. destruct (le_lt_dec p n). specialize (pcv n l). destruct (xn n). rewrite applyIntersectIterate in i0. apply i0, Nat.le_refl. exfalso. symmetry in pcv. pose proof CRzero_lt_one. specialize (X (RealT (ElemFunc IS))) as H0. rewrite pcv in H0. exact (CRlt_asym _ _ H0 H0). rewrite applyIntersectIterate in i. apply i. apply (Nat.le_trans _ (S n)). apply le_S, Nat.le_refl. exact l. right. intro abs. apply n. rewrite applyIntersectIterate. intros. apply abs. + intros. apply applyPointwiseLimit. simpl. destruct xD as [xn xcv]. destruct xG. exists O. intros n H0. destruct (xn n). unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le; discriminate. apply CRle_refl. exfalso. apply n0. rewrite applyIntersectIterate. intros. apply a0. apply CharacFuncStationary in xcv. destruct xcv as [p pcv]. exists p. intros. simpl in pcv. destruct (xn p). exfalso. (* if in all An above p and intersect p, means all n *) apply n. intros n1. destruct (le_lt_dec p n1). specialize (pcv n1 l). destruct (xn n1). rewrite applyIntersectIterate in i1. apply i1, Nat.le_refl. exfalso. symmetry in pcv. pose proof CRzero_lt_one. specialize (X (RealT (ElemFunc IS))). rewrite pcv in X. exact (CRlt_asym _ _ X X). rewrite applyIntersectIterate in i0. apply i0. apply (Nat.le_trans _ (S n1)). apply le_S, Nat.le_refl. exact l. (* So it is not in the intersection at p *) specialize (pcv i H0). destruct (xn i). exfalso. pose proof CRzero_lt_one. specialize (X (RealT (ElemFunc IS))). rewrite pcv in X. exact (CRlt_asym _ _ X X). unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le; discriminate. apply CRle_refl. + exists (existT _ i H0). exact cv. Defined. Lemma MeasureIntersectIncr : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop) (aInt : IntegrableSet A) (bInt : IntegrableSet B), MeasureSet (IntegrableSetIntersect A B aInt bInt) <= MeasureSet bInt. Proof. intros. apply MeasureNonDecreasing. intros. apply H. Qed. (* Integrable sets can serve as partial integration domains. Actually those domains can be enlarged to the measure sets, defined in a later file. This is proposition 4.2 of Bishop. *) Lemma growing_infinite : forall un : nat -> nat, (forall n:nat, lt (un n) (un (S n))) -> forall n : nat, le n (un n). Proof. induction n. - apply Nat.le_0_l. - specialize (H n). unfold lt in H. apply (Nat.le_trans _ (S (un n))). apply le_n_S, IHn. exact H. Qed. Lemma SliceBar : forall {R : ConstructiveReals} {X : Set} (x : CRcarrier R) (nk : nat -> nat), (forall n:nat, lt (nk n) (nk (S n))) -> nk O = O -> 0 <= x -> series_cv (fun n : nat => CRmin (INR (nk (S n) - nk n)) (x - CRmin x (INR (nk n)))) x. Proof. intros. assert (forall k:nat, CRsum (fun n : nat => CRmin (INR (nk (S n) - nk n)) (x - CRmin x (INR (nk n)))) k == CRmin x (INR (nk (S k)))). { induction k. - intros. simpl. rewrite (CRmin_right x (INR (nk 0%nat))). rewrite H0. rewrite CRmin_sym. rewrite Nat.sub_0_r. setoid_replace (x - INR 0) with x. reflexivity. unfold INR. simpl. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. rewrite H0. unfold INR. apply H1. - intros. simpl. rewrite IHk. clear IHk. rewrite CRmin_plus. setoid_replace (CRmin x (INR (nk (S k))) + (x - CRmin x (INR (nk (S k))))) with x. rewrite CRmin_sym, CRplus_comm, CRmin_plus. setoid_replace (@INR R (nk (S (S k)) - nk (S k)) + INR (nk (S k))) with (@INR R (nk (S (S k)))). rewrite CRmin_assoc. rewrite (CRmin_left x). reflexivity. apply (CRle_trans _ (0+x)). rewrite CRplus_0_l. apply CRle_refl. apply CRplus_le_compat. apply CR_of_Q_le. unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. apply CRle_refl. unfold INR. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. rewrite <- Nat2Z.inj_add. rewrite Nat.sub_add. reflexivity. specialize (H (S k)). apply (Nat.le_trans _ (S (nk (S k)))). apply le_S, Nat.le_refl. apply H. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. } destruct (CRup_nat x) as [n nmaj]. exists n. intros. rewrite H2. rewrite CRmin_left. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. apply (CRle_trans _ (INR n)). apply CRlt_asym, nmaj. apply CR_of_Q_le. unfold Qle; simpl. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le. apply (Nat.le_trans _ _ _ H3). apply (Nat.le_trans _ (S i)). apply le_S, Nat.le_refl. apply growing_infinite. exact H. Qed. Lemma SliceNonNegFunc : forall {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) (A : X -> Prop) (nk : nat -> nat), (forall n:nat, lt (nk n) (nk (S n))) -> nk O = O -> nonNegFunc f -> PartialRestriction (XinfiniteSumAbs (fun k : nat => Xmin (Xscale (INR (nk (S k) - nk k)) (CharacFunc A)) (Xminus f (XminConst f (INR (nk k)))))) (Xmult (CharacFunc A) f). Proof. split. - intros x [xn _]. specialize (xn O). destruct f, xn, d0, d0; split. exact d0. apply d. - intros. apply applyInfiniteSumAbs. assert (forall n:nat, Domain (Xscale (INR (nk (S n) - nk n)) (@CharacFunc R _ A)) x) as H2. { intro n. apply (domainInfiniteSumAbsIncReverse _ _ xD n). } assert (forall n:nat, Domain (Xminus f (XminConst f (INR (nk n)))) x) as H3. { intro n. apply (domainInfiniteSumAbsIncReverse _ _ xD n). } destruct xG. destruct d as [inA | notInA]. + (* Inside of A, prove convergence towards f x *) assert (Domain f x) as H4. { specialize (H3 O). apply H3. } apply (series_cv_eq (fun n : nat => CRmin (INR (nk (S n) - nk n)) (partialApply f x H4 - CRmin (partialApply f x H4) (INR (nk n))))). intro n. rewrite (applyXmin _ _ x (H2 n) (H3 n)). apply CRmin_morph. rewrite applyXscale. rewrite (DomainProp (CharacFunc A) x _ (left inA)). unfold CharacFunc, partialApply. rewrite CRmult_1_r. reflexivity. destruct (H3 n). rewrite (applyXminus f (XminConst f (INR (nk n)))). apply CRplus_morph. apply DomainProp. apply CRopp_morph. rewrite applyXminConst. apply CRmin_morph. apply DomainProp. reflexivity. setoid_replace (partialApply (Xmult (CharacFunc A) f) x (left inA, d0)) with (partialApply f x H4). apply (@SliceBar R X). exact H. exact H0. apply H1. destruct f; simpl. rewrite CRmult_1_l. apply DomainProp. + (* Outside of A we have 0 == 0 *) apply (series_cv_eq (fun _ => 0)). intro n. rewrite (applyXmin _ _ x (H2 n) (H3 n)), CRmin_left. rewrite applyXscale. rewrite (DomainProp (CharacFunc A) x _ (right notInA)). unfold CharacFunc, partialApply. rewrite CRmult_0_r. reflexivity. rewrite applyXscale. rewrite (DomainProp (CharacFunc A) x _ (right notInA)). apply (CRle_trans _ 0). unfold CharacFunc, partialApply. rewrite CRmult_0_r. apply CRle_refl. destruct (H3 n). rewrite (applyXminus f (XminConst f (INR (nk n)))). apply CRle_minus. rewrite applyXminConst. rewrite (DomainProp f x d1 d). apply CRmin_l. setoid_replace (partialApply (Xmult (CharacFunc A) f) x (right notInA, d0)) with (CR_of_Q R 0). intro p. exists O. intros. rewrite sum_const, CRmult_0_l. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. clear xD. destruct f; simpl. apply CRmult_0_l. Qed. (* Add zero before sequence un, if it does not already start with zero. *) Definition StartZero (un : nat -> nat) (n : nat) := match n with | O => O | S p => match un O with | O => un (S p) | S _ => un p end end. Lemma StartZeroInc : forall (un : nat -> nat), (forall n:nat, lt (un n) (un (S n))) -> (forall n:nat, lt (StartZero un n) (StartZero un (S n))). Proof. intros. destruct n. - simpl. destruct (un O) eqn:des. apply (Nat.le_lt_trans _ (un O)). apply Nat.le_0_l. apply H. apply le_n_S, Nat.le_0_l. - simpl. destruct (un O); apply H. Qed. Definition RestrictedIntegralNonneg {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (A : (X (ElemFunc IS)) -> Prop) : IntegrableFunction f -> nonNegFunc f -> IntegrableSet A -> IntegrableFunction (Xmult (CharacFunc A) f). Proof. intros fInt fNonNeg AInt. assert (forall k : nat, 0 < CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) k) as boundPos. { intro k. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. } pose (StartZero (fun n => let (p,_) := ControlSubSeqCv _ _ (CRpow (CR_of_Q _ (1#2))) (IntegralTruncateLimit f fInt) boundPos n in p)) as nk. (* Cut f's non-negative graph horizontally, according to the nk *) pose (fun k:nat => Xmin (Xscale (INR (nk (S k) - nk k)) (CharacFunc A)) (Xminus f (XminConst f (INR (nk k))))) as fk. pose (fun k:nat => IntegrableMinus fInt (IntegrableMinInt _ (nk k) fInt)) as fTopkInt. assert (forall k, IntegrableFunction (fk k)) as fkInt. { intro k. apply IntegrableMin. apply IntegrableScale, AInt. apply fTopkInt. } (* Majorate the series by the right-hand term of the minimum, which is itself lower than 2^k, a convergent series. *) destruct (series_cv_maj (fun n => Integral (IntegrableAbs (fkInt (S O + n)%nat))) (CRpow (CR_of_Q _ (1#2))) (CR_of_Q _ 2)) as [l llim]. 2: exact GeoHalfTwo. - intro n. rewrite CRabs_right. apply (CRle_trans _ (Integral (fTopkInt (S n)))). apply IntegralNonDecreasing. intros x xdf xdg. rewrite applyXabs. assert (Domain (Xscale (INR (nk (S (S n)) - nk (S n))) (@CharacFunc (RealT (ElemFunc IS)) _ A)) x) as H. { destruct xdf. apply d0. } rewrite CRabs_right. unfold fk. rewrite (applyXmin _ _ x H xdg). apply CRmin_r. unfold fk. rewrite (applyXmin _ _ x H xdg). apply CRmin_glb. rewrite applyXscale. rewrite <- (CRmult_0_r (INR (nk (S (S n)) - nk (S n)))). apply CRmult_le_compat_l. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. simpl. destruct H. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. destruct xdg. rewrite (applyXminus f (XminConst f (INR (nk (S n))))). apply CRle_minus. rewrite applyXminConst. rewrite (DomainProp f x d0 d). apply CRmin_l. unfold fTopkInt. rewrite IntegralMinus. unfold nk, StartZero. destruct (ControlSubSeqCv (fun n0 : nat => Integral (IntegrableMinInt f n0 fInt)) (Integral fInt) (CRpow (CR_of_Q _ (1 # 2))) (IntegralTruncateLimit f fInt) boundPos 0), x. destruct (ControlSubSeqCv (fun n0 : nat => Integral (IntegrableMinInt f n0 fInt)) (Integral fInt) (CRpow (CR_of_Q _ (1 # 2))) (IntegralTruncateLimit f fInt) boundPos (S n)). rewrite CRabs_minus_sym in c0. apply (CRle_trans _ _ _ (CRle_abs _)). apply (CRle_trans _ (CRpow (CR_of_Q _ (1 # 2)) (S n))). apply CRlt_asym, c0. apply (CRmult_le_reg_l (CRpow (CR_of_Q _ 2) (S n))). apply CRpow_gt_zero. apply CR_of_Q_lt. reflexivity. rewrite CRpow_mult. rewrite (CRpow_proper _ 1), CRpow_one. replace (CRpow (CR_of_Q _ 2) (S n)) with (CR_of_Q (RealT (ElemFunc IS)) 2 * CRpow (CR_of_Q _ 2) n). 2: reflexivity. rewrite CRmult_assoc, CRpow_mult. rewrite (CRpow_proper _ 1), CRpow_one. rewrite CRmult_1_r. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. reflexivity. reflexivity. rewrite <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. reflexivity. reflexivity. destruct (ControlSubSeqCv (fun n0 : nat => Integral (IntegrableMinInt f n0 fInt)) (Integral fInt) (CRpow (CR_of_Q _ (1 # 2))) (IntegralTruncateLimit f fInt) boundPos n). rewrite CRabs_minus_sym in c0. apply (CRle_trans _ _ _ (CRle_abs _)). apply CRlt_asym, c0. apply IntegralNonNeg. intros x xdf. rewrite applyXabs. apply CRabs_pos. - destruct (IntegrableFunctionsComplete IS fk fkInt (l+Integral (IntegrableAbs (fkInt O)))). destruct llim. apply (series_cv_shift (fun n : nat => Integral (IntegrableAbs (fkInt n))) O) in s. exact s. exists x. apply (PartialRestriction_trans _ _ (XinfiniteSumAbs fk)). apply p. clear p x llim l. apply (SliceNonNegFunc f A nk). apply StartZeroInc. apply ControlSubSeqCvInc. reflexivity. exact fNonNeg. Qed. Definition RestrictedIntegrable {IS : IntegrationSpace} {f : PartialFunction (X (ElemFunc IS))} {A : (X (ElemFunc IS)) -> Prop} : IntegrableFunction f -> IntegrableSet A -> IntegrableFunction (Xmult (CharacFunc A) f). Proof. intros. apply (IntegrableFunctionExtensional (Xminus (Xmult (CharacFunc A) (XposPart f)) (Xmult (CharacFunc A) (XnegPart f)))). split. - intros x xdf. destruct f; split; apply xdf. - intros. destruct xG, xD. rewrite (applyXmult (CharacFunc A) f). rewrite (applyXminus (Xmult (CharacFunc A) (XposPart f)) (Xmult (CharacFunc A) (XnegPart f))). unfold CRminus. destruct d1, d2. rewrite (applyXmult (CharacFunc A) (XposPart f)). rewrite (applyXmult (CharacFunc A) (XnegPart f)). rewrite (DomainProp _ x d2 d1), (DomainProp _ x d4 d3). rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. apply CRmult_morph. apply DomainProp. apply SplitPosNegParts. - apply IntegrableMinus. apply RestrictedIntegralNonneg. apply IntegrablePosPart, X. apply applyXposPartNonNeg. exact X0. apply RestrictedIntegralNonneg. apply IntegrableNegPart, X. apply XnegPartNonNeg. exact X0. Qed. Definition RestrictedIntegral {IS : IntegrationSpace} {f : PartialFunction (X (ElemFunc IS))} {A : (X (ElemFunc IS)) -> Prop} (fInt : IntegrableFunction f) (aInt : IntegrableSet A) := Integral (RestrictedIntegrable fInt aInt). (* A variant for the countable union, that allows redundancies in the sum. *) Definition IntegrableSetCountableUnionLe {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (AnInt : forall n:nat, IntegrableSet (An n)) (a : CRcarrier (RealT (ElemFunc IS))) : series_cv (fun n => MeasureSet (AnInt n)) a -> { intUnion : IntegrableSet (fun x => exists n:nat, An n x) | MeasureSet intUnion <= a }. Proof. intros. pose (fun n:nat => match n with | O => MeasureSet (AnInt O) | S p => MeasureSet (IntegrableSetUnionIterate An AnInt n) - MeasureSet (IntegrableSetUnionIterate An AnInt p) end) as incrMes. destruct (series_cv_maj incrMes (fun n => MeasureSet (AnInt n)) a) as [l [lcv lle]]. 2: exact H. - intro n. unfold incrMes. destruct n. + rewrite CRabs_right. apply CRle_refl. apply MeasureNonNeg. + rewrite <- MeasureDifferenceIncluded. rewrite CRabs_right. 2: apply MeasureNonNeg. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg. apply CRle_refl. 3: apply CRle_refl. 2: apply CRlt_asym, CRzero_lt_one. exfalso. destruct a0. destruct H0; contradiction. intros. left. exact H0. - destruct (IntegrableSetCountableUnion An AnInt l). + apply (CR_cv_eq _ (CRsum incrMes)). 2: exact lcv. induction n. reflexivity. simpl. rewrite IHn. clear IHn. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + exists x. rewrite c. exact lle. Qed. corn-8.20.0/reals/stdlib/CMTMeasurableFunctions.v000066400000000000000000002763211473720167500216640ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) From Coq Require Import ZArith QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Require Import ConstructivePartialFunctions. Require Import CMTbase. Require Import CMTIntegrableFunctions. Require Import CMTFullSets. Require Import CMTIntegrableSets. Require Import CMTprofile. Local Open Scope ConstructiveReals. (* A function f is measurable when it is integrable on any integrable rectangle A * [-k,k]. *) Definition MeasurableFunction {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) : Type := forall (A : (X (ElemFunc IS)) -> Prop) (k : positive), IntegrableSet A -> IntegrableFunction (XmaxConst (XminConst (Xmult (CharacFunc A) f) (CR_of_Q _ (Z.pos k # 1))) (CR_of_Q _ (Z.neg k # 1))). Lemma MeasurableFunctionExtensional : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))), PartialRestriction f g -> MeasurableFunction f -> MeasurableFunction g. Proof. intros IS f g [d c] fMes A k Aint. apply (IntegrableFunctionExtensional (XmaxConst (XminConst (Xmult (CharacFunc A) f) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1)))). 2: exact (fMes A k Aint). split. - intros x xdf. simpl in xdf. destruct xdf. split. exact s. exact (d x d0). - intros. simpl. destruct xD, xG. rewrite (c x d1 (d x d1)), (DomainProp g x (d x d1) d3). destruct d0. destruct d2. reflexivity. contradiction. destruct d2. contradiction. reflexivity. Qed. Lemma MeasurableFunctionFull : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))), MeasurableFunction f -> almost_everywhere (Domain f). Proof. intros IS f fMes. destruct (@PositiveMeasureSubsetExists IS) as [A Aint Apos]. specialize (fMes A 1%positive Aint). exists (XmaxConst (XminConst (Xmult (CharacFunc A) f) (CR_of_Q (RealT (ElemFunc IS)) 1)) (CR_of_Q (RealT (ElemFunc IS)) (-1))). split. exact fMes. intros x xD. apply xD. Qed. Lemma IntegrableMeasurable : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))), IntegrableFunction f -> MeasurableFunction f. Proof. intros IS f fInt A k Aint. apply IntegrableMaxConst. apply IntegrableMinConst. exact (RestrictedIntegrable fInt Aint). apply CR_of_Q_pos. reflexivity. apply (CRlt_le_trans _ (CR_of_Q _ 0)). apply CR_of_Q_lt. reflexivity. apply CRle_refl. Qed. Lemma MeasurableConst : forall {IS : IntegrationSpace} (a : CRcarrier (RealT (ElemFunc IS))), MeasurableFunction (Xconst (X (ElemFunc IS)) a). Proof. intros IS a A k Aint. apply IntegrableMaxConst. apply IntegrableMinConst. apply (IntegrableFunctionExtensional (Xscale a (CharacFunc A))). - split. intros x xdf. split. exact xdf. simpl. trivial. intros. simpl. destruct xG. destruct xD. destruct d. apply CRmult_comm. contradiction. destruct d. contradiction. apply CRmult_comm. - apply IntegrableScale, Aint. - apply CR_of_Q_lt. reflexivity. - apply CR_of_Q_lt. reflexivity. Qed. Definition MeasurableSet {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop) : Type := MeasurableFunction (CharacFunc A). Lemma MeasurableSetEquiv : forall {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop), prod (MeasurableSet A -> (forall B : (X (ElemFunc IS)) -> Prop, IntegrableSet B -> IntegrableFunction (Xmult (CharacFunc A) (CharacFunc B)))) ((forall B : (X (ElemFunc IS)) -> Prop, IntegrableSet B -> IntegrableFunction (Xmult (CharacFunc A) (CharacFunc B))) -> MeasurableSet A). Proof. intros IS A. assert (forall B x xD xG k, partialApply (Xmult (CharacFunc A) (CharacFunc B)) x xD == partialApply (XmaxConst (XminConst (Xmult (CharacFunc B) (CharacFunc A)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))) x xG). { intros. rewrite applyXmaxConst, CRmax_left. rewrite applyXminConst, CRmin_left. destruct xD, xG. simpl. destruct d. destruct d2. 2: contradiction. destruct d0. destruct d1. 2: contradiction. reflexivity. destruct d1. contradiction. apply CRmult_comm. rewrite CRmult_0_l. destruct d2. contradiction. rewrite CRmult_0_r. reflexivity. apply (CRle_trans _ 1). simpl. destruct xG. destruct d. destruct d0. rewrite CRmult_1_l. apply CRle_refl. rewrite CRmult_1_l. apply CRlt_asym, CRzero_lt_one. rewrite CRmult_0_l. apply CRlt_asym, CRzero_lt_one. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_r. destruct k; discriminate. apply (CRle_trans _ 0). apply CR_of_Q_le. discriminate. apply CRmin_glb. simpl. destruct xG, d. rewrite CRmult_1_l. destruct d0. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. rewrite CRmult_0_l. apply CRle_refl. apply CR_of_Q_le. discriminate. } split. - intros Ames B Bint. specialize (Ames B 1%positive Bint). refine (IntegrableFunctionExtensional _ _ _ Ames). split. + intros x xdf. destruct xdf. split. exact d0. exact d. + intros x xD xG. symmetry. apply H. - intros H0 B k Bint. specialize (H0 B Bint). refine (IntegrableFunctionExtensional _ _ _ H0). split. + intros x xdf. destruct xdf. split. exact d0. exact d. + intros x xD xG. apply H. Qed. Lemma IntegrableMeasurableSet : forall {IS : IntegrationSpace} (A : X (ElemFunc IS) -> Prop), IntegrableSet A -> MeasurableSet A. Proof. intros IS A Aint B k Bint. apply IntegrableMaxConst. apply IntegrableMinConst. apply (IntegrableExtensionalAE (CharacFunc (fun x => B x /\ A x))). - exists (Xplus (CharacFunc A) (CharacFunc B)). split. exact (IntegrablePlus _ _ Aint Bint). intros. split. apply H. apply H. - exists (CharacFunc A). split. exact Aint. intros. simpl. destruct dG. clear H. destruct d0. + (* In a *) rewrite CRmult_1_r. destruct d, dF. reflexivity. contradict n. split; assumption. destruct a0. contradiction. reflexivity. + (* Not in a *) rewrite CRmult_0_r. destruct dF. destruct a. contradiction. reflexivity. - exact (IntegrableSetIntersect _ _ Bint Aint). - apply CR_of_Q_pos. reflexivity. - apply (CRlt_le_trans _ (CR_of_Q _ 0)). apply CR_of_Q_lt. reflexivity. apply CRle_refl. Qed. (* In finite integration spaces, like probability spaces, measurable is equivalent to integrable. *) Lemma MeasurableIntegrableSubset : forall {IS : IntegrationSpace} (A B : X (ElemFunc IS) -> Prop), IntegrableSet B -> MeasurableSet A -> (forall x : X (ElemFunc IS), A x -> B x) -> IntegrableSet A. Proof. intros IS A B Bint Ames incl. specialize (Ames B 1%positive Bint). refine (IntegrableFunctionExtensional _ _ _ Ames). split. - intros x xdf. exact (snd xdf). - intros. destruct xG. + (* in A *) simpl. destruct xD. destruct d. 2: contradict n; exact (incl x a). destruct d0. rewrite CRmult_1_l, CRmin_left, CRmax_left. reflexivity. apply CR_of_Q_le. discriminate. apply CRle_refl. contradiction. + (* not in A *) simpl. destruct xD. destruct d0. contradiction. rewrite CRmult_0_r, CRmin_left, CRmax_left. reflexivity. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. Qed. Lemma TruncOpp : forall {R : ConstructiveReals} (x : CRcarrier R) (k : positive), - CRmax (CRmin x (CR_of_Q _ (Z.pos k # 1))) (CR_of_Q _ (Z.neg k # 1)) == CRmax (CRmin (-x) (CR_of_Q _ (Z.pos k # 1))) (CR_of_Q _ (Z.neg k # 1)). Proof. intros. destruct (CRltLinear R). setoid_replace (-x) with (-(1) * x). destruct (s (CR_of_Q R (Z.neg k # 1)) x 0). apply CR_of_Q_lt. reflexivity. rewrite CRmax_left, (CRmin_left (- (1) * x)). - setoid_replace (CR_of_Q R (Z.neg k # 1)) with (-(1) * CR_of_Q R (Z.pos k # 1)). rewrite CRmax_min_mult_neg. rewrite <- CRopp_mult_distr_l. rewrite CRmult_1_l. reflexivity. apply (CRplus_le_reg_l 1). rewrite CRplus_opp_r, CRplus_0_r. apply CRlt_asym, CRzero_lt_one. rewrite <- CRopp_mult_distr_l, CRmult_1_l, <- CR_of_Q_opp. apply CR_of_Q_morph. reflexivity. - rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- (CRopp_involutive (CR_of_Q R (Z.pos k # 1))). apply CRopp_ge_le_contravar. rewrite <- CR_of_Q_opp. apply (CRle_trans _ (CR_of_Q R (Z.neg k # 1))). apply CR_of_Q_le. apply Qle_refl. apply CRlt_asym, c. - apply CRmin_glb. apply CRlt_asym, c. apply CR_of_Q_le. discriminate. - rewrite CRmin_left, (CRmax_left (CRmin (- (1) * x) (CR_of_Q R (Z.pos k # 1)))). setoid_replace (CR_of_Q R (Z.pos k # 1)) with (-(1) * CR_of_Q R (Z.neg k # 1)). rewrite CRmin_max_mult_neg, <- CRopp_mult_distr_l, CRmult_1_l. reflexivity. apply (CRplus_le_reg_l 1). rewrite CRplus_opp_r, CRplus_0_r. apply CRlt_asym, CRzero_lt_one. rewrite <- CRopp_mult_distr_l, CRmult_1_l, <- CR_of_Q_opp. apply CR_of_Q_morph. reflexivity. apply CRmin_glb. apply (CRle_trans _ 0). apply CR_of_Q_le. discriminate. rewrite <- CRopp_mult_distr_l, CRmult_1_l, <- CRopp_0. apply CRopp_ge_le_contravar, CRlt_asym, c. apply CR_of_Q_le. discriminate. apply (CRle_trans _ 0). apply CRlt_asym, c. apply CR_of_Q_le. discriminate. - rewrite <- CRopp_mult_distr_l, CRmult_1_l. reflexivity. Qed. Lemma TruncPosNeg : forall {R : ConstructiveReals} (y : CRcarrier R) (k : positive), CRmax (CRmin (CRmax 0 y) (CR_of_Q R (Z.pos k # 1))) (CR_of_Q R (Z.neg k # 1)) + CRmax (CRmin (CRmin 0 y) (CR_of_Q R (Z.pos k # 1))) (CR_of_Q R (Z.neg k # 1)) == CRmax (CRmin y (CR_of_Q R (Z.pos k # 1))) (CR_of_Q R (Z.neg k # 1)). Proof. intros. rewrite (CRmax_left (CRmin (CRmax 0 y) (CR_of_Q R (Z.pos k # 1)))). rewrite (CRmin_left (CRmin 0 y)). - destruct (CRltLinear R). destruct (s (CR_of_Q R (Z.neg k # 1)) y 0). + apply CR_of_Q_lt. reflexivity. + rewrite (CRmax_left (CRmin y (CR_of_Q R (Z.pos k # 1)))). rewrite (CRmax_left (CRmin 0 y)). destruct (s 0 y (CR_of_Q R (Z.pos k # 1))). apply CR_of_Q_lt. reflexivity. rewrite CRmax_right, (CRmin_left 0 y). rewrite CRplus_0_r. reflexivity. apply CRlt_asym, c0. apply CRlt_asym, c0. rewrite (CRmin_left y), CRmin_left. unfold CRmax, CRmin. rewrite CRplus_0_l, <- CRmult_plus_distr_r. unfold CRminus. rewrite CRplus_assoc, <- (CRplus_comm (- CRabs R (y + - 0))). rewrite <- (CRplus_assoc (CRabs R (y + - 0))), CRplus_opp_r, CRplus_0_l. apply (CRmult_eq_reg_r (CR_of_Q R 2)). left. apply CR_of_Q_lt. reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_r, CRmult_plus_distr_l. rewrite CRmult_1_r. reflexivity. apply CRmax_lub. apply CR_of_Q_le. discriminate. apply CRlt_asym, c0. apply CRlt_asym, c0. apply CRmin_glb. apply CR_of_Q_le. discriminate. apply CRlt_asym, c. apply CRmin_glb. apply CRlt_asym, c. apply CR_of_Q_le. discriminate. + rewrite (CRmax_left 0 y). rewrite (CRmin_right 0 y). rewrite CRmin_left, CRplus_0_l. rewrite CRmin_left. reflexivity. apply (CRle_trans _ 0). apply CRlt_asym, c. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. apply CRlt_asym, c. apply CRlt_asym, c. - apply (CRle_trans _ 0). apply CRmin_l. apply CR_of_Q_le. discriminate. - apply CRmin_glb. apply (CRle_trans _ 0). apply CR_of_Q_le. discriminate. apply CRmax_l. apply CR_of_Q_le. discriminate. Qed. Definition MeasurablePosNegParts {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) : MeasurableFunction (XposPart f) -> MeasurableFunction (XnegPart f) -> MeasurableFunction f. Proof. intros fMes gMes A k Aint. apply (IntegrableFunctionExtensional (Xminus (XmaxConst (XminConst (Xmult (CharacFunc A) (XposPart f)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))) (XmaxConst (XminConst (Xmult (CharacFunc A) (XnegPart f)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))))). - split. intros x xdf. simpl. simpl in xdf. destruct xdf. split. apply p. apply p. intros. simpl. destruct xD, d, d0, d1, d2, xG. setoid_replace (if d5 then CR_of_Q (RealT (ElemFunc IS)) 1 else 0) with (if d then CR_of_Q (RealT (ElemFunc IS)) 1 else 0). setoid_replace (if d0 then CR_of_Q (RealT (ElemFunc IS)) 1 else 0) with (if d then CR_of_Q (RealT (ElemFunc IS)) 1 else 0). destruct d. + rewrite CRmult_1_l, CRmult_1_l, CRmult_1_l. rewrite (DomainProp f x d6 d1), (DomainProp f x d4 d1), (DomainProp f x d2 d1), (DomainProp f x d3 d1). clear d6 d4 d3 d2. generalize (partialApply f x d1). intro y. rewrite (CRmult_comm (CR_of_Q (RealT (ElemFunc IS)) (1 # 2))). rewrite <- CRposPartAbsMax. rewrite (CRmult_comm (CR_of_Q (RealT (ElemFunc IS)) (1 # 2))). do 2 rewrite <- CRopp_mult_distr_l. do 2 rewrite CRmult_1_l. rewrite TruncOpp, CRopp_mult_distr_l, CRopp_plus_distr. rewrite CRopp_involutive, <- (CRplus_comm y). pose proof (CRnegPartAbsMin y). unfold CRminus in H. rewrite <- H. clear H. apply TruncPosNeg. + rewrite CRmult_0_l, CRmult_0_l, CRmult_0_l. rewrite CRmin_left, CRmax_left, CRplus_0_l, CRmult_0_r. reflexivity. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. + destruct d0. destruct d. reflexivity. contradiction. destruct d. contradiction. reflexivity. + destruct d5. destruct d. reflexivity. contradiction. destruct d. contradiction. reflexivity. - apply IntegrableMinus. apply fMes, Aint. apply gMes, Aint. Qed. Lemma CR_cv_max : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (l a : CRcarrier R), CR_cv R un l -> CR_cv R (fun n : nat => CRmax (un n) a) (CRmax l a). Proof. intros. intro p. specialize (H p) as [n H]. exists n. intros. apply (CRle_trans _ _ _ (CRmax_contract _ _ a)). exact (H i H0). Qed. Lemma CR_cv_min : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (l a : CRcarrier R), CR_cv R un l -> CR_cv R (fun n : nat => CRmin (un n) a) (CRmin l a). Proof. intros. intro p. specialize (H p) as [n H]. exists n. intros. apply (CRle_trans _ _ _ (CRmin_contract _ _ a)). exact (H i H0). Qed. Lemma MeasurableSetCompl : forall {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop), MeasurableSet A -> MeasurableSet (fun x => ~A x). Proof. intros IS A Ameas. apply MeasurableSetEquiv. intros B Bint. destruct (MeasurableSetEquiv A) as [H _]. specialize (H Ameas B Bint). refine (IntegrableFunctionExtensional _ _ _ (IntegrableMinus Bint H)). split. - intros x. simpl. intros. destruct H0, p. split. destruct s0. right. intro abs. contradiction. left. exact n. exact s. - intros. destruct xD, d. + (* In B *) simpl. destruct d0. destruct d0. 2: contradiction. destruct xG. destruct d1. 2: contradiction. destruct d. destruct d0. contradiction. rewrite CRmult_1_r, CRmult_1_r, CRmult_1_r. apply CRplus_opp_r. destruct d0. 2: contradiction. rewrite CRmult_0_l, CRmult_0_r. rewrite CRmult_1_l, CRplus_0_r. reflexivity. + (* Not in B *) simpl. destruct xG. destruct d0. destruct d2. contradiction. destruct d1. contradiction. rewrite CRmult_0_r, CRmult_0_r, CRmult_0_r. apply CRplus_0_l. Qed. Lemma MeasurableIntersectIntegrable : forall {IS : IntegrationSpace} {A B : (X (ElemFunc IS)) -> Prop}, MeasurableSet A -> IntegrableSet B -> IntegrableSet (fun x => A x /\ B x). Proof. intros IS A B Ames Bint. pose proof (MeasurableSetEquiv A) as [Aint _]. specialize (Aint Ames B Bint). refine (IntegrableFunctionExtensional _ _ _ Aint). split. - intros x [d d0]. destruct d, d0. left. split; assumption. right. intros [_ abs]. contradiction. right. intros [abs _]. contradiction. right. intros [abs _]. contradiction. - intros. simpl. destruct xD. destruct d. destruct xG. destruct d0. apply CRmult_1_r. destruct a0; contradiction. destruct d0. contradict n. split; assumption. apply CRmult_0_r. rewrite CRmult_0_l. destruct xG. destruct a; contradiction. reflexivity. Qed. Lemma MeasurableSetUnion : forall {IS : IntegrationSpace} (A B : (X (ElemFunc IS)) -> Prop), MeasurableSet A -> MeasurableSet B -> MeasurableSet (fun x => A x \/ B x). Proof. intros IS A B Ameas Bmeas. apply MeasurableSetEquiv. intros C Cint. pose proof (MeasurableSetEquiv A) as [Aint _]. pose proof (MeasurableSetEquiv B) as [Bint _]. apply (IntegrableFunctionExtensional (Xminus (Xplus (Xmult (CharacFunc A) (CharacFunc C)) (Xmult (CharacFunc B) (CharacFunc C))) (Xmult (CharacFunc A) (CharacFunc (fun x => B x /\ C x))))). - split. + intros x. simpl. intros. destruct H, p, p. split. 2: exact s0. destruct s. left. left. exact a. destruct p1, s. left. right. exact b. right. intro abs. destruct abs; contradiction. + intros. destruct xD. rewrite (applyXminus (Xplus (Xmult (CharacFunc A) (CharacFunc C)) (Xmult (CharacFunc B) (CharacFunc C))) (Xmult (CharacFunc A) (CharacFunc (fun x0 : X (ElemFunc IS) => B x0 /\ C x0))) x d d0). destruct d. rewrite (applyXplus _ _ x d d1). destruct d. rewrite (applyXmult _ _ x d d2). destruct d1. rewrite (applyXmult _ _ x d1 d3). rewrite (DomainProp _ x d3 d2). clear d3. destruct d0. rewrite (applyXmult _ _ x d0 d3). rewrite (DomainProp _ x d0 d). clear d0. destruct xG. rewrite (applyXmult _ _ x d0 d4). rewrite (DomainProp _ x d4 d2). clear d4. simpl. destruct d2. rewrite CRmult_1_r, CRmult_1_r, CRmult_1_r. destruct d1. destruct d3. destruct d. destruct d0. rewrite CRmult_1_r. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r. apply CRplus_0_r. contradict n. left. exact a0. destruct d0. rewrite CRmult_0_l, CRplus_0_l. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. contradict n0. right. exact b. contradict n. split; assumption. destruct d3. destruct a; contradiction. rewrite CRmult_0_r. destruct d. destruct d0. rewrite CRplus_0_r. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. contradict n1. left. exact a. destruct d0. destruct o; contradiction. rewrite CRplus_0_l. apply CRplus_opp_r. destruct d3. destruct a. contradiction. rewrite CRmult_0_r, CRmult_0_r, CRmult_0_r, CRplus_0_l. apply CRplus_opp_r. - apply IntegrableMinus. apply IntegrablePlus. apply (Aint Ameas), Cint. apply (Bint Bmeas), Cint. apply (Aint Ameas). exact (MeasurableIntersectIntegrable Bmeas Cint). Qed. Definition MeasurableSetUnionIterate {IS : IntegrationSpace} (An : nat -> X (ElemFunc IS) -> Prop) (aInt : forall n:nat, MeasurableSet (An n)) : forall n:nat, MeasurableSet (UnionIterate An n). Proof. induction n. - apply aInt. - simpl. apply MeasurableSetUnion. apply IHn. apply aInt. Defined. Lemma MeasurableSetIntersection : forall {IS : IntegrationSpace} (A B : (X (ElemFunc IS)) -> Prop), MeasurableSet A -> MeasurableSet B -> MeasurableSet (fun x => A x /\ B x). Proof. intros IS A B Ameas Bmeas. apply MeasurableSetEquiv. intros C Cint. pose proof (MeasurableSetEquiv A) as [Aint _]. pose proof (MeasurableSetEquiv B) as [Bint _]. pose proof (MeasurableFunctionFull _ Bmeas) as Bfull. specialize (Aint Ameas). specialize (Bint Bmeas). apply (IntegrableExtensionalAE (Xmult (CharacFunc A) (CharacFunc (fun x => B x /\ C x)))). - destruct Bfull. exists (Xplus x (Xmult (CharacFunc A) (CharacFunc C))). split. apply IntegrablePlus. apply p. apply Aint. exact Cint. intros. destruct p, H, d1. specialize (d x0 d0). split. 2: exact d2. simpl. destruct d1. destruct d. 2: right; intros [H1 H0]; contradiction. left. split; assumption. right. intros [H H0]. contradiction. - exists (CharacFunc C). split. exact Cint. intros. simpl. destruct dF, dG. clear H. destruct d2. destruct d0. destruct d1. destruct d. reflexivity. destruct a0; contradiction. destruct d. contradict n. split. exact a0. apply a. reflexivity. rewrite CRmult_0_r. destruct d1. contradict n. split. apply a. exact c. rewrite CRmult_0_l. reflexivity. rewrite CRmult_0_r. destruct d0. destruct a; contradiction. apply CRmult_0_r. - apply Aint. apply (IntegrableFunctionExtensional (Xmult (CharacFunc B) (CharacFunc C))). split. intros x xdf. destruct xdf. destruct d. destruct d0. left. split; assumption. right. intro abs. destruct abs. contradiction. right. intro abs. destruct abs. contradiction. intros. 2: apply Bint; assumption. simpl. destruct xD. destruct d. destruct d0. destruct xG. apply CRmult_1_l. contradict n. split; assumption. destruct xG. destruct a; contradiction. apply CRmult_0_r. rewrite CRmult_0_l. destruct xG. destruct a; contradiction. reflexivity. Qed. Lemma Rcauchy_complete_cv : forall {R : ConstructiveReals } (un : nat -> CRcarrier R) (cau : CR_cauchy R un) (a : CRcarrier R), CR_cv R un a -> ((let (x,_) := CR_complete R un cau in x) == a)%ConstructiveReals. Proof. intros. destruct (CR_complete R un cau). exact (CR_cv_unique un _ _ c H). Qed. Lemma SigmaFiniteLimit : forall {R : ConstructiveReals} (A : CRcarrier R -> Prop), @PartialRestriction R _ (XpointwiseLimit (fun n => CharacFunc (fun x => -CR_of_Q R (Z.of_nat n # 1) <= x /\ x <= CR_of_Q R (Z.of_nat n # 1) /\ A x))) (CharacFunc A). Proof. split. - intros x [xnD H]. destruct (CRup_nat (CRabs _ x)) as [n H0]. apply CRabs_lt in H0. destruct H0. destruct (xnD n) as [isin|isout]. + left. apply isin. + right. intro abs. apply isout. repeat split. 3: exact abs. 2: apply CRlt_asym, c. rewrite <- (CRopp_involutive x). apply CRopp_ge_le_contravar. apply CRlt_asym, c0. - intros. simpl. destruct (CRup_nat (CRabs _ x)) as [n nup]. apply CRabs_lt in nup. destruct nup. destruct xD as [xnD H], xG. + (* in A *) unfold CharacFunc, Domain, inject_Z in xnD. unfold CharacFunc, partialApply in H. apply Rcauchy_complete_cv. intro p. exists n. intros. destruct (xnD i). unfold CRminus. rewrite CRplus_opp_r. rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. exfalso. apply n0. repeat split. 3: exact a. rewrite <- (CRopp_involutive x). apply CRopp_ge_le_contravar. apply (CRle_trans _ (CR_of_Q R (Z.of_nat n # 1))). apply CRlt_asym, c0. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, H0. apply (CRle_trans _ (CR_of_Q R (Z.of_nat n # 1))). apply CRlt_asym, c. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, H0. + (* not in A, constant sequence at 0. *) unfold CharacFunc, partialApply in H. apply Rcauchy_complete_cv. intro p. exists O. intros. destruct (xnD i). exfalso. destruct a, H2. contradiction. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. Qed. Lemma SigmaFiniteMonotone : forall {R : ConstructiveReals} (A : CRcarrier R -> Prop), let fn := fun n => @CharacFunc R _ (fun x => -CR_of_Q R (Z.of_nat n # 1) <= x /\ x <= CR_of_Q R (Z.of_nat n # 1) /\ A x) in forall n:nat, partialFuncLe (fn n) (fn (S n)). Proof. intros R A fn n x xdf xdg. simpl. destruct xdf. - destruct xdg. apply CRle_refl. exfalso. apply n0. destruct a, H0. repeat split. 3: exact H1. apply (CRle_trans _ (- CR_of_Q R (Z.of_nat n # 1))). apply CRopp_ge_le_contravar. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. exact H. apply (CRle_trans _ (CR_of_Q R (Z.of_nat n # 1)) _ H0). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. - destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. Qed. (* A classical hypothesis, to explain the relation with the classical Lebesgue measure. *) Definition IncrSeqCvT : Type := forall (R : ConstructiveReals) (un : nat -> CRcarrier R) (a : CRcarrier R), (forall n:nat, un n <= un (S n)) -> (forall n:nat, un n <= a) -> CR_cauchy R un. (* This proves that a Lebesgue-measurable function is Bishop-measurable, when we assume the classical theorem IncrSeqCvT. Because non-negative Lebesgue-measurable functions are non-decreasing limits of simple functions, which are Bishop-measurable. *) Definition MeasurableMonotoneConvergenceClassical {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) : (forall n:nat, MeasurableFunction (fn n)) -> (forall n:nat, partialFuncLe (fn n) (fn (S n))) -> IncrSeqCvT (* The sequence fn is assumed to converge everywhere, because the sequence fn is derived from a hypothetical Lebesgue-measurable function f, that we want to prove is Bishop-integrable. This hypothesis is necessary, to replace the convergence of integrals in the constructive monotone convergence theorem. For example, the sequence of constant measurable functions n converges nowhere, so we cannot conclude that the empty function is measurable. *) -> (forall x : X (ElemFunc IS), Domain (XpointwiseLimit fn) x) -> MeasurableFunction (XpointwiseLimit fn). Proof. intros fnMes H cl cv A k Aint. assert (forall n:nat, partialFuncLe (XmaxConst (XminConst (Xmult (CharacFunc A) (fn n)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))) (XmaxConst (XminConst (Xmult (CharacFunc A) (fn (S n))) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1)))). { intros n x xdf xdg. simpl. destruct xdf, xdg. destruct d. destruct d1. 2: contradiction. rewrite CRmult_1_l, CRmult_1_l. apply CRmax_lub. apply (CRle_trans _ (CRmin (partialApply (fn (S n)) x d2) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1)))). 2: apply CRmax_l. apply CRmin_glb. 2: apply CRmin_r. apply (CRle_trans _ (partialApply (fn n) x d0)). apply CRmin_l. apply H. apply CRmax_r. destruct d1. contradiction. rewrite CRmult_0_l, CRmult_0_l. apply CRle_refl. } assert (forall n : nat, (fun n0 : nat => Integral (fnMes n0 A k Aint)) n <= (fun n0 : nat => Integral (fnMes n0 A k Aint)) (S n)). { intro n. apply IntegralNonDecreasing. apply H0. } assert (forall n : nat, (fun n0 : nat => Integral (fnMes n0 A k Aint)) n <= MeasureSet Aint * CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1)). { intro n. apply (CRle_trans _ (Integral (IntegrableScale (CharacFunc A) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1)) Aint))). apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg. destruct d. 2: contradiction. rewrite CRmult_1_l, CRmult_1_r. apply CRmax_lub. apply CRmin_r. apply CR_of_Q_le. discriminate. destruct d. contradiction. rewrite CRmult_0_l, CRmult_0_r. apply CRmax_lub. apply CRmin_l. apply CR_of_Q_le. discriminate. rewrite IntegralScale. apply CRle_refl. } destruct (CR_complete _ _ (cl _ (fun n => Integral (fnMes n A k Aint)) (MeasureSet Aint * CR_of_Q _ (Z.pos k # 1)) H1 H2)) as [l lcv]. destruct (IntegralMonotoneConvergence IS (fun n => XmaxConst (XminConst (Xmult (CharacFunc A) (fn n)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))) (fun n => fnMes n A k Aint) l H0 lcv). apply (IntegrableFunctionExtensional (XpointwiseLimit (fun n : nat => XmaxConst (XminConst (Xmult (CharacFunc A) (fn n)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))))). 2: exact x. split. intros y ydf. simpl. simpl in ydf. destruct ydf. split. exact (fst (x0 O)). exists (fun n => snd (x0 n)). specialize (cv y). destruct cv. apply (CR_cauchy_eq (fun n : nat => partialApply (fn n) y (x1 n))). 2: exact c1. intro n. apply DomainProp. intros. apply applyPointwiseLimit. apply CR_cv_max. apply CR_cv_min. destruct xD, xG. destruct d. - setoid_replace (partialApply (Xmult (CharacFunc A) (XpointwiseLimit fn)) x0 (left a, d0)) with (partialApply (XpointwiseLimit fn) x0 d0). 2: simpl; rewrite CRmult_1_l; reflexivity. pose proof (applyPointwiseLimit fn x0 d0 (partialApply (XpointwiseLimit fn) x0 d0)) as [H3 _]. apply (CR_cv_eq _ (fun n : nat => partialApply (fn n) x0 (let (xn, _) := d0 in xn n))). intro n. simpl. destruct (x1 n), d. rewrite CRmult_1_l. apply DomainProp. contradiction. apply H3. reflexivity. - setoid_replace (partialApply (Xmult (CharacFunc A) (XpointwiseLimit fn)) x0 (right n, d0)) with (CR_of_Q (RealT (ElemFunc IS)) 0). 2: simpl; rewrite CRmult_0_l; reflexivity. apply (CR_cv_eq _ (fun _ => 0)). intros. simpl. destruct (x1 n0), d. contradiction. rewrite CRmult_0_l. reflexivity. intro p. exists O. intros. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. Qed. (* Lemma MeasurableSetUnionCountable : forall {IS : IntegrationSpace} (An : nat -> ((X (ElemFunc IS)) -> Prop)), (forall n:nat, MeasurableSet (An n)) -> IncrSeqCvT (* Maybe we can weaken this classical hypothesis *) -> MeasurableSet (fun x => exists n:nat, An n x). Proof. intros IS An AnMeas IncrSeqCv. apply MeasurableSetEquiv. intros B Bint. (* Integrate union intersected with B by the monotone convergence theorem. The limit of the intersected integrals will come from majoration and IncrSeqCv. *) assert (forall n : nat, IntegrableFunction (Xmult (CharacFunc (UnionIterate An n)) (CharacFunc B))) as unionMes. { intro n. pose proof (MeasurableSetUnionIterate An AnMeas). pose proof (MeasurableSetEquiv (UnionIterate An n)) as [mes _]. exact (mes (X n) B Bint). } assert (forall n : nat, @partialFuncLe (RealT (ElemFunc IS)) _ (Xmult (CharacFunc (UnionIterate An n)) (CharacFunc B)) (Xmult (CharacFunc (UnionIterate An (S n))) (CharacFunc B))). { intros n x xdf xdg. simpl. destruct xdf, xdg. destruct d0. destruct d2. 2: contradiction. rewrite CRmult_1_r, CRmult_1_r. destruct d. destruct d1. apply CRle_refl. contradict n0. left. exact u. destruct d1. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. rewrite CRmult_0_r. destruct d2. contradiction. rewrite CRmult_0_r. apply CRle_refl. } assert (forall n : nat, Integral (unionMes n) <= Integral Bint). { shelve. } specialize (IncrSeqCv _ (fun n : nat => Integral (unionMes n)) (Integral Bint) (fun n => IntegralNonDecreasing _ _ _ _ (H n)) H0). apply CR_complete in IncrSeqCv. destruct IncrSeqCv as [l lcv]. destruct (IntegralMonotoneConvergence IS (fun n => Xmult (CharacFunc (UnionIterate An n)) (CharacFunc B)) unionMes l H lcv) as [limInt _]. apply (IntegrableFunctionExtensional (XpointwiseLimit (fun n : nat => Xmult (CharacFunc (UnionIterate An n)) (CharacFunc B)))). 2: exact limInt. split. - intros x [xn c]. split. 2: apply (xn O). clear lcv l. apply CR_complete in c. destruct c as [l lcv]. split. 2: exact H1. destruct H2 as [xn c]. destruct H. simpl. destruct H0. left. destruct e. exists x0. apply H. right. intro abs. contradict n. destruct abs. exists x0. split; assumption. destruct H0. exfalso. destruct e, H. contradiction. simpl. right. intro abs. destruct abs. + intros x [H|H]. simpl. left. destruct H. split. exists x0. apply H. apply H. right. intros [[n H0] H1]. apply H. exists n. split; assumption. + intros. simpl. destruct xD, xG. reflexivity. exfalso. apply n. destruct e. split. exists x0. apply H. apply H. exfalso. apply n. destruct a, H. exists x0. split; assumption. reflexivity. - assert (forall n:nat, IntegrableSet (fun x => An n x /\ B x)) as AnInt. { intro n. apply AnMeas, Bint. } specialize (IncrSeqCv _ (fun n : nat => MeasureSet (IntegrableSetUnionIterate (fun (n0 : nat) (x : X (ElemFunc IS)) => An n0 x /\ B x) AnInt n)) (MeasureSet Bint)). apply CR_complete in IncrSeqCv. destruct IncrSeqCv as [l lim]. + apply (IntegrableSetCountableUnion _ AnInt l lim). + intros. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf. destruct xdg. apply CRle_refl. exfalso. apply n0. apply applyUnionIterate. apply applyUnionIterate in u. destruct u. exists x0. destruct H, H0. repeat split; try assumption. apply (Nat.le_trans _ _ _ H), le_S, le_refl. destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. + intros. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf. destruct xdg. apply CRle_refl. exfalso. apply applyUnionIterate in u. destruct u, H, H0. contradiction. destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. Qed. *) Definition IntegralSupport {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (A : (X (ElemFunc IS)) -> Prop) (eps : CRcarrier (RealT (ElemFunc IS))) : Type := { isupp_int : IntegrableSet A & IntegralDistance fInt (RestrictedIntegrable fInt isupp_int) < eps }. Lemma IntegralSupportExists : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (eps : CRcarrier (RealT (ElemFunc IS))), 0 < eps -> { t : CRcarrier _ & prod (t < eps) (IntegralSupport f fInt (fun x => exists xD:Domain (Xabs f) x, t <= partialApply (Xabs f) x xD) eps) }. Proof. intros. pose proof (InverseImageIntegrableAE (Xabs f) (IntegrableAbs fInt)) as [jumps invIm]. pose proof (Un_cv_nat_real _ _ (IntegralTruncateLimitZero f fInt) eps H) as [n nmaj]. pose proof (CRuncountable jumps 0 _ (CRmin_lt _ _ _ (invSuccRealPositive n) H)) as [t [[tpos tmin] tcont]]. specialize (invIm t tpos tcont) as [invIm _]. exists t. split. apply (CRlt_le_trans _ _ _ tmin). apply CRmin_r. exists invIm. specialize (nmaj n (Nat.le_refl n)). refine (CRle_lt_trans _ _ _ _ nmaj). unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. apply IntegralNonDecreasing. intros x xdf xdg. destruct xdf, d0, d0. - (* t <= |f x| *) apply (CRle_trans _ 0). simpl. rewrite CRmult_1_l. rewrite <- CRopp_mult_distr_l, CRmult_1_l, (DomainProp f x d1 d). rewrite CRplus_opp_r, CRabs_right. apply CRle_refl. apply CRle_refl. simpl. apply CRmin_glb. apply CRabs_pos. apply CR_of_Q_le. discriminate. - (* |f x| < t *) apply (CRle_trans _ (CRabs _ (partialApply f x d))). simpl. rewrite CRmult_0_l, CRmult_0_r, CRplus_0_r. apply CRle_refl. assert (CRabs _ (partialApply f x d) <= t). { intro abs. contradict n0. exists d. apply CRlt_asym, abs. } clear n0. apply CRmin_glb. rewrite applyXabs, (DomainProp f x xdg d). apply CRle_refl. apply (CRle_trans _ _ _ H0). apply CRlt_asym. apply (CRlt_le_trans _ _ _ tmin). apply CRmin_l. - apply IntegralNonNeg. intros x xdf. apply CRmin_glb. apply CRabs_pos. apply CR_of_Q_le. discriminate. Qed. Definition RestrictedMeasurable_pos {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (A : (X (ElemFunc IS)) -> Prop) : IntegrableFunction f -> MeasurableSet A -> nonNegFunc f -> IntegrableFunction (Xmult (CharacFunc A) f). Proof. intros fInt Ames fPos. (* Make a sequence of supports converging to f's integral. *) assert (forall n:nat, 0 < CRpow (CR_of_Q (RealT (ElemFunc IS)) (1#2)) n). { intro n. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. } pose proof (fun n:nat => IntegralSupportExists f fInt _ (H n)) as Bn. assert (forall n:nat, IntegrableFunction (Xmult (CharacFunc (fun x => A x /\ let (t,_) := Bn n in exists xD : Domain (Xabs f) x, t <= partialApply (Xabs f) x xD )) f)) as fnInt. { intro n. apply (RestrictedIntegrable fInt). pose proof (MeasurableSetEquiv A) as [H0 _]. destruct (Bn n) as [t p], p, i as [i c0]. specialize (H0 Ames _ i). refine (IntegrableFunctionExtensional _ _ _ H0). split. intros x xdf. destruct xdf, d. 2: right; intro abs; destruct abs; contradiction. destruct d0. left. split; assumption. right; intro abs; destruct abs; contradiction. intros. destruct xD. simpl. destruct d. rewrite CRmult_1_l. destruct d0,xG. reflexivity. contradict n0. split; assumption. contradict n0. apply a0. reflexivity. rewrite CRmult_0_l. destruct xG. contradict n0. apply a. reflexivity. } assert (forall n:nat, IntegrableFunction (Xmult (CharacFunc (fun x => let (t,_) := Bn n in exists xD : Domain (Xabs f) x, t <= partialApply (Xabs f) x xD)) f)) as gnInt. { intro n. apply (RestrictedIntegrable fInt). destruct (Bn n) as [t p], p, i as [i c0]. exact i. } destruct (series_cv_maj (fun n : nat => Integral (IntegrableAbs (IntegrableMinus (fnInt (S n)) (fnInt n)))) (fun n:nat => CRpow (CR_of_Q (RealT (ElemFunc IS)) (1#2)) n * CR_of_Q _ 2) (CR_of_Q _ 2 * CR_of_Q _ 2)) as [l lcv]. - intro n. rewrite CRabs_right. 2: apply IntegralNonNeg; intros x xdf; apply CRabs_pos. apply (CRle_trans _ (Integral (IntegrableAbs (IntegrableMinus (gnInt (S n)) (gnInt n))))). apply IntegralNonDecreasingAE. destruct (Bn n) as [t p], p, i as [i c0]. exists (Xmult (CharacFunc A) (CharacFunc (fun x => exists xD : Domain (Xabs f) x, t <= partialApply (Xabs f) x xD ))). split. pose proof (MeasurableSetEquiv A) as [H0 _]. specialize (H0 Ames _ i). exact H0. intros x xdA xdf xdg. simpl. destruct xdf, xdg, d, d1, d0, d2. destruct xdA, d7. + (* x in A *) rewrite (DomainProp f x d6 d5). clear d6. rewrite (DomainProp f x d4 d3). clear d4. destruct d. destruct d1. 2: contradict n0; apply a0. destruct d0. destruct d2. apply CRle_refl. contradict n0. apply a1. destruct d2. 2: apply CRle_refl. contradict n0. split. exact a. exact e. destruct d1. contradict n0. split. exact a. apply y. destruct d0. destruct d2. apply CRle_refl. contradict n2. apply a0. destruct d2. 2: apply CRle_refl. contradict n2. split. exact a. exact e. + (* x not in A *) destruct d. contradict n0. apply a. rewrite CRmult_0_l. destruct d0. contradict n0. apply a. rewrite CRmult_0_l. rewrite CRmult_0_r, CRplus_0_r, CRabs_right. apply CRabs_pos. apply CRle_refl. + apply (CRle_trans _ _ _ (IntegralDistance_triang _ _ _ _ fInt _)). rewrite (CR_of_Q_plus _ 1 1), CRmult_plus_distr_l. rewrite CRmult_1_r. apply CRplus_le_compat. generalize (gnInt (S n)). intro i. simpl in i. destruct (Bn (S n)), p, i0. apply CRlt_asym, (CRlt_trans _ (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S n))). refine (CRle_lt_trans _ _ _ _ c0). apply IntegralNonDecreasing. intros y ydf ydg. rewrite (DomainProp _ y ydf ydg). apply CRle_refl. apply (CRlt_le_trans _ (CR_of_Q _ 1 * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n)). apply CRmult_lt_compat_r. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CR_of_Q_lt. reflexivity. rewrite CRmult_1_l. apply CRle_refl. generalize (gnInt n). intro i. simpl in i. destruct (Bn n), p, i0. apply CRlt_asym. refine (CRle_lt_trans _ _ _ _ c0). apply IntegralNonDecreasing. intros y ydf ydg. rewrite (DomainProp _ y ydf ydg). apply CRle_refl. - apply series_cv_scale. exact GeoHalfTwo. - destruct (IntegrableXpointwiseLimit _ fnInt l (fst lcv)) as [limInt _]. pose proof (MeasurableFunctionFull _ Ames) as [h hint]. refine (IntegrableExtensionalAE _ _ _ _ limInt). destruct hint. + exists (Xplus h f). split. exact (IntegrablePlus _ _ i fInt). intros. destruct H0. split. specialize (d x d0). exact d. exact d1. + exists h. destruct hint. split. exact i. intros. clear d H0 i h. destruct dG. apply applyPointwiseLimit. intro p. destruct (CRltLinear (RealT (ElemFunc IS))) as [_ s]. assert (0 < CR_of_Q (RealT (ElemFunc IS)) (1 # (2*p))). { apply CR_of_Q_pos. reflexivity. } specialize (s 0 (partialApply f x d0) _ H0) as [c|c]. * (* 0 < f x. x will eventually be in the support, then the left term becomes 0. *) simpl in c. apply (CR_cv_open_above _ _ _ (@GeoCvZero (RealT (ElemFunc IS)))) in c. destruct c as [n nmaj]. exists n. intros i H1. specialize (nmaj i H1). destruct dF. generalize (x0 i). intros. destruct (Bn i) as [t r], r, i0 as [j c1], d1. simpl. rewrite (DomainProp f x d2 d0). clear d2. destruct d. destruct d1. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. contradict n0. split. exact a. exists d0. apply CRlt_asym, (CRlt_trans _ _ _ c0), (CRlt_le_trans _ _ _ nmaj). apply CRle_abs. destruct d1. destruct a. contradiction. unfold CRminus. rewrite CRmult_0_l, CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. * (* f x < 1 / 2p *) exists O. intros. apply (CRle_trans _ _ _ (CRabs_triang _ _)). setoid_replace (1#p) with ((1#(2*p)) + (1#(2*p)))%Q. 2: rewrite Qinv_plus_distr; reflexivity. rewrite CR_of_Q_plus. apply CRplus_le_compat. destruct dF, (x0 i). simpl. destruct d1. rewrite CRmult_1_l, CRabs_right, (DomainProp f x d2 d0). apply CRlt_asym, c. apply fPos. rewrite CRmult_0_l, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. rewrite CRabs_opp. simpl. destruct d. rewrite CRmult_1_l, CRabs_right. apply CRlt_asym, c. apply fPos. rewrite CRmult_0_l, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. Qed. Definition RestrictedMeasurable {IS : IntegrationSpace} {f : PartialFunction (X (ElemFunc IS))} {A : (X (ElemFunc IS)) -> Prop} : IntegrableFunction f -> MeasurableSet A -> IntegrableFunction (Xmult (CharacFunc A) f). Proof. intros fInt Ames. apply (IntegrableFunctionExtensional (Xminus (Xmult (CharacFunc A) (XposPart f)) (Xmult (CharacFunc A) (XnegPart f)))). - split. intros x xdf. destruct xdf. split. apply d. apply d. intros. destruct xD, xG. rewrite (applyXmult _ _ x d1 d2). rewrite <- (SplitPosNegParts _ x _ (snd d) (snd d0)). rewrite (applyXminus (Xmult (CharacFunc A) (XposPart f)) (Xmult (CharacFunc A) (XnegPart f)) x d d0). destruct d, d0. rewrite (applyXmult _ _ x d d3), (applyXmult _ _ x d0 d4). rewrite (DomainProp _ x d0 d), (DomainProp _ x d1 d). unfold CRminus. rewrite CRmult_plus_distr_l, CRopp_mult_distr_r. reflexivity. - apply IntegrableMinus. apply RestrictedMeasurable_pos. apply IntegrablePosPart, fInt. exact Ames. apply applyXposPartNonNeg. apply RestrictedMeasurable_pos. apply IntegrableNegPart, fInt. exact Ames. apply applyXnegPartNonNeg. Qed. (* IntegrableSet (fun x => A x /\ ~B x) is not enough, because it leads to ~~B. *) Record SetApprox {IS : IntegrationSpace} (A : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (eps : CRcarrier (RealT (ElemFunc IS))) : Type := { sa_approx : (X (ElemFunc IS)) -> Prop; sa_bint : IntegrableSet sa_approx; sa_mes : MeasureSet Aint - MeasureSet sa_bint < eps; sa_inc : forall x, sa_approx x -> A x; }. (* Generators for integrable sets, akin to a basis for a topology. *) Definition IntegrableSetsGen (IS : IntegrationSpace) : Type := forall (A : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (eps : CRcarrier (RealT (ElemFunc IS))), 0 < eps -> SetApprox A Aint eps. (* Increasing sequence of subsets of A that converge towards A, and which disjoint increments are generators. *) Fixpoint IntegrableApproxSequence {IS : IntegrationSpace} (gen : IntegrableSetsGen IS) (A : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (n : nat) {struct n} : { U : X (ElemFunc IS) -> Prop & IntegrableSet U }. Proof. destruct n as [|p]. - destruct (gen A Aint 1 (CRzero_lt_one _)). exists sa_approx0. exact sa_bint0. - destruct (IntegrableApproxSequence IS gen A Aint p) as [U Uint]. exists (fun x => U x \/ (sa_approx _ _ _ (gen _ (IntegrableSetDifference A U Aint Uint) (CRpow (CR_of_Q _ (1#2)) (S p)) (CRpow_gt_zero _ (S p) (CR_of_Q_pos (1#2) eq_refl))) x)). exact (IntegrableSetUnion _ _ Uint (sa_bint _ _ _ (gen _ (IntegrableSetDifference A U Aint Uint) (CRpow (CR_of_Q _ (1#2)) (S p)) (CRpow_gt_zero _ (S p) (CR_of_Q_pos (1#2) eq_refl))))). Defined. Lemma IntegrableApproxSequenceInc : forall {IS : IntegrationSpace} (gen : IntegrableSetsGen IS) (A : X (ElemFunc IS) -> Prop) (Aint : IntegrableSet A) (n : nat) (x : X (ElemFunc IS)), let (U,_) := IntegrableApproxSequence gen A Aint n in U x -> A x. Proof. induction n. - intros. simpl. destruct (gen A Aint 1 (CRzero_lt_one (RealT (ElemFunc IS)))). apply sa_inc0. - intros. simpl. destruct (IntegrableApproxSequence gen A Aint n). intros. destruct H. apply IHn, H. apply (sa_inc _ _ _ _ x H). Qed. Lemma IntegrableApproxSequenceIncr : forall {IS : IntegrationSpace} (gen : IntegrableSetsGen IS) (A : X (ElemFunc IS) -> Prop) (Aint : IntegrableSet A) (i j : nat) (x : X (ElemFunc IS)), le i j -> (let (U,_) := IntegrableApproxSequence gen A Aint i in U x) -> (let (U,_) := IntegrableApproxSequence gen A Aint j in U x). Proof. induction j. - intros. inversion H. subst i. exact H0. - intros. apply Nat.le_succ_r in H. destruct H. specialize (IHj x H). simpl; destruct (IntegrableApproxSequence gen A Aint j). left. exact (IHj H0). subst i. exact H0. Qed. Lemma IntegrableApproxSequenceBound : forall {IS : IntegrationSpace} (gen : IntegrableSetsGen IS) (A : X (ElemFunc IS) -> Prop) (Aint : IntegrableSet A) (n : nat) (Uint : IntegrableSet (let (U,_) := IntegrableApproxSequence gen A Aint n in U)), MeasureSet Aint - MeasureSet Uint < CRpow (CR_of_Q _ (1#2)) n. Proof. intros. destruct n. - simpl. simpl in Uint. destruct (gen A Aint 1 (CRzero_lt_one (RealT (ElemFunc IS)))). apply (CRle_lt_trans _ (MeasureSet Aint - MeasureSet sa_bint0)). apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply MeasureNonDecreasing. intros. exact H. exact sa_mes0. - simpl. pose proof (IntegrableApproxSequenceInc gen A Aint n) as Uinc. simpl in Uint; destruct (IntegrableApproxSequence gen A Aint n) as [U Vint]. apply (CRle_lt_trans _ (MeasureSet (IntegrableSetDifference A U Aint Vint) - MeasureSet (sa_bint _ _ _ (gen (fun x0 : X (ElemFunc IS) => A x0 /\ ~ U x0) (IntegrableSetDifference A U Aint Vint) (CR_of_Q (RealT (ElemFunc IS)) (1 # 2) * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n) (CRpow_gt_zero (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S n) (CR_of_Q_pos (1 # 2) eq_refl)))))). 2: apply sa_mes. rewrite <- MeasureDifferenceIncluded, <- MeasureDifferenceIncluded. apply MeasureNonDecreasing. intros. destruct H. split. split. exact H. intro abs. apply H0. left. exact abs. intro abs. apply H0. right. exact abs. intros. exact (sa_inc _ _ _ _ x H). intros. destruct H. 2: exact (proj1 (sa_inc _ _ _ _ x H)). apply Uinc, H. Qed. Lemma IntegrableApproxSequenceLimit : forall {IS : IntegrationSpace} (gen : IntegrableSetsGen IS) (A : X (ElemFunc IS) -> Prop) (Aint : IntegrableSet A), { intUnion : IntegrableSet (fun x => exists n:nat, let (U,_) := IntegrableApproxSequence gen A Aint n in U x) | MeasureSet intUnion == MeasureSet Aint }. Proof. intros. assert (forall n:nat, IntegrableSet (fun x => let (U, _) := IntegrableApproxSequence gen A Aint n in U x)) as seqInt. { intro n. destruct (IntegrableApproxSequence gen A Aint n). exact i. } apply (IntegrableSetCountableUnion (fun n x => let (U,_) := IntegrableApproxSequence gen A Aint n in U x) seqInt (MeasureSet Aint)). intro p. pose proof (@GeoCvZero (RealT (ElemFunc IS)) p) as [n ncv]. exists n. intros i H. rewrite CRabs_minus_sym, CRabs_right. - apply (CRle_trans _ (MeasureSet Aint - MeasureSet (seqInt i))). apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply MeasureNonDecreasing. intros. apply applyUnionIterate. exists i. exact (conj (Nat.le_refl i) H0). specialize (ncv i H). apply (CRle_trans _ (CRpow (CR_of_Q _ (1#2)) i)). generalize (seqInt i). intro iint. pose proof (IntegrableApproxSequenceBound gen A Aint i). destruct (IntegrableApproxSequence gen A Aint i). apply CRlt_asym, X. unfold CRminus in ncv. rewrite CRopp_0, CRplus_0_r, CRabs_right in ncv. exact ncv. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. - rewrite <- (CRplus_opp_r (MeasureSet Aint)). apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply MeasureNonDecreasing. intros. apply applyUnionIterate in H0. destruct H0, H0. pose proof (IntegrableApproxSequenceInc gen A Aint x0 x). destruct (IntegrableApproxSequence gen A Aint x0). exact (H2 H1). Qed. (* It is enough to truncate on generator sets to prove that a function is measurable. Bishop's lemma 4.9. *) Lemma MeasurableGen : forall {IS : IntegrationSpace} (h : PartialFunction (X (ElemFunc IS))), (forall (A : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (k : positive) (eps : CRcarrier (RealT (ElemFunc IS))) (epsPos : 0 < eps), { B : SetApprox A Aint eps & IntegrableFunction (XmaxConst (XminConst (Xmult (CharacFunc (sa_approx _ _ _ B)) h) (CR_of_Q _ (Z.pos k # 1))) (CR_of_Q _ (Z.neg k # 1))) }) -> MeasurableFunction h. Proof. intros IS f fMes A n Aint. pose (fun S Sint eps epsPos => let (B,_) := fMes S Sint n eps epsPos in B) as gen. (* Make a disjoint sequence of subsets B_k that converges to A in measure. Bound h by n so that B_k h converges monotonically towards (union B_k) h. *) pose (fun k:nat => match k with | O => let (U,_):=IntegrableApproxSequence gen A Aint O in U | S i => let (U,Uint):=IntegrableApproxSequence gen A Aint i in sa_approx _ _ _ (gen _ (IntegrableSetDifference A U Aint Uint) (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) k) (CRpow_gt_zero (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) k (CR_of_Q_pos (1 # 2) eq_refl))) end) as Bk. assert (forall k:nat, IntegrableSet (Bk k)) as BkInt. { intro k. unfold Bk. destruct k. - destruct (IntegrableApproxSequence gen A Aint 0). exact i. - destruct (IntegrableApproxSequence gen A Aint k). apply sa_bint. } assert (forall k:nat, Integral (BkInt (S k)) <= CRpow (CR_of_Q _ (1 # 2)) k) as BkMaj. { intro k. pose proof (IntegrableApproxSequenceBound gen A Aint k). pose proof (IntegrableApproxSequenceInc gen A Aint k). destruct (IntegrableApproxSequence gen A Aint k) as [U Uint] eqn:des. apply (CRle_trans _ (MeasureSet (IntegrableSetDifference A U Aint Uint))). apply IntegralNonDecreasing. intros x xdf xdg. simpl. simpl in xdf. destruct xdf. rewrite des in y. destruct xdg. apply CRle_refl. contradict n0. exact (sa_inc _ _ _ _ x y). destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. rewrite MeasureDifferenceIncluded. apply CRlt_asym, X. intros. exact (H x H0). } pose (fun k:nat => (XmaxConst (XminConst (Xmult (CharacFunc (Bk k)) f) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos n # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg n # 1)))) as fk. assert (forall k:nat, IntegrableFunction (fk k)) as fkInt. { unfold fk, Bk. intro k. destruct k. - simpl. unfold gen. destruct (fMes A Aint n 1 (CRzero_lt_one (RealT (ElemFunc IS)))), x; apply i. - destruct (IntegrableApproxSequence gen A Aint k) as [U Uint]. unfold gen. destruct (fMes (fun x : X (ElemFunc IS) => A x /\ ~ U x) (IntegrableSetDifference A U Aint Uint) n (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S k)) (CRpow_gt_zero (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S k) (CR_of_Q_pos (1 # 2) eq_refl))) as [B Bint]. refine (IntegrableFunctionExtensional _ _ _ Bint). split. + intros y yD. exact yD. + intros. rewrite (DomainProp _ x xD xG). reflexivity. } assert (forall (i : nat) x (xkD : forall k:nat, Domain (CharacFunc (Bk k)) x), (let (U, _) := IntegrableApproxSequence gen A Aint i in U x) -> @CRsum (RealT (ElemFunc IS)) (fun k : nat => partialApply _ x (xkD k)) i == 1) as BkDisjoint. { induction i. - intros. simpl. destruct (xkD O). reflexivity. contradict n0. simpl. simpl in H. destruct (gen A Aint 1 (CRzero_lt_one (RealT (ElemFunc IS)))). exact H. - intros. specialize (IHi x xkD). simpl in H; destruct (IntegrableApproxSequence gen A Aint i) as [U Uint] eqn:des. destruct H. (* In U so last term is zero. *) specialize (IHi H). rewrite <- (CRplus_0_r 1). simpl. simpl in IHi. rewrite IHi. clear IHi. apply CRplus_morph. reflexivity. destruct (xkD (S i)). 2: reflexivity. exfalso. unfold Bk in b. rewrite des in b. pose proof (sa_inc _ _ _ _ x b). destruct H0. contradiction. (* Not in U x so all previous terms are 0 in the sum. *) clear IHi. rewrite <- (CRplus_0_l 1). simpl. apply CRplus_morph. pose proof (sa_inc _ _ _ _ x H). destruct H0. clear H. rewrite (CRsum_eq _ (fun k => 0)), sum_const, CRmult_0_l. reflexivity. intros. destruct (xkD i0). 2: reflexivity. contradict H1. pose proof (IntegrableApproxSequenceIncr gen A Aint i0 i x H). rewrite des in H1. apply H1. clear H1. unfold Bk in b. destruct i0. destruct (IntegrableApproxSequence gen A Aint 0); exact b. simpl; destruct (IntegrableApproxSequence gen A Aint i0). right. exact b. (* In last Bk so last term equals 1. *) destruct (xkD (S i)). reflexivity. contradict n0. simpl. rewrite des. exact H. } assert (forall (i j : nat) x (xkD : forall k:nat, Domain (fk k) x) (dG : Domain (Xmult (CharacFunc A) f) x), (let (U, _) := IntegrableApproxSequence gen A Aint j in U x) -> le j i -> CRsum (fun k : nat => partialApply (fk k) x (xkD k)) i == partialApply (XmaxConst (XminConst (Xmult (CharacFunc A) f) (CR_of_Q _ (Z.pos n # 1))) (CR_of_Q _ (Z.neg n # 1))) x dG) as fkDisjoint. { intros. unfold fk. rewrite (CRsum_eq _ (fun k:nat => partialApply _ x (fst (xkD k)) * partialApply (XmaxConst (XminConst f (CR_of_Q _ (Z.pos n # 1))) (CR_of_Q _ (Z.neg n # 1))) x (snd (xkD O)))). - rewrite sum_scale. rewrite (BkDisjoint i x (fun k => fst (xkD k))), CRmult_1_l. simpl. destruct dG, d. rewrite CRmult_1_l, (DomainProp f x _ d0). reflexivity. contradict n0. pose proof (IntegrableApproxSequenceInc gen A Aint j x). destruct (IntegrableApproxSequence gen A Aint j). exact (H1 H). exact (IntegrableApproxSequenceIncr gen A Aint j i x H0 H). - intros. simpl. destruct (xkD i0), d. simpl. do 2 rewrite CRmult_1_l. rewrite (DomainProp f x d0 (snd (xkD 0%nat))). reflexivity. simpl. rewrite CRmult_0_l, CRmult_0_l. rewrite CRmin_left, CRmax_left. reflexivity. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. } destruct (series_cv_maj (fun k : nat => Integral (IntegrableAbs (fkInt k))) (fun k => match k with | O => MeasureSet (BkInt O) | S i => (CRpow (CR_of_Q _ (1 # 2)) i) end * CR_of_Q _ (Z.pos n # 1)) ((CR_of_Q _ 2 + MeasureSet (BkInt O)) * CR_of_Q _ (Z.pos n # 1))) as [l lcv]. - intro k. unfold fk. rewrite CRabs_right. apply (CRle_trans _ (Integral (IntegrableScale _ (CR_of_Q _ (Z.pos n # 1)) (BkInt k)))). apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg, d. rewrite CRmult_1_l, CRmult_1_r. apply CRabs_le. split. rewrite <- CR_of_Q_opp. setoid_replace (- (Z.pos n # 1))%Q with (Z.neg n # 1). apply CRmax_r. reflexivity. apply CRmax_lub. apply CRmin_r. apply CR_of_Q_le. discriminate. contradiction. contradiction. rewrite CRmult_0_l, CRmult_0_r. rewrite CRmin_left, CRmax_left, CRabs_right. apply CRle_refl. apply CRle_refl. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. rewrite IntegralScale, CRmult_comm. destruct k. rewrite CRmult_comm. apply CRle_refl. rewrite CRmult_comm. apply CRmult_le_compat_r. apply CR_of_Q_le. discriminate. exact (BkMaj k). apply IntegralNonNeg. intros x xdf. apply CRabs_pos. - apply series_cv_scale. apply (series_cv_shift (fun n0 : nat => match n0 with | 0%nat => MeasureSet (BkInt 0%nat) | S i => CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) i end) O); simpl. exact GeoHalfTwo. - destruct lcv. pose proof (IntegrableFunctionsComplete IS fk fkInt l s) as [rep repcv]. apply (IntegrableExtensionalAE (XinfiniteSumAbs (IntFn rep))). + exists (Xplus (CharacFunc A) (XinfiniteSumAbs (IntFn rep))). split. apply IntegrablePlus. apply Aint. exists rep. apply PartialRestriction_refl. intros. split. exact (fst H). destruct repcv, p. clear c0. specialize (d x (snd H)). destruct d as [xn d]. pose proof (xn O). destruct H0. exact d1. + pose proof (IntegrableApproxSequenceLimit gen A Aint) as [Uint Umes]. destruct (MeasureZeroAE _ (IntegrableSetDifference A _ Aint Uint)) as [h hInt]. rewrite MeasureDifferenceIncluded. rewrite Umes. unfold CRminus. apply CRplus_opp_r. intros. destruct H. pose proof (IntegrableApproxSequenceInc gen A Aint x0 x). destruct (IntegrableApproxSequence gen A Aint x0). exact (H0 H). exists (Xplus (CharacFunc (fun x : X (ElemFunc IS) => exists n : nat, let (U, _) := IntegrableApproxSequence gen A Aint n in U x)) h). split. exact (IntegrablePlus _ _ Uint (fst hInt)). intros. destruct H, hInt. specialize (n0 x d0). destruct repcv, p. rewrite (c0 x dF (d1 x dF)). clear c0. destruct d. (* Inside union *) clear n0. destruct e. apply applyInfiniteSumAbs. intro p. exists x0. intros. rewrite (fkDisjoint i0 x0 x _ dG). unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. exact H. exact H0. (* Outside A *) assert (~ A x). { intro abs. apply n0. split; assumption. } clear n1 n0 i d0 h. transitivity (CR_of_Q (RealT (ElemFunc IS)) 0). apply applyInfiniteSumAbs. apply (CR_cv_eq _ (fun _ => 0)). 2: apply CR_cv_const. intros. rewrite <- (CRmult_0_l (INR (S n0))). rewrite (CRsum_eq _ (fun _ => 0)). symmetry. apply sum_const. intros. unfold fk. simpl. destruct (domainInfiniteSumAbsIncReverse (fun k : nat => XmaxConst (XminConst (Xmult (CharacFunc (Bk k)) f) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos n # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg n # 1))) x (d1 x dF) i), d. contradict H. unfold Bk in b. destruct i. pose proof (IntegrableApproxSequenceInc gen A Aint O x). destruct (IntegrableApproxSequence gen A Aint 0). exact (H b). destruct (IntegrableApproxSequence gen A Aint i). exact (proj1 (sa_inc _ _ _ _ x b)). rewrite CRmult_0_l, CRmin_left, CRmax_left. reflexivity. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. simpl. destruct dG, d. contradiction. rewrite CRmult_0_l, CRmin_left, CRmax_left. reflexivity. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. + exists rep. apply PartialRestriction_refl. Qed. Lemma CR_cv_maj : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (s : CRcarrier R), (forall n:nat, CRabs R (un (S n) - un n) <= vn n) -> series_cv vn s -> { l : CRcarrier R & prod (CR_cv _ un l) (l <= s + un O) }. Proof. intros. destruct (series_cv_maj (fun n => un (S n) - un n) vn s H H0) as [l [lcv lmaj]]. apply (CR_cv_eq (fun n => un (S n) - un O)) in lcv. - exists (l + un O). split. apply (CR_cv_shift _ 1). apply (CR_cv_eq _ (fun n => un (S n) - un O + un O)). intros. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite Nat.add_comm. reflexivity. apply CR_cv_plus. exact lcv. apply CR_cv_const. unfold CRminus. apply CRplus_le_compat_r. exact lmaj. - induction n. reflexivity. simpl. rewrite IHn. clear IHn. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. (* Bishop's lemma 4.10. We strengthen the previous lemma by allowing the function to approximate within epsilon on each generator subset. This proves that continuous functions are measurable, because they are approximated by piecewise-constant functions. *) Lemma MeasurableGenApprox : forall {IS : IntegrationSpace} (h : PartialFunction (X (ElemFunc IS))), almost_everywhere (Domain h) -> (forall (A : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (n : positive) (eps : CRcarrier (RealT (ElemFunc IS))) (epsPos : 0 < eps), { fB : prod (PartialFunction (X (ElemFunc IS))) (SetApprox A Aint eps) & prod (IntegrableFunction (fst fB)) (forall (x : X (ElemFunc IS)) (xdh : Domain h x) (xdf : Domain (fst fB) x), sa_approx _ _ _ (snd fB) x -> CRabs _ (partialApply (XmaxConst (XminConst h (CR_of_Q _ (Z.pos n # 1))) (CR_of_Q _ (Z.neg n # 1))) x xdh - partialApply _ x xdf) < eps) }) -> MeasurableFunction h. Proof. intros IS h dom H. apply MeasurableGen. intros A Aint k eps epsPos. specialize (H A Aint k). (* We define another family of generator sets and call the previous lemma on it. *) assert (forall (i:nat), 0 < eps * CRpow (CR_of_Q _ (1 # 2)) i) as H0. { intros. apply (CRmult_lt_0_compat _ _ _ epsPos). apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. } pose (fun (i:nat) => sa_approx _ _ _ (let (fB,_) := H (eps * CRpow (CR_of_Q _ (1#2)) (S i)) (H0 (S i)) in snd fB)) as Bi. assert ({ BI : IntegrableSet (fun x => forall i:nat, Bi i x) & MeasureSet Aint - MeasureSet BI < eps }) as Bint. { destruct (CR_cv_maj (fun n => - MeasureSet (IntegrableSetIntersectIterate _ (fun i => sa_bint _ _ _ (let (fB,_) := H (eps * CRpow (CR_of_Q _ (1 # 2)) (S i)) (H0 (S i)) in snd fB)) n)) (fun n => (CRpow (CR_of_Q _ (1 # 2)) (2 + n) * eps)) (CR_of_Q _ (1 # 2) * eps)). intro n. unfold CRminus. rewrite CRopp_involutive, CRplus_comm. pose proof (@MeasureDifferenceIncluded IS). unfold CRminus in H1. rewrite <- H1, CRabs_right. clear H1. 2: apply MeasureNonNeg. apply (CRle_trans _ (MeasureSet Aint - MeasureSet (sa_bint _ _ _ (let (fB,_) := H (eps * CRpow (CR_of_Q _ (1 # 2)) (2 + n)) (H0 (2 + n)%nat) in snd fB)))). rewrite <- MeasureDifferenceIncluded. apply MeasureNonDecreasing. intros. destruct H1. split. apply (sa_inc _ _ _ (let (fB,_) := H (eps * CRpow (CR_of_Q _ (1 # 2)) (S n)) (H0 (S n)) in snd fB)). destruct n; apply H1. intro abs. contradict H2. split; assumption. apply sa_inc. rewrite <- (CRmult_comm eps). apply CRlt_asym. apply sa_mes. clear H1. intros. apply H1. apply (series_cv_eq (fun n : nat => CRpow (CR_of_Q _ (1 # 2)) n * ((CR_of_Q _ (1 # 2)) * (CR_of_Q _ (1 # 2)) * eps))). intros. simpl. rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. rewrite (CRmult_comm (CRpow (CR_of_Q _ (1 # 2)) n)), <- CRmult_assoc. reflexivity. apply (CR_cv_proper _ (CR_of_Q _ 2 * (CR_of_Q _ (1 # 2) * CR_of_Q _ (1 # 2) * eps))). apply series_cv_scale. exact GeoHalfTwo. rewrite <- CRmult_assoc, <- CRmult_assoc, <- (CR_of_Q_mult _ 2). setoid_replace (2 * (1#2))%Q with 1%Q. rewrite CRmult_1_l. reflexivity. reflexivity. destruct p. simpl in c0. apply CR_cv_opp in c. apply (CR_cv_eq (fun n : nat => MeasureSet (IntegrableSetIntersectIterate _ (fun i : nat => sa_bint A Aint (eps * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S i)) (let (fB, _) := H (eps * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S i)) (H0 (S i)) in snd fB)) n))) in c. destruct (IntegrableSetCountableIntersect _ _ _ c) as [intersectInt c1]. exists intersectInt. clear c. rewrite <- CRopp_involutive, <- c1 in c0. clear c1 x. apply (CRplus_le_compat_l (MeasureSet Aint)) in c0. rewrite (CRplus_comm (CR_of_Q (RealT (ElemFunc IS)) (1 # 2) * eps)) in c0. rewrite <- CRplus_assoc in c0. apply (CRle_lt_trans _ _ _ c0). clear c0. apply (CRlt_le_trans _ (eps * (CR_of_Q (RealT (ElemFunc IS)) (1 # 2) * 1) + CR_of_Q (RealT (ElemFunc IS)) (1 # 2) * eps)). apply CRplus_lt_compat_r. apply sa_mes. rewrite CRmult_1_r, CRmult_comm, <- CRmult_plus_distr_r, <- CR_of_Q_plus. setoid_replace ((1 # 2) + (1 # 2))%Q with 1%Q. rewrite CRmult_1_l. apply CRle_refl. reflexivity. intro n. apply CRopp_involutive. } assert (forall (x : X (ElemFunc IS)), (forall i : nat, Bi i x) -> A x). { intros. unfold Bi in H1. exact (sa_inc _ _ _ _ x (H1 O)). } destruct Bint as [BI Bmaj]. exists (Build_SetApprox IS A Aint eps _ BI Bmaj H1). pose (fun i:nat => let (fB,_) := H (eps * CRpow (CR_of_Q _ (1#2)) (S i)) (H0 (S i)) in fst fB) as fi. assert (forall i:nat, IntegrableFunction (Xmult (CharacFunc (fun x => forall i : nat, Bi i x)) (fi i))) as fiInt. { intro i. unfold fi. destruct (H (eps * CRpow (CR_of_Q _ (1 # 2)) (S i)) (H0 (S i))). exact (RestrictedIntegrable (fst p) BI). } destruct (series_cv_maj (fun n : nat => Integral (IntegrableAbs (IntegrableMinus (fiInt (S n)) (fiInt n)))) (fun n:nat => CRpow (CR_of_Q _ (1#2)) n * (CR_of_Q _ 2 * eps * MeasureSet BI)) (CR_of_Q _ 2 * (CR_of_Q _ 2 * eps * MeasureSet BI))) as [l lcv]. - intro n. rewrite CRabs_right. destruct dom as [hdom [hdomInt dom]]. apply (CRle_trans _ (Integral (IntegrablePlus _ _ (IntegrableScale _ 0 hdomInt) (IntegrableScale _ (CR_of_Q _ 2 * (eps * CRpow (CR_of_Q _ (1 # 2)) n)) BI)))). apply IntegralNonDecreasing. intros x xdf xdg. unfold fi. unfold fi in xdf. destruct xdg as [d d0]. destruct d0. pose proof (b n) as bn. unfold Bi in bn. pose proof (b (S n)) as bSn. unfold Bi in bSn. destruct (H (eps * CRpow (CR_of_Q _ (1 # 2)) (S n)) (H0 (S n))) as [x0 p]. destruct (H (eps * CRpow (CR_of_Q _ (1 # 2)) (S (S n))) (H0 (S (S n)))) as [x1 p0]. rewrite applyXabs. + setoid_replace (partialApply (Xminus (Xmult (CharacFunc (fun x2 : X (ElemFunc IS) => forall i : nat, Bi i x2)) (fst x1)) (Xmult (CharacFunc (fun x2 : X (ElemFunc IS) => forall i : nat, Bi i x2)) (fst x0))) x xdf) with (partialApply _ x (fst xdf) - partialApply (XmaxConst (XminConst h (CR_of_Q _ (Z.pos k # 1))) (CR_of_Q _ (Z.neg k # 1))) x (dom x d) + (partialApply (XmaxConst (XminConst h (CR_of_Q _ (Z.pos k # 1))) (CR_of_Q _ (Z.neg k # 1))) x (dom x d) - partialApply (Xmult (CharacFunc (fun x2 : X (ElemFunc IS) => forall i : nat, Bi i x2)) (fst x0)) x (snd xdf))). apply (CRle_trans _ _ _ (CRabs_triang _ _)). rewrite applyXplus, applyXscale, CRmult_0_l, CRplus_0_l. rewrite applyXscale, (CR_of_Q_plus _ 1 1). rewrite CRmult_plus_distr_r, CRmult_plus_distr_r, CRmult_1_l. apply CRplus_le_compat. destruct xdf, d1, d0, d0. simpl. rewrite CRmult_1_r, CRmult_1_l. apply CRlt_asym. destruct p0. specialize (c x (dom x d) d3). apply (CRle_lt_trans _ (CRabs (RealT (ElemFunc IS)) (partialApply (XmaxConst (XminConst h (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))) x (dom x d) - partialApply (fst x1) x d3))). rewrite CRabs_minus_sym. apply CRle_refl. apply (CRlt_le_trans _ (eps * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S (S n)))). apply c. exact bSn. simpl. rewrite <- CRmult_assoc. rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- (CRmult_1_r eps), CRmult_assoc, CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, epsPos. rewrite CRmult_1_l, <- CR_of_Q_mult. apply CR_of_Q_le. discriminate. contradiction. destruct xdf, d1, d1. simpl. rewrite CRmult_1_r, CRmult_1_l. apply CRlt_asym. apply (CRlt_le_trans _ (eps * CRpow (CR_of_Q _ (1 # 2)) (S n))). apply (snd p). exact bn. apply CRmult_le_compat_l. apply CRlt_asym, epsPos. rewrite <- (CRmult_1_l (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n)). apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. contradiction. unfold CRminus. rewrite CRplus_assoc. destruct xdf. rewrite (applyXminus (Xmult (CharacFunc (fun x2 : X (ElemFunc IS) => forall i : nat, Bi i x2)) (fst x1)) (Xmult (CharacFunc (fun x2 : X (ElemFunc IS) => forall i : nat, Bi i x2)) (fst x0)) x d0 d1). apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. + (* out of B *) simpl. rewrite CRmult_0_r, CRmult_0_l. destruct xdf, d0, d0. contradiction. rewrite CRmult_0_l. destruct d1, d0. contradiction. rewrite CRmult_0_l, CRmult_0_r. rewrite CRabs_right. apply CRle_refl. rewrite CRplus_0_r. apply CRle_refl. + (* Integral majoration *) rewrite IntegralPlus, IntegralScale, CRmult_0_r, CRplus_0_l. rewrite IntegralScale. rewrite CRmult_comm, <- CRmult_assoc, <- CRmult_assoc. rewrite (CRmult_comm (CR_of_Q (RealT (ElemFunc IS)) 2 * eps)). apply CRle_refl. + apply IntegralNonNeg. intros x xdf. rewrite applyXabs. apply CRabs_pos. - apply series_cv_scale. exact GeoHalfTwo. - destruct lcv. destruct (IntegrableXpointwiseLimit _ fiInt l s) as [limInt fcv]. clear s. refine (IntegrableExtensionalAE _ _ _ _ limInt). + destruct dom as [hdom [hdomInt dom]]. exists (Xplus hdom (XpointwiseLimit (fun i : nat => Xmult (CharacFunc (fun x : X (ElemFunc IS) => forall i0 : nat, Bi i0 x)) (fi i)))). split. apply IntegrablePlus. exact hdomInt. exact limInt. intros x [xdf xdg]. split. 2: exact (dom x xdf). simpl. destruct xdg as [xDn xdg]. destruct (xDn O). exact d. + destruct dom as [hdom [hdomInt dom]]. exists hdom. split. exact hdomInt. intros. unfold sa_approx. apply applyPointwiseLimit. destruct dG, d. simpl in s. (* Inside the intersection, the fi converge towards h. *) apply (CR_cv_proper _ (partialApply (XmaxConst (XminConst h (CR_of_Q (RealT (ElemFunc IS)) (Z.pos k # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg k # 1))) x d0)). 2: simpl; rewrite CRmult_1_l; reflexivity. apply (CR_cv_eq _ (fun n : nat => partialApply (fi n) x (let (xn, _) := dF in snd (xn n)))). intro n. simpl. destruct dF, (x0 n), d. rewrite CRmult_1_l. reflexivity. contradiction. intro p. assert (CR_cv _ (fun i => CRpow (CR_of_Q _ (1 # 2)) i * eps) 0). { apply (CR_cv_proper _ (0 * eps)). apply CR_cv_scale. exact GeoCvZero. apply CRmult_0_l. } specialize (H3 p) as [j jmaj]. exists j. intros. specialize (jmaj j (Nat.le_refl j)). unfold fi. destruct dF. destruct (x0 i). unfold snd. unfold fi in d1. unfold Bi in s. specialize (s i). destruct (H (eps * CRpow (CR_of_Q _ (1 # 2)) (S i)) (H0 (S i))). destruct p0 as [i0 c1]. rewrite CRabs_minus_sym. specialize (c1 x). apply (CRle_trans _ (eps * CRpow (CR_of_Q _ (1 # 2)) (S i))). apply CRlt_asym, c1, s. clear c1. refine (CRle_trans _ _ _ _ jmaj). unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right, CRmult_comm. apply CRmult_le_compat_r. apply CRlt_asym, epsPos. apply Nat.le_exists_sub in H3. destruct H3, H3. subst i. rewrite <- (CRmult_1_l (CRpow (CR_of_Q _ (1 # 2)) j)). replace (S (x2 + j)) with (S x2 + j)%nat. 2: reflexivity. rewrite <- CRpow_plus_distr. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. apply (CRmult_le_reg_l (CRpow (CR_of_Q _ 2) (S x2))). apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. rewrite CRpow_mult. rewrite <- (CRpow_proper 1). rewrite CRpow_one, CRmult_1_r. apply CRpow_ge_one. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. reflexivity. apply CRmult_le_0_compat. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. apply CRlt_asym, epsPos. (* Outside the intersection, 0 == 0. *) unfold sa_approx in n. apply (CR_cv_eq _ (fun _ => 0)). intros. simpl. destruct dF, (x0 n0), d. contradiction. rewrite CRmult_0_l. reflexivity. apply (CR_cv_proper _ 0). apply CR_cv_const. simpl. rewrite CRmult_0_l, CRmin_left, CRmax_left. reflexivity. apply CR_of_Q_le. discriminate. apply CR_of_Q_le. discriminate. Qed. (* The convergence in measure of a series of functions. It is the constructive counterpart of the pointwise convergence, weaker than uniform convergence. It is designed so that when a sequence fn of measurable functions converges towards function f, then f is measurable also (as would happen classically with pointwise convergence). For example the sequence of triangles (-1/n, 0), (0,n), (1/n,0) converges in measure towards 0. To prove that, take N an integer such as 2/N < eps. The SetApprox B simply removes the interval [-1/N, 1/N], where all the mass is. However the integrals of the triangles are all 1, which does not converge towards 0. *) Definition CvMeasure {IS : IntegrationSpace} (fn : nat -> @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) (f : @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) : Type := forall (A : (X (ElemFunc IS)) -> Prop) (Aint : IntegrableSet A) (eps : CRcarrier (RealT (ElemFunc IS))), 0 < eps -> { N : nat & forall n:nat, le N n -> { B : SetApprox A Aint eps & (forall x xdf xdfn, sa_approx _ _ _ B x -> CRabs _ (partialApply f x xdf - partialApply (fn n) x xdfn) < eps) } }. Lemma CvMeasureMeasurable : forall {IS : IntegrationSpace} (fn : nat -> @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) (f : @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))), almost_everywhere (Domain f) -> (forall n:nat, MeasurableFunction (fn n)) -> CvMeasure fn f -> MeasurableFunction f. Proof. intros IS fn f fFull fnMes fnCv. apply (MeasurableGenApprox f fFull). intros. specialize (fnCv A Aint eps epsPos) as [N Ncv]. specialize (Ncv N (Nat.le_refl N)) as [B Bcv]. specialize (fnMes N A n Aint). exists (pair (XmaxConst (XminConst (Xmult (CharacFunc A) (fn N)) (CR_of_Q (RealT (ElemFunc IS)) (Z.pos n # 1))) (CR_of_Q (RealT (ElemFunc IS)) (Z.neg n # 1))) B). split. exact fnMes. unfold fst, snd. intros. specialize (Bcv x xdh (snd xdf) H). refine (CRle_lt_trans _ _ _ _ Bcv). clear Bcv. rewrite applyXmaxConst, applyXmaxConst. apply (CRle_trans _ _ _ (CRmax_contract _ _ _)). rewrite applyXminConst, applyXminConst. apply (CRle_trans _ _ _ (CRmin_contract _ _ _)). simpl. destruct xdf, d. rewrite CRmult_1_l. apply CRle_refl. contradict n0. apply (sa_inc _ _ _ _ x H). Qed. (* fn converging in measure towards 0 is not enough to guarantee that the limit of I(fn) converge towards 0. An extra hypothesis of domination suffices. *) Record IntegralDominated {IS : IntegrationSpace} (fn : nat -> @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (eps : CRcarrier (RealT (ElemFunc IS))) : Type := { idom_support : (X (ElemFunc IS)) -> Prop; idom_idx : nat; idom_delta : CRcarrier (RealT (ElemFunc IS)); idom_delta_pos : 0 < idom_delta; idom_int : IntegrableSet idom_support; idom_dom : forall (B : X (ElemFunc IS) -> Prop) (Bmes : MeasurableSet B) (n:nat), le idom_idx n -> Integral (MeasurableIntersectIntegrable Bmes idom_int) < idom_delta -> Integral (RestrictedMeasurable (fnInt n) Bmes) < eps }. (* Bishop's lemma 4.14. *) Lemma DominatedMeasureCvZero : forall {IS : IntegrationSpace} (fn : nat -> @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)), CvMeasure fn (Xconst _ 0) -> (forall n:nat, nonNegFunc (fn n)) -> (forall (eps : CRcarrier (RealT (ElemFunc IS))) (epsPos : 0 < eps), IntegralDominated fn fnInt eps) -> CR_cv _ (fun n:nat => Integral (fnInt n)) 0. Proof. intros IS fn fnInt fnCvZero fnPos fnDominated. apply Un_cv_real_nat. intros eps epsPos. assert (0 < eps * CR_of_Q _ (1#2)) as halfEpsPos. { apply CRmult_lt_0_compat. exact epsPos. apply CR_of_Q_pos. reflexivity. } destruct (fnDominated _ halfEpsPos). assert (0 < MeasureSet idom_int0 + 1) as H. { apply (CRlt_le_trans _ 1). apply CRzero_lt_one. rewrite <- (CRplus_0_l 1), <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_0_r. apply MeasureNonNeg. } assert (0 < CRmin (eps * CR_of_Q _ (1#2) * CRinv _ _ (inr H)) idom_delta0) as H0. { apply CRmin_lt. 2: exact idom_delta_pos0. apply CRmult_lt_0_compat. apply CRmult_lt_0_compat. exact epsPos. apply CR_of_Q_pos. reflexivity. apply CRinv_0_lt_compat, H. } specialize (fnCvZero idom_support0 idom_int0 _ H0) as [N Nmaj]. exists (max N idom_idx0). intros. specialize (Nmaj i (Nat.le_trans _ _ _ (Nat.le_max_l _ _) H1)) as [[C Cint] Cmaj]. unfold sa_approx in Cmaj. assert (Integral (MeasurableIntersectIntegrable (MeasurableSetCompl C (IntegrableMeasurable (CharacFunc C) Cint)) idom_int0) < idom_delta0) as H2. { apply (CRlt_le_trans _ (CRmin (eps * CR_of_Q _ (1#2) * (/ (MeasureSet idom_int0 + 1)) (inr H)) idom_delta0)). 2: apply CRmin_r. refine (CRle_lt_trans _ _ _ _ sa_mes0). rewrite <- MeasureDifferenceIncluded. 2: exact sa_inc0. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf. destruct xdg. apply CRle_refl. contradict n. split; apply a. destruct xdg. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. } assert (le idom_idx0 i). { apply (Nat.le_trans _ (max N idom_idx0)). apply Nat.le_max_r. exact H1. } specialize (idom_dom0 _ _ _ H3 H2). clear H2 H3. apply (CRle_lt_trans _ (Integral (RestrictedMeasurable (fnInt i) (MeasurableSetCompl C (IntegrableMeasurable (CharacFunc C) Cint))) + Integral (RestrictedIntegrable (fnInt i) Cint))). unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. - rewrite <- IntegralPlus. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdg, d, d0. rewrite (DomainProp _ x d2 xdf), (DomainProp _ x d1 xdf). destruct d, d0. contradiction. rewrite CRmult_0_l, CRmult_1_l, CRplus_0_r. apply CRle_refl. rewrite CRmult_0_l, CRmult_1_l, CRplus_0_l. apply CRle_refl. contradiction. - exact (IntegralNonNeg _ _ (fnPos i)). - apply (CRlt_le_trans _ (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2) + eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2))). apply (CRplus_lt_le_compat _ _ _ _ idom_dom0). clear idom_dom0. apply (CRle_trans _ (MeasureSet Cint * (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2) * (/ (MeasureSet idom_int0 + 1)) (inr H)))). unfold MeasureSet. rewrite <- IntegralScale. apply IntegralNonDecreasing. + intros x xdf xdg. simpl. destruct xdf, d, xdg. rewrite CRmult_1_l, CRmult_1_r. clear c0. specialize (Cmaj x Logic.I d0 c). apply CRlt_asym in Cmaj. simpl in Cmaj. unfold CRminus in Cmaj. rewrite CRplus_0_l, CRabs_opp, CRabs_right in Cmaj. apply (CRle_trans _ _ _ Cmaj (CRmin_l _ _)). apply fnPos. contradiction. contradiction. rewrite CRmult_0_l, CRmult_0_r. apply CRle_refl. + rewrite CRmult_comm, CRmult_assoc. apply (CRle_trans _ (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2) * 1)). 2: rewrite CRmult_1_r; apply CRle_refl. apply CRmult_le_compat_l. apply CRmult_le_0_compat. apply CRlt_asym, epsPos. apply CR_of_Q_le. discriminate. apply (CRmult_le_reg_l (MeasureSet idom_int0 + 1) _ _ H). rewrite CRmult_1_r, <- CRmult_assoc, CRinv_r, CRmult_1_l. apply (CRle_trans _ (MeasureSet idom_int0 + 0)). rewrite CRplus_0_r. exact (MeasureNonDecreasing _ _ _ _ sa_inc0). apply CRplus_le_compat_l. apply CRlt_asym, CRzero_lt_one. + rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. setoid_replace ((1 # 2) + (1 # 2))%Q with 1%Q. 2: reflexivity. rewrite CRmult_1_r. apply CRle_refl. Qed. Lemma DominatedConvergence : forall {IS : IntegrationSpace} (fn : nat -> @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) (fnInt : forall n:nat, IntegrableFunction (fn n)) (f g : @PartialFunction (RealT (ElemFunc IS)) (X (ElemFunc IS))) (fInt : IntegrableFunction f), CvMeasure fn f -> IntegrableFunction g -> (forall n:nat, partialFuncLe (Xabs (fn n)) g) -> CR_cv _ (fun n:nat => Integral (fnInt n)) (Integral fInt). Proof. intros IS fn fnInt f g fInt cvfn gInt fnle. assert (CvMeasure (fun n : nat => Xabs (Xminus (fn n) f)) (Xconst (X (ElemFunc IS)) 0)) as cvZero. { intros A Aint eps epsPos. specialize (cvfn A Aint eps epsPos) as [N Nmaj]. exists N. intros. specialize (Nmaj n H) as [B Bapprox]. exists B. intros. destruct xdfn. specialize (Bapprox x d0 d H0). refine (CRle_lt_trans _ _ _ _ Bapprox). simpl. rewrite (CRabs_minus_sym (partialApply f x d0)). unfold CRminus. rewrite CRplus_0_l, CRabs_opp. rewrite CRabs_right. 2: apply CRabs_pos. rewrite <- CRopp_mult_distr_l, CRmult_1_l. apply CRle_refl. } assert (forall n : nat, nonNegFunc (Xabs (Xminus (fn n) f))). { intros n x xdf. apply CRabs_pos. } assert (forall (eps : CRcarrier (RealT (ElemFunc IS))) (p : positive), 0 < eps -> 0 < eps * CR_of_Q _ (1#p)) as deltaPos. { intros. apply (CRmult_lt_0_compat _ _ _ H0). apply CR_of_Q_pos. reflexivity. } assert (forall eps : CRcarrier (RealT (ElemFunc IS)), 0 < eps -> IntegralDominated (fun n : nat => Xabs (Xminus (fn n) f)) (fun n : nat => IntegrableAbs (IntegrableMinus (fnInt n) fInt)) eps) as domin. { intros eps epsPos. destruct (IntegralSupportExists _ (IntegrablePlus _ _ gInt (IntegrableAbs fInt)) _ (deltaPos eps 2%positive epsPos)) as [t [_ [tsupp tdist]]]. remember (fun x : X (ElemFunc IS) => exists xD : Domain (Xabs (Xplus g (Xabs f))) x, t <= partialApply (Xabs (Xplus g (Xabs f))) x xD) as A. destruct (Un_cv_nat_real _ _ (IntegralTruncateLimit _ (IntegrablePlus _ _ gInt (IntegrableAbs fInt))) _ (deltaPos eps 4%positive epsPos)) as [n nmaj]. apply (Build_IntegralDominated IS _ _ _ _ O _ (deltaPos eps (4 * Pos.of_nat (S n))%positive epsPos) tsupp). intros B Bmes i _ H0. apply (CRle_lt_trans _ (Integral (RestrictedIntegrable (IntegrableAbs (IntegrableMinus (fnInt i) fInt)) (MeasurableIntersectIntegrable Bmes tsupp)) + Integral (RestrictedMeasurable (IntegrableAbs (IntegrableMinus (fnInt i) fInt)) (MeasurableSetCompl _ (IntegrableMeasurable _ tsupp))))). - rewrite <- IntegralPlus; apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg, d0, d1, d2, d4, d5. rewrite (DomainProp f x d7 d3); clear d7. rewrite (DomainProp f x d6 d3); clear d6. rewrite (DomainProp _ x d5 d0); clear d5. rewrite (DomainProp _ x d4 d0); clear d4. rewrite <- CRmult_plus_distr_r. apply CRmult_le_compat_r. apply CRabs_pos. destruct d. destruct d1. destruct d2. destruct a; contradiction. rewrite CRplus_0_r. apply CRle_refl. rewrite CRplus_0_l. destruct d2. apply CRle_refl. contradict n1. intro abs. contradict n0. split; assumption. destruct d1. destruct d2. destruct a; contradiction. rewrite CRplus_0_r. apply CRlt_asym, CRzero_lt_one. rewrite CRplus_0_l. destruct d2. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. - apply (CRle_lt_trans _ (Integral (RestrictedIntegrable (IntegrablePlus _ _ gInt (IntegrableAbs fInt)) (MeasurableIntersectIntegrable Bmes tsupp)) + Integral (RestrictedMeasurable (IntegrablePlus _ _ gInt (IntegrableAbs fInt)) (MeasurableSetCompl _ (IntegrableMeasurable _ tsupp))))). apply CRplus_le_compat. + apply IntegralNonDecreasing. intros x xdf xdg. destruct xdf, xdg. rewrite applyXmult, applyXmult. rewrite (DomainProp _ x d1 d). apply CRmult_le_compat_l. simpl. destruct d. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. simpl. destruct d2, d0. apply (CRle_trans _ _ _ (CRabs_triang _ _)). apply CRplus_le_compat. apply fnle. rewrite <- CRopp_mult_distr_l, CRmult_1_l, CRabs_opp. rewrite (DomainProp f x d4 d3). apply CRle_refl. + apply IntegralNonDecreasing. intros x xdf xdg. destruct xdf, xdg. rewrite applyXmult, applyXmult. rewrite (DomainProp _ x d1 d). apply CRmult_le_compat_l. simpl. destruct d. apply CRlt_asym, CRzero_lt_one. apply CRle_refl. simpl. destruct d0, d2. rewrite <- CRopp_mult_distr_l, CRmult_1_l. apply (CRle_trans _ _ _ (CRabs_triang _ _)). apply CRplus_le_compat. apply fnle. rewrite CRabs_opp, (DomainProp f x d4 d3). apply CRle_refl. + apply (CRlt_le_trans _ (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2) + eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2))). apply CRplus_le_lt_compat. specialize (nmaj (S n) (le_S _ _ (Nat.le_refl n))). apply CRlt_asym in nmaj. rewrite CRabs_minus_sym, CRabs_right in nmaj. apply (CRplus_le_reg_r (- (MeasureSet (MeasurableIntersectIntegrable Bmes tsupp) * CR_of_Q _ (Z.of_nat (S n) #1)))). apply (CRle_trans _ (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 4))). apply (CRle_trans _ (Integral (RestrictedIntegrable (IntegrablePlus g (Xabs f) gInt (IntegrableAbs fInt)) (MeasurableIntersectIntegrable Bmes tsupp)) - Integral (RestrictedIntegrable (IntegrableMinInt (Xplus g (Xabs f)) (S n) (IntegrablePlus g (Xabs f) gInt (IntegrableAbs fInt))) (MeasurableIntersectIntegrable Bmes tsupp)))). apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. unfold MeasureSet. rewrite <- IntegralScale. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, d0. destruct d. rewrite CRmult_1_l. destruct xdg. rewrite CRmult_1_r. apply CRmin_r. contradiction. rewrite CRmult_0_l. destruct xdg. rewrite CRmult_1_r. apply CR_of_Q_le. destruct n; discriminate. rewrite CRmult_0_r. apply CRle_refl. refine (CRle_trans _ _ _ _ nmaj). rewrite <- IntegralMinus, <- IntegralMinus. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, d, d1, d0, d3, xdg, d5, d6. rewrite (DomainProp g x d3 d1), (DomainProp g x d6 d1), (DomainProp g x d5 d1), (DomainProp f x d8 d2), (DomainProp f x d7 d2), (DomainProp f x d4 d2). destruct d. destruct d0. 2: contradiction. rewrite CRmult_1_l, CRmult_1_l. apply CRle_refl. rewrite CRmult_0_l. destruct d0. contradiction. rewrite CRmult_0_l. rewrite CRmult_0_r, CRplus_0_l. rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- (CRplus_opp_r (CRmin (partialApply g x d1 + CRabs (RealT (ElemFunc IS)) (partialApply f x d2)) (INR (S n)))). apply CRplus_le_compat_r. apply CRmin_l. rewrite <- CRplus_0_r. setoid_replace (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) with (eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 4) + eps * CR_of_Q (RealT (ElemFunc IS)) (1 # 4)). rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite <- (CRplus_opp_r (MeasureSet (MeasurableIntersectIntegrable Bmes tsupp) * CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S n) # 1))). apply CRplus_le_compat_r. apply (CRmult_le_reg_r (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S n)))). apply CR_of_Q_pos. reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.of_nat (S n) # 1) * (1 # Pos.of_nat (S n)))%Q with 1%Q. rewrite CRmult_1_r, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 4) * (1 # Pos.of_nat (S n)))%Q with (1 # 4 * Pos.of_nat (S n))%Q. apply CRlt_asym, H0. reflexivity. unfold Qeq, Qmult, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l, Pos.mul_1_l. unfold Z.of_nat. rewrite Pos.of_nat_succ. reflexivity. rewrite <- CRmult_plus_distr_l. apply CRmult_morph. reflexivity. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. reflexivity. rewrite <- IntegralMinus. apply IntegralNonNeg. intros x xdf. simpl. destruct xdf, d, d0. rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- (CRplus_opp_r (CRmin (partialApply g x d0 + CRabs (RealT (ElemFunc IS)) (partialApply f x d2)) (INR (S n)))). apply CRplus_le_compat_r. rewrite (DomainProp g x d0 d), (DomainProp f x d2 d1). apply CRmin_l. refine (CRle_lt_trans _ _ _ _ tdist). apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg, d0, d1, d2, d5. destruct d. 2: rewrite CRmult_0_l; apply CRabs_pos. rewrite CRmult_1_l. destruct d2. contradiction. rewrite CRmult_0_l, CRmult_0_r, CRplus_0_r. rewrite (DomainProp g x d1 d0), (DomainProp f x d4 d3). apply CRle_abs. rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. setoid_replace ((1 # 2) + (1 # 2))%Q with 1%Q. rewrite CRmult_1_r. apply CRle_refl. reflexivity. } intro p. destruct (DominatedMeasureCvZero (fun n : nat => Xabs (Xminus (fn n) f)) (fun n => IntegrableAbs (IntegrableMinus (fnInt n) fInt)) cvZero H domin p) as [n nmaj]. exists n. intros. specialize (nmaj i H0). unfold CRminus in nmaj. rewrite CRopp_0, CRplus_0_r, CRabs_right in nmaj. refine (CRle_trans _ _ _ _ nmaj). clear nmaj. refine (CRle_trans _ _ _ _ (IntegralTriangle _ _)). rewrite (CRabs_morph _ (Integral (IntegrableMinus (fnInt i) fInt))). apply CRle_refl. rewrite <- IntegralMinus. reflexivity. apply IntegralNonNeg. intros x xdf. apply CRabs_pos. Qed. corn-8.20.0/reals/stdlib/CMTPositivity.v000066400000000000000000000535101473720167500200670ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* A lemma to simplify the proofs of Icontinuous in integration spaces. It looks classical because it does not need to give a convergence modulus. *) From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Require Import ConstructiveDiagonal. Require Import ConstructivePartialFunctions. Require Import CMTbase. Require Import CMTIntegrableFunctions. Local Open Scope ConstructiveReals. Lemma Rmult_continuous_zero {R : ConstructiveReals} (x eps : CRcarrier R) : 0 < eps -> { alpha : CRcarrier R & prod (0 < alpha) (alpha * x < eps) }. Proof. intros. destruct (CRltLinear R). destruct (s 0 x 1 (CRzero_lt_one R)). - assert (0 < x + 1). { apply (CRlt_trans _ (0 + 1)). rewrite CRplus_0_l. exact (CRzero_lt_one R). apply CRplus_lt_compat_r. exact c. } exists (eps * CRinv R (x+1) (inr H0)). split. apply CRmult_lt_0_compat. exact H. apply CRinv_0_lt_compat. exact H0. rewrite <- (CRmult_1_r eps). do 2 rewrite CRmult_assoc. apply CRmult_lt_compat_l. exact H. rewrite CRmult_1_l. apply (CRmult_lt_reg_l (x+1)). exact H0. rewrite <- CRmult_assoc, CRinv_r. rewrite CRmult_1_l, CRmult_1_r. rewrite <- (CRplus_0_r x), CRplus_assoc. apply CRplus_lt_compat_l. rewrite CRplus_0_l. exact (CRzero_lt_one R). - exists eps. split. exact H. rewrite <- (CRmult_1_r eps). rewrite CRmult_assoc. rewrite CRmult_1_l. exact (CRmult_lt_compat_l _ _ _ H c). Qed. (* Build an increasing sequence that respects sequence bound *) Fixpoint ControlSubSeqCv {R : ConstructiveReals} (un : nat -> CRcarrier R) (l : CRcarrier R) (bound : nat -> CRcarrier R) (_ : CR_cv _ un l) (_ : forall k:nat, 0 < bound k) (n : nat) { struct n } : { p : nat & CRabs _ (un p - l) < bound n }. Proof. destruct n. - intros. pose proof (Un_cv_nat_real _ l H (bound O) (H0 O)) as [p pmaj]. exists p. apply pmaj, Nat.le_refl. - intros. pose proof (Un_cv_nat_real _ l H (bound (S n)) (H0 (S n))) as [p pmaj]. exists (max p (S (let (k,_) := ControlSubSeqCv R un l bound H H0 n in k))). apply pmaj, Nat.le_max_l. Defined. Lemma ControlSubSeqCvInc : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (l : CRcarrier R) (bound : nat -> CRcarrier R) (cv : CR_cv _ un l) (boundPos : forall k:nat, 0 < bound k) (n : nat), lt (let (k,_) := ControlSubSeqCv un l bound cv boundPos n in k) (let (k,_) := ControlSubSeqCv un l bound cv boundPos (S n) in k). Proof. intros. simpl. destruct (Un_cv_nat_real un l cv (bound (S n)) (boundPos (S n))), (ControlSubSeqCv un l bound cv boundPos n). apply (Nat.lt_le_trans _ (S x0)). apply le_n_S, Nat.le_refl. apply Nat.le_max_r. Qed. Definition PrependSeq {X : Type} (x : X) (un : nat -> X) (n : nat) := match n with | O => x | S p => un p end. Lemma PrependSeqL : forall (E : FunctionRieszSpace) (f : PartialFunction (X E)) (un : nat -> PartialFunction (X E)), L E f -> (forall n:nat, L E (un n)) -> forall n:nat, L E (PrependSeq f un n). Proof. intros E f un H H0 n. unfold PrependSeq. destruct n. exact H. apply H0. Defined. Lemma PrependSeqSeries : forall {R : ConstructiveReals} (x : CRcarrier R) (un : nat -> CRcarrier R) (l : CRcarrier R), series_cv un l -> series_cv (PrependSeq x un) (x + l). Proof. intros. intros n. specialize (H n) as [p pmaj]. exists (S p). intros. destruct i. exfalso; inversion H. apply le_S_n in H. rewrite decomp_sum. simpl. setoid_replace (x + CRsum (fun i0 : nat => un i0) i - (x + l)) with (CRsum (fun i0 : nat => un i0) i - l). apply pmaj. exact H. 2: apply le_n_S, Nat.le_0_l. unfold CRminus. rewrite (CRplus_comm x). rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l. reflexivity. Qed. Lemma PosSumMaj : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (a : CRcarrier R) (k : nat), (forall n:nat, 0 <= un n) -> CRsum un k <= a -> un k <= a. Proof. destruct k. - intros. exact H0. - intros. simpl in H0. rewrite <- (CRplus_0_l (un (S k))). apply (CRle_trans _ (CRsum un k + un (S k))). apply CRplus_le_compat. apply cond_pos_sum. exact H. apply CRle_refl. exact H0. Qed. Lemma CRplus_eq_compat_l : forall {R : ConstructiveReals} (a b c : CRcarrier R), b == c -> a + b == a + c. Proof. intros. rewrite H. reflexivity. Qed. Lemma pow2inv : forall {R : ConstructiveReals} (n p:nat), CRpow (CR_of_Q R 2) n * CRpow (CR_of_Q R (1 # 2)) (n + p) == CRpow (CR_of_Q R (1 # 2)) p. Proof. induction p. - simpl. rewrite Nat.add_0_r, CRpow_mult. rewrite (CRpow_proper (CR_of_Q R 2 * CR_of_Q R (1 # 2)) 1). apply CRpow_one. rewrite <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. reflexivity. reflexivity. - rewrite Nat.add_succ_r. transitivity (CRpow (CR_of_Q R 2) n * (CR_of_Q R (1 # 2) * CRpow (CR_of_Q R (1 # 2)) (n + p))). reflexivity. rewrite <- CRmult_assoc. rewrite (CRmult_comm (CRpow (CR_of_Q R 2) n)). rewrite CRmult_assoc, IHp. reflexivity. Qed. Lemma seq_cv_le : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (l a : CRcarrier R), CR_cv R un l -> (forall n:nat, un n <= a) -> l <= a. Proof. intros. apply (CR_cv_bound_up un a l O). intros. apply H0. apply H. Qed. Lemma IcontinuousClassic : forall (E : FunctionRieszSpace) (I : forall f : PartialFunction (X E), (L E) f -> CRcarrier _) (Ihomogeneous : forall (a : CRcarrier _) (f : PartialFunction (X E)) (fL : L E f), I (Xscale a f) (LscaleStable E a f fL) == a * (I f fL)) (IadditiveIterate : forall (fn : nat -> PartialFunction (X E)) (fnL : forall n:nat, L E (fn n)) (N : nat), I (Xsum fn N) (LsumStable fn fnL N) == CRsum (fun n : nat => I (fn n) (fnL n)) N), (forall (f : PartialFunction (X E)) (fL : (L E) f), (* Usually the function Z is a plateau at 1 that contains the support of f. *) { ZL : { Z : PartialFunction (X E) & prod ((L E) Z) (nonNegFunc Z) } & forall (fn : nat -> PartialFunction (X E)) (fnL : forall n:nat, (L E) (fn n)), (forall n:nat, nonNegFunc (fn n)) -> series_cv_lim_lt (fun n => I (fn n) (fnL n)) (I f fL) -> { x : CommonPointFunSeq _ f fn | (let (Z,_) := ZL in exists xz : Domain Z (cpx _ _ _ x), partialApply Z (cpx _ _ _ x) xz == 1) /\ forall k:nat, CRsum (fun n => partialApply (fn n) (cpx _ _ _ x) (cpxFn _ _ _ x n)) k <= partialApply f (cpx _ _ _ x) (cpxF _ _ _ x) } }) -> ElemIntegralContinuous I. Proof. intros E I Ihomogeneous Iadd cont f fn fL fnL nonneg intMaj. rename cont into cont0; specialize (cont0 f); edestruct cont0 as [[Z [ZL Zpos]] cont]; clear cont0. destruct intMaj as [l [lcv lmaj]]. destruct (Rmult_continuous_zero (I Z ZL + 1) (I f fL - l)) as [alpha [alphapos alphamaj]]. rewrite <- (CRplus_opp_r l). apply CRplus_lt_compat_r, lmaj. assert (forall k : nat, (0 < (fun k0 : nat => CRpow (CR_of_Q _ (1#2)) (2 * k0 + 2)%nat * alpha) k)) as boundPos. { intro k. apply CRmult_lt_0_compat. apply CRpow_gt_zero. exact Rlt_0_half. exact alphapos. } pose (PrependSeq O (fun i => S ( let (k,_) := ControlSubSeqCv (CRsum (fun n : nat => I (fn n) (fnL n))) l (fun k => (CRpow (CR_of_Q _ (1#2)) (2*k + 2) * alpha )) lcv boundPos i in k))) as n. assert (forall k:nat, lt (n k) (n (S k))) as ninc. { intro k. unfold n, PrependSeq. destruct k. unfold ControlSubSeqCv. destruct (Un_cv_nat_real (CRsum (fun n0 : nat => I (fn n0) (fnL n0))) l lcv). apply le_n_S, Nat.le_0_l. apply le_n_S. apply (ControlSubSeqCvInc (CRsum (fun n0 : nat => I (fn n0) (fnL n0))) l (fun k0 : nat => CRpow (CR_of_Q _ (1#2)) (2 * k0 + 2) * alpha)). } (* Avoid the main mass of the series lcv, to focus on its convergence speed. Therefore seq starts at n 1. *) pose (PrependSeq (Xscale alpha Z) (weaveSequences _ fn (fun i => Xscale (CRpow (CR_of_Q _ 2) i) (Xsum (fun k => fn (n (S i) + k)%nat) (pred (n (S (S i)) - n (S i))))))) as seq. pose (PrependSeqL E (Xscale alpha Z) (weaveSequences _ fn (fun i => Xscale (CRpow (CR_of_Q _ 2) i) (Xsum (fun k => fn (n (S i) + k)%nat) (pred (n (S (S i)) - n (S i)))))) (LscaleStable E alpha Z ZL) (weaveSequencesL E fn fnL _ (fun n0 => LscaleStable E (CRpow (CR_of_Q _ 2) n0) _ (LsumStable _ (fun i => fnL _) _)))) as seqL. assert (forall k:nat, nonNegFunc (seq k)) as seqPos. { intros k x xdf. unfold seq, PrependSeq in xdf; unfold seq, PrependSeq; destruct k. rewrite applyXscale. rewrite <- (CRmult_0_r alpha). apply CRmult_le_compat_l. apply CRlt_asym, alphapos. apply Zpos. unfold weaveSequences. unfold weaveSequences in xdf. destruct (Nat.even k). apply nonneg. rewrite applyXscale. rewrite <- (CRmult_0_r (CRpow (CR_of_Q _ 2) (k/2))). apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. apply nonNegSumFunc. intros. apply nonneg. } destruct (cont seq seqL seqPos) as [x xgood]. - destruct (series_cv_maj (fun i : nat => CRpow (CR_of_Q _ 2) i * (CRsum (fun k => I (fn (n (S i) + k)%nat) (fnL (n (S i) + k)%nat)) (pred (n (S (S i)) - n (S i))))) (fun i => CRpow (CR_of_Q _ (1#2)) (S i) * alpha) alpha). + intros. rewrite CRabs_mult. rewrite CRabs_right. destruct (n (S n0)) eqn:des. exfalso; pose proof (ninc n0); rewrite des in H; inversion H. pose proof (sum_assoc (fun k => I (fn k) (fnL k)) n1 (Init.Nat.pred (n (S (S n0)) - S n1))). apply (CRplus_eq_compat_l (-CRsum (fun k : nat => I (fn k) (fnL k)) n1)) in H. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l in H. rewrite <- H. clear H. replace (S n1 + pred (n (S (S n0)) - S n1))%nat with (pred (n (S (S n0)))). setoid_replace (- CRsum (fun k : nat => I (fn k) (fnL k)) n1 + CRsum (fun k : nat => I (fn k) (fnL k)) (pred (n (S (S n0))))) with (l - CRsum (fun k : nat => I (fn k) (fnL k)) n1 + (CRsum (fun k : nat => I (fn k) (fnL k)) (pred (n (S (S n0)))) - l)). apply (CRle_trans _ (CRpow (CR_of_Q _ 2) n0 * (CRabs _ (l - CRsum (fun k : nat => I (fn k) (fnL k)) n1) + CRabs _ (CRsum (fun k : nat => I (fn k) (fnL k)) (pred (n (S (S n0)))) - l)))). apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. apply CRabs_triang. rewrite CRmult_plus_distr_l. apply (CRle_trans _ ((CRpow (CR_of_Q _ 2) n0) * CRpow (CR_of_Q _ (1#2)) (2 * n0 + 2) * alpha + (CRpow (CR_of_Q _ 2) n0) * CRpow (CR_of_Q _ (1#2)) (2 * (S n0) + 2) * alpha)). apply CRplus_le_compat. rewrite CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. replace n1 with (pred (n (S n0))). 2: rewrite des; reflexivity. unfold n, PrependSeq, proj1_sig, pred. destruct (ControlSubSeqCv (CRsum (fun n2 : nat => I (fn n2) (fnL n2))) l (fun k : nat => CRpow (CR_of_Q _ (1#2)) (2 * k + 2) * alpha) lcv boundPos n0). apply CRlt_asym. rewrite CRabs_minus_sym. exact c. rewrite CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. unfold n, PrependSeq, proj1_sig, pred. destruct (ControlSubSeqCv (CRsum (fun n2 : nat => I (fn n2) (fnL n2))) l (fun k : nat => CRpow (CR_of_Q _ (1#2)) (2 * k + 2) * alpha) lcv boundPos (S n0)). apply CRlt_asym, c. rewrite <- CRmult_plus_distr_r. apply CRmult_le_compat_r. apply CRlt_asym, alphapos. replace (2 * n0 + 2)%nat with (n0 + (1 + S n0))%nat. rewrite pow2inv. replace (2 * S n0 + 2)%nat with (n0 + (3 + S n0))%nat. rewrite pow2inv. rewrite <- (CRmult_1_l (CRpow (CR_of_Q _ (1 # 2)) (S n0))). apply (CRle_trans _ (CR_of_Q _ (1 # 2) * CRpow (CR_of_Q _ (1 # 2)) (S n0) + CR_of_Q _ (1 # 2) * (CR_of_Q _ (1 # 2) * (CR_of_Q _ (1 # 2) * CRpow (CR_of_Q _ (1 # 2)) (S n0))))). apply CRle_refl. do 2 rewrite <- CRmult_assoc. rewrite <- CRmult_plus_distr_r. apply CRmult_le_compat_r. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult, <- CR_of_Q_mult, <- CR_of_Q_plus. apply CR_of_Q_le. discriminate. rewrite Nat.add_comm. simpl. apply f_equal. rewrite <- (Nat.add_comm (S (n0 + 0))). simpl. apply f_equal. rewrite Nat.add_0_r. rewrite <- (Nat.add_comm 2). reflexivity. simpl. rewrite <- Nat.add_assoc. apply f_equal2. reflexivity. rewrite Nat.add_0_r, Nat.add_comm. reflexivity. unfold CRminus. rewrite (CRplus_comm l), CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. do 2 rewrite <- Nat.sub_1_r. rewrite Nat.add_sub_assoc. rewrite Nat.add_comm, Nat.sub_add. reflexivity. rewrite <- des. apply (Nat.le_trans _ (S (n (S n0)))). apply le_S, Nat.le_refl. exact (ninc (S n0)). rewrite <- des. apply Nat.le_add_le_sub_r. apply ninc. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. + apply (CR_cv_proper _ (1*alpha)). apply series_cv_scale. apply (series_cv_eq (fun n0 : nat => CRpow (CR_of_Q _ (1 # 2)) n0 * CR_of_Q _ (1#2))). intros. apply CRmult_comm. apply (CR_cv_proper _ (CR_of_Q _ 2 * CR_of_Q _ (1#2))). apply series_cv_scale, GeoHalfTwo. rewrite <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. reflexivity. reflexivity. apply CRmult_1_l. + clear cont. exists (alpha * I Z ZL + (l + x)). destruct p. split. apply (series_cv_eq (PrependSeq (alpha * (I Z ZL)) (weaveSequences (CRcarrier _) (fun k => I (fn k) (fnL k)) (fun i => CRpow (CR_of_Q _ 2) i * (CRsum (fun k => I (fn (n (S i) + k)%nat) (fnL (n (S i) + k)%nat)) (pred (n (S (S i)) - n (S i)))))))). intros. unfold seq, PrependSeq. destruct n0. simpl. rewrite Ihomogeneous. reflexivity. unfold seqL, weaveSequences, weaveSequencesL, PrependSeqL. clear seqL seqPos seq. destruct (Nat.even n0). reflexivity. rewrite Ihomogeneous, Iadd. reflexivity. apply PrependSeqSeries. apply weaveInfiniteSums. exact lcv. exact s. apply (CRplus_lt_reg_l _ (-l)). rewrite (CRplus_comm (alpha*I Z ZL)), <- CRplus_assoc, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. apply (CRle_lt_trans _ (alpha * I Z ZL + alpha)). rewrite CRplus_comm. apply CRplus_le_compat_l. exact c. rewrite CRmult_plus_distr_l, CRmult_1_r in alphamaj. rewrite (CRplus_comm (-l)). exact alphamaj. - destruct x as [x xf xseqn]. assert (forall n : nat, Domain (fn n) x) as xfn. { intro k. exact (domainWeaveEvenInc _ _ _ k x (xseqn (S (k * 2)))). } exists (Build_CommonPointFunSeq _ (X E) f fn x xf xfn). unfold cpx, cpxFn, cpxF. unfold cpx, cpxF, cpxFn in xgood. destruct xgood. (* Get the initial mass back *) destruct (series_cv_maj (fun i : nat => CRsum (fun k : nat => partialApply (fn (k + n i)%nat) x (xfn (k + n i)%nat)) (n (S i) - n i - 1)) (PrependSeq (CRsum (fun k:nat => partialApply (fn (k + n 0)%nat) x (xfn (k + n 0)%nat)) (n 1 - 1)%nat) (fun j => CRpow (CR_of_Q _ (1#2)) j * (partialApply f x xf))) (CRsum (fun k:nat => partialApply (fn (k + n 0)%nat) x (xfn (k + n 0)%nat)) (n 1 - 1)%nat + CR_of_Q _ 2 * partialApply f x xf)). + clear seqL. intros. rewrite CRabs_right. 2: apply cond_pos_sum; intros; apply nonneg. unfold PrependSeq. destruct n0. apply CRle_refl. apply (PosSumMaj _ (partialApply f x xf) (S (S (2*n0)))) in H0. 2: intros; apply seqPos. unfold pred, seq, PrependSeq in H0. rewrite Nat.mul_comm in H0. rewrite <- (partialApplyWeaveOdd (X E) fn _ _ x (domainWeaveOddInc (X E) fn _ n0 x (xseqn (S (S (n0 * 2)))))) in H0. rewrite applyXscale in H0. rewrite (applyXsum _ _ _ _ (fun k => xfn (n (S n0) + k)%nat)) in H0. intro abs. rewrite <- (Nat.add_0_r n0) in abs. apply (CRmult_lt_compat_l (CRpow (CR_of_Q _ 2) n0)) in abs. rewrite <- CRmult_assoc, pow2inv in abs. apply H0. apply (CRle_lt_trans _ (CRpow (CR_of_Q _ (1 # 2)) 0 * partialApply f x xf)). unfold CRpow. rewrite CRmult_1_l. apply CRle_refl. apply (CRlt_le_trans _ _ _ abs). apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt; reflexivity. rewrite <- Nat.sub_1_r. rewrite Nat.add_0_r. apply sum_Rle. intros. rewrite Nat.add_comm. apply CRle_refl. apply CRpow_gt_zero. apply CR_of_Q_lt. reflexivity. + apply PrependSeqSeries, series_cv_scale, GeoHalfTwo. + clear seqL. destruct p as [i _]. pose proof (infinite_sum_assoc _ n x0 ninc (fun k => nonneg k x (xfn k)) (eq_refl _) i). exists x0. split. exact H1. apply (CRle_lt_trans _ (partialApply f x xf - alpha)). apply (CRplus_le_reg_l alpha). rewrite <- (CRplus_comm (partialApply f x xf - alpha)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (seq_cv_le (CRsum (PrependSeq alpha (fun k => partialApply (fn k) x (xfn k))))). apply PrependSeqSeries. exact H1. intros. specialize (H0 (2*n0)%nat). apply (CRle_trans _ (CRsum (fun n : nat => partialApply (seq n) x (xseqn n)) (2 * n0))). 2: exact H0. destruct n0. unfold CRsum. simpl. destruct H. rewrite (DomainProp Z x _ x1), H, CRmult_1_r. apply CRle_refl. rewrite decomp_sum. rewrite (decomp_sum (fun n1 : nat => partialApply (seq n1) x (xseqn n1))). unfold seq, PrependSeq. apply CRplus_le_compat. destruct H. rewrite applyXscale, (DomainProp Z x _ x1), H, CRmult_1_r. apply CRle_refl. simpl (pred (S n0)). replace (pred (2 * S n0)) with (S (2*n0)). 2: simpl; rewrite Nat.add_succ_r; reflexivity. rewrite (CRsum_eq _ (weaveSequences (CRcarrier _) (fun i => partialApply (fn i) x (xfn i)) (fun i => CRpow (CR_of_Q _ 2) i * (CRsum (fun k => partialApply (fn (n (S i) + k)%nat) x (xfn (n (S i) + k)%nat)) (pred (n (S (S i)) - n (S i))) ))) (S (2 * n0))). rewrite weaveSequencesSum. rewrite <- (CRplus_0_r (CRsum (fun i0 : nat => partialApply (fn i0) x (xfn i0)) n0)). apply CRplus_le_compat. rewrite <- (Nat.mul_comm n0). pose proof (Nat.div_add 1 n0 2). simpl in H2. simpl. rewrite H2. apply CRle_refl. auto. apply cond_pos_sum. intros. rewrite <- (CRmult_0_r (CRpow (CR_of_Q _ 2) k)). apply CRmult_le_compat_l. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt; reflexivity. apply cond_pos_sum. intros. apply nonneg. intros. rewrite (partialApplyWeave (X E) fn _ i0 x (xfn (i0/2)%nat) (domainWeaveOddInc (X E) fn _ (i0/2) x (xseqn (S (S ((i0/2) * 2))))) (xseqn (S i0))). unfold weaveSequences. destruct (Nat.even i0). reflexivity. rewrite applyXscale. apply CRmult_morph. reflexivity. apply applyXsum. apply le_n_S, Nat.le_0_l. apply le_n_S, Nat.le_0_l. rewrite <- (CRplus_0_r (partialApply f x xf)). unfold CRminus. rewrite CRplus_assoc. apply CRplus_lt_compat_l. apply (CRplus_lt_reg_l _ alpha). rewrite CRplus_0_l, CRplus_opp_r, CRplus_0_r. exact alphapos. Qed. corn-8.20.0/reals/stdlib/CMTProductIntegral.v000066400000000000000000003012031473720167500210050ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Product of two integration spaces and Fubini's theorem. As a naive approach, we can think of taking linear combinations of products of integrable functions as L-functions, and I linear. However this fails to be stable stability under absolute value. We work around this problem by taking products of integrable characteristic functions, which linear combinations can be split on disjoint rectangles. Then we can take the absolute of those disjoint coefficients. *) From Coq Require Import ZArith QArith_base. From Coq Require Import List. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveRealsMorphisms. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveLimits. Require Import ConstructivePartialFunctions. Require Import CMTbase. Require Import CMTIntegrableFunctions. Require Import CMTIntegrableSets. Require Import CMTFullSets. Require Import CMTcast. Require Import CMTprofile. Local Open Scope ConstructiveReals. (* An element of a product L-function, ie a product of integrable sets, multiplied by a real number. Its elementary integral is the product of measures, multiplied by the real number. *) Record ProdIntegrable {I J : IntegrationSpace} : Type := { prodint_f : X (ElemFunc I) -> Prop; prodint_g : X (ElemFunc J) -> Prop; prodint_factor : CRcarrier (RealT (ElemFunc I)); prodint_fint : IntegrableSet prodint_f; prodint_gint : IntegrableSet prodint_g; }. (* Tensor product of prodint_f and prodint_g. *) Definition ProdIntegrableFunc {I J : IntegrationSpace} (fg : @ProdIntegrable I J) : @PartialFunction (RealT (ElemFunc I)) (* Convert in the first real type. *) (prod (X (ElemFunc I)) (X (ElemFunc J))). Proof. apply (Build_PartialFunctionXY (prod (X (ElemFunc I)) (X (ElemFunc J))) (CRcarrier (RealT (ElemFunc I))) (CReq (RealT (ElemFunc I))) (* This domain is smaller than just deciding the rectangle, because we decide both coordinates. It is necessary to subdivide a union of rectangles into a disjoint grid of rectangles. See ProdIntegrableSimplify below. *) (fun xy => prod (Domain (CharacFunc (prodint_f fg)) (fst xy)) (Domain (@CharacFunc (RealT (ElemFunc I)) _ (prodint_g fg)) (snd xy))) (fun xy xyD => prodint_factor fg * partialApply _ (fst xy) (fst xyD) * partialApply _ (snd xy) (snd xyD))). intros [x y] p q. destruct p,q; simpl. do 2 rewrite CRmult_assoc. apply CRmult_morph. reflexivity. destruct d,d0,d1,d2; try reflexivity; try contradiction. Defined. (* A product L-function, ie a linear combination of ProdIntegrable. *) Definition ProdLFunc {I J : IntegrationSpace} : list (@ProdIntegrable I J) -> PartialFunction (prod (X (ElemFunc I)) (X (ElemFunc J))) := fun l => XsumList (map ProdIntegrableFunc l). Definition ProdIntegrableZero (I J : IntegrationSpace) : @ProdIntegrable I J. Proof. apply (Build_ProdIntegrable I J (fun x => False) (fun y => False) 0). - apply (IntegrableFunctionExtensional (Xconst (X (ElemFunc I)) 0)). split. + intros x _. right. intro abs. contradiction. + intros. simpl. destruct xG. contradiction. reflexivity. + apply IntegrableZero. - apply (IntegrableFunctionExtensional (Xconst (X (ElemFunc J)) 0)). split. + intros x _. right. intro abs. contradiction. + intros. simpl. destruct xG. contradiction. reflexivity. + apply IntegrableZero. Defined. Lemma DomainProdLFuncInc : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyS : Domain (ProdLFunc hn) (x,y)) (n : nat), lt n (length hn) -> Domain (ProdIntegrableFunc (nth n hn (ProdIntegrableZero I J))) (x,y). Proof. induction hn. - intros. exfalso; inversion H. - intros. simpl in H. destruct n. + apply xyS. + apply le_S_n in H. simpl. apply (IHhn x y). apply xyS. exact H. Qed. Lemma DomainProdLFuncIncReverse : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), (forall n:nat, lt n (length hn) -> Domain (ProdIntegrableFunc (nth n hn (ProdIntegrableZero I J))) (x,y)) -> Domain (ProdLFunc hn) (x,y). Proof. induction hn. - intros. simpl. trivial. - intros x y H. split. + apply (H O). apply le_n_S, Nat.le_0_l. + apply IHhn. intros. apply le_n_S in H0. exact (H (S n) H0). Qed. Lemma DomainProdLFuncAppLeft : forall {I J : IntegrationSpace} (l k : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), Domain (ProdLFunc (l ++ k)) (x,y) -> Domain (ProdLFunc l) (x, y). Proof. induction l. - intros. simpl. trivial. - intros k x y H. destruct H. split. exact d. exact (IHl k x y d0). Qed. Lemma DomainProdLFuncAppRight : forall {I J : IntegrationSpace} (l k : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), Domain (ProdLFunc (l ++ k)) (x,y) -> Domain (ProdLFunc k) (x, y). Proof. induction l. - intros l x y H. exact H. - intros k x y H. destruct H. exact (IHl k x y d0). Qed. Lemma ApplyProdLFuncApp : forall {I J : IntegrationSpace} (l k : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyL : Domain (ProdLFunc l) (x,y)) (xyK : Domain (ProdLFunc k) (x,y)) (xyDS : Domain (ProdLFunc (l ++ k)) (x,y)), partialApply (ProdLFunc (l ++ k)) (x, y) xyDS == partialApply (ProdLFunc l) (x,y) xyL + partialApply (ProdLFunc k) (x,y) xyK. Proof. induction l as [|a l]. - intros. simpl (partialApply (ProdLFunc nil) (x, y) xyL). rewrite CRplus_0_l. apply DomainProp. - intros. simpl. destruct xyDS, d, xyL, d2. simpl. rewrite CRplus_assoc. apply CRplus_morph. + destruct d. destruct d2. 2: contradiction. destruct d1. destruct d4. 2: contradiction. reflexivity. destruct d4. contradiction. reflexivity. rewrite CRmult_0_r, CRmult_0_l. destruct d2. contradiction. rewrite CRmult_0_r, CRmult_0_l. reflexivity. + apply IHl. Qed. (* A product L-function is simple when its sum is on disjoint rectangles. But more convenient to sum on a disjoint grid. *) (* Computes a list of size 2^n, of lists of size n, with all possible combinations. Will be used to sum on all subsets later. We could also have used natural numbers to represent subset, with their binary digits as the lists of bool. *) Fixpoint FreeSubsets (n : nat) : list (list bool) := match n with | O => nil :: nil | S p => map (fun l => true :: l) (FreeSubsets p) ++ map (fun l => false :: l) (FreeSubsets p) end. Lemma FreeSubsetsNotNil : forall n : nat, FreeSubsets n <> nil. Proof. induction n. - discriminate. - simpl. intro abs. apply app_eq_nil in abs. destruct abs. apply map_eq_nil in H. exact (IHn H). Qed. Lemma FreeSubsetsLength : forall (n : nat) (l : list bool), In l (FreeSubsets n) -> length l = n. Proof. induction n. - intros. destruct H. subst l. reflexivity. exfalso; inversion H. - intros. simpl in H. apply in_app_or in H. destruct H. + apply in_map_iff in H. destruct H as [k [H H0]]. subst l. simpl. rewrite (IHn k). reflexivity. exact H0. + apply in_map_iff in H. destruct H as [k [H H0]]. subst l. simpl. rewrite (IHn k). reflexivity. exact H0. Qed. (* Produce a membership proposition in sort Type. This is actually the reading of l as the binary digits of the number k. *) Lemma FreeSubsetsFull : forall l : list bool, { k : nat | lt k (length (FreeSubsets (length l))) /\ nth k (FreeSubsets (length l)) nil = l }. Proof. induction l as [|a l]. - exists O. split. apply Nat.le_refl. reflexivity. - simpl. destruct IHl as [k [H H0]]. destruct a. + exists k. split. rewrite app_length, map_length, map_length. apply (Nat.lt_le_trans _ (0+length (FreeSubsets (length l)))). exact H. rewrite <- Nat.add_le_mono_r. apply Nat.le_0_l. rewrite app_nth1. rewrite (nth_indep _ nil (true::nil)), map_nth, H0. reflexivity. rewrite map_length. exact H. rewrite map_length. exact H. + exists (k + length (FreeSubsets (length l)))%nat. split. rewrite app_length, map_length, map_length. rewrite <- Nat.add_lt_mono_r. exact H. rewrite app_nth2. rewrite map_length, Nat.add_sub. rewrite (nth_indep _ nil (false::nil)), map_nth, H0. reflexivity. rewrite map_length. exact H. rewrite map_length. apply (Nat.le_trans _ (0+length (FreeSubsets (length l)))). apply Nat.le_refl. rewrite <- Nat.add_le_mono_r. apply Nat.le_0_l. Qed. Lemma FreeSubsetsDifferent : forall (n p q : nat), p <> q -> lt p (length (FreeSubsets n)) -> lt q (length (FreeSubsets n)) -> nth p (FreeSubsets n) nil <> nth q (FreeSubsets n) nil. Proof. induction n. - intros. exfalso. simpl in H0. simpl in H1. destruct p,q. exact (H eq_refl). apply le_S_n in H1. inversion H1. apply le_S_n in H0. inversion H0. apply le_S_n in H1. inversion H1. - intros. simpl. destruct (le_lt_dec (length (FreeSubsets n)) p), (le_lt_dec (length (FreeSubsets n)) q). + rewrite app_nth2. 2: rewrite map_length; exact l. rewrite app_nth2. 2: rewrite map_length; exact l0. rewrite map_length. assert (q - length (FreeSubsets n) < length (FreeSubsets n))%nat. { rewrite (Nat.add_lt_mono_r _ _ (length (FreeSubsets n))). rewrite Nat.sub_add. 2: exact l0. simpl in H1. rewrite app_length, map_length, map_length in H1. exact H1. } assert (p - length (FreeSubsets n) < length (FreeSubsets n))%nat. { rewrite (Nat.add_lt_mono_r _ _ (length (FreeSubsets n))). rewrite Nat.sub_add. 2: exact l. simpl in H0. rewrite app_length, map_length, map_length in H0. exact H0. } specialize (IHn (p - length (FreeSubsets n))%nat (q - length (FreeSubsets n))%nat). rewrite (nth_indep _ nil (false::nil)), (nth_indep _ nil (false::nil)). rewrite map_nth, map_nth. 2: rewrite map_length; exact H2. 2: rewrite map_length; exact H3. intro abs. inversion abs. apply IHn. 2: exact H3. 2: exact H2. 2: exact H5. intro abs2. assert ((p - length (FreeSubsets n) + length (FreeSubsets n))%nat = (q - length (FreeSubsets n) + length (FreeSubsets n))%nat). { rewrite abs2. reflexivity. } do 2 rewrite Nat.sub_add in H4. contradiction. exact l0. exact l. exact l. + clear IHn. rewrite app_nth2. 2: rewrite map_length; exact l. rewrite app_nth1. 2: rewrite map_length; exact l0. rewrite map_length. rewrite (nth_indep _ nil (false::nil)), (nth_indep _ nil (true::nil)). rewrite map_nth, map_nth. intro abs. inversion abs. rewrite map_length. exact l0. rewrite map_length. rewrite (Nat.add_lt_mono_r _ _ (length (FreeSubsets n))). rewrite Nat.sub_add. 2: exact l. simpl in H0. rewrite app_length, map_length, map_length in H0. exact H0. + clear IHn. rewrite app_nth1. 2: rewrite map_length; exact l. rewrite app_nth2. 2: rewrite map_length; exact l0. rewrite map_length. rewrite (nth_indep _ nil (true::nil)), (nth_indep _ nil (false::nil)). rewrite map_nth, map_nth. intro abs. inversion abs. rewrite map_length. rewrite (Nat.add_lt_mono_r _ _ (length (FreeSubsets n))). rewrite Nat.sub_add. 2: exact l0. simpl in H1. rewrite app_length, map_length, map_length in H1. exact H1. rewrite map_length. exact l. + rewrite app_nth1. 2: rewrite map_length; exact l. rewrite app_nth1. 2: rewrite map_length; exact l0. rewrite (nth_indep _ nil (true::nil)), (nth_indep _ nil (true::nil)). rewrite map_nth, map_nth. intro abs. inversion abs. apply (IHn p q H l l0). exact H3. rewrite map_length. exact l0. rewrite map_length. exact l. Qed. Definition ProdIntegrableDisjoint {I J : IntegrationSpace} (h k : ProdIntegrable) : Prop := forall (x : X (ElemFunc I)) (y : X (ElemFunc J)), ~(prodint_f h x /\ prodint_f k x /\ prodint_g h y /\ prodint_g k y). (* Equivalent to forall i,j < length l, i < j -> P (l i) (l j) *) Fixpoint forall_disjoint_pairs { X : Type } (l : list X) (P : X -> X -> Prop) : Prop := match l with | nil => True | h::t => forall_disjoint_pairs t P /\ Forall (P h) t end. Lemma forall_disjoint_pairs_equiv : forall { X : Type } (l : list X) (P : X -> X -> Prop) (x : X), (forall i j : nat, lt i j -> lt j (length l) -> P (nth i l x) (nth j l x)) -> forall_disjoint_pairs l P. Proof. induction l. - intros. constructor. - intros. split. + apply (IHl P x). intros. apply (H (S i) (S j)). apply le_n_S, H0. apply le_n_S, H1. + clear IHl. apply Forall_forall. intros. apply (In_nth _ _ a) in H0. destruct H0 as [n [H0 H1]]. subst x0. specialize (H O (S n)). simpl in H. rewrite (nth_indep _ a x). apply H. apply le_n_S, Nat.le_0_l. apply le_n_S, H0. exact H0. Qed. Definition ProdIntegrableSimple {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) : Prop := forall_disjoint_pairs hn ProdIntegrableDisjoint. Definition SubsetUnion {A : Set} (hn : list (A -> Prop)) : A -> Prop := fold_right (fun fg acc x => fg x \/ acc x) (fun x => False) hn. Lemma SubsetUnionLeftDec : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), (SubsetUnion (map prodint_f hn) x /\ ~Forall (fun fg => ~prodint_f fg x) hn) \/ (Forall (fun fg => ~prodint_f fg x) hn /\ ~SubsetUnion (map prodint_f hn) x). Proof. induction hn. - intros. right. split. apply Forall_nil. intro abs. exact abs. - intros. destruct xyH. destruct (IHhn x y d0). + left. split. right. apply H. intro abs. inversion abs. destruct H. contradiction. + simpl. destruct d, d. left. split. left. exact p. intro abs. inversion abs. destruct H. contradiction. right. split. apply Forall_cons. exact n. apply H. intro abs. destruct abs. contradiction. destruct H. contradiction. Qed. (* Intersection of init and hn, inside or outside according to filter. *) Fixpoint SubsetIntersectFilter { A : Set } (hn : list (A -> Prop)) (init : A -> Prop) (filter : list bool) : A -> Prop := match filter with | nil => init | b :: sub => match hn with | nil => init | p :: h => if b then fun x => p x /\ SubsetIntersectFilter h init sub x else fun x => SubsetIntersectFilter h init sub x /\ ~p x end end. Lemma SubsetIntersectFilterInc : forall { A : Set } (hn : list (A -> Prop)) (init biginit : A -> Prop) (filter : list bool) (x : A), (forall y:A, init y -> biginit y) -> SubsetIntersectFilter hn init filter x -> SubsetIntersectFilter hn biginit filter x. Proof. induction hn. - intros. simpl. simpl in H0. destruct filter. apply H, H0. apply H, H0. - intros. destruct filter. simpl. apply H, H0. simpl. simpl in H0. destruct b. split. apply H0. apply (IHhn init). exact H. apply H0. split. apply (IHhn init). exact H. apply H0. intro abs. destruct H0. contradiction. Qed. Definition SubsetIntersectLeft {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (init : X (ElemFunc I) -> Prop) (filter : list bool) : X (ElemFunc I) -> Prop := SubsetIntersectFilter (map prodint_f hn) init filter. Lemma SubsetIntersectFilter_init : forall { A : Set } (hn : list (A -> Prop)) (init : A -> Prop) (filter : list bool) (x : A), SubsetIntersectFilter hn init filter x -> init x. Proof. induction hn. - intros. destruct filter; exact H. - intros. destruct filter. exact H. simpl in H. destruct b; apply (IHhn init filter), H. Qed. Lemma SubsetUnionLeftIntegrable : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)), IntegrableSet (SubsetUnion (map prodint_f hn)). Proof. induction hn. - apply (IntegrableFunctionExtensional (Xconst (X (ElemFunc I)) 0)). split. + intros x _. right. intro abs. contradiction. + intros. simpl. destruct xG. contradiction. reflexivity. + apply IntegrableZero. - apply IntegrableSetUnion. apply a. apply IHhn. Qed. Lemma SubsetIntersectLeftIntegrable : forall {I J : IntegrationSpace} (subset : list bool) (init : X (ElemFunc I) -> Prop) (hn : list (@ProdIntegrable I J)), IntegrableSet init -> IntegrableSet (SubsetIntersectLeft hn init subset). Proof. induction subset as [|a subset]. - intros init hn initInt. destruct hn; exact initInt. - intros. simpl. destruct hn as [|p hn]. exact X. destruct a. apply IntegrableSetIntersect. apply p. apply IHsubset. exact X. apply IntegrableSetDifference. apply IHsubset. exact X. apply p. Qed. Lemma SubsetUnionRightDec : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), (SubsetUnion (map prodint_g hn) y /\ ~Forall (fun fg => ~prodint_g fg y) hn) \/ (Forall (fun fg => ~prodint_g fg y) hn /\ ~SubsetUnion (map prodint_g hn) y). Proof. induction hn. - intros. right. split. apply Forall_nil. intro abs. exact abs. - intros. destruct xyH. destruct (IHhn x y d0). + left. split. right. apply H. intro abs. inversion abs. destruct H. contradiction. + simpl. destruct d, d1. left. split. left. exact p. intro abs. inversion abs. destruct H. contradiction. right. split. apply Forall_cons. exact n. apply H. intro abs. destruct abs. contradiction. destruct H. contradiction. Qed. Definition SubsetIntersectRight {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (init : X (ElemFunc J) -> Prop) (filter : list bool) : X (ElemFunc J) -> Prop := SubsetIntersectFilter (map prodint_g hn) init filter. Lemma SubsetUnionRightIntegrable : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)), IntegrableSet (SubsetUnion (map prodint_g hn)). Proof. induction hn. - apply (IntegrableFunctionExtensional (Xconst (X (ElemFunc J)) 0)). split. + intros x _. right. intro abs. contradiction. + intros. simpl. destruct xG. contradiction. reflexivity. + apply IntegrableZero. - apply IntegrableSetUnion. apply a. apply IHhn. Qed. Lemma SubsetIntersectRightIntegrable : forall {I J : IntegrationSpace} (subset : list bool) (init : X (ElemFunc J) -> Prop) (hn : list (@ProdIntegrable I J)), IntegrableSet init -> IntegrableSet (SubsetIntersectRight hn init subset). Proof. induction subset as [|a subset]. - intros init hn initInt. destruct hn; exact initInt. - intros. simpl. destruct hn as [|p hn]. exact X. destruct a. apply IntegrableSetIntersect. apply p. apply IHsubset. exact X. apply IntegrableSetDifference. apply IHsubset. exact X. apply p. Qed. (* Sum all factors that are activated by subsetf and subsetg. *) Fixpoint SubsetIntersectFactor {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (subsetf subsetg : list bool) {struct subsetf} : CRcarrier (RealT (ElemFunc I)) := match subsetf, subsetg, hn with | sf::tf, sg::tg, h::t => SubsetIntersectFactor t tf tg + (if andb sf sg then prodint_factor h else 0) | _, _, _ => 0 end. (* If subsetf or subsetg is all false, the intersection of the corresponding complements can be not integrable. Bound it by the union of the subsets. *) Definition ProdSubsetIntersect {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (subsetf subsetg : list bool) : @ProdIntegrable I J. Proof. (* When the subsets are all false, it means the domain outside all of hn which is not necessarily integrable, but then it is assigned the coefficient zero. *) intros. apply (Build_ProdIntegrable I J (SubsetIntersectLeft hn (SubsetUnion (map prodint_f hn)) subsetf) (SubsetIntersectRight hn (SubsetUnion (map prodint_g hn)) subsetg) (SubsetIntersectFactor hn subsetf subsetg)). apply SubsetIntersectLeftIntegrable. apply SubsetUnionLeftIntegrable. apply SubsetIntersectRightIntegrable. apply SubsetUnionRightIntegrable. Defined. Lemma nth_list_prod : forall {A B : Type} (l:list A) (k:list B) (a:A) (b:B) (n:nat), lt n (length l * length k) -> nth n (list_prod l k) (a,b) = (nth (n / length k) l a, nth (n mod (length k)) k b). Proof. induction l. - intros. exfalso; inversion H. - intros. destruct (le_lt_dec (length k) n). + assert (n - length k < length l * length k)%nat. { rewrite (Nat.add_lt_mono_r _ _ (length k)), Nat.sub_add. 2: exact l0. rewrite Nat.add_comm. exact H. } specialize (IHl k a0 b (n - length k)%nat H0). clear H. simpl (list_prod (a :: l) k). rewrite app_nth2. 2: rewrite map_length; exact l0. rewrite map_length. rewrite IHl. pose proof (Nat.le_exists_sub (length k) n l0) as [i [H _]]. subst n. rewrite Nat.add_sub. apply f_equal2. replace ((i + length k) / length k)%nat with (S (i / length k))%nat. reflexivity. replace (i + length k)%nat with (i + 1*length k)%nat. rewrite Nat.div_add. rewrite Nat.add_comm. reflexivity. 2: rewrite Nat.mul_1_l; reflexivity. intro abs. rewrite Nat.add_sub, abs, Nat.mul_0_r in H0. inversion H0. replace (i + length k)%nat with (i + 1*length k)%nat. rewrite Nat.mod_add. reflexivity. intro abs. rewrite Nat.add_sub, abs, Nat.mul_0_r in H0. inversion H0. rewrite Nat.mul_1_l. reflexivity. + clear IHl. simpl (list_prod (a :: l) k). rewrite app_nth1. 2: rewrite map_length; exact l0. rewrite Nat.div_small, Nat.mod_small. 2: exact l0. 2: exact l0. simpl. rewrite (nth_indep _ (a0,b) (a,b)). rewrite map_nth. reflexivity. rewrite map_length. exact l0. Qed. Lemma DomainProdSubsetIntersect : forall {A : Set} (hn : list (A -> Prop)) (init : A -> Prop) (l : list bool) (x : A) (n : nat), SubsetIntersectFilter hn init l x -> match nth_error hn n, nth_error l n with | Some fg, Some b => if b then fg x else ~fg x | _, _ => True end. Proof. induction hn. - intros. destruct n; simpl; trivial. - intros. destruct n. + simpl. destruct l as [|b l]. trivial. destruct b; apply H. + simpl. destruct l as [|b l]. destruct (nth_error hn n); trivial. apply (IHhn init l). simpl in H. destruct b; apply H. Qed. Lemma SubsetsDifferent : forall (h k : list bool), length h = length k -> h <> k -> { n : nat | lt n (length h) /\ nth_error h n <> nth_error k n }. Proof. induction h. - intros. exfalso. destruct k. exact (H0 eq_refl). inversion H. - intros. destruct k. exfalso; inversion H. simpl in H. inversion H. clear H. destruct a, b. + destruct (IHh k H2) as [n [nlen ndiff]]. intro abs. subst k. exact (H0 eq_refl). exists (S n). split. apply le_n_S, nlen. exact ndiff. + exists O. split. apply le_n_S, Nat.le_0_l. simpl. discriminate. + exists O. split. apply le_n_S, Nat.le_0_l. simpl. discriminate. + destruct (IHh k H2) as [n [nlen ndiff]]. intro abs. subst k. exact (H0 eq_refl). exists (S n). split. apply le_n_S, nlen. exact ndiff. Qed. Lemma ProdIntegrableSubsetsDisjoint : forall {A : Set} (hn : list (A -> Prop)) (l l0 : list bool) (x : A), length l = length l0 -> length l = length hn -> l <> l0 -> ~ (SubsetIntersectFilter hn (SubsetUnion hn) l x /\ SubsetIntersectFilter hn (SubsetUnion hn) l0 x). Proof. intros. simpl. intros [H2 H3]. pose proof (SubsetsDifferent l l0 H H1) as [n [nlen ndiff]]. pose proof (DomainProdSubsetIntersect hn (SubsetUnion hn) l x n H2). pose proof (DomainProdSubsetIntersect hn (SubsetUnion hn) l0 x n H3). destruct (nth_error hn n) eqn:des. destruct (nth_error l n) eqn:desl. destruct (nth_error l0 n) eqn:des0. destruct b. destruct b0. exact (ndiff eq_refl). contradiction. destruct b0. contradiction. exact (ndiff eq_refl). rewrite nth_error_None, <- H in des0. exact (proj1 (Nat.lt_nge _ _) nlen des0). rewrite nth_error_None in desl. exact (proj1 (Nat.lt_nge _ _) nlen desl). rewrite nth_error_None, <- H0 in des. exact (proj1 (Nat.lt_nge _ _) nlen des). Qed. Definition ProdIntegrableSimplify {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) : list (@ProdIntegrable I J) := map (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy)) (list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn))). Lemma nat_euclid_unique : forall i j q : nat, lt 0 q -> (i / q = j / q)%nat -> i mod q = j mod q -> i = j. Proof. intros. assert (q <> O). { destruct q. exfalso; exact (Nat.lt_irrefl O H). discriminate. } rewrite (Nat.div_mod j q H2), <- H1, <- H0. apply Nat.div_mod, H2. Qed. Lemma ProdIntegrableSimplifyDisjoint : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)), ProdIntegrableSimple (ProdIntegrableSimplify hn). Proof. intros. apply (forall_disjoint_pairs_equiv _ _ (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))). intros. unfold ProdIntegrableSimplify in H0. rewrite map_length, prod_length in H0. assert (0 < length (FreeSubsets (length hn)))%nat as lenPos. { destruct (length (FreeSubsets (length hn))). exfalso; inversion H0. apply le_n_S, Nat.le_0_l. } unfold ProdIntegrableSimplify. do 2 rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy)) _ (@nil bool, @nil bool)). rewrite (nth_list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn)) nil nil i (Nat.lt_trans _ _ _ H H0)). rewrite (nth_list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn)) nil nil j H0). unfold fst, snd. (* Decompose i,j into product pairs of indices (a,b), (c,d). *) remember (i / length (FreeSubsets (length hn)))%nat as a. remember (i mod (length (FreeSubsets (length hn))))%nat as b. remember (j / length (FreeSubsets (length hn)))%nat as c. remember (j mod (length (FreeSubsets (length hn))))%nat as d. intros x y z. simpl in z. destruct z as [xH [xK [yH yK]]]. destruct (Nat.eq_dec a c). - (* If subsets b and d are different, the product on y's is zero. *) assert (b <> d). { intro abs. subst d. subst b. subst c. subst a. rewrite (nat_euclid_unique _ _ _ lenPos e abs) in H. exact (Nat.lt_irrefl j H). } assert (d < length (FreeSubsets (length hn)))%nat as din. { subst d. apply Nat.mod_upper_bound. intro abs. rewrite abs in lenPos. exact (Nat.lt_irrefl _ lenPos). } apply (ProdIntegrableSubsetsDisjoint (map prodint_g hn) (nth d (FreeSubsets (length hn)) nil) (nth b (FreeSubsets (length hn)) nil) y). 4: split; assumption. rewrite (FreeSubsetsLength (length hn)). rewrite (FreeSubsetsLength (length hn)). reflexivity. apply nth_In. subst b. apply Nat.mod_upper_bound. intro abs. rewrite abs in lenPos. exact (Nat.lt_irrefl _ lenPos). apply nth_In. exact din. rewrite (FreeSubsetsLength (length hn)). rewrite map_length. reflexivity. apply nth_In. exact din. apply FreeSubsetsDifferent. intro abs. apply H1. symmetry. exact abs. exact din. subst b. apply Nat.mod_upper_bound. intro abs. rewrite abs in lenPos. exact (Nat.lt_irrefl _ lenPos). - (* If subsets a and c are different, the product on x's is zero. *) assert (c < length (FreeSubsets (length hn)))%nat as cin. { subst c. apply Nat.div_lt_upper_bound. intro abs. rewrite abs in lenPos. exact (Nat.lt_irrefl 0 lenPos). exact H0. } apply (ProdIntegrableSubsetsDisjoint (map prodint_f hn) (nth c (FreeSubsets (length hn)) nil) (nth a (FreeSubsets (length hn)) nil) x). 4: split; assumption. clear xH xK yH yK. rewrite (FreeSubsetsLength (length hn)). rewrite (FreeSubsetsLength (length hn)). reflexivity. apply nth_In. subst a. apply Nat.div_lt_upper_bound. intro abs. rewrite abs in lenPos. exact (Nat.lt_irrefl 0 lenPos). exact (Nat.lt_trans _ _ _ H H0). apply nth_In. exact cin. rewrite (FreeSubsetsLength (length hn)). rewrite map_length. reflexivity. apply nth_In. exact cin. apply FreeSubsetsDifferent. intro abs. apply n. symmetry. exact abs. exact cin. subst a. apply Nat.div_lt_upper_bound. intro abs. rewrite abs in lenPos. exact (Nat.lt_irrefl 0 lenPos). exact (Nat.lt_trans _ _ _ H H0). Qed. Fixpoint ProdIntegrableSubsetLeft {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)) { struct hn } : list bool. Proof. destruct hn. - exact nil. - destruct xyH, d. exact ((if d then true else false) :: ProdIntegrableSubsetLeft I J hn x y d0). Defined. Lemma ProdIntegrableSubsetLeft_length : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), length (ProdIntegrableSubsetLeft hn x y xyH) = length hn. Proof. induction hn. - reflexivity. - intros. simpl. destruct xyH, d. simpl. rewrite IHhn. reflexivity. Qed. Fixpoint ProdIntegrableSubsetRight {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)) { struct hn } : list bool. Proof. destruct hn. - exact nil. - destruct xyH, d. exact ((if d1 then true else false) :: ProdIntegrableSubsetRight I J hn x y d0). Defined. Lemma ProdIntegrableSubsetRight_length : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), length (ProdIntegrableSubsetRight hn x y xyH) = length hn. Proof. induction hn. - reflexivity. - intros. simpl. destruct xyH, d. simpl. rewrite IHhn. reflexivity. Qed. (* Application of a list of rectangles, when none is activated. *) Lemma ProdLFuncApplyZero : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyS : Domain (ProdLFunc hn) (x,y)), (forall (n:nat) (ltnh : lt n (length hn)), partialApply _ _ (DomainProdLFuncInc hn x y xyS n ltnh) == 0) -> partialApply _ _ xyS == 0. Proof. induction hn. - intros. reflexivity. - intros. destruct xyS. transitivity (partialApply _ _ d + partialApply _ _ d0). reflexivity. rewrite IHhn, CRplus_0_r. clear IHhn. assert (O < length (a :: hn))%nat. { apply le_n_S, Nat.le_0_l. } rewrite <- (H O H0). apply DomainProp. clear IHhn. intros. assert (S n < length (a :: hn))%nat. { apply le_n_S, ltnh. } rewrite <- (H (S n) H0). apply DomainProp. Qed. (* Application of a list of rectangles, when only one is activated. *) Lemma ProdLFuncApplyUnique : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyS : Domain (ProdLFunc hn) (x,y)) (n : nat) (ltnh : lt n (length hn)), (forall (k:nat) (ltkh : lt k (length hn)), k <> n -> partialApply _ _ (DomainProdLFuncInc hn x y xyS k ltkh) == 0) -> partialApply _ _ xyS == partialApply _ _ (DomainProdLFuncInc hn x y xyS n ltnh). Proof. induction hn. - intros. exfalso; inversion ltnh. - intros. destruct xyS. specialize (IHhn x y d0). transitivity (partialApply _ _ d + partialApply _ _ d0). reflexivity. destruct n. + simpl (nth 0 (a :: hn) (ProdIntegrableZero I J)). rewrite <- (CRplus_0_r (partialApply (ProdIntegrableFunc a) (x, y) (DomainProdLFuncInc (a :: hn) x y (d, d0) 0 ltnh))). apply CRplus_morph. apply DomainProp. apply ProdLFuncApplyZero. intros. assert (S n < length (a :: hn))%nat. { apply le_n_S, ltnh0. } rewrite <- (H (S n) H0). apply DomainProp. discriminate. + assert (n < length hn)%nat. { apply le_S_n. exact ltnh. } specialize (IHhn n H0). rewrite IHhn. clear IHhn. rewrite <- (CRplus_0_l (partialApply (ProdIntegrableFunc (nth (S n) (a :: hn) (ProdIntegrableZero I J))) (x, y) (DomainProdLFuncInc (a :: hn) x y (d, d0) (S n) ltnh))). apply CRplus_morph. 2: apply DomainProp. assert (0 < S (length hn))%nat. apply le_n_S, Nat.le_0_l. specialize (H O H1). unfold nth in H. rewrite <- H. apply DomainProp. discriminate. clear IHhn. intros. assert (S k < length (a :: hn))%nat. { apply le_n_S, ltkh. } specialize (H (S k) H2). simpl (nth (S k) (a :: hn) (ProdIntegrableZero I J)) in H. rewrite <- H. apply DomainProp. intro abs. inversion abs. contradiction. Qed. Lemma ProdIntegrableSubsetLeft_match : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)) (init : X (ElemFunc I) -> Prop), init x -> SubsetIntersectLeft hn init (ProdIntegrableSubsetLeft hn x y xyH) x. Proof. induction hn. - intros. exact H. - intros. destruct xyH, d, d; split. exact p. apply IHhn. exact H. apply IHhn. exact H. exact n. Qed. Lemma ProdIntegrableSubsetRight_match : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)) (init : X (ElemFunc J) -> Prop), init y -> SubsetIntersectRight hn init (ProdIntegrableSubsetRight hn x y xyH) y. Proof. induction hn. - intros. exact H. - intros. destruct xyH, d, d1; split. exact p. apply IHhn. exact H. apply IHhn. exact H. exact n. Qed. Lemma ApplyOutsidePointLeft : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), Forall (fun fg : ProdIntegrable => ~ prodint_g fg y) hn -> SubsetIntersectFactor hn (ProdIntegrableSubsetLeft hn x y xyH) (ProdIntegrableSubsetRight hn x y xyH) == 0. Proof. induction hn. - reflexivity. - intros. inversion H. destruct xyH, d. specialize (IHhn x y d0 H3). subst x0. subst l. simpl. destruct d. + destruct d1. contradiction. simpl. rewrite IHhn. apply CRplus_0_l. + simpl. rewrite IHhn. apply CRplus_0_l. Qed. Lemma ApplyOutsidePointRight : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), Forall (fun fg : ProdIntegrable => ~ prodint_f fg x) hn -> SubsetIntersectFactor hn (ProdIntegrableSubsetLeft hn x y xyH) (ProdIntegrableSubsetRight hn x y xyH) == 0. Proof. induction hn. - reflexivity. - intros. inversion H. destruct xyH, d. specialize (IHhn x y d0 H3). subst x0. subst l. simpl. destruct d. + destruct d1. contradiction. simpl. rewrite IHhn. apply CRplus_0_l. + simpl. rewrite IHhn. apply CRplus_0_l. Qed. Lemma list_prod_head : forall { A B : Type } (l : list A) (k : list B) (a : A) (b : B), l <> nil -> k <> nil -> nth 0 (list_prod l k) (a,b) = (nth 0 l a, nth 0 k b). Proof. intros. destruct l,k. reflexivity. contradiction. contradiction. reflexivity. Qed. Lemma ProdLFuncDomainLeft : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), Domain (ProdLFunc hn) (x,y) -> { n:nat | lt n (length hn) /\ prodint_f (nth n hn (ProdIntegrableZero I J)) x } + { forall n:nat, lt n (length hn) -> ~prodint_f (nth n hn (ProdIntegrableZero I J)) x }. Proof. induction hn. - intros x y H. right. intros. exfalso. inversion H0. - intros x y H. destruct H, d. unfold fst in d. destruct d. + left. exists O. split. apply le_n_S, Nat.le_0_l. exact p. + specialize (IHhn x y d0) as [[k isin] | isout]. left. exists (S k). destruct isin. split. apply le_n_S, H. exact H0. right. intros. destruct n0. exact n. apply isout. apply le_S_n, H. Qed. Lemma ProdLFuncDomainRight : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), Domain (ProdLFunc hn) (x,y) -> { n:nat | lt n (length hn) /\ prodint_g (nth n hn (ProdIntegrableZero I J)) y } + { forall n:nat, lt n (length hn) -> ~prodint_g (nth n hn (ProdIntegrableZero I J)) y }. Proof. induction hn. - intros x y H. right. intros. exfalso. inversion H0. - intros x y H. destruct H, d. unfold snd in d1. destruct d1. + left. exists O. split. apply le_n_S, Nat.le_0_l. exact p. + specialize (IHhn x y d0) as [[k isin] | isout]. left. exists (S k). destruct isin. split. apply le_n_S, H. exact H0. right. intros. destruct n0. exact n. apply isout. apply le_S_n, H. Qed. Fixpoint ConstFilter (b : bool) (n : nat) : list bool := match n with | O => nil | S p => b :: ConstFilter b p end. Lemma ConstFilter_length : forall (b:bool) (n:nat), length (ConstFilter b n) = n. Proof. induction n. reflexivity. simpl. apply f_equal, IHn. Qed. Lemma ConstFilter_false : forall {A : Set} (hn : list (A -> Prop)) (x : A) (init : A -> Prop), init x -> Forall (fun h => ~h x) hn -> SubsetIntersectFilter hn init (ConstFilter false (length hn)) x. Proof. induction hn. - intros. exact H. - intros. inversion H0. split. 2: exact H3. exact (IHhn x init H H4). Qed. Lemma SubsetIntersectFilterOut : forall {A : Set} (hn : list (A -> Prop)) (x : A), (forall filter : list bool, length filter = length hn -> ~SubsetIntersectFilter hn (SubsetUnion hn) filter x) -> Forall (fun h => ~h x) hn. Proof. induction hn. - intros. apply Forall_nil. - intros. assert (a x -> forall filter : list bool, length filter = length hn -> ~ SubsetIntersectFilter hn (SubsetUnion (a :: hn)) filter x). { intros. intro abs. apply (H (true :: filter)). simpl. apply f_equal. exact H1. split. exact H0. exact abs. } assert (a x -> Forall (fun h => ~h x) hn). { intros. apply IHhn. intros. specialize (H0 H1 filter H2). intro abs. apply H0. apply (SubsetIntersectFilterInc hn (SubsetUnion hn) _ filter x). intros. right. exact H3. exact abs. } assert (~a x). { intro abs. apply (H0 abs (ConstFilter false (length hn))). specialize (H1 abs). apply ConstFilter_length. apply ConstFilter_false. left. exact abs. exact (H1 abs). } clear H0. clear H1. apply Forall_cons. + exact H2. + apply IHhn. intros. intro abs. apply (H (false :: filter)). simpl. apply f_equal, H0. split. 2: exact H2. apply (SubsetIntersectFilterInc hn (SubsetUnion hn) _ filter x). intros. right. exact H1. exact abs. Qed. Lemma DomainProdLFuncSplitCoord : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), (forall n:nat, lt n (length hn) -> { prodint_f (nth n hn (ProdIntegrableZero I J)) x } + { ~prodint_f (nth n hn (ProdIntegrableZero I J)) x }) -> (forall n:nat, lt n (length hn) -> { prodint_g (nth n hn (ProdIntegrableZero I J)) y } + { ~prodint_g (nth n hn (ProdIntegrableZero I J)) y }) -> Domain (ProdLFunc hn) (x,y). Proof. induction hn. - intros. simpl. trivial. - intros. split. + split. apply (H O). apply le_n_S, Nat.le_0_l. apply (H0 O). apply le_n_S, Nat.le_0_l. + apply IHhn. intros. apply le_n_S in H1. exact (H (S n) H1). intros. apply le_n_S in H1. exact (H0 (S n) H1). Qed. Lemma ProdIntegrableSimplifyDomain : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)), Domain (ProdLFunc (ProdIntegrableSimplify hn)) (x,y) -> Domain (ProdLFunc hn) (x,y). Proof. intros I J hn x y H. assert (lt O (length (FreeSubsets (length hn)))) as flen. { destruct (FreeSubsets (length hn)) eqn:des. exfalso. exact (FreeSubsetsNotNil _ des). apply le_n_S, Nat.le_0_l. } apply DomainProdLFuncSplitCoord. - destruct (ProdLFuncDomainLeft _ x y H) as [[nl isinl] | H0]. + intros. destruct isinl. unfold ProdIntegrableSimplify in H2. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))) in H2. 2: exact H1. unfold ProdIntegrableSimplify in H1. rewrite map_length, prod_length in H1. rewrite (map_nth (fun xy : list bool * list bool => ProdSubsetIntersect hn (fst xy) (snd xy))) in H2. simpl in H2. unfold SubsetIntersectLeft in H2. apply (DomainProdSubsetIntersect (map prodint_f hn) _ _ _ n) in H2. destruct (nth_error (map prodint_f hn) n) eqn:des. apply (nth_error_nth (map prodint_f hn) n (prodint_f (ProdIntegrableZero I J))) in des. subst P. destruct (nth_error (fst (nth nl (list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn))) (nil, nil))) n) eqn:des2. destruct b. left. rewrite map_nth in H2. exact H2. rewrite map_nth in H2. right. exact H2. exfalso. apply nth_error_None in des2. rewrite nth_list_prod in des2. unfold fst in des2. rewrite (FreeSubsetsLength (length hn) (nth (nl / length (FreeSubsets (length hn))) (FreeSubsets (length hn)) nil)) in des2. exact (proj1 (Nat.lt_nge _ _) H0 des2). apply nth_In. apply Nat.div_lt_upper_bound in H1. exact H1. intro abs. rewrite abs in flen. inversion flen. exact H1. exfalso. apply nth_error_None in des. rewrite map_length in des. exact (proj1 (Nat.lt_nge _ _) H0 des). + assert (Forall (fun h => ~h x) (map prodint_f hn)). { apply SubsetIntersectFilterOut. intros. destruct (FreeSubsetsFull filter) as [n [H2 H3]]. specialize (H0 (n * (length (FreeSubsets (length hn))))%nat). rewrite map_length in H1. intro abs. apply H0. unfold ProdIntegrableSimplify. rewrite map_length, prod_length. rewrite <- Nat.mul_lt_mono_pos_r. rewrite <- H1. exact H2. exact flen. clear H0. unfold ProdIntegrableSimplify. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))). rewrite (map_nth (fun xy : list bool * list bool => ProdSubsetIntersect hn (fst xy) (snd xy))). simpl. unfold SubsetIntersectLeft. rewrite (nth_list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn)) nil nil (n * (length (FreeSubsets (length hn))))). unfold fst. rewrite Nat.div_mul. rewrite <- H1, H3. exact abs. intro H4. rewrite H4 in flen. inversion flen. rewrite <- Nat.mul_lt_mono_pos_r. rewrite <- H1. exact H2. exact flen. rewrite map_length, prod_length. rewrite <- Nat.mul_lt_mono_pos_r. rewrite <- H1. exact H2. exact flen. } intros. right. rewrite Forall_forall in H1. apply (H1 (prodint_f (nth n hn (ProdIntegrableZero I J)))). apply in_map, nth_In, H2. - destruct (ProdLFuncDomainRight _ x y H) as [[nl isinl] | H0]. + intros. destruct isinl. unfold ProdIntegrableSimplify in H2. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))) in H2. 2: exact H1. unfold ProdIntegrableSimplify in H1. rewrite map_length, prod_length in H1. rewrite (map_nth (fun xy : list bool * list bool => ProdSubsetIntersect hn (fst xy) (snd xy))) in H2. simpl in H2. unfold SubsetIntersectLeft in H2. apply (DomainProdSubsetIntersect (map prodint_g hn) _ _ _ n) in H2. destruct (nth_error (map prodint_g hn) n) eqn:des. apply (nth_error_nth (map prodint_g hn) n (prodint_g (ProdIntegrableZero I J))) in des. subst P. destruct (nth_error (snd (nth nl (list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn))) (nil, nil))) n) eqn:des2. destruct b. left. rewrite map_nth in H2. exact H2. rewrite map_nth in H2. right. exact H2. exfalso. apply nth_error_None in des2. rewrite nth_list_prod in des2. unfold snd in des2. rewrite (FreeSubsetsLength (length hn) (nth (nl mod length (FreeSubsets (length hn))) (FreeSubsets (length hn)) nil)) in des2. exact (proj1 (Nat.lt_nge _ _) H0 des2). apply nth_In. apply Nat.mod_bound_pos. apply Nat.le_0_l. exact flen. exact H1. exfalso. apply nth_error_None in des. rewrite map_length in des. exact (proj1 (Nat.lt_nge _ _) H0 des). + assert (Forall (fun h => ~h y) (map prodint_g hn)). { apply SubsetIntersectFilterOut. intros. destruct (FreeSubsetsFull filter) as [n [H2 H3]]. specialize (H0 n). rewrite map_length in H1. intro abs. apply H0. unfold ProdIntegrableSimplify. rewrite map_length, prod_length. apply (Nat.lt_le_trans _ (1 * length (FreeSubsets (length hn)))). rewrite Nat.mul_1_l. rewrite <- H1. exact H2. apply Nat.mul_le_mono_nonneg_r. apply Nat.le_0_l. exact flen. clear H0. unfold ProdIntegrableSimplify. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))). rewrite (map_nth (fun xy : list bool * list bool => ProdSubsetIntersect hn (fst xy) (snd xy))). simpl. unfold SubsetIntersectRight. rewrite (nth_list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn)) nil nil n). unfold snd. rewrite Nat.mod_small. rewrite <- H1, H3. exact abs. rewrite <- H1. exact H2. apply (Nat.lt_le_trans _ (1 * length (FreeSubsets (length hn)))). rewrite Nat.mul_1_l. rewrite <- H1. exact H2. apply Nat.mul_le_mono_nonneg_r. apply Nat.le_0_l. exact flen. rewrite map_length, prod_length. apply (Nat.lt_le_trans _ (1 * length (FreeSubsets (length hn)))). rewrite Nat.mul_1_l. rewrite <- H1. exact H2. apply Nat.mul_le_mono_nonneg_r. apply Nat.le_0_l. exact flen. } intros. right. rewrite Forall_forall in H1. apply (H1 (prodint_g (nth n hn (ProdIntegrableZero I J)))). apply in_map, nth_In, H2. Qed. Lemma ProdIntegrableSimplifyApply : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)) (xyS : Domain (ProdLFunc (ProdIntegrableSimplify hn)) (x,y)), partialApply _ _ xyS == SubsetIntersectFactor hn (ProdIntegrableSubsetLeft hn x y xyH) (ProdIntegrableSubsetRight hn x y xyH). Proof. intros. destruct (SubsetUnionLeftDec hn x y xyH) as [inunionf|notinunionf]. destruct (SubsetUnionRightDec hn x y xyH) as [inuniong|notinuniong]. pose proof (FreeSubsetsFull (ProdIntegrableSubsetLeft hn x y xyH)) as [kf H]. rewrite ProdIntegrableSubsetLeft_length in H. pose proof (FreeSubsetsFull (ProdIntegrableSubsetRight hn x y xyH)) as [kg H0]. rewrite ProdIntegrableSubsetRight_length in H0. assert (kg + kf * (length (FreeSubsets (length hn))) < length (ProdIntegrableSimplify hn))%nat. { unfold ProdIntegrableSimplify. rewrite map_length, prod_length. destruct H. apply (Nat.lt_le_trans _ (length (FreeSubsets (length hn)) + kf * length (FreeSubsets (length hn)))). rewrite <- Nat.add_lt_mono_r. apply H0. apply (Nat.mul_le_mono_nonneg_r (S kf) _ (length (FreeSubsets (length hn)))). apply Nat.le_0_l. exact H. } rewrite (ProdLFuncApplyUnique (ProdIntegrableSimplify hn) x y xyS (kg + kf * (length (FreeSubsets (length hn)))) H1). - (* single matching point *) assert (kg + kf * (length (FreeSubsets (length hn))) < length (FreeSubsets (length hn)) * length (FreeSubsets (length hn)))%nat. { unfold ProdIntegrableSimplify in H1 ; rewrite map_length, prod_length in H1. exact H1. } pose proof (nth_list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn)) nil nil (kg + kf * (length (FreeSubsets (length hn)))) H2). rewrite Nat.div_add, Nat.mod_add, Nat.div_small, Nat.mod_small in H3. 2: apply H0. 2: apply H0. symmetry. rewrite <- CRmult_1_r. apply CRmult_morph. rewrite <- CRmult_1_r. apply CRmult_morph. + unfold ProdIntegrableSimplify. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))). rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), H3. unfold fst, snd. destruct H, H0. simpl (0 + kf)%nat. rewrite H4, H5. reflexivity. rewrite map_length. rewrite prod_length. exact H2. + destruct (DomainProdLFuncInc (ProdIntegrableSimplify hn) x y xyS (kg + kf * length (FreeSubsets (length hn))) H1). destruct d. reflexivity. exfalso. simpl in n. apply n. unfold ProdIntegrableSimplify. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))). rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), H3. simpl. destruct H. rewrite H4. apply ProdIntegrableSubsetLeft_match. apply inunionf. exact H1. + destruct (DomainProdLFuncInc (ProdIntegrableSimplify hn) x y xyS (kg + kf * length (FreeSubsets (length hn))) H1). destruct d0. reflexivity. exfalso. simpl in n. apply n. unfold ProdIntegrableSimplify. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))). rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), H3. simpl. destruct H0. rewrite H4. apply ProdIntegrableSubsetRight_match. apply inuniong. exact H1. + intros abs. destruct H. rewrite abs in H. inversion H. + intros abs. destruct H. rewrite abs in H. inversion H. - (* Other points evaluate to zero *) intros. simpl. rewrite CRmult_assoc. rewrite (CRmult_morph _ _ _ (CReq_refl _) _ 0). apply CRmult_0_r. destruct (DomainProdLFuncInc (ProdIntegrableSimplify hn) x y xyS k ltkh). destruct d. destruct d0. 2: unfold snd; apply CRmult_0_r. 2: unfold fst; apply CRmult_0_l. exfalso. assert (k < length (FreeSubsets (length hn)) * length (FreeSubsets (length hn)))%nat. { unfold ProdIntegrableSimplify in ltkh. rewrite map_length, prod_length in ltkh. exact ltkh. } pose proof (nth_list_prod (FreeSubsets (length hn)) (FreeSubsets (length hn)) nil nil k H3). unfold fst, ProdIntegrableSimplify in p. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))) in p. rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), H4 in p. unfold fst, snd in p. unfold fst, ProdIntegrableSimplify in p0. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))) in p0. rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), H4 in p0. unfold fst, snd in p0. 2: rewrite map_length, prod_length; exact H3. 2: rewrite map_length, prod_length; exact H3. clear H4. assert (0 < length (FreeSubsets (length hn)))%nat as lenPos. { apply (Nat.le_lt_trans _ kg _ (Nat.le_0_l _)). apply H0. } destruct (Nat.eq_dec (k / length (FreeSubsets (length hn))) kf). + rewrite e in p0. clear p. simpl in p0. apply (ProdIntegrableSubsetsDisjoint (map prodint_g hn) (nth (k mod length (FreeSubsets (length hn))) (FreeSubsets (length hn)) nil) (ProdIntegrableSubsetRight hn x y xyH) y). rewrite ProdIntegrableSubsetRight_length. apply FreeSubsetsLength. apply nth_In. apply Nat.mod_bound_pos. apply Nat.le_0_l. exact lenPos. apply FreeSubsetsLength. rewrite map_length. apply nth_In. apply Nat.mod_bound_pos. apply Nat.le_0_l. exact lenPos. destruct H0. rewrite <- H4. apply FreeSubsetsDifferent. intro abs. subst kg. subst kf. pose proof (Nat.div_mod k (length (FreeSubsets (length hn)))). rewrite Nat.add_comm, Nat.mul_comm in H5. apply H2, H5. intro abs. rewrite abs in lenPos. inversion lenPos. apply Nat.mod_bound_pos. apply Nat.le_0_l. exact lenPos. exact H0. split. exact p0. apply ProdIntegrableSubsetRight_match. apply inuniong. + clear p0. simpl in p. assert (k / length (FreeSubsets (length hn)) < length (FreeSubsets (length hn)))%nat. { apply Nat.div_lt_upper_bound in H3. exact H3. intro abs. rewrite abs in lenPos. inversion lenPos. } apply (ProdIntegrableSubsetsDisjoint (map prodint_f hn) (nth (k / length (FreeSubsets (length hn))) (FreeSubsets (length hn)) nil) (ProdIntegrableSubsetLeft hn x y xyH) x). rewrite ProdIntegrableSubsetLeft_length. apply FreeSubsetsLength. apply nth_In. exact H4. apply FreeSubsetsLength. rewrite map_length. apply nth_In. exact H4. destruct H. rewrite <- H5. apply FreeSubsetsDifferent. exact n. exact H4. exact H. split. exact p. apply ProdIntegrableSubsetLeft_match. apply inunionf. - (* If y is in no subsets, then 0 == 0. *) rewrite ApplyOutsidePointLeft. 2: apply notinuniong. apply ProdLFuncApplyZero. intros. simpl. destruct (DomainProdLFuncInc (ProdIntegrableSimplify hn) x y xyS n ltnh), d0. 2: apply CRmult_0_r. exfalso. clear d. simpl in p. unfold ProdIntegrableSimplify in p. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))) in p. 2: exact ltnh. rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), nth_list_prod in p. unfold fst, snd in p. apply SubsetIntersectFilter_init in p. destruct (SubsetUnionRightDec hn x y xyH). destruct H, notinuniong. contradiction. destruct H, notinuniong. contradiction. unfold ProdIntegrableSimplify in ltnh. rewrite map_length, prod_length in ltnh. exact ltnh. - (* If x is in no subsets, then 0 == 0. *) rewrite ApplyOutsidePointRight. 2: apply notinunionf. apply ProdLFuncApplyZero. intros. simpl. destruct (DomainProdLFuncInc (ProdIntegrableSimplify hn) x y xyS n ltnh), d. 2: rewrite CRmult_0_r; apply CRmult_0_l. exfalso. clear d0. simpl in p. unfold ProdIntegrableSimplify in p. rewrite (nth_indep _ (ProdIntegrableZero I J) (ProdSubsetIntersect hn (fst (nil,@nil bool)) (snd (@nil bool, nil)))) in p. 2: exact ltnh. rewrite (map_nth (fun xy => ProdSubsetIntersect hn (fst xy) (snd xy))), nth_list_prod in p. unfold fst, snd in p. apply SubsetIntersectFilter_init in p. destruct (SubsetUnionLeftDec hn x y xyH). destruct H, notinunionf. contradiction. destruct H, notinunionf. contradiction. unfold ProdIntegrableSimplify in ltnh. rewrite map_length, prod_length in ltnh. exact ltnh. Qed. Lemma ApplyIntersectFactor : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)), partialApply (ProdLFunc hn) (x, y) xyH == SubsetIntersectFactor hn (ProdIntegrableSubsetLeft hn x y xyH) (ProdIntegrableSubsetRight hn x y xyH). Proof. induction hn. - reflexivity. - intros. destruct xyH. specialize (IHhn x y d0). simpl. rewrite IHhn. clear IHhn. destruct d. simpl. rewrite CRplus_comm. apply CRplus_morph. reflexivity. destruct d. destruct d1. do 2 rewrite CRmult_1_r. reflexivity. rewrite CRmult_1_r. rewrite CRmult_0_r. reflexivity. destruct d1. rewrite CRmult_0_r, CRmult_0_l. reflexivity. rewrite CRmult_0_r. reflexivity. Qed. Lemma ProdIntegrableSimplifyEq : forall {I J : IntegrationSpace} (hn : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyH : Domain (ProdLFunc hn) (x,y)) (xyS : Domain (ProdLFunc (ProdIntegrableSimplify hn)) (x,y)), partialApply _ _ xyH == partialApply _ _ xyS. Proof. (* ProdLFunc hn is the linear combination of hn, so we know whether x and y belong to each of the components of hn. That makes a subset which selects only one component of ProdIntegrableSimplify hn. The value on that component is SubsetIntersectFactor which sums all the activated coefficients, as ProdLFunc hn does. *) intros. rewrite (ProdIntegrableSimplifyApply hn x y xyH). apply ApplyIntersectFactor. Qed. Definition ProdIntegrableMapCoef {I J : IntegrationSpace} : (CRcarrier (RealT (ElemFunc I)) -> CRcarrier (RealT (ElemFunc I))) -> @ProdIntegrable I J -> @ProdIntegrable I J := fun f P => Build_ProdIntegrable I J (prodint_f P) (prodint_g P) (f (prodint_factor P)) (prodint_fint P) (prodint_gint P). Lemma DomainProdLFuncMap : forall {I J : IntegrationSpace} (l : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (f : CRcarrier (RealT (ElemFunc I)) -> CRcarrier (RealT (ElemFunc I))), Domain (ProdLFunc (map (ProdIntegrableMapCoef f) l)) (x,y) -> Domain (ProdLFunc l) (x, y). Proof. induction l. - intros. simpl. trivial. - intros x y f H. destruct H. split. + destruct a; split; apply d. + exact (IHl x y f d0). Qed. Lemma ApplyProdLFuncDisjointHead : forall {I J : IntegrationSpace} (l : list ProdIntegrable) (a : @ProdIntegrable I J) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyL : Domain (ProdLFunc l) (x,y)), ProdIntegrableSimple (a :: l) -> prodint_f a x -> prodint_g a y -> partialApply _ (x,y) xyL == 0. Proof. induction l. - intros. reflexivity. - intros. simpl. destruct xyL, d. simpl. assert (ProdIntegrableSimple (a0 :: l)) as simple0. { destruct H, H. split. exact H. inversion H2. exact H7. } destruct d. + destruct d1. exfalso. simpl in p, p0. destruct H. inversion H2. apply (H5 x y). repeat split; assumption. rewrite CRmult_0_r, CRplus_0_l. apply (IHl a0). exact simple0. exact H0. exact H1. + rewrite CRmult_0_r, CRmult_0_l, CRplus_0_l. apply (IHl a0). exact simple0. exact H0. exact H1. Qed. Lemma ApplyProdLFuncDisjointHeadMap : forall {I J : IntegrationSpace} (l : list ProdIntegrable) (a : @ProdIntegrable I J) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (f : CRcarrier (RealT (ElemFunc I)) -> CRcarrier (RealT (ElemFunc I))) (xyL : Domain (ProdLFunc (map (ProdIntegrableMapCoef f) l)) (x,y)), ProdIntegrableSimple (a :: l) -> prodint_f a x -> prodint_g a y -> partialApply _ (x,y) xyL == 0. Proof. induction l. - intros. reflexivity. - intros. simpl. destruct xyL, d. simpl. assert (ProdIntegrableSimple (a0 :: l)) as simple0. { destruct H, H. split. exact H. inversion H2. exact H7. } destruct d. + destruct d1. exfalso. simpl in p, p0. destruct H. inversion H2. apply (H5 x y). repeat split; assumption. rewrite CRmult_0_r, CRplus_0_l. apply (IHl a0). exact simple0. exact H0. exact H1. + rewrite CRmult_0_r, CRmult_0_l, CRplus_0_l. apply (IHl a0). exact simple0. exact H0. exact H1. Qed. (* When a list of rectangles is disjoint, a point (x,y) is inside at most one rectangle. The sum reduces to one coefficient. *) Lemma ApplyProdLFuncDisjointAbs : forall {I J : IntegrationSpace} (l : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyL : Domain (ProdLFunc l) (x,y)) (f : CRcarrier (RealT (ElemFunc I)) -> CRcarrier (RealT (ElemFunc I))) (xyA : Domain (ProdLFunc (map (ProdIntegrableMapCoef f) l)) (x,y)), ProdIntegrableSimple l -> f 0 == 0 -> (forall x y : CRcarrier (RealT (ElemFunc I)), x == y -> f x == f y) -> partialApply (ProdLFunc (map (ProdIntegrableMapCoef f) l)) (x,y) xyA == f (partialApply (ProdLFunc l) (x,y) xyL). Proof. induction l as [|a l]. - intros. rewrite H0. reflexivity. - intros. simpl. destruct xyA, xyL, d. unfold fst in d. destruct d. unfold snd in d3. destruct d3. + (* (x,y) is inside a, stop the sum there. *) simpl. rewrite (H1 (prodint_factor a * (if fst d1 then 1 else 0) * (if snd d1 then 1 else 0) + partialApply (fold_right Xplus (Xconst (X (ElemFunc I) * X (ElemFunc J)) 0) (map ProdIntegrableFunc l)) (x, y) d2) (prodint_factor a)). rewrite (ApplyProdLFuncDisjointHeadMap l a x y f d0 H p p0). rewrite CRplus_0_r. do 2 rewrite CRmult_1_r. reflexivity. destruct d1. simpl. destruct d. destruct d1. 2: contradiction. 2: contradiction. do 2 rewrite CRmult_1_r. rewrite (ApplyProdLFuncDisjointHead l a x y d2 H p p0). rewrite CRplus_0_r. reflexivity. + (* (x,y) is outside a, use induction hypothesis. *) simpl. rewrite CRmult_0_r, CRplus_0_l. rewrite (H1 (prodint_factor a * (if fst d1 then 1 else 0) * (if snd d1 then 1 else 0) + partialApply (fold_right Xplus (Xconst (X (ElemFunc I) * X (ElemFunc J)) 0) (map ProdIntegrableFunc l)) (x, y) d2) (partialApply (ProdLFunc l) (x, y) d2)). apply IHl. apply H. exact H0. exact H1. destruct d1. unfold snd in d1. simpl. destruct d. destruct d1. contradiction. rewrite CRmult_0_r, CRplus_0_l. reflexivity. rewrite CRmult_0_r, CRmult_0_l, CRplus_0_l. reflexivity. + (* (x,y) is outside a, use induction hypothesis. *) simpl. rewrite CRmult_0_r, CRmult_0_l, CRplus_0_l. destruct d1. simpl. rewrite (H1 (prodint_factor a * (if d then 1 else 0) * (if d1 then 1 else 0) + partialApply (fold_right Xplus (Xconst (X (ElemFunc I) * X (ElemFunc J)) 0) (map ProdIntegrableFunc l)) (x, y) d2) (partialApply (ProdLFunc l) (x, y) d2)). apply IHl. apply H. exact H0. exact H1. destruct d. destruct d1. contradiction. rewrite CRmult_0_r, CRplus_0_l. reflexivity. rewrite CRmult_0_r, CRmult_0_l, CRplus_0_l. reflexivity. Qed. Lemma ApplyMapCoef : forall {I J : IntegrationSpace} (a : CRcarrier (RealT (ElemFunc I))) (l : list ProdIntegrable) (x : X (ElemFunc I)) (y : X (ElemFunc J)) (xyDS : Domain (ProdLFunc (map (ProdIntegrableMapCoef (fun x0 : CRcarrier _ => a * x0)) l)) (x,y)), partialApply _ (x, y) xyDS == a * partialApply (ProdLFunc l) (x, y) (DomainProdLFuncMap l x y (fun x0 : CRcarrier _ => a * x0) xyDS). Proof. induction l. - intros. simpl. rewrite CRmult_0_r. reflexivity. - intros. simpl. destruct xyDS. rewrite IHl. destruct (DomainProdLFuncMap (a0 :: l) x y (fun x0 : CRcarrier _ => a * x0) (d, d0)). rewrite CRmult_assoc, CRmult_assoc, <- CRmult_plus_distr_l. apply CRmult_morph. reflexivity. apply CRplus_morph. 2: apply DomainProp. destruct d, d1. simpl. destruct d. destruct d1. 2: contradiction. destruct d3. destruct d4. 2: contradiction. rewrite CRmult_assoc. reflexivity. destruct d4. contradiction. rewrite CRmult_assoc. reflexivity. rewrite CRmult_0_l. destruct d1. contradiction. rewrite CRmult_0_r, CRmult_0_l. reflexivity. Qed. Lemma ProductMinConstStable : forall {I J : IntegrationSpace} (l : list (@ProdIntegrable I J)) (a : CRcarrier (RealT (ElemFunc I))) (aPos : 0 < a), PartialRestriction (ProdLFunc (map (ProdIntegrableMapCoef (fun x => CRmin x a)) (ProdIntegrableSimplify l))) (XminConst (ProdLFunc l) a). Proof. intros I J l. split. - intros [x y] H. apply DomainProdLFuncMap, ProdIntegrableSimplifyDomain in H. exact H. - intros [x y] xyDS xG. simpl. rewrite (ApplyProdLFuncDisjointAbs _ x y (DomainProdLFuncMap (ProdIntegrableSimplify l) x y (fun x => CRmin x a) xyDS)). 2: apply ProdIntegrableSimplifyDisjoint. apply CRmin_morph. rewrite <- (ProdIntegrableSimplifyEq l x y (ProdIntegrableSimplifyDomain l x y (DomainProdLFuncMap (ProdIntegrableSimplify l) x y (fun x => CRmin x a) xyDS))). apply DomainProp. reflexivity. rewrite CRmin_left. reflexivity. apply CRlt_asym, aPos. intros. rewrite H. reflexivity. Qed. (* Product L-functions are linear combinations of products of integrable functions. *) Definition ProductFunctionRieszSpace (I J : IntegrationSpace) : FunctionRieszSpace. Proof. apply (Build_FunctionRieszSpace (prod (X (ElemFunc I)) (X (ElemFunc J))) (RealT (ElemFunc I)) (* L-functions are functions that extend ProdLFunc. l empty means f is the zero function defined on the whole product space. *) (fun f => { l : list ProdIntegrable & PartialRestriction (ProdLFunc l) f })). - (* extensionality of L *) intros f g H [l res]. exists l. apply (PartialRestriction_trans _ _ f _ res). destruct H. split. apply p. exact c. - (* stability under addition *) intros f g [l lf] [l0 lf0]. exists (l ++ l0). intros. split. intros [x y] xD. split. apply DomainProdLFuncAppLeft in xD. apply lf, xD. apply DomainProdLFuncAppRight in xD. apply lf0, xD. intros. destruct x as [x y]. rewrite (ApplyProdLFuncApp l l0 x y (DomainProdLFuncAppLeft l l0 x y xD) (DomainProdLFuncAppRight l l0 x y xD) ). simpl. destruct xG. apply CRplus_morph. apply lf. apply lf0. - (* Stability under absolute value. Cut the domain into disjoint rectangles and apply the absolute value on each coefficient. *) intros f [l lf]. exists (map (ProdIntegrableMapCoef (CRabs _)) (ProdIntegrableSimplify l)). split. intros [x y] H. destruct lf. apply d. exact (ProdIntegrableSimplifyDomain l x y (DomainProdLFuncMap (ProdIntegrableSimplify l) x y (CRabs _) H)). intros [x y] xyDS xG. simpl. rewrite (ApplyProdLFuncDisjointAbs _ x y (DomainProdLFuncMap (ProdIntegrableSimplify l) x y (CRabs _) xyDS)). 2: apply ProdIntegrableSimplifyDisjoint. apply CRabs_morph. rewrite <- (ProdIntegrableSimplifyEq l x y (ProdIntegrableSimplifyDomain l x y (DomainProdLFuncMap (ProdIntegrableSimplify l) x y (CRabs _) xyDS))). apply lf. rewrite CRabs_right. reflexivity. apply CRle_refl. exact CRabs_morph. - (* Stability under minimum. Cut the domain into disjoint rectangles and apply the absolute value on each coefficient. *) intros f [l lf]. exists (map (ProdIntegrableMapCoef (fun x => CRmin x 1)) (ProdIntegrableSimplify l)). apply (PartialRestriction_trans _ _ _ _ (ProductMinConstStable l 1 (CRzero_lt_one _))). split. intros [x y] H. destruct lf. apply d. exact H. intros [x y] xyDS xG. unfold XminConst, Xop, partialApply. destruct lf. rewrite (c _ xyDS xG). reflexivity. - (* stability under scaling *) intros a f [l H]. exists (map (ProdIntegrableMapCoef (fun x => a * x)) l). split. intros [x y] H0. simpl. destruct H. apply d. exact (DomainProdLFuncMap l x y (fun x => a * x) H0). intros [x y] xyDS xyD. simpl. destruct H. rewrite ApplyMapCoef. apply CRmult_morph. reflexivity. apply (c (x,y) (DomainProdLFuncMap l x y (fun x => a * x) xyDS)). Defined. Definition IElemProduct { I J : IntegrationSpace } (f : PartialFunction (prod (X (ElemFunc I)) (X (ElemFunc J)))) : L (ProductFunctionRieszSpace I J) f -> CRcarrier (RealT (ElemFunc I)) := fun fL => let (l,_) := fL in fold_right (CRplus (RealT (ElemFunc I))) 0 (map (fun pi => prodint_factor pi * MeasureSet (prodint_fint pi) * CRcast (MeasureSet (prodint_gint pi))) l). Definition IntegrableFunctionAE { I J : IntegrationSpace } (f : @PartialFunction (RealT (ElemFunc I)) (prod (X (ElemFunc I)) (X (ElemFunc J)))) : Type := almost_everywhere (fun x : X (ElemFunc I) (* Shorter than casting the function and then casting back the integral. *) => @IntegrableFunction (IntegrationSpaceCast J) (Xproj1 f x)). Definition IntegralFst { I J : IntegrationSpace } (f : @PartialFunction (RealT (ElemFunc I)) (prod (X (ElemFunc I)) (X (ElemFunc J)))) (fInt : IntegrableFunctionAE f) : @PartialFunction (RealT (ElemFunc I)) (X (ElemFunc I)). Proof. destruct fInt as [h [hint p]]. apply (Build_PartialFunctionXY (X (ElemFunc I)) (CRcarrier (RealT (ElemFunc I))) (CReq _) (Domain h) (fun x xD => Integral (p x xD))). intros. apply (@IntegralExtensional (IntegrationSpaceCast J)). intros. apply DomainProp. Defined. Lemma SumProdIntFIntegrable : forall { I J : IntegrationSpace } (l : list (@ProdIntegrable I J)), IntegrableFunction (XsumList (map (fun x : ProdIntegrable => CharacFunc (prodint_f x)) l)). Proof. induction l. - simpl. apply IntegrableZero. - simpl. apply IntegrablePlus. apply a. apply IHl. Qed. Lemma Xproj1Restriction : forall { I J : IntegrationSpace } (f g : @PartialFunction (RealT (ElemFunc I)) (prod (X (ElemFunc I)) (X (ElemFunc J)))) (x : X (ElemFunc I)), PartialRestriction f g -> PartialRestriction (Xproj1 f x) (Xproj1 g x). Proof. split. - intros y H. destruct X. exact (d (x,y) H). - intros. apply X. Qed. Lemma LElemProductIntegrableAEspec : forall { I J : IntegrationSpace } (l : list (@ProdIntegrable I J)) (x : X (ElemFunc I)), Domain (XsumList (map (fun pi => @CharacFunc (RealT (ElemFunc I)) _ (prodint_f pi)) l)) x -> @IntegrableFunction (IntegrationSpaceCast J) (Xproj1 (ProdLFunc l) x). Proof. intros I J l x xDS. (* x in the domain of sum_i f_i. Xproj1 f x = sum_i (a_i f_i(x) g_i), integrable as a linear combination of integrable functions. *) induction l. - apply (IntegrableFunctionExtensional (Xconst _ 0)). split. intros y H0. simpl. trivial. intros. apply DomainProp. apply IntegrableZero. - unfold ProdLFunc. simpl. apply (@IntegrableFunctionExtensional (IntegrationSpaceCast J) (Xplus (Xproj1 (ProdIntegrableFunc a) x) (Xproj1 (XsumList (map ProdIntegrableFunc l)) x))). split. intros y H0. apply H0. intros. destruct xD, xG. apply CRplus_morph. apply CRmult_morph. apply CRmult_morph. reflexivity. apply DomainProp. apply DomainProp. simpl. apply DomainProp. apply (@IntegrablePlus (IntegrationSpaceCast J)). 2: apply IHl, xDS. destruct xDS. apply (@IntegrableFunctionExtensional (IntegrationSpaceCast J) (Xscale (prodint_factor a * partialApply _ x d) (CharacFunc (prodint_g a)))). split. intros y H. split. exact d. exact H. intros. apply CRmult_morph. apply CRmult_morph. reflexivity. apply DomainProp. apply DomainProp. apply (@IntegrableScale (IntegrationSpaceCast J)). apply (@IntegrableFunctionExtensional (IntegrationSpaceCast J) (@PartialFunctionCast (RealT (ElemFunc J)) (RealT (ElemFunc I)) _ (CharacFunc (prodint_g a)))). split. intros y ydf. exact ydf. intros. simpl. destruct xD, xG. apply CRmorph_one. contradiction. contradiction. apply CRmorph_zero. exact (@IntegrableFunctionCast J _ (CharacFunc (prodint_g a)) (prodint_gint a)). Qed. Lemma LElemProductIntegrableAE : forall { I J : IntegrationSpace } (l : list (@ProdIntegrable I J)), IntegrableFunctionAE (ProdLFunc l). Proof. intros I J l. exists (XsumList (map (fun x => CharacFunc (prodint_f x)) l)). split. - apply SumProdIntFIntegrable. - apply LElemProductIntegrableAEspec. Defined. Definition ProdIntegrableFuncIntegrableAE : forall { I J : IntegrationSpace } (p : @ProdIntegrable I J), IntegrableFunctionAE (ProdIntegrableFunc p). Proof. (* Maybe redundant. *) intros. exists (CharacFunc (prodint_f p)). split. apply p. intros x xD. apply (@IntegrableFunctionExtensional (IntegrationSpaceCast J) (Xscale (prodint_factor p * partialApply _ x xD) (CharacFunc (prodint_g p)))). split. intros y H. split. exact xD. exact H. intros. apply CRmult_morph. apply CRmult_morph. reflexivity. apply DomainProp. apply DomainProp. apply (@IntegrableScale (IntegrationSpaceCast J)). apply (@IntegrableFunctionExtensional (IntegrationSpaceCast J) (@PartialFunctionCast (RealT (ElemFunc J)) (RealT (ElemFunc I)) _ (CharacFunc (prodint_g p)))). split. intros y ydf. exact ydf. intros. simpl. destruct xD0, xG. apply CRmorph_one. contradiction. contradiction. apply CRmorph_zero. exact (@IntegrableFunctionCast J _ (CharacFunc (prodint_g p)) (prodint_gint p)). Defined. Lemma ProdIntegrableFuncIntegrable : forall {I J : IntegrationSpace } (a : ProdIntegrable), IntegrableFunction (IntegralFst (ProdIntegrableFunc a) (@ProdIntegrableFuncIntegrableAE I J a)). Proof. intros. apply (IntegrableFunctionExtensional (Xscale (prodint_factor a * CRcast (Integral (prodint_gint a))) (CharacFunc (prodint_f a)))). 2: apply IntegrableScale, a. split. intros x xD. exact xD. intros. simpl in xD, xG. unfold ProdIntegrableFuncIntegrableAE, IntegralFst, partialApply; rewrite IntegralRestrict. rewrite (@IntegralScale (IntegrationSpaceCast J)), IntegralRestrict, IntegralFunctionCast. simpl. destruct xD. destruct xG. 2: contradiction. do 2 rewrite CRmult_1_r. rewrite CRmult_comm. reflexivity. destruct xG. contradiction. do 3 rewrite CRmult_0_r. reflexivity. Defined. Lemma LElemProductIntegralFstIntegrable : forall { I J : IntegrationSpace } (l : list (@ProdIntegrable I J)), IntegrableFunction (IntegralFst (ProdLFunc l) (LElemProductIntegrableAE l)). Proof. (* Linear combination of integrable functions. *) induction l. - (* The zero function defined almost everywhere is integrable. *) unfold IntegralFst; destruct (LElemProductIntegrableAE nil) as [f p], p. apply (IntegrableFunctionExtensional (Xscale 0 f)). split. intros x H; exact H. intros; unfold Domain in xG. simpl. rewrite CRmult_0_l. rewrite (IntegralExtensional _ _ (i0 x xG) IntegrableZero). symmetry. apply (@IntegralZeroIsZero (IntegrationSpaceCast J)). intros. reflexivity. apply IntegrableScale, i. - apply (IntegrableFunctionExtensional (Xplus (IntegralFst _ (ProdIntegrableFuncIntegrableAE a)) (IntegralFst (ProdLFunc l) (LElemProductIntegrableAE l)))). split. + unfold IntegralFst. unfold LElemProductIntegrableAE. intros x [d d0]; unfold Domain in d0; simpl in d; split. exact d. exact d0. + intros. unfold IntegralFst. unfold LElemProductIntegrableAE, Xplus, XbinOp, XbinOpXY, partialApply. destruct xD. unfold ProdIntegrableFuncIntegrableAE; rewrite IntegralRestrict. rewrite <- (@IntegralPlus (IntegrationSpaceCast J) _ _ _ (LElemProductIntegrableAEspec l x d0)); apply (@IntegralExtensional (IntegrationSpaceCast J)). intros. destruct xdf, xdg. unfold ProdLFunc. apply CRplus_morph. apply CRmult_morph. apply CRmult_morph. reflexivity. apply DomainProp. apply DomainProp. simpl. apply DomainProp. + apply IntegrablePlus. 2: exact IHl. clear IHl. apply ProdIntegrableFuncIntegrable. Qed. Lemma IElemProductFubini : forall { I J : IntegrationSpace } (f : PartialFunction (prod (X (ElemFunc I)) (X (ElemFunc J)))) (l : list ProdIntegrable) (res : PartialRestriction (ProdLFunc l) f), IElemProduct f (existT _ l res) == Integral (LElemProductIntegralFstIntegrable l). Proof. intros. simpl. clear res f. induction l. - simpl. rewrite <- (@IntegralZeroIsZero I). apply IntegralExtensional. simpl. intros. rewrite (@IntegralExtensional (IntegrationSpaceCast J) _ _ (LElemProductIntegrableAEspec nil x xdg) IntegrableZero). symmetry. apply (@IntegralZeroIsZero (IntegrationSpaceCast J)). reflexivity. - simpl. rewrite IHl. clear IHl. setoid_replace (prodint_factor a * MeasureSet (prodint_fint a) * CRcast (MeasureSet (prodint_gint a))) with (Integral (ProdIntegrableFuncIntegrable a)). + rewrite <- (@IntegralPlus I). apply IntegralExtensional. intros; simpl in xdf, xdg. destruct xdf as [s d]. unfold Xplus, XbinOp, XbinOpXY, IntegralFst, partialApply. unfold ProdIntegrableFuncIntegrableAE. rewrite IntegralRestrict. rewrite <- (@IntegralPlus (IntegrationSpaceCast J) _ _ _ (LElemProductIntegrableAEspec l x d)); apply (@IntegralExtensional (IntegrationSpaceCast J)). intros. destruct xdf, xdg0, d2. simpl. apply CRplus_morph. 2: apply DomainProp. destruct s. destruct d2. 2: contradiction. destruct d0. destruct d4. reflexivity. contradiction. destruct d4. contradiction. reflexivity. destruct d2. contradiction. rewrite CRmult_0_r, CRmult_0_l, CRmult_0_l. reflexivity. + unfold ProdIntegrableFuncIntegrable; rewrite IntegralRestrict. rewrite IntegralScale. rewrite (CRmult_comm (Integral (prodint_fint a))). do 2 rewrite CRmult_assoc. apply CRmult_morph. reflexivity. rewrite CRmult_comm. reflexivity. Qed. Lemma IElemProductAdditive : forall { I J : IntegrationSpace } (f g : PartialFunction (prod (X (ElemFunc I)) (X (ElemFunc J)))) (fL : L (ProductFunctionRieszSpace I J) f) (gL : L (ProductFunctionRieszSpace I J) g), IElemProduct (Xplus f g) (LplusStable (ProductFunctionRieszSpace I J) f g fL gL) == IElemProduct f fL + IElemProduct g gL. Proof. intros. simpl; unfold IElemProduct; destruct fL as [fl fL]; destruct gL as [gl gL]. clear gL g fL f. induction fl. - simpl (fold_right (CRplus (RealT (ElemFunc I))) 0 (map (fun pi : ProdIntegrable => prodint_factor pi * MeasureSet (prodint_fint pi) * MeasureSet (prodint_gint pi)) nil)). rewrite CRplus_0_l. reflexivity. - simpl. rewrite IHfl. rewrite CRplus_assoc. reflexivity. Qed. Lemma IElemProductHomogeneous : forall { I J : IntegrationSpace } (a : CRcarrier (RealT (ElemFunc I))) (f : PartialFunction (prod (X (ElemFunc I)) (X (ElemFunc J)))) (fL : L (ProductFunctionRieszSpace I J) f), IElemProduct (Xscale a f) (LscaleStable (ProductFunctionRieszSpace I J) a f fL) == a * (IElemProduct f fL). Proof. intros. simpl; unfold IElemProduct; destruct fL as [l fL]. clear fL f. induction l. - simpl. rewrite CRmult_0_r. reflexivity. - simpl. rewrite IHl. do 2 rewrite CRmult_assoc. rewrite <- CRmult_plus_distr_l. apply CRmult_morph. reflexivity. rewrite CRmult_assoc. reflexivity. Qed. Lemma IElemProductOneL : forall { I J : IntegrationSpace } (A : X (ElemFunc I) -> Prop) (B : X (ElemFunc J) -> Prop) (Aint : IntegrableSet A) (Bint : IntegrableSet B) (alpha : CRcarrier (RealT (ElemFunc I))), L (ProductFunctionRieszSpace I J) (ProdIntegrableFunc (Build_ProdIntegrable I J A B alpha Aint Bint)). Proof. intros. exists ((Build_ProdIntegrable I J A B alpha Aint Bint) :: nil). split. - intros [x y] H; apply H. - intros. simpl in xD, xG. unfold ProdLFunc. rewrite <- (CRplus_0_r ( partialApply (ProdIntegrableFunc {| prodint_f := A; prodint_g := B; prodint_factor := alpha; prodint_fint := Aint; prodint_gint := Bint |}) x xG)). destruct xD. apply CRplus_morph. apply DomainProp. reflexivity. Defined. Lemma IntegralFstNonNeg : forall { I J : IntegrationSpace } (f : PartialFunction (prod (X (ElemFunc I)) (X (ElemFunc J)))) (fInt : IntegrableFunctionAE f), nonNegFunc f -> nonNegFunc (IntegralFst f fInt). Proof. intros. intros x xdf. destruct fInt, p; simpl; simpl in xdf. apply (@IntegralNonNeg (IntegrationSpaceCast J)). intros y ydf. apply H. Qed. Lemma applyIntegralFst : forall { I J : IntegrationSpace } (l : list (@ProdIntegrable I J)) (x : X (ElemFunc I)) (lint : @IntegrableFunction (IntegrationSpaceCast J) (Xproj1 (ProdLFunc l) x)) (xD : Domain (IntegralFst (ProdLFunc l) (LElemProductIntegrableAE l)) x), partialApply _ x xD == Integral lint. Proof. intros. apply (@IntegralExtensional (IntegrationSpaceCast J)). intros. apply DomainProp. Qed. Lemma IElemProductExtensional : forall { I J : IntegrationSpace } (f : PartialFunction (X (ProductFunctionRieszSpace I J))) (fl : list (@ProdIntegrable I J)) (fres : PartialRestriction (ProdLFunc fl) f) (g : PartialFunction (X (ProductFunctionRieszSpace I J))) (gL : L (ProductFunctionRieszSpace I J) g) , (forall x (xD : Domain (ProdLFunc fl) x) (yD : Domain g x), partialApply _ x xD == partialApply g x yD) -> IElemProduct f (existT _ fl fres) == IElemProduct g gL. Proof. intros I J f fl fres g gL res. destruct gL. do 2 rewrite IElemProductFubini. apply IntegralExtensional. intros. simpl. apply (@IntegralExtensional (IntegrationSpaceCast J)). intros. simpl. destruct p, fres. rewrite (c _ xdg0 (d _ xdg0)). apply res. Qed. Lemma applyProdLFuncBound : forall { I J : IntegrationSpace } (l : list (@ProdIntegrable I J)) x (xD : Domain (ProdLFunc l) x), partialApply _ x xD <= fold_right (CRplus (RealT (ElemFunc I))) 0 (map (fun a => CRabs _ (prodint_factor a)) l). Proof. induction l. - intros. apply CRle_refl. - intros. simpl. destruct xD. apply CRplus_le_compat. destruct d. simpl. destruct d. destruct d1. do 2 rewrite CRmult_1_r. apply CRle_abs. rewrite CRmult_0_r. apply CRabs_pos. rewrite CRmult_0_r, CRmult_0_l. apply CRabs_pos. apply IHl. Qed. Lemma seq_cv_0_bound : forall {R : ConstructiveReals} (u v : nat -> CRcarrier R), (forall n:nat, 0 <= u n) -> (forall n:nat, u n <= v n) -> CR_cv R v 0 -> CR_cv R u 0. Proof. intros. intro p. specialize (H1 p) as [n H1]. exists n. intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. specialize (H1 i H2). unfold CRminus in H1. rewrite CRopp_0, CRplus_0_r, CRabs_right in H1. exact (CRle_trans _ (v i) _ (H0 i) H1). exact (CRle_trans _ (u i) _ (H i) (H0 i)). exact (H i). Qed. Lemma seq_cv_0_mult : forall {R : ConstructiveReals} (u : nat -> CRcarrier R) (a : CRcarrier R), CR_cv R u 0 -> CR_cv R (fun n => u n * a) 0. Proof. intros R u a H p. destruct (CRup_nat (CRabs _ a)) as [n nup]. destruct (H (p * Pos.of_nat n)%positive) as [k kmaj]. exists k. intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r. specialize (kmaj i H0). unfold CRminus in kmaj. rewrite CRopp_0, CRplus_0_r in kmaj. rewrite CRabs_mult. apply (CRmult_le_compat_r (CR_of_Q R (Z.of_nat n # 1))) in kmaj. rewrite <- CR_of_Q_mult in kmaj. setoid_replace ((1 # p * Pos.of_nat n) * (Z.of_nat n # 1))%Q with (1#p)%Q in kmaj. apply (CRle_trans _ (CRabs _ (u i) * CR_of_Q R (Z.of_nat n # 1))). apply CRmult_le_compat_l. apply CRabs_pos. apply CRlt_asym, nup. exact kmaj. unfold Qmult, Qnum, Qden. rewrite Z.mul_1_l, Pos.mul_1_r. unfold Qeq, Qnum, Qden. rewrite Z.mul_1_l. rewrite Pos2Z.inj_mul, Z.mul_comm. unfold Z.of_nat. simpl. destruct n. exfalso. simpl in nup. exact (CRabs_pos a nup). rewrite Pos.of_nat_succ. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Zle_0_nat. Qed. Lemma ProductMinLimitDecr : forall { I J : IntegrationSpace } (g : PartialFunction (X (ProductFunctionRieszSpace I J))) (gL : L (ProductFunctionRieszSpace I J) g), nonNegFunc g -> CR_cv _ (fun n : nat => IElemProduct (XminConst g (CR_of_Q _ (1 # Pos.of_nat (S n)))) (LminConstStable (CR_of_Q _ (1 # Pos.of_nat (S n))) g (invSuccRealPositive n) gL)) 0. Proof. intros. destruct gL as [l res]. assert (forall n:nat, IElemProduct (ProdLFunc (map (ProdIntegrableMapCoef (fun x => CRmin x (CR_of_Q _ (1 # Pos.of_nat (S n))))) (ProdIntegrableSimplify l))) (existT _ (map (ProdIntegrableMapCoef (fun x => CRmin x (CR_of_Q _ (1 # Pos.of_nat (S n))))) (ProdIntegrableSimplify l)) (PartialRestriction_refl _ _)) == IElemProduct (XminConst g (CR_of_Q _ (1 # Pos.of_nat (S n)))) (LminConstStable (CR_of_Q _ (1 # Pos.of_nat (S n))) g (invSuccRealPositive n) (existT (fun l0 : list ProdIntegrable => PartialRestriction (ProdLFunc l0) g) l res))). { intro n. apply IElemProductExtensional. intros. destruct (ProductMinConstStable l (CR_of_Q _ (1 # Pos.of_nat (S n))) (invSuccRealPositive n)). rewrite (c x xD (d x xD)). unfold XminConst, Xop, partialApply. destruct res. rewrite (c0 x (d x xD) yD). reflexivity. } apply (CR_cv_eq _ (fun n => IElemProduct (ProdLFunc (map (ProdIntegrableMapCoef (fun x => CRmin x (CR_of_Q _ (1 # Pos.of_nat (S n))))) (ProdIntegrableSimplify l))) (existT _ (map (ProdIntegrableMapCoef (fun x => CRmin x (CR_of_Q _ (1 # Pos.of_nat (S n))))) (ProdIntegrableSimplify l)) (PartialRestriction_refl _ _)))). exact H0. apply (seq_cv_0_bound _ (fun n => CR_of_Q _ (1 # Pos.of_nat (S n)) * fold_right (CRplus (RealT (ElemFunc I))) 0 (map (fun pi : ProdIntegrable => MeasureSet (prodint_fint pi) * CRcast (MeasureSet (prodint_gint pi))) (ProdIntegrableSimplify l)))). - intro n. rewrite H0. destruct (LminConstStable (CR_of_Q _ (1 # Pos.of_nat (S n))) g (invSuccRealPositive n) (existT (fun l0 : list ProdIntegrable => PartialRestriction (ProdLFunc l0) g) l res)). rewrite IElemProductFubini. apply IntegralNonNeg. intros x0 xdf. simpl. apply (@IntegralNonNeg (IntegrationSpaceCast J)). intros x1 xdf0. simpl. destruct p. rewrite (c _ xdf0 (d _ xdf0)). apply CRmin_glb. apply H. apply CR_of_Q_le. discriminate. - intro n. generalize (ProdIntegrableSimplify l). induction l0. simpl (fold_right (CRplus _) 0 (map (fun pi : ProdIntegrable => MeasureSet (prodint_fint pi) * MeasureSet (prodint_gint pi)) nil)). rewrite CRmult_0_r. apply CRle_refl. simpl (fold_right (CRplus _) 0 (map (fun pi : ProdIntegrable => MeasureSet (prodint_fint pi) * CRcast (MeasureSet (prodint_gint pi))) (a :: l0))). rewrite CRmult_plus_distr_l. apply CRplus_le_compat. 2: exact IHl0. destruct a; unfold prodint_gint, prodint_fint, ProdIntegrableMapCoef, prodint_factor, prodint_gint, prodint_fint. rewrite CRmult_assoc. apply CRmult_le_compat_r. rewrite <- (CRmult_0_l (CRcast (MeasureSet prodint_gint0))). apply CRmult_le_compat_r. unfold CRcast. rewrite <- (CRmorph_zero (@SlowConstructiveRealsMorphism (RealT (ElemFunc J)) (RealT (ElemFunc I)))). apply CRmorph_le. apply MeasureNonNeg. apply MeasureNonNeg. apply CRmin_r. - apply seq_cv_0_mult. intro p. exists (Pos.to_nat p). intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos, Pos2Nat.inj_le. rewrite Nat2Pos.id. 2: discriminate. apply (Nat.le_trans _ _ _ H1). apply le_S, Nat.le_refl. apply CR_of_Q_le. discriminate. Qed. Lemma ProductMinLimits : forall { I J : IntegrationSpace } (f : PartialFunction (X (ProductFunctionRieszSpace I J))) (fL : L (ProductFunctionRieszSpace I J) f), CR_cv _ (fun n : nat => IElemProduct (XminConst f (INR n)) (LminIntStable n f fL)) (IElemProduct f fL) * CR_cv _ (fun n : nat => IElemProduct (XminConst (Xabs f) (CR_of_Q _ (1 # Pos.of_nat (S n)))) (LminConstStable (CR_of_Q _ (1 # Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable (ProductFunctionRieszSpace I J) f fL))) 0. Proof. intros. split. - (* A sum of ProdIntegrableFunc is majorated by the sum of the product factors. *) destruct fL as [l fL]. destruct (CRup_nat (fold_right (CRplus _) 0 (map (fun a => CRabs _ (prodint_factor a)) l))) as [n nup]. exists n. intros. setoid_replace (IElemProduct (XminConst f (INR i)) (LminIntStable i f (existT (fun l0 : list ProdIntegrable => PartialRestriction (ProdLFunc l0) f) l fL)) - IElemProduct f (existT (fun l0 : list ProdIntegrable => PartialRestriction (ProdLFunc l0) f) l fL)) with (CR_of_Q (RealT (ElemFunc I)) 0). rewrite CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. rewrite <- (CRplus_opp_r (IElemProduct f (existT (fun l0 : list ProdIntegrable => PartialRestriction (ProdLFunc l0) f) l fL))). apply CRplus_morph. 2: reflexivity. symmetry. apply IElemProductExtensional. intros. unfold XminConst, Xop, partialApply. rewrite CRmin_left. destruct fL. rewrite (c x xD (d x xD)). apply DomainProp. simpl in yD. destruct fL. rewrite <- (c x xD). apply (CRle_trans _ _ _ (applyProdLFuncBound l x xD)). apply (CRle_trans _ (CR_of_Q _ (Z.of_nat n # 1))). apply CRlt_asym, nup. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, H. - (* The sequences finishes integrating a constant function. *) apply ProductMinLimitDecr. intros x xdf. apply CRabs_pos. Qed. Lemma ProductIContinuous { I J : IntegrationSpace } : @ElemIntegralContinuous (ProductFunctionRieszSpace I J) IElemProduct. Proof. intros f fn fL fnL fnNonNeg cv. destruct fL as [fl fL]. pose (fun n => let (l,_) := fnL n in l) as ln. assert (forall n:nat, PartialRestriction (ProdLFunc (ln n)) (fn n)) as resn. { intro n. unfold ln. destruct (fnL n). exact p. } destruct (IntegrableContinuous (IntegralFst (ProdLFunc fl) (LElemProductIntegrableAE fl)) (fun n => IntegralFst (ProdLFunc (ln n)) (LElemProductIntegrableAE (ln n))) (LElemProductIntegralFstIntegrable fl) (fun n => LElemProductIntegralFstIntegrable (ln n))) as [x [limx xcv]]. intro n. apply IntegralFstNonNeg. intros t tdf. destruct (resn n). rewrite (c t tdf (d t tdf)). apply fnNonNeg. destruct cv, p. simpl in x. exists x. split. apply (series_cv_eq (fun n : nat => IElemProduct (fn n) (fnL n))). 2: exact s. intro n. unfold ln. destruct (fnL n). rewrite IElemProductFubini. reflexivity. simpl. rewrite IElemProductFubini in c. exact c. assert (forall n:nat, Domain (XsumList (map (fun x : ProdIntegrable => @CharacFunc (RealT (ElemFunc I)) _ (prodint_f x)) (ln n))) (cpx _ _ _ x)) as H2. { intro n. apply (cpxFn _ _ _ x n). } assert (forall n:nat, @IntegrableFunction (IntegrationSpaceCast J) (Xproj1 (ProdLFunc (ln n)) (cpx _ _ _ x))) as fnInt. { intro n. specialize (H2 n). unfold ln. unfold ln in H2. destruct (fnL n). apply LElemProductIntegrableAEspec. exact H2. } destruct (@IntegrableContinuous (IntegrationSpaceCast J) (Xproj1 (ProdLFunc fl) (cpx _ _ _ x)) (fun n => Xproj1 (ProdLFunc (ln n)) (cpx _ _ _ x)) (LElemProductIntegrableAEspec fl (cpx _ _ _ x) (cpxF _ _ _ x)) fnInt) as [y ycv]. intro n. intros y ydf. pose proof (Xproj1Restriction _ _ (cpx _ _ _ x) (resn n)) as [d c]. rewrite (c y ydf (d y ydf)). apply fnNonNeg. exists limx. destruct xcv. split. apply (series_cv_eq (fun n : nat => partialApply (IntegralFst (ProdLFunc (ln n)) (LElemProductIntegrableAE (ln n))) (cpx _ _ _ x) (cpxFn _ _ _ x n))). 2: exact s. intro n. apply applyIntegralFst. destruct x. simpl in c. simpl. exact c. destruct fL. assert (forall n : nat, DomainInclusion (ProdLFunc (ln n)) (fn n)) as incn. { intro n. destruct (resn n). exact d0. } exists (Build_CommonPointFunSeq _ _ f fn (cpx _ _ _ x, cpx _ _ _ y) (d (cpx _ _ _ x, cpx _ _ _ y) (cpxF _ _ _ y)) (fun n => incn n (cpx _ _ _ x, cpx _ _ _ y) (cpxFn _ _ _ y n))); unfold cpx, cpxF, cpxFn. destruct ycv as [y0 [ycv ylt]]. exists y0. split. apply (series_cv_eq (fun n : nat => partialApply (Xproj1 (ProdLFunc (ln n)) (cpx (X (ElemFunc I)) (IntegralFst (ProdLFunc fl) (LElemProductIntegrableAE fl)) (fun n0 : nat => IntegralFst (ProdLFunc (ln n0)) (LElemProductIntegrableAE (ln n0))) x)) (cpx _ _ _ y) (cpxFn _ _ _ y n))). 2: exact ycv. intro n. destruct (resn n). apply c0. simpl in ylt; rewrite c in ylt; exact ylt. Qed. Definition ProductIntegrationSpace (I J : IntegrationSpace) : IntegrationSpace. Proof. intros. destruct (PositiveMeasureSubsetExists I) as [A Aint H]. destruct (PositiveMeasureSubsetExists J) as [B Bint H0]. apply (Build_IntegrationSpace (ProductFunctionRieszSpace I J) IElemProduct IElemProductAdditive IElemProductHomogeneous (ProdIntegrableFunc (Build_ProdIntegrable I J A B (CRinv _ (MeasureSet Aint) (inr H) * CRcast (CRinv _ (MeasureSet Bint) (inr H0))) Aint Bint)) (IElemProductOneL A B Aint Bint _)). - unfold IElemProduct, IElemProductOneL, map, fold_left, prodint_factor. unfold prodint_fint, prodint_gint, fold_right. rewrite CRplus_0_r, CRmult_assoc, (CRmult_comm (MeasureSet Aint)). rewrite CRmult_assoc. rewrite <- (CRmult_assoc (CRcast (CRinv (RealT (ElemFunc J)) (MeasureSet Bint) (inr H0)))). unfold CRcast. rewrite <- CRmorph_mult. rewrite (CRmorph_proper _ (CRinv (RealT (ElemFunc J)) (MeasureSet Bint) (inr H0) * MeasureSet Bint) 1). rewrite CRmorph_one, CRmult_1_l. apply CRinv_l. apply CRinv_l. - apply ProductIContinuous. - apply ProductMinLimits. Defined. corn-8.20.0/reals/stdlib/CMTReals.v000066400000000000000000002024751473720167500167600ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* We provide the standard constructive integration space on the real numbers. This is the constructive expression of the Lebesgue measure. The elementary functions are the uniformly continuous functions R -> R with compact support, with the canonical definition of the integral in this case : the difference of anti-derivatives. It is the example given by Bishop and Cheng, page 67 of their article. Working in R rather than in a locally compact space X simplifies the proof, because we replace compact sets by segments (thus skipping the theory of profiles). One might be tempted to restrict to piecewise linear functions with compact support, however one cannot constructively prove that those are stable under absolute value. It would require exact comparisons of the values of the functions with zero. *) From Coq Require Import ZArith QArith Qminmax Qpower Qabs. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Require Import ConstructiveDiagonal. Require Import ConstructivePartialFunctions. Require Import ConstructiveUniformCont. Require Import ConstructiveCauchyIntegral. Require Import CMTbase. Require Import CMTPositivity. Require Import CMTIntegrableFunctions. Require Import CMTFullSets. Require Import CMTIntegrableSets. Local Open Scope ConstructiveReals. Record Is_CSUC_func {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)) : Type := { CSUC_fullDomain : forall x : CRcarrier R, Domain f x; CSUC_low : CRcarrier R; CSUC_high : CRcarrier R; (* The zero function has an empty support, but we can extend it to a point. A nonempty support allows to define its distance to a point. *) CSUC_lowHigh : CSUC_low <= CSUC_high; CSUC_cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R; CSUC_adapt : CSUC (TotalizeFunc (CRcarrier R) f CSUC_fullDomain) CSUC_low CSUC_high CSUC_cont_mod; }. Definition CSUC_func_plus_stable : forall {R : ConstructiveReals} (f g : PartialFunction (CRcarrier R)), Is_CSUC_func f -> Is_CSUC_func g -> Is_CSUC_func (Xplus f g). Proof. intros R [df f injPrF] [dg g injPrG] [fullDomF lowF highF lowHighF modF] [fullDomG lowG highG lowHighG modG]. assert (CRmin lowF lowG <= CRmax highF highG) as sumLowHigh. { apply (CRle_trans _ lowF). apply CRmin_l. apply (CRle_trans _ highF). apply lowHighF. apply CRmax_l. } apply (Build_Is_CSUC_func R (Xplus {| Domain := df; partialApply := f; DomainProp := injPrF |} {| Domain := dg; partialApply := g; DomainProp := injPrG |}) (fun x => pair (fullDomF x) (fullDomG x)) (CRmin lowF lowG) (CRmax highF highG) sumLowHigh (fun x xPos => CRmin (modF (x * CR_of_Q R (1#2)) (eps2_Rgt_R0 x xPos)) (modG (x * CR_of_Q R (1#2)) (eps2_Rgt_R0 x xPos)))). split. - apply UC_plus. apply CSUC_adapt0. apply CSUC_adapt1. - intros. simpl. destruct CSUC_adapt0 as [H0 H1]. simpl in H1. rewrite H1. destruct CSUC_adapt1 as [H2 H3]. simpl in H3. rewrite H3. rewrite CRplus_0_l. reflexivity. destruct H as [H|H]. left. apply (CRlt_le_trans x _ _ H). apply CRmin_r. right. apply (CRle_lt_trans _ (CRmax highF highG)). apply CRmax_r. apply H. destruct H as [H|H]. left. apply (CRlt_le_trans x _ _ H). apply CRmin_l. right. apply (CRle_lt_trans _ (CRmax highF highG)). apply CRmax_l. apply H. Defined. Definition CSUC_func_abs_stable : forall {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)), Is_CSUC_func f -> Is_CSUC_func (Xabs f). Proof. intros R f H. destruct H, f. apply (Build_Is_CSUC_func R (Xabs {| Domain := Domain; partialApply := partialApply; DomainProp := DomainProp |}) CSUC_fullDomain0 CSUC_low0 CSUC_high0 CSUC_lowHigh0 CSUC_cont_mod0). destruct CSUC_adapt0. split. split. - intro x. apply (fst u). - intros. simpl. apply (CRle_lt_trans _ _ _ (CRabs_triang_inv2 _ _)). destruct u. apply (c1 _ _ _ epsPos). apply H. - intros. simpl. destruct u. simpl in c. rewrite c. apply CRabs_right. apply CRle_refl. apply H. Defined. Definition CSUC_func_min_stable : forall {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)), Is_CSUC_func f -> Is_CSUC_func (XminConst f 1). Proof. intros R f H. destruct H,f. apply (Build_Is_CSUC_func R (XminConst {| Domain := Domain; partialApply := partialApply; DomainProp := DomainProp |} 1) CSUC_fullDomain0 CSUC_low0 CSUC_high0 CSUC_lowHigh0 CSUC_cont_mod0). destruct CSUC_adapt0. split. split. - intro x. apply (fst u). - intros. simpl. apply (CRle_lt_trans _ (CRabs _ (partialApply x (CSUC_fullDomain0 x) - partialApply y (CSUC_fullDomain0 y)))). apply CRmin_contract. destruct u. apply (c1 _ _ _ epsPos). apply H. - intros. simpl in c. unfold TotalizeFunc, XminConst, Xop, ConstructivePartialFunctions.partialApply. rewrite c. apply CRmin_left. apply CRlt_asym, CRzero_lt_one. apply H. Defined. Definition CSUC_func_scale {R : ConstructiveReals} (a : CRcarrier R) (f : PartialFunction (CRcarrier R)) : Is_CSUC_func f -> Is_CSUC_func (Xscale a f). Proof. intros H. destruct H,f. apply (Build_Is_CSUC_func R (Xscale a {| Domain := Domain; partialApply := partialApply; DomainProp := DomainProp |}) CSUC_fullDomain0 CSUC_low0 CSUC_high0 CSUC_lowHigh0 (fun (eps:CRcarrier R) epsPos => CSUC_cont_mod0 (eps * CRinv R (CRmax 1 (CRabs _ a)) (inr (posScale a))) (CRmult_lt_0_compat _ eps _ epsPos (CRinv_0_lt_compat _ _ (inr (posScale a)) (posScale a))))). destruct CSUC_adapt0. split. - apply UC_scale. exact u. - intros. simpl. simpl in c. rewrite c. rewrite CRmult_0_r. reflexivity. exact H. Defined. Lemma CSUCext : forall {R : ConstructiveReals} (f g : PartialFunction (CRcarrier R)), PartialFunExtEq f g -> Is_CSUC_func f -> Is_CSUC_func g. Proof. intros R f g H H0. destruct f,g,H,H0,p; simpl in d. simpl in CSUC_fullDomain0. apply (Build_Is_CSUC_func R {| Domain := Domain0; partialApply := partialApply0; DomainProp := DomainProp0 |} (fun x => d x (CSUC_fullDomain0 x)) CSUC_low0 CSUC_high0 CSUC_lowHigh0 CSUC_cont_mod0). split. apply (UC_ext (TotalizeFunc (CRcarrier R) {| Domain := Domain; partialApply := partialApply; DomainProp := DomainProp |} CSUC_fullDomain0)). apply CSUC_adapt0. intro x. simpl. apply c. intros. simpl. destruct CSUC_adapt0. simpl in c, c0. rewrite <- (c x (CSUC_fullDomain0 x)). apply c0. exact H. Defined. Definition ElemCSUC {R : ConstructiveReals} : FunctionRieszSpace. Proof. apply (Build_FunctionRieszSpace (CRcarrier R) R Is_CSUC_func). - apply CSUCext. - apply CSUC_func_plus_stable. - apply CSUC_func_abs_stable. - apply CSUC_func_min_stable. - apply CSUC_func_scale. Defined. Definition IntegralCSUC {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)) (fCSUC : Is_CSUC_func f) : CRcarrier R := UC_integral (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain _ fCSUC)) (CSUC_low _ fCSUC) (CSUC_high _ fCSUC) (CSUC_cont_mod _ fCSUC) (fst (CSUC_adapt _ fCSUC)) (CSUC_lowHigh _ fCSUC). (* Extend the support *) Lemma CSUCextendAdapt : forall {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (a b : CRcarrier R), a <= CSUC_low f fL -> CSUC_high f fL <= b -> CSUC (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL)) a b (CSUC_cont_mod f fL). Proof. split. split. - apply fL. - apply fL. - intros. destruct fL,CSUC_adapt0,u. simpl. simpl in H,H0. rewrite (c x). reflexivity. destruct H1. left. exact (CRlt_le_trans x a _ c2 H). right. exact (CRle_lt_trans _ b x H0 c2). Qed. Lemma CSUCextendSupport : forall {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (a b : CRcarrier R) (aBelow : a <= CSUC_low f fL) (bAbove : CSUC_high f fL <= b) (leab : a <= b), (* redundant *) IntegralCSUC f fL == UC_integral (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL)) a b (CSUC_cont_mod f fL) (fst (CSUCextendAdapt f fL a b aBelow bAbove)) leab. Proof. (* Use Chasles relation *) intros. assert (CSUC_low f fL <= b). { apply (CRle_trans _ (CSUC_high f fL)). apply CSUC_lowHigh. apply bAbove. } rewrite (UC_integral_chasles a (CSUC_low f fL) b _ _ _ aBelow H). rewrite (UC_integral_chasles (CSUC_low f fL) (CSUC_high f fL) b _ _ _ (CSUC_lowHigh f fL) bAbove). rewrite (UC_integral_zero _ a (CSUC_low f fL)). rewrite (UC_integral_zero _ (CSUC_high f fL) b). rewrite CRplus_0_l, CRplus_0_r. apply (UC_integral_extens (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL)) (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL)) (CSUC_low f fL) (CSUC_high f fL)). - intros. reflexivity. - intros. apply (CSUC_connect_support _ (CSUC_low f fL) (CSUC_high f fL) (CSUC_cont_mod f fL)). apply fL. right. apply H0. - intros. apply (CSUC_connect_support _ (CSUC_low f fL) (CSUC_high f fL) (CSUC_cont_mod f fL)). apply fL. left. apply H0. Qed. Lemma CSUCIntegralAdditive : forall {R : ConstructiveReals} (f g : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (gL : Is_CSUC_func g), IntegralCSUC (Xplus f g) (CSUC_func_plus_stable f g fL gL) == IntegralCSUC f fL + IntegralCSUC g gL. Proof. intros. pose (CRmin (CSUC_low f fL) (CSUC_low g gL)) as c. pose (CRmax (CSUC_high f fL) (CSUC_high g gL)) as d. assert (c <= d). { apply (CRle_trans _ (CSUC_low f fL)). apply CRmin_l. apply (CRle_trans _ (CSUC_high f fL)). apply (CSUC_lowHigh f fL). apply CRmax_l. } (* Integrate f and g on [c,d], with same integral because they equal 0 outside their supports. *) rewrite (CSUCextendSupport f fL c d (CRmin_l _ _) (CRmax_l _ _) H). rewrite (CSUCextendSupport g gL c d (CRmin_r _ _) (CRmax_r _ _) H). transitivity (UC_integral (fun x => TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL) x + TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gL) x) (CSUC_low (Xplus f g) (CSUC_func_plus_stable f g fL gL)) (CSUC_high (Xplus f g) (CSUC_func_plus_stable f g fL gL)) _ (UC_plus _ _ _ _ (fst (CSUC_adapt f fL)) (fst (CSUC_adapt g gL))) (CSUC_lowHigh (Xplus f g) (CSUC_func_plus_stable f g fL gL))). unfold IntegralCSUC. apply (UC_integral_extens (TotalizeFunc (CRcarrier R) (Xplus f g) (CSUC_fullDomain (Xplus f g) (CSUC_func_plus_stable f g fL gL))) (fun x : CRcarrier R => TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL) x + TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gL) x)). - intros. destruct f,g,fL,gL; reflexivity. - destruct f,g,fL,gL; apply UC_integral_plus. Qed. Lemma CSUCIntegralAdditiveIterate : forall {R : ConstructiveReals} (fn : nat -> @PartialFunction R (X ElemCSUC)) (fnL : forall n : nat, L ElemCSUC (fn n)) (N : nat), IntegralCSUC (Xsum fn N) (LsumStable fn fnL N) == CRsum (fun n : nat => IntegralCSUC (fn n) (fnL n)) N. Proof. induction N. - reflexivity. - simpl. rewrite <- IHN. rewrite CSUCIntegralAdditive. reflexivity. Qed. Lemma CSUC_bound_ext : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b c d : CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R), a == c -> b == d -> CSUC f a b cont_mod -> CSUC f c d cont_mod. Proof. intros. destruct H1. split. exact u. intros. destruct H1. apply c0. left. apply (CRlt_le_trans _ _ _ c1). apply H. apply c0. right. apply (CRle_lt_trans _ d). apply H0. exact c1. Qed. Definition CSUCTrapeze_IS_CSUC {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta) : a <= b -> Is_CSUC_func (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze a b eta etaPos)) := fun leab => Build_Is_CSUC_func R (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze a b eta etaPos)) (fun x:CRcarrier R => Logic.I) (a-eta) (b+eta) (TrapezeLe a b eta etaPos leab) (* The modulus could be improved to eps *) (fun eps epsPos => eps * CR_of_Q R (1#2) * eta) (CSUCTrapeze_CSUC a b eta etaPos leab). Lemma CSUCIntegralHomogeneous : forall {R : ConstructiveReals} (a : CRcarrier R) (f : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f), IntegralCSUC (Xscale a f) (CSUC_func_scale a f fL) == a * IntegralCSUC f fL. Proof. intros. (* Get the a inside to the right *) unfold IntegralCSUC. rewrite <- UC_integral_scale. destruct f,fL; apply UC_integral_extens; reflexivity. Qed. Section CSUCContinuous. (* Hide the details of this proof *) Variable (R : ConstructiveReals) (g : CRcarrier R -> CRcarrier R) (fn : nat -> CRcarrier R -> CRcarrier R) (fnPos : forall (k:nat) (x:CRcarrier R), 0 <= fn k x) (fnMod : nat -> forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fnCont : forall n:nat, UniformCont (fn n) (fnMod n)) (gMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (a b : CRcarrier R) (leab : a <= b) (gCSUC : CSUC g a b gMod) (majInt : series_cv_lim_lt (fun k : nat => UC_integral (fn k) a b (fnMod k) (fnCont k) leab) (UC_integral g a b gMod (fst gCSUC) leab)). (* An interval where the searched point is *) Record CSUCposPointApprox : Set := { x : CRcarrier R; y : CRcarrier R; lexy : x <= y; lambdaInfiniteMaj : series_cv_lim_lt (fun k : nat => UC_integral (fn k) x y (fnMod k) (fnCont k) lexy) (UC_integral g x y gMod (fst gCSUC) lexy); }. Definition CSUCposPointApproxInit : CSUCposPointApprox := Build_CSUCposPointApprox a b leab majInt. Lemma LocalizeIntegralSeries : forall (x y z t : CRcarrier R) (infint : CRcarrier R) (lexy : x <= y) (lezt : z <= t), x <= z -> t <= y -> series_cv (fun k : nat => UC_integral (fn k) x y (fnMod k) (fnCont k) lexy) infint -> { sLoc : CRcarrier R & series_cv (fun k : nat => UC_integral (fn k) z t (fnMod k) (fnCont k) lezt) sLoc }. Proof. intros. destruct (series_cv_maj (fun k : nat => UC_integral (fn k) z t (fnMod k) (fnCont k) lezt) (fun k : nat => UC_integral (fn k) x0 y0 (fnMod k) (fnCont k) lexy0) infint). - intros. rewrite CRabs_right. apply (UC_integral_extend_nonneg (fn n) (fnMod n)). exact H. exact H0. apply fnPos. apply UC_integral_pos. intros. apply fnPos. - exact H1. - exists x1. apply p. Qed. Definition CSUCposPointApproxStep (n : nat) (currStep : CSUCposPointApprox) : { nextApprox : CSUCposPointApprox | x currStep <= x nextApprox /\ y nextApprox <= y currStep /\ y nextApprox - x nextApprox == (y currStep - x currStep) * CR_of_Q R (1#2) }. Proof. clear majInt. destruct currStep, lambdaInfiniteMaj0, p as [i r]. assert (x0 <= (x0+y0) * CR_of_Q R (1#2)). { apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos. reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l, CRmult_1_r, CRmult_1_r. apply CRplus_le_compat_l. exact lexy0. } assert ((x0+y0) * CR_of_Q R (1#2) <= y0). { apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos. reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l, CRmult_1_r, CRmult_1_r. apply CRplus_le_compat_r. exact lexy0. } destruct (LocalizeIntegralSeries x0 y0 x0 ((x0+y0)*CR_of_Q R (1#2)) x1 lexy0 H (CRle_refl x0)). exact H0. exact i. destruct (LocalizeIntegralSeries x0 y0 ((x0+y0) * CR_of_Q R (1#2)) y0 x1 lexy0 H0 H). apply CRle_refl. exact i. assert (x1 == x2 + x3) as H1. { apply (CR_cv_unique _ _ _ i). apply (series_cv_eq (fun k : nat => UC_integral (fn k) x0 ((x0 + y0) * CR_of_Q R (1#2)) (fnMod k) (fnCont k) H + (UC_integral (fn k) ((x0 + y0) * CR_of_Q R (1#2)) y0 (fnMod k) (fnCont k) H0))). intros. symmetry. apply UC_integral_chasles. apply series_cv_plus. exact s. exact s0. } simpl. rewrite H1 in r. rewrite (UC_integral_chasles x0 ((x0+y0) * CR_of_Q R (1#2)) y0 _ _ _ H H0) in r. apply Rplus_lt_epsilon in r. assert ((y0 - x0) * CR_of_Q R (1 # 2) <= (x0 + y0) * CR_of_Q R (1 # 2) - x0). { apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos. reflexivity. unfold CRminus. rewrite CRmult_plus_distr_r, CRmult_plus_distr_r. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_plus_distr_r, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_r, CRmult_1_r, CRmult_1_r. rewrite (CRplus_comm x0), CRplus_assoc. apply CRplus_le_compat_l. rewrite CRmult_plus_distr_l, CRmult_1_r, <- CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_l. apply CRle_refl. } destruct r. - assert (series_cv_lim_lt (fun k : nat => UC_integral (fn k) x0 ((x0 + y0) * CR_of_Q R (1#2)) (fnMod k) (fnCont k) H) (UC_integral g x0 ((x0 + y0) * CR_of_Q R (1#2)) gMod (fst gCSUC) H)). { exists x2. split. exact s. exact c. } exists (Build_CSUCposPointApprox x0 ((x0 + y0) * CR_of_Q R (1#2)) H H3). simpl. repeat split. apply CRle_refl. exact H0. exact H2. apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos. reflexivity. unfold CRminus. rewrite CRmult_plus_distr_r, CRmult_plus_distr_r. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_plus_distr_r, CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_plus_distr_r, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_r, CRmult_1_r, CRmult_1_r. rewrite (CRplus_comm x0), CRplus_assoc. apply CRplus_le_compat_l. rewrite CRmult_plus_distr_l, CRmult_1_r, <- CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_l. apply CRle_refl. - assert (series_cv_lim_lt (fun k : nat => UC_integral (fn k) ((x0 + y0) * CR_of_Q R (1#2)) y0 (fnMod k) (fnCont k) H0) (UC_integral g ((x0 + y0) * CR_of_Q R (1#2)) y0 gMod (fst gCSUC) H0)). { exists x3. split. exact s0. exact c. } exists (Build_CSUCposPointApprox ((x0 + y0) * CR_of_Q R (1#2)) y0 H0 H3). simpl. repeat split. exact H. apply CRle_refl. apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos. reflexivity. unfold CRminus. rewrite CRmult_plus_distr_r, CRmult_plus_distr_r. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_plus_distr_r, CRopp_mult_distr_l, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_r, CRmult_1_r, CRmult_1_r. rewrite CRopp_plus_distr. rewrite (CRplus_comm (-x0)), <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_r. apply CRle_refl. apply (CRmult_le_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos. reflexivity. unfold CRminus. rewrite CRmult_plus_distr_r, CRmult_plus_distr_r. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRopp_plus_distr, CRmult_plus_distr_r, CRopp_mult_distr_l, CRmult_assoc, <- CR_of_Q_mult. rewrite CRopp_mult_distr_l, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_r, CRmult_1_r, CRmult_1_r. rewrite (CRplus_comm (-x0)), <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_r. apply CRle_refl. Qed. Definition CSUCposPointApproxSequence : nat -> CSUCposPointApprox := nat_rec _ CSUCposPointApproxInit (fun (n:nat) currStep => proj1_sig (CSUCposPointApproxStep n currStep)). (* The segments are nested, so the centers form a Cauchy sequence. *) Lemma CSUCposPointApproxSequenceNested : forall n p : nat, x (CSUCposPointApproxSequence n) <= x (CSUCposPointApproxSequence (n + p)) /\ y (CSUCposPointApproxSequence (n+p)) <= y (CSUCposPointApproxSequence n). Proof. intros. generalize dependent n. induction p. - intros. rewrite Nat.add_0_r. destruct (CSUCposPointApproxSequence n). split; apply CRle_refl. - intro n. rewrite Nat.add_succ_r. simpl. specialize (IHp n). destruct (CSUCposPointApproxSequence n). destruct (CSUCposPointApproxStep (n + p) (CSUCposPointApproxSequence (n + p))). destruct (CSUCposPointApproxSequence (n+p)), x1. simpl. simpl in a0. split. apply (CRle_trans _ x2). apply IHp. apply a0. apply (CRle_trans _ y1). apply a0. apply IHp. Qed. Lemma CSUCposPointApproxSequenceLength : forall n:nat, (y (CSUCposPointApproxSequence n) - x (CSUCposPointApproxSequence n) == (b-a) * CR_of_Q R (/2^Z.of_nat n)). Proof. induction n. - simpl. rewrite CRmult_1_r. reflexivity. - rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Qpower_plus. simpl. destruct (CSUCposPointApproxStep n (CSUCposPointApproxSequence n)); simpl. destruct a0, H0. unfold Qdiv. rewrite Qinv_mult_distr, CR_of_Q_mult, <- CRmult_assoc, <- IHn. clear IHn. exact H1. discriminate. Qed. Lemma CSUCposPointApproxSequenceCvZero : forall n : positive, { p : nat & forall i : nat, (p <= i)%nat -> CRabs R (y (CSUCposPointApproxSequence i) - x (CSUCposPointApproxSequence i)) < CR_of_Q R (1 # n) }. Proof. intros n. destruct (CRup_nat (b - a)) as [i imaj]. destruct i. exfalso. simpl in imaj. rewrite <- (CRplus_opp_r a) in imaj. apply CRplus_lt_reg_r in imaj. contradiction. destruct (@GeoCvZero R (Pos.of_nat (S i)*n)%positive) as [p pmaj]. exists p. intros. apply (CRle_lt_trans _ ((b-a)* CR_of_Q R ((/2)^Z.of_nat p))). - rewrite Qinv_power. pose proof (CSUCposPointApproxSequenceLength p). rewrite <- H0. clear H0. destruct (Nat.le_exists_sub p i0 H), H0. subst i0. apply Rsmaller_interval. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. apply (CRle_trans _ (y (CSUCposPointApproxSequence (x0 + p)))). destruct (CSUCposPointApproxSequence (x0 + p)); simpl. exact lexy0. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. apply (CRle_trans _ (x (CSUCposPointApproxSequence (x0+p)))). rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. destruct (CSUCposPointApproxSequence (x0 + p)); simpl. exact lexy0. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. - specialize (pmaj p (Nat.le_refl p)). unfold CRminus in pmaj. rewrite CRopp_0, CRplus_0_r in pmaj. apply (CRlt_le_trans _ (CR_of_Q R ((Z.of_nat (S i) # 1) * (/ 2) ^ Z.of_nat p ))). rewrite CR_of_Q_mult. apply CRmult_lt_compat_r. 2: exact imaj. apply CR_of_Q_pos. apply Qpower_positive. reflexivity. rewrite CRabs_right in pmaj. 2: apply CRlt_asym, CRpow_gt_zero; exact Rlt_0_half. apply CR_of_Q_le. setoid_replace (CRpow (CR_of_Q R (1 # 2)) p) with (CR_of_Q R ((/ 2) ^ Z.of_nat p )) in pmaj. destruct (Q_dec ((/ 2) ^ Z.of_nat p) (1 # Pos.of_nat (S i) * n)). destruct s. apply (Qmult_lt_l _ _ (Z.of_nat (S i) # 1)) in q. apply (Qle_trans _ ((Z.of_nat (S i) # 1) * (1 # Pos.of_nat (S i) * n))%Q). apply Qlt_le_weak, q. 2: reflexivity. unfold Qmult, Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l, Pos.mul_1_l. rewrite Pos2Z.inj_mul. unfold Z.of_nat. rewrite Pos.of_nat_succ. apply Z.le_refl. exfalso. apply (CR_of_Q_lt R) in q. apply pmaj, q. rewrite q. unfold Qmult, Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l, Pos.mul_1_l. rewrite Pos2Z.inj_mul. unfold Z.of_nat. rewrite Pos.of_nat_succ. apply Z.le_refl. rewrite pow_inject_Q. reflexivity. discriminate. Qed. Lemma CSUCposPointApproxSequenceCauchy : { l : CRcarrier R & CR_cv R (fun n => x (CSUCposPointApproxSequence n)) l }. Proof. apply (CR_complete R (fun n => x (CSUCposPointApproxSequence n))). intros n. destruct (CSUCposPointApproxSequenceCvZero n) as [p pmaj]. exists p. intros. apply (CRle_trans _ (y (CSUCposPointApproxSequence p) - x (CSUCposPointApproxSequence p))). - destruct (Nat.le_exists_sub p j H0), H1. subst j. destruct (Nat.le_exists_sub p i H), H1. subst i. apply Rsmaller_interval. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. apply (CRle_trans _ (y (CSUCposPointApproxSequence (x0 + p)))). destruct (CSUCposPointApproxSequence (x0 + p)); simpl. exact lexy0. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. apply (CRle_trans _ (y (CSUCposPointApproxSequence (x1 + p)))). destruct (CSUCposPointApproxSequence (x1 + p)); simpl. exact lexy0. rewrite Nat.add_comm. apply CSUCposPointApproxSequenceNested. - specialize (pmaj p (Nat.le_refl p)). unfold CRminus in pmaj. unfold CRminus. apply CRlt_asym. exact (CRle_lt_trans _ _ _ (CRle_abs _) pmaj). Qed. Lemma CSUCposPointApproxLimitNested : forall n : nat, let (l,_) := CSUCposPointApproxSequenceCauchy in x (CSUCposPointApproxSequence n) <= l /\ l <= y (CSUCposPointApproxSequence n). Proof. intro n. pose proof (CSUCposPointApproxSequenceNested n). destruct CSUCposPointApproxSequenceCauchy as [l lcv], (CSUCposPointApproxSequence n); simpl. split. - apply (CR_cv_bound_down (fun n : nat => x (CSUCposPointApproxSequence n)) _ _ n). intros. destruct (Nat.le_exists_sub n n0 H0). destruct H1. subst n0. rewrite Nat.add_comm. specialize (H x1). destruct (CSUCposPointApproxSequence (n + x1)); simpl; simpl in H. apply H. apply lcv. - apply (CR_cv_bound_up (fun n : nat => x (CSUCposPointApproxSequence n)) _ _ n). intros. destruct (Nat.le_exists_sub n n0 H0). destruct H1. subst n0. rewrite Nat.add_comm. specialize (H x1). destruct (CSUCposPointApproxSequence (n + x1)); simpl; simpl in H. apply (CRle_trans _ y1). exact lexy1. apply H. apply lcv. Qed. Lemma CSUCIcontinuous : let (l,_) := CSUCposPointApproxSequenceCauchy in forall k:nat, CRsum (fun n => fn n l) k <= g l. Proof. pose proof CSUCposPointApproxLimitNested. destruct CSUCposPointApproxSequenceCauchy as [l lcv]. intro k. intro abs. destruct (UC_sum (fun n x => fn n x) fnMod fnCont k) as [modS contS]. destruct (EnlargePointMajoration g _ l gMod modS (fst gCSUC) contS abs) as [eta [etaPos etaMaj]]. (* Put the approximation's integral domain inside eta *) destruct (CRup_nat (CRinv R eta (inr etaPos))) as [p pmaj]. assert (0 < @INR R p) as qpPos. { apply (CRlt_trans _ (CRinv R eta (inr etaPos))). apply CRinv_0_lt_compat. exact etaPos. exact pmaj. } assert (0 < p)%nat. { unfold INR in qpPos. destruct p. 2: apply le_n_S, Nat.le_0_l. exfalso. contradict qpPos. apply (CRle_trans _ (CR_of_Q R 0)). apply CR_of_Q_le. discriminate. apply CRle_refl. } destruct (CSUCposPointApproxSequenceCvZero (Pos.of_nat p)) as [i imaj]. specialize (imaj i (Nat.le_refl i)). specialize (H i). destruct (CSUCposPointApproxSequence i); unfold x,y in imaj. destruct lambdaInfiniteMaj0. simpl in H. assert (CRsum (fun j : nat => UC_integral (fn j) x0 y0 (fnMod j) (fnCont j) lexy0) k < UC_integral g x0 y0 gMod (fst gCSUC) lexy0). { apply (CRle_lt_trans _ x1). 2: apply p0. apply growing_ineq. 2: apply p0. intros n. rewrite <- (CRplus_0_r (CRsum (fun j : nat => UC_integral (fn j) x0 y0 (fnMod j) (fnCont j) lexy0) n)). apply CRplus_le_compat_l. apply UC_integral_pos. intros. apply fnPos. } assert (forall x y : CRcarrier R, x < y -> ~(y<=x)) as CReal_lt_not_le. { intros. intro abs1. contradiction. } apply (CReal_lt_not_le _ _ H1). destruct (UC_sum fn fnMod fnCont k) as [modSk c]. rewrite <- (UC_integral_sum fn _ _ k _ _ fnCont c). apply UC_integral_nonneg. intros. apply CRlt_asym, etaMaj. rewrite CRabs_right in imaj. apply (CRle_lt_trans _ (y0- x0)). apply Rsmaller_interval. apply H2. apply H2. apply H. apply H. apply (CRlt_trans _ (CR_of_Q R (1#Pos.of_nat p))). unfold CRminus. exact imaj. 2: rewrite <- (CRplus_opp_r x0); apply CRplus_le_compat_r, lexy0. apply (CRmult_lt_compat_l eta) in pmaj. rewrite CRinv_r in pmaj. 2: exact etaPos. apply (CRmult_lt_reg_r (INR p)). exact qpPos. apply (CRle_lt_trans _ 1). 2: exact pmaj. unfold INR. rewrite <- CR_of_Q_mult. apply CR_of_Q_le. unfold Qmult, Qle, Qden, Qnum. rewrite Z.mul_1_l, Z.mul_1_l, Pos.mul_1_r. rewrite Z.mul_1_r. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. apply Z.le_refl. intro abs1. subst p. inversion H0. Qed. (* Workaround a destruct problem *) Lemma DestructCSUCposPoint : { l : CRcarrier R | (forall k:nat, CRsum (fun n => fn n l) k <= g l) /\ x (CSUCposPointApproxSequence 0) <= l /\ l <= y (CSUCposPointApproxSequence 0) }. Proof. pose proof CSUCIcontinuous. pose proof CSUCposPointApproxLimitNested. destruct CSUCposPointApproxSequenceCauchy as [l lcv]. exists l. split. exact H. apply H0. Qed. End CSUCContinuous. Lemma CSUC_extend_pos : forall {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (a b : CRcarrier R) (leab : a <= b), nonNegFunc f -> UC_integral (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL)) a b (CSUC_cont_mod f fL) (fst (CSUC_adapt f fL)) leab <= IntegralCSUC f fL. Proof. intros. unfold IntegralCSUC, TotalizeFunc. pose proof (CSUC_connect_support (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain f fL)) (CSUC_low f fL) (CSUC_high f fL) (CSUC_cont_mod f fL)). destruct fL, f; simpl; simpl in H0. assert (CRmin a CSUC_low0 <= CRmax b CSUC_high0). { apply (CRle_trans _ a). apply CRmin_l. apply (CRle_trans _ b _ leab). apply CRmax_l. } apply (CRle_trans _ (UC_integral (fun x1 : CRcarrier R => partialApply x1 (CSUC_fullDomain0 x1)) (CRmin a CSUC_low0) (CRmax b CSUC_high0) CSUC_cont_mod0 (fst CSUC_adapt0) H1)). apply (UC_integral_extend_nonneg _ CSUC_cont_mod0). apply CRmin_l. apply CRmax_l. intros. apply H. assert (forall x y:CRcarrier R, x == y -> x <= y). { intros. rewrite H2. apply CRle_refl. } apply H2. symmetry. apply (UC_integral_extend_zero _ CSUC_cont_mod0). apply CRmin_r. apply CRmax_r. intros. apply H0. apply CSUC_adapt0. left. apply H3. intros. apply H0. apply CSUC_adapt0. right. apply H3. Qed. Lemma CSUCIntegralContinuous {R : ConstructiveReals} : @ElemIntegralContinuous (@ElemCSUC R) IntegralCSUC. Proof. intros. apply IcontinuousClassic. - apply CSUCIntegralHomogeneous. - apply CSUCIntegralAdditiveIterate. - intros g gL. assert (nonNegFunc (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze (CSUC_low g gL) (CSUC_high g gL) 1 (CRzero_lt_one R)))) as ZnonNeg. { intros x xdf. simpl. apply (CSUCTrapezeBounded (CSUC_low g gL) (CSUC_high g gL) 1 x (CRzero_lt_one R)). apply (CSUC_lowHigh g gL). } exists (existT _ (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze (CSUC_low g gL) (CSUC_high g gL) 1 (CRzero_lt_one R))) (pair (CSUCTrapeze_IS_CSUC (CSUC_low g gL) (CSUC_high g gL) 1 (CRzero_lt_one R) (CSUC_lowHigh g gL)) ZnonNeg)). intros. assert (forall (k : nat) (x : CRcarrier R), (0 <= (fun n : nat => TotalizeFunc (CRcarrier R) (fn n) (CSUC_fullDomain (fn n) (fnL n))) k x)) as fnPos. { intros. unfold TotalizeFunc. specialize (H k). clear H0. unfold nonNegFunc in H. destruct (fnL k), (fn k); simpl; simpl in H. apply H. } destruct H0 as [sIfn [icv imaj]]. assert (forall n : nat, (CRabs _ ((fun k : nat => UC_integral ((fun n0 : nat => TotalizeFunc (CRcarrier R) (fn n0) (CSUC_fullDomain (fn n0) (fnL n0))) k) (CSUC_low g gL) (CSUC_high g gL) ((fun n0 : nat => CSUC_cont_mod (fn n0) (fnL n0)) k) ((fun n0 : nat => fst (CSUC_adapt (fn n0) (fnL n0))) k) (CSUC_lowHigh g gL) ) n) <= (fun n0 : nat => UC_integral (TotalizeFunc (CRcarrier R) (fn n0) (CSUC_fullDomain (fn n0) (fnL n0))) (CSUC_low (fn n0) (fnL n0)) (CSUC_high (fn n0) (fnL n0)) (CSUC_cont_mod (fn n0) (fnL n0)) (fst (CSUC_adapt (fn n0) (fnL n0))) (CSUC_lowHigh (fn n0) (fnL n0))) n)). { intro n. rewrite CRabs_right. apply CSUC_extend_pos. apply H. apply UC_integral_pos. intros. specialize (H n). destruct (fnL n), (fn n); simpl. apply H. } destruct (series_cv_maj _ _ sIfn H0 icv) as [sIfnTrunc [scv smaj]]. assert (sIfnTrunc < UC_integral (TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gL)) (CSUC_low g gL) (CSUC_high g gL) (CSUC_cont_mod g gL) (fst (CSUC_adapt g gL)) (CSUC_lowHigh g gL) ) as majInt. { apply (CRle_lt_trans _ sIfn). apply smaj. exact imaj. } destruct (DestructCSUCposPoint R (TotalizeFunc (CRcarrier R) g (CSUC_fullDomain _ gL)) (fun n => TotalizeFunc (CRcarrier R) (fn n) (CSUC_fullDomain _ (fnL n))) fnPos (fun n => CSUC_cont_mod _ (fnL n)) (fun n => fst (CSUC_adapt _ (fnL n))) (CSUC_cont_mod _ gL) (CSUC_low _ gL) (CSUC_high _ gL) (CSUC_lowHigh _ gL) (CSUC_adapt _ gL) (existT _ sIfnTrunc (pair scv majInt))) as [l lcv]. exists (Build_CommonPointFunSeq _ _ g fn l (CSUC_fullDomain g gL l) (fun n => CSUC_fullDomain (fn n) (fnL n) l)). unfold cpx, cpxF, cpxFn. simpl in lcv. split. exists Logic.I. unfold PartializeFunc, partialApply. apply CSUCTrapezePlateau. apply lcv. apply lcv. Qed. Lemma CSUC_transport_apply : forall {R : ConstructiveReals} (f g : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (pEq : PartialFunExtEq f g) (x : CRcarrier R), TotalizeFunc (CRcarrier R) f (CSUC_fullDomain _ fL) x == TotalizeFunc (CRcarrier R) g (CSUC_fullDomain _ (CSUCext f g pEq fL)) x. Proof. intros. destruct pEq, p. apply c. Qed. Lemma CSUC_transport_low : forall {R : ConstructiveReals} (f g : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (pEq : PartialFunExtEq f g), CSUC_low _ fL = CSUC_low _ (Lext ElemCSUC f g pEq fL). Proof. intros. destruct pEq, p, f, g, fL; reflexivity. Qed. Lemma CSUC_transport_high : forall {R : ConstructiveReals} (f g : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f) (pEq : PartialFunExtEq f g), CSUC_high _ fL = CSUC_high _ (Lext ElemCSUC f g pEq fL). Proof. intros. destruct pEq, p, f, g, fL; reflexivity. Qed. Lemma IntegralCSUC_ext : forall {R : ConstructiveReals} (g h : PartialFunction (CRcarrier R)) (gCS : Is_CSUC_func g) (hCS : Is_CSUC_func h), (forall x:CRcarrier R, TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gCS) x == TotalizeFunc (CRcarrier R) h (CSUC_fullDomain h hCS) x) -> IntegralCSUC g gCS == IntegralCSUC h hCS. Proof. intros. pose proof (CSUC_connect_support (TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gCS)) (CSUC_low g gCS) (CSUC_high g gCS) (CSUC_cont_mod g gCS)). pose proof (CSUC_connect_support (TotalizeFunc (CRcarrier R) h (CSUC_fullDomain h hCS)) (CSUC_low h hCS) (CSUC_high h hCS) (CSUC_cont_mod h hCS)). unfold IntegralCSUC; destruct gCS, hCS, g, h; simpl; simpl in H, H0, H1. unfold TotalizeFunc. assert (CRmin CSUC_low0 CSUC_low1 <= CRmax CSUC_high0 CSUC_high1). { apply (CRle_trans _ CSUC_low0). apply CRmin_l. apply (CRle_trans _ CSUC_high0). apply CSUC_lowHigh0. apply CRmax_l. } (* Extend bounds *) transitivity (UC_integral (fun x2 : CRcarrier R => partialApply x2 (CSUC_fullDomain0 x2)) (CRmin CSUC_low0 CSUC_low1) (CRmax CSUC_high0 CSUC_high1) CSUC_cont_mod0 (fst CSUC_adapt0) H2). - apply (UC_integral_extend_zero _ CSUC_cont_mod0). apply CRmin_l. apply CRmax_l. intros. apply H0. apply CSUC_adapt0. left. apply H3. intros. apply H0. apply CSUC_adapt0. right. apply H3. - transitivity (UC_integral (fun x2 : CRcarrier R => partialApply0 x2 (CSUC_fullDomain1 x2)) (CRmin CSUC_low0 CSUC_low1) (CRmax CSUC_high0 CSUC_high1) CSUC_cont_mod1 (fst CSUC_adapt1) H2). apply UC_integral_extens. intros. apply H. symmetry. apply (UC_integral_extend_zero _ CSUC_cont_mod1). apply CRmin_r. apply CRmax_r. intros. apply H1. apply CSUC_adapt1. left. apply H3. intros. apply H1. apply CSUC_adapt1. right. apply H3. Qed. Lemma IntegralCSUC_bounded : forall {R : ConstructiveReals} (g : PartialFunction (CRcarrier R)) (gCS : Is_CSUC_func g) (A : CRcarrier R), (forall x:CRcarrier R, TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gCS) x <= A) -> IntegralCSUC g gCS <= (A* (CSUC_high g gCS - CSUC_low g gCS)). Proof. intros. rewrite CRmult_comm. unfold Qminus. rewrite <- (UC_integral_constant _ _ _ A _ (UC_constant A) (CSUC_lowHigh g gCS)). unfold IntegralCSUC. apply (UC_integral_nonneg (TotalizeFunc (CRcarrier R) g (CSUC_fullDomain g gCS)) (fun _ => A)). intros. apply H. intros. reflexivity. Qed. Lemma CSUCIntegralLimit : forall {R : ConstructiveReals} (f : PartialFunction (CRcarrier R)) (fL : Is_CSUC_func f), prod (CR_cv _ (fun n => IntegralCSUC (XminConst f (INR n)) (@LminIntStable ElemCSUC n f fL)) (IntegralCSUC f fL)) (CR_cv _ (fun n => IntegralCSUC (XminConst (Xabs f) (CR_of_Q R (1# Pos.of_nat (S n)))) (@LminConstStable ElemCSUC (CR_of_Q R (1# Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable ElemCSUC f fL))) 0). Proof. split. - destruct (CSUC_bounded (TotalizeFunc (CRcarrier R) f (CSUC_fullDomain _ fL)) (CSUC_low _ fL) (CSUC_high _ fL) (CSUC_cont_mod _ fL) (CSUC_adapt _ fL) (CSUC_lowHigh _ fL)) as [B Bmaj]. destruct (CRup_nat B) as [k kmaj]. apply (CR_cv_shift _ k). apply (CR_cv_eq _ (fun n : nat => IntegralCSUC f fL)). intro n. apply IntegralCSUC_ext. intro x0. assert (PartialFunExtEq f (XminConst f (INR (n + k)))) as feq. { split. split. intros x H. destruct f; simpl. exact H. intros x H. destruct f; simpl. exact H. intros. unfold XminConst, Xop, partialApply. rewrite CRmin_left. rewrite (DomainProp f x1 xD xG). reflexivity. apply (CRle_trans _ B). specialize (Bmaj x1). unfold TotalizeFunc in Bmaj. rewrite (DomainProp _ _ _ (CSUC_fullDomain f fL x1)). apply (CRle_trans _ _ _ (CRle_abs _)). apply CRlt_asym, Bmaj. apply (CRle_trans _ (INR k)). apply CRlt_asym, kmaj. apply CR_of_Q_le. unfold Qle, Qden, Qnum. do 2 rewrite Z.mul_1_r. rewrite <- (Z.add_0_r (Z.of_nat k)). rewrite Nat2Z.inj_add. rewrite (Z.add_comm (Z.of_nat n)). apply Z.add_le_mono_l. apply Nat2Z.is_nonneg. } rewrite (CSUC_transport_apply f (XminConst f (INR (n + k))) fL feq). unfold TotalizeFunc. apply DomainProp. exists O. intros. unfold CRminus. rewrite CRplus_opp_r. rewrite CRabs_right. apply CR_of_Q_le; discriminate. apply CRle_refl. - intros p. destruct (CRup_nat ((CSUC_high f fL - CSUC_low f fL ) * (CR_of_Q R (Z.pos p # 1)))) as [k kmaj]. exists k. intros n H. unfold CRminus. rewrite CRopp_0. rewrite CRplus_0_r. rewrite CRabs_right. apply (CRle_trans _ (CR_of_Q R (1# Pos.of_nat (S n)) * (CSUC_high _ (@LminConstStable ElemCSUC (CR_of_Q R (1# Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable ElemCSUC f fL)) - CSUC_low _ (@LminConstStable ElemCSUC (CR_of_Q R (1# Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable ElemCSUC f fL))))). + apply IntegralCSUC_bounded. intro x0. apply CRmin_r. + apply CRlt_asym in kmaj. apply (CRmult_le_compat_r (CR_of_Q R (1 # p))) in kmaj. rewrite CRmult_assoc, <- CR_of_Q_mult in kmaj. setoid_replace ((Z.pos p # 1) * (1 # p))%Q with 1%Q in kmaj. rewrite CRmult_1_r in kmaj. apply (CRmult_le_reg_l (CR_of_Q R (Z.of_nat (S n) #1))). apply CR_of_Q_pos; reflexivity. rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.of_nat (S n) # 1) * (1 # Pos.of_nat (S n)))%Q with 1%Q. rewrite CRmult_1_l. apply (CRle_trans _ (INR k * CR_of_Q R (1#p))). apply (CRle_trans _ (CSUC_high f fL - CSUC_low f fL)). 2: apply kmaj. unfold LminConstStable. rewrite <- CSUC_transport_low. rewrite <- CSUC_transport_high. destruct f, fL; apply CRle_refl. apply CRmult_le_compat_r. apply CR_of_Q_le; discriminate. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, H. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l, Pos.mul_1_l. rewrite <- positive_nat_Z, Nat2Pos.id. reflexivity. discriminate. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r, Z.mul_1_l, Pos.mul_1_l. reflexivity. apply CR_of_Q_le. discriminate. + unfold IntegralCSUC. apply (UC_integral_pos (TotalizeFunc (CRcarrier R) (XminConst (Xabs f) (CR_of_Q R (1 # Pos.of_nat (S n)))) (CSUC_fullDomain (XminConst (Xabs f) (CR_of_Q R (1 # Pos.of_nat (S n)))) (@LminConstStable ElemCSUC (CR_of_Q R (1 # Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable ElemCSUC f fL))))). intros. unfold TotalizeFunc. assert (Domain (Xabs f) x0). { destruct fL,f; apply CSUC_fullDomain0. } rewrite applyXminConst. apply CRmin_glb. 2: apply CR_of_Q_le; discriminate. destruct f; apply CRabs_pos. Qed. Lemma OneCSUC_IS_CSUC : forall {R : ConstructiveReals}, Is_CSUC_func (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze 0 0 1 (CRzero_lt_one R))). Proof. intro R. assert (-(1) <= CR_of_Q R 1). { apply (CRle_trans _ (-0)). apply CRopp_ge_le_contravar, CRlt_asym, CRzero_lt_one. rewrite CRopp_0. apply CRlt_asym, CRzero_lt_one. } apply (Build_Is_CSUC_func R (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze 0 0 1 (CRzero_lt_one R))) (fun x:CRcarrier R => Logic.I) (-(1)) 1 H (fun eps epsPos => eps *CR_of_Q R (1#2))). pose proof (CSUCTrapeze_CSUC 0 0 1 (CRzero_lt_one R) (CRle_refl 0)). destruct H0. destruct u. split. split. intros. specialize (c0 x0 xPos). apply (CRlt_le_trans _ _ _ c0). rewrite CRmult_1_r. apply CRle_refl. intros. apply (c1 eps x0 y0 epsPos). apply (CRlt_le_trans _ _ _ H0). rewrite CRmult_1_r. apply CRle_refl. intros. apply c. destruct H0. left. apply (CRlt_le_trans _ _ _ c2). unfold CRminus. rewrite CRplus_0_l. apply CRle_refl. right. apply (CRle_lt_trans _ 1). rewrite CRplus_0_l. apply CRle_refl. exact c2. Defined. Lemma IntegralOneCSUC : forall {R : ConstructiveReals}, IntegralCSUC (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze 0 0 1 (CRzero_lt_one R))) OneCSUC_IS_CSUC == 1. Proof. intro R. transitivity (CR_of_Q R 1 + 0 - 0). rewrite <- (CSUCUnitTrapezeInt 0 0 1 (CRzero_lt_one R) (CRle_refl 0)). (* IntegralCSUC is between CR_of_Q (-1) and CR_of_Q 1 *) assert (-(1) <= CR_of_Q R 1). { apply (CRle_trans _ (-0)). apply CRopp_ge_le_contravar, CRlt_asym, CRzero_lt_one. rewrite CRopp_0. apply CRlt_asym, CRzero_lt_one. } rewrite (UC_integral_bound_proper (CSUCUnitTrapeze 0 0 1 (CRzero_lt_one R)) (0-1) (0+1) (-(1)) 1 _ _ _ H). apply UC_integral_extens. reflexivity. unfold CRminus. rewrite CRplus_0_l, <- CR_of_Q_opp. apply CR_of_Q_morph. reflexivity. rewrite CRplus_0_l. reflexivity. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. reflexivity. Qed. Definition IntSpaceCSUCFunctions {R : ConstructiveReals} : IntegrationSpace := Build_IntegrationSpace ElemCSUC IntegralCSUC CSUCIntegralAdditive CSUCIntegralHomogeneous (PartializeFunc (CRcarrier R) (CSUCUnitTrapeze 0 0 1 (CRzero_lt_one R))) OneCSUC_IS_CSUC IntegralOneCSUC CSUCIntegralContinuous CSUCIntegralLimit. (* An integrable function for the Lebesgue measure is proper almost everywhere. *) Lemma CSUCIntegrableProper : forall {R : ConstructiveReals} (fn : nat -> PartialFunction (CRcarrier R)) (x y : CRcarrier R) (xD : Domain (XinfiniteSumAbs fn) x) (yD : Domain (XinfiniteSumAbs fn) y), (forall n : nat, Is_CSUC_func (fn n)) -> x == y -> partialApply _ x xD == partialApply _ y yD. Proof. intros. simpl. destruct xD, yD. simpl in c, c0. apply series_cv_abs_eq. apply (series_cv_eq (fun n : nat => partialApply (fn n) x0 (x1 n))). 2: apply series_cv_abs_cv. intro n. specialize (H n). destruct H, CSUC_adapt0. pose proof (UniformContProper _ _ u x0 y0 H0). unfold TotalizeFunc in H. transitivity (partialApply (fn n) x0 (CSUC_fullDomain0 x0)). apply DomainProp. rewrite H. apply DomainProp. Qed. Lemma OpenIntervalIntegrable : forall {R : ConstructiveReals} (a b : CRcarrier R), a < b -> { limInt : @IntegrableSet IntSpaceCSUCFunctions (fun x => CRltProp R a x /\ CRltProp R x b) | MeasureSet limInt == b-a }. Proof. intros. assert (forall n:nat, 0 < (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) as etaPos. { intro n. apply CRmult_lt_0_compat. rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r, H. apply CR_of_Q_pos. reflexivity. } pose (fun n:nat => PartializeFunc (CRcarrier R) (CSUCUnitTrapeze (a + (b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) (b - (b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) ((b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) (etaPos n))) as fn. assert (forall c d : CRcarrier R, CR_cv R (fun n => c + d * CR_of_Q R (1 # Pos.of_nat (n + 2))) c) as affineCv. { intros. apply (CR_cv_proper _ (c+0) c). apply CR_cv_plus. apply CR_cv_const. apply (CR_cv_proper _ (0*d)). apply (CR_cv_eq _ (fun n : nat => CR_of_Q R (1 # Pos.of_nat (n + 2)) * d)). intro n. apply CRmult_comm. apply CR_cv_scale. intro p. exists (Pos.to_nat p). intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (Nat.le_trans _ _ _ H0). rewrite Nat.add_comm. apply le_S, le_S, Nat.le_refl. intro abs. rewrite Nat.add_comm in abs. discriminate. apply CR_of_Q_le. discriminate. rewrite CRmult_0_l. reflexivity. rewrite CRplus_0_r. reflexivity. } assert (CR_cv R (fun n => a + (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) a) as cv_left. { apply affineCv. } assert (CR_cv R (fun n => b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) b) as cv_right. { apply (CR_cv_eq _ (fun n => b + (-(b - a)) * CR_of_Q R (1 # Pos.of_nat (n + 2)))). intro n. apply CRplus_morph. reflexivity. rewrite CRopp_mult_distr_l. reflexivity. apply affineCv. } assert (forall x (xdn : forall n, Domain (fn n) x), (CRltProp R a x /\ CRltProp R x b) -> CR_cv R (fun n => partialApply (fn n) x (xdn n)) 1) as inPlateau. (* Serves twice. First, for the domain inclusion when the limit is below 1, we assume by contradiction that the point is in the interval, and then 1 is below 1. Second, to prove the partial restriction inside the interval. *) { intros. destruct H0. apply CRltEpsilon in H0. apply CRltEpsilon in H1. destruct (CR_cv_open_above _ x0 a cv_left H0). destruct (CR_cv_open_below _ x0 b cv_right H1). exists (max x1 x2). intros. specialize (c i). specialize (c0 i). simpl. rewrite CSUCTrapezePlateau. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. split; apply CRlt_asym. apply c. apply (Nat.le_trans _ (max x1 x2)). apply Nat.le_max_l. exact H2. apply c0. apply (Nat.le_trans _ (max x1 x2)). apply Nat.le_max_r. exact H2. } assert (forall n:nat, a + (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2)) <= b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) as fnL. { intro n. apply (CRplus_le_reg_r ((b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2)))). unfold CRminus. rewrite (CRplus_assoc b), CRplus_opp_l, CRplus_0_r. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. rewrite Qinv_plus_distr, CRplus_comm. rewrite <- (CRmult_1_r (-a + b)). rewrite CRmult_assoc. apply CRmult_le_compat_l. rewrite <- (CRplus_opp_l a). apply CRplus_le_compat_l, CRlt_asym, H. rewrite CRmult_1_l. apply CR_of_Q_le. unfold Qle,Qnum,Qden. rewrite Z.mul_1_r, Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite Nat.add_comm. apply le_n_S, le_n_S, Nat.le_0_l. intro abs. rewrite Nat.add_comm in abs. discriminate. } assert (PartialRestriction (XpointwiseLimit fn) (CharacFunc (fun x0 : CRcarrier R => CRltProp R a x0 /\ CRltProp R x0 b))). { split. - intros x xdf. simpl. destruct xdf as [xdn c]. apply CR_complete in c. destruct c as [l lcv]. destruct (CRltLinear R). destruct (s 0 l 1 (CRzero_lt_one R)). + left. apply (CR_cv_open_below _ 0) in lcv. 2: exact c. destruct lcv as [n nmaj]. specialize (nmaj n (Nat.le_refl n)). apply (CSUCTrapezeInPlateau (a + (b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) (b - (b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) ((b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) x (etaPos n)) in nmaj. destruct nmaj. split. apply CRltForget. apply (CRle_lt_trans _ (a + (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2)) - (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2)))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply CRle_refl. exact c0. unfold CRminus in c1. apply CRltForget. apply (CRlt_le_trans _ _ _ c1). rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRle_refl. + right. intro abs. specialize (inPlateau x xdn abs). contradict c. fold (CRle _ 1 l). rewrite (CR_cv_unique _ _ _ inPlateau lcv). apply CRle_refl. - intros. simpl in xG. destruct xG. + (* one *) apply applyPointwiseLimit. exact (inPlateau _ (fun n => let (xdn,_) := xD in xdn n) a0). + (* zero *) apply applyPointwiseLimit. apply (CR_cv_eq _ (fun _ => 0)). 2: apply CR_cv_const. intros. simpl. unfold CSUCUnitTrapeze, UCUnitHeaviside. rewrite (CRinv_morph _ ((b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2))) _ (inr (etaPos n0))). rewrite (CRinv_morph (b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)) + (b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)) - (b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))) ((b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2))) _ (inr (etaPos n0))). destruct (CRltLinear R). destruct (s a x0 b H). assert (b <= x0). { intro abs. apply n. split. apply CRltForget, c. apply CRltForget, abs. } clear c. rewrite CRmin_left, CRmin_left. rewrite CRmax_right. unfold CRminus. rewrite CRplus_opp_r. reflexivity. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r ((b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))). apply etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. unfold CRminus. rewrite <- CRplus_0_l. rewrite CRopp_plus_distr, CRopp_involutive. do 2 rewrite <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_0_r. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r, H0. apply (CRmult_le_reg_r ((b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))). apply etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_0_l. rewrite <- CRplus_assoc, <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_0_r, CRplus_0_l. rewrite <- (CRplus_opp_r (a + (b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))). apply CRplus_le_compat_r, (CRle_trans _ b). 2: exact H0. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- (CRmult_1_r (-a+b)), (CRplus_comm (-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r. apply CRlt_asym, H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite Nat.add_comm. apply le_n_S, Nat.le_0_l. intro abs. rewrite Nat.add_comm in abs. discriminate. assert (x0 <= a). { intro abs. apply n. split. apply CRltForget, abs. apply CRltForget, c. } clear c. rewrite CRmax_left, CRmax_left. unfold CRminus. rewrite CRplus_opp_r. reflexivity. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply (CRmult_le_reg_r ((b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))). apply etaPos. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. rewrite <- (CRplus_opp_r (b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))). apply CRplus_le_compat_r. apply (CRle_trans _ _ _ H0). apply (CRplus_le_reg_l (-b)). unfold CRminus. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. setoid_replace (-b+a) with (-(b-a)). apply CRopp_ge_le_contravar. rewrite <- (CRmult_1_r (b-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r, CRlt_asym, H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite Nat.add_comm. apply le_n_S, Nat.le_0_l. intro abs. rewrite Nat.add_comm in abs. discriminate. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. reflexivity. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply (CRmult_le_reg_r ((b - a) * CR_of_Q R (1 # Pos.of_nat (n0 + 2)))). apply etaPos. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r, H0. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. } destruct (IntegralMonotoneConvergence IntSpaceCSUCFunctions fn (fun n => @IntegrableL IntSpaceCSUCFunctions (fn n) (CSUCTrapeze_IS_CSUC (a + (b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) (b - (b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) ((b-a) * CR_of_Q R (1#Pos.of_nat (n+2))) (etaPos n) (fnL n))) (b-a)) as [limInt mesRect]. - intros n x xdf xdg. unfold fn, PartializeFunc, partialApply. apply TrapezeIncluded. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. reflexivity. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. apply CRmult_le_compat_l. apply CRle_minus, CRlt_asym, H. apply CR_of_Q_le. unfold Qle,Qnum,Qden. rewrite Z.mul_1_l, Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. apply le_S, Nat.le_refl. discriminate. intro abs. rewrite Nat.add_comm in abs. discriminate. - simpl. apply (CR_cv_eq _ (fun n => b-a + (-(b-a)) * CR_of_Q R (1 # Pos.of_nat (n + 2)))). 2: apply affineCv. intro n. rewrite IntegralLstable. simpl. symmetry. unfold fn. unfold IntegralCSUC, CSUCTrapeze_IS_CSUC, CSUC_fullDomain, CSUC_low; simpl. rewrite (UC_integral_extens _ (CSUCUnitTrapeze (a + (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) (b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) ((b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) (etaPos n)) _ _ _ (fun eps epsPos => eps * CR_of_Q R (1#2) * ((b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2)))) _ (CSUCUnitTrapeze_cont _ _ _ _ (fnL n)) _ (TrapezeLe _ _ _ (etaPos n) (fnL n))). 2: intros; reflexivity. rewrite (CSUCUnitTrapezeInt (a + (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) (b - (b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) ((b - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))) (etaPos n) (fnL n)). unfold CRminus. rewrite CRplus_comm, CRopp_plus_distr, CRplus_assoc. rewrite <- (CRplus_assoc (- ((b + - a) * CR_of_Q R (1 # Pos.of_nat (n + 2))))). rewrite CRplus_opp_l, CRplus_0_l, <- CRplus_assoc, (CRplus_comm (-a)). rewrite CRopp_mult_distr_l. reflexivity. - exists (@IntegrableFunctionExtensional IntSpaceCSUCFunctions _ _ X limInt). unfold MeasureSet. rewrite IntegralRestrict. exact mesRect. Qed. Lemma ClosedIntervalIntegrable : forall {R : ConstructiveReals} (a b : CRcarrier R), a <= b -> { limInt : @IntegrableSet IntSpaceCSUCFunctions (fun x => a <= x <= b) | MeasureSet limInt == b-a }. Proof. intros. assert (forall n:nat, a - CR_of_Q R (1 # Pos.of_nat n) < b + CR_of_Q R (1 # Pos.of_nat n)) as ltabn. { intro n. apply (CRle_lt_trans _ (a + 0)). rewrite <- CRopp_0. apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply CR_of_Q_le. discriminate. apply (CRle_lt_trans _ (b+0)). apply CRplus_le_compat_r, H. apply CRplus_lt_compat_l, CR_of_Q_pos. reflexivity. } assert (CR_cv R (fun i : nat => CR_of_Q R (1 # Pos.of_nat i)) 0) as invCv. { intro p. exists (Pos.to_nat p). intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r, CRabs_right. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. exact H0. destruct i. exfalso. inversion H0. pose proof (Pos2Nat.is_pos p). rewrite H2 in H1. inversion H1. discriminate. apply CR_of_Q_le. discriminate. } destruct (@IntegrableSetCountableIntersect IntSpaceCSUCFunctions (fun n x => CRltProp R (a - CR_of_Q _ (1 # Pos.of_nat n)) x /\ CRltProp R x (b + CR_of_Q _ (1 # Pos.of_nat n))) (fun n => let (i,_) := OpenIntervalIntegrable _ _ (ltabn n) in i) (b-a)). - apply (CR_cv_eq _ (fun n => b + CR_of_Q R (1 # Pos.of_nat n) - (a - CR_of_Q R (1 # Pos.of_nat n)))). intro n. rewrite MeasureIntersectSeqDecr. destruct (OpenIntervalIntegrable (a - CR_of_Q R (1 # Pos.of_nat n)) (b + CR_of_Q R (1 # Pos.of_nat n)) (ltabn n)). symmetry; exact c. intros. destruct H0. split. apply CRltForget. apply CRltEpsilon in H0. apply (CRle_lt_trans _ (a - CR_of_Q R (1 # Pos.of_nat (S n0)))). 2: exact H0. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. destruct n0. discriminate. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. apply le_S, Nat.le_refl. discriminate. discriminate. apply CRltEpsilon in H1. apply CRltForget. apply (CRlt_le_trans _ _ _ H1). apply CRplus_le_compat_l. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. destruct n0. discriminate. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. apply le_S, Nat.le_refl. discriminate. discriminate. apply CR_cv_minus. apply (CR_cv_proper _ (b+0)). apply CR_cv_plus. apply CR_cv_const. exact invCv. rewrite CRplus_0_r. reflexivity. apply (CR_cv_proper _ (a-0)). apply CR_cv_minus. apply CR_cv_const. exact invCv. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. - assert (forall x, (forall n : nat, CRltProp R (a - CR_of_Q R (1 # Pos.of_nat n)) x /\ CRltProp R x (b + CR_of_Q R (1 # Pos.of_nat n))) <-> a <= x <= b) as H0. { split. intros. split. apply (CR_cv_bound_up (fun n => (a - CR_of_Q R (1 # Pos.of_nat n))) _ _ O). intros. specialize (H0 n) as [H0 _]. apply CRlt_asym, CRltEpsilon, H0. apply (CR_cv_proper _ (a-0)). apply CR_cv_minus. apply CR_cv_const. exact invCv. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. apply (CR_cv_bound_down (fun n => (b + CR_of_Q R (1 # Pos.of_nat n))) _ _ O). intros. specialize (H0 n) as [_ H0]. apply CRlt_asym, CRltEpsilon, H0. apply (CR_cv_proper _ (b+0)). apply CR_cv_plus. apply CR_cv_const. exact invCv. rewrite CRplus_0_r. reflexivity. intros. split. apply CRltForget. apply (CRlt_le_trans _ (a+-0)). 2: rewrite CRopp_0, CRplus_0_r; exact (proj1 H0). apply CRplus_lt_compat_l, CRopp_gt_lt_contravar, CR_of_Q_pos. reflexivity. apply CRltForget. apply (CRle_lt_trans _ (b+0)). rewrite CRplus_0_r. exact (proj2 H0). apply CRplus_lt_compat_l, CR_of_Q_pos. reflexivity. } exists (IntegrableSetExtensional (fun x : X (ElemFunc IntSpaceCSUCFunctions) => forall n : nat, CRltProp R (a - CR_of_Q R (1 # Pos.of_nat n)) x /\ CRltProp R x (b + CR_of_Q R (1 # Pos.of_nat n))) _ (fun x _ => H0 x) x0). rewrite <- (MeasureExtensional _ _ x0 _ (fun x _ _ => H0 x)). exact c. Qed. corn-8.20.0/reals/stdlib/CMTbase.v000066400000000000000000000572751473720167500166320ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* This is an implementation of Errett Bishop and Henry Cheng's article, "Constructive Measure Theory". By its many applications and concrete nature, measure theory and probability theory are expected to be constructive. Indeed they are, and this formalization shows exactly how. All measure theories (Riemann, Lebesgue, Daniell and here constructive) follow the same pattern : 1) Observe that the rectangles of Rn [a1,b1] \times ... \times [an,bn] have an obvious measure, which is the product (b1-a1)...(bn-an). 2) Define a notion of limit, to measure more complicated domains by rectangle approximations. For example this is how Archimedes computed the length of a circle 2000 years ago. Nowadays the classical measure theory is that of Lebesgue, and its limit notion is the sigma-algebra generated by the rectangles, aka the Borel sets of Rn. This classically defines a gigantic set of measurable parts, but it is not constructive, because there is no way to effectively compute which rectangles approximate an arbitrary Borel set. It is therefore not surprising that the associated tool, Caratheodory's extension theorem, extends measures from rectangles to Borel sets in a non-constructive manner: by using infimums of arbitrary bounded subsets of R. Bishop and Cheng's measure theory is the constructive expression of Daniell's measure theory. Instead of starting with rectangles as subsets of Rn, this theory considers elementary real-valued functions, for example piecewise-constant functions. Those two concepts are almost the same, because the graph of a piecewise-constant function is a finite union of rectangles. But by starting with functions, we get a very simple notion of limit between a function f and a sequence of elementary functions fn: f(x) = lim fn(x), for all x's such as the real sequence fn(x) converges. This resolves the objection above, because the approximating sequence fn of rectangles is now the very definition of an integrable function f. This restricts the theory to constructively integrable functions, which is precisely what we want. In the constructive definition, fn is not required to converge at every x. This allows to integrate more functions f, but takes the risk of badly approximating their integrals, by ignoring what f does outside of the domain of convergence of fn. To make sure that the sequence fn converges on a subset with full measure, we require that the integrals of the absolute values of fn converge. Roughly speaking, if the |fn| converged to positive infinity on a subset with positive measure, it would contradict the finite integral limit. This condition also makes the integrals of fn converge, which defines the integral of f. Another characteristic of constructive real functions is worth stressing: all total constructive functions R -> R are continuous. So a constructive function R -> R must either be undefined at a point of discontinuity x, or be defined on a topological subspace of R, such as the disconnection of x by taking [x, +\infty[ to be open. In the last 2 cases we will declare the function to be partially defined on R, see PartialFunction below. *) Require Import QArith. Require Import ConstructiveReals. Require Import ConstructiveAbs. Require Import ConstructiveMinMax. Require Import ConstructiveSum. Require Import ConstructiveLimits. Require Import ConstructivePartialFunctions. Local Open Scope ConstructiveReals. (* A Riesz space is a vector space with a lattice structure compatible with the vectorial structure. An important example for measure theory is when vectors are real-valued functions, which allows to define an integral as a linear and non-decreasing functional. *) Structure FunctionRieszSpace := { (* A superset of the domains. Typically, X will be R or R^n, and the functions will be defined almost-everywhere on X. Bishop generalizes to a setoid, to be able to consider functions on quotient spaces ; we do not do it for now, because most of the time the domain is plain R^n.*) X : Set; RealT : ConstructiveReals; (* We use Set instead of Prop, to destruct the witness in the integral function later. In the example of piecewise-linear functions, the Prop would be "there exists a finite list of angular points"; here the type is a sig with this finite list, and a proof that the function is linear between these points. *) L : @PartialFunction RealT X -> Type; (* The integration spaces are usually provably extensional, so we avoid using the functional extensionality axiom. *) Lext : forall f g : PartialFunction X, PartialFunExtEq f g -> L f -> L g; LplusStable : forall f g : PartialFunction X, L f -> L g -> L (Xplus f g); LabsStable : forall (f : PartialFunction X), L f -> L (Xabs f); LminOneStable : forall (f : PartialFunction X), L f -> L (XminConst f 1); LscaleStable : forall (a : CRcarrier RealT) (f : PartialFunction X), L f -> L (Xscale a f); }. (* LminOneStable seems redundant, because the minimum can be built from plus, minus and abs. However the constant function one is not L most of the time : its integral is infinite when the domain X is R or R^n. *) Lemma LminusStable : forall {Elem : FunctionRieszSpace} (f g : PartialFunction (X Elem)) (fL : L Elem f) (gL : L Elem g), L Elem (Xminus f g). Proof. intros. unfold Xminus. apply LplusStable. assumption. apply LscaleStable. assumption. Defined. Lemma LposPartStable : forall {Elem : FunctionRieszSpace} (f : PartialFunction (X Elem)) (fL : L Elem f), L Elem (XposPart f). Proof. intros. unfold XposPart. apply LscaleStable. apply LplusStable. assumption. apply LabsStable. assumption. Defined. Lemma LnegPartStable : forall {Elem : FunctionRieszSpace} (f : PartialFunction (X Elem)) (fL : L Elem f), L Elem (XnegPart f). Proof. intros. unfold XnegPart. apply LscaleStable. apply LminusStable. apply LabsStable. assumption. assumption. Defined. Lemma LminStable : forall {Elem : FunctionRieszSpace} (f g : PartialFunction (X Elem)) (fL : L Elem f) (gL : L Elem g), L Elem (Xmin f g). Proof. intros. apply LminusStable. assumption. apply LnegPartStable. apply LminusStable. assumption. assumption. Qed. Lemma LmaxStable : forall {Elem : FunctionRieszSpace} (f g : PartialFunction (X Elem)) (fL : L Elem f) (gL : L Elem g), L Elem (Xmax f g). Proof. intros. apply LplusStable. assumption. apply LposPartStable. apply LminusStable. assumption. assumption. Qed. Lemma LsumStable : forall {Elem : FunctionRieszSpace} (fn : nat -> PartialFunction (X Elem)) (fnL : forall n:nat, L Elem (fn n)), forall n:nat, L Elem (Xsum fn n). Proof. induction n. simpl. apply fnL. simpl. apply (LplusStable Elem). exact IHn. apply fnL. Defined. Lemma LminConstStable : forall {E : FunctionRieszSpace} (a : CRcarrier (RealT E)) (f : PartialFunction (X E)), 0 < a -> L E f -> L E (XminConst f a). Proof. intros. apply (Lext _ _ _ (XminMultPosDistribOne f a H)). apply LscaleStable. apply LminOneStable. apply LscaleStable. assumption. Defined. (* Include the zero case *) Lemma LminIntStable : forall {E : FunctionRieszSpace} (n : nat) (f : PartialFunction (X E)), L E f -> L E (XminConst f (INR n)). Proof. intros E n f H. destruct n. - apply (Lext _ (Xscale (-(1)) (XnegPart f))). 2: apply LscaleStable, LnegPartStable, H. split. split. + intros x xd. destruct f; apply xd. + intros x xd. destruct f; split; apply xd. + intros. rewrite applyXscale, applyXminConst. simpl in xD, xG. rewrite (DomainProp (XnegPart f) x _ (xG, xG)). rewrite (applyXnegPartMin f x xG), <- CRopp_mult_distr_l. rewrite CRmult_1_l, CRopp_involutive, CRmin_sym. apply CRmin_morph. reflexivity. reflexivity. - apply LminConstStable. apply CR_of_Q_lt. reflexivity. exact H. Qed. Lemma invSuccRealPositive : forall {R : ConstructiveReals} (n : nat), 0 < CR_of_Q R (1# Pos.of_nat (S n)). Proof. intros R n. apply CR_of_Q_lt. reflexivity. Qed. Definition ElemIntegralContinuous {E : FunctionRieszSpace} (I : forall f : PartialFunction (X E), (L E) f -> CRcarrier (RealT E)) : Type := forall (f : PartialFunction (X E)) (fn : nat -> PartialFunction (X E)) (fL : (L E) f) (fnL : forall n:nat, (L E) (fn n)), (forall n:nat, nonNegFunc (fn n)) -> series_cv_lim_lt (fun n => I (fn n) (fnL n)) (I f fL) -> { x : CommonPointFunSeq _ f fn & series_cv_lim_lt (fun n => partialApply (fn n) _ (cpxFn _ _ _ x n)) (partialApply f _ (cpxF _ _ _ x)) }. Record IntegrationSpace := { ElemFunc : FunctionRieszSpace; (* The integrals of the elementary functions. The argument L f is in sort Set, but lemma IExtensional below proves that I does not use it to produce different values. *) I : forall f : PartialFunction (X ElemFunc), (L ElemFunc) f -> CRcarrier (RealT ElemFunc); Iadditive : forall (f g : PartialFunction (X ElemFunc)) (fL : L ElemFunc f) (gL : L ElemFunc g), I (Xplus f g) (LplusStable ElemFunc f g fL gL) == I f fL + I g gL; Ihomogeneous : forall (a : CRcarrier (RealT ElemFunc)) (f : PartialFunction (X ElemFunc)) (fL : L ElemFunc f), I (Xscale a f) (LscaleStable ElemFunc a f fL) == a * (I f fL); Ione : PartialFunction (X ElemFunc); IoneL : L ElemFunc Ione; IoneInt : I Ione IoneL == 1; (* Now the usual majoration of integrals : (forall x, f(x) <= g(x)) -> I f <= I g. See lemma INonDecreasing below for the detailed formulation. Because x is in the intersection of the domains of f and g, it implies that L-functions are defined almost everywhere, ie the abscissas outside any of their domains don't affect integrals. Moreover we require the existential contrapositive, which is constructively stronger : I g < I f -> { x | g(x) < f(x) }. Finally we want the integral to be sigma-linear (the countable limit of Iadditive and Ihomogeneous), so we take g to be a countable sum of nonnegative functions fn. This gives an non-decreasing sequence of functions, as in the monotone convergence theorem (that we will prove later). The function f is actually optional. If the integrals of fn converge towards a limit l, we can take f = (l+1) * Ione. This means that the convergence on the integrals of fn proves that the pointwise limit of fn has a non-empty domain (which will later be proved to have full measure in X ElemFunc). *) Icontinuous : ElemIntegralContinuous I; Ilimit : forall (f : PartialFunction (X ElemFunc)) (fL : L ElemFunc f), prod (CR_cv _ (fun n => I (XminConst f (INR n)) (LminIntStable n f fL)) (I f fL)) (CR_cv _ (fun n => I (XminConst (Xabs f) (CR_of_Q _ (1# Pos.of_nat (S n)))) (LminConstStable (CR_of_Q _ (1# Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable ElemFunc f fL))) 0) }. (* Shortcut for the integral of the absolute value, will be used a lot. *) Definition Iabs {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) := I IS (Xabs f) (LabsStable _ f fL). Lemma Iminus : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) (gL : L (ElemFunc IS) g), I IS (Xminus f g) (LminusStable f g fL gL) == I IS f fL - I IS g gL. Proof. intros. unfold Xminus. unfold LminusStable. rewrite Iadditive. apply CRplus_morph. reflexivity. rewrite Ihomogeneous. rewrite <- CRopp_mult_distr_l, CRmult_1_l. reflexivity. Qed. Lemma IadditiveIterate : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (N : nat), I IS (Xsum fn N) (LsumStable fn fnL N) == CRsum (fun n : nat => I IS (fn n) (fnL n)) N. Proof. induction N. - reflexivity. - simpl. rewrite Iadditive. rewrite IHN. reflexivity. Qed. Definition Izero (IS : IntegrationSpace) := Xscale 0 (Ione IS). Lemma Izero_is_L : forall (IS : IntegrationSpace), L (ElemFunc IS) (Izero IS). Proof. intros IS. unfold Izero. apply LscaleStable. apply IoneL. Defined. Lemma Izero_nonNeg : forall (IS : IntegrationSpace), nonNegFunc (Izero IS). Proof. intros IS x xdf. unfold Izero. rewrite applyXscale, CRmult_0_l. apply CRle_refl. Qed. Lemma Izero_is_zero : forall (IS : IntegrationSpace), I IS (Izero IS) (Izero_is_L IS) == 0. Proof. intros. unfold Izero. unfold Izero_is_L. rewrite Ihomogeneous. rewrite CRmult_0_l. reflexivity. Qed. Lemma applyIzero : forall (IS : IntegrationSpace) (x : X (ElemFunc IS)) (xD : Domain (Izero IS) x), partialApply (Izero IS) x xD == 0. Proof. intros. unfold Izero. rewrite applyXscale, CRmult_0_l. reflexivity. Qed. (* This usual property of integrals also proves that the domains of L-functions are full sets. The majoration f <= g is defined on the intersection of the domains of f and g, and it is enough to imply that I f <= I g. It proves that the difference between the domains of g and f is a null set : g can have arbitrary large negative values on it without breaking the integral majoration. *) Lemma INonDecreasing : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) (gL : L (ElemFunc IS) g), (forall (x : X (ElemFunc IS)) (xF : Domain f x) (y : Domain g x), partialApply f x xF <= partialApply g x y) -> I IS f fL <= I IS g gL. Proof. intros. intro abs. destruct (Icontinuous IS (Xminus f g) (fun n:nat => Izero IS) (LminusStable f g fL gL) (fun n:nat => Izero_is_L IS) (fun n:nat => Izero_nonNeg IS)) as [[x xdminus xdfn] [l [H1 H0]]]. - exists 0. split. + intros n. exists O. intros. rewrite CRabs_right. rewrite sum_eq_R0. unfold CRminus. rewrite CRplus_opp_r. apply CR_of_Q_le. discriminate. intro k. apply Izero_is_zero. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite sum_eq_R0. apply CRle_refl. intro k. apply Izero_is_zero. + unfold Xminus. unfold LminusStable. rewrite Iadditive. rewrite Ihomogeneous. rewrite <- (CRopp_mult_distr_l 1). rewrite CRmult_1_l. rewrite <- (CRplus_opp_r (I IS g gL)). apply CRplus_lt_compat_r. exact abs. - unfold cpxF in H0. destruct xdminus. rewrite (applyXminus f g) in H0. simpl in H0. assert (series_cv (fun n : nat => partialApply (Izero IS) x (xdfn n)) 0). { apply (CR_cv_eq _ (fun n => 0)). 2: apply CR_cv_const. intro n. rewrite sum_eq_R0. reflexivity. intro k. apply applyIzero. } assert (l == 0). { apply (series_cv_unique (fun n : nat => partialApply (Izero IS) x (xdfn n))). apply H1. apply H2. } rewrite H3 in H0. clear H1 H2 H3 l. rewrite <- (CRplus_opp_r (partialApply g x d0)) in H0. apply CRplus_lt_reg_r in H0. exact (H x _ _ H0). Qed. (* Again, the extensionality is simplified because f and g are defined almost everywhere. This lemma is rigorously a statement about the intersection of the domains of f and g. In particular, the lemma shows that I does not depend on the L arguments. *) Lemma IExtensional : forall {IS : IntegrationSpace} (f g : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f) (gL : L (ElemFunc IS) g), (forall (x : X (ElemFunc IS)) (xF : Domain f x) (y : Domain g x), partialApply f x xF == partialApply g x y) -> I IS f fL == I IS g gL. Proof. split. + apply INonDecreasing. intros. rewrite (H x y xF). apply CRle_refl. + apply INonDecreasing. intros. rewrite (H x xF y). apply CRle_refl. Qed. (* When we have an integration space, we only need to check stabilities to create smaller spaces. *) Definition SubIntegrationSpace (IS : IntegrationSpace) (Lsub : PartialFunction (X (ElemFunc IS)) -> Set) : (forall f:PartialFunction (X (ElemFunc IS)), Lsub f -> L _ f) -> (forall f g : PartialFunction (X (ElemFunc IS)), PartialFunExtEq f g -> Lsub f -> Lsub g) -> Lsub (Ione IS) -> (forall f g : PartialFunction (X (ElemFunc IS)), (Lsub f -> Lsub g -> Lsub (Xplus f g))) -> (forall f : PartialFunction (X (ElemFunc IS)), Lsub f -> Lsub (Xabs f)) -> (forall f : PartialFunction (X (ElemFunc IS)), Lsub f -> Lsub (XminConst f 1)) -> (forall (a:CRcarrier (RealT (ElemFunc IS))) (f : PartialFunction (X (ElemFunc IS))), Lsub f -> Lsub (Xscale a f)) -> IntegrationSpace. Proof. intros. pose (Build_FunctionRieszSpace (X (ElemFunc IS)) (RealT (ElemFunc IS)) Lsub X1 X2 X3 X4 X5) as ElemSub. pose (fun f fLsub => I _ f (X0 f fLsub)) as Isub. assert (forall (f g : PartialFunction (X (ElemFunc IS))) (fL : Lsub f) (gL : Lsub g), Isub (Xplus f g) (LplusStable ElemSub f g fL gL) == Isub f fL + Isub g gL). { intros. unfold Isub. apply (CReq_trans _ (I IS (Xplus f g) (LplusStable (ElemFunc IS) f g (X0 f fL) (X0 g gL)))). 2: apply Iadditive. apply IExtensional. intros. destruct f,g,xF,y; simpl. apply CRplus_morph. apply DomainProp. apply DomainProp0. } assert (forall (a : CRcarrier (RealT (ElemFunc IS))) (f : PartialFunction (X (ElemFunc IS))) (fL : Lsub f), Isub (Xscale a f) (LscaleStable ElemSub a f fL) == a * (Isub f fL)). { intros. unfold Isub. apply (CReq_trans _ (I IS (Xscale a f) (LscaleStable (ElemFunc IS) a f (X0 f fL)))). 2: apply Ihomogeneous. apply IExtensional. intros. destruct f; simpl. apply CRmult_morph. reflexivity. apply DomainProp. } apply (Build_IntegrationSpace ElemSub Isub H0 H1 (Ione IS) H). - unfold Isub. transitivity (CR_of_Q (RealT (ElemFunc IS)) 1). rewrite <- (IoneInt IS). apply IExtensional. intros. destruct (Ione IS); simpl. apply DomainProp. reflexivity. - intros f fn fL fnL. intros. simpl in fL, fnL. apply (Icontinuous IS f fn (X0 f fL) (fun n => X0 (fn n) (fnL n)) H2 H3). - intros. pose proof (Ilimit IS f (X0 f fL)). split. apply (CR_cv_eq _ (fun n : nat => I IS (XminConst f (INR n)) (@LminIntStable (ElemFunc IS) n f (X0 f fL)))). 2: apply H2. intro n. apply IExtensional. intros. apply DomainProp. apply (CR_cv_eq _ (fun n : nat => I IS (XminConst (Xabs f) (CR_of_Q _ (1# Pos.of_nat (S n)))) (@LminConstStable (ElemFunc IS) (CR_of_Q _ (1# Pos.of_nat (S n))) (Xabs f) (invSuccRealPositive n) (LabsStable (ElemFunc IS) f (X0 f fL))))). 2: apply H2. intro n. apply IExtensional. intros. apply DomainProp. Defined. Lemma IabsHomogeneous : forall {IS : IntegrationSpace} (a : CRcarrier (RealT (ElemFunc IS))) (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f), Iabs (Xscale a f) (LscaleStable (ElemFunc IS) a f fL) == (CRabs _ a) * Iabs f fL. Proof. intros. unfold Iabs. rewrite <- Ihomogeneous. apply IExtensional. intros. destruct f; simpl. rewrite CRabs_mult. apply CRmult_morph. reflexivity. rewrite (DomainProp x xF y). reflexivity. Qed. Lemma integralPositive : forall (IS : IntegrationSpace) (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f), nonNegFunc f -> 0 <= I IS f fL. Proof. intros. apply (CRle_trans 0 (I IS (Izero IS) (Izero_is_L IS))). unfold Izero. unfold Izero_is_L. rewrite Ihomogeneous. rewrite CRmult_0_l. apply CRle_refl. apply INonDecreasing. intros. rewrite applyIzero. apply H. Qed. (* The usual triangular inequality of integrals : the absolute value of an integral is lower than the integral of the absolute value. *) Lemma integralAbsMaj : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fL : L (ElemFunc IS) f), CRabs _ (I IS f fL) <= Iabs f fL. Proof. (* Because integral is increasing and I f <= I |f| and -I f <= I |f| *) intros. apply CRabs_le. split. + unfold Iabs. rewrite <- (CRmult_1_l (I IS (Xabs f) (LabsStable (ElemFunc IS) f fL))). rewrite (CRopp_mult_distr_l 1). rewrite <- Ihomogeneous. apply INonDecreasing. intros. rewrite applyXscale. rewrite <- (CRopp_mult_distr_l 1). rewrite CRmult_1_l. destruct f; simpl. rewrite <- (CRopp_involutive (partialApply x y)). rewrite (DomainProp x xF y). rewrite <- CRabs_opp. apply CRopp_ge_le_contravar. apply CRle_abs. + apply INonDecreasing. intros. destruct f; simpl. rewrite (DomainProp x xF y). apply CRle_abs. Qed. Lemma IAbsSumMaj : forall {IS : IntegrationSpace} (fn : nat -> PartialFunction (X (ElemFunc IS))) (fnL : forall n:nat, L (ElemFunc IS) (fn n)) (n : nat), Iabs (Xsum fn n) (LsumStable fn fnL n) <= CRsum (fun n0 : nat => Iabs (fn n0) (fnL n0)) n. Proof. induction n. - simpl. apply CRle_refl. - simpl. apply (CRle_trans _ (I IS (Xplus (Xabs (Xsum fn n)) (Xabs (fn (S n)))) (LplusStable (ElemFunc IS) (Xabs (Xsum fn n)) (Xabs (fn (S n))) (LabsStable (ElemFunc IS) (Xsum fn n) (LsumStable fn fnL n)) (LabsStable (ElemFunc IS) (fn (S n)) (fnL (S n)))))). + clear IHn. apply INonDecreasing. intros. destruct (fn (S n)), (Xsum fn n), xF, y ; simpl. apply (CRle_trans _ _ _ (CRabs_triang _ _)). apply CRplus_le_compat. rewrite (DomainProp0 x d d1). apply CRle_refl. rewrite (DomainProp x d0 d2). apply CRle_refl. + rewrite Iadditive. apply CRplus_le_compat. apply IHn. apply CRle_refl. Qed. corn-8.20.0/reals/stdlib/CMTcast.v000066400000000000000000000373341473720167500166440ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Cast of constructive reals inside an integration space. Because two instances of constructive reals are isomorphic, so are their integrations spaces. *) Require Import QArith_base. Require Import List. Require Import ConstructiveReals. Require Import ConstructiveRealsMorphisms. Require Import ConstructiveAbs. Require Import ConstructiveMinMax. Require Import ConstructiveSum. Require Import ConstructiveLimits. Require Import ConstructivePartialFunctions. Require Import CMTbase. Require Import CMTIntegrableFunctions. Require Import CMTIntegrableSets. Require Import CMTFullSets. Local Open Scope ConstructiveReals. Definition CRcast {R1 R2 : ConstructiveReals} : CRcarrier R1 -> CRcarrier R2 := CRmorph (@SlowConstructiveRealsMorphism R1 R2). Definition PartialFunctionCast {R1 R2 : ConstructiveReals} {X : Set} (f : @PartialFunction R1 X) : @PartialFunction R2 X. Proof. apply (Build_PartialFunctionXY X (CRcarrier R2) (CReq R2) (Domain f) (fun x xD => CRcast (partialApply f x xD))). intros. apply CRmorph_proper. apply DomainProp. Defined. Definition FunctionRieszSpaceCast {R : ConstructiveReals} : FunctionRieszSpace -> FunctionRieszSpace. Proof. intro el. apply (Build_FunctionRieszSpace (X el) R (fun f => L el (@PartialFunctionCast R _ (X el) f))). - intros. destruct el. apply (Lext (PartialFunctionCast f)). 2: exact X. destruct H, p. split. split. intros x xD. exact (d x xD). intros x xD. exact (d0 x xD). intros. apply CRmorph_proper, c. - intros. destruct el. apply (Lext (Xplus (PartialFunctionCast f) (PartialFunctionCast g))). split. split. intros x xD. exact xD. intros x xD. exact xD. intros. destruct xD, xG. simpl. unfold CRcast. rewrite <- CRmorph_plus. apply CRmorph_proper. apply CRplus_morph; apply DomainProp. apply LplusStable; assumption. - intros. destruct el. apply (Lext (Xabs (PartialFunctionCast f))). split. split. intros x xD. exact xD. intros x xD. exact xD. intros. simpl. unfold CRcast. rewrite CRmorph_abs. apply CRmorph_proper. apply CRabs_morph, DomainProp. apply LabsStable, X. - intros. destruct el. apply (Lext (XminConst (PartialFunctionCast f) 1)). split. split. intros x xD. exact xD. intros x xD. exact xD. intros. simpl. unfold CRcast. rewrite CRmorph_min. apply CRmin_morph. apply CRmorph_proper, DomainProp. symmetry. apply CRmorph_one. apply LminOneStable, X. - intros. destruct el. apply (Lext (Xscale (CRcast a) (PartialFunctionCast f))). split. split. intros x xD. exact xD. intros x xD. exact xD. intros. simpl. unfold CRcast. rewrite <- CRmorph_mult. apply CRmorph_proper. apply CRmult_morph. reflexivity. apply DomainProp. apply LscaleStable, X. Defined. Lemma IadditiveCast : forall (IS : IntegrationSpace) {R : ConstructiveReals} (f g : PartialFunction (X (FunctionRieszSpaceCast (ElemFunc IS)))) (fL : L (FunctionRieszSpaceCast (ElemFunc IS)) f) (gL : L (FunctionRieszSpaceCast (ElemFunc IS)) g), CRcast (I IS (PartialFunctionCast (Xplus f g)) (LplusStable (@FunctionRieszSpaceCast R (ElemFunc IS)) f g fL gL)) == CRcast (I IS (PartialFunctionCast f) fL) + @CRcast (RealT (ElemFunc IS)) R (I IS (PartialFunctionCast g) gL). Proof. intros. unfold CRcast. rewrite <- CRmorph_plus. apply CRmorph_proper. rewrite <- (Iadditive IS). apply IExtensional. intros. simpl. destruct xF, y. unfold CRcast. rewrite <- CRmorph_plus. apply CRmorph_proper. apply CRplus_morph; apply DomainProp. Qed. Lemma IhomogeneousCast : forall (IS : IntegrationSpace) {R : ConstructiveReals} (a : CRcarrier (RealT (FunctionRieszSpaceCast (ElemFunc IS)))) (f : PartialFunction (X (FunctionRieszSpaceCast (ElemFunc IS)))) (fL : L (FunctionRieszSpaceCast (ElemFunc IS)) f), CRcast (I IS (PartialFunctionCast (Xscale a f)) (LscaleStable (@FunctionRieszSpaceCast R (ElemFunc IS)) a f fL)) == a * CRcast (I IS (PartialFunctionCast f) fL). Proof. intros. unfold CRcast. rewrite (CRmorph_proper _ (I IS (PartialFunctionCast (Xscale a f)) (LscaleStable (FunctionRieszSpaceCast (ElemFunc IS)) a f fL)) (CRcast a * I IS (PartialFunctionCast f) fL)). rewrite CRmorph_mult. apply CRmult_morph. unfold CRcast. simpl in a. transitivity (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS))) (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) ) a). unfold CRmorph_compose, CRmorph. reflexivity. apply Endomorph_id. reflexivity. rewrite <- (Ihomogeneous IS). apply IExtensional. intros. simpl. unfold CRcast. rewrite <- CRmorph_mult. apply CRmorph_proper. apply CRmult_morph. reflexivity. apply DomainProp. Qed. Lemma LElemFuncCastReverse : forall (E : FunctionRieszSpace) {R : ConstructiveReals} (f : PartialFunction (X E)), L E f -> L (@FunctionRieszSpaceCast R E) (PartialFunctionCast f). Proof. intros E R f fL. simpl. apply (Lext _ f). split. split. intros x xD. exact xD. intros x xD. exact xD. intros. simpl. unfold CRcast. transitivity (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT E) R) (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast E)) (RealT E)) ) (partialApply f x xG)). rewrite Endomorph_id. apply DomainProp. reflexivity. apply fL. Qed. Lemma IcontinuousCast : forall (IS : IntegrationSpace) {R : ConstructiveReals}, ElemIntegralContinuous (fun (f : PartialFunction (X (FunctionRieszSpaceCast (ElemFunc IS)))) (fL : L (@FunctionRieszSpaceCast R (ElemFunc IS)) f) => CRcast (I IS (PartialFunctionCast f) fL)). Proof. intros IS R f fn fL fnL fnPos [l [lcv lmaj]]. destruct (Icontinuous IS (PartialFunctionCast f) (fun n => PartialFunctionCast (fn n)) fL fnL). - intros n x xdf. simpl. unfold CRcast. rewrite <- (CRmorph_zero (@SlowConstructiveRealsMorphism R (RealT (ElemFunc IS)))). apply CRmorph_le, fnPos. - exists (CRcast l). split. apply (series_cv_eq (fun n => (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS))) ) (I IS (PartialFunctionCast (fn n)) (fnL n))))). intro n. apply Endomorph_id. unfold CRmorph_compose, CRmorph. apply CRmorph_series_cv, lcv. rewrite <- (Endomorph_id (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS))) ) (I IS (PartialFunctionCast f) fL)). unfold CRcast. unfold CRmorph_compose, CRmorph. apply CRmorph_increasing. exact lmaj. - destruct x. simpl in s. exists (Build_CommonPointFunSeq _ _ f fn cpx cpxF cpxFn). simpl. destruct s. exists (CRcast x). split. apply (series_cv_eq (fun n => (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS))) (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) ) (partialApply (fn n) cpx (cpxFn n))))). intro n. apply Endomorph_id. unfold CRmorph_compose, CRmorph. apply CRmorph_series_cv, p. rewrite <- (Endomorph_id (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS))) (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) ) (partialApply f cpx cpxF)). unfold CRcast. unfold CRmorph_compose, CRmorph. apply CRmorph_increasing. apply p. Qed. Definition IntegrationSpaceCast {R : ConstructiveReals} : IntegrationSpace -> IntegrationSpace. Proof. intro IS. apply (Build_IntegrationSpace (@FunctionRieszSpaceCast R (ElemFunc IS)) (fun f fL => CRcast (I IS (PartialFunctionCast f) fL)) (IadditiveCast IS) (IhomogeneousCast IS) (@PartialFunctionCast _ R _ (Ione IS)) (LElemFuncCastReverse _ _ (IoneL IS))). - unfold CRcast. rewrite (CRmorph_proper _ (I IS (PartialFunctionCast (PartialFunctionCast (Ione IS))) (LElemFuncCastReverse _ _ (IoneL IS))) 1). apply CRmorph_one. rewrite <- IoneInt. apply IExtensional. intros. simpl. transitivity (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS))) ) (partialApply (Ione IS) x xF)). unfold CRmorph_compose, CRmorph; reflexivity. rewrite Endomorph_id. apply DomainProp. - exact (IcontinuousCast IS). - intros. pose proof (Ilimit IS (PartialFunctionCast f) fL) as [H H0]. split. clear H0. apply CRmorph_cv. simpl. simpl in H. simpl in fL, f. apply (CR_cv_eq _ (fun n : nat => I IS (XminConst (PartialFunctionCast f) (INR n)) (LminIntStable n (PartialFunctionCast f) fL))). 2: exact H. intro n. apply IExtensional. intros. simpl. unfold CRcast. rewrite CRmorph_min. apply CRmin_morph. apply CRmorph_proper, DomainProp. rewrite CRmorph_INR. reflexivity. apply (CR_cv_proper _ (@CRcast (RealT (ElemFunc IS)) R 0) 0). 2: apply CRmorph_zero. apply CRmorph_cv. apply (CR_cv_eq _ (fun n : nat => I IS (XminConst (Xabs (PartialFunctionCast f)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S n)))) (LminConstStable (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S n))) (Xabs (PartialFunctionCast f)) (invSuccRealPositive n) (LabsStable (ElemFunc IS) (PartialFunctionCast f) fL)))). 2: exact H0. intro n. apply IExtensional. intros. simpl. unfold CRcast. rewrite CRmorph_min. apply CRmin_morph. rewrite CRmorph_abs. apply CRmorph_proper, CRabs_morph, DomainProp. symmetry. apply CRmorph_rat. Defined. Definition IntegrableFunctionCast {IS : IntegrationSpace} {R : ConstructiveReals} (f : PartialFunction (X (ElemFunc IS))) : IntegrableFunction f -> @IntegrableFunction (@IntegrationSpaceCast R IS) (@PartialFunctionCast (RealT (ElemFunc IS)) R _ f). Proof. intros fInt. destruct fInt, x. assert (series_cv (fun k : nat => @Iabs (@IntegrationSpaceCast R IS) (@PartialFunctionCast _ R _ (IntFn k)) (LElemFuncCastReverse (ElemFunc IS) (IntFn k) (IntFnL k))) (CRcast IntAbsSum)). { apply CRmorph_series_cv. apply (series_cv_eq (fun k : nat => Iabs (IntFn k) (IntFnL k))). 2: exact IntAbsSumCv. intro n. apply IExtensional. intros. simpl. unfold CRcast. rewrite <- CRmorph_abs. apply CRabs_morph. transitivity (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS)))) (partialApply (IntFn n) x y)). rewrite Endomorph_id. apply DomainProp. reflexivity. } exists (Build_IntegralRepresentation (@IntegrationSpaceCast R IS) (fun n => @PartialFunctionCast (RealT (ElemFunc IS)) R _ (IntFn n)) (fun n => LElemFuncCastReverse _ _ (IntFnL n)) (CRcast IntAbsSum) H). simpl. simpl in p. assert (@DomainInclusion R _ (XinfiniteSumAbs (fun n : nat => PartialFunctionCast (IntFn n))) (PartialFunctionCast (XinfiniteSumAbs IntFn))) as incCast. { intros y ydf. simpl. simpl in ydf. destruct ydf. exists x. unfold CRcast in c. apply (CRmorph_cauchy_reverse (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R)). apply (CR_cauchy_eq (CRsum (fun n : nat => CRabs R (CRmorph (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) (partialApply (IntFn n) y (x n)))))). 2: exact c. intro n. rewrite CRmorph_sum. apply CRsum_eq. intros. rewrite CRmorph_abs. reflexivity. } split. simpl. - intros y ydf. simpl. specialize (incCast y). destruct p. apply d. apply incCast. exact ydf. - intros. destruct p. specialize (c x (incCast x xD) xG). simpl. apply applyInfiniteSumAbs in c. destruct xD. symmetry. apply series_cv_abs_eq. apply CRmorph_series_cv. apply (series_cv_eq (fun n : nat => partialApply (IntFn n) x (domainInfiniteSumAbsIncReverse IntFn x (incCast x (existT _ x0 c0)) n))). 2: exact c. intro n. apply DomainProp. Defined. Lemma IntegralFunctionCast : forall {IS : IntegrationSpace} {R : ConstructiveReals} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), Integral (@IntegrableFunctionCast IS R f fInt) == CRcast (Integral fInt). Proof. intros. unfold Integral. apply (series_cv_unique _ _ _ (IntegralCv (let (i, _) := IntegrableFunctionCast f fInt in i))). apply CRmorph_series_cv. apply (series_cv_eq (fun n : nat => I IS (IntFn (let (i, _) := fInt in i) n) (IntFnL (let (i, _) := fInt in i) n))). 2: exact (IntegralCv (let (i, _) := fInt in i)). intro n. apply IExtensional. intros. destruct fInt, x0. unfold IntegrableFunctionCast, CMTIntegrableFunctions.IntFn. simpl. unfold CRcast. transitivity (CRmorph (CRmorph_compose (@SlowConstructiveRealsMorphism (RealT (ElemFunc IS)) R) (@SlowConstructiveRealsMorphism (RealT (FunctionRieszSpaceCast (ElemFunc IS))) (RealT (ElemFunc IS)))) (partialApply (IntFn n) x y)). rewrite Endomorph_id. apply DomainProp. reflexivity. Qed. corn-8.20.0/reals/stdlib/CMTprofile.v000066400000000000000000003223521473720167500173470ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Proof that for an integrable function f, the inverse image of of most intervals [t, +\infty[ are integrable, when 0 < t. As a quick justification : if those inverse images has infinite measure, it would be an infinite-area rectangle lower bounding the integral of f. The difficulty is making this argument constructive. First, we approximate the indicator function of [t, +\infty[ by a piecewise-linear function that continuously increases from 0 to 1, between s < t and t. This means considering the integrable functions (min(f,t) - min(f,s)) / (t-s) and using the monotone convergence theorem in the limit where s tends to t from below. The last, and main, difficulty is to constructively prove that this non-increasing limit of integrals exists. *) From Coq Require Import ZArith QArith_base Qabs. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveLimits. Require Import ConstructiveUniformCont. Require Import ConstructivePartialFunctions. Require Import ConstructiveDiagonal. Require Import CMTbase. Require Import CMTIntegrableFunctions. Require Import CMTIntegrableSets. Require Import CMTFullSets. Require Import CMTReals. From Coq Require Import Lia. Local Open Scope ConstructiveReals. Lemma RealSequenceCoverMeasure : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (N : nat), { coverInt : @IntegrableSet IntSpaceCSUCFunctions (fun x => exists n:nat, CRltProp R (un n - CRpow (CR_of_Q R (1#2)) (2 + N + n)) x /\ CRltProp R x (un n + CRpow (CR_of_Q R (1#2)) (2 + N + n))) & MeasureSet coverInt <= CRpow (CR_of_Q R (1#2)) N }. Proof. intros. assert (forall n:nat, un n - CRpow (CR_of_Q R (1#2)) (2 + N + n) < un n + CRpow (CR_of_Q R (1#2)) (2 + N + n)). { intro n. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ 0). rewrite <- CRopp_0. apply CRopp_ge_le_contravar. apply CRpow_ge_zero, CRlt_asym, CR_of_Q_pos. reflexivity. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. } pose (fun n:nat => OpenIntervalIntegrable _ _ (H n)) as openInt. destruct (@IntegrableSetCountableUnionLe IntSpaceCSUCFunctions (fun n x => CRltProp R (un n - CRpow (CR_of_Q _ (1#2)) (2 + N + n)) x /\ CRltProp R x (un n + CRpow (CR_of_Q _ (1#2)) (2 + N + n))) (fun n => let (i,_) := openInt n in i) (CRpow (CR_of_Q R (1#2)) N)). - apply (series_cv_eq (fun n => CRpow (CR_of_Q R (1#2)) n * CRpow (CR_of_Q R (1#2)) (S N))). intro n. destruct (openInt n). rewrite c. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. rewrite (CRplus_comm (un n)), CRplus_assoc, <- (CRplus_assoc (un n)). rewrite CRplus_opp_r, CRplus_0_l. rewrite CRpow_plus_distr, Nat.add_comm. simpl. rewrite <- CRmult_plus_distr_r, <- CR_of_Q_plus, Qinv_plus_distr. setoid_replace (1 + 1 # 2)%Q with 1%Q. 2: reflexivity. rewrite CRmult_1_l. reflexivity. apply (CR_cv_proper _ (CR_of_Q R 2 * CRpow (CR_of_Q R (1 # 2)) (S N))). apply series_cv_scale. apply GeoHalfTwo. simpl. rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace (2 * (1 # 2))%Q with 1%Q. 2: reflexivity. rewrite CRmult_1_l. reflexivity. - exists x. exact c. Qed. (* Constructive proof that the computable Cauchy reals are uncountable. We prove the even stronger contrapositive : an automatic extraction of a real number appart from the image of any real sequence. *) Lemma CRuncountable : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (a b : CRcarrier R), a < b -> { x : CRcarrier R & prod (a < x < b) (forall n:nat, CRapart R x (un n)) }. Proof. intros. pose proof (CRlt_minus a b H). destruct (CR_cv_open_above (fun n:nat => CRpow (CR_of_Q R (1#2)) n) (b-a) 0) as [n nmaj]. apply GeoCvZero. exact H0. destruct (fun n:nat => OpenIntervalIntegrable a b H) as [intervInt intervMes]. destruct (RealSequenceCoverMeasure un n) as [coverInt coverMes]. specialize (nmaj n (Nat.le_refl n)). assert (0 < MeasureSet (IntegrableSetDifference _ _ intervInt coverInt)). { rewrite MeasureDifference. apply CRlt_minus. apply (CRle_lt_trans _ (MeasureSet coverInt)). apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg. apply CRle_refl. 3: apply CRle_refl. 2: apply CRlt_asym, CRzero_lt_one. destruct a0. contradiction. apply (CRle_lt_trans _ _ _ coverMes). apply (CRlt_le_trans _ _ _ nmaj). rewrite intervMes. apply CRle_refl. } apply PositiveMeasureInhabited in H1. destruct H1 as [x xcv]. exists x. destruct xcv, H1. split. split. apply CRltEpsilon, H1. apply CRltEpsilon, H3. intro k. destruct (CRltLinear R). destruct (s (un k - CRpow (CR_of_Q R (1 # 2)) (2 + n + k)) x (un k-0)). - apply CRplus_lt_compat_l, CRopp_gt_lt_contravar. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. - destruct (s (un k) x (un k + CRpow (CR_of_Q R (1 # 2)) (2 + n + k))). + apply (CRle_lt_trans _ (un k + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. + right. exact c0. + exfalso. apply H2. exists k. split. apply CRltForget. exact c. apply CRltForget. exact c0. - left. apply (CRlt_le_trans _ _ _ c). unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. Qed. Lemma CRuncountableDiag : forall {R : ConstructiveReals} (un : nat -> nat -> CRcarrier R) (a b : CRcarrier R), a < b -> { x : CRcarrier R & prod (a < x < b) (forall n k:nat, CRapart R x (un n k)) }. Proof. intros. destruct (CRuncountable (fun p:nat => let (n, k) := diagPlaneInv p in un n k) a b H). exists x. split. exact (fst p). intros n k. destruct p. specialize (c (diagPlane n k)). rewrite diagPlaneInject in c. exact c. Qed. Lemma CRuncountableDiag3 : forall {R : ConstructiveReals} (un : nat -> nat -> nat -> CRcarrier R) (a b : CRcarrier R), a < b -> { x : CRcarrier R & prod (a < x < b) (forall n k i:nat, CRapart R x (un n k i)) }. Proof. intros. destruct (CRuncountableDiag (fun p i:nat => let (n, k) := diagPlaneInv p in un n k i) a b H). exists x. split. exact (fst p). intros n k i. destruct p. specialize (c (diagPlane n k) i). rewrite diagPlaneInject in c. exact c. Qed. Definition StepApprox {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (s t : CRcarrier R) (ltst : s < t) : PartialFunction X := Xscale (CRinv R (t - s) (inr (CRlt_minus s t ltst))) (Xminus (XminConst f t) (XminConst f s)). Definition StepApproxIntegrable {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (s t : CRcarrier (RealT (ElemFunc IS))) (ltst : 0 < s < t) : IntegrableFunction f -> IntegrableFunction (StepApprox f s t (snd ltst)) := fun fInt => IntegrableScale _ _ (IntegrableMinus (IntegrableMinConst f t fInt (CRlt_trans 0 s t (fst ltst) (snd ltst))) (IntegrableMinConst f s fInt (fst ltst))). Lemma StepApproxBetween : forall {R : ConstructiveReals} (t : CRcarrier R) (tPos : 0 < t) (n : nat), 0 < t*CR_of_Q _ (1-(1#Pos.of_nat (2*S n))) < t. Proof. split. - apply CRmult_lt_0_compat. exact tPos. apply CR_of_Q_pos. unfold Qminus. rewrite <- (Qplus_opp_r (1 # Pos.of_nat (2 * S n))), Qplus_lt_l. unfold Qlt, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_lt_pos. rewrite Pos2Nat.inj_lt, Nat2Pos.id. simpl. apply le_n_S. rewrite Nat.add_comm. apply le_n_S, Nat.le_0_l. discriminate. - apply (CRlt_le_trans _ (t* CR_of_Q _ 1)). 2: rewrite CRmult_1_r; apply CRle_refl. apply CRmult_lt_compat_l. exact tPos. apply CR_of_Q_lt. apply (Qplus_lt_l _ _ ((1 # Pos.of_nat (2 * S n))-1)). ring_simplify. reflexivity. Qed. Lemma StepApproxCv : forall {R : ConstructiveReals} (t : CRcarrier R), CR_cv R (fun n => t*CR_of_Q _ (1-(1#Pos.of_nat (2*S n)))) t. Proof. intros. apply (CR_cv_proper _ (1*t)). 2: apply CRmult_1_l. apply (CR_cv_eq _ (fun n : nat => CR_of_Q R (1 - (1 # Pos.of_nat (2 * S n))) * t)). intro n. apply CRmult_comm. apply CR_cv_scale. intro p. exists (Pos.to_nat p). intros. setoid_replace (CR_of_Q R (1 - (1 # Pos.of_nat (2 * S i))) - 1) with (-CR_of_Q R (1 # Pos.of_nat (2 * S i))). - rewrite CRabs_opp, CRabs_right. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. rewrite Pos2Nat.inj_le, Nat2Pos.id. 2: discriminate. apply (Nat.le_trans _ _ _ H). simpl. apply le_S. apply (Nat.le_trans _ (i+0)). rewrite Nat.add_comm. apply Nat.le_refl. apply Nat.add_le_mono_l, Nat.le_0_l. apply CR_of_Q_le. discriminate. - unfold Qminus. rewrite CR_of_Q_plus, CR_of_Q_opp. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_l. reflexivity. Qed. Lemma StepApproxAbove : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (t : CRcarrier R) (tPos : 0 < t) (x : X) (xnD : nat -> Domain f x * Domain f x) (l : CRcarrier R), 0 < l -> CR_cv R (fun n : nat => partialApply (StepApprox f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S n)))) t (snd (StepApproxBetween t tPos n))) x (xnD n)) l -> t <= partialApply f x (fst (xnD O)). Proof. intros. intro abs. destruct (CR_cv_open_below _ _ _ (StepApproxCv t) abs) as [n nmaj]. assert (CR_cv R (fun n : nat => partialApply (StepApprox f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S n)))) t (snd (StepApproxBetween t tPos n))) x (xnD n)) 0). intro p. exists n. intros. unfold StepApprox. rewrite applyXscale. setoid_replace (partialApply (Xminus (XminConst f t) (XminConst f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S i)))))) x (xnD i)) with (CR_of_Q R 0). rewrite CRmult_0_r. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. destruct (xnD i). rewrite (applyXminus (XminConst f t) (XminConst f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S i))))) x). rewrite applyXminConst, applyXminConst. rewrite CRmin_left, CRmin_left. unfold CRminus. rewrite (DomainProp f x d d0), CRplus_opp_r. reflexivity. specialize (nmaj i H1). rewrite (DomainProp f x d0 (fst (xnD 0%nat))). apply CRlt_asym, nmaj. specialize (nmaj i H1). rewrite (DomainProp f x d (fst (xnD 0%nat))). apply CRlt_asym, (CRlt_trans _ _ _ nmaj). apply StepApproxBetween, tPos. rewrite <- (CR_cv_unique _ _ _ H1 H0) in H. exact (CRlt_asym 0 0 H H). Qed. Lemma StepApproxBelow : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (t : CRcarrier R) (tPos : 0 < t) (x : X) (xnD : nat -> Domain f x * Domain f x) (l : CRcarrier R), l < 1 -> CR_cv R (fun n : nat => partialApply (StepApprox f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S n)))) t (snd (StepApproxBetween t tPos n))) x (xnD n)) l -> partialApply f x (fst (xnD O)) < t. Proof. intros. destruct (CR_cv_open_above _ _ _ H0 H) as [k kmaj]. specialize (kmaj k (Nat.le_refl k)). unfold StepApprox in kmaj. rewrite applyXscale in kmaj. apply (CRmult_lt_compat_l (t - t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S k))))) in kmaj. 2: apply CRlt_minus, StepApproxBetween, tPos. destruct (xnD k) as [d d0]. assert (partialApply (XminConst f t) x d < t) as H1. { apply (CRplus_lt_reg_r (- partialApply (XminConst f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S k))))) x d0)). apply (CRle_lt_trans (partialApply (XminConst f t) x d + - partialApply (XminConst f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S k))))) x d0 )) in kmaj. apply (CRlt_le_trans _ _ _ kmaj). rewrite CRmult_1_r. apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply CRmin_r. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l. rewrite (applyXminus (XminConst f t) (XminConst f (t * CR_of_Q R (1 - (1 # Pos.of_nat (2 * S k)))))). apply CRle_refl. } clear kmaj. apply (CRle_lt_trans _ (partialApply (XminConst f t) x d)). 2: exact H1. apply CRmin_lt_r in H1. rewrite H1. rewrite (DomainProp f x _ d). apply CRle_refl. Qed. Lemma AffineLe : forall {R : ConstructiveReals} (a b c d x low up : CRcarrier R), a * low + b <= c * low + d -> a * up + b <= c * up + d -> low <= x <= up -> a * x + b <= c * x + d. Proof. intro R. assert (forall (a b x low up : CRcarrier R), 0 <= a * low + b -> 0 <= a * up + b -> low <= x <= up -> 0 <= a * x + b). { intros. apply (CRle_trans _ (CRmin (a*low+b) (a*up+b))). apply CRmin_glb; assumption. rewrite CRplus_comm, (CRplus_comm (a*up)), <- CRmin_plus, CRplus_comm. apply CRplus_le_compat_r. intro abs. apply CRlt_min in abs. destruct abs. clear H H0. apply CRlt_minus in c. pose proof (CRmult_pos_appart_zero a (low-x)). destruct H. apply (CRlt_le_trans _ _ _ c). unfold CRminus. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. apply CRle_refl. + contradict c. apply (CRle_trans _ (a * (low - x))). unfold CRminus. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. apply CRle_refl. rewrite <- (CRmult_0_r a). apply CRmult_le_compat_l. apply CRlt_asym, c1. rewrite <- (CRplus_opp_r x). apply CRplus_le_compat_r. exact (proj1 H1). + apply CRopp_gt_lt_contravar in c0. contradict c0. fold (-(a*x) <= -(a*up)). do 2 rewrite CRopp_mult_distr_l. apply CRmult_le_compat_l. rewrite <- CRopp_0. apply CRopp_ge_le_contravar, CRlt_asym, c1. exact (proj2 H1). } intros. apply (CRplus_le_reg_r (-(a*x+b))). rewrite CRplus_opp_r, CRopp_plus_distr, CRplus_assoc. rewrite (CRplus_comm d), <- CRplus_assoc, <- CRplus_assoc. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. rewrite CRplus_assoc. apply (H (c-a) (-b+d) x low up). 3: exact H2. rewrite (CRplus_comm (-b)), <- CRplus_assoc. apply (CRplus_le_reg_r b). rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r. unfold CRminus. rewrite CRmult_plus_distr_r, CRplus_comm, <- CRplus_assoc. apply (CRplus_le_reg_r (a*low)). rewrite CRplus_assoc, <- CRopp_mult_distr_l, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm, (CRplus_comm d). exact H0. rewrite (CRplus_comm (-b)), <- CRplus_assoc. apply (CRplus_le_reg_r b). rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r. unfold CRminus. rewrite CRmult_plus_distr_r, CRplus_comm, <- CRplus_assoc. apply (CRplus_le_reg_r (a*up)). rewrite CRplus_assoc, <- CRopp_mult_distr_l, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm, (CRplus_comm d). exact H1. Qed. Lemma StepApproxLe : forall {R : ConstructiveReals} (c s1 t1 s2 t2 : CRcarrier R) (ltst1 : s1 < t1) (ltst2 : s2 < t2), s1 <= s2 -> t1 <= t2 -> CRinv R (t2 - s2) (inr (CRlt_minus s2 t2 ltst2)) * (CRmin c t2 + - CRmin c s2) <= CRinv R (t1 - s1) (inr (CRlt_minus s1 t1 ltst1)) * (CRmin c t1 + - CRmin c s1). Proof. intros. destruct (CRltLinear R) as [_ s]. destruct (s s2 c t2 ltst2). - rewrite (CRmin_right c s2), (CRmin_right c s1). 2: apply (CRle_trans _ _ _ H), CRlt_asym, c0. 2: apply CRlt_asym, c0. apply (CRmult_le_reg_l (t1-s1)). apply CRlt_minus, ltst1. rewrite <- CRmult_assoc, <- CRmult_assoc, CRinv_r, CRmult_1_l, CRmult_comm. apply (CRplus_le_reg_r s1). rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRmin_glb. + apply (CRplus_le_reg_r (-s1)). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply (CRmult_le_reg_r (t2-s2)). apply CRlt_minus, ltst2. rewrite CRmult_assoc, CRmult_assoc, CRinv_l, CRmult_1_r. rewrite CRplus_comm, CRmin_plus, CRmult_comm, <- CRmin_mult. 2: apply CRlt_asym, CRlt_minus, ltst1. intro abs. apply CRlt_min in abs. destruct abs. rewrite (CRplus_comm (-s2)) in c2. apply CRmult_lt_reg_r in c2. 2: apply CRlt_minus, ltst2. apply CRplus_lt_reg_r in c2. assert ((t1 - s1) * (- s2 + c) <= (c + - s1) * (t2 - s2)). { clear c1. rewrite CRplus_comm, CRmult_plus_distr_l. rewrite (CRmult_comm (c+-s1)), CRmult_plus_distr_l. apply (AffineLe _ _ _ _ _ s2 t1). do 2 rewrite <- CRmult_plus_distr_l. rewrite CRplus_opp_r, CRmult_0_r. apply CRmult_le_0_compat. apply CRlt_asym, CRlt_minus, ltst2. rewrite <- (CRplus_opp_r s1). apply CRplus_le_compat_r, H. do 2 rewrite <- CRmult_plus_distr_l. rewrite CRmult_comm. apply CRmult_le_compat_r. apply CRlt_asym, CRlt_minus, ltst1. apply CRplus_le_compat_r, H0. split; apply CRlt_asym; assumption. } contradiction. + apply (CRplus_le_reg_r (-s1)). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply (CRmult_le_reg_r (t2-s2)). apply CRlt_minus, ltst2. rewrite CRmult_assoc, CRmult_assoc, CRinv_l, CRmult_1_r. rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltst1. apply CRplus_le_compat_r, CRmin_r. - rewrite CRmin_left. 2: apply CRlt_asym, c0. destruct (s s1 c t1 ltst1). + rewrite (CRmin_right c s1). 2: apply CRlt_asym, c1. apply (CRmult_le_reg_l (t1-s1)). apply CRlt_minus, ltst1. rewrite <- CRmult_assoc, <- CRmult_assoc, CRinv_r, CRmult_1_l. apply (CRplus_le_reg_r s1). rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRmin_glb. apply (CRplus_le_reg_r (-s1)). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. rewrite CRmult_comm. apply (CRmult_le_reg_r (t2-s2)). apply CRlt_minus, ltst2. rewrite CRmult_assoc, CRmult_assoc, CRinv_l, CRmult_1_r. setoid_replace (- CRmin c s2) with (-(1) * CRmin c s2). rewrite <- CRmax_min_mult_neg. do 2 rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite CRmax_plus, CRmult_comm, <- CRmax_mult. apply CRmax_lub. rewrite CRplus_opp_r, CRmult_0_r. rewrite <- (CRmult_0_r (c-s1)). apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, c1. apply CRlt_asym, CRlt_minus, ltst2. rewrite CRmult_plus_distr_l, (CRmult_comm (c+-s1)), CRmult_plus_distr_l. apply (AffineLe _ _ _ _ _ s1 t2). do 2 rewrite <- CRmult_plus_distr_l. rewrite CRplus_opp_r, CRmult_0_r. rewrite <- (CRmult_0_r (t1-s1)). apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltst1. rewrite <- (CRplus_opp_r s2). apply CRplus_le_compat_r, H. do 2 rewrite <- CRmult_plus_distr_l. rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltst2. apply CRplus_le_compat_r, H0. split; apply CRlt_asym; assumption. apply CRlt_asym, CRlt_minus, ltst1. apply (CRplus_le_reg_l 1). rewrite CRplus_opp_r, CRplus_0_r. apply CRlt_asym, CRzero_lt_one. rewrite <- CRopp_mult_distr_l, CRmult_1_l. reflexivity. apply (CRplus_le_reg_r (-s1)). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. rewrite <- (CRmult_1_r (t1 + - s1)), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltst1. apply (CRmult_le_reg_l (t2-s2)). apply CRlt_minus, ltst2. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l, CRmult_1_r. apply (CRplus_le_reg_r (CRmin c s2)). rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRmin_plus. apply CRmin_glb. apply (CRplus_le_reg_l s2). rewrite <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRlt_asym, ltst2. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRlt_asym, c0. + clear c0. rewrite (CRmin_left c t1). 2: apply CRlt_asym, c1. apply (CRmult_le_reg_l (t2-s2)). apply CRlt_minus, ltst2. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l. apply (CRplus_le_reg_l (-c)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. setoid_replace (- CRmin c s2) with (-(1) * CRmin c s2). 2: rewrite <- CRopp_mult_distr_l, CRmult_1_l; reflexivity. rewrite <- CRmax_min_mult_neg. apply CRmax_lub. rewrite <- CRopp_mult_distr_l, CRmult_1_l. apply (CRle_trans _ (-c +0)). rewrite CRplus_0_r; apply CRle_refl. apply CRplus_le_compat_l. apply (CRle_trans _ ((t2-s2)*0)). rewrite CRmult_0_r; apply CRle_refl. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltst2. apply (CRmult_le_reg_l (t1-s1)). apply CRlt_minus, ltst1. rewrite CRmult_0_r, <- CRmult_assoc, CRinv_r, CRmult_1_l. rewrite <- (CRplus_opp_r (CRmin c s1)). apply CRplus_le_compat_r, CRmin_l. rewrite <- CRopp_mult_distr_l, CRmult_1_l. apply (CRplus_le_reg_l c). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l, CRmult_comm. apply (CRmult_le_reg_l (t1-s1)). apply CRlt_minus, ltst1. rewrite <- CRmult_assoc, <- CRmult_assoc, CRinv_r, CRmult_1_l. rewrite CRmult_plus_distr_r. apply (CRplus_le_reg_l (-(c*(t2-s2)))). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite (CRmult_comm (-CRmin c s1)), <- CRopp_mult_distr_r. rewrite <- CRmin_mult. 2: apply CRlt_asym, CRlt_minus, ltst2. rewrite <- CRopp_involutive, CRopp_plus_distr, CRopp_involutive. apply CRopp_ge_le_contravar. intro abs. apply CRlt_min in abs. destruct abs. rewrite <- (CRplus_0_r ((t2-s2)*c)), (CRmult_comm (t2-s2)) in c0. apply CRplus_lt_reg_l in c0. apply (CRplus_lt_compat_l R ((t1 - s1) * (c + - s2))) in c0. rewrite CRplus_opp_r, CRplus_0_r in c0. rewrite <- (CRmult_0_r (t1-s1)) in c0. apply CRmult_lt_reg_l in c0. 2: apply CRlt_minus, ltst1. rewrite <- (CRplus_opp_r s2) in c0. apply CRplus_lt_reg_r in c0. assert ((t2-s2)*s1 <= c * (t2 - s2) + - ((t1 - s1) * (c + - s2))). { apply (CRplus_le_reg_r ((t1 - s1) * (c + - s2))). rewrite CRplus_assoc, CRplus_opp_l, CRplus_comm. rewrite CRmult_plus_distr_l, CRplus_assoc, (CRmult_comm c). apply (AffineLe _ _ _ _ _ s2 t1). 3: split; apply CRlt_asym; assumption. rewrite CRplus_0_r, <- CRplus_assoc, <- CRopp_mult_distr_r. rewrite CRplus_opp_r, CRplus_0_l. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltst2. exact H. rewrite CRplus_0_r, <- CRplus_assoc, <- CRmult_plus_distr_l. apply (CRplus_le_reg_r (-((t2-s2)*s1))). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r, CRopp_mult_distr_r. rewrite <- CRmult_plus_distr_l, CRmult_comm. apply CRmult_le_compat_r. apply CRlt_asym, CRlt_minus, ltst1. apply CRplus_le_compat_r, H0. } contradiction. apply (CRplus_le_reg_l 1). rewrite CRplus_opp_r, CRplus_0_r. apply CRlt_asym, CRzero_lt_one. Qed. Definition InverseImageIntegrableGivenLimit {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (t : CRcarrier (RealT (ElemFunc IS))) (tPos : 0 < t) : CR_cauchy _ (fun n:nat => Integral (StepApproxIntegrable f _ t (StepApproxBetween t tPos n) fInt)) -> { limInt : IntegrableSet (fun x => exists xD:Domain f x, t <= partialApply f x xD) & CR_cv _ (fun n:nat => Integral (StepApproxIntegrable f _ t (StepApproxBetween t tPos n) fInt)) (MeasureSet limInt) }. Proof. intro cv. apply CR_complete in cv. destruct cv as [a cv]. destruct (IntegralMonotoneConvergenceDecr IS _ (fun n => StepApproxIntegrable f _ _ (StepApproxBetween t tPos n) fInt) a) as [limInt c]. - intros n x xdf xdg. destruct xdf, xdg. unfold StepApprox. rewrite applyXscale, applyXscale. rewrite (applyXminus (XminConst f t) (XminConst f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S (S n))))))). rewrite (applyXminus (XminConst f t) (XminConst f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S n)))))). do 4 rewrite applyXminConst. rewrite (DomainProp f x d2 d), (DomainProp f x d1 d), (DomainProp f x d0 d). apply StepApproxLe. 2: apply CRle_refl. apply CRmult_le_compat_l. apply CRlt_asym, tPos. apply CR_of_Q_le. apply Qplus_le_r, Qopp_le_compat. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. rewrite Pos2Nat.inj_le, Nat2Pos.id, Nat2Pos.id. 2: discriminate. 2: discriminate. simpl. apply le_n_S, le_S. apply Nat.add_le_mono_l. apply le_S, Nat.le_refl. - exact cv. - assert (PartialRestriction (XpointwiseLimit (fun n : nat => StepApprox f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S n)))) t (snd (StepApproxBetween t tPos n)))) (CharacFunc (fun x => exists xD:Domain f x, t <= partialApply f x xD))) as res. { clear c limInt cv a. split. + intros x [xnD xnlim]. simpl in xnD. apply CR_complete in xnlim. destruct xnlim as [l xnlim]. destruct (CRltLinear (RealT (ElemFunc IS))). destruct (s 0 l 1 (CRzero_lt_one _)). left. exists (fst (xnD O)). exact (StepApproxAbove f t tPos x xnD l c xnlim). right. intros [xD abs]. apply abs. clear abs. rewrite (DomainProp f x xD (fst (xnD O))). exact (StepApproxBelow f t tPos x xnD l c xnlim). + intros. apply applyPointwiseLimit. destruct xG. apply (CR_cv_eq _ (fun _ => 1)). 2: apply CR_cv_const. intro n. destruct xD as [xnD H]. unfold StepApprox. rewrite applyXscale. setoid_replace (partialApply (Xminus (XminConst f t) (XminConst f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S n)))))) x (xnD n)) with (t - t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S n)))). rewrite CRinv_l. reflexivity. destruct (xnD n). apply CRplus_morph. rewrite applyXminConst. rewrite CRmin_right. reflexivity. destruct e. rewrite (DomainProp f x d x0). exact H0. rewrite applyXscale. rewrite applyXminConst, CRmin_right. rewrite <- CRopp_mult_distr_l, CRmult_1_l. reflexivity. destruct e. rewrite (DomainProp f x d0 x0). apply (CRle_trans _ t). 2: exact H0. apply CRlt_asym, StepApproxBetween, tPos. destruct xD as [xnD H]. simpl in xnD. apply CR_complete in H. destruct H as [l lcv]. destruct (CRltLinear (RealT (ElemFunc IS))). destruct (s 0 l 1 (CRzero_lt_one _)). exfalso. apply n. exists (fst (xnD O)). exact (StepApproxAbove f t tPos x xnD l c lcv). pose proof (StepApproxBelow f t tPos x xnD l c lcv). destruct (CR_cv_open_below _ _ _ (StepApproxCv t) H) as [k kmaj]. intro i. exists k. intros. setoid_replace (partialApply (StepApprox f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S i0)))) t (snd (StepApproxBetween t tPos i0))) x (xnD i0)) with (CR_of_Q (RealT (ElemFunc IS)) 0). simpl. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. apply CR_of_Q_le. discriminate. apply CRle_refl. unfold StepApprox. rewrite applyXscale. setoid_replace (partialApply (Xminus (XminConst f t) (XminConst f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S i0)))))) x (xnD i0) ) with (CR_of_Q (RealT (ElemFunc IS)) 0). rewrite CRmult_0_r. reflexivity. destruct (xnD i0). rewrite (applyXminus (XminConst f t) (XminConst f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S i0))))) ). rewrite applyXminConst, applyXminConst, CRmin_left, CRmin_left. unfold CRminus; rewrite (DomainProp f x d0 d), CRplus_opp_r; reflexivity. rewrite (DomainProp f x d0 (fst (xnD O))). apply CRlt_asym, kmaj, H0. rewrite (DomainProp f x d (fst (xnD O))). apply CRlt_asym, H. } exists (IntegrableFunctionExtensional _ _ res limInt). unfold MeasureSet. rewrite IntegralRestrict. exact (CR_cv_proper _ _ _ cv (CReq_sym _ _ c)). Qed. (* To prove that the inverse image {t <= f} is integrable, we have reduced the problem of giving a sequence of representative L-functions to the problem of the convergence of a non-increasing and bounded sequence : lim_{s -> t} Integral (StepApproxIntegrable f s t). Classically this convergence is automatic at each t, which gives a non-increasing function of t that is caglad. It is well-known classically that those functions are almost everywhere continuous, with at most a countable infinity of jump points. Constructively this convergence is not automatic, so we are left with studying the function of 2 variables fun s t => Integral (StepApproxIntegrable f s t) with 0 < s < t. We will define constructively what t's are jump points of the intended limit function, prove that they are at most countable, and prove that outside of them the limit exists constructively. Besides at those continuity points t we will also have equal measures for the subsets {t <= f} and {t < f}. *) (* The monotone property extended constructively in 2 variables. *) Lemma StepApproxIntegralIncr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (s1 t1 s2 t2 : CRcarrier (RealT (ElemFunc IS))) (ltst1 : 0 < s1 < t1) (ltst2 : 0 < s2 < t2), s1 <= s2 -> t1 <= t2 -> Integral (StepApproxIntegrable f s2 t2 ltst2 fInt) <= Integral (StepApproxIntegrable f s1 t1 ltst1 fInt). Proof. intros. apply IntegralNonDecreasing. intros x xdf xdg. simpl. destruct xdf, xdg. rewrite (DomainProp f x d2 d), (DomainProp f x d1 d), (DomainProp f x d0 d). generalize (partialApply f x d). intro c. rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- CRopp_mult_distr_l, CRmult_1_l. apply StepApproxLe; assumption. Qed. Record IntervalExtension {R : ConstructiveReals} {x y : CRcarrier R} : Set := { ext_eta : CRcarrier R; left_ordered : 0 < x - ext_eta < x; right_ordered : y < y + ext_eta; }. Lemma IntExtRightPos : forall {R : ConstructiveReals} {x y : CRcarrier R} (IntExt : @IntervalExtension R x y), x <= y -> 0 < y. Proof. intros. apply (CRlt_le_trans _ x). apply (CRlt_trans _ _ _ (fst (left_ordered IntExt)) (snd (left_ordered IntExt))). exact H. Qed. (* Now for t1 <= t2 we bound the difference of measures of { t1 <= f } and { t2 <= f }, left limit at t1 and right limit at t2, ie including both jumps at the extreme points t1 and t2. *) Definition StepApproxBound {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (t1 t2 b : CRcarrier (RealT (ElemFunc IS))) (let1t2 : t1 <= t2) : Set := { ext : @IntervalExtension _ t1 t2 & Integral (StepApproxIntegrable f (t1 - ext_eta ext) t1 (left_ordered ext) fInt) - Integral (StepApproxIntegrable f t2 (t2 + ext_eta ext) (pair (IntExtRightPos ext let1t2) (right_ordered ext)) fInt) < b }. (* Exlude jumps at extreme points t1, t2 for open intervals ]t1,t2[. *) Definition StepApproxBoundOpen {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (t1 t2 b : CRcarrier (RealT (ElemFunc IS))) : Prop := forall x y u v (ltxy : 0 < x < y) (ltuv : 0 < u < v), t1 < x -> y <= u -> v < t2 -> Integral (StepApproxIntegrable f x y ltxy fInt) - Integral (StepApproxIntegrable f u v ltuv fInt) <= b. Lemma StepApproxBoundPos : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (t1 t2 b : CRcarrier (RealT (ElemFunc IS))) (let1t2 : t1 <= t2), StepApproxBound f fInt t1 t2 b let1t2 -> 0 < b. Proof. intros. destruct H. apply (CRle_lt_trans _ (Integral (StepApproxIntegrable f (t1 - ext_eta x) t1 (left_ordered x) fInt) - Integral (StepApproxIntegrable f t2 (t2 + ext_eta x) (IntExtRightPos x let1t2, right_ordered x) fInt))). 2: exact c. apply (CRplus_le_reg_r (Integral (StepApproxIntegrable f t2 (t2 + ext_eta x) (IntExtRightPos x let1t2, right_ordered x) fInt))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l. clear c. apply StepApproxIntegralIncr. destruct x. simpl. apply (CRle_trans _ t1). apply CRlt_asym, left_ordered0. exact let1t2. destruct x. simpl. apply (CRle_trans _ t2). exact let1t2. apply CRlt_asym, right_ordered0. Qed. (* It is easier to detect that a monotone sequence converges. *) Lemma StepApproxBoundCv : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (t : CRcarrier (RealT (ElemFunc IS))) (tPos : 0 < t), (forall b : CRcarrier (RealT (ElemFunc IS)), 0 < b -> StepApproxBound f fInt t t b (CRle_refl t)) -> CR_cauchy _ (fun n:nat => Integral (StepApproxIntegrable f _ t (StepApproxBetween t tPos n) fInt)). Proof. intros. intro p. destruct (H (CR_of_Q _ (1 # p))) as [ext extmaj]. apply CR_of_Q_pos. reflexivity. assert (0 < ext_eta ext). { destruct ext; clear extmaj. simpl. apply (CRplus_lt_reg_l _ t). rewrite CRplus_0_r. exact right_ordered0. } destruct (CR_cv_open_below _ (t-ext_eta ext) t (StepApproxCv t)) as [n nmaj]. apply ext. exists n. intros. destruct (le_lt_dec i j). - rewrite CRabs_right. apply (CRle_trans _ (Integral (StepApproxIntegrable f (t - ext_eta ext) t (left_ordered ext) fInt) - Integral (StepApproxIntegrable f t (t + ext_eta ext) (IntExtRightPos ext (CRle_refl t), right_ordered ext) fInt))). 2: apply CRlt_asym; exact extmaj. apply CRplus_le_compat. apply StepApproxIntegralIncr. apply CRlt_asym, nmaj, H1. apply CRle_refl. apply CRopp_ge_le_contravar. apply StepApproxIntegralIncr. apply CRlt_asym, StepApproxBetween, tPos. apply CRlt_asym, ext. apply (CRplus_le_reg_r (Integral (StepApproxIntegrable f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S j)))) t (StepApproxBetween t tPos j) fInt))). unfold CRminus. rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply StepApproxIntegralIncr. 2: apply CRle_refl. apply CRmult_le_compat_l. apply CRlt_asym, tPos. apply CR_of_Q_le, Qplus_le_r, Qopp_le_compat. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. rewrite Pos2Nat.inj_le, Nat2Pos.id, Nat2Pos.id. apply Nat.mul_le_mono_nonneg_l. auto. apply le_n_S, l. discriminate. discriminate. - rewrite CRabs_minus_sym. rewrite CRabs_right. apply (CRle_trans _ (Integral (StepApproxIntegrable f (t - ext_eta ext) t (left_ordered ext) fInt) - Integral (StepApproxIntegrable f t (t + ext_eta ext) (IntExtRightPos ext (CRle_refl t), right_ordered ext) fInt))). 2: apply CRlt_asym; exact extmaj. apply CRplus_le_compat. apply StepApproxIntegralIncr. apply CRlt_asym, nmaj, H2. apply CRle_refl. apply CRopp_ge_le_contravar. apply StepApproxIntegralIncr. apply CRlt_asym, StepApproxBetween, tPos. apply CRlt_asym, ext. apply (CRplus_le_reg_r (Integral (StepApproxIntegrable f (t * CR_of_Q (RealT (ElemFunc IS)) (1 - (1 # Pos.of_nat (2 * S i)))) t (StepApproxBetween t tPos i) fInt))). unfold CRminus. rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply StepApproxIntegralIncr. 2: apply CRle_refl. apply CRmult_le_compat_l. apply CRlt_asym, tPos. apply CR_of_Q_le, Qplus_le_r, Qopp_le_compat. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. rewrite Pos2Nat.inj_le, Nat2Pos.id, Nat2Pos.id. apply Nat.mul_le_mono_nonneg_l. auto. apply le_S, l. discriminate. discriminate. Qed. Definition BinarySubdiv {R : ConstructiveReals} (a b : CRcarrier R) (n i : nat) : CRcarrier R := a + CR_of_Q R (Z.of_nat i # 1) * (b-a) * CRpow (CR_of_Q R ((/2))) n. Lemma BinarySubdivIncr : forall {R : ConstructiveReals} (a b : CRcarrier R) (n i : nat), 0 < a < b -> 0 < BinarySubdiv a b n i < BinarySubdiv a b n (S i). Proof. intros. assert (0 < (b - a) * CRpow (CR_of_Q R (/ 2)) n). { apply CRmult_lt_0_compat. apply CRlt_minus. exact (snd H). apply CRpow_gt_zero. apply CR_of_Q_pos. reflexivity. } split. - unfold BinarySubdiv. apply (CRlt_le_trans _ (a + 0)). rewrite CRplus_0_r. exact (fst H). apply CRplus_le_compat_l. rewrite CRmult_assoc. apply CRmult_le_0_compat. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Zle_0_nat. apply CRlt_asym, H0. - apply CRplus_lt_compat_l. apply CRmult_lt_compat_r. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CRmult_lt_compat_r. apply CRlt_minus. exact (snd H). apply CR_of_Q_lt. unfold Qlt, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply inj_lt, Nat.le_refl. Qed. Lemma BinarySubdivNext : forall {R : ConstructiveReals} (a b : CRcarrier R) (n i:nat), BinarySubdiv a b n i + CRpow (CR_of_Q R (1 # 2)) n * (b - a) == BinarySubdiv a b n (S i). Proof. intros. unfold BinarySubdiv. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRmult_assoc, <- (CRmult_comm (b-a)). rewrite <- (CRmult_1_l ((b - a) * CRpow (CR_of_Q R (1 # 2)) n)). rewrite (CRpow_proper (CR_of_Q R (/ 2)) (CR_of_Q R (1#2))). 2: apply CR_of_Q_morph; reflexivity. rewrite <- CRmult_plus_distr_r. rewrite CRmult_assoc. apply CRmult_morph. 2: reflexivity. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. rewrite Nat.add_comm. reflexivity. reflexivity. Qed. Lemma pow_nat : forall {R : ConstructiveReals} (a n : nat), CR_of_Q R (Z.of_nat (a ^ n) # 1) == CRpow (CR_of_Q R (Z.of_nat a # 1)) n. Proof. induction n. - reflexivity. - simpl. setoid_replace (Z.of_nat (a * a ^ n) # 1) with ((Z.of_nat a # 1) * (Z.of_nat (a ^ n) # 1))%Q. rewrite CR_of_Q_mult. apply CRmult_morph. reflexivity. exact IHn. rewrite Nat2Z.inj_mul. reflexivity. Qed. Lemma BinarySubdivInside : forall {R : ConstructiveReals} (a b : CRcarrier R) (n i : nat), a <= b -> le i (2 ^ n) -> a <= BinarySubdiv a b n i <= b. Proof. split. - apply (CRle_trans _ (a+0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_le_compat_l. apply CRmult_le_0_compat. apply CRmult_le_0_compat. apply CR_of_Q_le. destruct i; discriminate. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r, H. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. - unfold BinarySubdiv. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite (CRplus_comm (-a)), <- (CRmult_comm (b-a)), <- (CRmult_1_r (b+-a)). rewrite CRmult_assoc. apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r, H. apply (CRmult_le_reg_r (CRpow (CR_of_Q R 2) n)). apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. rewrite CRmult_assoc, CRpow_mult. rewrite (CRpow_proper (CR_of_Q R (/ 2) * CR_of_Q R 2) 1). rewrite CRpow_one, CRmult_1_r, CRmult_1_l. apply (CRle_trans _ (CR_of_Q R (Z.of_nat (2^n)#1))). apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. apply Nat2Z.inj_le, H0. rewrite <- (pow_nat 2). apply CRle_refl. rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. reflexivity. Qed. Lemma BinarySubdivRight : forall {R : ConstructiveReals} (a b : CRcarrier R) (n : nat), a <= b -> BinarySubdiv a b n (2 ^ n) == b. Proof. intros. unfold BinarySubdiv. apply (CRplus_eq_reg_l (-a)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, (CRplus_comm (-a)). rewrite <- (CRmult_comm (b-a)), <- (CRmult_1_r (b+-a)). rewrite CRmult_assoc. apply CRmult_morph. reflexivity. apply (CRmult_eq_reg_r (CRpow (CR_of_Q R 2) n)). left. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. rewrite CRmult_assoc, CRmult_1_l, CRpow_mult. rewrite (CRpow_proper (CR_of_Q R (/ 2) * CR_of_Q R 2) 1). rewrite CRpow_one, CRmult_1_r. apply (pow_nat 2). rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. reflexivity. Qed. Fixpoint FindCrossingPoint {R : ConstructiveReals} (un : nat -> CRcarrier R) (N : nat) (alpha : CRcarrier R) { struct N } : (forall n:nat, un (S n) <= un n) -> (forall n:nat, CRapart R alpha (un n)) -> alpha < un O -> { k : nat & (le k N) * (sum (k = N) (un (S k) < alpha)) * (alpha < un k) }%type. (* besides k is unique *) Proof. intros. destruct N. - exists O. split. split. exact (Nat.le_refl O). left. reflexivity. exact H1. - destruct (H0 (S N)). + exists (S N). split. split. exact (Nat.le_refl (S N)). left. reflexivity. exact c. + destruct (FindCrossingPoint R un N alpha H H0 H1) as [k kmaj]. exists k. split. split. apply le_S, (fst kmaj). right. destruct kmaj, p, s. subst k. exact c. exact c1. exact (snd kmaj). Qed. (* Search the jump points in the binary discretization of interval [a,b]. Allows to build incrementally better approximations of them. Also, being countable, we can use a jump size epsilon that is appart of them all. *) Definition StepApproxDiscretize {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i : nat) (* Cut [a,b] into 2^n pieces *) : CRcarrier (RealT (ElemFunc IS)) := match i with | O => Integral (StepApproxIntegrable f (a - eta) a aeta fInt) | S j => if le_lt_dec (S (2 ^ n)) i then Integral (StepApproxIntegrable f b (b + eta) beta fInt) else Integral (StepApproxIntegrable f (BinarySubdiv a b n j) (BinarySubdiv a b n (S j)) (BinarySubdivIncr a b n j (pair aPos ltab)) fInt) end. Lemma StepApproxDiscretizeDecr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i j : nat), le i j -> StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n j <= StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n i. Proof. induction j. - intros. inversion H. apply CRle_refl. - intros. apply Nat.le_succ_r in H. destruct H. 2: subst i; apply CRle_refl. apply (CRle_trans _ (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n j)). 2: exact (IHj H). destruct j. + unfold StepApproxDiscretize. destruct (le_lt_dec (S (2 ^ n)) 1). exfalso. apply le_S_n in l. inversion l. pose proof (Nat.pow_gt_lin_r 2 n (Nat.le_refl _)). rewrite H1 in H0. inversion H0. apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, (snd aeta). apply BinarySubdivInside. apply CRlt_asym, ltab. apply Nat.le_0_l. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n, l. + unfold StepApproxDiscretize. destruct (le_lt_dec (S (2 ^ n)) (S (S j))), (le_lt_dec (S (2 ^ n)) (S j)). apply CRle_refl. apply StepApproxIntegralIncr. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n in l0. apply (Nat.le_trans _ (S j)). apply le_S, Nat.le_refl. exact l0. apply (CRle_trans _ b). apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n, l0. apply CRlt_asym, (snd beta). exfalso. pose proof (Nat.lt_le_trans _ _ _ l l0). apply (proj1 (Nat.lt_nge _ _) H0). apply le_S, Nat.le_refl. apply StepApproxIntegralIncr. apply CRlt_asym, BinarySubdivIncr. exact (pair aPos ltab). apply CRlt_asym, BinarySubdivIncr. exact (pair aPos ltab). Qed. Lemma StepApproxDiscretizeRefineDecr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i j : nat), le (2*j) i -> StepApproxDiscretize f fInt a b eta aPos ltab aeta beta (S n) i <= StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n j. (* Integral between a + (b-a)*(j-1)/2^n and a + (b-a)*j/2^n *) Proof. intros. unfold StepApproxDiscretize. destruct j,i. - apply CRle_refl. - clear H. destruct (le_lt_dec (S (2 ^ S n)) (S i)). apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, (snd aeta). apply CRlt_asym, ltab. apply (CRle_trans _ b). apply CRlt_asym, ltab. apply CRlt_asym, (snd beta). apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, (snd aeta). apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n in l. apply (Nat.le_trans _ (S i)). apply le_S, Nat.le_refl. exact l. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n, l. - exfalso. inversion H. - destruct (le_lt_dec (S (2 ^ n)) (S j)), (le_lt_dec (S (2 ^ S n)) (S i)). + apply CRle_refl. + exfalso. apply le_S_n in l0. apply (Nat.le_trans _ _ _ H) in l0. clear H. apply (Nat.mul_le_mono_pos_l _ _ 2) in l0. apply (Nat.le_trans _ _ _ l) in l0. apply (proj1 (Nat.le_ngt _ _) l0 (Nat.le_refl _)). apply le_n_S, Nat.le_0_l. + apply StepApproxIntegralIncr. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n in l. apply (Nat.le_trans _ (S j)). apply le_S, Nat.le_refl. exact l. apply (CRle_trans _ b). apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n, l. apply CRlt_asym, (snd beta). + apply StepApproxIntegralIncr. apply CRplus_le_compat_l. do 2 rewrite <- (CRmult_comm (b-a)), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. simpl (CRpow (CR_of_Q (RealT (ElemFunc IS)) (/ 2)) (S n)). rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_mult. apply CR_of_Q_le. apply Qle_shift_div_l. reflexivity. unfold Qmult, Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. replace 2%Z with (Z.of_nat 2). 2: reflexivity. rewrite <- Nat2Z.inj_mul. apply Nat2Z.inj_le. apply le_S_n. apply (Nat.le_trans _ (2*S j)). 2: exact H. rewrite Nat.mul_comm. simpl. rewrite Nat.add_0_r, Nat.add_succ_r. apply le_S, Nat.le_refl. apply CRplus_le_compat_l. do 2 rewrite <- (CRmult_comm (b-a)), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. simpl (CRpow (CR_of_Q (RealT (ElemFunc IS)) (/ 2)) (S n)). rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_mult. apply CR_of_Q_le. apply Qle_shift_div_l. reflexivity. unfold Qmult, Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. replace 2%Z with (Z.of_nat 2). 2: reflexivity. rewrite <- Nat2Z.inj_mul. apply Nat2Z.inj_le. apply (Nat.le_trans _ (2*S j)). 2: exact H. rewrite Nat.mul_comm. apply Nat.le_refl. Qed. Lemma StepApproxDiscretizeRefineIncr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i j : nat), le (S i) (2*j) -> StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n j (* Integral between a + (b-a)*(j-1)/2^n and a + (b-a)*j/2^n *) <= StepApproxDiscretize f fInt a b eta aPos ltab aeta beta (S n) i. Proof. intros. unfold StepApproxDiscretize. destruct j. exfalso; inversion H. destruct i. - destruct (le_lt_dec (S (2 ^ n)) (S j)). apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, aeta. apply CRlt_asym, ltab. apply (CRle_trans _ b). apply CRlt_asym, ltab. apply CRlt_asym, beta. apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, aeta. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n in l. apply (Nat.le_trans _ (S j)). apply le_S, Nat.le_refl. exact l. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n, l. - destruct (le_lt_dec (S (2 ^ n)) (S j)), (le_lt_dec (S (2 ^ S n)) (S i)). + apply CRle_refl. + apply StepApproxIntegralIncr. apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n in l0. apply (Nat.le_trans _ (S i)). apply le_S, Nat.le_refl. exact l0. apply (CRle_trans _ b). apply BinarySubdivInside. apply CRlt_asym, ltab. apply le_S_n, l0. apply CRlt_asym, (snd beta). + exfalso. apply le_S_n in l0. apply le_S_n in l. apply (Nat.le_trans _ _ (2^S n)) in H. apply (Nat.le_trans _ _ _ H) in l0. apply (proj1 (Nat.le_ngt _ _) l0). apply le_S, Nat.le_refl. apply Nat.mul_le_mono_nonneg_l. apply Nat.le_0_l. exact l. + clear l l0. replace (2 * S j)%nat with (S (S (2 * j))) in H. 2: simpl; rewrite Nat.add_0_r, Nat.add_succ_r; reflexivity. apply le_S_n, le_S_n in H. apply StepApproxIntegralIncr. apply CRplus_le_compat_l. do 2 rewrite <- (CRmult_comm (b-a)), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. simpl (CRpow (CR_of_Q (RealT (ElemFunc IS)) (/ 2)) (S n)). rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_mult. apply CR_of_Q_le. apply Qle_shift_div_r. reflexivity. unfold Qmult, Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. replace 2%Z with (Z.of_nat 2). 2: reflexivity. rewrite <- (Nat2Z.inj_mul j 2). apply Nat2Z.inj_le. rewrite Nat.mul_comm. exact H. apply CRplus_le_compat_l. do 2 rewrite <- (CRmult_comm (b-a)), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. simpl (CRpow (CR_of_Q (RealT (ElemFunc IS)) (/ 2)) (S n)). rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_mult. apply CR_of_Q_le. apply Qle_shift_div_r. reflexivity. unfold Qmult, Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_r. replace 2%Z with (Z.of_nat 2). 2: reflexivity. rewrite <- (Nat2Z.inj_mul (S j) 2). apply Nat2Z.inj_le. replace (S j * 2)%nat with (S (S (2*j))). apply le_n_S. apply (Nat.le_trans _ _ _ H). apply le_S, Nat.le_refl. rewrite (Nat.mul_comm (S j)). simpl. rewrite Nat.add_0_r, Nat.add_succ_r. reflexivity. Qed. (* More points to approximate, so better approximation. *) Lemma FindCrossingPointIncr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta alpha : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i j : nat), ((i <= 2 ^ n)%nat * ((i = (2 ^ n)%nat) + (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n (S i) < alpha)) * (alpha < StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n i)) -> ((j <= 2 ^ S n)%nat * ((j = (2 ^ S n)%nat) + (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta (S n) (S j) < alpha)) * (alpha < StepApproxDiscretize f fInt a b eta aPos ltab aeta beta (S n) j)) -> BinarySubdiv a b n i <= BinarySubdiv a b (S n) j + (b-a) * CRpow (CR_of_Q _ (1#2)) (S n). Proof. intros. destruct H,H0,p,p0. destruct s0. - subst j. rewrite BinarySubdivRight. apply (CRle_trans _ (b+0)). rewrite CRplus_0_r. apply BinarySubdivInside. apply CRlt_asym, ltab. exact l. apply CRplus_le_compat_l. apply CRmult_le_0_compat. apply CRlt_asym, CRlt_minus, ltab. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. apply CRlt_asym, ltab. - destruct s. subst i. rewrite BinarySubdivRight. 2: apply CRlt_asym, ltab. destruct (le_lt_dec (2^S n) (S j)). + unfold BinarySubdiv. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- (CRmult_comm (b-a)), <- (CRmult_1_r (-a+b)). rewrite CRmult_assoc, <- CRmult_plus_distr_l, CRplus_comm. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. rewrite <- (CRmult_1_l (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S n))). rewrite <- CRmult_plus_distr_r. apply (CRmult_le_reg_r (CRpow (CR_of_Q _ (Z.of_nat 2 # 1)) (S n))). apply CRpow_gt_zero. apply CR_of_Q_pos. reflexivity. rewrite CRmult_1_l, CRmult_assoc, CRpow_mult. rewrite (CRpow_proper (CR_of_Q (RealT (ElemFunc IS)) (/ 2) * CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat 2 # 1)) 1). rewrite CRpow_one, <- pow_nat, CRmult_1_r. rewrite <- CR_of_Q_plus. apply CR_of_Q_le. unfold Qplus, Qle, Qnum, Qden. do 4 rewrite Z.mul_1_r. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. apply Nat2Z.inj_le. rewrite Nat.add_comm. exact l1. reflexivity. rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. reflexivity. + exfalso. pose proof (CRlt_trans _ _ _ c1 c). apply (StepApproxDiscretizeRefineIncr f fInt a b eta aPos ltab aeta beta n (S j) (2^n)). 2: exact H. unfold lt in l1. replace (2*2^n)%nat with (2 ^ S n)%nat. exact l1. reflexivity. + pose proof (CRlt_trans _ _ _ c1 c) as H. (* Integral on [BinarySubdiv a b (S n) j, BinarySubdiv a b (S n) (S j)] lower than integral on [BinarySubdiv a b n (i-1), BinarySubdiv a b n i] *) destruct (le_lt_dec (S (S j)) (2*i)). * exfalso. exact (StepApproxDiscretizeRefineIncr f fInt a b eta aPos ltab aeta beta n (S j) i l1 H). * apply le_S_n in l1. unfold BinarySubdiv. rewrite CRplus_assoc. apply CRplus_le_compat_l. do 2 rewrite <- (CRmult_comm (b-a)), CRmult_assoc. rewrite <- CRmult_plus_distr_l. rewrite <- (CRmult_1_l (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) (S n))). rewrite <- CRmult_plus_distr_r. simpl (CRpow (CR_of_Q (RealT (ElemFunc IS)) (/ 2)) (S n)). apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_plus, <- CR_of_Q_mult. apply CR_of_Q_le. apply Qle_shift_div_l. reflexivity. unfold Qplus, Qmult, Qle, Qnum, Qden. do 4 rewrite Z.mul_1_r. replace 2%Z with (Z.of_nat 2). rewrite <- Nat2Z.inj_mul. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. apply Nat2Z.inj_le. rewrite Nat.add_comm, Nat.mul_comm. exact l1. reflexivity. reflexivity. Qed. Lemma FindCrossingPointDecr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta alpha : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i j : nat), ((i <= 2 ^ n)%nat * ((i = (2 ^ n)%nat) + (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n (S i) < alpha)) * (alpha < StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n i)) -> ((j <= 2 ^ S n)%nat * ((j = (2 ^ S n)%nat) + (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta (S n) (S j) < alpha)) * (alpha < StepApproxDiscretize f fInt a b eta aPos ltab aeta beta (S n) j)) -> BinarySubdiv a b (S n) j <= BinarySubdiv a b n i + (b-a) * CRpow (CR_of_Q _ (1#2)) n. Proof. intros. destruct H,H0,p,p0. destruct s. - subst i. rewrite BinarySubdivRight. apply (CRle_trans _ (b+0)). rewrite CRplus_0_r. apply BinarySubdivInside. apply CRlt_asym, ltab. exact l0. apply CRplus_le_compat_l. apply CRmult_le_0_compat. apply CRlt_asym, CRlt_minus, ltab. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. apply CRlt_asym, ltab. - destruct s0. subst j. rewrite BinarySubdivRight. 2: apply CRlt_asym, ltab. destruct (le_lt_dec (2^n) i). + unfold BinarySubdiv. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- (CRmult_comm (b-a)), <- (CRmult_1_r (-a+b)). rewrite CRmult_assoc, <- CRmult_plus_distr_l, CRplus_comm. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. rewrite <- (CRmult_1_l (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n)). rewrite <- CRmult_plus_distr_r. apply (CRmult_le_reg_r (CRpow (CR_of_Q _ (Z.of_nat 2 # 1)) n)). apply CRpow_gt_zero. apply CR_of_Q_pos. reflexivity. rewrite CRmult_1_l, CRmult_assoc, CRpow_mult. rewrite (CRpow_proper (CR_of_Q (RealT (ElemFunc IS)) (/ 2) * CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat 2 # 1)) 1). rewrite CRpow_one, <- pow_nat, CRmult_1_r. rewrite <- CR_of_Q_plus. apply CR_of_Q_le. unfold Qplus, Qle, Qnum, Qden. do 4 rewrite Z.mul_1_r. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. apply Nat2Z.inj_le. apply (Nat.le_trans _ i _ l1). rewrite Nat.add_comm. apply le_S, Nat.le_refl. reflexivity. rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. reflexivity. + exfalso. pose proof (CRlt_trans _ _ _ c1 c0). apply (StepApproxDiscretizeRefineDecr f fInt a b eta aPos ltab aeta beta n (2^S n) (S i)). 2: exact H. unfold lt in l1. apply Nat.mul_le_mono_nonneg_l. apply Nat.le_0_l. exact l1. + pose proof (CRlt_trans _ _ _ c1 c0) as H. (* Integral on [BinarySubdiv a b (S n) j, BinarySubdiv a b (S n) (S j)] lower than integral on [BinarySubdiv a b n (i-1), BinarySubdiv a b n i] *) destruct (le_lt_dec (2*S i) j). * exfalso. exact (StepApproxDiscretizeRefineDecr f fInt a b eta aPos ltab aeta beta n j (S i) l1 H). * unfold BinarySubdiv. rewrite CRplus_assoc. apply CRplus_le_compat_l. do 2 rewrite <- (CRmult_comm (b-a)), CRmult_assoc. rewrite <- CRmult_plus_distr_l. rewrite <- (CRmult_1_l (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n)). rewrite <- CRmult_plus_distr_r. simpl (CRpow (CR_of_Q (RealT (ElemFunc IS)) (/ 2)) (S n)). apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRpow_ge_zero. apply CR_of_Q_le. discriminate. rewrite <- CR_of_Q_plus, <- CR_of_Q_mult. apply CR_of_Q_le. apply Qle_shift_div_r. reflexivity. unfold Qplus, Qmult, Qle, Qnum, Qden. do 4 rewrite Z.mul_1_r. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add. 2: reflexivity. replace 2%Z with (Z.of_nat 2). rewrite <- Nat2Z.inj_mul. 2: reflexivity. apply Nat2Z.inj_le. apply le_S_n. apply (Nat.le_trans _ _ _ l1). rewrite (Nat.mul_comm (i+1)). apply le_S. rewrite Nat.add_comm. apply Nat.le_refl. Qed. Lemma FindCrossingPointThreasholdDecr : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b eta alpha gamma : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (aeta : 0 < a - eta < a) (beta : 0 < b < b + eta) (n i j : nat), alpha <= gamma -> ((i <= 2 ^ n)%nat * ((i = (2 ^ n)%nat) + (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n (S i) < alpha)) * (alpha < StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n i)) -> ((j <= 2 ^ n)%nat * ((j = (2 ^ n)%nat) + (StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n (S j) < gamma)) * (gamma < StepApproxDiscretize f fInt a b eta aPos ltab aeta beta n j)) -> le j i. Proof. intros. destruct H0, H1, p, p0. destruct s, s0. - subst i. rewrite e0. apply Nat.le_refl. - subst i. exact l0. - subst j. clear l0. apply (CRlt_le_trans _ _ _ c1) in H. apply (CRlt_trans _ _ _ H) in c0. clear H c1 c. unfold StepApproxDiscretize in c0. destruct (2^n)%nat eqn:des. apply Nat.le_0_l. rewrite <- des. destruct (le_lt_dec (S (S n0)) (S n0)). exfalso. lia. destruct (le_lt_dec (S (S n0)) (S i)). + apply le_S_n in l1. pose proof (Nat.le_antisymm _ _ l l1). subst i. rewrite <- des. apply Nat.le_refl. + clear l0. apply le_S_n, le_S_n in l1. clear l. exfalso. apply (StepApproxIntegralIncr f fInt (BinarySubdiv a b n i) (BinarySubdiv a b n (S i)) (BinarySubdiv a b n n0) (BinarySubdiv a b n (S n0)) (BinarySubdivIncr a b n i (aPos, ltab)) (BinarySubdivIncr a b n n0 (aPos, ltab))). 3: exact c0. clear c0. apply CRplus_le_compat_l. do 2 rewrite CRmult_assoc. apply CRmult_le_compat_r. apply CRlt_asym, CRmult_lt_0_compat. apply CRlt_minus, ltab. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, l1. apply CRplus_le_compat_l. do 2 rewrite CRmult_assoc. apply CRmult_le_compat_r. apply CRlt_asym, CRmult_lt_0_compat. apply CRlt_minus, ltab. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_n_S, l1. - apply (CRlt_le_trans _ _ _ c1) in H. apply (CRlt_trans _ _ _ H) in c0. unfold StepApproxDiscretize in c0. destruct j. apply Nat.le_0_l. destruct (le_lt_dec (S (2 ^ n)) (S j)). exfalso. apply le_S_n in l1. lia. destruct (le_lt_dec (S (2 ^ n)) (S i)). apply le_S_n in l1. apply le_S_n in l2. exact (Nat.le_trans _ _ _ l1 l2). destruct (le_lt_dec (S j) i). exact l3. exfalso. apply (StepApproxIntegralIncr f fInt (BinarySubdiv a b n i) (BinarySubdiv a b n (S i)) (BinarySubdiv a b n j) (BinarySubdiv a b n (S j)) (BinarySubdivIncr a b n i (aPos, ltab)) (BinarySubdivIncr a b n j (aPos, ltab))). 3: exact c0. apply le_S_n in l3. apply CRplus_le_compat_l. do 2 rewrite CRmult_assoc. apply CRmult_le_compat_r. apply CRlt_asym, CRmult_lt_0_compat. apply CRlt_minus, ltab. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, l3. apply CRplus_le_compat_l. do 2 rewrite CRmult_assoc. apply CRmult_le_compat_r. apply CRlt_asym, CRmult_lt_0_compat. apply CRlt_minus, ltab. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, l3. Qed. Lemma diff_series_cv_maj : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (s : CRcarrier R), (* skip 0 *) (forall n:nat, CRabs R (un (S n) - un n) <= vn n) -> series_cv vn s -> { l : CRcarrier R & prod (CR_cv R un l) (l <= s + CRabs R (un O)) }. Proof. intros. destruct (series_cv_maj (fun n:nat => match n with | O => un O | S p => un n - un p end) (fun n:nat => match n with | O => CRabs R (un O) | S p => vn p end) (s + CRabs R (un O))) as [l lcv]. - intro n. destruct n. apply CRle_refl. apply H. - intro p. specialize (H0 p) as [n ncv]. exists (S n). intros. destruct i. exfalso; inversion H0. rewrite decomp_sum. simpl. unfold CRminus. rewrite CRplus_comm, CRopp_plus_distr, CRplus_assoc. rewrite <- (CRplus_assoc (-CRabs R (un O))), CRplus_opp_l, CRplus_0_l. rewrite CRplus_comm. apply ncv. apply le_S_n, H0. apply le_n_S, Nat.le_0_l. - exists l. split. 2: exact (snd lcv). apply (CR_cv_eq _ (CRsum (fun n : nat => match n with | 0%nat => un 0%nat | S p => un n - un p end))). + induction n. reflexivity. simpl. rewrite IHn. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + exact (fst lcv). Qed. Lemma StepApproxProofIrrel : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (s t : CRcarrier (RealT (ElemFunc IS))) (ltst ltst2 : 0 < s < t), Integral (StepApproxIntegrable f s t ltst fInt) == Integral (StepApproxIntegrable f s t ltst2 fInt). Proof. intros. apply IntegralExtensional. intros. simpl. destruct xdf, xdg. apply (CRmult_eq_reg_l (t-s)). right. apply CRlt_minus, ltst. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l, (CRmult_comm (t-s)). apply (CRmult_eq_reg_l (t-s)). right. apply CRlt_minus, ltst. rewrite <- CRmult_assoc, <- CRmult_assoc, CRinv_r, CRmult_1_l. rewrite CRmult_comm. rewrite (DomainProp f x d2 d), (DomainProp f x d1 d). rewrite (DomainProp f x d0 d). reflexivity. Qed. (* There are at most q+1 points with jumps bigger than epsilon, s0, ..., sq. To search jump points, we throw missiles from a to b with increasing speeds epsilon * (k / q), k=0..q Jump points are barriers that take down some of the missile speed, it will continue going towards b as long as it has positive speed. When there are no jump points (f = 0), all points sk's will be equal to b. *) Lemma FindJumpPointsFinite : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f) (a b alpha epsilon : CRcarrier (RealT (ElemFunc IS))) (aPos : 0 < a) (ltab : a < b) (epsPos : 0 < epsilon) (q : nat), alpha <= CR_of_Q _ (Z.of_nat q # 1) * epsilon -> q <> O -> StepApproxBound f fInt a b alpha (CRlt_asym a b ltab) -> { s : nat -> CRcarrier (RealT (ElemFunc IS)) | (s O == a) /\ (forall k:nat, le q k -> s k == b) /\ (forall k:nat, s k <= s (S k)) /\ (forall k:nat, StepApproxBoundOpen f fInt (s k) (s (S k)) epsilon) }. Proof. intros IS f fInt a b alpha epsilon aPos ltab epsPos q H qnz H0. destruct H0 as [ext c]. pose (StepApproxDiscretize f fInt a b (ext_eta ext) aPos ltab (left_ordered ext) (pair (CRlt_trans _ _ _ aPos ltab) (right_ordered ext))) as Fni. (* We define the q numbers sk as limits of sequences. *) (* Define the non-negative sequence of jumps *) (* pose (fun n i : nat => Fni n O - Fni n i) as Sni. *) destruct (CRuncountableDiag3 (fun n i k => (Fni n O - Fni n i) * CR_of_Q _ (Z.of_nat q # Pos.of_nat (S k))) _ alpha c) as [epsilonPrime H0]. destruct H0. assert (0 < epsilonPrime) as epsilonPrimePos. { apply (CRle_lt_trans _ (Integral (StepApproxIntegrable f (a - ext_eta ext) a (left_ordered ext) fInt) - Integral (StepApproxIntegrable f b (b + ext_eta ext) (IntExtRightPos ext (CRlt_asym a b ltab), right_ordered ext) fInt))). 2: apply p. apply (CRplus_le_reg_r ( Integral (StepApproxIntegrable f b (b + ext_eta ext) (IntExtRightPos ext (CRlt_asym a b ltab), right_ordered ext) fInt))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l. apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, ext. apply CRlt_asym, ltab. apply (CRle_trans _ b). apply CRlt_asym, ltab. apply CRlt_asym, ext. } assert (forall n k:nat, Fni n O - CR_of_Q _ (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime < Fni n O) as H0. { intros. apply (CRlt_le_trans _ (Fni n 0%nat - 0)). apply CRplus_lt_compat_l, CRopp_gt_lt_contravar. apply CRmult_lt_0_compat. apply CR_of_Q_pos. reflexivity. exact epsilonPrimePos. unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. } assert (forall n k i : nat, (Fni n 0%nat - CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime) ≶ (Fni n i)). { intros. apply (CRplus_appart_reg_r (CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (CRplus_appart_reg_l (-(Fni n i))). apply (CRapart_morph _ _ (CReq_refl _) _ (CR_of_Q _ (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. rewrite CRplus_comm. specialize (c0 n i k). apply (CRmult_appart_reg_l (CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat q # Pos.of_nat (S k)))). apply CR_of_Q_pos. destruct q. exfalso; exact (qnz (eq_refl O)). reflexivity. apply (CRapart_morph _ _ (CReq_refl _) _ epsilonPrime). rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.of_nat q # Pos.of_nat (S k)) * (Z.of_nat (S k) # Pos.of_nat q))%Q with 1%Q. rewrite CRmult_1_l. reflexivity. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_r, Z.mul_comm. rewrite Pos2Z.inj_mul. apply f_equal2. simpl (Z.of_nat (S k)). apply f_equal. rewrite Pos.of_nat_succ. reflexivity. destruct q. exfalso; exact (qnz (eq_refl O)). simpl (Z.of_nat (S q)). apply f_equal. rewrite Pos.of_nat_succ. reflexivity. rewrite CRmult_comm. destruct c0. right. exact c0. left. exact c0. } pose proof (fun (n k:nat) => FindCrossingPoint (Fni n) (2 ^ n) (* gives 2^n + 1 possible indices, as many as the numbers of points in the nth binary subdivision of [a,b] *) (Fni n O - CR_of_Q _ (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime) (fun i:nat => StepApproxDiscretizeDecr f fInt a b (ext_eta ext) aPos ltab (left_ordered ext) (pair (CRlt_trans _ _ _ aPos ltab) (right_ordered ext)) n i (S i) (le_S i i (Nat.le_refl i))) (H1 n k) (H0 n k)) as H2. clear H1. clear H0. pose (fun (n k:nat) => let (i,_) := H2 n k in BinarySubdiv a b n i) as snk. assert (forall n k:nat, CRabs _ (snk (S n) k - snk n k) <= (b-a) * CRpow (CR_of_Q _ (1#2)) n). { intros n k. unfold snk. destruct (H2 n k), (H2 (S n) k). apply CRabs_le. split. - pose proof (FindCrossingPointIncr f fInt a b (ext_eta ext) (Fni n O - CR_of_Q _ (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime) aPos ltab (left_ordered ext) (pair (CRlt_trans _ _ _ aPos ltab) (right_ordered ext)) _ _ _ p0 p1). apply (CRplus_le_reg_r (BinarySubdiv a b n x)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (CRplus_le_reg_l ((b - a) * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n)). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l, CRplus_comm. apply (CRle_trans _ _ _ H0). apply CRplus_le_compat_l. apply CRmult_le_compat_l. apply CRlt_asym, CRlt_minus, ltab. rewrite <- (CRmult_1_l (CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n)). simpl. apply CRmult_le_compat_r. apply CRpow_ge_zero, CRlt_asym, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. discriminate. - pose proof (FindCrossingPointDecr f fInt a b (ext_eta ext) (Fni n O - CR_of_Q _ (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime) aPos ltab (left_ordered ext) (pair (CRlt_trans _ _ _ aPos ltab) (right_ordered ext)) _ _ _ p0 p1). apply (CRplus_le_reg_r (BinarySubdiv a b n x)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. exact H0. } assert (series_cv (fun n : nat => (b - a) * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n) (CR_of_Q _ 2 * (b-a))). { apply (series_cv_eq (fun n : nat => CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n * (b-a))). intro n. apply CRmult_comm. apply series_cv_scale. apply GeoHalfTwo. } pose proof (fun (k:nat) => diff_series_cv_maj (fun n => snk n k) (fun n => (b - a) * CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) n) (CR_of_Q _ 2 * (b-a)) (fun n => H0 n k) H1). pose (fun k:nat => match k with | O => a (* necessary special case at a, because all missiles go to b when f=0 *) | S i => let (l,_) := H3 i in l end) as sk. exists sk. assert (forall k:nat, le q k -> sk k == b) as lastB. { intros. unfold sk. destruct k. exfalso. inversion H4. rewrite H5 in qnz. exact (qnz (eq_refl _)). destruct (H3 k) as [x p0]. destruct p0. clear c2. apply (CR_cv_unique (fun n : nat => snk n k) _ _ c1). clear c1 x. apply (CR_cv_eq _ (fun _ : nat => b)). 2: apply CR_cv_const. intro n. unfold snk. destruct (H2 n k). destruct p0, p0. destruct s. - rewrite e. rewrite BinarySubdivRight. reflexivity. apply CRlt_asym, ltab. - exfalso. clear c1. contradict c2. apply (CRle_trans _ (Fni n (S (2^n)))). 2: apply StepApproxDiscretizeDecr, le_n_S, l. apply (CRle_trans _ ( Fni n 0%nat - 1 * epsilonPrime)). apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply CRmult_le_compat_r. apply CRlt_asym, epsilonPrimePos. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. simpl (Z.of_nat (S k)). apply Pos2Z.pos_le_pos. rewrite Pos.of_nat_succ. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. exact H4. discriminate. exact qnz. rewrite CRmult_1_l. apply (CRplus_le_reg_r epsilonPrime). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (CRplus_le_reg_l (-Fni n (S (2^n)))). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm. destruct p. unfold Fni, StepApproxDiscretize. destruct (le_lt_dec (S (2 ^ n)) (S (2 ^ n))). rewrite (StepApproxProofIrrel f fInt _ _ (CRlt_trans 0 a b aPos ltab, right_ordered ext) (IntExtRightPos ext (CRlt_asym a b ltab), right_ordered ext) ). apply CRlt_asym, c1. exfalso; exact (proj1 (Nat.lt_nge _ _) l0 (Nat.le_refl _)). } assert (forall k : nat, sk k <= sk (S k)) as skIncr. { unfold sk. intros k. destruct k. - destruct (H3 O). apply (CR_cv_bound_down (fun n : nat => snk n 0%nat) _ _ O). intros. unfold snk. destruct (H2 n O). apply BinarySubdivInside. apply CRlt_asym, ltab. apply (fst p1). exact (fst p0). - destruct (H3 k), (H3 (S k)). apply (CR_cv_le (fun n : nat => snk n k) (fun n : nat => snk n (S k))). 2: exact (fst p0). 2: exact (fst p1). intro n. unfold snk. destruct (H2 n k), (H2 n (S k)). apply CRplus_le_compat_l. rewrite CRmult_assoc, CRmult_assoc. apply CRmult_le_compat_r. apply CRmult_le_0_compat. apply CRlt_asym, CRlt_minus, ltab. apply CRpow_ge_zero. apply CRlt_asym, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le. apply (FindCrossingPointThreasholdDecr f fInt a b (ext_eta ext) (Fni n 0%nat - CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S (S k)) # Pos.of_nat q) * epsilonPrime) (Fni n 0%nat - CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime) aPos ltab (left_ordered ext) (CRlt_trans 0 a b aPos ltab, right_ordered ext) n). 2: exact p3. 2: exact p2. apply CRplus_le_compat_l, CRopp_ge_le_contravar. apply CRmult_le_compat_r. apply CRlt_asym, epsilonPrimePos. apply CR_of_Q_le. unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. discriminate. apply Nat2Z.inj_le. apply le_S, Nat.le_refl. } split. 2: split. 3: split. - reflexivity. - exact lastB. - exact skIncr. - (* No jumps between jump points. *) intros k x y u v ltxy ltuv H4 H5 H6. destruct (le_lt_dec q k) as [l | ltkq]. contradict H6. apply (CRle_trans _ b). apply lastB. apply le_S, l. apply (CRle_trans _ u). 2: apply CRlt_asym, (snd ltuv). apply (CRle_trans _ y). 2: exact H5. apply (CRle_trans _ x). 2: apply CRlt_asym, (snd ltxy). rewrite <- (lastB k). apply CRlt_asym, H4. exact l. assert (CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat 1 # Pos.of_nat q) * epsilonPrime < epsilon). { apply (CRmult_lt_reg_l (CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat q # 1))). apply CR_of_Q_pos. destruct q. exfalso; exact (qnz (eq_refl _)). reflexivity. apply (CRlt_le_trans _ alpha). 2: exact H. apply (CRle_lt_trans _ epsilonPrime). 2: exact (snd p). rewrite <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((Z.of_nat q # 1) * (Z.of_nat 1 # Pos.of_nat q))%Q with 1%Q. rewrite CRmult_1_l. apply CRle_refl. unfold Qmult, Qeq, Qnum, Qden. simpl. do 2 rewrite Z.mul_1_r. destruct q. exfalso; exact (qnz (eq_refl _)). simpl (Z.of_nat (S q)). apply f_equal. apply (Pos.of_nat_succ). } destruct (CR_cv_open_below (fun n => snk n k + (CRpow (CR_of_Q _ (1#2)) n)*(-(b-a))) v (sk (S k))) as [m mcv]. apply (CR_cv_proper _ (sk (S k) + 0)). 2: apply CRplus_0_r. apply CR_cv_plus. unfold sk. destruct (H3 k). exact (fst p0). apply (CR_cv_proper _ (0 * (-(b-a)))). apply CR_cv_scale. apply GeoCvZero. apply CRmult_0_l. exact H6. destruct k. + (* First segment, starting at a *) apply (CRle_trans _ (Fni m O - Fni m (let (i, _) := H2 m O in i))). unfold sk in H4. apply CRplus_le_compat. apply StepApproxIntegralIncr. apply (CRle_trans _ a). apply CRlt_asym, (snd (left_ordered ext)). apply CRlt_asym, H4. apply (CRle_trans _ x). apply CRlt_asym, H4. apply CRlt_asym, (snd ltxy). apply CRopp_ge_le_contravar. unfold Fni. specialize (mcv m (Nat.le_refl m)). unfold snk in mcv. destruct (H2 m O), p0, p0. unfold StepApproxDiscretize. destruct x0. exfalso. contradict mcv. apply (CRle_trans _ (a+0)). unfold BinarySubdiv. rewrite CRmult_0_l, CRmult_0_l, CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_0_l, <- CRopp_mult_distr_r, <- CRopp_0. apply CRopp_ge_le_contravar, CRmult_le_0_compat. apply CRpow_ge_zero. apply CRlt_asym, CR_of_Q_pos. reflexivity. apply CRlt_asym, CRlt_minus, ltab. rewrite CRplus_0_r. apply CRlt_asym. apply (CRlt_trans _ _ _ H4), (CRlt_trans _ _ _ (snd ltxy)). apply (CRle_lt_trans _ _ _ H5), (snd ltuv). destruct (le_lt_dec (S (2 ^ m)) (S x0)). exfalso. apply le_S_n in l0. exact (proj1 (Nat.lt_nge _ _) l l0). assert (v <= BinarySubdiv a b m x0). { apply (CRle_trans _ (BinarySubdiv a b m (S x0) + CRpow (CR_of_Q (RealT (ElemFunc IS)) (1 # 2)) m * - (b - a))). apply CRlt_asym, mcv. rewrite <- BinarySubdivNext. rewrite <- CRopp_mult_distr_r, CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_r. apply CRle_refl. } apply StepApproxIntegralIncr. clear l0 c1 s. apply (CRle_trans _ v). apply CRlt_asym, (snd ltuv). exact H8. apply (CRle_trans _ _ _ H8). apply CRplus_le_compat_l. rewrite CRmult_assoc, CRmult_assoc. apply CRmult_le_compat_r. apply CRmult_le_0_compat. apply CRlt_asym, CRlt_minus, ltab. apply CRpow_ge_zero. apply CRlt_asym, CR_of_Q_pos. reflexivity. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. destruct (H2 m O), p0, p0. apply (CRplus_le_reg_r (Fni m x0)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (CRplus_le_reg_r (- (CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat 1 # Pos.of_nat q) * epsilonPrime))). apply (CRle_trans _ (Fni m x0) _ (CRlt_asym _ _ c1)). rewrite (CRplus_comm epsilon), <- (CRplus_0_r (Fni m x0)). rewrite CRplus_assoc, CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_0_l. apply CRlt_asym, CRlt_minus, H7. + destruct (CR_cv_open_above (fun n => snk n k + (CRpow (CR_of_Q _ (1#2)) n)*(b-a)) x (sk (S k))) as [n ncv]. 2: exact H4. apply (CR_cv_proper _ (sk (S k) + 0)). 2: apply CRplus_0_r. apply CR_cv_plus. unfold sk. destruct (H3 k), p0. exact c1. apply (CR_cv_proper _ (0 * (b-a))). apply CR_cv_scale. apply GeoCvZero. apply CRmult_0_l. specialize (ncv (max n m) (Nat.le_max_l _ _)). specialize (mcv (max n m) (Nat.le_max_r _ _)). rewrite <- CRopp_mult_distr_r in mcv. apply (CRle_trans _ (Fni (max n m) (let (i,_) := H2 (max n m) k in S i) - Fni (max n m) (let (i, _) := H2 (max n m) (S k) in i))). * assert (forall i j:nat, le i j -> sk i <= sk j). { induction j. intros. inversion H8. apply CRle_refl. intros. apply Nat.le_succ_r in H8. destruct H8. apply (CRle_trans _ (sk j)). exact (IHj H8). apply skIncr. subst i. apply CRle_refl. } apply CRplus_le_compat. (* Interval [x,y] *) clear mcv. unfold Fni, StepApproxDiscretize. unfold snk in ncv. destruct (H2 (max n m) k) as [x0 p0]. destruct (le_lt_dec (S (2 ^ max n m)) (S x0)). destruct p0, p0. apply le_S_n in l. apply (Nat.le_antisymm _ _ l0) in l. subst x0. (* x0 = 2 ^ max n m *) clear l0 s c1. contradict ncv. apply (CRle_trans _ (b+0)). rewrite CRplus_0_r. apply (CRle_trans _ y _ (CRlt_asym _ _ (snd ltxy))). apply (CRle_trans _ u _ H5). apply (CRle_trans _ v _ (CRlt_asym _ _ (snd ltuv))). apply (CRle_trans _ _ _ (CRlt_asym _ _ H6)). apply (CRle_trans _ (sk q)). apply H8. exact ltkq. apply lastB. apply Nat.le_refl. rewrite BinarySubdivRight. apply CRplus_le_compat_l. apply CRlt_asym, CRmult_lt_0_compat. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CRlt_minus, ltab. apply CRlt_asym, ltab. rewrite BinarySubdivNext in ncv. apply StepApproxIntegralIncr. apply le_S_n in l. destruct p0, p0. clear l0. apply (CRle_trans _ (BinarySubdiv a b (max n m) (S x0))). apply CRlt_asym, BinarySubdivIncr. exact (pair aPos ltab). apply CRlt_asym, ncv. apply (CRle_trans _ x). apply CRlt_asym, ncv. apply CRlt_asym, (snd ltxy). (* Interval [u,v] *) clear ncv. apply CRopp_ge_le_contravar. unfold Fni, StepApproxDiscretize. unfold snk in mcv. destruct (H2 (max n m) (S k)), p0, p0. destruct x0. clear l c1. contradict mcv. apply (CRle_trans _ (a-0)). unfold BinarySubdiv, CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite CRmult_0_l, CRmult_0_l, CRplus_0_l. apply CRopp_ge_le_contravar. apply CRlt_asym, CRmult_lt_0_compat. apply CRpow_gt_zero, CR_of_Q_pos. reflexivity. apply CRlt_minus, ltab. unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply (CRle_trans _ (sk (S k))). apply (H8 O (S k)), Nat.le_0_l. apply (CRle_trans _ x _ (CRlt_asym _ _ H4)). apply (CRle_trans _ y _ (CRlt_asym _ _ (snd ltxy))). apply (CRle_trans _ u _ H5). apply CRlt_asym, (snd ltuv). destruct (le_lt_dec (S (2 ^ max n m)) (S x0)). apply le_S_n in l0. exfalso. exact (proj1 (Nat.lt_nge _ _) l l0). apply CRlt_asym in mcv. rewrite <- BinarySubdivNext, CRplus_assoc, CRplus_opp_r, CRplus_0_r in mcv. apply StepApproxIntegralIncr. apply (CRle_trans _ v _ (CRlt_asym _ _ (snd ltuv)) mcv). apply (CRle_trans _ _ _ mcv). apply CRlt_asym, BinarySubdivIncr. exact (pair aPos ltab). * destruct (H2 (max n m) k) as [x0 p0], (H2 (max n m) (S k)) as [x1 p1]. destruct p0, p1, p0, p1. destruct s. subst x0. apply (CRplus_le_reg_r (Fni (max n m) x1)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (CRle_trans _ (0 + Fni (max n m) x1)). rewrite CRplus_0_l. apply StepApproxDiscretizeDecr. apply le_S, l0. apply CRplus_le_compat_r. apply CRlt_asym, epsPos. apply (CRle_trans _ (Fni (Init.Nat.max n m) 0%nat - CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S k) # Pos.of_nat q) * epsilonPrime - (Fni (Init.Nat.max n m) 0%nat - CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S (S k)) # Pos.of_nat q) * epsilonPrime))). apply CRplus_le_compat. apply CRlt_asym, c3. apply CRopp_ge_le_contravar. apply CRlt_asym, c2. unfold CRminus. rewrite (CRplus_comm (Fni (max n m) O)), CRplus_assoc, CRopp_plus_distr. rewrite <- (CRplus_assoc (Fni (max n m) O)), CRplus_opp_r, CRplus_0_l. rewrite CRopp_involutive, CRopp_mult_distr_l. rewrite <- CRmult_plus_distr_r. apply (CRle_trans _ ((CR_of_Q _ (1 # Pos.of_nat q)) * epsilonPrime)). apply CRmult_le_compat_r. apply CRlt_asym, epsilonPrimePos. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_le. rewrite Qplus_comm, Qinv_minus_distr. unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. discriminate. destruct k. discriminate. 2: apply CRlt_asym, H7. rewrite (Z.add_le_mono_r _ _ (Z.of_nat (S (S k)))). ring_simplify. replace 1%Z with (Z.of_nat 1). rewrite <- Nat2Z.inj_add, Nat.add_comm. apply Z.le_refl. reflexivity. Qed. Lemma FindInterval {R : ConstructiveReals} (un : nat -> CRcarrier R) (x : CRcarrier R) (i j : nat) : (forall n:nat, un n <= un (S n)) -> (forall n:nat, CRapart R x (un n)) -> un i < x < un j -> { k : nat & un k < x < un (S k) }. Proof. intro uIncr. assert (forall b : nat, un O <= un b). { induction b. apply CRle_refl. apply (CRle_trans _ (un b) _ IHb). apply uIncr. } induction j. - intros. pose proof (CRlt_trans _ _ _ (fst H1) (snd H1)) as H3. contradict H3. apply H. - intros. specialize (IHj H0). destruct (H0 j). exact (IHj (pair (fst H1) c)). exists j. exact (pair c (snd H1)). Qed. Lemma IntervalOpenEta : forall {R : ConstructiveReals} (a b x : CRcarrier R), a < x < b -> { eta : CRcarrier R & prod (a < x-eta < x) (x < x+eta < b) }. Proof. intros. exists (CRmin (x-a) (b-x) * CR_of_Q R (1#2)). split. split. apply (CRplus_lt_reg_r (CRmin (x - a) (b - x) * CR_of_Q R (1 # 2))). apply (CRlt_le_trans _ x). 2: unfold CRminus; rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r; apply CRle_refl. apply (CRplus_lt_reg_l R (-a)). apply (CRle_lt_trans _ (CRmin (x - a) (b - x) * CR_of_Q R (1 # 2))). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply CRle_refl. apply (CRlt_le_trans _ (CRmin (x + - a) (b + - x) * 1)). 2: rewrite CRmult_1_r, CRplus_comm; apply CRmin_l. apply CRmult_lt_compat_l. apply CRmin_lt. apply CRlt_minus, (fst H). apply CRlt_minus, (snd H). apply CR_of_Q_lt. reflexivity. apply (CRlt_le_trans _ (x+0)). apply CRplus_lt_compat_l. rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. apply CRmult_lt_0_compat. apply CRmin_lt. apply CRlt_minus. exact (fst H). apply CRlt_minus. exact (snd H). apply CR_of_Q_pos. reflexivity. rewrite CRplus_0_r. apply CRle_refl. split. apply (CRle_lt_trans _ (x+0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l. apply CRmult_lt_0_compat. apply CRmin_lt. apply CRlt_minus. exact (fst H). apply CRlt_minus. exact (snd H). apply CR_of_Q_pos. reflexivity. apply (CRplus_lt_reg_l R (-x)). apply (CRle_lt_trans _ (CRmin (x - a) (b - x) * CR_of_Q R (1 # 2))). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply CRle_refl. apply (CRle_lt_trans _ ((b - x) * CR_of_Q R (1 # 2))). apply CRmult_le_compat_r. apply CR_of_Q_le. discriminate. apply CRmin_r. apply (CRlt_le_trans _ ((b-x)*CR_of_Q _ 1)). apply CRmult_lt_compat_l. apply CRlt_minus. exact (snd H). apply CR_of_Q_lt. reflexivity. rewrite CRplus_comm, <- (CRmult_1_r (b + - x)). apply CRle_refl. Qed. Lemma FindJumpPointsCountable : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), { s : nat -> CRcarrier (RealT (ElemFunc IS)) & forall x, 0 < x -> (forall n:nat, CRapart _ x (s n)) -> (forall eps, 0 < eps -> StepApproxBound f fInt x x eps (CRle_refl x)) }. Proof. intros. pose (fun (n:nat) => CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S n))) as an. pose (fun (n:nat) => CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (2+n) # 1)) as bn. assert (forall n:nat, an n < bn n) as ltabn. { intro n. unfold an, bn. apply (CRle_lt_trans _ (CR_of_Q _ 1)). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos.le_1_l. apply CR_of_Q_lt. unfold Qlt, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply (Nat2Z.inj_lt 1 (2+n)). apply le_n_S, le_n_S, Nat.le_0_l. } assert (forall n:nat, 0 < an n) as anPos. { intro n. apply CR_of_Q_pos. reflexivity. } assert (forall n:nat, 0 < an n - an n * CR_of_Q _ (1#2) < an n) as orderBefore. { split. apply (CRlt_le_trans _ (an n * CR_of_Q _ (1#2))). apply CRmult_lt_0_compat. exact (anPos n). apply CR_of_Q_pos. reflexivity. apply (CRplus_le_reg_r (an n * CR_of_Q (RealT (ElemFunc IS)) (1 # 2))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. setoid_replace ((1 # 2) + (1 # 2))%Q with 1%Q. rewrite CRmult_1_r. apply CRle_refl. reflexivity. apply (CRle_lt_trans _ (an n * CR_of_Q _ (1#2))). apply (CRplus_le_reg_r (an n * CR_of_Q (RealT (ElemFunc IS)) (1 # 2))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. setoid_replace ((1 # 2) + (1 # 2))%Q with 1%Q. rewrite CRmult_1_r. apply CRle_refl. reflexivity. rewrite <- (CRmult_1_r (an n)), CRmult_assoc. apply CRmult_lt_compat_l. exact (anPos n). rewrite CRmult_1_l. apply CR_of_Q_lt. reflexivity. } assert (forall n:nat, 0 < bn n < bn n + an n*CR_of_Q _ (1#2)) as orderAfter. { split. exact (CRlt_trans _ (an n) _ (anPos n) (ltabn n)). apply (CRle_lt_trans _ (bn n + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l. apply CRmult_lt_0_compat. exact (anPos n). apply CR_of_Q_pos. reflexivity. } pose (fun n:nat => Integral (StepApproxIntegrable f (an n - an n*CR_of_Q _ (1#2)) (an n) (orderBefore n) fInt)) as intBefore. pose (fun n:nat => Integral (StepApproxIntegrable f (bn n) (bn n + an n*CR_of_Q _ (1#2)) (orderAfter n) fInt)) as intAfter. pose (fun (n:nat) => let (k,_) := CRup_nat ((1+ intBefore n - intAfter n) * CRinv _ (CR_of_Q _ (1 # Pos.of_nat n)) (inr (CR_of_Q_pos (1 # Pos.of_nat n) (eq_refl _)))) in k) as qn. assert (forall n:nat, 1 + intBefore n - intAfter n <= CR_of_Q _ (Z.of_nat (qn n) # 1) * CR_of_Q _ (1 # Pos.of_nat n)). { intro n. unfold qn. destruct ( CRup_nat ((1 + intBefore n - intAfter n) * CRinv (RealT (ElemFunc IS)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat n)) (inr (CR_of_Q_pos (1 # Pos.of_nat n) eq_refl)))). apply CRlt_asym in c. apply (CRmult_le_compat_r (CR_of_Q _ (1 # Pos.of_nat n))) in c. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in c. exact c. apply CR_of_Q_le. discriminate. } assert (forall n:nat, intAfter n <= intBefore n) as orderInt. { intro n. apply (StepApproxIntegralIncr f fInt (an n - an n * CR_of_Q _ (1 # 2)) (an n) (bn n) (bn n + an n * CR_of_Q _ (1 # 2)) (orderBefore n) (orderAfter n)). apply (CRle_trans _ (an n)). apply CRlt_asym, orderBefore. apply CRlt_asym, ltabn. apply (CRle_trans _ (bn n + 0)). rewrite CRplus_0_r. apply CRlt_asym, ltabn. apply CRplus_le_compat_l. apply CRlt_asym, CRmult_lt_0_compat. exact (anPos n). apply CR_of_Q_pos. reflexivity. } assert (forall n:nat, qn n <> O) as qnz. { intro n. unfold qn. destruct ( CRup_nat ((1 + intBefore n - intAfter n) * CRinv (RealT (ElemFunc IS)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat n)) (inr (CR_of_Q_pos (1 # Pos.of_nat n) eq_refl)))). apply CRlt_asym in c. intro abs. rewrite abs in c. apply (CRmult_le_compat_r (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat n))) in c. rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_0_l in c. apply (CRplus_le_compat _ _ _ _ (orderInt n)) in c. rewrite CRplus_comm in c. unfold CRminus in c. rewrite CRplus_assoc, CRplus_assoc, CRplus_opp_l, CRplus_comm in c. rewrite CRplus_assoc in c. apply CRplus_le_reg_l in c. rewrite CRplus_0_l in c. apply c. apply CRzero_lt_one. apply CR_of_Q_le. discriminate. } assert (forall n:nat, bn n < bn n + an n*CR_of_Q _ (1#2)). { intro n. apply (CRle_lt_trans _ (bn n + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l. apply CRmult_lt_0_compat. exact (anPos n). apply CR_of_Q_pos. reflexivity. } assert (forall n : nat, StepApproxBound f fInt (an n) (bn n) (1 + intBefore n - intAfter n) (CRlt_asym (an n) (bn n) (ltabn n)) ) as intBound. { intro n. exists (Build_IntervalExtension _ _ _ _ (orderBefore n) (H0 n)). simpl. apply (CRle_lt_trans _ (intBefore n - intAfter n)). apply CRplus_le_compat. unfold intBefore. apply StepApproxIntegralIncr. apply CRle_refl. apply CRle_refl. unfold intAfter. apply CRopp_ge_le_contravar, StepApproxIntegralIncr. apply CRle_refl. apply CRle_refl. rewrite <- (CRplus_0_l (intBefore n - intAfter n)). unfold CRminus. rewrite CRplus_assoc. apply CRplus_lt_compat_r, CRzero_lt_one. } pose proof (fun (n:nat) => FindJumpPointsFinite f fInt (an n) (bn n) (1 + intBefore n - intAfter n) (CR_of_Q _ (1 # Pos.of_nat n)) (anPos n) (ltabn n) (CR_of_Q_pos (1 # Pos.of_nat n) (eq_refl _)) (qn n) (H n) (qnz n) (intBound n)). exists (diagSeq (fun n k => let (s,_) := H1 n in s k)). intros. assert (forall n k : nat, CRapart _ x (let (s, _) := H1 n in s k)). { intros. specialize (H3 (diagPlane n k)). unfold diagSeq in H3. rewrite diagPlaneInject in H3. exact H3. } clear H3. destruct (CRup_nat (CRinv _ eps (inr H4))) as [n nmaj]. (* Locate x in an open interval ]an p, bn p[ with n <= p *) assert (CR_cv _ an 0) as stepCv. { unfold an. intro p. exists (Pos.to_nat p). intros. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRabs_right. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (Nat.le_trans _ _ _ H3). apply le_S, Nat.le_refl. discriminate. apply CR_of_Q_le. discriminate. } destruct (CR_cv_open_above an x 0 stepCv H2) as [i imaj]. destruct (CRup_nat x) as [j jmaj]. specialize (imaj (max n (max i j)) (Nat.le_trans _ _ _ (Nat.le_max_l i j) (Nat.le_max_r _ _))). specialize (H5 (max n (max i j))). destruct (H1 (max n (max i j))) as [s a0], a0, H6, H7. (* Locate x in an open interval ]s k, s (k+1)[ *) destruct (FindInterval s x O (qn (max n (max i j))) H7 H5) as [k kmaj]. split. rewrite H3. exact imaj. rewrite H6. apply (CRlt_le_trans _ _ _ jmaj). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le. apply (Nat.le_trans _ (2+j)). apply le_S, le_S, Nat.le_refl. apply le_n_S, le_n_S. exact (Nat.le_trans _ _ _ (Nat.le_max_r i _) (Nat.le_max_r _ _)). apply Nat.le_refl. destruct (IntervalOpenEta (s k) (s (S k)) x kmaj) as [eta etamaj]. destruct etamaj. assert (0 < x - eta < x). { split. 2: exact (snd p). apply (CRle_lt_trans _ (s k)). 2: exact (fst p). apply (CRle_trans _ (s O)). rewrite H3. apply CRlt_asym, anPos. apply growing_transit. exact H7. apply Nat.le_0_l. } exists (Build_IntervalExtension _ _ _ _ H9 (fst p0)). simpl. apply (CRle_lt_trans _ (CR_of_Q _ (1 # Pos.of_nat n))). specialize (H8 k (x - eta) x x (x + eta) H9). apply (CRle_trans _ (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (max n (max i j))))). apply H8. 2: exact (CRle_refl x). exact (fst p). exact (snd p0). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. rewrite Nat2Pos.inj_max. apply Pos.le_max_l. apply (CRmult_lt_compat_l eps) in nmaj. rewrite CRinv_r in nmaj. destruct n. exfalso. rewrite CRmult_0_r in nmaj. contradict nmaj. apply CRlt_asym, CRzero_lt_one. apply (CRmult_lt_reg_r (CR_of_Q (RealT (ElemFunc IS)) (Z.of_nat (S n) # 1))). apply CR_of_Q_pos. reflexivity. rewrite <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S n)) * (Z.of_nat (S n) # 1))%Q with 1%Q. exact nmaj. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_l, Z.mul_1_l, Z.mul_1_r, Pos.mul_1_r. simpl (Z.of_nat (S n)). apply f_equal. rewrite Pos.of_nat_succ. reflexivity. exact H4. Qed. (* The main theorem of profiles : inverse images are integrable except possibly on a countable set of points. *) Lemma InverseImageIntegrableAE : forall {IS : IntegrationSpace} (f : PartialFunction (X (ElemFunc IS))) (fInt : IntegrableFunction f), { s : nat -> CRcarrier (RealT (ElemFunc IS)) & forall t (tPos : 0 < t), (forall n:nat, CRapart _ t (s n)) -> { limInt : IntegrableSet (fun x => exists xD:Domain f x, t <= partialApply f x xD) & CR_cv _ (fun n:nat => Integral (StepApproxIntegrable f _ t (StepApproxBetween t tPos n) fInt)) (MeasureSet limInt) } }. Proof. intros. destruct (FindJumpPointsCountable f fInt). exists x. intros. apply (InverseImageIntegrableGivenLimit f fInt t tPos). apply StepApproxBoundCv. apply (s t tPos H). Qed. (* In any integration space, construct a subset of positive measure. *) Lemma IoneValSplit : forall {IS : IntegrationSpace}, { nk : prod nat nat & I IS (XminConst (Xabs (Ione IS)) (CR_of_Q _ (1# Pos.of_nat (S (snd nk))))) (LminConstStable (CR_of_Q _ (1# Pos.of_nat (S (snd nk)))) (Xabs (Ione IS)) (invSuccRealPositive (snd nk)) (LabsStable (ElemFunc IS) (Ione IS) (IoneL IS))) < I IS (XminConst (Xabs (Ione IS)) (INR (2 + (fst nk)))) (LminIntStable (2 + (fst nk)) (Xabs (Ione IS)) (LabsStable _ _ (IoneL IS))) }. Proof. intro IS. assert (0 < I IS (Xabs (Ione IS)) (LabsStable _ _ (IoneL IS))). { apply (CRlt_le_trans _ 1). apply CRzero_lt_one. rewrite <- IoneInt. apply INonDecreasing. intros. simpl. rewrite (DomainProp _ x xF y). apply CRle_abs. } pose proof (Ilimit IS (Ione IS) (IoneL IS)) as [_ lowInt]. pose proof (CR_cv_open_above _ _ _ lowInt H) as [k kmaj]. specialize (kmaj k (Nat.le_refl k)). pose proof (Ilimit IS (Xabs (Ione IS)) (LabsStable _ _ (IoneL IS))) as [highInt _]. pose proof (CR_cv_open_below _ _ _ highInt kmaj) as [n nmaj]. exists (pair n k). apply nmaj. unfold fst. apply le_S, le_S, Nat.le_refl. Qed. Record PositiveMeasureSubset {IS : IntegrationSpace} := { pms_subset : X (ElemFunc IS) -> Prop; pms_int : IntegrableSet pms_subset; pms_pos : 0 < MeasureSet pms_int; }. Lemma StepApproxMax : forall {R : ConstructiveReals} (c s2 t2 : CRcarrier R) (ltst2 : s2 < t2), s2 <= t2 -> CRinv R (t2 - s2) (inr (CRlt_minus s2 t2 ltst2)) * (CRmin c t2 + - CRmin c s2) <= 1. Proof. intros. apply (CRmult_le_reg_l (t2-s2)). apply CRlt_minus, ltst2. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l, CRmult_1_r. apply (CRle_trans _ _ _ (CRle_abs _)). rewrite CRmin_sym, (CRmin_sym c s2). apply (CRle_trans _ _ _ (CRmin_contract _ _ _)). rewrite CRabs_right. apply CRle_refl. apply CRlt_asym, CRlt_minus, ltst2. Qed. Lemma PositiveMeasureSubsetExists : forall (IS : IntegrationSpace), @PositiveMeasureSubset IS. Proof. intro IS. destruct (@IoneValSplit IS) as [[n k] H]. unfold fst, snd in H. assert (1 # Pos.of_nat (S k) < Z.of_nat (2 + n) # 1)%Q. { unfold Qlt, Qnum, Qden. rewrite Z.mul_1_l. apply (Z.lt_le_trans _ (Z.of_nat (2+n)*1)). rewrite Z.mul_1_r. replace 1%Z with (Z.of_nat 1). apply Nat2Z.inj_lt. apply le_n_S, le_n_S, Nat.le_0_l. reflexivity. apply Z.mul_le_mono_nonneg_l. discriminate. apply Pos2Z.pos_le_pos. apply Pos.le_1_l. } pose proof (InverseImageIntegrableAE (Xabs (Ione IS)) (IntegrableL _ (LabsStable _ _ (IoneL IS)))) as [s sint]. assert (0 < CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k)) < INR (2 + n)). { split. apply CR_of_Q_pos. reflexivity. apply CR_of_Q_lt. exact H0. } destruct (CRuncountable s 0 (CR_of_Q _ (1 # Pos.of_nat (S k))) (fst H1)) as [t tap]. destruct tap. specialize (sint t (fst p) c). destruct sint. assert (0 < MeasureSet x). { apply (CRlt_le_trans _ (Integral (StepApproxIntegrable (Xabs (Ione IS)) (CR_of_Q _ (1 # Pos.of_nat (S k))) (INR (2 + n)) H1 (IntegrableL _ (LabsStable _ _ (IoneL IS)))))). unfold StepApproxIntegrable. rewrite (IntegralScale (Xminus (XminConst (Xabs (Ione IS)) (INR (2 + n))) (XminConst (Xabs (Ione IS)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k))))) _ (CRinv (RealT (ElemFunc IS)) (INR (2 + n) - CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k))) (inr (CRlt_minus (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k))) (INR (2 + n)) (snd H1)))) ). apply CRmult_lt_0_compat. rewrite IntegralMinus. apply CRlt_minus. apply (CRle_lt_trans _ (Integral (IntegrableL _ (LminConstStable (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k))) (Xabs (Ione IS)) (invSuccRealPositive k) (LabsStable (ElemFunc IS) (Ione IS) (IoneL IS)))))). apply IntegralNonDecreasing. intros y ydf ydg. rewrite (DomainProp _ y ydf ydg). apply CRle_refl. rewrite IntegralLstable. apply (CRlt_le_trans _ _ _ H). apply (CRle_trans _ (Integral (IntegrableL _ (LminIntStable (2 + n) (Xabs (Ione IS)) (LabsStable (ElemFunc IS) (Ione IS) (IoneL IS)))))). rewrite IntegralLstable. apply CRle_refl. apply IntegralNonDecreasing. intros y ydf ydg. rewrite (DomainProp _ y ydf ydg). apply CRle_refl. apply CRinv_0_lt_compat, CRlt_minus, CR_of_Q_lt. exact H0. apply IntegralNonDecreasing. intros y ydf ydg. simpl ( partialApply (CharacFunc (fun x0 : X (ElemFunc IS) => exists xD : Domain (Xabs (Ione IS)) x0, t <= partialApply (Xabs (Ione IS)) x0 xD)) y ydg). destruct ydg. - unfold StepApprox. rewrite applyXscale. destruct ydf. rewrite (applyXminus _ (XminConst (Xabs (Ione IS)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k))))). do 2 rewrite applyXminConst. rewrite (DomainProp (Xabs (Ione IS)) y d0 d). apply StepApproxMax. apply CRlt_asym, CR_of_Q_lt. exact H0. - destruct (CRltLinear (RealT (ElemFunc IS))). destruct ydf. destruct (s0 t (partialApply (Xabs (Ione IS)) y d0) (CR_of_Q _ (1 # Pos.of_nat (S k))) (snd p)). exfalso. apply n0. exists d0. apply CRlt_asym, c1. unfold StepApprox. rewrite applyXscale. apply (CRmult_le_reg_l (INR (2 + n) - CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k)))). apply CRlt_minus, CR_of_Q_lt. exact H0. rewrite <- CRmult_assoc, CRinv_r, CRmult_0_r, CRmult_1_l. rewrite (applyXminus _ (XminConst (Xabs (Ione IS)) (CR_of_Q (RealT (ElemFunc IS)) (1 # Pos.of_nat (S k))))). do 2 rewrite applyXminConst. rewrite (DomainProp (Xabs (Ione IS)) y d d0). unfold CRminus. rewrite CRmin_left, CRmin_left, CRplus_opp_r. apply CRle_refl. apply CRlt_asym, c1. apply CRlt_asym. apply (CRlt_trans _ _ _ c1). apply CR_of_Q_lt. exact H0. } exact (Build_PositiveMeasureSubset IS _ x H2). Qed. corn-8.20.0/reals/stdlib/ConstructiveCauchyIntegral.v000066400000000000000000004253621473720167500226630ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* The Cauchy integral of uniformly continuous functions R -> R. It is the simplest integration theory, and the one used in the proof of the Picard-Lindelhöf theorem. The Cauchy integral approximates uniformly continuous functions by histograms, which widths tend to 0. In other words, it is the proof that sequences of rectangles integrate continuous functions. *) From Coq Require Import List Permutation Orders Sorted Mergesort. From Coq Require Import ZArith QArith Qpower. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructiveLimits. From Coq Require Import ConstructiveRcomplete. Require Import ConstructiveDiagonal. Require Import ConstructiveUniformCont. Local Open Scope ConstructiveReals. (* Elementary theory of integration for the uniformly continuous functions. To integrate discontinuous functions, the full constructive measure theory will be developped later. *) Record IntervalPartition {R : ConstructiveReals} {a b : CRcarrier R} : Set := { ipt_seq : nat -> CRcarrier R; ipt_last : nat; ipt_head : a == ipt_seq 0; ipt_lastB : b == ipt_seq (S ipt_last); ipt_ordered : forall n:nat, le n ipt_last -> ipt_seq n <= ipt_seq (S n); }. Lemma ipt_ordered_transit : forall {R : ConstructiveReals} (a b : CRcarrier R) (P : @IntervalPartition R a b) (n p : nat), le n p -> le p (S (ipt_last P)) -> ipt_seq P n <= ipt_seq P p. Proof. induction p. - intros. inversion H. apply CRle_refl. - intros. apply Nat.le_succ_r in H. destruct H. + apply (CRle_trans _ (ipt_seq P p)). apply (IHp H). apply (Nat.le_trans _ (ipt_last P)). apply le_S_n. exact H0. apply le_S, Nat.le_refl. apply P. apply le_S_n. exact H0. + subst n. apply CRle_refl. Qed. Fixpoint PartitionMesh {R : ConstructiveReals} (points : nat -> CRcarrier R) (len : nat) : CRcarrier R := match len with | O => 0 | S l => CRmax (points len - points l) (PartitionMesh points l) end. Lemma PartitionMesh_ext : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (len : nat), (forall n:nat, le n len -> un n == vn n) -> PartitionMesh un len == PartitionMesh vn len. Proof. induction len. - intros. reflexivity. - intros. simpl. rewrite IHlen. rewrite (H (S len)), (H len). reflexivity. apply le_S, Nat.le_refl. apply Nat.le_refl. intros. apply H. apply le_S, H0. Qed. Lemma PartitionMesh_nonneg : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (n : nat), 0 <= PartitionMesh xn n. Proof. induction n. apply CRle_refl. simpl. apply (CRle_trans _ _ _ IHn), CRmax_r. Qed. Lemma AllIntervalsSmallerThanMesh : forall {R : ConstructiveReals} (a b : CRcarrier R) (P : @IntervalPartition R a b) (n : nat), le n (ipt_last P) -> ipt_seq P (S n) - ipt_seq P n <= PartitionMesh (ipt_seq P) (S (ipt_last P)). Proof. intros. destruct P; unfold ipt_seq, ipt_last; simpl in H. clear ipt_lastB0 b. generalize dependent ipt_last0. induction ipt_last0. - intros. inversion H. apply CRmax_l. - intros. assert (forall n : nat, le n ipt_last0 -> (ipt_seq0 n <= ipt_seq0 (S n))). { intros. apply ipt_ordered0. apply (Nat.le_trans _ ipt_last0 _ H0). apply le_S, Nat.le_refl. } specialize (IHipt_last0 H0). apply Nat.le_succ_r in H. destruct H. + specialize (IHipt_last0 H). apply (CRle_trans _ _ _ IHipt_last0). apply CRmax_r. + rewrite <- H. apply CRmax_l. Qed. Definition IntegralFiniteSum {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (x partition : nat -> CRcarrier R) (last : nat) : CRcarrier R := CRsum (fun n:nat => f (x n) * (partition (S n) - partition n)) last. Definition WeavedLists {R : ConstructiveReals} (x partition : nat -> CRcarrier R) (last : nat) : Prop := forall n:nat, le n last -> (partition n <= x n /\ x n <= partition (S n)). Definition IntervalPartitionRefinement {R : ConstructiveReals} (a b : CRcarrier R) (small big : @IntervalPartition R a b) (subseq : nat -> nat) : Prop := (forall n:nat, le n (S (ipt_last small)) -> ipt_seq big (subseq n) == ipt_seq small n) /\ (forall n p:nat, n < p -> p <= S (ipt_last small) -> subseq n < subseq p)%nat /\ (forall n:nat, n <= S (ipt_last small) -> subseq n <= S (ipt_last big))%nat. Lemma in_refinement_packet : forall {R : ConstructiveReals} (a b : CRcarrier R) (n i : nat) (x y : nat -> CRcarrier R) (P Q : @IntervalPartition R a b) (subseq : nat -> nat), WeavedLists x (ipt_seq P) (ipt_last P) -> WeavedLists y (ipt_seq Q) (ipt_last Q) -> IntervalPartitionRefinement _ _ P Q subseq -> le n (ipt_last P) -> le (subseq n) i -> lt i (subseq (S n)) (* i = S n can overflow in the last packet *) -> CRabs _ (x n - y i) <= PartitionMesh (ipt_seq P) (S (ipt_last P)). Proof. intros. assert (ipt_seq P n <= y i /\ y i <= ipt_seq P (S n)). { specialize (H0 i). split. apply (CRle_trans _ (ipt_seq Q i)). apply (CRle_trans _ (ipt_seq Q (subseq n))). destruct H1. rewrite H1. apply CRle_refl. apply (Nat.le_trans _ _ _ H2). apply le_S, Nat.le_refl. apply ipt_ordered_transit. exact H3. destruct H1. apply (Nat.le_trans _ (subseq (S n))). apply (Nat.le_trans _ (S i)). apply le_S, Nat.le_refl. exact H4. apply H5. apply le_n_S. exact H2. apply H0. destruct H1. apply le_S_n. apply (Nat.le_trans _ _ _ H4). apply H5, le_n_S, H2. apply (CRle_trans _ (ipt_seq Q (S i))). apply H0. apply le_S_n. apply (Nat.le_trans _ _ _ H4). destruct H1. apply H5, le_n_S, H2. destruct H1. apply (CRle_trans _ (ipt_seq Q (subseq (S n)))). apply ipt_ordered_transit. exact H4. apply H5, le_n_S, H2. rewrite H1. apply CRle_refl. apply le_n_S, H2. } apply (CRle_trans _ (ipt_seq P (S n) - ipt_seq P n)). apply Rsmaller_interval. apply H5. apply H5. apply H. exact H2. apply H. exact H2. apply AllIntervalsSmallerThanMesh. exact H2. Qed. Lemma partition_before_start : forall {R : ConstructiveReals} (a b : CRcarrier R) (P : @IntervalPartition R a b) (n : nat), le n (S (ipt_last P)) -> ipt_seq P n == a -> (forall p:nat, le p n -> ipt_seq P p == a). Proof. intros. pose proof (ipt_ordered_transit a b P). destruct P; unfold ipt_seq; simpl in H,H0,H2. split. - fold (a <= ipt_seq0 p). rewrite ipt_head0. apply H2. apply Nat.le_0_l. apply (Nat.le_trans _ _ _ H1). exact H. - intro abs. rewrite <- H0 in abs. apply (H2 p n). exact H1. exact H. exact abs. Qed. Lemma partition_after_end : forall {R : ConstructiveReals} (a b : CRcarrier R) (P : @IntervalPartition R a b) (n : nat), ipt_seq P n == b -> (forall p:nat, le n p -> le p (S (ipt_last P)) -> ipt_seq P p == b). Proof. intros. pose proof (ipt_ordered_transit a b P). destruct P; unfold ipt_seq; simpl in H,H1,H2. split. - fold (b <= ipt_seq0 p). rewrite <- H. apply H2. exact H0. exact H1. - fold (ipt_seq0 p <= b). rewrite ipt_lastB0. apply H2. exact H1. apply Nat.le_refl. Qed. (* Sum on the refined partition, either grouped or not. *) Lemma partition_sum_by_packets : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (y : nat -> CRcarrier R) (P Q : @IntervalPartition R a b) (subseq : nat -> nat), IntervalPartitionRefinement _ _ P Q subseq -> CRsum (fun n : nat => CRsum (fun i : nat => (f (y (i + subseq n)%nat) * (ipt_seq Q (S i + subseq n) - ipt_seq Q (i + subseq n)))) (pred (subseq (S n) - subseq n))) (ipt_last P) == CRsum (fun n : nat => (f (y n) * (ipt_seq Q (S n) - ipt_seq Q n))) (ipt_last Q). Proof. intros. destruct H, H0. (* Get rid of the last points equal to b *) transitivity (CRsum (fun n : nat => (f (y n) * (ipt_seq Q (S n) - ipt_seq Q n))) (pred (subseq (S (ipt_last P))))). (* Get rid of the first points equal to a *) pose (fun n:nat => match n with O => O | S p => subseq n end) as shiftSubseq. transitivity ( CRsum (fun n0 : nat => CRsum (fun i : nat => (f (y (i + shiftSubseq n0)%nat) * (ipt_seq Q (S i + shiftSubseq n0) - ipt_seq Q (i + shiftSubseq n0)))) (pred (shiftSubseq (S n0) - shiftSubseq n0))) (ipt_last P)). - apply CRsum_eq. intros. destruct i. 2: apply CRsum_eq; reflexivity. unfold shiftSubseq. destruct (Nat.le_exists_sub (S (subseq O)) (subseq 1%nat)) as [p [peq _]]. apply H0. auto. apply le_n_S, Nat.le_0_l. rewrite Nat.sub_0_r. rewrite peq. rewrite Nat.add_succ_r. replace (S (p + subseq 0%nat) - subseq 0)%nat with (S p). simpl. destruct (subseq O) eqn:des. rewrite Nat.add_0_r. apply CRsum_eq; reflexivity. rewrite <- (Nat.add_comm (S n)). rewrite sum_assoc. symmetry. rewrite <- (CRplus_0_l (CRsum (fun i : nat => f (y (i + S n)%nat) * (ipt_seq Q (S (i + S n)) - ipt_seq Q (i + S n))) p)). apply CRplus_morph. rewrite (CRsum_eq _ (fun _ => 0 * 0)). rewrite sum_scale, CRmult_0_r. reflexivity. intros. rewrite CRmult_0_l. rewrite Nat.add_0_r. setoid_replace (ipt_seq Q (S i)) with a. setoid_replace (ipt_seq Q i) with a. unfold CRminus. rewrite CRplus_opp_r, CRmult_0_r. reflexivity. symmetry. rewrite (partition_before_start _ _ _ (subseq O)). reflexivity. apply H1, Nat.le_0_l. rewrite H. symmetry. apply P. apply Nat.le_0_l. rewrite des. apply (Nat.le_trans _ _ _ H3). apply le_S, Nat.le_refl. rewrite (partition_before_start _ _ _ (subseq O)). reflexivity. apply H1, Nat.le_0_l. rewrite H. symmetry. apply P. apply Nat.le_0_l. rewrite des. apply le_n_S. exact H3. apply CRsum_eq. intros. rewrite Nat.add_0_r, Nat.add_comm. reflexivity. rewrite Nat.sub_succ_l. apply f_equal. rewrite Nat.add_sub. reflexivity. rewrite <- (Nat.add_0_l (subseq O)). rewrite Nat.add_assoc. apply Nat.add_le_mono_r. apply Nat.le_0_l. - replace (pred (subseq (S (ipt_last P)))) with (pred (shiftSubseq (S (ipt_last P)))). apply (sum_by_packets (fun n : nat => (f (y n) * (ipt_seq Q (S n) - ipt_seq Q n)))). intros. unfold shiftSubseq. destruct k. apply (Nat.le_lt_trans _ (subseq O)). apply Nat.le_0_l. apply H0. auto. apply le_n_S. exact H2. apply H0. apply Nat.le_refl. apply le_n_S. exact H2. reflexivity. reflexivity. - destruct (Nat.le_exists_sub (subseq (S (ipt_last P))) (S (ipt_last Q))) as [p [peq _]]. apply H1. apply Nat.le_refl. destruct p. replace (Init.Nat.pred (subseq (S (ipt_last P)))) with (ipt_last Q). reflexivity. simpl in peq. rewrite <- peq. reflexivity. inversion peq. clear peq. assert (subseq (S (ipt_last P)) <> 0%nat). { intro abs. specialize (H0 (ipt_last P) (S (ipt_last P)) (Nat.le_refl _) (Nat.le_refl _)). rewrite abs in H0. inversion H0. } pose proof (Nat.succ_pred (subseq (S (ipt_last P))) H2). replace (ipt_last Q) with (S (pred (subseq (S (ipt_last P)))) + p)%nat. rewrite sum_assoc. symmetry. rewrite <- (CRplus_0_r (CRsum (fun n : nat => f (y n) * (ipt_seq Q (S n) - ipt_seq Q n)) (Init.Nat.pred (subseq (S (ipt_last P)))))). apply CRplus_morph. rewrite CRplus_0_r. reflexivity. rewrite (CRsum_eq _ (fun _ => 0 * 0)). rewrite sum_scale, CRmult_0_r. reflexivity. intros. rewrite CRmult_0_l. rewrite H4. setoid_replace (ipt_seq Q (S (subseq (S (ipt_last P)) + i))) with b. setoid_replace (ipt_seq Q (subseq (S (ipt_last P)) + i)) with b. unfold CRminus. rewrite CRplus_opp_r, CRmult_0_r. reflexivity. rewrite (partition_after_end _ _ _ (subseq (S (ipt_last P)))). reflexivity. rewrite H. symmetry. apply P. apply Nat.le_refl. rewrite <- (Nat.add_0_r (subseq (S (ipt_last P)))). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l, Nat.le_0_l. apply (Nat.le_trans _ (subseq (S (ipt_last P)) + p)). apply Nat.add_le_mono_l. exact H5. rewrite Nat.add_comm, H3. apply le_S, Nat.le_refl. rewrite (partition_after_end _ _ _ (subseq (S (ipt_last P)))). reflexivity. rewrite H. symmetry. apply P. apply Nat.le_refl. apply (Nat.le_trans _ (S (subseq (S (ipt_last P))))). apply le_S, Nat.le_refl. apply le_n_S. rewrite <- (Nat.add_0_r (subseq (S (ipt_last P)))). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l, Nat.le_0_l. apply le_n_S. apply (Nat.le_trans _ (subseq (S (ipt_last P)) + p)). apply Nat.add_le_mono_l. exact H5. rewrite Nat.add_comm, H3. apply Nat.le_refl. rewrite H4, H3. rewrite Nat.add_comm. reflexivity. Qed. Lemma UC_refine_integral : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b eps : CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (x y : nat -> CRcarrier R) (P Q : @IntervalPartition R a b) (epsPos : 0 < eps) (subseq : nat -> nat), UniformCont f cont_mod -> WeavedLists x (ipt_seq P) (ipt_last P) -> WeavedLists y (ipt_seq Q) (ipt_last Q) -> IntervalPartitionRefinement _ _ P Q subseq -> (PartitionMesh (ipt_seq P) (S (ipt_last P))) < (cont_mod eps epsPos) -> CRabs _ (IntegralFiniteSum f x (ipt_seq P) (ipt_last P) - IntegralFiniteSum f y (ipt_seq Q) (ipt_last Q)) <= eps * (b-a). Proof. (* Use subseq to make packets of summations *) intros. setoid_replace (IntegralFiniteSum f x (ipt_seq P) (ipt_last P) - IntegralFiniteSum f y (ipt_seq Q) (ipt_last Q)) with (CRsum (fun n:nat => f (x n) * (CRsum (fun i => ipt_seq Q (S i + subseq n) - ipt_seq Q (i + subseq n)) (pred (subseq (S n) - subseq n)))) (ipt_last P) - (CRsum (fun n:nat => CRsum (fun i => f (y (i + subseq n)%nat) * (ipt_seq Q (S i + subseq n) - ipt_seq Q (i + subseq n))) (pred (subseq (S n) - subseq n))) (ipt_last P))). - rewrite <- Rsum_minus. apply (CRle_trans _ _ _ (multiTriangleIneg _ _)). apply (CRle_trans _ (CRsum (fun k => eps * (ipt_seq P (S k) - ipt_seq P k)) (ipt_last P))). + apply sum_Rle. intros n H4. rewrite CRmult_comm, <- sum_scale, <- Rsum_minus. apply (CRle_trans _ _ _ (multiTriangleIneg _ _)). apply (CRle_trans _ (CRsum (fun k : nat => CRabs _ (f (x n) - f (y (plus k (subseq n)))) * (ipt_seq Q (S k + subseq n) - ipt_seq Q (k + subseq n))) (pred (subseq (S n) - subseq n)))). apply sum_Rle. intros. rewrite <- (CRmult_comm (f (x n))). unfold CRminus. rewrite CRopp_mult_distr_l. rewrite <- CRmult_plus_distr_r, CRabs_mult. apply CRmult_le_compat_l. apply CRabs_pos. rewrite CRabs_right. apply CRle_refl. rewrite <- (CRplus_opp_r (ipt_seq Q (k + subseq n))). apply CRplus_le_compat. 2: apply CRle_refl. apply ipt_ordered. apply le_S_n. apply le_n_S in H5. apply (Nat.le_trans _ (subseq (S n))). rewrite Nat.succ_pred in H5. rewrite Nat.add_comm. apply Nat.lt_add_lt_sub_l. exact H5. intro abs. destruct H2, H6. specialize (H6 n (S n) (Nat.le_refl _)). apply Nat.sub_0_le in abs. apply (proj1 (Nat.le_ngt _ _) abs). apply H6, le_n_S, H4. apply H2. apply le_n_S, H4. apply (CRle_trans _ (CRsum (fun k : nat => (ipt_seq Q (S k + subseq n) - ipt_seq Q (k + subseq n)) * eps) (Init.Nat.pred (subseq (S n) - subseq n)))). apply sum_Rle. intros n0 H5. rewrite CRmult_comm. apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r (ipt_seq Q (n0 + subseq n))). apply CRplus_le_compat. 2: apply CRle_refl. apply (ipt_ordered Q). apply le_n_S in H5. rewrite Nat.succ_pred in H5. apply le_S_n. apply (Nat.le_trans _ (subseq (S n))). rewrite Nat.add_comm. apply Nat.lt_add_lt_sub_l. exact H5. apply H2, le_n_S, H4. intro abs. destruct H2, H6. specialize (H6 n (S n) (Nat.le_refl _)). apply Nat.sub_0_le in abs. apply (proj1 (Nat.le_ngt _ _) abs). apply H6, le_n_S, H4. destruct H. apply CRlt_asym. apply (c0 eps _ _ epsPos). apply (CRle_lt_trans _ (PartitionMesh (ipt_seq P) (S (ipt_last P)))). 2: exact H3. apply (in_refinement_packet a b n (n0 + subseq n) x y P Q subseq H0 H1 H2 H4). apply le_n_S in H5. rewrite Nat.succ_pred in H5. apply (Nat.le_trans _ (0 + subseq n)). apply Nat.le_refl. apply Nat.add_le_mono_r. apply Nat.le_0_l. intro abs. destruct H2, H2. specialize (H2 n (S n) (Nat.le_refl _)). apply Nat.sub_0_le in abs. apply (proj1 (Nat.le_ngt _ _) abs). apply H2. apply le_n_S, H4. rewrite Nat.add_comm. apply Nat.lt_add_lt_sub_l. apply le_n_S in H5. rewrite Nat.succ_pred in H5. exact H5. intro abs. destruct H2, H2. specialize (H2 n (S n) (Nat.le_refl _)). apply Nat.sub_0_le in abs. apply (proj1 (Nat.le_ngt _ _) abs). apply H2. apply le_n_S, H4. rewrite sum_scale, CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, epsPos. rewrite (TelescopicSum (fun i => ipt_seq Q (i + subseq n))). simpl. replace (S (pred (subseq (S n) - subseq n) + subseq n)) with (subseq (S n)). destruct H2. rewrite H2. 2: apply le_n_S, H4. rewrite H2. apply CRle_refl. apply (Nat.le_trans _ _ _ H4). apply le_S, Nat.le_refl. replace (S (Init.Nat.pred (subseq (S n) - subseq n) + subseq n)) with (S (Init.Nat.pred (subseq (S n) - subseq n)) + subseq n)%nat. 2: reflexivity. rewrite Nat.succ_pred. rewrite Nat.sub_add. reflexivity. apply (Nat.le_trans _ (S (subseq n))). apply le_S, Nat.le_refl. apply H2. apply Nat.le_refl. apply le_n_S, H4. intro abs. destruct H2, H5. specialize (H5 n (S n) (Nat.le_refl _)). apply Nat.sub_0_le in abs. apply (proj1 (Nat.le_ngt _ _) abs), H5, le_n_S, H4. + rewrite (CRsum_eq _ (fun k : nat => (ipt_seq P (S k) - ipt_seq P k) * eps)). rewrite sum_scale, CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, epsPos. rewrite TelescopicSum. destruct P; simpl. rewrite <- ipt_lastB0, <- ipt_head0. apply CRle_refl. intros. rewrite CRmult_comm. reflexivity. - apply CRplus_morph. + apply CRsum_eq. intros. apply CRmult_morph. reflexivity. rewrite (TelescopicSum (fun n => ipt_seq Q (n + subseq i))). simpl. replace (S (pred (subseq (S i) - subseq i) + subseq i)) with (subseq (S i)). destruct H2. rewrite (H2 i). rewrite (H2 (S i)). reflexivity. apply le_n_S, H4. apply (Nat.le_trans _ _ _ H4), le_S, Nat.le_refl. replace (S (Init.Nat.pred (subseq (S i) - subseq i) + subseq i)) with (S (Init.Nat.pred (subseq (S i) - subseq i)) + subseq i)%nat. 2: reflexivity. rewrite Nat.succ_pred. rewrite Nat.sub_add. reflexivity. apply (Nat.le_trans _ (S (subseq i))). apply le_S, Nat.le_refl. apply H2. apply Nat.le_refl. apply le_n_S, H4. intro abs. destruct H2, H5. specialize (H5 i (S i) (Nat.le_refl _)). apply Nat.sub_0_le in abs. apply (proj1 (Nat.le_ngt _ _) abs), H5, le_n_S, H4. + unfold IntegralFiniteSum. rewrite partition_sum_by_packets. reflexivity. exact H2. Qed. Definition IntervalEquiPartition {R : ConstructiveReals} (a b : CRcarrier R) (last : nat) : a <= b -> @IntervalPartition R a b. Proof. intros. apply (Build_IntervalPartition R a b (fun n:nat => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last). setoid_replace (Z.of_nat 0 # Pos.of_nat (S last))%Q with 0%Q. rewrite CRmult_0_r, CRplus_0_r. reflexivity. reflexivity. setoid_replace (Z.of_nat (S last) # Pos.of_nat (S last))%Q with 1%Q. rewrite CRmult_1_r. unfold CRminus. rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_r. reflexivity. unfold Qeq, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. rewrite <- positive_nat_Z, Nat2Pos.id. reflexivity. discriminate. intros. apply CRplus_le_compat_l. apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact H. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. discriminate. apply Nat2Z.inj_le, le_S, Nat.le_refl. Defined. Lemma WeavedListSelf : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (last : nat), (forall n:nat, le n last -> (xn n) <= (xn (S n))) -> WeavedLists xn xn last. Proof. intros R xn last H n H0. split. apply CRle_refl. apply H. exact H0. Qed. Lemma EquiPartitionMesh : forall {R : ConstructiveReals} (a b : CRcarrier R) (n last : nat) (leab : a <= b), PartitionMesh (ipt_seq (IntervalEquiPartition a b last leab)) (S n) == (b-a) * CR_of_Q R (1 # Pos.of_nat (S last)). Proof. induction n. - intros. unfold PartitionMesh, IntervalEquiPartition, ipt_seq. setoid_replace (Z.of_nat 0 # Pos.of_nat (S last))%Q with 0%Q. 2: reflexivity. rewrite CRmult_0_r, CRplus_0_r. unfold CRminus. rewrite CRplus_assoc, <- (CRplus_comm (-a)), <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l. rewrite CRmax_left. reflexivity. rewrite <- (CRmult_0_r (b-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact leab. apply CRle_refl. apply CR_of_Q_le. discriminate. - intros. specialize (IHn last leab). unfold IntervalEquiPartition, ipt_seq. transitivity (CRmax ((a + (b - a) * CR_of_Q R (Z.of_nat (2+n) # Pos.of_nat (S last))) - (a + (b - a) * CR_of_Q R (Z.of_nat (1+n) # Pos.of_nat (S last)))) (PartitionMesh (ipt_seq (IntervalEquiPartition a b last leab)) (S n))). reflexivity. rewrite IHn. clear IHn. setoid_replace (a + (b - a) * CR_of_Q R (Z.of_nat (2 + n) # Pos.of_nat (S last)) - (a + (b - a) * CR_of_Q R (Z.of_nat (1 + n) # Pos.of_nat (S last)))) with ((b - a) * CR_of_Q R (1 # Pos.of_nat (S last))). rewrite CRmax_left. reflexivity. apply CRle_refl. rewrite CRplus_comm. unfold CRminus. rewrite CRopp_plus_distr, CRplus_assoc. rewrite <- (CRplus_assoc a), CRplus_opp_r, CRplus_0_l. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. apply CRmult_morph. reflexivity. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_minus_distr. unfold Qeq, Qnum, Qden. apply f_equal2. 2: reflexivity. simpl (2+n)%nat. rewrite (Nat2Z.inj_succ (S n)). unfold Z.succ. simpl (1+n)%nat. ring. Qed. Lemma UC_compare_integrals : forall {Re : ConstructiveReals} (f : CRcarrier Re -> CRcarrier Re) (a b eps epsR : CRcarrier Re) (cont_mod : forall eps:CRcarrier Re, 0 < eps -> CRcarrier Re) (P R Q : @IntervalPartition Re a b) (epsPos : 0 < eps) (epsPosR : 0 < epsR) (subseq : nat -> nat) (subseqR : nat -> nat), UniformCont f cont_mod -> IntervalPartitionRefinement _ _ P Q subseq -> IntervalPartitionRefinement _ _ R Q subseqR -> (PartitionMesh (ipt_seq P) (S (ipt_last P))) < (cont_mod eps epsPos) -> (PartitionMesh (ipt_seq R) (S (ipt_last R))) < (cont_mod epsR epsPosR) -> CRabs _ (IntegralFiniteSum f (ipt_seq P) (ipt_seq P) (ipt_last P) - IntegralFiniteSum f (ipt_seq R) (ipt_seq R) (ipt_last R)) <= (eps+epsR) * (b-a). Proof. intros. setoid_replace (IntegralFiniteSum f (ipt_seq P) (ipt_seq P) (ipt_last P) - IntegralFiniteSum f (ipt_seq R) (ipt_seq R) (ipt_last R)) with (IntegralFiniteSum f (ipt_seq P) (ipt_seq P) (ipt_last P) - (IntegralFiniteSum f (ipt_seq Q) (ipt_seq Q) (ipt_last Q)) + (IntegralFiniteSum f (ipt_seq Q) (ipt_seq Q) (ipt_last Q) - IntegralFiniteSum f (ipt_seq R) (ipt_seq R) (ipt_last R))). apply (CRle_trans _ _ _ (CRabs_triang _ _)). rewrite CRmult_plus_distr_r. apply CRplus_le_compat. - apply (UC_refine_integral f a b eps cont_mod _ _ _ _ epsPos subseq). exact H. apply WeavedListSelf, ipt_ordered. apply WeavedListSelf, ipt_ordered. exact H0. exact H2. - rewrite CRabs_minus_sym. apply (UC_refine_integral f a b epsR cont_mod _ _ _ _ epsPosR subseqR). exact H. apply WeavedListSelf, ipt_ordered. apply WeavedListSelf, ipt_ordered. exact H1. exact H3. - unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. (* This definition can be generalized to function uniformly continuous on an interval. Just multiply f by a trapeze of height 1. *) Lemma UC_integral_cauchy : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R), UniformCont f cont_mod -> a <= b -> CR_cauchy R (fun last : nat => IntegralFiniteSum f (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last). Proof. intros. intros n. (* eps = / INR (S (2 * n)) * / (b - a) *) assert (0 < CR_of_Q R (Z.pos (2*n) # 1) * (1+b-a)) as invStepPos. { apply CRmult_lt_0_compat. apply CR_of_Q_lt. reflexivity. apply (CRlt_le_trans _ (1+0)). rewrite CRplus_0_r. apply CRzero_lt_one. unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact H0. apply CRle_refl. } assert (0 < CRinv R (CR_of_Q R (Z.pos (2*n) # 1) * (1+b-a)) (inr invStepPos)) as stepPos. { apply CRinv_0_lt_compat. exact invStepPos. } destruct H. destruct (CRup_nat ((b-a) * (CRinv R (cont_mod _ stepPos) (inr (c _ stepPos))))) as [p pmaj]. exists p. intros. apply (CRle_trans _ (((CRinv R (CR_of_Q R (Z.pos (2*n) # 1) * (1+b-a)) (inr invStepPos)) + (CRinv R (CR_of_Q R (Z.pos (2*n) # 1) * (1+b-a)) (inr invStepPos))) * (b-a))). assert (0 < S i * S j)%nat as sisjPos. { apply Nat.mul_pos_pos; apply le_n_S, Nat.le_0_l. } apply (UC_compare_integrals f a b (CRinv R (CR_of_Q R (Z.pos (2*n) # 1) * (1+b-a)) (inr invStepPos)) (CRinv R (CR_of_Q R (Z.pos (2*n) # 1) * (1+b-a)) (inr invStepPos)) cont_mod (IntervalEquiPartition a b i H0) (IntervalEquiPartition a b j H0) (IntervalEquiPartition a b (pred (S i * S j)) H0) stepPos stepPos (fun n => S j * n)%nat (fun n => S i * n)%nat). split; assumption. - split. intros. unfold IntervalEquiPartition, ipt_seq. rewrite Nat.succ_pred. apply CRplus_morph. reflexivity. apply CRmult_morph. reflexivity. apply CR_of_Q_morph. rewrite Nat2Z.inj_mul, Nat2Pos.inj_mul. unfold Qeq, Qnum, Qden. do 2 rewrite <- positive_nat_Z. rewrite Pos2Nat.inj_mul. rewrite Nat2Pos.id. rewrite Nat2Pos.id. rewrite Nat2Z.inj_mul. ring. discriminate. discriminate. discriminate. discriminate. discriminate. split. intros. apply Nat.mul_lt_mono_pos_l. apply le_n_S, Nat.le_0_l. exact H2. unfold IntervalEquiPartition, ipt_last. intros. rewrite Nat.succ_pred. rewrite Nat.mul_comm. apply Nat.mul_le_mono_nonneg_r. apply Nat.le_0_l. exact H2. intro abs. rewrite abs in sisjPos. inversion sisjPos. - split. intros. unfold IntervalEquiPartition, ipt_seq. rewrite Nat.succ_pred. apply CRplus_morph. reflexivity. apply CRmult_morph. reflexivity. apply CR_of_Q_morph. rewrite Nat2Z.inj_mul, Nat2Pos.inj_mul. unfold Qeq, Qnum, Qden. do 2 rewrite <- positive_nat_Z. rewrite Pos2Nat.inj_mul. rewrite Nat2Pos.id. rewrite Nat2Pos.id. rewrite Nat2Z.inj_mul. ring. discriminate. discriminate. discriminate. discriminate. discriminate. split. intros. apply Nat.mul_lt_mono_pos_l. apply le_n_S, Nat.le_0_l. exact H2. unfold IntervalEquiPartition, ipt_last. intros. rewrite Nat.succ_pred. apply Nat.mul_le_mono_nonneg_l. apply Nat.le_0_l. exact H2. intro abs. rewrite abs in sisjPos. inversion sisjPos. - rewrite EquiPartitionMesh. unfold IntervalEquiPartition, ipt_last. apply (CRle_lt_trans _ ((b - a) * CR_of_Q R (1 # Pos.of_nat (S p)))). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact H0. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite Nat2Pos.id. apply le_n_S, H. discriminate. discriminate. apply (CRmult_lt_compat_r (cont_mod _ stepPos)) in pmaj. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in pmaj. apply (CRmult_lt_reg_l (INR (S p))). apply CR_of_Q_lt; reflexivity. rewrite CRmult_comm, CRmult_assoc. unfold INR. rewrite <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S p)) * (Z.of_nat (S p) # 1))%Q with 1%Q. rewrite CRmult_1_r. apply (CRlt_le_trans _ _ _ pmaj). apply CRmult_le_compat_r. apply CRlt_asym, c. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, <- positive_nat_Z. apply f_equal. rewrite Pos.mul_1_r. rewrite Nat2Pos.id. reflexivity. discriminate. apply c. - rewrite EquiPartitionMesh. unfold IntervalEquiPartition, ipt_last. apply (CRle_lt_trans _ ((b - a) * CR_of_Q R (1 # Pos.of_nat (S p)))). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact H0. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite Nat2Pos.id. apply le_n_S, H1. discriminate. discriminate. apply (CRmult_lt_compat_r (cont_mod _ stepPos)) in pmaj. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in pmaj. apply (CRmult_lt_reg_l (INR (S p))). apply CR_of_Q_lt; reflexivity. rewrite CRmult_comm, CRmult_assoc. unfold INR. rewrite <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S p)) * (Z.of_nat (S p) # 1))%Q with 1%Q. rewrite CRmult_1_r. apply (CRlt_le_trans _ _ _ pmaj). apply CRmult_le_compat_r. apply CRlt_asym, c. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, <- positive_nat_Z. apply f_equal. rewrite Pos.mul_1_r. rewrite Nat2Pos.id. reflexivity. discriminate. apply c. - rewrite <- (CRmult_1_r (CRinv R (CR_of_Q R (Z.pos (2 * n) # 1) * (1 + b - a)) (inr invStepPos))). rewrite <- CRmult_plus_distr_l. apply (CRmult_le_reg_l (CR_of_Q R (Z.pos (2 * n) # 1) * (1 + b - a))). exact invStepPos. do 2 rewrite <- CRmult_assoc. rewrite CRinv_r, CRmult_1_l. rewrite <- (CRmult_comm (1 + b - a)), CRmult_assoc. rewrite <- CR_of_Q_mult. setoid_replace ((Z.pos (2 * n) # 1) * (1 # n))%Q with 2%Q. rewrite CRmult_comm, <- CR_of_Q_plus. apply CRmult_le_compat_r. apply CR_of_Q_le. discriminate. rewrite <- (CRplus_0_l (b-a)). unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_r. apply CRlt_asym, CRzero_lt_one. unfold Qeq, Qnum, Qden. simpl. do 2 rewrite Pos.mul_1_r. reflexivity. Qed. Definition UC_integral {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) : UniformCont f cont_mod -> a <= b -> CRcarrier R := fun H H0 => let (i,_) := CR_complete R (fun last : nat => IntegralFiniteSum f (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b cont_mod H H0) in i. (* Give the convergence speed of the integral more explicitly. This formula is useful for numerical computations of integrals in practice, to majorate the error. *) Lemma UC_compare_integrals_limit : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (leab : a <= b) (n : nat) (eps : CRcarrier R) (epsPos : 0 < eps) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod), PartitionMesh (ipt_seq (IntervalEquiPartition a b n leab)) (S (ipt_last (IntervalEquiPartition a b n leab))) < cont_mod eps epsPos -> CRabs _ (IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_last (IntervalEquiPartition a b n leab)) - UC_integral f a b cont_mod fCont leab) <= eps * (b-a). Proof. intros. assert (forall k:nat, 0 < CR_of_Q R (1 # Pos.of_nat (S k))) as kPos. { intros. apply CR_of_Q_lt. reflexivity. } assert (forall k:nat, let (q,_) := CRup_nat ((b-a) * (CRinv R (cont_mod _ (kPos k)) (inr ((fst fCont) _ (kPos k))))) in CRabs _ (IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_last (IntervalEquiPartition a b n leab)) - IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b (max k q) leab)) (ipt_seq (IntervalEquiPartition a b (max k q) leab)) (ipt_last (IntervalEquiPartition a b (max k q) leab))) <= (eps + (CR_of_Q R (1# Pos.of_nat (S k)))) * (b-a)). { intro k. destruct (CRup_nat ((b-a) * (CRinv R (cont_mod _ (kPos k)) (inr ((fst fCont) _ (kPos k)))))) as [q qmaj]. assert (0 < S n * S (max k q))%nat as sisjPos. apply Nat.mul_pos_pos; apply le_n_S, Nat.le_0_l. apply (UC_compare_integrals f a b _ _ cont_mod _ _ (IntervalEquiPartition a b (pred (S n * S (max k q))) leab) epsPos (kPos k) (fun i => S (max k q) * i)%nat (fun i => S n * i)%nat fCont). - split. intros. unfold IntervalEquiPartition, ipt_seq. rewrite Nat.succ_pred. apply CRplus_morph. reflexivity. apply CRmult_morph. reflexivity. apply CR_of_Q_morph. rewrite Nat2Z.inj_mul, Nat2Pos.inj_mul. unfold Qeq, Qnum, Qden. do 2 rewrite <- positive_nat_Z. rewrite Pos2Nat.inj_mul. rewrite Nat2Pos.id. rewrite Nat2Pos.id. rewrite Nat2Z.inj_mul. ring. discriminate. discriminate. discriminate. discriminate. discriminate. split. intros. apply Nat.mul_lt_mono_pos_l. apply le_n_S, Nat.le_0_l. exact H0. unfold IntervalEquiPartition, ipt_last. intros. rewrite Nat.succ_pred. rewrite Nat.mul_comm. apply Nat.mul_le_mono_nonneg_r. apply Nat.le_0_l. exact H0. intro abs. rewrite abs in sisjPos. inversion sisjPos. - split. intros. unfold IntervalEquiPartition, ipt_seq. rewrite Nat.succ_pred. apply CRplus_morph. reflexivity. apply CRmult_morph. reflexivity. apply CR_of_Q_morph. rewrite Nat2Z.inj_mul, Nat2Pos.inj_mul. unfold Qeq, Qnum, Qden. do 2 rewrite <- positive_nat_Z. rewrite Pos2Nat.inj_mul. rewrite Nat2Pos.id. rewrite Nat2Pos.id. rewrite Nat2Z.inj_mul. ring. discriminate. discriminate. discriminate. discriminate. discriminate. split. intros. apply Nat.mul_lt_mono_pos_l. apply le_n_S, Nat.le_0_l. exact H0. unfold IntervalEquiPartition, ipt_last. intros. rewrite Nat.succ_pred. apply Nat.mul_le_mono_nonneg_l. apply Nat.le_0_l. exact H0. intro abs. rewrite abs in sisjPos. inversion sisjPos. - exact H. - rewrite EquiPartitionMesh. apply (CRle_lt_trans _ ((b - a) * CR_of_Q R (1# Pos.of_nat (S q)))). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact leab. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. rewrite Nat2Pos.id. apply le_n_S, Nat.le_max_r. discriminate. discriminate. apply (CRmult_lt_compat_r (cont_mod _ (kPos k))) in qmaj. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in qmaj. apply (CRmult_lt_reg_l (INR (S q))). apply CR_of_Q_lt; reflexivity. rewrite CRmult_comm, CRmult_assoc. unfold INR. rewrite <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S q)) * (Z.of_nat (S q) # 1))%Q with 1%Q. rewrite CRmult_1_r. apply (CRlt_le_trans _ _ _ qmaj). apply CRmult_le_compat_r. apply CRlt_asym. destruct fCont. apply c. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_refl. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, <- positive_nat_Z. apply f_equal. rewrite Pos.mul_1_r. rewrite Nat2Pos.id. reflexivity. discriminate. destruct fCont. apply c. } apply (CR_cv_le (fun k => let (q, _) := CRup_nat ((b - a) * (CRinv R (cont_mod (CR_of_Q R (1 # Pos.of_nat (S k))) (kPos k)) (inr (fst fCont (CR_of_Q R (1 # Pos.of_nat (S k))) (kPos k))))) in CRabs _ (IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_last (IntervalEquiPartition a b n leab)) - IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b (Init.Nat.max k q) leab)) (ipt_seq (IntervalEquiPartition a b (Init.Nat.max k q) leab)) (ipt_last (IntervalEquiPartition a b (Init.Nat.max k q) leab)))) (fun k => (eps + CR_of_Q R (1 # Pos.of_nat (S k))) * (b - a))). - intros. specialize (H0 n0). destruct (CRup_nat ((b - a) * (CRinv R (cont_mod (CR_of_Q R (1 # Pos.of_nat (S n0))) (kPos n0)) (inr (fst fCont (CR_of_Q R (1 # Pos.of_nat (S n0))) (kPos n0)))))). exact H0. - intros eta. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n1 : nat => a + (b - a) * CR_of_Q R (Z.of_nat n1 # Pos.of_nat (S last))) (fun n1 : nat => a + (b - a) * CR_of_Q R (Z.of_nat n1 # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b cont_mod fCont leab)). specialize (c eta) as [N u]. exists N. intros n0 H1. destruct (CRup_nat ((b - a) * (CRinv R (cont_mod (CR_of_Q R (1 # Pos.of_nat (S n0))) (kPos n0)) (inr (fst fCont (CR_of_Q R (1 # Pos.of_nat (S n0))) (kPos n0)))))). apply (CRle_trans _ _ _ (CRabs_triang_inv2 _ _)). setoid_replace (IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_last (IntervalEquiPartition a b n leab)) - IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b (Init.Nat.max n0 x0) leab)) (ipt_seq (IntervalEquiPartition a b (Init.Nat.max n0 x0) leab)) (ipt_last (IntervalEquiPartition a b (Init.Nat.max n0 x0) leab)) - (IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_seq (IntervalEquiPartition a b n leab)) (ipt_last (IntervalEquiPartition a b n leab)) - x)) with (-(IntegralFiniteSum f (ipt_seq (IntervalEquiPartition a b (Init.Nat.max n0 x0) leab)) (ipt_seq (IntervalEquiPartition a b (Init.Nat.max n0 x0) leab)) (ipt_last (IntervalEquiPartition a b (Init.Nat.max n0 x0) leab)) - x)). rewrite CRabs_opp. apply u. unfold IntervalEquiPartition, ipt_last. apply (Nat.le_trans _ _ _ H1), Nat.le_max_l. unfold CRminus. do 2 rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_l. reflexivity. - apply CR_cv_scale. intros i. exists (Pos.to_nat i). intros. setoid_replace (eps + CR_of_Q R (1 # Pos.of_nat (S i0)) - eps) with (CR_of_Q R (1 # Pos.of_nat (S i0))). rewrite CRabs_right. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply (Nat.le_trans _ _ _ H1), le_S, Nat.le_refl. discriminate. apply CR_of_Q_le. discriminate. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Lemma UC_integral_translate : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b t : CRcarrier R) (leab : a <= b) (leabt : a+t <= b+t) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod), UC_integral f a b cont_mod fCont leab == UC_integral (fun x => f (x-t)) (a+t) (b+t) cont_mod (UC_translate_horizontal f (-t) cont_mod fCont) leabt. Proof. intros. unfold UC_integral. assert (forall i j k : CRcarrier R, i + j - (i + k) == j - k) as addSub. { intros. unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. } destruct (CR_complete R (fun last : nat => IntegralFiniteSum (fun x : CRcarrier R => f (x - t)) (fun n : nat => a + t + (b + t - (a + t)) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + t + (b + t - (a + t)) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy (fun x : CRcarrier R => f (x - t)) (a + t) (b + t) cont_mod (UC_translate_horizontal f (- t) cont_mod fCont) leabt)). apply (CR_cv_unique (fun last : nat => IntegralFiniteSum (fun x : CRcarrier R => f (x - t)) (fun n : nat => a + t + (b + t - (a + t)) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + t + (b + t - (a + t)) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last)). 2: exact c. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b cont_mod fCont leab)). apply (CR_cv_eq _ (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last)). 2: exact c0. intro n. apply CRsum_eq. intros. apply CRmult_morph. - apply (UniformContProper f cont_mod fCont). setoid_replace (b + t - (a + t)) with (b-a). unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite (CRplus_comm t), CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. rewrite (CRplus_comm b), (CRplus_comm a). rewrite addSub. reflexivity. - setoid_replace (b + t - (a + t)) with (b-a). rewrite addSub, addSub. reflexivity. rewrite (CRplus_comm b), (CRplus_comm a). rewrite addSub. reflexivity. Qed. Lemma UC_integral_bound_proper : forall {R : ConstructiveReals} f (a b c d : CRcarrier R) (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f modF) (leab : a <= b) (lecd : c <= d), a == c -> b == d -> UC_integral f a b modF fCont leab == UC_integral f c d modF fCont lecd. Proof. intros. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => c + (d - c) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => c + (d - c) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f c d modF fCont lecd) ). apply (CR_cv_unique (fun last : nat => IntegralFiniteSum f (fun n : nat => c + (d - c) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => c + (d - c) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last)). 2: exact c0. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b modF fCont leab)). apply (CR_cv_eq _ (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last)). 2: exact c1. intro n. apply CRsum_eq. intros. clear c1 x0 c0 x. apply CRmult_morph. apply (UniformContProper f modF fCont). rewrite H, H0. reflexivity. rewrite H, H0. reflexivity. Qed. Lemma UC_right_bound_continuous : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (leab : a <= b) (eps : CRcarrier R) (epsPos : 0 < eps) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod), { eta : CRcarrier R & prod (0 < eta) (forall (c:CRcarrier R) (leac : prod (b <= c) (c < b+eta)), CRabs R (UC_integral f a b cont_mod fCont leab - UC_integral f a c cont_mod fCont (CRle_trans a b c leab (fst leac))) <= eps) }. Proof. intros. (* When f is a constant function, its integral on [a,b] equals (b-a)f, so pushing b is weighted by f. *) destruct (UC_bounded f a b cont_mod fCont leab) as [B Bmaj]. assert (forall i j k : CRcarrier R, i + j - (i + k) == j - k) as addSub. { intros. unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. } assert (0 < b-a+1). { rewrite <- (CRplus_opp_l a). unfold CRminus. rewrite (CRplus_comm b), CRplus_assoc. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ (b+0)). rewrite CRplus_0_r. exact leab. apply CRplus_lt_compat_l, CRzero_lt_one. } assert (0 < B) as Bpos. { apply (CRle_lt_trans _ (CRabs R (f a))). apply CRabs_pos. apply Bmaj. apply CRle_refl. exact leab. } assert (0 < eps * CR_of_Q R (1#2) * CRinv R (b-a+1) (inr H)). { destruct fCont. apply CRmult_lt_0_compat. apply CRmult_lt_0_compat. exact epsPos. apply CR_of_Q_pos. reflexivity. apply CRinv_0_lt_compat, H. } exists (CRmin (cont_mod (eps * CR_of_Q R (1#2) * CRinv R (b-a+1) (inr H)) H0) (CRmin (eps * CR_of_Q R (1#2) * CRinv R B (inr Bpos)) 1)). split. apply CRmin_lt. apply (fst fCont). apply CRmin_lt. apply CRmult_lt_0_compat. apply CRmult_lt_0_compat. exact epsPos. apply CR_of_Q_pos. reflexivity. apply CRinv_0_lt_compat, Bpos. exact (CRzero_lt_one R). intros. apply (CR_cv_bound_up (fun last : nat => CRabs R (IntegralFiniteSum f (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last - IntegralFiniteSum f (fun n => a + (c-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n => a + (c-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last)) eps _ O). - intros n _. unfold IntegralFiniteSum. unfold CRminus. rewrite <- sum_opp, <- sum_plus. rewrite (CRsum_eq _ (fun n0 => ((f (a + (b + - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S n))) * (b + - a) - f (a + (c + - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S n))) * (c + - a)) * CR_of_Q R (1 # Pos.of_nat (S n))))). rewrite sum_scale, CRmult_comm. rewrite CRabs_mult, CRabs_right. 2: apply CR_of_Q_le; discriminate. apply (CRle_trans _ (CR_of_Q R (1 # Pos.of_nat (S n)) * CRsum (fun k => CRabs R (f (a + (b + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (b-a) - f (a + (c + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (c-a))) n)). apply CRmult_le_compat_l. apply CR_of_Q_le; discriminate. apply multiTriangleIneg. apply (CRle_trans _ (CR_of_Q R (1 # Pos.of_nat (S n)) * CRsum (fun _ => eps) n)). + (* Prove that each element of the sum is lower than eps. *) apply CRmult_le_compat_l. apply CR_of_Q_le; discriminate. apply sum_Rle. intros. assert (CR_of_Q R (Z.of_nat k # Pos.of_nat (S n)) <= 1) as inInterval. { apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. destruct k. discriminate. unfold Z.of_nat. apply Pos2Z.pos_le_pos. rewrite Pos.of_nat_succ. apply Pos2Nat.inj_le. rewrite Nat2Pos.id, Nat2Pos.id. apply le_S, H1. discriminate. discriminate. } setoid_replace (f (a + (b + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (b - a) - f (a + (c + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (c - a)) with (f (a + (b + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (b - a) - f (a + (b + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (c - a) + (f (a + (b + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (c - a) - f (a + (c + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) * (c - a))). apply (CRle_trans _ _ _ (CRabs_triang _ _)). apply (CRle_trans _ (eps * CR_of_Q R (1#2) + eps * CR_of_Q R (1#2))). apply CRplus_le_compat. unfold CRminus. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l, CRabs_mult. setoid_replace (b + - a + - (c + - a)) with (b-c). apply (CRle_trans _ (B * CRabs R (b-c))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRlt_asym, Bmaj. apply (CRle_trans _ (a + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_le_compat_l. apply CRmult_le_0_compat. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r. exact leab. apply CR_of_Q_le. unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- (CRmult_1_r (-a+b)), (CRplus_comm (-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r. exact leab. exact inInterval. rewrite CRabs_minus_sym, CRabs_right. apply (CRmult_le_reg_r (CRinv R B (inr Bpos))). apply CRinv_0_lt_compat, Bpos. rewrite CRmult_comm, <- CRmult_assoc, CRinv_l, CRmult_1_l. destruct leac. apply (CRplus_lt_compat_l R (-b)) in c1. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm in c1. apply CRlt_asym, (CRlt_le_trans _ _ _ c1). apply (CRle_trans _ _ _ (CRmin_r _ _)). apply CRmin_l. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r. exact (fst leac). do 2 rewrite <- (CRplus_comm (-a)). exact (addSub (-a) b c). unfold CRminus. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. rewrite CRabs_mult. apply (CRle_trans _ (eps * CR_of_Q R (1 # 2) * CRinv R (b - a + 1) (inr H) * CRabs R (c + - a))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRlt_asym. apply (snd fCont _ _ _ H0). rewrite addSub. apply (CRle_lt_trans _ (c-b)). unfold CRminus. rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r, CRabs_mult. rewrite <- (CRplus_comm (-a)), <- (CRplus_comm (-a)), (addSub (-a) b c). rewrite <- (CRmult_1_r (c+-b)), CRabs_minus_sym, CRabs_right. apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r. exact (fst leac). rewrite CRabs_right. exact inInterval. apply CR_of_Q_le. unfold Qle; simpl. rewrite Z.mul_1_r. apply Nat2Z.is_nonneg. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r. exact (fst leac). destruct leac. apply (CRplus_lt_compat_l R (-b)) in c1. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm in c1. apply (CRlt_le_trans _ _ _ c1). apply CRmin_l. rewrite <- (CRmult_1_r (eps * CR_of_Q R (1 # 2))). do 2 rewrite CRmult_assoc. apply CRmult_le_compat_l. apply CRmult_le_0_compat. apply CRlt_asym, epsPos. apply CRlt_asym, CR_of_Q_pos. reflexivity. rewrite CRmult_1_l. apply (CRmult_le_reg_l (b-a+1) _ _ H). rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l, CRmult_1_r. rewrite CRabs_right. unfold CRminus. rewrite (CRplus_comm c), (CRplus_comm b). rewrite CRplus_assoc. apply CRplus_le_compat_l. apply CRlt_asym. destruct leac. apply (CRlt_le_trans _ _ _ c1). apply CRplus_le_compat_l. apply (CRle_trans _ _ _ (CRmin_r _ _)), CRmin_r. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r. apply (CRle_trans _ _ _ leab). exact (fst leac). rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. rewrite Qinv_plus_distr. setoid_replace (1 + 1 # 2)%Q with 1%Q. rewrite CRmult_1_r. apply CRle_refl. reflexivity. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. + rewrite sum_const. rewrite CRmult_comm, CRmult_assoc. unfold INR. rewrite <- CR_of_Q_mult. setoid_replace ((Z.of_nat (S n) # 1) * (1 # Pos.of_nat (S n)))%Q with 1%Q. rewrite CRmult_1_r. apply CRle_refl. unfold Z.of_nat. rewrite Pos.of_nat_succ. unfold Qeq. simpl. do 2 rewrite Pos.mul_1_r. reflexivity. + intros. unfold CRminus. unfold CRminus in addSub. do 2 rewrite (addSub a). rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. rewrite (CRopp_mult_distr_r (c+-a)), <- CRmult_plus_distr_l. setoid_replace (CR_of_Q R (Z.of_nat (S i) # Pos.of_nat (S n)) + - CR_of_Q R (Z.of_nat i # Pos.of_nat (S n))) with (CR_of_Q R (1 # Pos.of_nat (S n))). rewrite <- CRmult_assoc, <- CRmult_assoc, CRopp_mult_distr_l. rewrite <- CRmult_plus_distr_r. reflexivity. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_minus_distr. replace (Z.of_nat (S i) - Z.of_nat i)%Z with 1%Z. reflexivity. rewrite Nat2Z.inj_succ. unfold Z.succ. ring. - apply CR_cv_abs_cont. apply CR_cv_minus. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n0 : nat => a + (b - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) (fun n0 : nat => a + (b - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b cont_mod fCont leab)). exact c0. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n0 : nat => a + (c - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) (fun n0 : nat => a + (c - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) last) (UC_integral_cauchy f a c cont_mod fCont (CRle_trans a b c leab (fst leac)))). exact c0. Qed. Definition ConcatSequences {R : ConstructiveReals} (xn yn : nat -> CRcarrier R) (lenX n : nat) : CRcarrier R := if lt_dec n lenX then xn n else yn (n - lenX)%nat. Definition IntervalPartitionConcat {R : ConstructiveReals} {a b c : CRcarrier R} : @IntervalPartition R a b -> @IntervalPartition R b c -> @IntervalPartition R a c. Proof. intros P Q. apply (Build_IntervalPartition R a c (* do not count b twice *) (ConcatSequences (ipt_seq P) (ipt_seq Q) (S (ipt_last P))) (S (ipt_last P) + ipt_last Q)). - apply P. - unfold ConcatSequences. destruct (lt_dec (S (S (ipt_last P) + ipt_last Q)) (S (ipt_last P))). + exfalso. apply (proj1 (Nat.lt_nge _ _) l), le_n_S, (Nat.le_trans _ (S (ipt_last P) + 0)). rewrite Nat.add_0_r. apply le_S, Nat.le_refl. apply Nat.add_le_mono_l, Nat.le_0_l. + replace (S (S (ipt_last P) + ipt_last Q) - (S (ipt_last P)))%nat with (S (ipt_last Q)). apply Q. rewrite Nat.sub_succ. simpl plus. rewrite Nat.sub_succ_l. apply f_equal. rewrite Nat.add_comm, Nat.add_sub. reflexivity. apply (Nat.le_trans _ (ipt_last P + 0)). rewrite Nat.add_comm. apply Nat.le_refl. apply Nat.add_le_mono_l, Nat.le_0_l. - intros. unfold ConcatSequences. destruct (lt_dec (S n) (S (ipt_last P))). + destruct (lt_dec n (S (ipt_last P))). apply P, le_S_n, l0. exfalso. apply n0. apply le_S, le_S_n, l. + destruct (lt_dec n (S (ipt_last P))). apply (CRle_trans _ (ipt_seq P (S (ipt_last P)))). apply ipt_ordered_transit. apply le_S, le_S_n, l. apply Nat.le_refl. rewrite <- (ipt_lastB P). apply (CRle_trans _ (ipt_seq Q 0)). rewrite <- (ipt_head Q). apply CRle_refl. apply ipt_ordered_transit. apply Nat.le_0_l. simpl. apply Nat.le_sub_le_add_l. rewrite Nat.add_succ_r. exact H. clear n0. apply ipt_ordered_transit. apply Nat.le_sub_le_add_r. rewrite Nat.sub_add. apply le_S, Nat.le_refl. apply Nat.nlt_ge in n1. apply le_n_S, (Nat.le_trans _ (S (ipt_last P))). apply le_S, Nat.le_refl. exact n1. apply Nat.le_sub_le_add_r. simpl. apply le_n_S. rewrite Nat.add_comm. exact H. Defined. Definition IntervalPartitionConcatSum : forall {R : ConstructiveReals} (a b c : CRcarrier R) (f : CRcarrier R -> CRcarrier R) (P : @IntervalPartition R a b) (Q : @IntervalPartition R b c), IntegralFiniteSum f (ipt_seq P) (ipt_seq P) (ipt_last P) + IntegralFiniteSum f (ipt_seq Q) (ipt_seq Q) (ipt_last Q) == IntegralFiniteSum f (ipt_seq (IntervalPartitionConcat P Q)) (ipt_seq (IntervalPartitionConcat P Q)) (ipt_last (IntervalPartitionConcat P Q)). Proof. intros. destruct P,Q; simpl. unfold IntegralFiniteSum. replace (S (ipt_last0 + ipt_last1)) with (S ipt_last0 + ipt_last1)%nat. 2: reflexivity. rewrite sum_assoc. apply CRplus_morph. - apply CRsum_eq. intros. unfold ConcatSequences. destruct (lt_dec i (S ipt_last0)). clear l. 2: apply le_n_S in H; contradiction. destruct (lt_dec (S i) (S ipt_last0)). reflexivity. apply CRmult_morph. reflexivity. apply CRplus_morph. 2: reflexivity. replace i with ipt_last0. + rewrite <- ipt_lastB0. rewrite Nat.sub_diag. rewrite <- ipt_head1. reflexivity. + apply Nat.le_antisymm. apply le_S_n, Nat.nlt_ge, n. exact H. - apply CRsum_eq. intros. unfold ConcatSequences. destruct (lt_dec (S ipt_last0 + i) (S ipt_last0)). exfalso. apply (proj1 (Nat.lt_nge _ _) l). apply (Nat.le_trans _ (S ipt_last0 + 0)). rewrite Nat.add_0_r. apply Nat.le_refl. apply Nat.add_le_mono_l, Nat.le_0_l. clear n. destruct (lt_dec (S (S ipt_last0 + i)) (S ipt_last0)). exfalso. apply Nat.lt_nge in l. apply l, le_n_S. apply (Nat.le_trans _ (S ipt_last0 + 0)). rewrite Nat.add_0_r. apply le_S, Nat.le_refl. apply Nat.add_le_mono_l, Nat.le_0_l. clear n. replace (S ipt_last0 + i - S ipt_last0)%nat with i. 2: rewrite Nat.add_comm, Nat.add_sub; reflexivity. apply CRmult_morph. reflexivity. apply CRplus_morph. 2: reflexivity. replace (S (S ipt_last0 + i) - S ipt_last0)%nat with (S i). reflexivity. rewrite Nat.sub_succ. simpl plus. rewrite <- Nat.add_succ_r, Nat.add_comm, Nat.add_sub. reflexivity. Qed. (* The last point of the first list must be equal to the first point of the second list, otherwise the concatenation would introduce a parasite difference. *) Lemma PartitionMeshConcat : forall {R : ConstructiveReals} (a b c : CRcarrier R) (P : @IntervalPartition R a b) (Q : @IntervalPartition R b c), PartitionMesh (ipt_seq (IntervalPartitionConcat P Q)) (S (ipt_last (IntervalPartitionConcat P Q))) == CRmax (PartitionMesh (ipt_seq P) (S (ipt_last P))) (PartitionMesh (ipt_seq Q) (S (ipt_last Q))). Proof. intro R. assert (forall (xn yn : nat -> CRcarrier R) (p n : nat), xn n == yn O -> PartitionMesh (ConcatSequences xn yn n) (n + p) == CRmax (PartitionMesh xn n) (PartitionMesh yn p)). { induction p. - intros. unfold ConcatSequences. rewrite CRmax_left. 2: apply PartitionMesh_nonneg. rewrite Nat.add_0_r. rewrite (PartitionMesh_ext (fun n0 : nat => if lt_dec n0 n then xn n0 else yn (n0 - n)%nat) xn). reflexivity. intros. destruct (lt_dec n0 n). reflexivity. replace n0 with n. rewrite Nat.sub_diag. symmetry. exact H. apply Nat.le_antisymm. 2: exact H0. apply Nat.nlt_ge. exact n1. - intros. rewrite Nat.add_succ_r. simpl. rewrite IHp. 2: exact H. assert (forall a b c : CRcarrier R, CRmax a (CRmax b c) == CRmax b (CRmax a c)). intros. rewrite CRmax_assoc, (CRmax_sym a), <- CRmax_assoc. reflexivity. setoid_replace (ConcatSequences xn yn n (S (n + p)) - ConcatSequences xn yn n (n+p)) with (yn (S p) - yn p). apply H0. unfold ConcatSequences. destruct (lt_dec (S (n + p)) n). exfalso. apply (proj1 (Nat.lt_nge _ _) l). apply (Nat.le_trans _ (S n + 0)). rewrite Nat.add_0_r. apply le_S, Nat.le_refl. simpl. apply le_n_S, Nat.add_le_mono_l, Nat.le_0_l. clear n0. destruct (lt_dec (n + p) n). exfalso. apply (proj1 (Nat.lt_nge _ _) l). apply (Nat.le_trans _ (n + 0)). rewrite Nat.add_0_r. apply Nat.le_refl. apply Nat.add_le_mono_l, Nat.le_0_l. clear n0. rewrite (Nat.add_comm n), Nat.add_sub. apply CRplus_morph. 2: reflexivity. replace (S (p+n)) with (S p + n)%nat. 2: reflexivity. rewrite Nat.add_sub. reflexivity. } intros. unfold IntervalPartitionConcat, ipt_seq, ipt_last. destruct P, Q. replace (S (S ipt_last0 + ipt_last1)) with (S ipt_last0 + S ipt_last1)%nat. rewrite H. apply CRmax_morph. reflexivity. reflexivity. rewrite <- ipt_lastB0. rewrite <- ipt_head1. reflexivity. rewrite Nat.add_succ_r. reflexivity. Qed. Fixpoint Fun2List (xn : nat -> Q) (len : nat) : list Q := match len with | O => Datatypes.nil | S p => Fun2List xn p ++ (Datatypes.cons (xn p) Datatypes.nil) end. Lemma Fun2ListLength : forall (xn : nat -> Q) (len : nat), length (Fun2List xn len) = len. Proof. induction len. - reflexivity. - simpl. rewrite app_length, IHlen, Nat.add_comm. reflexivity. Qed. Lemma Fun2ListNth : forall (xn : nat -> Q) (len n : nat), lt n len -> nth n (Fun2List xn len) 0%Q = xn n. Proof. induction len. - intros. exfalso; inversion H. - intros. simpl. apply Nat.le_succ_r in H. destruct H. rewrite app_nth1. apply IHlen. exact H. rewrite Fun2ListLength. exact H. inversion H. rewrite app_nth2. rewrite Fun2ListLength, Nat.sub_diag. reflexivity. rewrite Fun2ListLength. apply Nat.le_refl. Qed. Definition IntervalPartitionRational {R : ConstructiveReals} {a b : CRcarrier R} (P : @IntervalPartition R a b) : Set := { rat : list Q | (length rat = plus 2 (ipt_last P)) /\ forall n:nat, le n (S (ipt_last P)) -> ipt_seq P n == CR_of_Q R (nth n rat 0%Q) }. Lemma EquiPartitionRational : forall {R : ConstructiveReals} (a b : Q) (k : nat) (leab : (CR_of_Q R a) <= (CR_of_Q R b)), IntervalPartitionRational (IntervalEquiPartition (CR_of_Q R a) (CR_of_Q R b) k leab). Proof. intros. exists (Fun2List (fun n => a + (b-a) * (Z.of_nat n # Pos.of_nat (S k)))%Q (2+k)). intros. split. - rewrite Fun2ListLength. reflexivity. - intros. unfold IntervalEquiPartition, ipt_seq. unfold IntervalEquiPartition, ipt_last in H. rewrite Fun2ListNth. 2: apply le_n_S, H. rewrite CR_of_Q_plus. apply CRplus_morph. reflexivity. rewrite CR_of_Q_mult. unfold Qminus. rewrite CR_of_Q_plus, CR_of_Q_opp. reflexivity. Qed. Lemma PartitionRationalConcat : forall {R : ConstructiveReals} (a b c : CRcarrier R) (P : @IntervalPartition R a b) (Q : @IntervalPartition R b c), IntervalPartitionRational P -> IntervalPartitionRational Q -> IntervalPartitionRational (IntervalPartitionConcat P Q). Proof. intros. destruct H, a0, H0, a0. exists (x ++ tl x0). intros. destruct P, Q; simpl; simpl in H, H2, H1, H0. split. - rewrite app_length, H. destruct x0. exfalso; inversion H0. simpl. simpl in H0. inversion H0. rewrite H4. rewrite Nat.add_succ_r. reflexivity. - intros. unfold ConcatSequences. destruct (lt_dec n (S ipt_last0)). + rewrite app_nth1. apply H1. apply le_S_n in l. apply (Nat.le_trans _ ipt_last0 _ l), le_S, Nat.le_refl. rewrite H. apply (Nat.lt_trans _ _ _ l), Nat.le_refl. + destruct (Nat.lt_trichotomy n (S ipt_last0)). contradiction. destruct H4. subst n. rewrite app_nth1. rewrite Nat.sub_diag, <- ipt_head1. rewrite <- H1. rewrite <- ipt_lastB0. reflexivity. apply Nat.le_refl. rewrite H. apply Nat.le_refl. clear n0. rewrite app_nth2, H. 2: rewrite H; exact H4. destruct x0. exfalso; inversion H0. simpl. specialize (H2 (S(n - S (S(ipt_last0))))%nat). simpl in H2. rewrite <- H2. replace (n - S ipt_last0)%nat with (S (n - S (S ipt_last0))). reflexivity. rewrite (Nat.sub_succ_r _ (S ipt_last0)). rewrite Nat.succ_pred. reflexivity. intro abs. apply Nat.sub_0_le in abs. exact (proj1 (Nat.lt_nge _ _) H4 abs). rewrite (Nat.sub_succ_r _ (S ipt_last0)). rewrite Nat.succ_pred. rewrite Nat.le_sub_le_add_l, Nat.add_succ_r. exact H3. intro abs. apply Nat.sub_0_le in abs. exact (proj1 (Nat.lt_nge _ _) H4 abs). Qed. Lemma FunLocSorted : forall (xn : list Q), (forall n:nat, lt (S n) (length xn) -> Qle (nth n xn 0%Q) (nth (S n) xn 0%Q)) -> LocallySorted (fun x x0 : QArith_base.Q => is_true (Qle_bool x x0)) xn. Proof. induction xn. - intros. apply LSorted_nil. - intros. destruct xn. apply LSorted_cons1. apply LSorted_consn. apply IHxn. intros. apply (H (S n)). apply le_n_S, H0. unfold is_true. rewrite Qle_bool_iff. apply (H O). apply le_n_S, le_n_S, Nat.le_0_l. Qed. Lemma LocSortedFun : forall (xn : list Q), LocallySorted (fun x x0 : QArith_base.Q => is_true (Qle_bool x x0)) xn -> (forall n:nat, lt (S n) (length xn) -> Qle (nth n xn 0%Q) (nth (S n) xn 0%Q)). Proof. induction xn. - intros. exfalso; inversion H0. - intros. simpl in H0. destruct xn. exfalso; inversion H0; inversion H2. destruct n. simpl. inversion H. unfold is_true in H5. rewrite Qle_bool_iff in H5. exact H5. apply IHxn. inversion H; exact H3. apply le_S_n in H0. exact H0. Qed. Lemma PartitionRationalLocSorted : forall {R : ConstructiveReals} (a b : CRcarrier R) (P : @IntervalPartition R a b) (rat : IntervalPartitionRational P), LocallySorted (fun x x0 : QArith_base.Q => is_true (Qle_bool x x0)) (proj1_sig rat). Proof. intros. apply FunLocSorted. intros. destruct rat; simpl; unfold proj1_sig in H. destruct (Q_dec (nth n x 0) (nth (S n) x 0))%Q. destruct s. apply Qlt_le_weak, q. exfalso. destruct a0. rewrite H0 in H. apply le_S_n, le_S_n in H. apply (CR_of_Q_lt R) in q. rewrite <- H1 in q. rewrite <- (H1 n) in q. destruct P. simpl in q, H1. apply (ipt_ordered0 n). exact H. exact q. apply le_S, H. apply le_n_S, H. rewrite q. apply Qle_refl. Qed. Module QOrder <: TotalLeBool. Definition t := Q. Definition leb := Qle_bool. Theorem leb_total : forall a1 a2:Q, leb a1 a2 = true \/ leb a2 a1 = true. Proof. intros. unfold leb. do 2 rewrite Qle_bool_iff. destruct (Qlt_le_dec a1 a2). left. apply Qlt_le_weak, q. right. exact q. Qed. End QOrder. Module Import QSort := Sort QOrder. Lemma MergeLength : forall (xn yn : list Q), length (merge xn yn) = plus (length xn) (length yn). Proof. intros. pose proof (Permuted_merge xn yn). apply Permutation_length in H. rewrite <- H. apply app_length. Qed. (* index of xn n inside merge xn yn. Inner fixpoint allows to prove that recursive calls terminate. *) Fixpoint MergeInjectL (xn yn : list Q) (n : nat) { struct xn } : nat := let fix merge_aux yn n := match xn with | Datatypes.nil => O (* shouldn't happen *) | Datatypes.cons x tx => match yn with | Datatypes.nil => n | Datatypes.cons y ty => if Qlt_le_dec y x then S (merge_aux ty n) else (match n with O => O | S p => S (MergeInjectL tx yn p) end) end end in merge_aux yn n. Lemma MergeInjectLSpec : forall (gas n : nat) (xn yn : list Q), lt (length xn + length yn) gas -> lt n (length xn) -> nth (MergeInjectL xn yn n) (merge xn yn) 0%Q = nth n xn 0%Q. Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct xn. + simpl. destruct yn. destruct n; reflexivity. exfalso; inversion H0. + destruct yn. simpl; destruct n; reflexivity. simpl. destruct (Qlt_le_dec q0 q). * destruct (Qle_bool q q0) eqn:des. exfalso. pose proof (Qle_bool_iff q q0) as [H1 _]. apply (Qlt_not_le _ _ q1), H1, des. simpl. specialize (IHgas n (q :: xn) yn). simpl in IHgas. rewrite IHgas. reflexivity. simpl (length (q0 :: yn)) in H. rewrite Nat.add_succ_r in H. apply le_S_n in H. exact H. exact H0. * (* head of x first *) destruct n. (* equal q, no need of induction hypo *) destruct (Qle_bool q q0) eqn:des. reflexivity. exfalso. pose proof (Qle_bool_iff q q0) as [_ H1]. rewrite H1 in des. discriminate. exact q1. specialize (IHgas n xn (q0 :: yn)). destruct (Qle_bool q q0) eqn:des. simpl. rewrite IHgas. reflexivity. simpl. simpl in H. apply le_S_n in H. exact H. simpl in H0. apply le_S_n in H0. exact H0. exfalso. pose proof (Qle_bool_iff q q0) as [_ H1]. rewrite H1 in des. discriminate. exact q1. Qed. Lemma MergeInjectLInc : forall (gas n : nat) (xn yn : list Q), lt (length xn + length yn) gas -> lt (S n) (length xn) -> lt (MergeInjectL xn yn n) (MergeInjectL xn yn (S n)). Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct xn. exfalso; inversion H0. destruct yn. apply Nat.le_refl. simpl. destruct (Qlt_le_dec q0 q). + apply le_n_S. apply (IHgas n (q :: xn) yn). simpl in H. apply le_S_n in H. simpl. rewrite Nat.add_succ_r in H. exact H. exact H0. + destruct n. apply le_n_S, Nat.le_0_l. apply le_n_S. apply IHgas. simpl in H. apply le_S_n in H. exact H. simpl in H0. apply le_S_n in H0. exact H0. Qed. Lemma MergeInjectLBound : forall (gas n : nat) (xn yn : list Q), lt (length xn + length yn) gas -> lt n (length xn) -> lt (MergeInjectL xn yn n) (length xn + length yn). Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct xn. exfalso; inversion H0. destruct yn. simpl. rewrite Nat.add_0_r. exact H0. simpl. destruct (Qlt_le_dec q0 q). + apply le_n_S. specialize (IHgas n (q :: xn) yn). rewrite Nat.add_succ_r. apply IHgas. simpl in H. apply le_S_n in H. rewrite Nat.add_succ_r in H. exact H. exact H0. + destruct n. apply le_n_S, Nat.le_0_l. apply le_n_S. apply IHgas. simpl in H. apply le_S_n in H. exact H. simpl in H0. apply le_S_n in H0. exact H0. Qed. (* index of yn n inside merge xn yn. Inner fixpoint allows to prove that recursive calls terminate. *) Fixpoint MergeInjectR (xn yn : list Q) (n : nat) { struct xn } : nat := let fix merge_aux yn n := match xn with | Datatypes.nil => n | Datatypes.cons x tx => match yn with | Datatypes.nil => O (* shouldn't happen *) | Datatypes.cons y ty => if Qlt_le_dec y x then (match n with O => O | S p => S (merge_aux ty p) end) else S (MergeInjectR tx yn n) end end in merge_aux yn n. Lemma MergeInjectRSpec : forall (gas n : nat) (xn yn : list Q), lt (length xn + length yn) gas -> lt n (length yn) -> nth (MergeInjectR xn yn n) (merge xn yn) 0%Q = nth n yn 0%Q. Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct xn. + simpl. destruct yn; reflexivity. + destruct yn. exfalso; inversion H0. simpl. destruct (Qlt_le_dec q0 q). * destruct n. destruct (Qle_bool q q0) eqn:des. exfalso. pose proof (Qle_bool_iff q q0) as [H1 _]. apply (Qlt_not_le _ _ q1), H1, des. reflexivity. destruct (Qle_bool q q0) eqn:des. exfalso. pose proof (Qle_bool_iff q q0) as [H1 _]. apply (Qlt_not_le _ _ q1), H1, des. specialize (IHgas n (q :: xn) yn). simpl. simpl in IHgas. rewrite IHgas. reflexivity. clear IHgas. simpl in H. apply le_S_n in H. rewrite Nat.add_succ_r in H. exact H. simpl in H0. apply le_S_n in H0. exact H0. * (* head of x first *) destruct (Qle_bool q q0) eqn:des. simpl. rewrite IHgas. reflexivity. simpl. simpl in H. apply le_S_n in H. exact H. simpl in H0. exact H0. exfalso. pose proof (Qle_bool_iff q q0) as [_ H1]. rewrite H1 in des. discriminate. exact q1. Qed. Lemma MergeInjectRInc : forall (gas n : nat) (xn yn : list Q), lt (length xn + length yn) gas -> lt (S n) (length yn) -> lt (MergeInjectR xn yn n) (MergeInjectR xn yn (S n)). Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct yn as [|q0 yn]. exfalso; inversion H0. destruct xn as [|q xn]. apply Nat.le_refl. simpl. destruct (Qlt_le_dec q0 q). + destruct n. apply le_n_S, Nat.le_0_l. apply le_n_S. apply (IHgas n (q :: xn) yn). simpl in H. apply le_S_n in H. simpl. rewrite Nat.add_succ_r in H. exact H. simpl in H0. apply le_S_n in H0. exact H0. + apply le_n_S. apply IHgas. simpl in H. apply le_S_n in H. simpl. exact H. exact H0. Qed. Lemma MergeInjectRBound : forall (gas n : nat) (xn yn : list Q), lt (length xn + length yn) gas -> lt n (length yn) -> lt (MergeInjectR xn yn n) (length xn + length yn). Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct yn as [|q0 yn]. exfalso; inversion H0. destruct xn as [|q xn]. simpl. exact H0. simpl. destruct (Qlt_le_dec q0 q). + destruct n. apply le_n_S, Nat.le_0_l. apply le_n_S. rewrite Nat.add_succ_r. apply (IHgas n (q :: xn) yn). simpl in H. apply le_S_n in H. rewrite Nat.add_succ_r in H. exact H. simpl in H0. apply le_S_n in H0. exact H0. + apply le_n_S. apply (IHgas n xn (q0 :: yn)). simpl in H. apply le_S_n in H. exact H. exact H0. Qed. Lemma LastCons : forall (xn : list Q) (q : Q), lt 0 (length xn) -> last (q :: xn) 0%Q = last xn 0%Q. Proof. intros. destruct xn. exfalso; inversion H. reflexivity. Qed. Lemma MergeLast : forall (gas : nat) (xn yn : list Q), lt (length xn + length yn) gas -> (lt 0 (length xn) \/ lt 0 (length yn)) -> ((lt 0 (length xn) /\ last (merge xn yn) 0%Q = last xn 0%Q) \/ (lt 0 (length yn) /\ last (merge xn yn) 0%Q = last yn 0%Q)). Proof. induction gas. - intros. exfalso; inversion H. - intros. destruct xn. right. split. destruct H0. exfalso; inversion H0. exact H0. destruct yn; reflexivity. (* xn not empty *) destruct yn. left. split. simpl. apply le_n_S, Nat.le_0_l. simpl. reflexivity. simpl. destruct (Qle_bool q q0) eqn:des. + specialize (IHgas xn (q0 :: yn)). simpl in IHgas. destruct IHgas. simpl in H. apply le_S_n in H. exact H. right. apply le_n_S, Nat.le_0_l. * destruct H1. left. split. apply le_n_S, Nat.le_0_l. rewrite LastCons. rewrite H2. destruct xn. exfalso; inversion H1. reflexivity. rewrite MergeLength. simpl. rewrite Nat.add_succ_r. apply le_n_S, Nat.le_0_l. * destruct H1 as [_ H1]. right. split. apply le_n_S, Nat.le_0_l. rewrite <- H1. pose proof (MergeLength xn (q0 :: yn)). simpl. destruct (merge xn (q0 :: yn)). exfalso. simpl in H2. rewrite Nat.add_succ_r in H2. discriminate. reflexivity. + specialize (IHgas (q :: xn) yn). destruct IHgas. simpl in H. apply le_S_n in H. rewrite Nat.add_succ_r in H. exact H. left. apply le_n_S, Nat.le_0_l. * destruct H1 as [_ H1]. left. split. apply le_n_S, Nat.le_0_l. rewrite LastCons. simpl in H1. rewrite H1. reflexivity. pose proof (MergeLength (q :: xn) yn). simpl in H2. rewrite H2. apply le_n_S, Nat.le_0_l. * destruct H1. right. split. apply le_n_S, Nat.le_0_l. rewrite LastCons. simpl in H2. rewrite H2. destruct yn. exfalso; inversion H1. reflexivity. pose proof (MergeLength (q :: xn) yn). simpl in H3. rewrite H3. apply le_n_S, Nat.le_0_l. Qed. Lemma LastNth : forall (xn : list Q), lt 0 (length xn) -> last xn 0%Q = nth (pred (length xn)) xn 0%Q. Proof. induction xn. - reflexivity. - intros. clear H. destruct xn. reflexivity. transitivity (last (q :: xn) 0%Q). reflexivity. rewrite IHxn. reflexivity. simpl. apply le_n_S, Nat.le_0_l. Qed. Definition RationalPartitionMerge {R : ConstructiveReals} (a b : CRcarrier R) (P Q : @IntervalPartition R a b) : IntervalPartitionRational P -> IntervalPartitionRational Q -> @IntervalPartition R a b. Proof. intros. apply (Build_IntervalPartition R a b (fun n:nat => CR_of_Q R (nth n (merge (proj1_sig H) (proj1_sig H0)) 0%Q)) (2+ipt_last P + ipt_last Q)). - destruct H, H0; unfold proj1_sig. destruct a0, a1. destruct x. exfalso; inversion H. destruct x0. exfalso; inversion H1. specialize (H0 O). simpl in H0. specialize (H2 O). simpl in H2. simpl. destruct (Qle_bool q q0) eqn:des. + simpl. rewrite <- H0. apply P. apply Nat.le_0_l. + exfalso. assert (q == q0)%Q. apply (@eq_inject_Q R). rewrite <- H0, <- H2. transitivity a. symmetry. apply P. apply Q. apply Nat.le_0_l. apply Nat.le_0_l. rewrite <- H3 in des. clear H3. pose proof (Qle_bool_iff q q) as [_ H4]. rewrite H4 in des. discriminate. apply Qle_refl. - destruct H, H0; unfold proj1_sig. destruct a0, a1. destruct (MergeLast (S (2+ ipt_last P + (2+ipt_last Q))) x x0). rewrite H, H1. apply Nat.le_refl. left. rewrite H. apply le_n_S, Nat.le_0_l. + rewrite LastNth, MergeLength in H3. rewrite (LastNth x), H in H3. simpl in H3. transitivity (ipt_seq P (S (ipt_last P))). apply P. rewrite H0. 2: apply Nat.le_refl. apply CR_of_Q_morph. destruct H3. rewrite <- H4, H1. replace (ipt_last P + (2 + ipt_last Q))%nat with (2 + ipt_last P + ipt_last Q)%nat. reflexivity. rewrite (Nat.add_comm 2), Nat.add_assoc. reflexivity. rewrite H. apply le_n_S, Nat.le_0_l. rewrite MergeLength. apply (Nat.lt_trans _ (0 + length x0)). simpl. rewrite H1. apply le_n_S, Nat.le_0_l. apply Nat.add_lt_mono_r. rewrite H. apply le_n_S, Nat.le_0_l. + rewrite LastNth, MergeLength in H3. rewrite (LastNth x0), H1 in H3. simpl in H3. transitivity (ipt_seq Q (S (ipt_last Q))). apply Q. rewrite H2. 2: apply Nat.le_refl. apply CR_of_Q_morph. destruct H3. rewrite <- H4, H. simpl. replace (ipt_last P + S (S (ipt_last Q)))%nat with (2 + ipt_last P + ipt_last Q)%nat. reflexivity. rewrite (Nat.add_comm 2), <- Nat.add_assoc. reflexivity. rewrite H1. apply le_n_S, Nat.le_0_l. rewrite MergeLength. apply (Nat.lt_trans _ (0 + length x0)). simpl. rewrite H1. apply le_n_S, Nat.le_0_l. apply Nat.add_lt_mono_r. rewrite H. apply le_n_S, Nat.le_0_l. - pose proof (PartitionRationalLocSorted a b P H) as sortP. pose proof (PartitionRationalLocSorted a b Q H0) as sortQ. intros. apply CR_of_Q_le. destruct H, H0; unfold proj1_sig; unfold proj1_sig in sortP, sortQ. pose proof (Sorted_merge x x0 sortP sortQ). apply (LocSortedFun _ H n). rewrite MergeLength. destruct a0, a1. rewrite H0, H3. simpl. apply le_n_S, le_n_S. apply (Nat.le_trans _ _ _ H1). do 2 rewrite Nat.add_succ_r. apply Nat.le_refl. Defined. Lemma ordered_transit : forall (xn : nat -> nat) (last : nat), (forall n:nat, S n <= last -> xn n < xn (S n))%nat -> (forall n p:nat, lt n p -> p <= last -> (xn n < xn p))%nat. Proof. induction p. - intros. exfalso. inversion H0. - intros. apply Nat.le_succ_r in H0. destruct H0. apply (Nat.lt_trans _ (xn p)). apply IHp. exact H0. apply (Nat.le_trans _ (S p)). apply le_S, Nat.le_refl. exact H1. apply H. exact H1. inversion H0. subst n. apply H. exact H1. Qed. Definition CommonChaslesRefinement {R : ConstructiveReals} {a b : CRcarrier R} (P Q : @IntervalPartition R a b) : Prop := exists (ccr_subseqP : nat -> nat) (ccr_subseqQ : nat -> nat) (ccr_refinement : @IntervalPartition R a b), IntervalPartitionRefinement a b P ccr_refinement ccr_subseqP /\ IntervalPartitionRefinement a b Q ccr_refinement ccr_subseqQ. (* The rational numbers have a total order, which allows to merge 2 sorted lists. *) Lemma CommonRationalRefinement : forall {R : ConstructiveReals} (a b : CRcarrier R) (P Q : @IntervalPartition R a b), IntervalPartitionRational P -> IntervalPartitionRational Q -> @CommonChaslesRefinement R a b P Q. Proof. intros. exists (fun n => MergeInjectL (proj1_sig H) (proj1_sig H0) n), (fun n => MergeInjectR (proj1_sig H) (proj1_sig H0) n), (RationalPartitionMerge a b P Q H H0). split. - destruct H,H0; unfold proj1_sig. split. 2: split. + intros. unfold RationalPartitionMerge, ipt_seq; unfold proj1_sig. destruct P,Q; simpl in a0; unfold ipt_last in H; unfold ipt_last; unfold ipt_last, ipt_seq in a1. destruct a0, a1. rewrite H1. 2: exact H. apply CR_of_Q_morph. rewrite (MergeInjectLSpec (S (2 + ipt_last0 + (2+ ipt_last1)))). reflexivity. rewrite H0, H2. apply Nat.le_refl. rewrite H0. apply le_n_S, H. + apply ordered_transit. intros. destruct a0, a1. apply (MergeInjectLInc (S (2 + ipt_last P + (2+ ipt_last Q)))). rewrite H0, H2. apply Nat.le_refl. rewrite H0. apply le_n_S, H. + unfold RationalPartitionMerge, ipt_last. destruct P,Q; simpl in a0, a1. intros. destruct a0, a1. apply le_S_n. apply (Nat.le_trans _ (S (S ipt_last0) + S (S ipt_last1))). rewrite <- H0, <- H2. apply (MergeInjectLBound (S (2 + ipt_last0 + (2+ ipt_last1)))). rewrite H0, H2. apply Nat.le_refl. rewrite H0. apply le_n_S, H. simpl. do 2 rewrite Nat.add_succ_r. apply Nat.le_refl. - destruct H,H0; unfold proj1_sig. split. 2: split. + intros. unfold RationalPartitionMerge, ipt_seq; unfold proj1_sig. destruct P,Q; simpl in a0; unfold ipt_last in H; unfold ipt_last; unfold ipt_last, ipt_seq in a1. destruct a0, a1. rewrite H3. 2: exact H. apply CR_of_Q_morph. rewrite (MergeInjectRSpec (S (2 + ipt_last0 + (2+ ipt_last1)))). reflexivity. rewrite H0, H2. apply Nat.le_refl. rewrite H2. apply le_n_S, H. + apply ordered_transit. intros. destruct a0, a1. apply (MergeInjectRInc (S (2 + ipt_last P + (2+ ipt_last Q)))). rewrite H0, H2. apply Nat.le_refl. rewrite H2. apply le_n_S, H. + unfold RationalPartitionMerge, ipt_last. destruct P,Q; simpl in a0, a1. intros. destruct a0, a1. apply le_S_n. apply (Nat.le_trans _ (S (S ipt_last0) + S (S ipt_last1))). rewrite <- H0, <- H2. apply (MergeInjectRBound (S (2 + ipt_last0 + (2+ ipt_last1)))). rewrite H0, H2. apply Nat.le_refl. rewrite H2. apply le_n_S, H. simpl. do 2 rewrite Nat.add_succ_r. apply Nat.le_refl. Qed. (* Need a total order to merge partitions. Keep them rational for now, it is sufficient to bootstrap the constructive theory of measure. *) Lemma UC_integral_chasles_rat : forall {R : ConstructiveReals} (a b c : Q) (f : CRcarrier R -> CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : (CR_of_Q R a) <= (CR_of_Q R b)) (lebc : (CR_of_Q R b) <= (CR_of_Q R c)) (leac : (CR_of_Q R a) <= (CR_of_Q R c)), UC_integral f (CR_of_Q R a) (CR_of_Q R c) cont_mod fCont leac == UC_integral f (CR_of_Q R a) (CR_of_Q R b) cont_mod fCont leab + UC_integral f (CR_of_Q R b) (CR_of_Q R c) cont_mod fCont lebc. Proof. intros. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => (CR_of_Q R a + (CR_of_Q R c - CR_of_Q R a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (CR_of_Q R a + (CR_of_Q R c - CR_of_Q R a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last) (UC_integral_cauchy f (CR_of_Q R a) (CR_of_Q R c) cont_mod fCont leac)) as [l lcv]. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => CR_of_Q R a + (CR_of_Q R b - CR_of_Q R a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => CR_of_Q R a + (CR_of_Q R b - CR_of_Q R a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f (CR_of_Q R a) (CR_of_Q R b) cont_mod fCont leab)) as [lab H]. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => CR_of_Q R b + (CR_of_Q R c - CR_of_Q R b) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => CR_of_Q R b + (CR_of_Q R c - CR_of_Q R b) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f (CR_of_Q R b) (CR_of_Q R c) cont_mod fCont lebc)) as [lbc H0]. apply (CR_cv_unique _ _ _ lcv). intros n. assert (0 < 1+CR_of_Q R c - CR_of_Q R a) as invStepPos. { apply (CRlt_le_trans _ (1 + 0)). rewrite CRplus_0_r. apply CRzero_lt_one. unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite <- (CRplus_opp_r (CR_of_Q R a)). apply CRplus_le_compat. exact leac. apply CRle_refl. } assert (0 < CR_of_Q R (1 # 4*n) * CRinv R (1+CR_of_Q R c - CR_of_Q R a) (inr invStepPos)) as stepPos. { apply CRmult_lt_0_compat. apply CR_of_Q_lt; reflexivity. apply CRinv_0_lt_compat. exact invStepPos. } destruct (CRup_nat ((CR_of_Q R c-CR_of_Q R a) * CRinv R (cont_mod _ stepPos) (inr ((fst fCont) _ stepPos)))) as [p pmaj]. destruct (CRup_nat ((CR_of_Q R b-CR_of_Q R a) * CRinv R (cont_mod _ stepPos) (inr ((fst fCont) _ stepPos)))) as [q qmaj]. destruct (CRup_nat ((CR_of_Q R c-CR_of_Q R b) * CRinv R (cont_mod _ stepPos) (inr ((fst fCont) _ stepPos)))) as [r rmaj]. specialize (H (4*n)%positive) as [i imaj]. specialize (H0 (4*n)%positive) as [j jmaj]. exists p. intros i0 H. pose (IntervalPartitionConcat (IntervalEquiPartition (CR_of_Q R a) (CR_of_Q R b) (max i q) leab) (IntervalEquiPartition (CR_of_Q R b) (CR_of_Q R c) (max j r) lebc)) as conc. setoid_replace (IntegralFiniteSum f (fun n0 : nat => CR_of_Q R a + (CR_of_Q R c - CR_of_Q R a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S i0))) (fun n0 : nat => CR_of_Q R a + (CR_of_Q R c - CR_of_Q R a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S i0))) i0 - (lab + lbc)) with (IntegralFiniteSum f (fun n0 : nat => CR_of_Q R a + (CR_of_Q R c - CR_of_Q R a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S i0))) (fun n0 : nat => CR_of_Q R a + (CR_of_Q R c - CR_of_Q R a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S i0))) i0 - IntegralFiniteSum f (ipt_seq conc) (ipt_seq conc) (ipt_last conc) + (IntegralFiniteSum f (ipt_seq conc) (ipt_seq conc) (ipt_last conc) - (lab + lbc))). apply (CRle_trans _ _ _ (CRabs_triang _ _)). setoid_replace (CR_of_Q R (1 # n)) with (CR_of_Q R (1 # 2*n) + CR_of_Q R (1 # 2*n)). apply CRplus_le_compat. - apply (CRle_trans _ ((CR_of_Q R (1# 4*n) * CRinv R (1+CR_of_Q R c - CR_of_Q R a) (inr invStepPos) + CR_of_Q R (1# 4*n) * CRinv R (1+CR_of_Q R c - CR_of_Q R a) (inr invStepPos)) * (CR_of_Q R c-CR_of_Q R a))). destruct (CommonRationalRefinement (CR_of_Q R a) (CR_of_Q R c) (IntervalEquiPartition (CR_of_Q R a) (CR_of_Q R c) i0 leac) conc) as [ccr_subseqP0 [ccr_subseqQ0 [ccr_refinement0 [ccr_refineP0 ccr_refineQ0]]]]. apply EquiPartitionRational. apply PartitionRationalConcat. apply EquiPartitionRational. apply EquiPartitionRational. apply (UC_compare_integrals f (CR_of_Q R a) (CR_of_Q R c) _ _ cont_mod (IntervalEquiPartition (CR_of_Q R a) (CR_of_Q R c) i0 leac) conc ccr_refinement0 stepPos stepPos ccr_subseqP0 ccr_subseqQ0 fCont ccr_refineP0 ccr_refineQ0). + rewrite EquiPartitionMesh. apply (CRmult_lt_compat_r (cont_mod _ stepPos)) in pmaj. 2: apply (fst fCont). rewrite CRmult_assoc, CRinv_l, CRmult_1_r in pmaj. apply (CRmult_lt_reg_r (CR_of_Q R (Z.of_nat (S i0) # 1))). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S i0)) * (Z.of_nat (S i0) # 1))%Q with 1%Q. rewrite CRmult_1_r. apply (CRlt_le_trans _ _ _ pmaj). rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, (fst fCont). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, H. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, Pos.mul_1_r. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. reflexivity. discriminate. + assert (PartitionMesh (ipt_seq conc) (S (ipt_last conc)) == CRmax ((CR_of_Q R b- CR_of_Q R a) * CR_of_Q R (1# Pos.of_nat (S (max i q)))) ((CR_of_Q R c- CR_of_Q R b) * CR_of_Q R (1# Pos.of_nat (S (max j r))))). { unfold conc. rewrite PartitionMeshConcat. apply CRmax_morph; apply EquiPartitionMesh. } rewrite H0. apply CRmax_lub_lt. apply (CRmult_lt_compat_r (cont_mod _ stepPos)) in qmaj. 2: apply (fst fCont). rewrite CRmult_assoc, CRinv_l, CRmult_1_r in qmaj. apply (CRmult_lt_reg_r (CR_of_Q R (Z.of_nat (S (Init.Nat.max i q)) # 1))). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S (Init.Nat.max i q))) * (Z.of_nat (S (Init.Nat.max i q)) # 1))%Q with 1%Q. rewrite CRmult_1_r. apply (CRlt_le_trans _ _ _ qmaj). rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, (fst fCont). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_max_r. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, Pos.mul_1_r. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. reflexivity. discriminate. apply (CRmult_lt_compat_r (cont_mod _ stepPos)) in rmaj. 2: apply (fst fCont). rewrite CRmult_assoc, CRinv_l, CRmult_1_r in rmaj. apply (CRmult_lt_reg_r (CR_of_Q R (Z.of_nat (S (Init.Nat.max j r)) # 1))). apply CR_of_Q_lt; reflexivity. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S (Init.Nat.max j r))) * (Z.of_nat (S (Init.Nat.max j r)) # 1))%Q with 1%Q. rewrite CRmult_1_r. apply (CRlt_le_trans _ _ _ rmaj). rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, (fst fCont). apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. apply Nat2Z.inj_le, le_S, Nat.le_max_r. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, Pos.mul_1_r. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. reflexivity. discriminate. + rewrite <- (CRmult_1_r (CR_of_Q R (1 # 4 * n) * CRinv R (1 + CR_of_Q R c - CR_of_Q R a) (inr invStepPos))). rewrite <- CRmult_plus_distr_l. rewrite (CRmult_comm (CR_of_Q R (1#4*n))). apply (CRmult_le_reg_l (1 + CR_of_Q R c - CR_of_Q R a)). exact invStepPos. do 3 rewrite <- CRmult_assoc. rewrite CRinv_r, CRmult_1_l. setoid_replace (CR_of_Q R (1 # 4 * n) * (1 + 1)) with (CR_of_Q R (1 # 2 * n)). rewrite CRmult_comm. apply CRmult_le_compat_r. apply CR_of_Q_le. discriminate. rewrite <- (CRplus_0_l (CR_of_Q R c - CR_of_Q R a)). unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_r. exact (CRlt_asym 0 1 (CRzero_lt_one R)). rewrite <- (CR_of_Q_plus R 1 1), <- CR_of_Q_mult. apply CR_of_Q_morph. unfold Qeq, Qnum, Qden. simpl. rewrite Pos.mul_1_r. reflexivity. - unfold conc. rewrite <- IntervalPartitionConcatSum. unfold IntervalEquiPartition, ipt_seq, ipt_last. setoid_replace (CR_of_Q R (1 # 2 * n)) with (CR_of_Q R (1 # 4 * n) + CR_of_Q R (1 # 4 * n)). assert (forall a b c d : CRcarrier R, CRabs _ (a + b - (c + d)) <= CRabs _ (a - c) + CRabs _ (b - d)). intros. setoid_replace (a0 + b0 - (c0 + d)) with ((a0 - c0) + (b0 - d)). apply CRabs_triang. unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite (CRplus_comm (-c0)). rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr, CRplus_comm. reflexivity. apply (CRle_trans _ _ _ (H0 _ _ _ _)). apply CRplus_le_compat. apply imaj, Nat.le_max_l. apply jmaj, Nat.le_max_l. rewrite <- CR_of_Q_plus, Qinv_plus_distr. apply CR_of_Q_morph. reflexivity. - rewrite <- CR_of_Q_plus, Qinv_plus_distr. apply CR_of_Q_morph. reflexivity. - unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Lemma UC_right_bound_cv : forall {R : ConstructiveReals} (a b : CRcarrier R) (bn : nat -> CRcarrier R) (f : CRcarrier R -> CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : a <= b) (lebbn : forall n:nat, b <= bn n), CR_cv R bn b -> CR_cv R (fun n : nat => UC_integral f a (bn n) cont_mod fCont (CRle_trans a b (bn n) leab (lebbn n))) (UC_integral f a b cont_mod fCont leab). Proof. intros. intro p. assert (0 < CR_of_Q R (1 # p)). { apply CR_of_Q_pos. reflexivity. } destruct (UC_right_bound_continuous f a b leab _ H0 cont_mod fCont) as [eta [etaPos etaMaj]]. pose proof (Un_cv_nat_real _ _ H eta etaPos) as [n nmaj]. exists n. intros. rewrite CRabs_minus_sym. assert (bn i < b + eta). { specialize (nmaj i H1). apply (CRplus_lt_reg_l R (-b)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm. exact (CRle_lt_trans _ _ _ (CRle_abs _) nmaj). } apply (etaMaj (bn i) (pair (lebbn i) H2)). Qed. Lemma UC_integral_chasles_rat_rat : forall {R : ConstructiveReals} (a b : Q) (c : CRcarrier R) (f : CRcarrier R -> CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : (CR_of_Q R a) <= (CR_of_Q R b)) (lebc : (CR_of_Q R b) <= c) (leac : (CR_of_Q R a) <= c), UC_integral f (CR_of_Q R a) c cont_mod fCont leac == UC_integral f (CR_of_Q R a) (CR_of_Q R b) cont_mod fCont leab + UC_integral f (CR_of_Q R b) c cont_mod fCont lebc. Proof. intros. assert (forall n : nat, c < c + CR_of_Q R (1 # Pos.of_nat (S n))). { intro n. apply (CRle_lt_trans _ (c+0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l, CR_of_Q_pos. reflexivity. } pose (fun n => let (q,_) := CR_Q_dense R c (c + CR_of_Q R (1 # Pos.of_nat (S n))) (H n) in q) as cn. assert (forall n:nat, c <= CR_of_Q R (cn n)) as H0. { intro n. unfold cn. destruct (CR_Q_dense R c (c + CR_of_Q R (1 # Pos.of_nat (S n))) (H n)). apply CRlt_asym, p. } assert (CR_cv R (fun n : nat => CR_of_Q R (cn n)) c) as cvRight. { intro p. exists (Pos.to_nat p). intros. unfold cn. destruct (CR_Q_dense R c (c + CR_of_Q R (1 # Pos.of_nat (S i))) (H i)). rewrite CRabs_right. apply (CRplus_le_reg_r c). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. apply CRlt_asym, (CRlt_le_trans _ _ _ (snd p0)). apply CRplus_le_compat_l. apply CR_of_Q_le. apply Pos2Z.pos_le_pos. unfold Qden. do 2 rewrite Pos.mul_1_l. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply le_S, H1. discriminate. rewrite <- (CRplus_opp_r c). apply CRplus_le_compat_r. apply CRlt_asym, p0. } apply (CR_cv_unique (fun n => UC_integral f (CR_of_Q R a) (CR_of_Q R (cn n)) cont_mod fCont (CRle_trans _ _ _ leac (H0 n)))). - apply (UC_right_bound_cv (CR_of_Q R a) c (fun n => CR_of_Q R (cn n)) f cont_mod fCont leac). exact cvRight. - apply (CR_cv_eq _ (fun n : nat => UC_integral f (CR_of_Q R a) (CR_of_Q R b) cont_mod fCont leab + UC_integral f (CR_of_Q R b) (CR_of_Q R (cn n)) cont_mod fCont (CRle_trans _ _ _ lebc (H0 n)))). intro n. symmetry. apply (UC_integral_chasles_rat a b (cn n) f). apply CR_cv_plus. apply CR_cv_const. exact (UC_right_bound_cv (CR_of_Q R b) c (fun n => CR_of_Q R (cn n)) f _ _ _ _ cvRight). Qed. Lemma UC_integral_slide_cv : forall {R : ConstructiveReals} (a b : CRcarrier R) (f : CRcarrier R -> CRcarrier R) (cont_mod : forall eps : CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : a <= b) (an : nat -> CRcarrier R) (lebbn : forall n:nat, an n <= b + (an n - a)), CR_cv R an a -> CR_cv R (fun n : nat => UC_integral f (an n) (b + (an n - a)) cont_mod fCont (lebbn n)) (UC_integral f a b cont_mod fCont leab). Proof. intros. intro p. assert (forall i j k : CRcarrier R, i + j - (i + k) == j - k) as addSub. { intros. unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. } assert (0 < b-a+1). { rewrite <- (CRplus_opp_l a). unfold CRminus. rewrite (CRplus_comm b), CRplus_assoc. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ (b+0)). rewrite CRplus_0_r. exact leab. apply CRplus_lt_compat_l, CRzero_lt_one. } assert (0 < CR_of_Q R (1#p) * CRinv R (b-a+1) (inr H0)) as H1. { destruct fCont. apply CRmult_lt_0_compat. apply CR_of_Q_pos. reflexivity. apply CRinv_0_lt_compat, H0. } pose proof (Un_cv_nat_real _ _ H _ (fst fCont _ H1)) as [n nmaj]. exists n. intros. apply (CR_cv_bound_up (fun last : nat => CRabs R (IntegralFiniteSum f (fun n => an i + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n => an i + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last - IntegralFiniteSum f (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n => a + (b-a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last)) (CR_of_Q R (1#p)) _ O). - intros n0 _. unfold IntegralFiniteSum. unfold CRminus. rewrite <- sum_opp, <- sum_plus. rewrite (CRsum_eq _ (fun n1 => (f (an i + (b + - a) * CR_of_Q R (Z.of_nat n1 # Pos.of_nat (S n0))) - f (a + (b + - a) * CR_of_Q R (Z.of_nat n1 # Pos.of_nat (S n0)))) * (b + - a) * CR_of_Q R (1 # Pos.of_nat (S n0)))). + rewrite sum_scale, sum_scale. specialize (nmaj i H2). rewrite CRmult_assoc, CRabs_mult. apply (CRle_trans _ ((CRsum (fun _ : nat => CR_of_Q R (1 # p) * CRinv R (b - a + 1) (inr H0)) n0) * CRabs R (CR_of_Q R (1 # Pos.of_nat (S n0)) * (b + - a)))). rewrite <- (CRmult_comm (b+-a)). apply CRmult_le_compat_r. apply CRabs_pos. apply (CRle_trans _ _ _ (multiTriangleIneg _ _)). apply sum_Rle. intros. apply CRlt_asym, (snd fCont _ _ _ H1). rewrite (CRplus_comm (an i)), (CRplus_comm a), addSub. exact nmaj. rewrite sum_const, CRabs_right, CRmult_assoc, <- (CRmult_1_r (CR_of_Q R (1 # p))). do 2 rewrite CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, CR_of_Q_pos. reflexivity. rewrite CRmult_1_l. unfold INR. rewrite CRmult_comm, <- CRmult_assoc. rewrite <- CR_of_Q_mult. setoid_replace ((Z.of_nat (S n0) # 1) * (1 # Pos.of_nat (S n0)))%Q with 1%Q. rewrite CRmult_1_l. apply (CRmult_le_reg_r (b-a+1) _ _ H0). rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. apply (CRle_trans _ (b-a + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_le_compat_l. apply CRlt_asym, CRzero_lt_one. unfold Z.of_nat. rewrite Pos.of_nat_succ. unfold Qeq. simpl. do 2 rewrite Pos.mul_1_r. reflexivity. apply CRmult_le_0_compat. apply CR_of_Q_le. discriminate. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r. exact leab. + intros. rewrite (addSub (an i) ((b + - a) * CR_of_Q R (Z.of_nat (S i0) # Pos.of_nat (S n0))) ((b + - a) * CR_of_Q R (Z.of_nat i0 # Pos.of_nat (S n0)))). rewrite (addSub a ((b + - a) * CR_of_Q R (Z.of_nat (S i0) # Pos.of_nat (S n0))) ((b + - a) * CR_of_Q R (Z.of_nat i0 # Pos.of_nat (S n0)))). rewrite CRopp_mult_distr_l, <- CRmult_plus_distr_r. unfold CRminus. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. rewrite CRmult_assoc. apply CRmult_morph. reflexivity. apply CRmult_morph. reflexivity. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_minus_distr. replace (Z.of_nat (S i0) - Z.of_nat i0)%Z with 1%Z. reflexivity. rewrite Nat2Z.inj_succ. unfold Z.succ. ring. - apply CR_cv_abs_cont. apply CR_cv_minus. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n0 : nat => an i + (b + (an i - a) - an i) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) (fun n0 : nat => an i + (b + (an i - a) - an i) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) last) (UC_integral_cauchy f (an i) (b + (an i - a)) cont_mod fCont (lebbn i))). apply (CR_cv_eq _ (fun last : nat => IntegralFiniteSum f (fun n0 : nat => an i + (b + (an i - a) - an i) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) (fun n0 : nat => an i + (b + (an i - a) - an i) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) last)). 2: exact c. intros. apply CRsum_eq. intros. rewrite (UniformContProper f cont_mod fCont _ (an i + (b - a) * CR_of_Q R (Z.of_nat i0 # Pos.of_nat (S n0)))). setoid_replace (b + (an i - a) - an i) with (b-a). reflexivity. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l. apply CRplus_0_l. apply CRplus_morph. reflexivity. apply CRmult_morph. 2: reflexivity. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l. apply CRplus_0_l. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n0 : nat => a + (b - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) (fun n0 : nat => a + (b - a) * CR_of_Q R (Z.of_nat n0 # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b cont_mod fCont leab)). exact c. Qed. Lemma UC_integral_chasles_rat_rat_rat : forall {R : ConstructiveReals} (a : Q) (b c : CRcarrier R) (f : CRcarrier R -> CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : (CR_of_Q R a) <= b) (lebc : b <= c) (leac : (CR_of_Q R a) <= c), UC_integral f (CR_of_Q R a) c cont_mod fCont leac == UC_integral f (CR_of_Q R a) b cont_mod fCont leab + UC_integral f b c cont_mod fCont lebc. Proof. intros. assert (forall n : nat, b < b + CR_of_Q R (1 # Pos.of_nat (S n))). { intro n. apply (CRle_lt_trans _ (b+0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_lt_compat_l, CR_of_Q_pos. reflexivity. } pose (fun n => let (q,_) := CR_Q_dense R b (b + CR_of_Q R (1 # Pos.of_nat (S n))) (H n) in q) as bn. assert (CR_cv R (fun n : nat => CR_of_Q R (bn n)) b) as cvb. { intro p. exists (Pos.to_nat p). intros. unfold bn. destruct (CR_Q_dense R b (b + CR_of_Q R (1 # Pos.of_nat (S i))) (H i)). rewrite CRabs_right. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. apply CRlt_asym, (CRlt_le_trans _ _ _ (snd p0)). apply CRplus_le_compat_l. apply CR_of_Q_le. apply Pos2Z.pos_le_pos. unfold Qden. do 2 rewrite Pos.mul_1_l. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply le_S, H0. discriminate. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r. apply CRlt_asym, p0. } assert (forall n:nat, b <= CR_of_Q R (bn n)) as H0. { intro n. unfold bn. destruct (CR_Q_dense R b (b + CR_of_Q R (1 # Pos.of_nat (S n))) (H n)). apply CRlt_asym, p. } pose (fun n => c + (CR_of_Q R (bn n) - b)) as cn. assert (forall n:nat, CR_of_Q R (bn n) <= cn n). { intro n. unfold cn. rewrite CRplus_comm. apply (CRplus_le_reg_r (-c)). rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply CRplus_le_compat_l, CRopp_ge_le_contravar. exact lebc. } apply (CR_cv_unique (fun n => UC_integral f (CR_of_Q R a) (CR_of_Q R (bn n)) cont_mod fCont (CRle_trans _ _ _ leab (H0 n)) + UC_integral f (CR_of_Q R (bn n)) (cn n) cont_mod fCont (H1 n))). - (* Use Chasles relation *) assert (forall n:nat, c <= cn n) as H2. { intro n. unfold cn. apply (CRle_trans _ (c+0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_le_compat_l. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r. apply H0. } apply (CR_cv_eq _ (fun n : nat => UC_integral f (CR_of_Q R a) (cn n) cont_mod fCont (CRle_trans _ _ _ leac (H2 n)))). intro n. apply UC_integral_chasles_rat_rat. apply UC_right_bound_cv. unfold cn. apply (CR_cv_proper _ (b+(c-b))). apply (CR_cv_eq _ (fun n : nat => CR_of_Q R (bn n) + (c - b))). intro n. rewrite (CRplus_comm c). unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. apply CRplus_comm. apply CR_cv_plus. exact cvb. apply CR_cv_const. unfold CRminus. rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l. apply CRplus_0_r. - (* Split sum *) apply CR_cv_plus. + apply UC_right_bound_cv. exact cvb. + unfold cn. apply (UC_integral_slide_cv b c f cont_mod fCont lebc (fun n => CR_of_Q R (bn n))). exact cvb. Qed. Lemma UC_integral_chasles : forall {R : ConstructiveReals} (a b c : CRcarrier R) (f : CRcarrier R -> CRcarrier R) (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : a <= b) (lebc : b <= c) (leac : a <= c), UC_integral f a c cont_mod fCont leac == UC_integral f a b cont_mod fCont leab + UC_integral f b c cont_mod fCont lebc. Proof. intros. assert (a-a <= c-a). { apply CRplus_le_compat_r, leac. } assert (CR_of_Q R 0 <= c-a). { rewrite <- (CRplus_opp_r a). exact H. } rewrite (UC_integral_translate f a c (-a) _ H). rewrite (UC_integral_bound_proper _ (a+-a) (c+-a) (CR_of_Q R 0) (c+-a) cont_mod _ _ H0). assert (CR_of_Q R 0 <= b-a). { rewrite <- (CRplus_opp_r a). apply CRplus_le_compat_r. exact leab. } assert (b-a <= c-a). { apply CRplus_le_compat_r. exact lebc. } rewrite (UC_integral_chasles_rat_rat_rat 0 (b-a) (c+-a) _ _ _ H1 H2). apply CRplus_morph. - assert (a-a <= b-a). { apply CRplus_le_compat_r. exact leab. } rewrite (UC_integral_translate f a b (-a) _ H3). apply UC_integral_bound_proper. rewrite CRplus_opp_r. reflexivity. reflexivity. - rewrite (UC_integral_translate f b c (-a) _ H2). apply UC_integral_bound_proper. reflexivity. reflexivity. - rewrite CRplus_opp_r. reflexivity. - reflexivity. Qed. Lemma UC_integral_constant : forall {R : ConstructiveReals} f a b c (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : a <= b), (forall x, (a <= x /\ x <= b) -> f x == c) -> UC_integral f a b cont_mod fCont leab == (b-a) * c. Proof. intros. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b cont_mod fCont leab)). apply (CR_cv_unique (fun last : nat => IntegralFiniteSum f (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last) ). exact c0. intros n. exists O. intros. unfold IntegralFiniteSum, CRminus. rewrite (CRsum_eq _ (fun k => c * (b-a) * CR_of_Q R (1# Pos.of_nat (S i)))). rewrite sum_const. setoid_replace (c * (b - a) * CR_of_Q R (1 # Pos.of_nat (S i)) * INR (S i) + - ((b + - a) * c)) with (CR_of_Q R 0). rewrite CRabs_right. apply CR_of_Q_le; discriminate. apply CRle_refl. unfold INR. rewrite CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1 # Pos.of_nat (S i)) * (Z.of_nat (S i) # 1))%Q with 1%Q. rewrite CRmult_1_r, CRmult_comm. unfold CRminus. rewrite CRplus_opp_r. reflexivity. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite Z.mul_1_r, Pos.mul_1_r. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. reflexivity. discriminate. intros. rewrite H. rewrite CRmult_assoc. apply CRmult_morph. reflexivity. transitivity ((b + - a) * (CR_of_Q R (Z.of_nat (S i0) # Pos.of_nat (S i)) - CR_of_Q R (Z.of_nat i0 # Pos.of_nat (S i)))). unfold CRminus. do 3 rewrite CRmult_plus_distr_r. do 2 rewrite CRopp_plus_distr. do 2 rewrite CRmult_plus_distr_l. do 2 rewrite CRopp_mult_distr_l. do 4 rewrite <- CRplus_assoc. apply CRplus_morph. 2: rewrite CRopp_involutive, <- CRopp_mult_distr_l, <- CRopp_mult_distr_r, CRopp_involutive; reflexivity. rewrite (CRplus_comm a). do 4 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. do 2 rewrite <- CRplus_assoc. rewrite (CRplus_comm (b * - CR_of_Q R (Z.of_nat i0 # Pos.of_nat (S i)))). apply CRplus_morph. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_l. reflexivity. rewrite <- CRopp_mult_distr_l, <- CRopp_mult_distr_r. reflexivity. apply CRmult_morph. reflexivity. unfold CRminus. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_minus_distr. replace (Z.of_nat (S i0) - Z.of_nat i0)%Z with 1%Z. reflexivity. rewrite Nat2Z.inj_succ. ring. split. apply (CRle_trans _ (a + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_le_compat_l. rewrite <- (CRmult_0_r (b-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact leab. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_0_l, Z.mul_1_r. apply Nat2Z.is_nonneg. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- (CRmult_1_r (-a+b)), (CRplus_comm (-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact leab. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. apply Nat2Z.inj_le, le_S, H1. discriminate. Qed. Lemma UC_integral_zero : forall {R : ConstructiveReals} f a b (cont_mod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f cont_mod) (leab : a <= b), (forall x, (a <= x /\ x <= b) -> f x == 0) -> UC_integral f a b cont_mod fCont leab == 0. Proof. intros. rewrite (UC_integral_constant _ _ _ 0). rewrite CRmult_0_r. reflexivity. exact H. Qed. Lemma UC_integral_nonneg : forall {R : ConstructiveReals} f g a b (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (modG : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f modF) (gCont : UniformCont g modG) (leab leabb : a <= b), (forall x, (a <= x /\ x <= b) -> (f x) <= (g x)) -> UC_integral f a b modF fCont leab <= (UC_integral g a b modG gCont leabb). Proof. intros. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b modF fCont leab)). destruct (CR_complete R (fun last : nat => IntegralFiniteSum g (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy g a b modG gCont leabb)). assert (forall n:nat, ((fun last : nat => IntegralFiniteSum f (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last) n) <= ((fun last : nat => IntegralFiniteSum g (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last) n)). { intros. unfold IntegralFiniteSum, CRminus. apply sum_Rle. intros. apply CRmult_le_compat_r. apply (CRle_minus (a + (b + - a) * CR_of_Q R (Z.of_nat k # Pos.of_nat (S n))) ( a + (b + - a) * CR_of_Q R (Z.of_nat (S k) # Pos.of_nat (S n)))). apply CRplus_le_compat_l. apply CRmult_le_compat_l. apply (CRle_minus a b), leab. apply CR_of_Q_le. unfold Qle, Qnum, Qden. apply Z.mul_le_mono_nonneg_r. discriminate. apply Nat2Z.inj_le, le_S, Nat.le_refl. apply H. split. apply (CRle_trans _ (a + 0)). rewrite CRplus_0_r. apply CRle_refl. apply CRplus_le_compat_l. rewrite <- (CRmult_0_r (b-a)). apply CRmult_le_compat_l. apply (CRle_minus a b), leab. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_0_l, Z.mul_1_r. apply Nat2Z.is_nonneg. apply (CRplus_le_reg_l (-a)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. rewrite <- (CRmult_1_r (-a+b)), (CRplus_comm (-a)). apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_le_compat. exact leab. apply CRle_refl. apply CR_of_Q_le. unfold Qle, Qnum, Qden. rewrite Z.mul_1_r, Z.mul_1_l. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. apply Nat2Z.inj_le, le_S, H0. discriminate. } apply (CR_cv_le _ _ _ _ H0); assumption. Qed. Lemma UC_integral_pos : forall {R : ConstructiveReals} f a b (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f modF) (leab : a <= b), (forall x, (a <= x /\ x <= b) -> 0 <= f x) -> 0 <= UC_integral f a b modF fCont leab. Proof. intros. rewrite <- (UC_integral_zero (fun _ => 0) a b (fun _ _ => 1) (UC_constant 0) leab). apply UC_integral_nonneg. exact H. intros. reflexivity. Qed. Lemma UC_integral_extens : forall {R : ConstructiveReals} f g a b (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (modG : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f modF) (gCont : UniformCont g modG) (leab leabb : a <= b), (forall x, (a <= x /\ x <= b) -> f x == g x) -> UC_integral f a b modF fCont leab == UC_integral g a b modG gCont leabb. Proof. intros. split; apply UC_integral_nonneg. intros. rewrite H. apply CRle_refl. exact H0. intros. rewrite H. apply CRle_refl. exact H0. Qed. Lemma UC_integral_extend_zero : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (a b c d : CRcarrier R) (fCont : UniformCont f modF) (leab : a <= b) (lecd : c <= d), c <= a -> b <= d -> (forall x : CRcarrier R, (c <= x /\ x <= a) -> f x == 0) -> (forall x : CRcarrier R, (b <= x /\ x <= d) -> f x == 0) -> UC_integral f a b modF fCont leab == UC_integral f c d modF fCont lecd. Proof. intros. assert (a <= d). { apply (CRle_trans _ _ _ leab H0). } rewrite (UC_integral_chasles c a d f modF fCont H H3). rewrite (UC_integral_chasles a b d f modF fCont leab H0). rewrite (UC_integral_zero f c a). rewrite (UC_integral_zero f b d). rewrite CRplus_0_l, CRplus_0_r. reflexivity. exact H2. exact H1. Qed. Lemma UC_integral_extend_nonneg : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (a b c d : CRcarrier R) (fCont : UniformCont f modF) (leab : a <= b) (lecd : c <= d), c <= a -> b <= d -> (forall x : CRcarrier R, 0 <= (f x)) -> UC_integral f a b modF fCont leab <= UC_integral f c d modF fCont lecd. Proof. intros. assert (a <= d). { apply (CRle_trans _ _ _ leab). exact H0. } rewrite (UC_integral_chasles c a d f modF fCont H H2). rewrite (UC_integral_chasles a b d f modF fCont leab H0). apply (CRplus_le_reg_l (- UC_integral f a b modF fCont leab)). apply CRplus_le_compat_l. rewrite CRplus_comm. rewrite <- (CRplus_0_r (UC_integral f a b modF fCont leab)). do 2 rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_0_l. rewrite <- (CRplus_0_r 0). apply CRplus_le_compat. apply UC_integral_pos. intros. apply H1. apply UC_integral_pos. intros. apply H1. Qed. Lemma UC_integral_plus : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (modF modG modS : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f modF) (gCont : UniformCont g modG) (sCont : UniformCont (fun x => (f x) + (g x)) modS) (leab leabb : a <= b), UC_integral (fun x => (f x) + (g x)) a b modS sCont leab == UC_integral f a b modF fCont leabb + UC_integral g a b modG gCont leabb. Proof. intros. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b modF fCont leabb)). destruct (CR_complete R (fun last : nat => IntegralFiniteSum g (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy g a b modG gCont leabb)). destruct (CR_complete R (fun last : nat => IntegralFiniteSum (fun x1 : CRcarrier R => f x1 + g x1) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy (fun x1 : CRcarrier R => f x1 + g x1) a b modS sCont leab)). apply (CR_cv_unique _ _ _ c1). apply (CR_cv_eq _ (fun last : nat => (IntegralFiniteSum f (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last) + (IntegralFiniteSum g (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last))). intro n. unfold IntegralFiniteSum. rewrite <- sum_plus. apply CRsum_eq. 2: apply CR_cv_plus; assumption. intros. generalize (f (a + (b - a) * CR_of_Q R (Z.of_nat i # Pos.of_nat (S n)))), (g (a + (b - a) * CR_of_Q R (Z.of_nat i # Pos.of_nat (S n)))). intros. setoid_replace (a + (b - a) * CR_of_Q R (Z.of_nat (S i) # Pos.of_nat (S n)) - (a + (b - a) * CR_of_Q R (Z.of_nat i # Pos.of_nat (S n)))) with ((b - a) * CR_of_Q R (Z.of_nat (S i) # Pos.of_nat (S n)) - (b - a) * CR_of_Q R (Z.of_nat i # Pos.of_nat (S n))). rewrite <- CRmult_plus_distr_r. reflexivity. unfold CRminus. rewrite (CRplus_comm a), CRopp_plus_distr. rewrite CRplus_assoc, <- (CRplus_assoc a), CRplus_opp_r, CRplus_0_l. reflexivity. Qed. Lemma UC_integral_sum : forall {R : ConstructiveReals} (fn : nat -> CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (n : nat) (modFn : forall (n:nat) (eps:CRcarrier R), 0 < eps -> CRcarrier R) (modSn : forall (eps:CRcarrier R), 0 < eps -> CRcarrier R) (fnCont : forall k:nat, UniformCont (fn k) (modFn k)) (sCont : UniformCont (fun x => CRsum (fun k => (fn k x)) n) modSn) (leab : a <= b), UC_integral (fun x => CRsum (fun k => (fn k x)) n) a b modSn sCont leab == CRsum (fun k => UC_integral (fn k) a b (modFn k) (fnCont k) leab) n. Proof. induction n. - intros. simpl. apply UC_integral_extens. intros. reflexivity. - intros. simpl. destruct (UC_sum fn modFn fnCont n) as [modS c]. rewrite <- (IHn _ _ _ c). apply UC_integral_plus. Qed. Lemma Rcauchy_complete_eq : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (cau : CR_cauchy R xn) (a : CRcarrier R), CR_cv R xn a -> (let (l,_) := CR_complete R xn cau in l) == a. Proof. intros. destruct (CR_complete R xn cau). apply (CR_cv_unique xn); assumption. Qed. (* The partial integral sum equals a^2 * n/(2*(n+1)) which converges to a^2/2. *) Lemma x_RiemannInt : forall {R : ConstructiveReals} (a b : CRcarrier R) (leab : a <= b), UC_integral (fun x=> x) a b _ UC_x leab == (b*b - a*a) * CR_of_Q R (1#2). Proof. intros. unfold UC_integral. apply Rcauchy_complete_eq. apply (CR_cv_eq _ (fun n => a*(b-a) + (CR_of_Q R (Z.of_nat n # Pos.of_nat (S n))) * ((b-a) * (b-a) * CR_of_Q R (1#2)))). - intros. unfold IntegralFiniteSum. rewrite (CRsum_eq _ (fun k => a*(b-a) * CR_of_Q R (1# Pos.of_nat (S n)) + INR k * ((b-a)*(b-a) * CR_of_Q R (1# Pos.of_nat (S n * S n))))). + symmetry. rewrite sum_plus, sum_const. rewrite sum_scale, (CRmult_comm (CRsum (fun n0 => INR n0) n)). rewrite sum_INR. rewrite CRmult_assoc. setoid_replace (CR_of_Q R (1 # Pos.of_nat (S n)) * INR (S n)) with (CR_of_Q R 1). rewrite CRmult_1_r. apply CRplus_morph. reflexivity. rewrite <- (CRmult_comm ((b - a) * (b - a) * CR_of_Q R (1 # 2))). rewrite CRmult_assoc. rewrite (CRmult_assoc ((b-a)*(b-a))). apply CRmult_morph. reflexivity. rewrite CRmult_comm, (CRmult_comm ((INR n)*(INR (S n)))). rewrite (CRmult_assoc (CR_of_Q R (1#2))). apply CRmult_morph. reflexivity. unfold INR, CRealConstructive, CR_of_Q. do 2 rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. rewrite Nat2Pos.inj_mul. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_r, Pos.mul_1_l. rewrite <- Z.mul_assoc. apply f_equal2. reflexivity. rewrite Pos2Z.inj_mul. apply f_equal2. 2: reflexivity. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. reflexivity. discriminate. discriminate. discriminate. unfold INR. rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. unfold Qmult, Qeq, Qnum, Qden. rewrite Pos.mul_1_r. rewrite Z.mul_1_l, Z.mul_1_l, Z.mul_1_r. rewrite <- positive_nat_Z. rewrite Nat2Pos.id. reflexivity. discriminate. + intros. setoid_replace (a + (b - a) * CR_of_Q R (Z.of_nat (S i) # Pos.of_nat (S n)) - (a + (b - a) * CR_of_Q R (Z.of_nat i # Pos.of_nat (S n)))) with ((b - a) * CR_of_Q R (1 # Pos.of_nat (S n))). rewrite CRmult_plus_distr_r. apply CRplus_morph. rewrite CRmult_assoc. reflexivity. unfold INR. rewrite Nat2Pos.inj_mul. setoid_replace (1 # Pos.of_nat (S n) * Pos.of_nat (S n))%Q with ((1 # Pos.of_nat (S n)) * (1 # Pos.of_nat (S n)))%Q. 2: reflexivity. rewrite CR_of_Q_mult. setoid_replace (Z.of_nat i # Pos.of_nat (S n))%Q with ((Z.of_nat i # 1) * (1# Pos.of_nat (S n)))%Q. rewrite CR_of_Q_mult. do 4 rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. rewrite (CRmult_comm (b-a)). rewrite <- CRmult_assoc. do 2 rewrite (CRmult_assoc (CR_of_Q R (Z.of_nat i # 1) * (b - a))). apply CRmult_morph. reflexivity. apply CRmult_comm. unfold Qmult, Qeq, Qnum, Qden. rewrite Z.mul_1_r. reflexivity. discriminate. discriminate. setoid_replace (Z.of_nat (S i) # Pos.of_nat (S n))%Q with ((1#Pos.of_nat (S n)) + (Z.of_nat i # Pos.of_nat (S n)))%Q. rewrite CR_of_Q_plus. unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc, (CRplus_comm a). do 2 rewrite CRplus_assoc. rewrite <- (CRplus_assoc a). rewrite CRplus_opp_r, CRplus_0_l, CRopp_mult_distr_r. rewrite <- CRmult_plus_distr_l. apply CRmult_morph. reflexivity. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. reflexivity. rewrite Qinv_plus_distr. fold (1 + i)%nat. rewrite Nat2Z.inj_add. reflexivity. - apply (CR_cv_proper _ (a*(b-a) + 1 * ((b-a) * (b-a) * CR_of_Q R (1#2)))). apply (CR_cv_plus _ _ (a*(b-a))). apply CR_cv_const. apply CR_cv_scale. intros n. exists (Pos.to_nat n). intros. rewrite CRabs_minus_sym. setoid_replace (1 - CR_of_Q R (Z.of_nat i # Pos.of_nat (S i))) with (CR_of_Q R (1# Pos.of_nat (S i))). rewrite CRabs_right. apply CR_of_Q_le. unfold Qle,Qnum,Qden. do 2 rewrite Z.mul_1_l. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite Nat2Pos.id. apply le_S,H. discriminate. apply CR_of_Q_le; discriminate. unfold CRminus. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. apply CR_of_Q_morph. unfold Qopp,Qplus,Qeq,Qnum,Qden. apply f_equal2. 2: reflexivity. rewrite Z.mul_1_l, Z.mul_1_r. rewrite <- positive_nat_Z, Nat2Pos.id. 2: discriminate. fold (1+i)%nat. rewrite Nat2Z.inj_add. ring. rewrite CRmult_1_l. rewrite (CRmult_comm a), CRmult_assoc, <- CRmult_plus_distr_l. setoid_replace (a + (b - a) * CR_of_Q R (1 # 2)) with ((a+b) * CR_of_Q R (1#2)). rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. unfold CRminus. rewrite CRmult_plus_distr_r, CRmult_plus_distr_l. rewrite CRmult_plus_distr_l, (CRplus_comm (b*a)), CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm. rewrite <- (CRopp_mult_distr_l a b), (CRmult_comm a b). rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite <- CRopp_mult_distr_l. reflexivity. apply (CRmult_eq_reg_r (CR_of_Q R 2)). left. apply CR_of_Q_lt; reflexivity. rewrite CRmult_plus_distr_r. rewrite CRmult_assoc, CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1), CRmult_1_r, CRmult_1_r. rewrite CRmult_plus_distr_l. rewrite CRmult_1_r. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. unfold CRminus. rewrite CRplus_comm, CRplus_assoc, CRplus_opp_l. apply CRplus_0_r. Qed. Lemma UC_integral_scale : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b l : CRcarrier R) (modF : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCont : UniformCont f modF) (leab : a <= b), UC_integral (fun x => l * (f x)) a b _ (UC_scale f modF l fCont) leab == l * (UC_integral f a b modF fCont leab). Proof. intros. unfold UC_integral. destruct (CR_complete R (fun last : nat => IntegralFiniteSum f (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) (fun n : nat => a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last))) last) (UC_integral_cauchy f a b modF fCont leab)). apply Rcauchy_complete_eq. apply (CR_cv_eq _ (fun last : nat => (IntegralFiniteSum f (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) (fun n : nat => (a + (b - a) * CR_of_Q R (Z.of_nat n # Pos.of_nat (S last)))) last) * l)). 2: rewrite CRmult_comm; apply CR_cv_scale, c. intro n. unfold IntegralFiniteSum. rewrite <- sum_scale. apply CRsum_eq. intros. rewrite (CRmult_comm l). do 2 rewrite CRmult_assoc. apply CRmult_morph. reflexivity. apply CRmult_comm. Qed. Lemma TrapezeLe : forall {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta), a <= b -> a-eta <= b+eta. Proof. intros. apply (CRle_trans _ (a-0)). apply CRplus_le_compat_l, CRopp_ge_le_contravar, CRlt_asym, etaPos. unfold CRminus. rewrite CRopp_0. apply CRplus_le_compat. exact H. apply CRlt_asym, etaPos. Qed. Lemma CSUCUnitTrapezeInt : forall {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta) (leab : a <= b), UC_integral (CSUCUnitTrapeze a b eta etaPos) (a-eta) (b+eta) _ (CSUCUnitTrapeze_cont a b eta etaPos leab) (TrapezeLe a b eta etaPos leab) == eta + b - a. Proof. intros. assert (a-eta <= a). { apply (CRle_trans _ (a-0)). apply CRplus_le_compat_l, CRopp_ge_le_contravar, CRlt_asym, etaPos. unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. } assert (b <= b+eta) as H1. { apply (CRplus_le_reg_l (-b)). rewrite CRplus_opp_l, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply CRlt_asym, etaPos. } assert (a <= b+eta). { apply (CRle_trans _ b _ leab). exact H1. } rewrite (UC_integral_chasles (a-eta) a (b+eta) (CSUCUnitTrapeze a b eta etaPos) _ _ H H0). rewrite (UC_integral_chasles a b (b+eta) (CSUCUnitTrapeze a b eta etaPos) _ _ leab H1). assert (forall t:CRcarrier R, UniformCont (fun x => x + t) (fun eps epsPos => eps)) as H2. { intro t. apply (UC_translate_horizontal (fun x=>x) t). apply UC_x. } rewrite (UC_integral_extens _ (fun x:CRcarrier R => CRinv R eta (inr etaPos) * (x + (eta - a))) (a - eta) a _ _ _ (UC_scale _ _ _ (H2 _)) H H). rewrite (UC_integral_extens _ (fun x:CRcarrier R => 1) a b _ (fun eps epsPos => 1) _ (UC_constant _) leab leab). rewrite (UC_integral_extens _ (fun x:CRcarrier R => (-CRinv R eta (inr etaPos)) * (x + (- b - eta))) b (b+eta) _ _ _ (UC_scale _ _ (-CRinv R eta (inr etaPos)) (H2 _)) H1 H1). - rewrite (UC_integral_scale _ (a-eta) a (CRinv R eta (inr etaPos)) (fun (eps : CRcarrier R) (_ : 0 < eps) => eps)). rewrite (UC_integral_plus _ _ (a-eta) a _ _ _ UC_x (UC_constant (eta-a)) _ _ H). rewrite (UC_integral_scale _ b (b+eta) _ (fun eps epsPos => eps)). rewrite (UC_integral_plus _ _ b (b+eta) _ _ _ UC_x (UC_constant (-b -eta)) _ _ H1). rewrite (UC_integral_constant _ a b 1). 2: intros; reflexivity. rewrite CRmult_1_r. rewrite x_RiemannInt. rewrite (UC_integral_constant _ (a-eta) a (eta-a)). rewrite x_RiemannInt. rewrite (UC_integral_constant _ b (b+eta) (-b-eta)). unfold CRminus. rewrite (CRplus_assoc eta). rewrite CRplus_comm, CRplus_assoc, (CRplus_comm eta (b+-a)). apply CRplus_morph. reflexivity. rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r. rewrite <- CRmult_plus_distr_l. apply (CRmult_eq_reg_l eta). right. exact etaPos. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l. setoid_replace (b + eta + - b) with eta. setoid_replace (a + - (a + - eta)) with eta. rewrite CRopp_plus_distr. rewrite (CRopp_mult_distr_r eta). rewrite CRopp_plus_distr, CRopp_involutive, CRopp_involutive. rewrite CRopp_mult_distr_l, CRopp_plus_distr, CRopp_involutive. setoid_replace (a * a + - ((a + - eta) * (a + - eta))) with (CR_of_Q R 2*a*eta - eta*eta). setoid_replace (- ((b + eta) * (b + eta)) + b * b) with (-CR_of_Q R 2*b*eta - eta*eta). setoid_replace ((- CR_of_Q R 2 * b * eta - eta * eta) * CR_of_Q R (1 # 2)) with (- eta*eta *CR_of_Q R (1#2) + -(eta*b)). setoid_replace ((CR_of_Q R 2 * a * eta - eta * eta) * CR_of_Q R (1 # 2)) with ( - eta*eta *CR_of_Q R (1#2) + eta*a). do 2 rewrite CRplus_assoc. rewrite CRmult_plus_distr_l. do 2 rewrite <- (CRplus_assoc (-(eta*b))). rewrite CRplus_opp_l, CRplus_0_l. rewrite (CRplus_comm (eta) (-a)), CRmult_plus_distr_l. rewrite CRplus_assoc, <- (CRplus_assoc (eta*a)). rewrite <- (CRopp_mult_distr_r eta a), CRplus_opp_r, CRplus_0_l. rewrite (CRplus_comm (eta*eta)), <- CRplus_assoc, <- CRplus_assoc. rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus, Qinv_plus_distr. setoid_replace (1+1#2)%Q with 1%Q. 2: reflexivity. rewrite CRmult_1_r, <- CRopp_mult_distr_l. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. unfold CRminus. rewrite CRmult_comm, CRmult_plus_distr_l. rewrite <- CRmult_assoc, <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1#2)*2)%Q with 1%Q. rewrite CRmult_1_l. rewrite CRplus_comm, CRmult_comm, CRopp_mult_distr_l, (CRmult_comm a eta). reflexivity. reflexivity. unfold CRminus. rewrite CRmult_comm, CRmult_plus_distr_l. rewrite <- CR_of_Q_opp, <- CRmult_assoc, <- CRmult_assoc, <- CR_of_Q_mult. setoid_replace ((1#2)*-(2))%Q with (-(1))%Q. rewrite CR_of_Q_opp, <- CRopp_mult_distr_l, CRmult_1_l. rewrite CRplus_comm, CRmult_comm, CRopp_mult_distr_l. rewrite (CRopp_mult_distr_r eta b), (CRmult_comm eta (-b)). reflexivity. reflexivity. rewrite CRmult_plus_distr_l, CRmult_plus_distr_r. rewrite CRplus_comm, CRopp_plus_distr, CRopp_plus_distr, <- CRplus_assoc. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. rewrite CRmult_plus_distr_r, CRopp_plus_distr, <- CRplus_assoc. apply CRplus_morph. 2: reflexivity. rewrite (CR_of_Q_plus R 1 1). rewrite <- (CRopp_mult_distr_l), CRmult_plus_distr_r, CRmult_1_l. rewrite <- (CRopp_mult_distr_l), CRmult_plus_distr_r. rewrite CRopp_plus_distr, (CRmult_comm eta). reflexivity. rewrite CRmult_plus_distr_l, CRmult_plus_distr_r. rewrite CRopp_plus_distr, CRopp_plus_distr. rewrite <- CRplus_assoc, <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. rewrite CRmult_plus_distr_r, CRopp_plus_distr. rewrite CRopp_mult_distr_l, CRopp_involutive. rewrite CRopp_mult_distr_r, CRopp_involutive. rewrite CRopp_mult_distr_l, CRopp_involutive, <- CRplus_assoc. apply CRplus_morph. rewrite (CR_of_Q_plus R 1 1). rewrite CRmult_plus_distr_r, CRmult_1_l, CRmult_plus_distr_r. rewrite (CRmult_comm eta a). reflexivity. rewrite CRopp_mult_distr_r. reflexivity. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l. reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. intro. reflexivity. intros. reflexivity. - intros. unfold CSUCUnitTrapeze. rewrite UCHeavisideIn. unfold UCUnitHeaviside. rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)). rewrite CRmax_right. rewrite CRmin_right. apply (CRmult_eq_reg_l eta). right. apply etaPos. rewrite <- CRmult_assoc, <- CRopp_mult_distr_r, CRinv_r. unfold CRminus. rewrite (CRmult_plus_distr_l eta), CRmult_1_r. rewrite <- CRopp_mult_distr_r, <- CRmult_assoc, CRmult_comm, <- CRmult_assoc. rewrite CRinv_l, CRmult_1_l. rewrite <- CRopp_mult_distr_l, CRmult_1_l, CRopp_plus_distr, CRopp_plus_distr. rewrite CRopp_plus_distr, CRopp_involutive, CRopp_involutive. rewrite CRplus_comm, CRplus_assoc. reflexivity. apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm. apply H3. apply CRmin_glb. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. rewrite <- (CRplus_opp_r b). apply CRplus_le_compat_r. apply H3. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. apply (CRle_trans _ b _ leab). apply H3. - intros. rewrite CSUCTrapezePlateau. reflexivity. exact H3. - intros. unfold CSUCUnitTrapeze, UCUnitHeaviside. rewrite (CRinv_morph (a - (a- eta)) eta _ (inr etaPos)). rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)). rewrite CRmax_right, CRmin_right. rewrite CRmax_left. unfold CRminus. rewrite CRopp_0, CRplus_0_r. rewrite CRmult_comm. apply CRmult_morph. reflexivity. apply CRplus_morph. reflexivity. rewrite CRplus_comm. rewrite CRopp_plus_distr, CRopp_involutive. reflexivity. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_0_l. apply (CRle_trans _ a). apply H3. exact leab. apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. apply (CRplus_le_reg_r (a - eta)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply H3. apply CRmin_glb. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_0_l. apply (CRplus_le_reg_r (a - eta)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_0_l. unfold CRminus. apply H3. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l. apply CRplus_0_l. unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRopp_involutive. apply CRplus_0_l. Qed. corn-8.20.0/reals/stdlib/ConstructiveDiagonal.v000066400000000000000000001376621473720167500215020ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* The diagonal bijection between nat^2 and nat, as well as convergence results for double series. *) From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import PeanoNat. From Coq Require Import ArithRing. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Local Open Scope ConstructiveReals. (*********************************************************) (** * Auxiliary lemmas *) (*********************************************************) (* Those lemmas should probably either be inlined, or go in other libraries *) Definition SubSeq : Type := { sub : nat -> nat | forall n p:nat, lt n p -> lt (sub n) (sub p) }. Lemma SubSeqAboveId : forall (un : SubSeq) (n : nat), le n (proj1_sig un n). Proof. intros [un inc]. induction n. simpl. apply Nat.le_0_l. simpl. simpl in IHn. specialize (inc n (S n)). unfold lt in inc. apply (Nat.le_trans _ (S (un n))). apply le_n_S. assumption. apply inc. apply Nat.le_refl. Qed. (* Inversion of a subsequence *) Fixpoint SubSeqInv (un : SubSeq) (n p : nat) : nat := if Nat.eq_dec (proj1_sig un p) n then p else match p with | O => S n (* not found *) | S k => SubSeqInv un n k end. Lemma SubSeqInvFound : forall (un : SubSeq) (n k : nat), (SubSeqInv un n k <= n <-> proj1_sig un (SubSeqInv un n k) = n)%nat. Proof. intros. generalize dependent n. induction k. - simpl. split. + intro. destruct (Nat.eq_dec (proj1_sig un O) n). assumption. exfalso. apply (Nat.lt_nge n (S n)). apply Nat.le_refl. assumption. + intro. destruct (Nat.eq_dec (proj1_sig un O) n). apply Nat.le_0_l. exfalso. pose proof (SubSeqAboveId un n). destruct un. simpl in H. simpl in n0. simpl in H0. apply (Nat.lt_nge (x n) (x (S n))). apply l. apply Nat.le_refl. rewrite H. assumption. - split. + intro. simpl. simpl in H. destruct (Nat.eq_dec (proj1_sig un (S k)) n). assumption. apply IHk. assumption. + simpl. intro. destruct (Nat.eq_dec (proj1_sig un (S k)) n). rewrite <- e. apply SubSeqAboveId. apply IHk. assumption. Qed. Lemma SubSeqInvNotFound : forall (un : SubSeq) (n k : nat), SubSeqInv un n k = S n <-> (forall p:nat, le p k -> proj1_sig un p <> n). Proof. intros. generalize dependent n. induction k. - split. + intros. intro absurd. simpl in H. destruct (Nat.eq_dec (proj1_sig un O) n). discriminate. destruct un. simpl in absurd. simpl in n0. inversion H0. subst p. contradiction. + intros. simpl. destruct (Nat.eq_dec (proj1_sig un O) n). exfalso. exact (H O (Nat.le_refl 0) e). reflexivity. - split. + intros. intro absurd. simpl in H. destruct (Nat.eq_dec (proj1_sig un (S k)) n). inversion H. subst k. pose proof (SubSeqAboveId un (S n)). rewrite e in H1. apply (Nat.lt_nge n (S n)). apply Nat.le_refl. assumption. apply Nat.le_succ_r in H0. destruct H0. specialize (IHk n) as [IHk _]. specialize (IHk H p H0). contradiction. subst p. contradiction. + intros. simpl. destruct (Nat.eq_dec (proj1_sig un (S k)) n). exfalso. specialize (H (S k) (Nat.le_refl _)). contradiction. apply IHk. intros. apply H. apply (Nat.le_trans _ k). assumption. apply le_S. apply Nat.le_refl. Qed. Lemma SubSeqInvInit : forall (un : SubSeq) (n : nat), SubSeqInv un (proj1_sig un O) n = O. Proof. induction n. - simpl. destruct (Nat.eq_dec (proj1_sig un O) (proj1_sig un O)). reflexivity. exfalso. exact (n (eq_refl _)). - simpl. destruct (Nat.eq_dec (proj1_sig un (S n)) (proj1_sig un O)). exfalso. destruct un. simpl in e. apply (Nat.lt_nge (x O) (x (S n))). apply l. apply le_n_S. apply Nat.le_0_l. rewrite e. apply Nat.le_refl. apply IHn. Qed. (* Realign the indexes, filling with zeros *) Definition FillSubSeqWithZeros {R : ConstructiveReals} (un : nat -> CRcarrier R) (sub : SubSeq) (n : nat) : CRcarrier R := if Nat.eq_dec (SubSeqInv sub n n) (S n) then 0 else un n. Lemma sumLastElem : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), (forall k:nat, lt k n -> un k == 0) -> CRsum un n == un n. Proof. intros. destruct n. - reflexivity. - simpl. rewrite <- (CRplus_0_l (un (S n))). apply CRplus_morph. rewrite (CRsum_eq _ (fun n => 0)). rewrite sum_const. rewrite CRmult_0_l. reflexivity. intros. apply H. apply le_n_S. assumption. apply CRplus_0_l. Qed. Lemma FillSubSeqWithZerosInit : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (sub : SubSeq), CRsum (FillSubSeqWithZeros un sub) (proj1_sig sub O) == un (proj1_sig sub O). Proof. intros R un sub. replace (un (proj1_sig sub O)) with ((FillSubSeqWithZeros un sub) (proj1_sig sub O)). - apply sumLastElem. intros. unfold FillSubSeqWithZeros. destruct (Nat.eq_dec (SubSeqInv sub k k) (S k)). reflexivity. exfalso. apply n. clear n. apply SubSeqInvNotFound. intros. intro absurd. destruct p. rewrite absurd in H. exact (Nat.lt_irrefl k H). destruct sub. simpl in absurd, H. apply (Nat.lt_nge (x O) (x (S p))). apply l. apply le_n_S. apply Nat.le_0_l. rewrite absurd. apply le_S in H. apply le_S_n in H. apply H. - unfold FillSubSeqWithZeros. destruct (Nat.eq_dec (SubSeqInv sub (proj1_sig sub O) (proj1_sig sub O)) (S (proj1_sig sub O))). exfalso. pose proof (SubSeqInvNotFound sub (proj1_sig sub O) (proj1_sig sub O)) as [H _]. specialize (H e O (Nat.le_0_l _)). apply H. reflexivity. reflexivity. Qed. Lemma FillSubSeqWithZerosStep : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (sub : SubSeq) (n : nat), CRsum (fun k : nat => FillSubSeqWithZeros un sub (S (proj1_sig sub n) + k)) (proj1_sig sub (S n) - S (proj1_sig sub n)) == un (proj1_sig sub (S n)). Proof. intros. replace (un (proj1_sig sub (S n))) with (FillSubSeqWithZeros un sub (S (proj1_sig sub n) + (proj1_sig sub (S n) - S (proj1_sig sub n)))). - apply (sumLastElem (fun k : nat => FillSubSeqWithZeros un sub (S (proj1_sig sub n) + k))). intros. unfold FillSubSeqWithZeros. destruct (Nat.eq_dec (SubSeqInv sub (S (proj1_sig sub n) + k) (S (proj1_sig sub n) + k))). reflexivity. exfalso. apply n0. clear n0. apply SubSeqInvNotFound. intros. intro absurd. (* sub reaches a number between sub n and sub (S n) *) destruct sub as [sub inc]. simpl in absurd, H0, H. assert (sub p < sub (S n))%nat. { rewrite absurd. apply (Nat.lt_le_trans _ (S (sub n) + (sub (S n) - S (sub n)))). simpl. apply le_n_S. apply Nat.add_lt_mono_l. assumption. rewrite Nat.add_comm. rewrite Nat.sub_add. apply Nat.le_refl. apply inc. apply Nat.le_refl. } destruct (Nat.lt_trichotomy p (S n)). apply Nat.le_succ_r in H2. destruct H2. specialize (inc p n H2). rewrite absurd in inc. apply (Nat.lt_nge (S (sub n + k)) (sub n)). assumption. apply le_S. rewrite <- (Nat.add_0_r (sub n)). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. inversion H2. subst p. apply (Nat.lt_nge (sub n) (S (sub n + k))). apply le_n_S. rewrite <- (Nat.add_0_r (sub n)). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. rewrite <- absurd. apply Nat.le_refl. destruct H2. subst p. exact (Nat.lt_irrefl (sub (S n)) H1). specialize (inc (S n) p H2). apply (Nat.lt_asymm (sub p) (sub (S n))); assumption. - rewrite Nat.add_comm. rewrite Nat.sub_add. unfold FillSubSeqWithZeros. destruct (Nat.eq_dec (SubSeqInv sub (proj1_sig sub (S n)) (proj1_sig sub (S n))) (S (proj1_sig sub (S n)))). exfalso. pose proof (SubSeqInvNotFound sub (proj1_sig sub (S n)) (proj1_sig sub (S n))) as [H _]. specialize (H e (S n) (SubSeqAboveId _ _)). apply H. reflexivity. reflexivity. destruct sub. simpl. apply l. apply Nat.le_refl. Qed. (* The same modulus of convergence applies to any subsequence. *) Lemma SubSeqCv : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (sub : SubSeq) (l : CRcarrier R), CR_cv R un l -> CR_cv R (fun n => un (proj1_sig sub n)) l. Proof. intros. intros p. specialize (H p) as [N cv]. exists N. intros. apply cv. apply (Nat.le_trans _ i). assumption. apply SubSeqAboveId. Qed. Lemma SubSeriesCv : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (sub : SubSeq) (s : CRcarrier R), series_cv un s -> (forall n:nat, 0 <= un n) -> { t : CRcarrier R & series_cv (fun n => un (proj1_sig sub n)) t }. Proof. intros. destruct (series_cv_maj (FillSubSeqWithZeros un sub) un s) as [lim [cv _]]. - intro n. unfold FillSubSeqWithZeros. destruct (Nat.eq_dec (SubSeqInv sub n n) (S n)). rewrite CRabs_right. apply H0. apply CRle_refl. rewrite CRabs_right. apply CRle_refl. apply H0. - assumption. - exists lim. apply (CR_cv_eq _ (fun n => CRsum (FillSubSeqWithZeros un sub) (proj1_sig sub n))). induction n. + apply FillSubSeqWithZerosInit. + simpl. rewrite <- IHn. clear IHn. destruct (Nat.le_exists_sub (S (proj1_sig sub n)) (proj1_sig sub (S n))) as [p [inf _]]. destruct sub. simpl. apply l. apply le_n_S. apply Nat.le_refl. rewrite inf. rewrite Nat.add_comm. rewrite sum_assoc. apply CRplus_morph. reflexivity. rewrite Nat.add_comm. rewrite <- inf. apply eq_sym in inf. apply Nat.add_sub_eq_r in inf. subst p. apply FillSubSeqWithZerosStep. + apply (SubSeqCv _ sub lim cv). Qed. (* The points (n,0) are mapped to 0, 1, 3, 6, 10, ... = n(n+1)/2 *) Definition diagPlane (i j : nat) : nat := j + (i+j) * S (i+j)/2. Definition diagPlaneInvNext i j : prod nat nat := match i with | O => (* change diag *) pair (S j) O | S k => pair k (S j) end. (* Apply n times function f starting at point i j. *) Fixpoint iterateN2Func (n i j : nat) (f : nat -> nat -> prod nat nat) := match n with | O => pair i j | S p => let (k,l) := iterateN2Func p i j f in f k l end. Definition diagPlaneInv (n : nat) : prod nat nat := iterateN2Func n O O diagPlaneInvNext. Lemma diagPlaneAbsNext : forall n : nat, (S n * (S (S n)) / 2 = n * S n / 2 + S n)%nat. Proof. intro n. assert (S n * S (S n) = n * S n + S n * 2)%nat. ring. rewrite H. rewrite Nat.div_add. ring. intro absurd. inversion absurd. Qed. (* g (f ... f 0) = 1 + ... + 1 + g 0 *) Lemma diagPlaneSurject : forall n : nat, let (i,j) := diagPlaneInv n in diagPlane i j = n. Proof. assert (forall i j:nat, let (k, l) := diagPlaneInvNext i j in diagPlane k l = S (diagPlane i j)). { intros. destruct (diagPlaneInvNext i j) as [k l] eqn:des. unfold diagPlane. unfold diagPlaneInvNext in des. destruct i. - inversion des. subst l. subst k. clear des. rewrite Nat.add_0_l. rewrite Nat.add_0_r. rewrite Nat.add_0_l. rewrite diagPlaneAbsNext. ring. - inversion des. subst l. subst k. clear des. assert ((i + S j) = S i + j)%nat. ring. rewrite H. assert (S j + (S i + j) * S (S i + j) / 2 = S (j + (S i + j) * S (S i + j) / 2))%nat. ring. rewrite H0. reflexivity. } induction n. - reflexivity. - unfold diagPlaneInv. simpl. unfold diagPlaneInv in IHn. destruct (iterateN2Func n 0 0 diagPlaneInvNext) as [i j]. rewrite <- IHn. apply H. Qed. Lemma diagPlaneInjectBis : forall i j k l : nat, diagPlane i j = diagPlane k l -> (i = k /\ j = l). Proof. intros. unfold diagPlane in H. remember (i + j)%nat as I. remember (k + l)%nat as K. assert (I = K). - destruct (Nat.lt_trichotomy I K). + exfalso. unfold lt in H0. assert ((S I) * S (S I) / 2 <= K * S K / 2)%nat. apply Nat.div_le_mono. intro absurd. inversion absurd. apply Nat.mul_le_mono_nonneg. apply Nat.le_0_l. assumption. apply Nat.le_0_l. apply le_n_S. assumption. rewrite diagPlaneAbsNext in H1. apply (Nat.add_le_mono_l (I * S I / 2 + S I) (K * S K / 2) l) in H1. rewrite <- H in H1. rewrite <- (Nat.add_comm (S I)) in H1. rewrite Nat.add_assoc in H1. apply Nat.le_le_add_le in H1. rewrite HeqI in H1. apply (Nat.nle_succ_diag_l j). apply (Nat.le_trans (S j) (l + S (i + j))). rewrite <- (Nat.add_0_r (S j)). assert (l + S (i + j) = S j + (l + i))%nat. ring. rewrite H2. pose proof (Nat.add_le_mono_l). apply Nat.add_le_mono_l. apply Nat.le_0_l. assumption. apply Nat.le_refl. + destruct H0. assumption. exfalso. unfold lt in H0. assert ((S K) * S (S K) / 2 <= I * S I / 2)%nat. apply Nat.div_le_mono. intro absurd. inversion absurd. apply Nat.mul_le_mono_nonneg. apply Nat.le_0_l. assumption. apply Nat.le_0_l. apply le_n_S. assumption. rewrite diagPlaneAbsNext in H1. apply (Nat.add_le_mono_l (K * S K / 2 + S K) (I * S I / 2) j) in H1. rewrite H in H1. rewrite <- (Nat.add_comm (S K)) in H1. rewrite Nat.add_assoc in H1. apply Nat.le_le_add_le in H1. rewrite HeqK in H1. apply (Nat.nle_succ_diag_l l). apply (Nat.le_trans (S l) (j + S (k + l))). rewrite <- (Nat.add_0_r (S l)). assert (j + S (k + l) = S l + (j + k))%nat. ring. rewrite H2. pose proof Nat.add_le_mono_l. apply Nat.add_le_mono_l. apply Nat.le_0_l. assumption. apply Nat.le_refl. - rewrite <- H0 in H. apply Nat.add_cancel_r in H. subst l. subst K. rewrite H0 in HeqI. apply Nat.add_cancel_r in HeqI. subst k. split; reflexivity. Qed. Lemma diagPlaneInject : forall i j : nat, diagPlaneInv (diagPlane i j) = pair i j. Proof. intros. destruct (diagPlaneInv (diagPlane i j)) as [k l] eqn:des. pose proof (diagPlaneSurject (diagPlane i j)). rewrite des in H. apply diagPlaneInjectBis in H. destruct H. subst k. subst l. reflexivity. Qed. Definition diagSeq {X : Type} (u : nat -> nat -> X) (p : nat) := let (n, k) := diagPlaneInv p in u n k. Lemma sub_cancel_m : forall n i:nat, (i <= n -> n - (n - i) = i)%nat. Proof. intros. pose proof (Nat.sub_add i n H). apply Nat.add_sub_eq_l in H0. assumption. Qed. Lemma diagSumTriangle : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R), forall n : nat, CRsum (diagSeq u) (diagPlane 0 n) == CRsum (fun i => CRsum (u i) (n-i)) n. Proof. induction n. - simpl. unfold diagSeq. reflexivity. - (* The bigger triangle is the smaller one plus the diagonal *) assert (forall i:nat, i <= S n -> diagPlane 0 n + S i = diagPlane (S n - i) i)%nat. { intros. unfold diagPlane. rewrite Nat.add_0_l. rewrite Nat.sub_add. rewrite diagPlaneAbsNext. ring. assumption. } pose proof (H (S n)). rewrite Nat.sub_diag in H0. rewrite <- H0. assert (diagPlane 0 n + S (S n) = S (diagPlane 0 n) + (S n))%nat. ring. rewrite H1. rewrite sum_assoc. rewrite IHn. clear IHn. rewrite (reverse_sum (fun k : nat => diagSeq u (S (diagPlane 0 n) + k))). simpl. (* Remove point S n, 0 *) rewrite Nat.sub_diag. rewrite Nat.add_0_r. simpl. assert (diagSeq u (S (diagPlane 0 n)) = u (S n) O). { pose proof (H O (Nat.le_0_l (S n))). rewrite Nat.sub_0_r in H2. rewrite Nat.add_succ_r in H2. rewrite Nat.add_0_r in H2. rewrite H2. unfold diagSeq. rewrite diagPlaneInject. reflexivity. } rewrite H2. rewrite <- CRplus_assoc. apply CRplus_morph. (* Then rearrange main sum *) rewrite <- sum_plus. apply CRsum_eq. intros. assert (match i with | 0 => S n | S l => n - l end = S (n - i))%nat. { destruct i. rewrite Nat.sub_0_r. reflexivity. rewrite Nat.sub_succ_r. rewrite Nat.succ_pred. reflexivity. apply Nat.sub_gt. assumption. } rewrite H4. simpl. apply CRplus_morph. reflexivity. pose proof (H (S (n - i))). simpl in H5. assert (S (n - i) <= S n)%nat. { apply le_n_S. apply Nat.le_sub_l. } 2: reflexivity. 2: apply Nat.le_refl. specialize (H5 H6). rewrite Nat.add_succ_r in H5. rewrite H5. unfold diagSeq. rewrite diagPlaneInject. rewrite sub_cancel_m. reflexivity. assumption. Qed. Lemma diagSumMajTriangle : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R), (forall n k : nat, 0 <= u n k) -> forall n : nat, CRsum (diagSeq u) (diagPlane 0 n) <= CRsum (fun i => CRsum (u i) n) n. Proof. (* The triangle is included in the square *) intros. rewrite diagSumTriangle. apply sum_Rle. intros. apply pos_sum_more. intros. apply H. apply Nat.le_sub_l. Qed. Lemma diagSumMaj : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R) (A : CRcarrier R), (forall n k : nat, 0 <= u n k) -> (forall n k : nat, CRsum (fun i => CRsum (u i) k) n <= A) -> forall n:nat, CRsum (diagSeq u) n <= A. Proof. (* Finish the triangle and apply previous lemma *) intros. destruct (diagPlaneInv n) as [i j] eqn:desN. apply (CRle_trans _ (CRsum (diagSeq u) (n+i))). - apply pos_sum_more. unfold diagSeq. intros. destruct (diagPlaneInv k). apply H. rewrite <- (Nat.add_0_r n). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. rewrite Nat.add_0_l. apply Nat.le_0_l. - assert (diagPlane 0 (i+j) = n + i)%nat. pose proof (diagPlaneSurject n). rewrite desN in H1. unfold diagPlane in H1. unfold diagPlane. rewrite <- H1. simpl. ring. rewrite <- H1. apply (CRle_trans _ (CRsum (fun k => CRsum (u k) (i+j)) (i+j))). apply diagSumMajTriangle. apply H. apply H0. Qed. Lemma diagSumMajByLine : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R) (A : CRcarrier R), (forall n k : nat, 0 <= u n k) -> (forall n:nat, CRsum (diagSeq u) n <= A) -> forall n k:nat, CRsum (u n) k <= A. Proof. intros. specialize (H0 (diagPlane 0 (n + k))). rewrite diagSumTriangle in H0. apply (CRle_trans _ (CRsum (fun i : nat => CRsum (u i) (n + k - i)) (n + k))). pose proof (selectOneInSum (fun i : nat => CRsum (u i) (n + k - i)) (n + k) n). simpl in H1. rewrite Nat.add_comm in H1. rewrite Nat.add_sub in H1. rewrite Nat.add_comm in H1. apply H1. rewrite <- (Nat.add_0_r n). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. intros. apply cond_pos_sum. intros. apply H. assumption. Qed. Lemma powerPositive : forall {R : ConstructiveReals} (n:nat), (0 < CRpow (CR_of_Q R 2) n). Proof. intros. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. Qed. Lemma DiagTriangleShift : forall (p n : nat), let (i, j) := diagPlaneInv p in le (i + j) n -> le p (diagPlane 0 n). Proof. intros. destruct (diagPlaneInv p) as [i j] eqn:des. intros. apply (Nat.le_trans p (diagPlane 0 (i+j))). replace (diagPlane 0 (i + j)) with (p + i)%nat. rewrite <- (Nat.add_0_r p). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. pose proof (diagPlaneSurject p). rewrite des in H0. unfold diagPlane in H0. unfold diagPlane. subst p. rewrite Nat.add_0_l. ring. unfold diagPlane. rewrite Nat.add_0_l. rewrite Nat.add_0_l. remember (i + j)%nat. apply Nat.add_le_mono. assumption. apply Nat.div_le_mono. auto. apply Nat.mul_le_mono_nonneg. apply Nat.le_0_l. assumption. apply Nat.le_0_l. apply le_n_S. assumption. Qed. Fixpoint DiagTruncateRect {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R) (sumCol : nat -> CRcarrier R) (eps : CRcarrier R) (n : nat) : 0 < eps -> (forall n:nat, series_cv (u n) (sumCol n)) -> { p : nat & forall q k:nat, le k n -> le p q -> CRabs _ (CRsum (u k) q - sumCol k) < eps * CRpow (CR_of_Q _ (1#2)) k }. Proof. intros. destruct n. - destruct (CRup_nat (CRinv R eps (inr H))) as [epsN maj]. specialize (H0 O (Pos.of_nat epsN)) as [p lim]. exists p. intros. apply CRltEpsilon. inversion H0. subst k. simpl. apply CRltForget. rewrite CRmult_1_r. apply (CRle_lt_trans _ (CR_of_Q R (1 # Pos.of_nat epsN))). apply lim, H1. apply (CRmult_lt_compat_l eps) in maj. 2: exact H. rewrite CRinv_r in maj. apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos (Pos.of_nat epsN) # 1))). apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. setoid_replace ((Z.pos (Pos.of_nat epsN) # 1) * (1 # Pos.of_nat epsN))%Q with 1%Q. rewrite CRmult_comm. apply (CRlt_le_trans _ _ _ maj). apply CRmult_le_compat_l_half. exact H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct epsN. discriminate. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite SuccNat2Pos.id_succ, Nat2Pos.id. apply Nat.le_refl. discriminate. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. reflexivity. - destruct (DiagTruncateRect _ u sumCol eps n H H0) as [pp geo]. assert (0 < CRpow (CR_of_Q R (1#2)) (S n)). { apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. } destruct (CRup_nat (CRinv R eps (inr H) * (CRinv R (CRpow (CR_of_Q R (1#2)) (S n))) (inr H1))) as [epsN maj]. specialize (H0 (S n) (Pos.of_nat epsN)) as [p lim]. exists (p + pp)%nat. intros. apply Nat.le_succ_r in H0. apply CRltEpsilon. destruct H0. + apply CRltForget. apply geo. assumption. apply (Nat.le_trans pp (p + pp)). rewrite <- (Nat.add_0_l pp). rewrite Nat.add_assoc. apply Nat.add_le_mono_r. apply Nat.le_0_l. assumption. + subst k. apply CRltForget. apply (CRle_lt_trans _ (CR_of_Q R (1 # Pos.of_nat epsN))). apply lim. apply (Nat.le_trans p (p + pp)). rewrite <- (Nat.add_0_r p). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. assumption. apply (CRmult_lt_compat_l eps) in maj. 2: exact H. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l in maj. apply (CRmult_lt_compat_l (CRpow (CR_of_Q R (1 # 2)) (S n))) in maj. 2: apply CRpow_gt_zero; apply CR_of_Q_lt; reflexivity. rewrite CRinv_r in maj. apply (CRmult_lt_reg_l (CR_of_Q R (Z.pos (Pos.of_nat epsN) # 1))). apply CR_of_Q_lt. reflexivity. rewrite <- CR_of_Q_mult. setoid_replace ((Z.pos (Pos.of_nat epsN) # 1) * (1 # Pos.of_nat epsN))%Q with 1%Q. apply (CRlt_le_trans _ _ _ maj). rewrite CRmult_comm. rewrite <- CRmult_assoc. apply CRmult_le_compat_r. apply CRlt_asym, CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. rewrite CRmult_comm. apply CRmult_le_compat_r. apply CRlt_asym, H. apply CR_of_Q_le. unfold Qle, Qnum, Qden. do 2 rewrite Z.mul_1_r. destruct epsN. discriminate. apply Pos2Z.pos_le_pos. apply Pos2Nat.inj_le. rewrite SuccNat2Pos.id_succ, Nat2Pos.id. apply Nat.le_refl. discriminate. unfold Qmult, Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. reflexivity. Qed. Lemma DiagSeqNegTriangle : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R) (n p : nat) (eps sAbs : CRcarrier R), (forall k : nat, le (diagPlane 0 n) k -> (CRabs _ (CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) k - sAbs) < eps )) -> CRabs _ (CRsum (fun k : nat => CRsum (u (S n + k)%nat) (p - k)) p) < eps * CR_of_Q R 2. Proof. intros. apply (CRle_lt_trans _ (CRsum (fun k : nat => CRabs _ (CRsum (u (S n + k)%nat) (p - k))) p)). apply multiTriangleIneg. apply (CRle_lt_trans _ (CRsum (fun k : nat => CRsum (fun l => CRabs _ (u (S n + k)%nat l)) (p - k)) p)). apply sum_Rle. intros. apply multiTriangleIneg. apply (CRle_lt_trans _ (CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) (diagPlane 0 (S n + p)) - CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) (diagPlane 0 n))). rewrite (diagSumTriangle _ (S n + p)). rewrite (diagSumTriangle _ n). rewrite sum_assoc. rewrite CRplus_comm. rewrite <- (CRplus_0_r (CRsum (fun k : nat => CRsum (fun l : nat => CRabs _ (u (S n + k)%nat l)) (p - k)) p)). setoid_replace (CRsum (fun k : nat => CRsum (fun j : nat => CRabs _ (u (S n + k)%nat j)) (S n + p - (S n + k))) p) with (CRsum (fun k : nat => CRsum (fun l : nat => CRabs _ (u (S n + k)%nat l)) (p - k)) p). unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. rewrite CRplus_comm. rewrite <- (CRplus_opp_l (CRsum (fun i : nat => CRsum (fun j : nat => CRabs _ (u i j)) (n - i)) n)). apply CRplus_le_compat_l. apply sum_Rle. intros. apply pos_sum_more. intros. apply CRabs_pos. apply Nat.sub_le_mono_r. simpl. apply le_S. rewrite <- (Nat.add_0_r n). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. apply CRsum_eq. intros. replace (S n + p - (S n + i))%nat with (p - i)%nat. reflexivity. simpl. rewrite Nat.sub_add_distr. rewrite Nat.add_comm. rewrite Nat.add_sub. reflexivity. apply (CRle_lt_trans _ _ _ (CRle_abs _)). setoid_replace (CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) (diagPlane 0 (S n + p)) - CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) (diagPlane 0 n)) with (CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) (diagPlane 0 (S n + p)) - sAbs + (sAbs - CRsum (diagSeq (fun i j : nat => CRabs _ (u i j))) (diagPlane 0 n))). apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)). rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_l, CRmult_1_r. apply CRplus_le_lt_compat. apply CRlt_asym. apply (H (diagPlane 0 (S n + p))). unfold diagPlane. rewrite Nat.add_0_l. rewrite Nat.add_0_l. remember (S n + p)%nat as n0. assert (n <= n0)%nat. subst n0. simpl. apply le_S. rewrite <- (Nat.add_0_r n). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. apply Nat.add_le_mono. assumption. apply Nat.div_le_mono. auto. apply Nat.mul_le_mono. assumption. apply le_n_S. assumption. rewrite CRabs_minus_sym. apply H. apply Nat.le_refl. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Lemma DiagSeqInfiniteSum : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R) (sumCol : nat -> CRcarrier R) (sAbs : CRcarrier R), series_cv (diagSeq (fun i j => CRabs _ (u i j))) sAbs -> (forall n:nat, series_cv (u n) (sumCol n)) -> { s : CRcarrier R & (series_cv sumCol s) * (series_cv (diagSeq u) s) * (s <= sAbs) }%type. Proof. intros R u sumCol sAbs H7 H1. assert { s : CRcarrier R & prod (series_cv (diagSeq u) s) (s <= sAbs) } as [s H]. { destruct (series_cv_maj (diagSeq u) (diagSeq (fun i j => CRabs _ (u i j))) sAbs) as [s scv]. intros. unfold diagSeq. destruct (diagPlaneInv n). apply CRle_refl. exact H7. exists s. exact scv. } exists s. split. split. 2: apply H. 2: apply H. destruct H as [H _]. pose proof (Un_cv_nat_real _ _ H7) as H0. clear H7. apply Un_cv_real_nat. intros eps epsPos. (* Take big triangle absolute-close to epsilon *) assert (forall n : nat, (0 <= diagSeq (fun i j : nat => CRabs _ (u i j)) n)) as diagPos. { intro n. unfold diagSeq. destruct (diagPlaneInv n). apply CRabs_pos. } assert (0 < eps * CRpow (CR_of_Q R (1#2)) 3) as eighthEpsPos. { apply CRmult_lt_0_compat. assumption. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. } destruct (H0 (eps * CRpow (CR_of_Q R (1#2)) 3) eighthEpsPos) as [Nabs H2]. pose proof (DiagTriangleShift Nabs) as tShift. destruct (diagPlaneInv Nabs) as [i j] eqn:desNabs. exists (i + j)%nat. intros n nMaj. specialize (tShift n nMaj). setoid_replace eps with (INR 7 * eps * CRpow (CR_of_Q R (1#2)) 3 + eps * CRpow (CR_of_Q R (1#2)) 3). setoid_replace (CRsum sumCol n - s) with (CRsum sumCol n -CRsum (diagSeq u) (diagPlane 0 n) + (CRsum (diagSeq u) (diagPlane 0 n) - s)). apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)). apply CRplus_le_lt_compat. - (* Replace infinite rectangle by finite trapeze, which contains the main triangle. *) apply CRlt_asym. destruct (DiagTruncateRect u sumCol (eps * CRpow (CR_of_Q R (1#2)) 4) n) as [p geo]. apply CRmult_lt_0_compat. assumption. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. intros. apply H1. setoid_replace (CRsum sumCol n - CRsum (diagSeq u) (diagPlane 0 n)) with (CRsum sumCol n - CRsum (fun k => (CRsum (u k) (p+(n-k)))) n + (CRsum (fun k => (CRsum (u k) (p+(n-k)))) n - CRsum (diagSeq u) (diagPlane 0 n))). apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)). setoid_replace (INR 7 * eps * CRpow (CR_of_Q R (1 # 2)) 3) with (eps * CRpow (CR_of_Q R (1 # 2)) 3 + INR 6 * eps * CRpow (CR_of_Q R (1 # 2)) 3). apply CRplus_le_lt_compat. + apply CRlt_asym. unfold CRminus. rewrite <- sum_opp, <- sum_plus. (* Majorate by the trapeze, which contains the triangle *) apply (CRle_lt_trans _ (CRsum (fun l : nat => CRabs _ (sumCol l - CRsum (u l) (p+(n-l)))) n)). apply multiTriangleIneg. apply (CRle_lt_trans _ (CRsum (fun k => eps * CRpow (CR_of_Q R (1 # 2)) 4 * CRpow (CR_of_Q R (1 # 2)) k) n)). apply sum_Rle. intros. specialize (geo (p + (n - k))%nat k). apply CRlt_asym. rewrite CRabs_minus_sym. apply geo. exact H3. rewrite <- (Nat.add_0_r p). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. rewrite <- (CRsum_eq (fun k : nat => CRpow (CR_of_Q R (1 # 2)) k * (eps * CRpow (CR_of_Q R (1 # 2)) 4))). rewrite sum_scale. rewrite CRmult_comm, CRmult_assoc. apply CRmult_lt_compat_l. assumption. setoid_replace (CRpow (CR_of_Q R (1 # 2)) 3) with (CRpow (CR_of_Q R (1 # 2)) 4 * CR_of_Q R 2). apply CRmult_lt_compat_l. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. apply GeoHalfBelowTwo. setoid_replace (CRpow (CR_of_Q R (1 # 2)) 4) with (CR_of_Q R (1#2) * CRpow (CR_of_Q R (1 # 2)) 3). 2: reflexivity. rewrite CRmult_comm, <- CRmult_assoc, <- (CR_of_Q_mult _ 2). setoid_replace (2 * (1 # 2))%Q with 1%Q. rewrite CRmult_1_l. reflexivity. reflexivity. intros. apply CRmult_comm. + destruct p. setoid_replace (CRsum (fun k : nat => CRsum (u k) (0 + (n - k))) n) with (CRsum (diagSeq u) (diagPlane 0 n)). unfold CRminus. rewrite CRplus_opp_r. rewrite CRabs_right. 2: apply CRle_refl. apply CRmult_lt_0_compat. apply CRmult_lt_0_compat. apply CR_of_Q_lt. reflexivity. assumption. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. simpl. rewrite diagSumTriangle. reflexivity. setoid_replace (CRsum (fun k : nat => CRsum (u k) (S p + (n - k))) n) with (CRsum (diagSeq u) (diagPlane 0 (S n+p)) - CRsum (fun k : nat => CRsum (u (S n + k)%nat) (p - k)) p). unfold CRminus. rewrite CRplus_comm. rewrite <- CRplus_assoc. setoid_replace (- CRsum (diagSeq u) (diagPlane 0 n) + CRsum (diagSeq u) (diagPlane 0 (S n + p)) + - CRsum (fun k : nat => CRsum (u (S n + k)%nat) (p - k)) p) with (CRsum (diagSeq u) (diagPlane 0 (S n + p)) - CRsum (diagSeq u) (diagPlane 0 n) - (CRsum (fun k : nat => CRsum (u (S n + k)%nat) (p - k)) p)). apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)). rewrite CRabs_opp. setoid_replace (INR 6 * eps * CRpow (CR_of_Q R (1 # 2)) 3) with (INR 2 * eps * CRpow (CR_of_Q R (1 # 2)) 3 + INR 4 * eps * CRpow (CR_of_Q R (1 # 2)) 3). apply CRplus_le_lt_compat. setoid_replace (CRsum (diagSeq u) (diagPlane 0 (S n + p)) - CRsum (diagSeq u) (diagPlane 0 n)) with (CRsum (diagSeq u) (diagPlane 0 (S n + p)) - s + (s - CRsum (diagSeq u) (diagPlane 0 n))). apply (CRle_trans _ _ _ (CRabs_triang _ _)). unfold INR. simpl (Z.of_nat 2 # 1). rewrite (CR_of_Q_plus R 1 1), CRmult_plus_distr_r, CRmult_1_l. rewrite CRmult_plus_distr_r. apply CRplus_le_compat. apply (CRle_trans _ (sAbs - CRsum (fun n0 : nat => CRabs _ (diagSeq u n0)) (diagPlane 0 (S n + p)))). apply (series_cv_abs_remainder (diagSeq u)). apply H. apply (series_cv_eq (diagSeq (fun i j : nat => CRabs _ (u i j)))). intros. unfold diagSeq. destruct (diagPlaneInv n0). reflexivity. apply Un_cv_real_nat. apply H0. rewrite <- (CRsum_eq (diagSeq (fun i j : nat => CRabs _ (u i j)))). apply CRlt_asym. apply (CRle_lt_trans _ _ _ (CRle_abs _)). rewrite CRabs_minus_sym. apply H2. pose proof (DiagTriangleShift Nabs (S n +p)). rewrite desNabs in H3. apply H3. apply (Nat.le_trans _ n). assumption. simpl. apply le_S. rewrite <- (Nat.add_0_r n). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. intros. unfold diagSeq. destruct (diagPlaneInv i0). reflexivity. rewrite CRabs_minus_sym. apply (CRle_trans _ (sAbs - CRsum (fun n0 : nat => CRabs _ (diagSeq u n0)) (diagPlane 0 n))). apply (series_cv_abs_remainder (fun n0 : nat => diagSeq u n0)). assumption. apply (series_cv_eq (diagSeq (fun i j : nat => CRabs _ (u i j)))). intros. unfold diagSeq. destruct (diagPlaneInv n0). reflexivity. apply Un_cv_real_nat. apply H0. rewrite <- (CRsum_eq (diagSeq (fun i j : nat => CRabs _ (u i j)))). apply CRlt_asym. apply (CRle_lt_trans _ _ _ (CRle_abs _)). rewrite CRabs_minus_sym. apply H2. assumption. intros. unfold diagSeq. destruct (diagPlaneInv i0). reflexivity. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. apply (CRlt_trans _ (eps * CRpow (CR_of_Q R (1 # 2)) 3 * CR_of_Q R 2)). apply (DiagSeqNegTriangle _ _ _ _ sAbs). intros. apply H2. apply (Nat.le_trans _ (diagPlane 0 n)); assumption. rewrite <- (CRmult_comm (CR_of_Q R 2)). rewrite CRmult_assoc. apply CRmult_lt_compat_r. apply CRmult_lt_0_compat. assumption. apply CRpow_gt_zero. simpl. apply CR_of_Q_lt. reflexivity. apply CR_of_Q_lt. reflexivity. setoid_replace (@INR R 6) with (@INR R 2 + @INR R 4). do 2 rewrite CRmult_plus_distr_r. reflexivity. unfold INR. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. reflexivity. apply CRplus_morph. 2: reflexivity. rewrite (diagSumTriangle _ (S n + p)). unfold CRminus. rewrite CRplus_comm. reflexivity. rewrite (diagSumTriangle _ (S n + p)). unfold CRminus. rewrite sum_assoc. rewrite (CRsum_eq (fun k : nat => CRsum (u (S n + k)%nat) (S n + p - (S n + k))) (fun k : nat => CRsum (u (S n + k)%nat) (p - k))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. apply CRsum_eq. intros. replace (S n + p - i0)%nat with (S p + (n - i0))%nat. reflexivity. rewrite Nat.add_sub_assoc. simpl. destruct i0. rewrite Nat.add_comm. reflexivity. rewrite Nat.add_comm. reflexivity. assumption. intros. replace (S n + p - (S n + i0))%nat with (p - i0)%nat. reflexivity. simpl. rewrite Nat.sub_add_distr. rewrite Nat.add_comm. rewrite Nat.add_sub. reflexivity. + setoid_replace (@INR R 7) with (1 + @INR R 6). do 2 rewrite CRmult_plus_distr_r. rewrite CRmult_1_l. reflexivity. unfold INR. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. reflexivity. + unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. - apply (CRle_lt_trans _ (sAbs - CRsum (fun n => CRabs _ (diagSeq u n)) (diagPlane 0 n))). apply (series_cv_abs_remainder (fun n0 : nat => diagSeq u n0)). apply H. apply (series_cv_eq (diagSeq (fun i j : nat => CRabs _ (u i j)))). intros. unfold diagSeq. destruct (diagPlaneInv n0). reflexivity. apply Un_cv_real_nat. apply H0. rewrite <- (CRsum_eq (diagSeq (fun i j : nat => CRabs _ (u i j)))). apply (CRle_lt_trans _ _ _ (CRle_abs _)). rewrite CRabs_minus_sym. apply H2. assumption. intros. unfold diagSeq. destruct (diagPlaneInv i0). reflexivity. - unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. - setoid_replace (CRpow (CR_of_Q R (1 # 2)) 3) with (CR_of_Q R (1 # 8)). rewrite <- CRmult_plus_distr_r. setoid_replace (INR 7 * eps + eps) with (eps * INR 8). rewrite CRmult_assoc. unfold INR. rewrite <- CR_of_Q_mult. setoid_replace ((Z.of_nat 8 # 1) * (1 # 8))%Q with 1%Q. rewrite CRmult_1_r. reflexivity. reflexivity. setoid_replace (@INR R 8) with (1 + @INR R 7). rewrite CRmult_plus_distr_l, CRmult_1_r, CRplus_comm, CRmult_comm. reflexivity. unfold INR. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. reflexivity. unfold CRpow. rewrite CRmult_1_r. do 2 rewrite <- CR_of_Q_mult. apply CR_of_Q_morph. reflexivity. Qed. Lemma growing_transit : forall {R : ConstructiveReals} (un : nat -> CRcarrier R), (forall n:nat, un n <= un (S n)) -> forall n p : nat, le n p -> un n <= un p. Proof. induction p. - intros. inversion H0. apply CRle_refl. - intros. apply Nat.le_succ_r in H0. destruct H0. apply (CRle_trans _ (un p)). apply IHp, H0. apply H. subst n. apply CRle_refl. Qed. (* In the positive case, requesting the convergence of Rabs diagSeq would be absurd, as it is the same as the conclusion. *) Lemma DiagSeqInfiniteSumColPos : forall {R : ConstructiveReals} (u : nat -> nat -> CRcarrier R) (sumCol : nat -> CRcarrier R) (s : CRcarrier R), (forall n k:nat, 0 <= u n k) -> (forall n:nat, series_cv (u n) (sumCol n)) -> (series_cv sumCol s) -> (series_cv (diagSeq u) s). Proof. intros R u sumCol s uPos cvCol cvSumCol. assert (forall n:nat, CRsum (diagSeq u) n <= s) as belowS. { apply diagSumMaj. assumption. intros n k. apply (CRle_trans _ (CRsum sumCol n)). apply sum_Rle. intros. apply growing_ineq. 2: apply cvCol. intro i. rewrite <- CRplus_0_r. apply CRplus_le_compat. apply CRle_refl. apply uPos. apply growing_ineq. 2: apply cvSumCol. intro i. rewrite <- CRplus_0_r. apply CRplus_le_compat. apply CRle_refl. apply (series_cv_nonneg (u (S i))). apply uPos. apply cvCol. } (* Conversely, show that diagSeq approaches s *) intros n. destruct (cvSumCol (2*n)%positive) as [N H1]. assert (0 < CR_of_Q R (1 # 4*n)) as quarterEpsPos. { apply CR_of_Q_lt. reflexivity. } destruct (DiagTruncateRect u sumCol (CR_of_Q R (1 # 4*n)) N quarterEpsPos cvCol) as [p H2]. exists (diagPlane 0 (N+p)). intros. (* Go back to the N+p triangle *) rewrite CRabs_minus_sym. rewrite CRabs_right. apply (CRle_trans _ (s - CRsum (diagSeq u) (diagPlane 0 (N + p)))). unfold CRminus. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply growing_transit. - intro k. rewrite <- (CRplus_0_r (CRsum (diagSeq u) k)). simpl. apply CRplus_le_compat_l. unfold diagSeq. destruct (diagPlaneInv (S k)). apply uPos. - apply H. - rewrite diagSumTriangle. (* Truncate to the N trapeze *) apply (CRle_trans _ (s - CRsum (fun i : nat => CRsum (u i) (N + p - i)) N)). unfold CRminus. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply pos_sum_more. intro k. apply cond_pos_sum. apply uPos. rewrite <- (Nat.add_0_r N). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. (* Extend to the infinite vertical rectangle *) apply (CRle_trans _ (s - CRsum sumCol N + CR_of_Q R (1#2*n))). specialize (H1 N (Nat.le_refl N)). rewrite CRabs_minus_sym in H1. apply (CRle_trans _ _ _ (CRle_abs _)) in H1. unfold CRminus. rewrite CRplus_assoc. apply CRplus_le_compat_l. apply (CRplus_le_reg_l (CRsum sumCol N)). rewrite <- CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_l. rewrite <- sum_opp. rewrite <- sum_plus. apply (CRle_trans _ (CRsum (fun k => CR_of_Q R (1#4*n) * CRpow (CR_of_Q R (1#2)) k) N)). apply sum_Rle. intros n0 H0. specialize (H2 (N+p-n0)%nat n0). apply (CRle_trans _ _ _ (CRle_abs _)). pose proof (CRabs_minus_sym (sumCol n0)). unfold CRminus in H3. rewrite H3. clear H3. apply CRlt_asym, H2. exact H0. rewrite Nat.add_comm. rewrite <- Nat.add_sub_assoc. rewrite <- (Nat.add_0_r p). rewrite <- Nat.add_assoc. apply Nat.add_le_mono_l. apply Nat.le_0_l. assumption. rewrite (CRsum_eq _ (fun k : nat => CRpow (CR_of_Q R (1#2)) k * (CR_of_Q R (1# 4*n)))). rewrite sum_scale, CRmult_comm. apply CRlt_asym. apply (CRlt_le_trans _ (CR_of_Q R (1#4*n) * CR_of_Q R 2)). apply CRmult_lt_compat_l. exact quarterEpsPos. apply GeoHalfBelowTwo. rewrite <- CR_of_Q_mult. apply CR_of_Q_le. unfold Qmult, Qle, Qnum, Qden. do 2 rewrite Z.mul_1_l. rewrite <- Pos2Z.inj_mul. rewrite Pos.mul_1_r, Pos.mul_assoc. apply Z.le_refl. intros. apply CRmult_comm. apply (CRplus_le_reg_r (- CR_of_Q R (1#2*n))). rewrite CRplus_assoc. rewrite CRplus_opp_r. rewrite CRplus_0_r. rewrite <- CR_of_Q_opp, <- CR_of_Q_plus. setoid_replace ((1 # n) + - (1 # 2 * n))%Q with (1 # 2*n)%Q. specialize (H1 N (Nat.le_refl N)). apply (CRle_trans _ _ _ (CRle_abs _)). rewrite CRabs_minus_sym. apply H1. rewrite <- (Qplus_inj_r _ _ (1#2*n)). rewrite Qinv_plus_distr. ring_simplify. reflexivity. - rewrite <- (CRplus_opp_r (CRsum (diagSeq u) i)). apply CRplus_le_compat. apply belowS. apply CRle_refl. Qed. Lemma Rlt_0_half : forall {R : ConstructiveReals}, 0 < CR_of_Q R (1#2). Proof. intro R. apply CR_of_Q_lt. reflexivity. Qed. Fixpoint FindPointInSubdivision (Pn : nat -> nat) (n : nat) : (forall k, Pn k < Pn (S k))%nat -> (Pn O = O) -> { p : nat | (Pn p <= n < Pn (S p))%nat }. Proof. intros. destruct n. - exists O. repeat split. rewrite H0. apply Nat.le_refl. specialize (H O). rewrite H0 in H. apply H. - destruct (FindPointInSubdivision Pn n H H0) as [k kmaj]. destruct (le_lt_dec (Pn (S k)) (S n)). + exists (S k). split. apply l. apply (Nat.lt_le_trans _ (S (Pn (S k)))). apply le_n_S. apply kmaj. apply (H (S k)). + exists k. split. 2: apply l. apply (Nat.le_trans _ n). apply kmaj. apply le_S. apply Nat.le_refl. Qed. Lemma FindPointInSubdivisionSmallest : forall (Pn : nat -> nat) (Pinc : forall k, lt (Pn k) (Pn (S k))) (Pzero : Pn O = O) (n i : nat), le (Pn i) n -> le i (proj1_sig (FindPointInSubdivision Pn n Pinc Pzero)). Proof. induction i. - intros. apply Nat.le_0_l. - intros. destruct (FindPointInSubdivision Pn n Pinc Pzero) as [r rmaj]. simpl in IHi. simpl. assert (i <= r)%nat. apply IHi. apply (Nat.le_trans _ (Pn (S i))). 2: apply H. specialize (Pinc i). apply le_S in Pinc. apply le_S_n in Pinc. apply Pinc. clear IHi. apply le_n_S in H0. apply Nat.le_succ_r in H0. destruct H0. apply H0. exfalso. inversion H0. subst i. apply Nat.le_ngt in H. destruct rmaj. contradiction. Qed. Lemma ROpenBallConvex : forall {R : ConstructiveReals} (x r a b c : CRcarrier R), (a <= b /\ b <= c) -> CRabs _ (x - a) <= r -> CRabs _ (x - c) <= r -> CRabs _ (x - b) <= r. Proof. intros. apply CRabs_le. destruct H. apply CRabs_def2 in H0. apply CRabs_def2 in H1. split. - apply (CRle_trans _ (x-c)). apply H1. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply H2. - apply (CRle_trans _ (x-a)). 2: apply H0. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply H. Qed. (* Positivity is necessary, because 1 - 1 can be summed by blocks of two and make a constant zero sum, whereas individually the sum oscillates between 0 and 1. *) Lemma infinite_sum_assoc : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (Pn : nat -> nat) (s : CRcarrier R), (forall n, Pn n < Pn (S n))%nat -> (forall n, 0 <= xn n) -> Pn O = O -> (series_cv (fun n => CRsum (fun k => xn (k+ Pn n)%nat) (Pn (S n) - Pn n - 1)) s) -> series_cv xn s. Proof. intros. assert (forall p q : nat, p <= q -> Pn p <= Pn q)%nat as PnInc. { induction q. - intros. inversion H3. apply Nat.le_refl. - intros. apply Nat.le_succ_r in H3. destruct H3. apply (Nat.le_trans _ (Pn q)). apply IHq. apply H3. apply (Nat.le_trans _ (S (Pn q))). apply le_S. apply Nat.le_refl. apply H. subst p. apply Nat.le_refl. } assert (forall p:nat, CRsum (fun n : nat => CRsum (fun k : nat => xn (k + Pn n))%nat (Pn (S n) - Pn n - 1)) p == CRsum xn (Pn (S p) - 1)) as assocSum. { induction p. - simpl. repeat rewrite H1. rewrite Nat.sub_0_r. rewrite (CRsum_eq _ xn). reflexivity. intros. rewrite Nat.add_0_r. reflexivity. - simpl. rewrite IHp. clear IHp. destruct (Nat.le_exists_sub 1 (Pn (S p))) as [r [H3 _]]. specialize (H p). apply (Nat.le_trans _ (S (Pn p))). 2: apply H. apply le_n_S. apply Nat.le_0_l. assert (r+1 = S r)%nat. rewrite Nat.add_comm. reflexivity. rewrite H3. rewrite Nat.add_sub. rewrite (CRsum_eq (fun k : nat => xn (k + (r + 1))%nat) (fun k : nat => xn (S r + k)%nat)). rewrite <- (sum_assoc xn r). replace (S r + (Pn (S (S p)) - (r + 1) - 1))%nat with (Pn (S (S p)) - 1)%nat. reflexivity. rewrite Nat.add_sub_assoc. rewrite <- H4. rewrite Nat.add_comm. rewrite Nat.sub_add. reflexivity. rewrite <- H3. apply (Nat.le_trans _ (S (Pn (S p)))). apply le_S. apply Nat.le_refl. apply H. rewrite <- H3. destruct (Nat.le_exists_sub (S (Pn (S p))) (Pn (S (S p)))). apply H. destruct H5. rewrite H5. simpl. replace (S (Pn (S p))) with (1 + Pn (S p))%nat. rewrite Nat.add_assoc. rewrite Nat.add_sub. 2: reflexivity. rewrite Nat.add_comm. apply le_n_S. apply Nat.le_0_l. intros. rewrite Nat.add_comm. rewrite (Nat.add_comm r). reflexivity. } assert (forall n:nat, (Pn 1 <= n)%nat -> let (p,_) := FindPointInSubdivision Pn n H H1 in (CRsum (fun n : nat => CRsum (fun k : nat => xn (k + Pn n))%nat (Pn (S n) - Pn n - 1)) (p-1) <= CRsum xn n /\ CRsum xn n <= CRsum (fun n : nat => CRsum (fun k : nat => xn (k + Pn n))%nat (Pn (S n) - Pn n - 1)) p)). { intro n. destruct (FindPointInSubdivision Pn n H H1) as [p pmaj]. repeat rewrite assocSum. split. apply pos_sum_more. apply H0. destruct p. exfalso. apply Nat.le_ngt in H3. destruct pmaj. contradiction. simpl. rewrite Nat.sub_0_r. apply (Nat.le_trans _ (Pn (S p))). 2: apply pmaj. apply Nat.le_sub_l. apply pos_sum_more. apply H0. apply Nat.le_add_le_sub_r. rewrite Nat.add_comm. apply pmaj. } intros n. specialize (H2 n) as [p pmaj]. exists (Pn (S p)). intros. specialize (H3 i). pose proof (FindPointInSubdivisionSmallest Pn H H1 i). destruct (FindPointInSubdivision Pn i H H1) as [q qmaj]. rewrite CRabs_minus_sym. assert (S p <= q)%nat. { apply H4. apply H2. } apply (ROpenBallConvex _ _ (CRsum (fun n : nat => CRsum (fun k : nat => xn (k + Pn n)%nat) (Pn (S n) - Pn n - 1)) (q-1)) _ (CRsum (fun n : nat => CRsum (fun k : nat => xn (k + Pn n)%nat) (Pn (S n) - Pn n - 1)) q)). split; apply H3. apply (Nat.le_trans _ (Pn (S p))). 2: apply H2. apply PnInc. apply le_n_S. apply Nat.le_0_l. apply (Nat.le_trans _ (Pn (S p))). 2: apply H2. apply PnInc. apply le_n_S. apply Nat.le_0_l. rewrite CRabs_minus_sym. apply pmaj. apply Nat.le_add_le_sub_r. rewrite Nat.add_comm. apply H5. rewrite CRabs_minus_sym; apply pmaj. apply (Nat.le_trans _ (S p)). apply le_S. apply Nat.le_refl. apply H5. Qed. corn-8.20.0/reals/stdlib/ConstructiveFastReals.v000066400000000000000000000326741473720167500216450ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Proof that CoRN's fast reals implement the standard library's interface ConstructiveReals. *) From Coq Require Import ZArith ConstructiveReals. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.model.metric2.CRmetric. Require Import CoRN.reals.fast.CRFieldOps. Require Import CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRabs. Require Import CoRN.model.totalorder.QposMinMax. From Coq Require Import ConstructiveEpsilon. Lemma CRltT_linear : @isLinearOrder (RegularFunction Qball) CRltT. Proof. split. split. - intros. apply (CRlt_trans _ _ _ H) in H0. apply (CRlt_irrefl x H0). - intros. exact (CRlt_trans _ _ _ H H0). - apply CRlt_linear. Qed. Lemma CRlt_equiv : forall x y : CR, CRlt x y <-> exists n:nat, approximate x (Qpos2QposInf (1#Pos.of_nat n)) + (2#Pos.of_nat n) < approximate y (Qpos2QposInf (1#Pos.of_nat n)). Proof. split. - intros H. apply CR_lt_ltT in H. destruct H as [q H]. destruct q as [q qpos]; unfold proj1_sig in H. destruct q as [a b]. destruct a as [|a|a]. exfalso; inversion qpos. 2: exfalso; inversion qpos. clear qpos. assert (translate (1#b) x <= y)%CR. { rewrite (CRplus_le_r _ _ x) in H. ring_simplify in H. rewrite <- CRplus_translate. apply (@CRle_trans _ (' (Z.pos a # b) + x)%CR). 2: exact H. apply CRplus_le_r, CRle_Qle. change (b <= a*b)%positive. apply (Pos.le_trans _ (1*b)). apply Pos.le_refl. apply Pos.mul_le_mono_r. apply Pos.le_1_l. } clear H a. exists (Pos.to_nat (5*b)). rewrite Pos2Nat.id. apply (CRle_trans (lower_CRapproximation (translate (1#b) x) (1#5*b)%Qpos)) in H0. pose proof (upper_CRapproximation y (1#5*b)%Qpos) as H. apply (CRle_trans H0) in H. clear H0. apply CRle_Qle in H. simpl in H. rewrite Qplus_comm in H. unfold Qminus in H. rewrite <- Qplus_assoc in H. setoid_replace ((1 # b) + - (1 # b + b~0~0)) with ((3#5*b) + (1#5*b)) in H. rewrite Qplus_assoc in H. apply Qplus_le_l in H. refine (Qlt_le_trans _ _ _ _ H). apply Qplus_lt_r. apply Pos.mul_lt_mono_r. reflexivity. unfold canonical_names.equiv, stdlib_rationals.Q_eq. rewrite Qinv_plus_distr. setoid_replace (1#b) with (5#5*b) by reflexivity. rewrite Qinv_minus_distr. reflexivity. - intros [n H]. apply CR_lt_ltT. apply (@CRle_lt_trans _ _ _ (upper_CRapproximation x (1#Pos.of_nat n)%Qpos)). refine (CRlt_le_trans _ _ _ _ (lower_CRapproximation y (1#Pos.of_nat n)%Qpos)). apply CRlt_Qlt. simpl. apply (Qplus_lt_l _ _ (1# Pos.of_nat n)). ring_simplify. refine (Qle_lt_trans _ _ _ _ H). apply Qplus_le_r. apply Qle_refl. Qed. Lemma CRlt_or_epsilon : (forall a b c d : CR, CRlt a b \/ CRlt c d -> (a < b)%CR + (c < d)%CR). Proof. intros. assert (exists n:nat, approximate a (Qpos2QposInf (1#Pos.of_nat n)) + (2#Pos.of_nat n) < approximate b (Qpos2QposInf (1#Pos.of_nat n)) \/ approximate c (Qpos2QposInf (1#Pos.of_nat n)) + (2#Pos.of_nat n) < approximate d (Qpos2QposInf (1#Pos.of_nat n))). { destruct H. - apply CRlt_equiv in H. destruct H as [n H]. exists n. left. exact H. - apply CRlt_equiv in H. destruct H as [n H]. exists n. right. exact H. } apply constructive_indefinite_ground_description_nat in H0. - destruct H0 as [n H0]. destruct (Qlt_le_dec (approximate a (Qpos2QposInf (1 # Pos.of_nat n)) + (2 # Pos.of_nat n)) (approximate b (Qpos2QposInf (1 # Pos.of_nat n)))). + left. apply CR_lt_ltT, CRlt_equiv. exists n. exact q. + right. apply CR_lt_ltT, CRlt_equiv. exists n. destruct H0. 2: exact H0. exfalso. exact (Qlt_not_le _ _ H0 q). - intro n. clear H0 H. destruct (Qlt_le_dec (approximate a (Qpos2QposInf (1 # Pos.of_nat n)) + (2 # Pos.of_nat n)) (approximate b (Qpos2QposInf (1 # Pos.of_nat n)))). left. left. exact q. destruct (Qlt_le_dec (approximate c (Qpos2QposInf (1 # Pos.of_nat n)) + (2 # Pos.of_nat n)) (approximate d (Qpos2QposInf (1 # Pos.of_nat n)))). left. right. exact q0. right. intros [H|H]. exact (Qlt_not_le _ _ H q). exact (Qlt_not_le _ _ H q0). Qed. Lemma CReq_nlt : forall a b : CR, msp_eq a b <-> (fun x y : CR => (fun x0 y0 : CR => (y0 < x0)%CR -> False) y x /\ (fun x0 y0 : CR => (y0 < x0)%CR -> False) x y) a b. Proof. split. - split. intro abs. exact (CRlt_irrefl _ (@CRltT_wd _ _ H b _ (reflexivity _) abs)). intro abs. exact (CRlt_irrefl _ (@CRltT_wd b _ (reflexivity _) _ _ H abs)). - intros [H H0]. apply CRle_antisym. split. apply CRle_not_lt in H0. exact H0. apply CRle_not_lt in H. exact H. Qed. Lemma inject_Q_CR_plus : forall q r : Q, (fun x y : CR => (fun x0 y0 : CR => (y0 < x0)%CR -> False) y x /\ (fun x0 y0 : CR => (y0 < x0)%CR -> False) x y) (' (q + r)%Q)%CR (CRplus (' q)%CR (' r)%CR). Proof. intros q r. apply CReq_nlt, (CRplus_Qplus q r). Qed. Lemma inject_Q_CR_mult : forall q r : Q, (fun x y : CR => (fun x0 y0 : CR => (y0 < x0)%CR -> False) y x /\ (fun x0 y0 : CR => (y0 < x0)%CR -> False) x y) (' (q * r)%Q)%CR (CRmult (' q)%CR (' r)%CR). Proof. intros q r. apply CReq_nlt. symmetry. apply (CRmult_Qmult q r). Qed. Lemma CR_ring_nlt : ring_theory 0%CR 1%CR CRplus CRmult (fun x y : CR => CRplus x (- y)%CR) CRopp (fun x y : CR => (fun x0 y0 : CR => (y0 < x0)%CR -> False) y x /\ (fun x0 y0 : CR => (y0 < x0)%CR -> False) x y). Proof. destruct CR_ring_theory. split. - intro x. apply CReq_nlt, Radd_0_l. - intros x y. apply CReq_nlt, Radd_comm. - intros x y z. apply CReq_nlt, Radd_assoc. - intro x. apply CReq_nlt, Rmul_1_l. - intros x y. apply CReq_nlt, Rmul_comm. - intros x y z. apply CReq_nlt, Rmul_assoc. - intros x y z. apply CReq_nlt, Rdistr_l. - intros x y. apply CReq_nlt, Rsub_def. - intro x. apply CReq_nlt, Ropp_def. Qed. Lemma CR_ring_ext_nlt : ring_eq_ext CRplus CRmult CRopp (fun x y : CR => (fun x0 y0 : CR => (y0 < x0)%CR -> False) y x /\ (fun x0 y0 : CR => (y0 < x0)%CR -> False) x y). Proof. split. - intros x y H z t H0. apply CReq_nlt. apply CReq_nlt in H. apply CReq_nlt in H0. rewrite H, H0. reflexivity. - intros x y H z t H0. apply CReq_nlt. apply CReq_nlt in H. apply CReq_nlt in H0. rewrite H, H0. reflexivity. - intros x y H. apply CReq_nlt. apply CReq_nlt in H. rewrite H. reflexivity. Qed. Lemma CRmult_inv_r_nlt : (forall (r : CR) (rnz : (fun x y : CR => ((x < y)%CR + (y < x)%CR)%type) r 0%CR), (fun x y : CR => (fun x0 y0 : CR => (y0 < x0)%CR -> False) y x /\ (fun x0 y0 : CR => (y0 < x0)%CR -> False) x y) (CRinvT r rnz * r)%CR 1%CR). Proof. intros. apply CReq_nlt. rewrite CRmult_comm. apply CRmult_inv_r. Qed. Definition CRup (x : CR) : {n : positive & (x < ' (Z.pos n # 1))%CR}. Proof. exists (match Qnum (proj1_sig (CR_b (1#1)%Qpos x)) with | Z0 => 1%positive | Zpos p => Pos.succ p | Zneg p => 1%positive end). apply (CRle_lt_trans _ _ _ (CR_b_upperBound (1#1)%Qpos x)). apply CRlt_Qlt. destruct (CR_b (1 # 1) x), x0. simpl. destruct Qnum. - reflexivity. - change (p*1 < Pos.succ p * Qden)%positive. apply (Pos.le_lt_trans _ (p * Qden)). apply Pos.mul_le_mono_l. apply Pos.le_1_l. apply Pos.mul_lt_mono_r. apply Pos.lt_succ_diag_r. - reflexivity. Qed. Lemma CRabs_nlt : forall x y : CR, (((y < x)%CR -> False) /\ ((y < -x)%CR -> False)) <-> ((y < CRabs x)%CR -> False). Proof. split. - intros [H H0] H1. apply CRle_not_lt in H1. contradiction. clear H2 H1. pose proof (CRdistance_CRle y x 0%CR) as [H2 _]. unfold CRdistance in H2. rewrite CRopp_0, CRplus_0_r in H2. apply H2. clear H2. split. apply (CRplus_le_r _ _ y). apply CRle_not_lt in H. ring_simplify. exact H. apply CRle_not_lt in H0. rewrite (CRplus_le_r _ _ x) in H0. ring_simplify in H0. exact H0. - split. apply CRle_not_lt in H. apply CRle_not_lt. apply (@CRle_trans _ (CRabs x)). 2: exact H. apply CRle_abs. apply CRle_not_lt in H. apply CRle_not_lt. apply (@CRle_trans _ (CRabs x)). 2: exact H. rewrite <- CRabs_opp. apply CRle_abs. Qed. Definition CRcauchy_sequence (xn : nat -> CR) : Set := forall p : positive, {n : nat | forall i j : nat, (n <= i)%nat -> (n <= j)%nat -> (' (1 # p) < CRabs (xn i - xn j))%CR -> False}. Lemma Qarchimedean_le : forall q : Q, { p : positive | q <= Z.pos p # 1 }. Proof. intros. destruct q as [a b]. destruct a. - exists xH. discriminate. - exists p. unfold Qle; simpl. apply Pos.mul_le_mono_l, Pos.le_1_l. - exists xH. discriminate. Defined. Definition CRstandard_modulus (xn : nat -> CR) (xncau : CRcauchy_sequence xn) (e : QposInf) : CR := match e with | Qpos2QposInf q => xn (proj1_sig (xncau (proj1_sig (Qarchimedean_le (/ proj1_sig q))))) | QposInfinity => 0%CR end. Lemma CRstandard_regular : forall (xn : nat -> CR) (xncau : CRcauchy_sequence xn), is_RegularFunction (@ball CR) (CRstandard_modulus xn xncau). Proof. intros xn xncau e1 e2. apply CRabs_ball. unfold CRstandard_modulus. destruct (le_ge_dec (proj1_sig (xncau (proj1_sig (Qarchimedean_le (/ proj1_sig e1))))) (proj1_sig (xncau (proj1_sig (Qarchimedean_le (/ proj1_sig e2)))))). - destruct (xncau (proj1_sig (Qarchimedean_le (/ proj1_sig e1)))) as [n H]. simpl in l. destruct e1 as [e1 e1pos]. destruct e2 as [e2 e2pos]. unfold proj1_sig. specialize (H n _ (Nat.le_refl _) l). apply CRle_not_lt in H. apply (CRle_trans H). clear H. apply CRle_Qle. unfold proj1_sig. destruct (Qarchimedean_le (/ e1)) as [p H]. apply (Qle_trans _ (e1+0)). 2: apply Qplus_le_r, Qlt_le_weak, e2pos. rewrite Qplus_0_r. apply (Qmult_le_l _ _ e1) in H. 2: exact e1pos. rewrite Qmult_inv_r in H. change (1#p) with (/(Z.pos p#1)). apply Qle_shift_inv_r. reflexivity. apply H. apply (Qpos_nonzero (exist _ e1 e1pos)). - destruct (xncau (proj1_sig (Qarchimedean_le (/ proj1_sig e2)))) as [n H]. simpl in g. destruct e1 as [e1 e1pos]. destruct e2 as [e2 e2pos]. unfold proj1_sig. specialize (H _ n g (Nat.le_refl _)). apply CRle_not_lt in H. apply (CRle_trans H). clear H. apply CRle_Qle. unfold proj1_sig. destruct (Qarchimedean_le (/ e2)) as [p H]. apply (Qle_trans _ (0+e2)). 2: apply Qplus_le_l, Qlt_le_weak, e1pos. rewrite Qplus_0_l. apply (Qmult_le_l _ _ e2) in H. 2: exact e2pos. rewrite Qmult_inv_r in H. change (1#p) with (/(Z.pos p#1)). apply Qle_shift_inv_r. reflexivity. apply H. apply (Qpos_nonzero (exist _ e2 e2pos)). Qed. Lemma CRcauchy_complete : forall xn : nat -> CR, CRcauchy_sequence xn -> {l : CR & forall p : positive, {n : nat | forall i : nat, (n <= i)%nat -> (' (1 # p) < CRabs (xn i - l))%CR -> False}}. Proof. intros xn xncau. exists (Cjoin_fun (Build_RegularFunction (CRstandard_regular xn xncau))). intro p. exists (proj1_sig (xncau (2*p)%positive)). intros i H. apply CRle_not_lt. apply (CRle_trans (CRdistance_triangle _ (CRstandard_modulus xn xncau (Qpos2QposInf (1#2*p))) _)). apply (@CRle_trans _ ('(1#2*p) + '(1#2*p))%CR). apply CRplus_le_compat. - simpl. destruct (xncau (2*p)%positive) as [n H0] eqn:des. apply CRle_not_lt. apply H0. exact H. clear H i. simpl in des. rewrite des. apply Nat.le_refl. - apply CRabs_ball, ball_sym. apply (Cjoin_ball (Build_RegularFunction (CRstandard_regular xn xncau)) (1#2*p)). - rewrite CRplus_Qplus. apply CRle_Qle. rewrite Qinv_plus_distr. apply Z.le_refl. Qed. Definition FastRealsConstructive : ConstructiveReals := Build_ConstructiveReals (RegularFunction Qball) CRltT CRltT_linear CRlt (fun x y => fst (CR_lt_ltT x y)) (fun x y => snd (CR_lt_ltT x y)) CRlt_or_epsilon inject_Q_CR CRlt_Qlt Qlt_from_CRlt CRplus CRopp CRmult inject_Q_CR_plus inject_Q_CR_mult CR_ring_nlt CR_ring_ext_nlt (CRlt_Qlt 0 1 eq_refl) (fun r r1 r2 => fst (CRplus_lt_l r1 r2 r)) (fun r r1 r2 => snd (CRplus_lt_l r1 r2 r)) CRmult_lt_0_compat CRinvT CRmult_inv_r_nlt CRinv_0_lt_compat CRlt_Qmid CRup CRabs CRabs_nlt CRcauchy_complete. corn-8.20.0/reals/stdlib/ConstructiveFasterReals.v000066400000000000000000000350451473720167500221670ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Proof that CoRN's faster reals implement the standard library's interface ConstructiveReals. *) Require Import Coq.Reals.Abstract.ConstructiveReals. Require Import CoRN.reals.faster.ARArith. Require Import CoRN.reals.faster.ARabs. Require Import CoRN.metric2.Metric. Require Import CoRN.metric2.Complete. Require Import CoRN.metric2.MetricMorphisms. Require Import CoRN.model.metric2.Qmetric. Require Import CoRN.model.totalorder.QposMinMax. Require Import CoRN.reals.fast.CRArith. Require Import CoRN.reals.fast.CRabs. Require Import ConstructiveFastReals. Section ConstructiveFaster. Context {AQ : Set} `{AppRationals AQ}. (* Redefine ARltT in sort Set *) Definition AQPosS : Set := sig (lt zero). Definition ARposS (x : AR) : Set := sig (λ y : AQPosS, 'y ≤ x). Definition ARltS: AR → AR → Set := λ x y, ARposS (ARplus y (ARopp x)). Lemma ARltS_correct : eq ARltT ARltS. Proof. reflexivity. Qed. Lemma ARltS_linear : @isLinearOrder (RegularFunction (Eball (cast AQ Q))) ARltS. Proof. destruct ARfpsro, full_pseudo_srorder_pso. destruct pseudo_srorder_strict. split. split. - intros x y J J0. pose proof (AR_lt_ltT x y) as [_ J1]. pose proof (AR_lt_ltT y x) as [_ J2]. exact (pseudo_order_antisym x y (conj (J1 J) (J2 J0))). - intros. destruct (ARtoCR_preserves_ltT x z) as [_ a]. apply a. clear a. destruct (ARtoCR_preserves_ltT x y) as [a _]. apply a in H5. clear a. destruct (ARtoCR_preserves_ltT y z) as [a _]. apply a in H6. apply (CRlt_trans _ _ _ H5 H6). - intros x y z J. destruct (CRlt_linear (cast AR CR x) (cast AR CR y) (cast AR CR z)). apply (ARtoCR_preserves_ltT x z), J. left. destruct (ARtoCR_preserves_ltT x y). apply a, c. right. destruct (ARtoCR_preserves_ltT y z). apply a, c. Qed. Lemma ARlt_or_epsilon : forall a b c d : AR, ARlt a b \/ ARlt c d -> ARltS a b + ARltS c d. Proof. intros. destruct (CRlt_or_epsilon (cast AR CR a) (cast AR CR b) (cast AR CR c) (cast AR CR d)). - destruct H5. left. apply CR_lt_ltT, (ARtoCR_preserves_ltT a b), AR_lt_ltT. exact H5. right. apply CR_lt_ltT, (ARtoCR_preserves_ltT c d), AR_lt_ltT. exact H5. - left. apply (ARtoCR_preserves_ltT a b). exact c0. - right. apply (ARtoCR_preserves_ltT c d). exact c0. Qed. Lemma AReq_nlt : forall a b : AR, msp_eq a b <-> (fun x y : AR => (fun x0 y0 : AR => (ARltS y0 x0) -> False) y x /\ (fun x0 y0 : AR => (ARltS y0 x0) -> False) x y) a b. Proof. split. - split. pose proof (ARle_not_lt b a) as [H6 _]. apply H6. rewrite H5. apply PreOrder_Reflexive. pose proof (ARle_not_lt a b) as [H6 _]. apply H6. rewrite H5. apply PreOrder_Reflexive. - intros [J J0]. apply po_antisym. pose proof (ARle_not_lt a b) as [_ H6]. apply (H6 J0). pose proof (ARle_not_lt b a) as [_ H6]. apply (H6 J). Qed. Lemma inject_Q_AR_plus_nlt : ∀ q r : Q, (ARltS (inject_Q_AR (q + r)) (ARplus (inject_Q_AR q) (inject_Q_AR r)) → False) ∧ (ARltS (ARplus (inject_Q_AR q) (inject_Q_AR r)) (inject_Q_AR (q + r)) → False). Proof. intros. rewrite <- AReq_nlt. pose proof (inject_Q_AR_plus q r). simpl in H5. simpl. exact H5. Qed. Lemma inject_Q_AR_mult_nlt : ∀ q r : Q, (ARltS (inject_Q_AR (q * r)) (ARmult (inject_Q_AR q) (inject_Q_AR r)) → False) ∧ (ARltS (ARmult (inject_Q_AR q) (inject_Q_AR r)) (inject_Q_AR (q * r)) → False). Proof. intros. rewrite <- AReq_nlt. pose proof (inject_Q_AR_mult q r). simpl in H5. exact H5. Qed. Lemma AR_zero : msp_eq (inject_Q_AR 0) (cast AQ AR zero0). Proof. pose proof (ARtoCR_inject zero0) as H5. unfold cast in H5. unfold cast. rewrite inject_Q_AR_CR. apply (injective ARtoCR). rewrite H5. pose proof CRAR_id as H6. unfold cast in H6. rewrite (H6 (0%CR)). apply inject_Q_CR_wd. symmetry. apply rings.preserves_0. Qed. Lemma AR_one : msp_eq (inject_Q_AR 1) (cast AQ AR one0). Proof. pose proof (ARtoCR_inject one0) as H5. unfold cast in H5. unfold cast. rewrite inject_Q_AR_CR. apply (injective ARtoCR). rewrite H5. pose proof CRAR_id. unfold cast in H6. rewrite (H6 (1%CR)). apply inject_Q_CR_wd. symmetry. apply rings.preserves_1. Qed. Lemma AR_ring : ring_theory (inject_Q_AR 0) (inject_Q_AR 1) ARplus ARmult (λ x y : AR, ARplus x (ARopp y)) ARopp (λ x y : AR, (λ x0 y0 : AR, ARltS y0 x0 → False) y x ∧ (λ x0 y0 : AR, ARltS y0 x0 → False) x y). Proof. destruct (rings.stdlib_ring_theory AR). split. - intros. apply AReq_nlt. rewrite AR_zero. apply (Radd_0_l x). - intros. apply AReq_nlt. apply (Radd_comm x y). - intros. apply AReq_nlt. apply (Radd_assoc x y z). - intros. apply AReq_nlt. rewrite AR_one. apply (Rmul_1_l x). - intros. apply AReq_nlt. apply (Rmul_comm x y). - intros. apply AReq_nlt. apply (Rmul_assoc x y z). - intros. apply AReq_nlt. apply (Rdistr_l x y z). - intros. apply AReq_nlt. reflexivity. - intros. apply AReq_nlt. rewrite AR_zero. apply (Ropp_def x). Qed. Lemma AR_ring_ext : ring_eq_ext ARplus ARmult ARopp (λ x y : AR, (λ x0 y0 : AR, ARltS y0 x0 → False) y x ∧ (λ x0 y0 : AR, ARltS y0 x0 → False) x y). Proof. split. - intros x y J z t J0. apply AReq_nlt. apply AReq_nlt in J. apply AReq_nlt in J0. rewrite J, J0. reflexivity. - intros x y J z t J0. apply AReq_nlt. apply AReq_nlt in J. apply AReq_nlt in J0. rewrite J, J0. reflexivity. - intros x y J. apply AReq_nlt. apply AReq_nlt in J. rewrite J. reflexivity. Qed. Lemma AR_lt_0_1 : ARltT (inject_Q_AR 0) (inject_Q_AR 1). Proof. pose proof (inject_Q_AR_CR 0). pose proof (inject_Q_AR_CR 1). symmetry in H5. symmetry in H6. apply (ARltT_wd _ _ H5 _ _ H6). destruct (CRtoAR_preserves_ltT 0%CR 1%CR). exact (a (CRlt_Qlt 0 1 eq_refl)). Qed. Lemma AR_plus_lt : ∀ r r1 r2 : AR, ARltS r1 r2 → ARltS (ARplus r r1) (ARplus r r2). Proof. intros. destruct (ARtoCR_preserves_ltT (ARplus r r1) (ARplus r r2)) as [_ a]. apply a. clear a. pose proof (ARtoCR_preserves_plus r r1). pose proof (ARtoCR_preserves_plus r r2). symmetry in H6. symmetry in H7. apply (CRltT_wd H6 H7). apply CRplus_lt_l. apply (ARtoCR_preserves_ltT r1 r2). exact H5. Qed. Lemma AR_plus_lt_rev : ∀ r r1 r2 : AR, ARltS (ARplus r r1) (ARplus r r2) → ARltS r1 r2. Proof. intros. destruct (ARtoCR_preserves_ltT r1 r2) as [_ a]. apply a. clear a. pose proof (ARtoCR_preserves_plus r r1). pose proof (ARtoCR_preserves_plus r r2). destruct (ARtoCR_preserves_ltT (ARplus r r1) (ARplus r r2)) as [a _]. apply a in H5. clear a. apply (CRltT_wd H6 H7) in H5. pose proof (CRplus_lt_l ('r1) ('r2) ('r)) as [_ H8]. apply H8, H5. Qed. Definition ARinvS (x : AR) : ARltS x (inject_Q_AR 0) + ARltS (inject_Q_AR 0) x → AR := fun H => ARinvT x (ARapartT_wd _ _ _ _ (reflexivity _) (AR_zero) H). Lemma ARmult_inv_r : (∀ (r : AR) (rnz : (ARltS r (inject_Q_AR 0) + ARltS (inject_Q_AR 0) r)%type), (λ x y : AR, (λ x0 y0 : AR, ARltS y0 x0 → False) y x ∧ (λ x0 y0 : AR, ARltS y0 x0 → False) x y) (ARmult (ARinvS r rnz) r) (inject_Q_AR 1)). Proof. intros. rewrite <- AReq_nlt. rewrite (commutativity _ r). unfold ARinvS. pose proof (AR_inverseT r (ARapartT_wd r r (inject_Q_AR 0) (' zero0) (reflexivity r) AR_zero rnz)). rewrite H5. symmetry. apply AR_one. Qed. Lemma ARinv_0_lt_compat : ∀ (r : AR) (rnz : (ARltS r (inject_Q_AR 0) + ARltS (inject_Q_AR 0) r)%type), ARltS (inject_Q_AR 0) r → ARltS (inject_Q_AR 0) (ARinvS r rnz). Proof. intros r rnz H5. destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) (ARinvS r rnz)) as [_ a]. apply a. clear a. assert (0 = ARtoCR (inject_Q_AR 0))%CR as H7. { rewrite <- (CRAR_id 0%CR). unfold cast. rewrite (inject_Q_AR_CR 0). reflexivity. } pose proof (ARtoCR_preserves_apartT_0 r ) as [ap _]. pose proof (ARtoCR_preserves_invT r (ARapartT_wd r r (inject_Q_AR 0) (' zero0) (reflexivity r) AR_zero rnz) (ap (ARapartT_wd r r (inject_Q_AR 0) (' zero0) (reflexivity r) AR_zero rnz))) as H6. symmetry in H6. apply (CRltT_wd H7 H6). clear H6. apply CRinv_0_lt_compat. destruct (ARtoCR_preserves_ltT (inject_Q_AR 0) r) as [a _]. apply a in H5. clear a. symmetry in H7. apply (CRltT_wd H7 (reflexivity _)). exact H5. Qed. Definition AR_Q_dense (x y : AR) : ARltS x y → sigT (fun q : Q => prod (ARltS x (inject_Q_AR q)) (ARltS (inject_Q_AR q) y)). Proof. intro J. destruct (ARtoCR_preserves_ltT x y) as [a _]. apply a in J. clear a. destruct (CRlt_Qmid (cast AR CR x) (cast AR CR y) J) as [q [J0 J1]]. exists q. split. destruct (ARtoCR_preserves_ltT x (inject_Q_AR q)) as [_ a]. apply a; clear a. pose proof (CRAR_id ('q)%CR). symmetry in H5. rewrite <- (inject_Q_AR_CR q) in H5. apply (CRltT_wd (reflexivity _) H5), J0. destruct (ARtoCR_preserves_ltT (inject_Q_AR q) y) as [_ a]. apply a; clear a. pose proof (CRAR_id ('q)%CR). rewrite <- (inject_Q_AR_CR q) in H5. symmetry in H5. apply (CRltT_wd H5 (reflexivity _)), J1. Qed. Definition ARup (x : AR) : sigT (fun n : positive => ARltS x (inject_Q_AR (Z.pos n # 1))). Proof. destruct (CRup (cast AR CR x)) as [n J]. exists n. destruct (ARtoCR_preserves_ltT x (inject_Q_AR (Z.pos n # 1))) as [_ a]. apply a; clear a. pose proof (CRAR_id ('(Z.pos n#1))%CR). rewrite <- inject_Q_AR_CR in H5. symmetry in H5. apply (CRltT_wd (reflexivity _) H5), J. Qed. Lemma ARabs_spec : ∀ x y : AR, (ARltS y x → False) ∧ (ARltS y (ARopp x) → False) ↔ (ARltS y (ARabs x) → False). Proof. intros x y. split. - intros [H6 H7]. apply (ARle_not_lt (ARabs x) y). apply (ARle_not_lt x y) in H6. apply (ARle_not_lt (ARopp x) y) in H7. pose proof (ARabs_AbsSmall y x) as [_ H5]. apply H5. split. 2: exact H6. rewrite <- (rings.negate_involutive x). apply rings.flip_le_negate. exact H7. - intro H6. apply (ARle_not_lt (ARabs x) y) in H6. pose proof (ARabs_AbsSmall y x) as [H5 _]. split. + apply (ARle_not_lt x y). apply H5. exact H6. + apply (ARle_not_lt (ARopp x) y). rewrite <- (rings.negate_involutive y). apply rings.flip_le_negate. apply H5, H6. Qed. Definition ARcauchy_sequence (xn : nat -> AR) : Set := ∀ p : positive, {n : nat | ∀ i j : nat, (n <= i)%nat → (n <= j)%nat → ARltT (inject_Q_AR (1 # p)) (ARabs (ARplus (xn i) (ARopp (xn j)))) → False}. Lemma ARtoCR_preserves_cauchy : forall xn : nat → AR, ARcauchy_sequence xn -> CRcauchy_sequence (fun n => cast AR CR (xn n)). Proof. intros xn xncau p. specialize (xncau p) as [n J]. exists n. intros. apply (J i j H5 H6); clear J. destruct (CRtoAR_preserves_ltT (' (1 # p))%CR (CRabs (' ARplus (xn i) (ARopp (xn j))))) as [c _]. apply (ARltT_wd _ _ (reflexivity _) (' CRabs (' ARplus (xn i) (ARopp (xn j))))). - rewrite <- ARtoCR_preserves_abs. apply CRAR_id. - pose proof (inject_Q_AR_CR (1#p)). symmetry in H8. apply (ARltT_wd _ _ H8 _ _ (reflexivity _)). clear H8. apply c; clear c. apply (CRlt_le_trans _ _ _ H7); clear H7. setoid_replace ((' xn i)%mc - (' xn j)%mc)%CR with (cast AR CR (ARplus (xn i) (ARopp (xn j)))). apply CRle_refl. pose proof (ARtoCR_preserves_plus (xn i) (ARopp (xn j))). rewrite H7. apply ucFun2_wd. reflexivity. pose proof (ARtoCR_preserves_opp (xn j)). rewrite H8. apply Cmap_wd. reflexivity. reflexivity. Qed. Lemma ARcauchy_complete : ∀ xn : nat → AR, ARcauchy_sequence xn → sigT (fun l : AR => ∀ p : positive, {n : nat | ∀ i : nat, (n <= i)%nat → ARltT (inject_Q_AR (1 # p)) (ARabs (ARplus (xn i) (ARopp l))) → False}). Proof. intros. destruct (CRcauchy_complete _ (ARtoCR_preserves_cauchy xn H5)) as [l J]. exists (cast CR AR l). intro p. specialize (J p) as [n J]. exists n. intros i H6 H7. specialize (J i H6). apply J. unfold ARabs in H7. destruct (CRtoAR_preserves_ltT (' (1 # p))%CR (CRabs (' ARplus (xn i) (ARopp (' l))))) as [_ c]. apply (ARltT_wd _ _ (reflexivity _) _ (' CRabs (' ARplus (xn i) (ARopp ('l))))) in H7. - pose proof (inject_Q_AR_CR (1#p)). apply (ARltT_wd _ _ H8 _ _ (reflexivity _)) in H7. clear H8. apply c in H7; clear c. apply (CRlt_le_trans _ _ _ H7). setoid_replace ((' xn i)%mc - l)%CR with (cast AR CR (ARplus (xn i) (ARopp (' l)))). apply CRle_refl. pose proof (ARtoCR_preserves_plus (xn i) (ARopp ('l))). rewrite H8. apply ucFun2_wd. reflexivity. pose proof (ARtoCR_preserves_opp ('l)). rewrite H9. apply Cmap_wd. reflexivity. symmetry. apply CRAR_id. - rewrite <- ARtoCR_preserves_abs. symmetry. apply CRAR_id. Qed. Definition FasterRealsConstructive : ConstructiveReals := Build_ConstructiveReals (RegularFunction (Eball (cast AQ Q))) ARltS ARltS_linear ARlt (fun x y H => fst (AR_lt_ltT x y) H) (fun x y H => snd (AR_lt_ltT x y) H) ARlt_or_epsilon inject_Q_AR inject_Q_AR_lt inject_Q_AR_lt_rev ARplus ARopp ARmult inject_Q_AR_plus_nlt inject_Q_AR_mult_nlt AR_ring AR_ring_ext AR_lt_0_1 AR_plus_lt AR_plus_lt_rev AR_mult_0_lt_compat ARinvS ARmult_inv_r ARinv_0_lt_compat AR_Q_dense ARup ARabs ARabs_spec ARcauchy_complete. End ConstructiveFaster. corn-8.20.0/reals/stdlib/ConstructivePartialFunctions.v000066400000000000000000001001761473720167500232370ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* Partial functions between two sets X and Y. They have domains of definition which are subsets of X. *) From Coq Require Import List. From Coq Require Import ZArith. From Coq Require Import QArith. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructiveLimits. From Coq Require Import ConstructiveRcomplete. Local Open Scope ConstructiveReals. (* The type of real-valued partial functions on X. Partial means the functions are defined only on subsets D of X, called their domains. In classical logic, partial functions are useless for the theory of integration, because a partial function X -> R can be extended to all X by zeroes, with the same integral. However, in constructive mathematics a function R -> R must be undefined at its points of discontinuity. Besides, we will prove that the domain of an integrable function X -> R has full measure in X, ie it is the complement of a null set of X. *) Record PartialFunctionXY {X Y : Set} {Yeq : Y -> Y -> Prop} : Type := { Domain : X -> Set; partialApply : forall x : X, Domain x -> Y; DomainProp : forall (x : X) (p q : Domain x), Yeq (partialApply x p) (partialApply x q); }. Definition PartialFunction {R : ConstructiveReals} (X : Set) : Type := @PartialFunctionXY X (CRcarrier R) (CReq R). Definition TotalizeFunc {R : ConstructiveReals} (X : Set) (f : PartialFunction X) (domainTotal : forall x:X, Domain f x) : X -> CRcarrier R := fun x => partialApply f x (domainTotal x). Definition PartializeFunc {R : ConstructiveReals} (X : Set) (f : X -> CRcarrier R) : PartialFunction X := Build_PartialFunctionXY X (CRcarrier R) (CReq R) (fun x:X => True) (fun x _ => f x) (fun x _ _ => CReq_refl (f x)). Record CommonPointFunSeq {R : ConstructiveReals} (X : Set) (f : @PartialFunction R X) (fn : nat -> @PartialFunction R X) : Set := { cpx : X; cpxF : Domain f cpx; cpxFn : forall n:nat, Domain (fn n) cpx; }. (* We have a major use of the sort Set for integration, that could not be done with Ensemble X : the domain of the pointwise limit of a sequence of functions. The limit is stored at each point in sort Set, so that we can form the (partial) limit function. *) Definition XpointwiseLimit {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) : @PartialFunction R X. Proof. apply (Build_PartialFunctionXY X (CRcarrier R) (CReq R) (* x is in all domains and the sequence converges *) (fun x:X => { xnlim : (forall n:nat, Domain (fn n) x) & CR_cauchy _ (fun n:nat => partialApply (fn n) x (xnlim n)) }) (fun x p => let (xnlim, cau) := p in let (c,d) := CR_complete R _ cau in c)). intros. destruct p,q. destruct (CR_complete R (fun n : nat => partialApply (fn n) x (x0 n)) c). destruct (CR_complete R (fun n : nat => partialApply (fn n) x (x1 n)) c0). apply (CR_cv_unique (fun n : nat => partialApply (fn n) x (x0 n))). exact c1. apply (CR_cv_eq _ (fun n : nat => partialApply (fn n) x (x1 n))). 2: exact c2. intro n. apply DomainProp. Defined. Lemma applyPointwiseLimit : forall {R : ConstructiveReals} {X : Set} (fn : nat -> PartialFunction X) (x : X) (xD : Domain (XpointwiseLimit fn) x) (a : CRcarrier R), prod (partialApply (XpointwiseLimit fn) x xD == a -> CR_cv _ (fun n => partialApply (fn n) x (let (xn, _) := xD in xn n)) a) (CR_cv _ (fun n => partialApply (fn n) x (let (xn, _) := xD in xn n)) a -> partialApply (XpointwiseLimit fn) x xD == a). Proof. intros. simpl. destruct xD. destruct (CR_complete R (fun n : nat => partialApply (fn n) x (x0 n)) c). split. - intros. exact (CR_cv_proper _ x1 a c0 H). - intros. apply (CR_cv_unique (fun n : nat => partialApply (fn n) x (x0 n))). exact c0. exact H. Qed. Definition XinfiniteSumAbs {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) : @PartialFunction R X. Proof. apply (Build_PartialFunctionXY X (CRcarrier R) (CReq R) (* x is in all domains and the series converges *) (fun x:X => { xnlim : (forall n:nat, Domain (fn n) x) & CR_cauchy _ (CRsum (fun n:nat => CRabs _ (partialApply (fn n) x (xnlim n)))) }) (fun x p => let (xnlim, cau) := p in let (c,d) := series_cv_abs _ cau in c)). intros. destruct p,q. destruct (series_cv_abs (fun n : nat => partialApply (fn n) x (x0 n)) c). destruct (series_cv_abs (fun n : nat => partialApply (fn n) x (x1 n)) c0). apply (CR_cv_unique (CRsum (fun n : nat => partialApply (fn n) x (x0 n)))). exact s. apply (series_cv_eq (fun n : nat => partialApply (fn n) x (x1 n))). 2: exact s0. intro n. apply DomainProp. Defined. Definition domainInfiniteSumAbsInc {R : ConstructiveReals} {X : Set} (fn : nat -> PartialFunction X) (x : X) (xnD : forall n:nat, Domain (fn n) x) (lim : CRcarrier R) : series_cv (fun n => CRabs _ (partialApply (fn n) x (xnD n))) lim -> Domain (XinfiniteSumAbs fn) x. Proof. intros cvlim. exists xnD. apply (Rcv_cauchy_mod _ lim cvlim). Qed. Definition domainInfiniteSumAbsIncReverse {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) (x : X) : Domain (XinfiniteSumAbs fn) x -> forall n:nat, Domain (fn n) x := fun xD n => let (xn, _) := xD in xn n. Lemma applyInfiniteSumAbs : forall {R : ConstructiveReals} (X : Set) (fn : nat -> PartialFunction X) (x : X) (xD : Domain (XinfiniteSumAbs fn) x) (a : CRcarrier R), prod (partialApply (XinfiniteSumAbs fn) x xD == a -> series_cv (fun n => partialApply (fn n) x (domainInfiniteSumAbsIncReverse fn x xD n)) a) (series_cv (fun n => partialApply (fn n) x (domainInfiniteSumAbsIncReverse fn x xD n)) a -> partialApply (XinfiniteSumAbs fn) x xD == a). Proof. intros. unfold domainInfiniteSumAbsIncReverse. destruct xD. simpl. destruct (series_cv_abs (fun n : nat => partialApply (fn n) x (x0 n))). split. - intros. exact (CR_cv_proper _ _ _ s H). - intros. apply (series_cv_unique (fun n : nat => partialApply (fn n) x (x0 n))); assumption. Qed. Definition DomainInclusion {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : Set (* Prop-like *) := forall x:X, Domain f x -> Domain g x. Definition PartialRestriction {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : Type := prod (DomainInclusion f g) (forall (x : X) (xD : Domain f x) (xG : Domain g x), partialApply f x xD == partialApply g x xG). Definition PartialRestriction_refl : forall {R : ConstructiveReals} (X : Set) (f : @PartialFunction R X), PartialRestriction f f. Proof. split. - exact (fun x a => a). - intros. apply DomainProp. Qed. Definition PartialRestriction_trans : forall {R : ConstructiveReals} (X : Set) (f g h : @PartialFunction R X), PartialRestriction f g -> PartialRestriction g h -> PartialRestriction f h. Proof. intros R X f g h H H0. split. - intros x H1. apply H0, H, H1. - intros. destruct H, H0. rewrite <- (c0 x (d x xD)), <- (c x xD). reflexivity. Qed. Definition PartialFunExtEq {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : Set := (DomainInclusion f g) * (DomainInclusion g f) * (forall (x : X) (xD : Domain f x) (xG : Domain g x), partialApply f x xD == partialApply g x xG). Definition Xconst {R : ConstructiveReals} (X : Set) (c : CRcarrier R) : PartialFunction X := Build_PartialFunctionXY X (CRcarrier R) (CReq R) (fun x => True) (fun x _ => c) (fun _ _ _ => CReq_refl c). Definition XopXY (X Y : Set) (Yeq : Y -> Y -> Prop) (f : @PartialFunctionXY X Y Yeq) (op : Y -> Y) : (forall x y : Y, Yeq x y -> Yeq (op x) (op y)) -> @PartialFunctionXY X Y Yeq := fun H => Build_PartialFunctionXY X Y Yeq (Domain f) (fun x p => op (partialApply f x p)) (fun x p q => H _ _ (DomainProp f x p q)). Definition Xop {R : ConstructiveReals} (X : Set) (f : PartialFunction X) (op : CRcarrier R -> CRcarrier R) : (forall x y : CRcarrier R, x == y -> op x == op y) -> PartialFunction X := fun H => Build_PartialFunctionXY X (CRcarrier R) (CReq R) (Domain f) (fun x p => op (partialApply f x p)) (fun x p q => H _ _ (DomainProp f x p q)). Definition Xabs {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) : @PartialFunction R X := Xop X f (CRabs R) (CRabs_morph_prop R). Lemma applyXabs : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (x : X) (xD : Domain f x), partialApply (Xabs f) x xD = CRabs R (partialApply f x xD). Proof. reflexivity. Qed. Definition Xscale {R : ConstructiveReals} {X : Set} (a : CRcarrier R) (f : PartialFunction X) : PartialFunction X := Xop X f (fun x => a * x) (CRmult_morph R a a (CReq_refl a)). Lemma applyXscale : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (a : CRcarrier R) (x : X) (xD : Domain f x), partialApply (Xscale a f) x xD = a * (partialApply f x xD). Proof. reflexivity. Qed. (* To intersect the domains of a sequence of functions, we build the zero function on that intersection. *) Definition Domain_intersect_countable {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) : PartialFunction X := XinfiniteSumAbs(fun n => Xscale 0 (fn n)). Definition XbinOpXY (X Y : Set) (Yeq : Y -> Y -> Prop) (f g : @PartialFunctionXY X Y Yeq) (op : Y -> Y -> Y) : (forall x y z t : Y, Yeq x y -> Yeq z t -> Yeq (op x z) (op y t)) -> @PartialFunctionXY X Y Yeq. Proof. intros. apply (Build_PartialFunctionXY X Y Yeq (fun x => prod (Domain f x) (Domain g x)) (fun x xD => let (a,b) := xD in op (partialApply f x a) (partialApply g x b))). intros. destruct p,q. apply H. - apply DomainProp. - apply DomainProp. Defined. Definition XbinOp {R : ConstructiveReals} {X : Set} (f g : PartialFunction X) (op : CRcarrier R -> CRcarrier R -> CRcarrier R) (opEq : forall x y z t : CRcarrier R, x == y -> z == t -> op x z == op y t) : PartialFunction X := XbinOpXY X (CRcarrier R) (CReq R) f g op opEq. (* This definition of the sum of partial functions will have a major consequence on measure theory : all integrable functions are defined almost everywhere. Otherwise the intersection of domains could reduce the integral of the sum of 2 functions. For example, if an integrable function has R+ for domain, then the measure of R- is zero. *) Definition Xplus {R : ConstructiveReals} {X : Set} (f g : PartialFunction X) : PartialFunction X := XbinOp f g (CRplus R) (fun x y z t Hxy => CRplus_morph R x y Hxy z t). Lemma applyXplus : forall {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) (x : X) (xdf : Domain f x) (xdg : Domain g x), partialApply (Xplus f g) x (pair xdf xdg) == partialApply f x xdf + partialApply g x xdg. Proof. reflexivity. Qed. Definition Xminus {R : ConstructiveReals} {X : Set} (f g : PartialFunction X) : PartialFunction X := Xplus f (Xscale (CRopp R 1) g). Lemma applyXminus : forall {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) (x : X) (xdf : Domain f x) (xdg : Domain g x), partialApply (Xminus f g) x (pair xdf xdg) == partialApply f x xdf - partialApply g x xdg. Proof. intros. apply CRplus_morph. reflexivity. rewrite applyXscale. rewrite <- CRopp_mult_distr_l. rewrite CRmult_1_l. reflexivity. Qed. Definition Xmult {R : ConstructiveReals} {X : Set} (f g : PartialFunction X) : PartialFunction X := XbinOp f g (CRmult R) (fun x y z t Hxy => CRmult_morph R x y Hxy z t). Lemma applyXmult : forall {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) (x : X) (xdf : Domain f x) (xdg : Domain g x), partialApply (Xmult f g) x (pair xdf xdg) == partialApply f x xdf * partialApply g x xdg. Proof. reflexivity. Qed. Definition XminConst {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) (a : CRcarrier R) : PartialFunction X := Xop X f (fun x => CRmin x a) (fun x y Hxy => CRmin_morph _ x y Hxy a a (CReq_refl a)). Lemma applyXminConst : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (a : CRcarrier R) (x : X) (xD : Domain f x), partialApply (XminConst f a) x xD = CRmin (partialApply f x xD) a. Proof. reflexivity. Qed. Definition XmaxConst {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) (a : CRcarrier R) : PartialFunction X := Xop X f (fun x => CRmax x a) (fun x y Hxy => CRmax_morph _ x y Hxy a a (CReq_refl a)). Lemma applyXmaxConst : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (a : CRcarrier R) (x : X) (xD : Domain f x), partialApply (XmaxConst f a) x xD = CRmax (partialApply f x xD) a. Proof. reflexivity. Qed. (* This definition is biased in favor of integrable functions, ie functions defined almost everywhere. Literally it means that f <= g on the intersection of their domains. *) Definition partialFuncLe {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : Prop := forall (x : X) (xdf : Domain f x) (xdg : Domain g x), partialApply f x xdf <= partialApply g x xdg. Definition nonNegFunc {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) : Prop := forall (x : X) (xdf : Domain f x), 0 <= partialApply f x xdf. Lemma zeroNonNeg : forall {R : ConstructiveReals}, nonNegFunc (@Xconst R (CRcarrier R) 0). Proof. intros R x xdf. apply CRle_refl. Qed. Lemma nonNegFuncPlus {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : nonNegFunc f -> nonNegFunc g -> nonNegFunc (Xplus f g). Proof. intros H H0 x xdf. destruct xdf; simpl. apply (CRle_trans _ (partialApply f x d + 0)). rewrite CRplus_0_r. apply H. apply CRplus_le_compat_l. apply H0. Qed. Fixpoint Xsum {R : ConstructiveReals} {X : Set} (fn : nat -> PartialFunction X) (n : nat) : @PartialFunction R X := match n with | O => fn O | S i => (Xplus (Xsum fn i) (fn (S i))) end. Definition XsumList {R : ConstructiveReals} {X : Set} : list (@PartialFunction R X) -> PartialFunction X := fold_right Xplus (* empty list means zero function defined everywhere *) (Xconst _ 0). Lemma nonNegSumFunc {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) : (forall n:nat, nonNegFunc (fn n)) -> (forall n:nat, nonNegFunc (Xsum fn n)). Proof. intros. induction n. - intros x. simpl. apply H. - intros x. simpl. apply nonNegFuncPlus. assumption. apply H. Qed. Lemma Nat_le_succ_r_dec : forall n m : nat, le n (S m) -> { le n m } + { n = S m }. Proof. intros. destruct (Nat.eq_dec n (S m)). right. assumption. left. destruct (Nat.le_succ_r n m) as [H0 _]. destruct H0. assumption. assumption. contradiction. Qed. Definition domainXsumInc {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) (x : X) (xn : forall n:nat, Domain (fn n) x) : forall n:nat, Domain (Xsum fn n) x. Proof. induction n. - exact (xn O). - simpl. split. apply IHn. apply xn. Qed. Definition domainXsumIncReverse : forall {R : ConstructiveReals} {X : Set} (fn : nat -> @PartialFunction R X) (k n : nat) (x : X) (xD : Domain (Xsum fn n) x), le k n -> Domain (fn k) x. Proof. induction n. - intros. replace k with O. exact xD. inversion H. reflexivity. - intros. apply Nat_le_succ_r_dec in H. simpl in xD. destruct H. + specialize (IHn x (fst xD) l). exact IHn. + subst k. exact (snd xD). Qed. (* Simplification of the previous lemma to avoid proof irrelevance. *) Definition domainXsumIncLast : forall {X : Set} {R : ConstructiveReals} (fn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (Xsum fn n) x), Domain (fn n) x. Proof. intros. destruct n. - assumption. - simpl in xD. exact (snd xD). Defined. Lemma applyXsum : forall {X : Set} {R : ConstructiveReals} (fn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (Xsum fn n) x) (xn : forall n:nat, Domain (fn n) x), partialApply (Xsum fn n) x xD == CRsum (fun k:nat => partialApply (fn k) x (xn k)) n. Proof. induction n. - intros x xD xn. simpl. apply DomainProp. - intros x xD xn. simpl. rewrite <- (IHn x (fst xD)). clear IHn. destruct xD. apply CRplus_morph. reflexivity. apply DomainProp. Qed. Lemma Xsum_assoc : forall {X : Set} {R : ConstructiveReals} (u : nat -> @PartialFunction R X) (n p : nat) (x : X) (xd : Domain (Xsum u (S n + p)) x) (y : Domain (Xsum u n) x) (z : Domain (Xsum (fun k => u (S n + k)%nat) p) x), partialApply (Xsum u (S n + p)) x xd == partialApply (Xsum u n) x y + partialApply (Xsum (fun k => u (S n + k)%nat) p) x z. Proof. induction p. - intros. simpl in z. simpl. destruct xd. remember (n + 0)%nat as sn. rewrite Nat.add_0_r in Heqsn. subst sn. apply CRplus_morph. apply DomainProp. apply DomainProp. - intros. simpl. destruct xd. simpl in z. remember (n + S p)%nat as sn. rewrite Nat.add_succ_r in Heqsn. subst sn. rewrite (IHp x _ y (fst z)). clear IHp. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. destruct z. apply CRplus_morph. reflexivity. apply DomainProp. Qed. Lemma Xsum_assocMinus : forall {X : Set} {R : ConstructiveReals} (u : nat -> @PartialFunction R X) (n p : nat) (x : X) (px : Domain (Xminus (Xsum u (S n + p)) (Xsum u n)) x) (pxD : Domain (Xsum (fun k => u (S n + k)%nat) p) x), partialApply (Xminus (Xsum u (S n + p)) (Xsum u n)) x px == partialApply (Xsum (fun k => u (S n + k)%nat) p) x pxD. Proof. induction p. - intros. simpl in px, pxD. transitivity (partialApply (u (S n + 0)%nat) x pxD). 2: reflexivity. simpl (S n + 0)%nat. remember (n + 0)%nat. rewrite Nat.add_0_r in Heqn0. subst n0. destruct px. rewrite applyXminus. rewrite <- (CRplus_0_r (partialApply (u (S n)) x pxD)). unfold CRminus. destruct p. simpl. rewrite (CRplus_comm (partialApply (Xsum u n) x d0)). rewrite CRplus_assoc. apply CRplus_morph. apply DomainProp. rewrite (DomainProp _ _ d0 d). rewrite CRplus_opp_r. reflexivity. - intros. destruct px. rewrite (applyXminus (Xsum u (S n + S p)) (Xsum u n) x d d0). simpl. simpl in d. destruct d, pxD. simpl in d3. remember (n + S p)%nat. rewrite Nat.add_succ_r in Heqn0. subst n0. specialize (IHp x (pair d d0) d2). rewrite <- IHp. rewrite (applyXminus (Xsum u (S n + p)) (Xsum u n)). unfold CRminus. rewrite (DomainProp _ x d1 d3). do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm. reflexivity. Qed. Definition XposPart {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) : PartialFunction X := Xscale (CR_of_Q _ (1#2)) (Xplus f (Xabs f)). Lemma applyXposPartNonNeg : forall {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X), nonNegFunc (XposPart f). Proof. intros. intros x xdf. unfold XposPart. rewrite applyXscale. rewrite <- (CRmult_0_r (CR_of_Q _ (1#2))). apply CRmult_le_compat_l_half. apply CR_of_Q_pos. reflexivity. destruct f,xdf; simpl. rewrite <- (CRplus_opp_r (partialApply0 x d)). apply CRplus_le_compat_l. setoid_replace (partialApply0 x d0) with (partialApply0 x d). rewrite <- CRabs_opp. apply CRle_abs. apply DomainProp0. Qed. Lemma applyXposPart : forall {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X) (x : X) (xD : Domain f x), partialApply (XposPart f) x (pair xD xD) == CRmax 0 (partialApply f x xD). Proof. intros. rewrite CRposPartAbsMax. unfold XposPart. rewrite applyXscale. rewrite CRmult_comm. apply CRmult_morph. 2: reflexivity. destruct f; simpl. reflexivity. Qed. (* This definition is L-stable, whereas XminConst f 0 is not. *) Definition XnegPart {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X) : PartialFunction X := Xscale (CR_of_Q R (1#2)) (Xminus (Xabs f) f). Lemma applyXnegPartNonNeg : forall {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X), nonNegFunc (XnegPart f). Proof. intros. intros y ydf. unfold XnegPart. rewrite applyXscale. rewrite <- (CRmult_0_r (CR_of_Q _ (1#2))). apply CRmult_le_compat_l_half. apply CR_of_Q_pos. reflexivity. destruct ydf; simpl. rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- (CRplus_opp_r (partialApply f y d0)). apply CRplus_le_compat_r. rewrite (DomainProp f y d0 d). apply CRle_abs. Qed. Lemma XnegPartAbsMax : forall {R : ConstructiveReals} (x : CRcarrier R), CRmax 0 (-x) == (CRabs _ x - x) * (CR_of_Q _ (1#2)). Proof. intros. rewrite CRposPartAbsMax. rewrite CRabs_opp. apply CRmult_morph. rewrite CRplus_comm. reflexivity. reflexivity. Qed. Lemma applyXnegPart : forall {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) (x : X) (xD : Domain f x), partialApply (XnegPart f) x (pair xD xD) == CRmax 0 (- partialApply f x xD). Proof. intros. rewrite XnegPartAbsMax. unfold XnegPart. rewrite applyXscale, CRmult_comm. apply CRmult_morph. 2: reflexivity. rewrite (applyXminus (Xabs f) f). apply CRplus_morph. rewrite applyXabs. apply CRabs_morph. apply DomainProp. reflexivity. Qed. Lemma applyXnegPartMin : forall {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X) (x : X) (xD : Domain f x), partialApply (XnegPart f) x (pair xD xD) == - CRmin 0 (partialApply f x xD). Proof. intros. rewrite CRnegPartAbsMin. unfold XnegPart. rewrite applyXscale, CRmult_comm. rewrite CRopp_mult_distr_l. apply CRmult_morph. 2: reflexivity. rewrite (applyXminus (Xabs f) f). unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, CRplus_comm. apply CRplus_morph. reflexivity. rewrite applyXabs. apply CRabs_morph. apply DomainProp. Qed. Lemma XnegPartNonNeg : forall {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X), nonNegFunc (XnegPart f). Proof. intros. intros x xdf. destruct xdf. rewrite (DomainProp (XnegPart f) x _ (pair d d)). rewrite (applyXnegPart f x d). apply CRmax_l. Qed. Lemma SplitPosNegParts : forall {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X) (x : X) (xdf : Domain f x) (xdp : Domain (XposPart f) x) (xdn : Domain (XnegPart f) x), partialApply (XposPart f) x xdp - partialApply (XnegPart f) x xdn == partialApply f x xdf. Proof. intros. unfold XposPart, XnegPart, CRminus. do 2 rewrite applyXscale. destruct xdp. rewrite (applyXplus f (Xabs f)). destruct xdn. rewrite (applyXminus (Xabs f) f). rewrite CRplus_comm. unfold CRminus. rewrite (DomainProp f x _ xdf), (DomainProp (Xabs f) x _ xdf). rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. rewrite (DomainProp f x d xdf), (DomainProp (Xabs f) x d0 xdf). setoid_replace (- (partialApply (Xabs f) x xdf + - partialApply f x xdf) + (partialApply f x xdf + partialApply (Xabs f) x xdf)) with (partialApply f x xdf + partialApply f x xdf). rewrite <- (CRmult_1_l (partialApply f x xdf)), <- CRmult_plus_distr_r. rewrite <- CRmult_assoc, CRmult_1_l, <- CR_of_Q_plus. rewrite <- CR_of_Q_mult. setoid_replace ((1 # 2) * (1+1))%Q with 1%Q. apply CRmult_1_l. reflexivity. rewrite CRplus_comm, CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRopp_plus_distr. rewrite CRopp_involutive. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. reflexivity. Qed. Definition Xmin {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : PartialFunction X := Xminus g (XnegPart (Xminus f g)). Lemma applyXmin : forall {X : Set} {R : ConstructiveReals} (f g : @PartialFunction R X) (x : X) (xdf : Domain f x) (xdg : Domain g x) (xdp : Domain (Xmin f g) x), partialApply (Xmin f g) x xdp == CRmin (partialApply f x xdf) (partialApply g x xdg). Proof. intros. unfold Xmin. destruct xdp. rewrite (applyXminus g (XnegPart (Xminus f g))). assert (Domain (Xminus f g) x). { destruct f,g; split. exact xdf. exact xdg. } simpl in d0. unfold CRminus. rewrite (DomainProp (XnegPart (Xminus f g)) x _ (fst d0, fst d0)), applyXnegPartMin. destruct d0,p. unfold fst. rewrite (applyXminus f g). destruct f, g; simpl. rewrite CRopp_involutive. unfold CRminus. rewrite (DomainProp1 x d1 d), (DomainProp1 x xdg d), (DomainProp0 x _ xdf). rewrite CRmin_plus, CRplus_0_r, (CRplus_comm (partialApply0 x xdf)). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRmin_sym. Qed. Definition Xmax {R : ConstructiveReals} {X : Set} (f g : @PartialFunction R X) : PartialFunction X := (Xplus g (XposPart (Xminus f g))). Lemma applyXmax : forall {X : Set} {R : ConstructiveReals} (f g : @PartialFunction R X) (x : X) (xdf : Domain f x) (xdg : Domain g x) (xdp : Domain (Xmax f g) x), partialApply (Xmax f g) x xdp == CRmax (partialApply f x xdf) (partialApply g x xdg). Proof. intros. unfold Xmax. destruct xdp. rewrite applyXplus. assert (Domain (Xminus f g) x). { destruct f,g; split. exact xdf. exact xdg. } rewrite (DomainProp (XposPart (Xminus f g)) x _ (fst d0, fst d0)), applyXposPart. destruct d0, d0. unfold fst. rewrite (applyXminus f g). destruct f, g; simpl. rewrite (DomainProp1 x d2 d), (DomainProp1 x xdg d), (DomainProp0 x d0 xdf). unfold CRminus. rewrite CRmax_plus, CRplus_0_r, (CRplus_comm (partialApply0 x xdf)). rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. apply CRmax_sym. Qed. Lemma XminMultPosDistrib : forall {X : Set} {R : ConstructiveReals} (f : PartialFunction X) (a b : CRcarrier R), 0 <= a -> PartialFunExtEq (Xscale a (XminConst f b)) (XminConst (Xscale a f) (a*b)). Proof. intros. destruct f; simpl; split; unfold DomainInclusion, Domain. - split. + intros x xdf. exact xdf. + intros x xdf. exact xdf. - intros x xdf xg. simpl. rewrite CRmin_mult. rewrite (DomainProp0 x xdf xg). reflexivity. exact H. Qed. Lemma XscaleAssoc : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (a b : CRcarrier R), PartialFunExtEq (Xscale a (Xscale b f)) (Xscale (a*b) f). Proof. intros. destruct f; simpl; split. - split. + intros x. simpl. exact (fun x => x). + intros x. simpl. exact (fun x => x). - intros. simpl. rewrite (DomainProp0 x xD xG). rewrite CRmult_assoc. reflexivity. Qed. Lemma XscaleOne : forall {X : Set} {R : ConstructiveReals} (f : @PartialFunction R X), PartialFunExtEq (Xscale 1 f) f. Proof. intros. split. - split. + intros x H. destruct f; exact H. + intros x H. destruct f; exact H. - intros. rewrite applyXscale, CRmult_1_l. apply DomainProp. Qed. Lemma XminMultPosDistribOne : forall {R : ConstructiveReals} {X : Set} (f : PartialFunction X) (a : CRcarrier R) (aPos : 0 < a), PartialFunExtEq (Xscale a (XminConst (Xscale (CRinv _ a (inr aPos)) f) 1)) (XminConst f a). Proof. intros. split. split. - intros x xD. destruct f; exact xD. - intros x xD. destruct f; exact xD. - intros. rewrite applyXscale. simpl in xD, xG. rewrite applyXminConst. rewrite applyXminConst. rewrite applyXscale. rewrite (DomainProp _ _ xD xG). rewrite <- CRmin_mult. rewrite <- CRmult_assoc, CRinv_r, CRmult_1_l. rewrite CRmult_1_r. reflexivity. apply CRlt_asym, aPos. Qed. Lemma XmultiTriangleIneg : forall {X : Set} {R : ConstructiveReals} (fn : nat -> @PartialFunction R X) (n : nat) (x : X) (xD : Domain (Xabs (Xsum fn n)) x) (y : Domain (Xsum (fun a : nat => Xabs (fn a)) n) x), partialApply (Xabs (Xsum fn n)) x xD <= partialApply (Xsum (fun a : nat => Xabs (fn a)) n) x y. Proof. induction n. - intros. simpl. simpl in xD. rewrite (DomainProp _ _ xD y). apply CRle_refl. - intros. simpl. simpl in x,y,xD. destruct (Xsum fn n), (fn (S n)), (Xsum (fun a : nat => Xabs (fn a)) n), xD, y; simpl; simpl in IHn. apply (CRle_trans _ (CRabs _ (partialApply0 x d) + CRabs _ (partialApply1 x d0))). apply CRabs_triang. apply CRplus_le_compat. apply IHn. rewrite (DomainProp1 x d0 d2). apply CRle_refl. Qed. (* For partial functions on a product domain, we can project at any point in any coordinate, possibly by the empty function. *) Definition Xproj1 {R : ConstructiveReals} {X Y : Set} (f : PartialFunction (prod X Y)) (x : X) : PartialFunction Y := Build_PartialFunctionXY Y (CRcarrier R) (CReq R) (fun y:Y => Domain f (x,y)) (fun y yD => partialApply f (x,y) yD) (fun y p q => DomainProp f (x,y) p q). Definition Xproj2 {R : ConstructiveReals} {X Y : Set} (f : PartialFunction (prod X Y)) (y : Y) : PartialFunction X := Build_PartialFunctionXY X (CRcarrier R) (CReq R) (fun x:X => Domain f (x,y)) (fun x xD => partialApply f (x,y) xD) (fun x p q => DomainProp f (x,y) p q). Definition Xdiv {R : ConstructiveReals} {X : Set} (f : @PartialFunction R X) : @PartialFunction R X. Proof. apply (Build_PartialFunctionXY X (CRcarrier R) (CReq R) (fun x:X => {xD : Domain f x & partialApply f x xD ≶ 0}) (fun x y => let (xD,xnz) := y in CRinv R (partialApply f x xD) xnz)). intros. destruct p,q. apply CRinv_morph, DomainProp. Defined. corn-8.20.0/reals/stdlib/ConstructiveUniformCont.v000066400000000000000000001766341473720167500222310ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (* The uniformly continuous functions R -> R. *) From Coq Require Import List Permutation Orders Sorted Mergesort. From Coq Require Import ZArith QArith Qpower. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. From Coq Require Import ConstructiveMinMax. From Coq Require Import ConstructiveSum. From Coq Require Import ConstructivePower. From Coq Require Import ConstructiveLimits. Require Import ConstructiveDiagonal. Local Open Scope ConstructiveReals. Definition UniformCont {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R) : Set := prod (forall (x:CRcarrier R) (xPos : 0 < x), 0 < cont_mod x xPos) (* otherwise any function is trivially continuous *) (forall (eps x y : CRcarrier R) (epsPos : 0 < eps), CRabs _ (x - y) < cont_mod eps epsPos -> CRabs _ (f x - f y) < eps). Definition Lipschitz {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (k : CRcarrier R) : Set := forall (x y : CRcarrier R), CRabs _ (f x - f y) <= k * CRabs _ (x - y). Lemma UniformContProper : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f cont_mod -> (forall x y : CRcarrier R, x == y -> f x == f y). Proof. intros. destruct H. split. - intro abs. assert (0 < f y - f x) as epsPos. { rewrite <- (CRplus_opp_r (f x)). apply CRplus_lt_compat_r. exact abs. } specialize (c0 (f y - f x) x y epsPos). apply (CRle_abs (f y - f x)). rewrite CRabs_minus_sym. apply c0. apply (CRle_lt_trans _ (CRabs _ 0)). rewrite H0. unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl. rewrite CRabs_right. apply c. apply CRle_refl. - intro abs. assert (0 < f x - f y) as epsPos. { rewrite <- (CRplus_opp_r (f y)). apply CRplus_lt_compat_r. exact abs. } specialize (c0 (f x - f y) x y epsPos). apply (CRle_abs (f x - f y)). apply c0. apply (CRle_lt_trans _ (CRabs _ 0)). rewrite H0. unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl. rewrite CRabs_right. apply c. apply CRle_refl. Qed. Lemma LipschitzUC : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (k : CRcarrier R) (kPos : 0 < k), Lipschitz f k -> UniformCont f (fun eps epsPos => eps * CRinv R k (inr kPos)). Proof. split. - intros eps epsPos. apply (CRle_lt_trans _ (eps * 0)). rewrite CRmult_0_r. apply CRle_refl. apply CRmult_lt_compat_l. exact epsPos. apply CRinv_0_lt_compat, kPos. - intros. apply (CRle_lt_trans _ _ _ (H x y)). apply (CRmult_lt_compat_r k) in H0. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in H0. rewrite CRmult_comm. exact H0. exact kPos. Qed. (* Compact support and uniformly continuous. On R we simplify this by segment support and uniformly continuous. *) Definition CSUC {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R) : Set := prod (UniformCont f cont_mod) (forall x : CRcarrier R, (sum (x < a) (b < x)) -> f x == 0). Lemma CSUC_connect_support : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (cont_mod : forall x:CRcarrier R, 0 < x -> CRcarrier R), CSUC f a b cont_mod -> (forall x : CRcarrier R, (sum (x <= a) (b <= x)) -> f x == 0). Proof. intros. destruct H, u. split. - intro abs. destruct H0. + apply CRopp_gt_lt_contravar in abs. rewrite CRopp_0 in abs. specialize (c1 (-f x) (x - (cont_mod (-f x) abs) * CR_of_Q R (1#2)) x abs). apply (CRle_abs (-f x)). apply (CRle_lt_trans _ (CRabs _ (f (x - cont_mod (- f x) abs * CR_of_Q R (1 # 2)) - f x))). rewrite (c (x - cont_mod (-f x) abs * CR_of_Q R (1#2))). unfold CRminus. rewrite CRplus_0_l. apply CRle_refl. left. apply (CRlt_le_trans _ (x + 0)). apply CRplus_lt_compat_l. rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. rewrite CRplus_0_r. exact c2. apply c1. setoid_replace (x + - (cont_mod (-f x) abs * CR_of_Q R (1#2)) + - x) with (- (cont_mod (-f x) abs * CR_of_Q R (1#2))). rewrite CRabs_opp. rewrite CRabs_right. rewrite <- (CRmult_1_r (cont_mod (- f x) abs)). rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0. rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity. apply CRlt_asym. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. + apply CRopp_gt_lt_contravar in abs. rewrite CRopp_0 in abs. specialize (c1 (-f x) (x + (cont_mod (-f x) abs) * CR_of_Q R (1#2)) x abs). apply (CRle_abs (-f x)). apply (CRle_lt_trans _ (CRabs _ (f (x + cont_mod (- f x) abs * CR_of_Q R (1 # 2)) - f x))). rewrite (c (x + cont_mod (-f x) abs * CR_of_Q R (1#2))). unfold CRminus. rewrite CRplus_0_l. apply CRle_refl. right. apply (CRle_lt_trans _ (x + 0)). rewrite CRplus_0_r. exact c2. apply CRplus_lt_compat_l. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. apply c1. setoid_replace (x + (cont_mod (-f x) abs * CR_of_Q R (1#2)) + - x) with (cont_mod (-f x) abs * CR_of_Q R (1#2)). rewrite CRabs_right. rewrite <- (CRmult_1_r (cont_mod (- f x) abs)). rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0. rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity. apply CRlt_asym. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. - intro abs. destruct H0. + specialize (c1 (f x) (x - (cont_mod (f x) abs) * CR_of_Q R (1#2)) x abs). apply (CRle_abs (f x)). apply (CRle_lt_trans _ (CRabs _ (f (x - cont_mod (f x) abs * CR_of_Q R (1 # 2)) - f x))). rewrite (c (x - cont_mod (f x) abs * CR_of_Q R (1#2))). unfold CRminus. rewrite CRplus_0_l, CRabs_opp. apply CRle_refl. left. apply (CRlt_le_trans _ (x + 0)). apply CRplus_lt_compat_l. rewrite <- CRopp_0. apply CRopp_gt_lt_contravar. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. rewrite CRplus_0_r. exact c2. apply c1. setoid_replace (x + - (cont_mod (f x) abs * CR_of_Q R (1#2)) + - x) with (- (cont_mod (f x) abs * CR_of_Q R (1#2))). rewrite CRabs_opp. rewrite CRabs_right. rewrite <- (CRmult_1_r (cont_mod (f x) abs)). rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0. rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity. apply CRlt_asym. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. + specialize (c1 (f x) (x + (cont_mod (f x) abs) * CR_of_Q R (1#2)) x abs). apply (CRle_abs (f x)). apply (CRle_lt_trans _ (CRabs _ (f (x + cont_mod (f x) abs * CR_of_Q R (1 # 2)) - f x))). rewrite (c (x + cont_mod (f x) abs * CR_of_Q R (1#2))). unfold CRminus. rewrite CRplus_0_l, CRabs_opp. apply CRle_refl. right. apply (CRle_lt_trans _ (x + 0)). rewrite CRplus_0_r. exact c2. apply CRplus_lt_compat_l. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. apply c1. setoid_replace (x + (cont_mod (f x) abs * CR_of_Q R (1#2)) + - x) with (cont_mod (f x) abs * CR_of_Q R (1#2)). rewrite CRabs_right. rewrite <- (CRmult_1_r (cont_mod (f x) abs)). rewrite CRmult_assoc. apply CRmult_lt_compat_l. apply c0. rewrite CRmult_1_l. apply CR_of_Q_lt; reflexivity. apply CRlt_asym. apply CRmult_lt_0_compat. apply c0. apply CR_of_Q_pos; reflexivity. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Lemma UC_constant : forall {R : ConstructiveReals} (c : CRcarrier R), UniformCont (fun _:CRcarrier R => c) (fun _ _ => 1). Proof. split. intros. apply CRzero_lt_one. intros. unfold CRminus. rewrite CRplus_opp_r, CRabs_right. exact epsPos. apply CRle_refl. Qed. Lemma eps2_Rgt_R0 : forall {R : ConstructiveReals} (eps : CRcarrier R), 0 < eps -> 0 < eps * CR_of_Q R (1#2). Proof. intros. apply CRmult_lt_0_compat. apply H. apply CR_of_Q_pos; reflexivity. Qed. Lemma UC_plus : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> UniformCont g modG -> UniformCont (fun x:CRcarrier R => f x + g x) (fun eps epsPos => CRmin (modF (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)) (modG (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))). Proof. split. - intros. apply CRmin_lt. destruct H. apply c. destruct H0. apply c. - intros. setoid_replace (f x + g x - (f y + g y)) with (f x - f y + (g x - g y)). apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)). setoid_replace eps with (eps* CR_of_Q R (1#2) + eps* CR_of_Q R (1#2)). apply CRplus_le_lt_compat. apply CRlt_asym. destruct H. apply (c0 _ _ _ (eps2_Rgt_R0 eps epsPos)). apply (CRlt_le_trans _ (CRmin (modF (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)) (modG (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)))). apply H1. apply CRmin_l. destruct H0. apply (c0 _ _ _ (eps2_Rgt_R0 eps epsPos)). apply (CRlt_le_trans _ (CRmin (modF (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)) (modG (eps * CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)))). apply H1. apply CRmin_r. rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. setoid_replace ((1 # 2) + (1#2))%Q with 1%Q. rewrite CRmult_1_r. reflexivity. reflexivity. unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRopp_plus_distr. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm. reflexivity. Qed. Fixpoint UC_sum {R : ConstructiveReals} (fn : nat -> CRcarrier R -> CRcarrier R) (fnMod : nat -> forall x:CRcarrier R, 0 < x -> CRcarrier R) (fnCont : forall n:nat, UniformCont (fn n) (fnMod n)) (n : nat) : { sMod : forall x:CRcarrier R, 0 < x -> CRcarrier R & UniformCont (fun x:CRcarrier R => CRsum (fun i => fn i x) n) sMod }. Proof. destruct n. - exists (fnMod O). apply fnCont. - destruct (UC_sum R fn fnMod fnCont n) as [sMod sCont]. exists (fun eps epsPos => CRmin (sMod (eps* CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos)) (fnMod (S n) (eps* CR_of_Q R (1#2)) (eps2_Rgt_R0 eps epsPos))). simpl. apply UC_plus. apply sCont. apply fnCont. Qed. Lemma UC_translate : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a : CRcarrier R) (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> UniformCont (fun x:CRcarrier R => f x + a) modF. Proof. split. apply H. intros. setoid_replace (f x + a - (f y + a)) with (f x - f y). destruct H. apply (c0 _ _ _ epsPos). apply H0. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRopp_plus_distr. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. Qed. Lemma UC_translate_horizontal : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a : CRcarrier R) (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> UniformCont (fun x:CRcarrier R => f (x + a)) modF. Proof. split. apply H. intros. destruct H. apply (c0 _ _ _ epsPos). setoid_replace (x + a - (y + a)) with (x-y). apply H0. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRopp_plus_distr. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. Qed. Lemma UC_modExt : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> (forall x xPos, modF x xPos == modG x xPos) -> UniformCont f modG. Proof. split. - intros. rewrite <- H0. destruct H. apply c. - intros. rewrite <- H0 in H1. destruct H. apply (c0 _ _ _ epsPos). apply H1. Qed. Lemma UC_ext : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> (forall x:CRcarrier R, f x == g x) -> UniformCont g modF. Proof. intros. destruct H. split. - apply c. - intros. do 2 rewrite <- H0. exact (c0 eps x y epsPos H). Qed. Lemma posScale : forall {R : ConstructiveReals} (a : CRcarrier R), 0 < CRmax 1 (CRabs _ a). Proof. intros. apply (CRlt_le_trans 0 1). apply CRzero_lt_one. apply CRmax_l. Qed. Lemma UC_scale : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R) (a : CRcarrier R), UniformCont f modF -> UniformCont (fun x:CRcarrier R => a * f x) (fun (eps:CRcarrier R) epsPos => modF (eps * (CRinv R (CRmax 1 (CRabs _ a)) (inr (posScale a)))) (CRmult_lt_0_compat _ eps _ epsPos (CRinv_0_lt_compat _ _ (inr (posScale a)) (posScale a)))). Proof. split. - intros x xPos. destruct H. apply c. - intros. unfold CRminus. rewrite CRopp_mult_distr_r, <- CRmult_plus_distr_l. rewrite CRabs_mult. apply (CRle_lt_trans _ (CRmax 1 (CRabs _ a) * CRabs _ (f x - f y))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRmax_r. destruct H. specialize (c0 _ _ _ _ H0). apply (CRmult_lt_compat_r (CRmax 1 (CRabs _ a))) in c0. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in c0. rewrite CRmult_comm. exact c0. apply posScale. Qed. Lemma TelescopicSum : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (n : nat), CRsum (fun k => un (S k) - un k) n == un (S n) - (un O). Proof. induction n. - reflexivity. - simpl. rewrite IHn. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Lemma Rsum_minus : forall {R : ConstructiveReals} (un vn : nat -> CRcarrier R) (n : nat), CRsum (fun k => un k - vn k) n == CRsum un n - CRsum vn n. Proof. induction n. - reflexivity. - simpl. rewrite IHn. unfold CRminus. do 2 rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRopp_plus_distr. reflexivity. Qed. Lemma Rsmaller_interval : forall {R : ConstructiveReals} (a b c d : CRcarrier R), a <= c -> c <= b -> a <= d -> d <= b -> CRabs _ (d - c) <= b-a. Proof. intros. apply CRabs_le. split. - apply (CRplus_le_reg_l (c+b)). unfold CRminus. rewrite CRopp_plus_distr. rewrite CRplus_assoc, <- (CRplus_assoc b). rewrite CRplus_opp_r, (CRplus_comm c b), CRplus_assoc. apply CRplus_le_compat. exact H0. rewrite CRopp_involutive, CRplus_0_l, CRplus_comm. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. exact H1. - apply (CRplus_le_reg_r (a+c)). unfold CRminus. rewrite (CRplus_assoc b), <- (CRplus_assoc (-a)). rewrite CRplus_opp_l, CRplus_0_l, CRplus_assoc. apply CRplus_le_compat. exact H2. rewrite CRplus_comm. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. exact H. Qed. Lemma sum_by_packets : forall {R : ConstructiveReals} (xn : nat -> CRcarrier R) (Pn : nat -> nat) (n : nat), (forall k, le k n -> lt (Pn k) (Pn (S k))) -> Pn O = O -> CRsum (fun i => CRsum (fun k => xn (k + Pn i))%nat (pred (Pn (S i) - Pn i))) n == CRsum xn (pred (Pn (S n))). Proof. induction n. - intros. simpl. rewrite H0. replace (pred (Pn 1 - 0))%nat with (pred (Pn 1%nat)). apply CRsum_eq. intros. rewrite Nat.add_comm. reflexivity. rewrite Nat.sub_0_r. reflexivity. - intros. assert (forall k : nat, k <= n -> Pn k < Pn (S k))%nat. { intros. apply H. apply (Nat.le_trans _ n _ H1). apply le_S, Nat.le_refl. } specialize (IHn H1 H0). clear H1. simpl. rewrite IHn. destruct (Pn (S (S n)) - Pn (S n))%nat eqn:des. exfalso. apply Nat.sub_0_le in des. apply (proj1 (Nat.le_ngt _ _) des). apply H, Nat.le_refl. simpl. pose proof (H n). destruct (Pn (S n)). exfalso. apply (proj1 (Nat.le_ngt 0 (Pn n)) (Nat.le_0_l _)). apply H1, le_S, Nat.le_refl. clear H1. simpl. rewrite (CRsum_eq (fun k : nat => xn (k + S n1)%nat) (fun k : nat => xn (S n1 + k)%nat)). 2: intros; rewrite Nat.add_comm; reflexivity. rewrite <- (sum_assoc xn n1). replace (S n1 + n0)%nat with (Init.Nat.pred (Pn (S (S n)))). reflexivity. pose proof (H (S n) (Nat.le_refl _)). destruct (Pn (S (S n))). exfalso. inversion H1. simpl. simpl in des. replace (S (n1 + n0)) with (n1 + S n0)%nat. 2: apply Nat.add_succ_r. rewrite <- des. rewrite Nat.add_comm. rewrite Nat.sub_add. reflexivity. destruct (le_lt_dec n2 n1). apply Nat.sub_0_le in l. rewrite l in des. discriminate. apply (Nat.le_trans _ (S n1)). apply le_S, Nat.le_refl. exact l. Qed. (* TODO replace SubSeqCv *) Lemma ShouldReplaceSubSeq : forall (sub : SubSeq) (n : nat), le n (proj1_sig sub n). Proof. induction n. - apply Nat.le_0_l. - destruct sub; simpl. simpl in IHn. specialize (l n (S n) (Nat.le_refl _)). apply (Nat.le_trans _ (S (x n))). apply le_n_S, IHn. exact l. Qed. Lemma SubSeqCvMerge : forall {R : ConstructiveReals} (un : nat -> CRcarrier R) (sub : nat -> nat) (l : CRcarrier R), (forall n:nat, le n (sub n)) -> CR_cv R un l -> CR_cv R (fun n => un (sub n)) l. Proof. intros. intros n. specialize (H0 n) as [p pmaj]. exists p. intros. apply pmaj. apply (Nat.le_trans _ i _ H0), H. Qed. Lemma Qpower_positive : forall (q : Q) (n : nat), Qlt 0 q -> Qlt 0 (q^Z.of_nat n). Proof. induction n. - intros. reflexivity. - intros. rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Qpower_plus. rewrite <- (Qmult_0_l q). apply Qmult_lt_r. exact H. exact (IHn H). intro abs. rewrite abs in H. inversion H. Qed. Lemma pow_inject_Q : forall {R : ConstructiveReals} (q : Q) (n : nat), ~(q == 0)%Q -> (CR_of_Q R (q ^ Z.of_nat n) == CRpow (CR_of_Q R q) n). Proof. induction n. - intros. reflexivity. - intros. rewrite Nat2Z.inj_succ. unfold Z.succ. rewrite Qpower_plus. rewrite CR_of_Q_mult, IHn. simpl. apply CRmult_comm. exact H. exact H. Qed. Definition UCUnitHeaviside {R : ConstructiveReals} (a b : CRcarrier R) (ltab : a < b) : CRcarrier R -> CRcarrier R := fun x => (CRmax 0 (CRmin 1 ((x - a) * (CRinv R (b-a) (inr (CRlt_minus _ _ ltab)))))). Lemma LipschitzMin : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (k m : CRcarrier R), Lipschitz f k -> Lipschitz (fun x => CRmin m (f x)) k. Proof. intros R f k m fl x y. rewrite CRmin_sym, (CRmin_sym m). apply (CRle_trans _ _ _ (CRmin_contract _ _ _)). apply fl. Qed. Lemma UCmin : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (m : CRcarrier R) (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R), 0 <= m -> UniformCont f fMod -> UniformCont (fun x => CRmin m (f x)) fMod. Proof. intros R f m fMod mPos H. destruct H. split. exact c. intros. apply (CRle_lt_trans _ (CRabs _ (f x - f y))). 2: apply (c0 eps _ _ epsPos H). rewrite CRmin_sym, (CRmin_sym m). apply CRmin_contract. Qed. Lemma UCmax : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (m : CRcarrier R) (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R), 0 <= m -> UniformCont f fMod -> UniformCont (fun x => CRmax m (f x)) fMod. Proof. intros R f m fMod mPos H. destruct H. split. exact c. intros. apply (CRle_lt_trans _ (CRabs _ (f x - f y))). 2: apply (c0 eps _ _ epsPos H). rewrite CRmax_sym, (CRmax_sym m). apply CRmax_contract. Qed. Lemma UCHeaviside_cont : forall {R : ConstructiveReals} (a b : CRcarrier R) (ltab : a < b), UniformCont (UCUnitHeaviside a b ltab) (fun eps epsPos => eps * (b-a)). Proof. intros. apply UCmax. apply CRle_refl. apply UCmin. apply CRlt_asym, CRzero_lt_one. assert (0 < (b - a)). apply CRlt_minus. apply ltab. split. - intros. apply CRmult_lt_0_compat; assumption. - intros. rewrite (CRabs_morph _ ((x - y) * (CRinv R (b - a) (inr (CRlt_minus a b ltab))))). rewrite CRabs_mult. rewrite (CRabs_right (CRinv R (b - a) (inr (CRlt_minus a b ltab)))). apply (CRlt_le_trans _ (eps * (b-a) * (CRinv R (b - a) (inr (CRlt_minus a b ltab))))). apply CRmult_lt_compat_r. 2: exact H0. apply CRinv_0_lt_compat, H. rewrite CRmult_assoc, CRinv_r, CRmult_1_r. apply CRle_refl. apply CRlt_asym, CRinv_0_lt_compat, H. unfold CRminus. rewrite CRopp_mult_distr_l. rewrite <- CRmult_plus_distr_r. setoid_replace (x + - a + - (y + - a)) with (x+-y). reflexivity. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite CRplus_comm, CRopp_plus_distr. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. Qed. Lemma UCHeavisideBounded : forall {R : ConstructiveReals} (a b x : CRcarrier R) (ltab : a < b), (0 <= UCUnitHeaviside a b ltab x <= 1). Proof. intros. unfold UCUnitHeaviside. split. - apply CRmax_l. - apply CRmax_lub. apply CRlt_asym, CRzero_lt_one. apply CRmin_l. Qed. Lemma Rplus_pos_higher : forall {R : ConstructiveReals} (a eps:CRcarrier R), 0 < eps -> a < (a+eps). Proof. intros. rewrite <- (CRplus_0_r a). rewrite CRplus_assoc. apply CRplus_lt_compat_l. rewrite CRplus_0_l. exact H. Qed. Lemma Rminus_pos_lower : forall {R : ConstructiveReals} (a eps:CRcarrier R), 0 < eps -> (a-eps) < a. Proof. intros. apply (CRplus_lt_reg_r eps). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply Rplus_pos_higher. apply H. Qed. Definition CSUCUnitTrapeze {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta) (x : CRcarrier R) : CRcarrier R := UCUnitHeaviside (a-eta) a (Rminus_pos_lower a eta etaPos) x - UCUnitHeaviside b (b+eta) (Rplus_pos_higher b eta etaPos) x. Lemma CSUCUnitTrapeze_cont : forall {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta), a <= b -> UniformCont (CSUCUnitTrapeze a b eta etaPos) (* The modulus could be improved to eps*eta *) (fun eps epsPos => eps * CR_of_Q R (1#2) * eta). Proof. intros. apply (UC_modExt _ (fun eps epsPos => CRmin (eps * CR_of_Q R (1#2) * (a - (a - eta))) (eps * CR_of_Q R (1#2) * (b + eta - b)))). - apply (UC_plus _ _ (fun eps epsPos => eps * (a-(a-eta))) (fun eps epsPos => eps * (b+eta-b))). apply UCHeaviside_cont. split. intros. rewrite CRplus_comm. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_r, CRplus_0_r. rewrite <- (CRmult_0_r x). apply CRmult_lt_compat_l. exact xPos. exact etaPos. intros. unfold CRminus. rewrite <- CRopp_plus_distr. rewrite CRabs_opp. apply UCHeaviside_cont. apply epsPos. apply H0. - intros. rewrite CRmin_left. unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. rewrite CRopp_involutive. reflexivity. setoid_replace (a - (a - eta)) with eta. setoid_replace (b + eta - b) with eta. apply CRle_refl. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. Qed. Lemma UCHeavisideIn : forall {R : ConstructiveReals} (a b x : CRcarrier R) (altb : a < b), b <= x -> UCUnitHeaviside a b altb x == 1. Proof. intros. unfold UCUnitHeaviside. rewrite CRmin_left, CRmax_right. reflexivity. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r (b-a)). unfold CRminus. rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r. exact altb. rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r. unfold CRminus. rewrite CRplus_comm, (CRplus_comm x). apply CRplus_le_compat_l. apply H. Qed. Lemma CSUCTrapezePlateau : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta), (a <= x <= b) -> CSUCUnitTrapeze a b eta etaPos x == 1. Proof. intros. unfold CSUCUnitTrapeze. rewrite UCHeavisideIn. 2: apply H. unfold UCUnitHeaviside. rewrite CRmax_left. unfold CRminus. rewrite CRopp_0, CRplus_0_r. reflexivity. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply (CRmult_le_reg_r (b+eta-b)). unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. apply etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_0_l, CRmult_1_r. unfold CRminus. rewrite CRplus_comm. rewrite <- (CRplus_opp_l b). apply CRplus_le_compat_l. apply H. Qed. Lemma CSUCTrapezeInPlateau : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta), 0 < CSUCUnitTrapeze a b eta etaPos x -> (a-eta < x < b+eta). Proof. intros. unfold CSUCUnitTrapeze in H. apply (CRplus_lt_compat_r (UCUnitHeaviside b (b + eta) (Rplus_pos_higher b eta etaPos) x)) in H. unfold CRminus in H. rewrite CRplus_0_l, CRplus_assoc, CRplus_opp_l, CRplus_0_r in H. split. - assert (0 < UCUnitHeaviside (a - eta) a (Rminus_pos_lower a eta etaPos) x). { apply (CRle_lt_trans _ (UCUnitHeaviside b (b + eta) (Rplus_pos_higher b eta etaPos) x)). 2: exact H. apply UCHeavisideBounded. } unfold UCUnitHeaviside in H0. rewrite CRmax_right in H0. apply CRlt_min in H0. destruct H0. apply (CRmult_lt_compat_r (a-(a-eta))) in c0. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r in c0. rewrite <- (CRplus_opp_r (a-eta)) in c0. apply CRplus_lt_reg_r in c0. exact c0. unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. rewrite CRopp_involutive. exact etaPos. intro abs. rewrite CRmax_left in H0. exact (CRlt_asym 0 0 H0 H0). apply CRlt_asym, abs. - assert (UCUnitHeaviside b (b+eta) (Rplus_pos_higher b eta etaPos) x < 1). { apply (CRlt_le_trans _ _ _ H). apply UCHeavisideBounded. } unfold UCUnitHeaviside in H0. apply CRlt_max in H0. destruct H0 as [_ H0]. rewrite CRmin_right in H0. apply (CRmult_lt_compat_r (b+eta-b)) in H0. rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r in H0. apply CRplus_lt_reg_r in H0. exact H0. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. exact etaPos. intro abs. rewrite CRmin_left in H0. exact (CRlt_asym 1 1 H0 H0). apply CRlt_asym, abs. Qed. Lemma CSUCTrapezePositive : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta) (leab : a <= b), prod (a-eta < x) (x < b+eta) -> 0 < (CSUCUnitTrapeze a b eta etaPos x). Proof. intros. unfold CSUCUnitTrapeze, UCUnitHeaviside. rewrite CRmax_right. rewrite (CRmin_right 1 ((x - b) * CRinv R (b + eta - b) (inr (CRlt_minus b (b + eta) (Rplus_pos_higher b eta etaPos))))). - apply (CRle_lt_trans _ (CRmax 0 ((x - b) * CRinv R (b + eta - b) (inr (CRlt_minus b (b + eta) (Rplus_pos_higher b eta etaPos)))) - CRmax 0 ((x - b) * CRinv R (b + eta - b) (inr (CRlt_minus b (b + eta) (Rplus_pos_higher b eta etaPos)))))). unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl. apply CRplus_lt_compat_r. apply CRmin_lt. apply CRmax_lub_lt. apply CRzero_lt_one. 2: apply CRmax_lub_lt. + apply (CRmult_lt_reg_r (b+eta-b)). unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r. unfold CRminus. apply CRplus_lt_compat_r. apply H. + apply (CRmult_lt_reg_r (a-(a-eta))). unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_0_l, CRmult_1_r. rewrite <- (CRplus_opp_r (a-eta)). apply CRplus_lt_compat_r. apply H. + apply (CRmult_lt_reg_r (b+eta-b)). unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_r. setoid_replace (b + eta - b) with eta. rewrite <- (CRmult_comm eta). apply (CRmult_lt_reg_r (a-(a-eta))). unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. exact etaPos. rewrite CRmult_assoc, CRmult_assoc, CRinv_l, CRmult_1_r. setoid_replace (a - (a - eta)) with eta. rewrite CRmult_comm. apply CRmult_lt_compat_l. exact etaPos. apply CRplus_lt_compat_l. apply CRopp_gt_lt_contravar. apply (CRlt_le_trans _ a). apply (CRplus_lt_reg_r eta). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. apply CRplus_lt_compat_l, etaPos. exact leab. unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. - apply (CRmult_le_reg_r (b+eta-b)). unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r. unfold CRminus. rewrite CRplus_comm. rewrite <- (CRplus_comm (-b)). apply CRplus_le_compat_l. apply CRlt_asym, H. - apply CRmin_glb. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r (a-(a-eta))). unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_0_l, CRmult_1_r. unfold CRminus. rewrite <- (CRplus_opp_l (a-eta)), (CRplus_comm x). apply CRplus_le_compat_l. apply CRlt_asym, H. Qed. Lemma CSUCTrapezeBounded : forall {R : ConstructiveReals} (a b eta x : CRcarrier R) (etaPos : 0 < eta), a <= b -> (0 <= CSUCUnitTrapeze a b eta etaPos x <= 1). Proof. intros. unfold CSUCUnitTrapeze, UCUnitHeaviside. rewrite (CRinv_morph (a - (a-eta)) eta _ (inr etaPos)). rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)). destruct (CRltLinear R). destruct (s a x (b+eta)). - apply (CRle_lt_trans _ (b+0)). rewrite CRplus_0_r. exact H. apply CRplus_lt_compat_l. exact etaPos. - (* a < x *) rewrite CRmax_right, CRmin_left. split. + apply (CRle_trans _ (1-1)). unfold CRminus. rewrite CRplus_opp_r. apply CRle_refl. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply CRmax_lub. apply CRlt_asym, CRzero_lt_one. apply CRmin_l. + apply (CRle_trans _ (1-0)). apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply CRmax_l. unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive. rewrite <- CRplus_assoc, CRmult_plus_distr_r, CRinv_r. apply (CRle_trans _ (0+1)). rewrite CRplus_0_l. apply CRle_refl. apply CRplus_le_compat_r. apply (CRle_trans _ ((x-a)*0)). rewrite CRmult_0_r. apply CRle_refl. apply CRlt_asym. apply CRmult_lt_compat_l. rewrite <- (CRplus_opp_r a). apply CRplus_lt_compat_r, c. apply CRinv_0_lt_compat. exact etaPos. + apply CRmin_glb. apply CRlt_asym, CRzero_lt_one. apply (CRle_trans _ ((x-(a-eta))*0)). rewrite CRmult_0_r. apply CRle_refl. apply CRlt_asym. apply CRmult_lt_compat_l. apply (CRplus_lt_reg_r (a-eta)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l. apply (CRlt_trans _ a). 2: apply c. apply (CRplus_lt_reg_r eta). rewrite CRplus_assoc, CRplus_opp_l. apply CRplus_lt_compat_l. exact etaPos. apply CRinv_0_lt_compat. exact etaPos. - rewrite (CRmin_right 1 ((x - b) * CRinv R eta (inr etaPos))). split. + unfold CRminus. rewrite CRplus_comm. apply (CRle_trans _ (-(CRmax 0 ((x - b) * CRinv R eta (inr etaPos))) + CRmax 0 ((x - b)* CRinv R eta (inr etaPos)))). rewrite CRplus_opp_l. apply CRle_refl. apply CRplus_le_compat_l. apply CRmax_lub. apply CRmax_l. apply (CRle_trans _ (CRmin 1 ((x + - (a + - eta)) * CRinv R eta (inr etaPos)))). 2: apply CRmax_r. apply CRmin_glb. apply (CRmult_le_reg_r eta _ 1). exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm. apply CRlt_asym, c. apply CRmult_le_compat_r. apply CRlt_asym, CRinv_0_lt_compat. exact etaPos. apply CRplus_le_compat_l. apply CRopp_ge_le_contravar. apply (CRplus_le_reg_r eta). rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply (CRle_trans _ (b+0)). rewrite CRplus_0_r. exact H. apply CRplus_le_compat_l. apply CRlt_asym, etaPos. + apply (CRplus_le_reg_r (CRmax 0 ((x - b) * CRinv R eta (inr etaPos)))). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRmax_lub. apply (CRle_trans _ (1+0)). rewrite CRplus_0_r. apply CRlt_asym, CRzero_lt_one. apply CRplus_le_compat_l. apply CRmax_l. apply (CRle_trans _ (1+0)). rewrite CRplus_0_r. apply CRmin_l. apply CRplus_le_compat_l. apply CRmax_l. + apply (CRmult_le_reg_r eta _ 1). exact etaPos. rewrite CRmult_assoc, CRinv_l, CRmult_1_l, CRmult_1_r. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm. apply CRlt_asym, c. - unfold CRminus. rewrite CRplus_comm. rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. reflexivity. - unfold CRminus. rewrite CRopp_plus_distr. rewrite <- CRplus_assoc, CRplus_opp_r, CRplus_0_l. rewrite CRopp_involutive. reflexivity. Qed. Lemma TrapezeIncluded : forall {R : ConstructiveReals} (a b c d eta mu x : CRcarrier R) (etaPos : 0 < eta) (muPos : 0 < mu), a - eta == c - mu -> b + eta == d + mu -> eta <= mu -> CSUCUnitTrapeze c d mu muPos x <= CSUCUnitTrapeze a b eta etaPos x. Proof. intros. assert (CRinv R mu (inr muPos) <= CRinv R eta (inr etaPos)) as invLe. { apply (CRmult_le_reg_l mu _ _ muPos). rewrite CRinv_r. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. exact H1. } apply CRplus_le_compat. - unfold UCUnitHeaviside. rewrite (CRinv_morph (a - (a-eta)) eta _ (inr etaPos)). rewrite (CRinv_morph (c - (c-mu)) mu _ (inr muPos)). apply CRmax_lub. apply CRmax_l. rewrite <- H. destruct (CRltLinear R). destruct (s (a-eta) x a). + apply (CRplus_lt_reg_r eta). unfold CRminus. rewrite CRplus_assoc. apply CRplus_lt_compat_l. rewrite CRplus_opp_l. exact etaPos. + apply (CRle_trans _ (CRmin 1 ((x - (a - eta)) * CRinv R eta (inr etaPos)))). 2: apply CRmax_r. apply CRmin_glb. apply CRmin_l. apply (CRle_trans _ ((x - (a - eta)) * CRinv R mu (inr muPos))). apply CRmin_r. apply CRmult_le_compat_l. rewrite <- (CRplus_opp_r (a-eta)). apply CRplus_le_compat_r, CRlt_asym, c0. exact invLe. + rewrite CRmin_right. rewrite CRmin_right. apply (CRmult_le_reg_r mu _ _ muPos). rewrite CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRle_trans _ (eta * CRmax 0 ((x - (a - eta)) * CRinv R eta (inr etaPos)))). rewrite <- CRmax_mult. rewrite CRmult_0_r, CRmult_comm. rewrite CRmult_assoc, CRinv_l, CRmult_1_r. apply CRmax_r. apply CRlt_asym, etaPos. rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRmax_l. exact H1. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_l a). unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc, <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply CRlt_asym, c0. apply (CRmult_le_reg_r mu _ _ muPos). rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRle_trans _ eta). apply (CRplus_le_reg_l a). unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc, <- CRplus_assoc. apply CRplus_le_compat_r. rewrite CRplus_comm, <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply CRlt_asym, c0. exact H1. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l. reflexivity. + unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l. reflexivity. - apply CRopp_ge_le_contravar. unfold UCUnitHeaviside. rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)). rewrite (CRinv_morph (d + mu - d) mu _ (inr muPos)). apply CRmax_lub. apply CRmax_l. destruct (CRltLinear R). destruct (s b x (b+eta)). + apply (CRplus_lt_reg_r 0). rewrite CRplus_assoc. apply CRplus_lt_compat_l. rewrite CRplus_0_r. exact etaPos. + apply (CRle_trans _ (CRmin 1 ((x - d) * CRinv R mu (inr muPos)))). 2: apply CRmax_r. apply CRmin_glb. apply CRmin_l. apply (CRmult_le_reg_r mu _ _ muPos). rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_comm. rewrite <- (CRplus_0_r 1). setoid_replace ((x - b) * CRinv R eta (inr etaPos)) with (1 + (x - (b+eta)) * CRinv R eta (inr etaPos)). rewrite <- CRmin_plus, CRmult_plus_distr_l, CRmult_1_r. apply (CRplus_le_reg_l (-mu)). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l. apply (CRle_trans _ (x - (b + eta))). assert (0 == CRinv R eta (inr etaPos) * 0). symmetry. apply CRmult_0_r. rewrite (CRmult_comm (x - (b + eta))). rewrite (CRmin_morph R 0 (CRinv R eta (inr etaPos) * 0) H2 _ _ (CReq_refl _)). rewrite CRmin_mult. apply (CRle_trans _ (CRmin 0 (x - (b + eta)))). 2: apply CRmin_r. rewrite <- CRopp_involutive, <- (CRopp_involutive (CRmin 0 (x - (b + eta)))). apply CRopp_ge_le_contravar. rewrite CRopp_involutive, CRopp_mult_distr_r, CRopp_mult_distr_r. rewrite <- (CRmult_1_l (- CRmin 0 (x - (b + eta)))), <- CRmult_assoc. rewrite <- CRmult_assoc. apply CRmult_le_compat_r. rewrite <- CRopp_0. apply CRopp_ge_le_contravar. apply (CRle_trans _ (-0)). apply CRmin_l. rewrite CRopp_0. apply CRle_refl. rewrite CRmult_1_r. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. exact H1. apply CRlt_asym, CRinv_0_lt_compat, etaPos. unfold CRminus. rewrite H0, CRopp_plus_distr, (CRplus_comm (-mu)). rewrite CRplus_assoc. apply CRle_refl. unfold CRminus. rewrite (CRplus_comm 1), CRmult_plus_distr_r. rewrite CRmult_plus_distr_r, CRopp_plus_distr, CRmult_plus_distr_r. rewrite CRplus_assoc. apply CRplus_morph. reflexivity. rewrite <- (CRopp_mult_distr_l eta), CRinv_r. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. reflexivity. + rewrite CRmin_right. rewrite CRmin_right. apply (CRle_trans _ ((x - d) * CRinv R mu (inr muPos))). 2: apply CRmax_r. apply (CRplus_le_reg_r (-(1))). apply (CRle_trans _ ((x - (b+eta)) * CRinv R eta (inr etaPos))). unfold CRminus. do 2 rewrite CRmult_plus_distr_r. rewrite CRopp_plus_distr, CRmult_plus_distr_r, <- (CRopp_mult_distr_l eta). rewrite CRinv_r, <- CRplus_assoc. apply CRle_refl. apply (CRle_trans _ ((x - (d+mu)) * CRinv R mu (inr muPos))). rewrite <- H0. rewrite <- CRopp_involutive. rewrite <- (CRopp_involutive ((x - (b + eta)) * CRinv R mu (inr muPos))). apply CRopp_ge_le_contravar. do 2 rewrite CRopp_mult_distr_l. apply CRmult_le_compat_l. unfold CRminus. rewrite CRopp_plus_distr, CRopp_involutive, <- (CRplus_opp_l x). apply CRplus_le_compat_l. apply CRlt_asym, c0. exact invLe. unfold CRminus. do 2 rewrite CRmult_plus_distr_r. rewrite CRopp_plus_distr, CRmult_plus_distr_r, <- (CRopp_mult_distr_l mu). rewrite CRinv_r, <- CRplus_assoc. apply CRle_refl. apply (CRmult_le_reg_r mu _ _ muPos). rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. apply (CRplus_le_reg_r d). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_r, CRplus_comm, <- H0. apply CRlt_asym, c0. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_assoc, CRinv_l, CRmult_1_r, CRmult_1_l. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l. rewrite CRplus_0_r, CRplus_comm. apply CRlt_asym, c0. + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. Qed. Lemma Rminus_plus_one_lower : forall {R : ConstructiveReals} (a b : CRcarrier R), a <= b -> (a-1) <= (b+1). Proof. intros. apply (CRle_trans _ a). apply CRlt_asym, Rminus_pos_lower. apply CRzero_lt_one. apply (CRle_trans _ b _ H). apply CRlt_asym, Rplus_pos_higher. apply CRzero_lt_one. Qed. Lemma UC_x : forall {R : ConstructiveReals}, UniformCont (fun x:CRcarrier R => x) (fun eps _ => eps). Proof. split. intros. exact xPos. intros. exact H. Qed. Lemma S_INR : forall {R : ConstructiveReals} (n:nat), INR (S n) == @INR R n + 1. Proof. intros R n. unfold INR. rewrite <- CR_of_Q_plus. apply CR_of_Q_morph. rewrite Qinv_plus_distr. unfold Qeq, Qnum, Qden. do 2 rewrite Z.mul_1_r. fold (1 + n)%nat. rewrite (Nat2Z.inj_add 1 n). rewrite Z.add_comm. reflexivity. Qed. Lemma sum_INR : forall {R : ConstructiveReals} (n:nat), CRsum INR n == INR n * (INR (S n)) * CR_of_Q R (1#2). Proof. induction n. - unfold CRsum, INR, Z.of_nat. rewrite CRmult_0_l, CRmult_0_l. reflexivity. - transitivity (CRsum INR n + @INR R (S n)). reflexivity. rewrite IHn. clear IHn. transitivity (INR (S n) * (INR n * CR_of_Q R (1#2) + 1)). rewrite CRmult_plus_distr_l. apply CRplus_morph. rewrite <- CRmult_assoc. apply CRmult_morph. 2: reflexivity. apply CRmult_comm. rewrite CRmult_1_r. reflexivity. rewrite CRmult_assoc. apply CRmult_morph. reflexivity. apply (CRmult_eq_reg_r (CR_of_Q R 2)). left. apply CR_of_Q_pos; reflexivity. rewrite CRmult_plus_distr_r, CRmult_1_l. rewrite CRmult_assoc, <- CR_of_Q_mult. rewrite CRmult_assoc, <- (CR_of_Q_mult _ (1#2)). setoid_replace ((1 # 2) * 2)%Q with 1%Q. 2: reflexivity. do 2 rewrite CRmult_1_r. rewrite (CR_of_Q_plus R 1 1). do 2 rewrite S_INR. rewrite CRplus_assoc. reflexivity. Qed. Lemma CSUCTrapeze_CSUC : forall {R : ConstructiveReals} (a b eta : CRcarrier R) (etaPos : 0 < eta), a <= b -> CSUC (CSUCUnitTrapeze a b eta etaPos) (a-eta) (b+eta) (fun eps epsPos => eps * CR_of_Q R (1#2) * eta). Proof. intros. split. - apply CSUCUnitTrapeze_cont. apply H. - intros. unfold CSUCUnitTrapeze, UCUnitHeaviside. rewrite (CRinv_morph (a - (a-eta)) eta _ (inr etaPos)). rewrite (CRinv_morph (b + eta - b) eta _ (inr etaPos)). destruct H0 as [H0|H0]. + assert (x < a). { apply (CRlt_trans x (a-eta)). apply H0. apply Rminus_pos_lower. exact etaPos. } assert (x < b). { exact (CRlt_le_trans x a _ H1 H). } rewrite CRmax_left, CRmax_left. unfold CRminus. rewrite CRplus_opp_r. reflexivity. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_0_r. apply CRlt_asym, H2. apply (CRle_trans _ _ _ (CRmin_r _ _)). apply (CRmult_le_reg_r eta). exact etaPos. rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r (a-eta)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_0_r. apply CRlt_asym, H0. + assert (b < x). { apply (CRlt_trans b (b+eta)). apply Rplus_pos_higher. exact etaPos. apply H0. } assert (a < x). { exact (CRle_lt_trans a b _ H H1). } rewrite CRmax_right, CRmax_right. rewrite CRmin_left, CRmin_left. unfold CRminus. apply CRplus_opp_r. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. apply CRlt_asym, H0. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_1_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r (a-eta)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_comm. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRlt_asym, H2. apply CRmin_glb. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r b). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l. apply CRlt_asym, H1. apply CRmin_glb. apply CRlt_asym, CRzero_lt_one. apply (CRmult_le_reg_r eta _ _ etaPos). rewrite CRmult_0_l, CRmult_assoc, CRinv_l, CRmult_1_r. apply (CRplus_le_reg_r (a-eta)). unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r, CRplus_0_l. apply (CRle_trans _ a). 2: apply CRlt_asym, H2. apply (CRplus_le_reg_r eta). rewrite CRplus_assoc, CRplus_opp_l. apply CRplus_le_compat_l. apply CRlt_asym, etaPos. + unfold CRminus. rewrite CRplus_comm, <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. reflexivity. + unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_l, CRopp_involutive. reflexivity. Qed. Definition UC_bounded {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fUC : UniformCont f fMod) : a <= b -> { B : CRcarrier R & forall x:CRcarrier R, a <= x -> x <= b -> CRabs _ (f x) < B }. Proof. (* Evaluate the modulus of uniform continuity for 1, then divide the segment [a,b] by this length and take the highest value of f at those points, plus 1. *) pose proof ((snd fUC) 1). intros. (* Divide the modulus by 2, because constructively there is no exact comparison of real numbers. *) pose (nat_rec (fun n => CRcarrier R) (CRabs _ (f a)) (fun n x => CRmax x (CRabs _ (f (a + INR (S n) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2)))))) as maxou. assert (forall i k : nat, le i k -> CRabs _ (f (a + INR i * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1# 2))) <= (maxou k)) as maxouSpec. { induction k. - intros. inversion H1. unfold INR, Z.of_nat. rewrite (UniformContProper f fMod fUC _ a). apply CRle_refl. rewrite CRmult_0_l. rewrite CRmult_0_l, CRplus_0_r. reflexivity. - intros. apply Nat.le_succ_r in H1. destruct H1. apply (CRle_trans _ (maxou k) _ (IHk H1)). apply CRmax_l. subst i. apply CRmax_r. } (* Get maximal index k of subdivision *) destruct (CRup_nat ((b - a) * CR_of_Q R 2 * (CRinv R (fMod 1 (CRzero_lt_one R)) (inr ((fst fUC) 1 (CRzero_lt_one R)))))) as [k kmaj]. exists (maxou k + 1). intros. assert (0 < fMod 1 (CRzero_lt_one R)) as stepPos. { apply (fst fUC). } (* Find 2 columns around x *) destruct (CRfloor ((x-a) * CR_of_Q R 2 * (CRinv R (fMod 1 (CRzero_lt_one R)) (inr ((fst fUC) 1 (CRzero_lt_one R)))))) as [i [H4 H5]]. apply (CRmult_lt_compat_r (fMod 1 (CRzero_lt_one R))) in H4. rewrite CRmult_assoc in H4. rewrite CRinv_l in H4. rewrite CRmult_1_r in H4. apply (CRmult_lt_compat_r (fMod 1 (CRzero_lt_one R))) in H5. rewrite CRmult_assoc in H5. rewrite CRinv_l in H5. rewrite CRmult_1_r in H5. 2: apply (fst fUC). 2: apply (fst fUC). apply CRltEpsilon. destruct (Z.le_gt_cases i 0). - (* i <= 0 *) clear H4. apply CRltForget. apply (CRlt_le_trans _ (CRabs _ (f a) + 1)). apply (CRplus_lt_reg_r (-CRabs _ (f a))). rewrite (CRplus_comm (CRabs _ (f a))), CRplus_assoc. rewrite CRplus_opp_r, CRplus_0_r. apply (CRle_lt_trans _ _ _ (CRabs_triang_inv _ _)). apply (H _ _ (CRzero_lt_one R)). rewrite CRabs_right. apply (CRmult_lt_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos; reflexivity. apply (CRlt_le_trans _ _ _ H5). rewrite CRmult_comm. apply CRmult_le_compat_l. apply CRlt_asym, (fst fUC). rewrite <- (CRplus_0_l (CR_of_Q R 2)), <- CRplus_assoc. apply CRplus_le_compat. 2: apply CRle_refl. rewrite CRplus_0_r. apply CR_of_Q_le. unfold Qle,Qnum,Qden. simpl. rewrite Z.mul_1_r. exact H3. apply CRle_minus. exact H1. rewrite (UniformContProper f fMod fUC _ (a + INR 0 * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))). apply CRplus_le_compat. 2: apply CRle_refl. apply maxouSpec, Nat.le_0_l. unfold INR, Z.of_nat. rewrite CRmult_0_l, CRmult_0_l, CRplus_0_r. reflexivity. - (* 0 < i *) apply CRltForget. apply (CRlt_le_trans _ (CRabs _ (f (a + CR_of_Q R (i#1) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))) + 1)). + apply (CRplus_lt_reg_l _ (-CRabs _ (f (a + CR_of_Q R (i#1) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2))))). rewrite <- CRplus_assoc, CRplus_opp_l, CRplus_0_l, CRplus_comm. apply (CRle_lt_trans _ _ _ (CRabs_triang_inv _ _)). apply (H _ _ (CRzero_lt_one R)). rewrite CRabs_right. apply (CRplus_lt_reg_r (a + CR_of_Q R (i#1) * (fMod 1 (CRzero_lt_one R) * CR_of_Q R (1#2)))). unfold CRminus. rewrite CRplus_assoc, <- CRmult_assoc, CRplus_opp_l, CRplus_0_r. rewrite CRplus_comm. apply (CRplus_lt_reg_l _ (-a)). do 2 rewrite <- CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_l. rewrite CRplus_comm. apply (CRmult_lt_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos; reflexivity. apply (CRlt_le_trans _ _ _ H5). do 2 rewrite CRmult_plus_distr_r. apply CRplus_le_compat. 2: rewrite CRmult_comm; apply CRle_refl. do 2 rewrite CRmult_assoc. rewrite <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. rewrite CRmult_1_r, CRmult_comm. apply CRle_refl. reflexivity. unfold CRminus. rewrite CRopp_plus_distr, <- CRplus_assoc. apply (CRle_minus (CR_of_Q R (i # 1) * fMod 1 (CRzero_lt_one R) * CR_of_Q R (1 # 2)) (x - a)). apply CRlt_asym, (CRmult_lt_reg_r (CR_of_Q R 2)). apply CR_of_Q_pos; reflexivity. do 2 rewrite CRmult_assoc. rewrite <- CR_of_Q_mult. setoid_replace ((1 # 2) * 2)%Q with 1%Q. rewrite CRmult_1_r. exact H4. reflexivity. + clear H5. apply CRplus_le_compat. 2: apply CRle_refl. unfold INR in maxouSpec. destruct i. exfalso; inversion H3. 2: exfalso; inversion H3. specialize (maxouSpec (Pos.to_nat p) k). rewrite positive_nat_Z in maxouSpec. apply maxouSpec. apply (CRmult_lt_compat_r (fMod 1 (CRzero_lt_one R))) in kmaj. rewrite CRmult_assoc, CRinv_l, CRmult_1_r in kmaj. 2: apply (fst fUC). assert ((x-a)*CR_of_Q R 2 <= (b-a)*CR_of_Q R 2). { apply CRmult_le_compat_r. apply CR_of_Q_le; discriminate. apply CRplus_le_compat. exact H2. apply CRle_refl. } apply (CRlt_le_trans _ _ _ H4) in H5. clear H4. apply (CRlt_trans _ _ _ H5) in kmaj. clear H5. apply CRmult_lt_reg_r in kmaj. 2: apply (fst fUC). destruct (Q_dec (Z.pos p # 1) (Z.of_nat k # 1)). destruct s. unfold Qlt, Qnum, Qden in q. apply le_S_n. apply (Nat.le_trans _ k). apply Nat2Z.inj_lt. rewrite positive_nat_Z. do 2 rewrite Z.mul_1_r in q. exact q. apply le_S, Nat.le_refl. exfalso. apply (CR_of_Q_lt R) in q. exact (CRlt_asym _ _ q kmaj). exfalso. rewrite q in kmaj. exact (CRlt_asym _ _ kmaj kmaj). Qed. Definition CSUC_bounded {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (fMod : forall eps:CRcarrier R, 0 < eps -> CRcarrier R) (fCSUC : CSUC f a b fMod) : a <= b -> { B : CRcarrier R & forall x:CRcarrier R, CRabs _ (f x) < B }. Proof. intros. destruct fCSUC as [H0 H1]. destruct (UC_bounded f (a-1) (b+1) fMod H0) as [B Bmaj]. apply Rminus_plus_one_lower. apply H. exists B. assert (0 < B) as Bpos. { specialize (Bmaj a). apply (CRle_lt_trans _ (CRabs _ (f a))). apply CRabs_pos. apply Bmaj. apply CRlt_asym, Rminus_pos_lower. apply CRzero_lt_one. apply (CRle_trans _ b _ H). apply CRlt_asym, Rplus_pos_higher. apply CRzero_lt_one. } intros. destruct (CRltLinear R). destruct (s (a-1) x a (Rminus_pos_lower a 1 (CRzero_lt_one R))). - destruct (s b x (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))). rewrite H1. rewrite CRabs_right. apply Bpos. apply CRle_refl. right. exact c0. apply Bmaj. apply CRlt_asym, c. apply CRlt_asym, c0. - rewrite H1. rewrite CRabs_right. apply Bpos. apply CRle_refl. left. exact c. Qed. (* Used to zoom in subdomains in the proof of Icontinuous below *) Lemma CSUC_func_mult_stable : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (a b : CRcarrier R) (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R), CSUC f a b modF -> a <= b -> UniformCont g modG -> { modFG : forall x:CRcarrier R, 0 < x -> CRcarrier R & CSUC (fun x => f x * g x) a b modFG }. Proof. intros. destruct (CSUC_bounded f a b modF H H0) as [Bf majf]. destruct H. assert (0 < Bf) as Bfpos. { specialize (majf a). apply (CRle_lt_trans _ (CRabs _ (f a))). apply CRabs_pos. apply majf. } destruct (UC_bounded g (a-1) (b+1) modG H1 (Rminus_plus_one_lower a b H0)) as [Bg majg]. assert (0 < Bg) as Bgpos. { specialize (majg a). apply (CRle_lt_trans _ (CRabs _ (g a))). apply CRabs_pos. apply majg. apply CRlt_asym, Rminus_pos_lower. apply CRzero_lt_one. apply (CRle_trans _ b _ H0). apply CRlt_asym, Rplus_pos_higher. apply CRzero_lt_one. } assert (forall eps:CRcarrier R, 0 < eps -> 0 < eps * CR_of_Q R (1#2) * (CRinv R Bg (inr Bgpos))). { intros. apply CRmult_lt_0_compat. apply CRmult_lt_0_compat. exact H. apply CR_of_Q_pos; reflexivity. apply CRinv_0_lt_compat, Bgpos. } assert (forall eps:CRcarrier R, 0 < eps -> 0 < eps * CR_of_Q R (1#2) * (CRinv R Bf (inr Bfpos))). { intros. apply CRmult_lt_0_compat. apply CRmult_lt_0_compat. exact H2. apply CR_of_Q_pos; reflexivity. apply CRinv_0_lt_compat, Bfpos. } exists (fun eps epsPos => CRmin (modF (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)) (H eps epsPos)) (modG (eps * CR_of_Q R (1#2) * CRinv R Bf (inr Bfpos)) (H2 eps epsPos))). split. split. - intros. apply CRmin_lt. apply (fst u). apply (fst H1). - intros. destruct (CRltLinear R). destruct (s (a-1) x a (Rminus_pos_lower a 1 (CRzero_lt_one R))). + destruct (s b x (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))). (* x is out to the right. *) destruct (s (a-1) y a (Rminus_pos_lower a 1 (CRzero_lt_one R))). destruct (s b y (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))). rewrite c,c. do 2 rewrite CRmult_0_l. unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0. rewrite CRabs_right. apply epsPos. apply CRle_refl. right. exact c3. right. exact c1. (* y is inside *) specialize (c x (inr c1)). setoid_replace (f x * g x - f y * g y) with ((f x - f y) * g y). 2: rewrite c. rewrite CRabs_mult. rewrite CRmult_comm. apply (CRle_lt_trans _ (Bg * CRabs _ (f x - f y))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRlt_asym, majg. apply CRlt_asym, c2. apply CRlt_asym, c3. apply (CRlt_le_trans _ (Bg * (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)))). apply CRmult_lt_compat_l. apply Bgpos. destruct u. apply (c5 _ _ _ (H _ epsPos)). apply (CRlt_le_trans _ _ _ H3). apply CRmin_l. rewrite CRmult_comm, CRmult_assoc, CRinv_l, CRmult_1_r. rewrite <- (CRmult_1_r eps), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, epsPos. rewrite CRmult_1_l. apply CR_of_Q_le; discriminate. unfold CRminus. rewrite CRmult_0_l, CRplus_0_l, CRplus_0_l. apply CRopp_mult_distr_l. (* y < a *) rewrite c, c. do 2 rewrite CRmult_0_l. unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0. rewrite CRabs_right. apply epsPos. apply CRle_refl. left. exact c2. right. exact c1. (* x is inside *) setoid_replace (f x * g x - f y * g y) with (g x * (f x - f y) + f y *(g x - g y)). apply (CRle_lt_trans _ _ _ (CRabs_triang _ _)). setoid_replace eps with (eps*CR_of_Q R (1#2) + eps*CR_of_Q R (1#2)). apply CRplus_le_lt_compat. apply CRlt_asym. * (* delta f *) rewrite CRabs_mult. apply (CRle_lt_trans _ (Bg * CRabs _ (f x - f y))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRlt_asym, majg. apply CRlt_asym, c0. apply CRlt_asym, c1. apply (CRlt_le_trans _ (Bg * (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)))). apply CRmult_lt_compat_l. apply Bgpos. destruct u. apply (c3 _ _ _ (H _ epsPos)). apply (CRlt_le_trans _ _ _ H3). apply CRmin_l. rewrite CRmult_comm, CRmult_assoc, CRinv_l. rewrite CRmult_1_r. apply CRle_refl. * (* delta g *) rewrite CRabs_mult. apply (CRle_lt_trans _ (Bf * CRabs _ (g x - g y))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRlt_asym, majf. apply (CRlt_le_trans _ (Bf * (eps *CR_of_Q R (1#2) * CRinv R Bf (inr Bfpos)))). apply CRmult_lt_compat_l. apply Bfpos. destruct H1. apply (c3 _ _ _ (H2 _ epsPos)). apply (CRlt_le_trans _ _ _ H3). apply CRmin_r. rewrite CRmult_comm, CRmult_assoc, CRinv_l. rewrite CRmult_1_r. apply CRle_refl. * rewrite <- CRmult_plus_distr_l, <- CR_of_Q_plus. setoid_replace ((1#2) + (1#2))%Q with 1%Q. rewrite CRmult_1_r. reflexivity. reflexivity. * unfold CRminus. do 2 rewrite CRmult_plus_distr_l. rewrite CRplus_assoc. apply CRplus_morph. apply CRmult_comm. rewrite <- CRplus_assoc, (CRmult_comm (g x)). rewrite <- CRmult_plus_distr_r, CRplus_opp_l, CRmult_0_l. rewrite CRplus_0_l, CRopp_mult_distr_r. reflexivity. + (* x is out to the left. *) destruct (s (a-1) y a (Rminus_pos_lower a 1 (CRzero_lt_one R))). destruct (s b y (b+1) (Rplus_pos_higher b 1 (CRzero_lt_one R))). * rewrite c,c. do 2 rewrite CRmult_0_l. unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0. rewrite CRabs_right. apply epsPos. apply CRle_refl. right. exact c2. left. exact c0. * (* y is inside *) specialize (c x (inl c0)). setoid_replace (f x * g x - f y * g y) with ((f x - f y) * g y). 2: rewrite c. rewrite CRabs_mult. rewrite CRmult_comm. apply (CRle_lt_trans _ (Bg * CRabs _ (f x - f y))). apply CRmult_le_compat_r. apply CRabs_pos. apply CRlt_asym, majg. apply CRlt_asym, c1. apply CRlt_asym, c2. apply (CRlt_le_trans _ (Bg * (eps * CR_of_Q R (1#2) * CRinv R Bg (inr Bgpos)))). apply CRmult_lt_compat_l. apply Bgpos. destruct u. apply (c4 _ _ _ (H _ epsPos)). apply (CRlt_le_trans _ _ _ H3). apply CRmin_l. rewrite CRmult_comm, CRmult_assoc, CRinv_l. rewrite CRmult_1_r. rewrite <- (CRmult_1_r eps), CRmult_assoc. apply CRmult_le_compat_l. apply CRlt_asym, epsPos. rewrite CRmult_1_l. apply CR_of_Q_le; discriminate. rewrite CRmult_0_l. unfold CRminus. do 2 rewrite CRplus_0_l. rewrite CRopp_mult_distr_l. reflexivity. * rewrite c,c. do 2 rewrite CRmult_0_l. unfold CRminus. rewrite CRplus_0_l. rewrite CRopp_0. rewrite CRabs_right. apply epsPos. apply CRle_refl. left. exact c1. left. exact c0. - intros. destruct H3. rewrite c, CRmult_0_l. reflexivity. left. exact c0. rewrite c, CRmult_0_l. reflexivity. right. exact c0. Qed. Lemma Rplus_lt_epsilon : forall {R : ConstructiveReals} (a b c d : CRcarrier R), (a + b) < (c + d) -> sum (a < c) (b < d). Proof. intros. destruct (CRltLinear R). destruct (s (a+b) (a+d) (c+d) H). - right. apply CRplus_lt_reg_l in c0. exact c0. - left. apply CRplus_lt_reg_r in c0. exact c0. Qed. Lemma EnlargePointMajorationZero : forall {R : ConstructiveReals} (f : CRcarrier R -> CRcarrier R) (x : CRcarrier R) (modF : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> 0 < f x -> { eta : CRcarrier R & prod (0 < eta) (forall y:CRcarrier R, CRabs _ (x-y) < eta -> 0 < (f y)) }. Proof. intros. destruct H as [H H1]. exists (modF (f x) H0). split. - apply H. - intros. specialize (H1 (f x) x y H0 H2). apply (CRle_lt_trans _ _ _ (CRle_abs _)) in H1. apply (CRplus_lt_reg_l _ (f x - f y)). rewrite CRplus_0_r. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. exact H1. Qed. Lemma EnlargePointMajoration : forall {R : ConstructiveReals} (f g : CRcarrier R -> CRcarrier R) (x : CRcarrier R) (modF modG : forall x:CRcarrier R, 0 < x -> CRcarrier R), UniformCont f modF -> UniformCont g modG -> f x < g x -> { eta : CRcarrier R & prod (0 < eta) (forall y:CRcarrier R, CRabs _ (x-y) < eta -> f y < g y) }. Proof. intros. pose proof (UC_scale f modF (-(1)) H). pose proof (UC_plus (fun x => -(1)*f x) g _ modG H2 H0). destruct (EnlargePointMajorationZero (fun t => -(1)*f t + g t) x _ H3). rewrite <- CRopp_mult_distr_l, CRopp_mult_distr_r. rewrite CRmult_1_l. apply (CRplus_lt_reg_l _ (f x)). rewrite <- CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_l, CRplus_0_r. exact H1. exists x0. destruct p. split. exact c. intros. specialize (c0 y H4). apply (CRplus_lt_compat_l _ (f y)) in c0. rewrite CRplus_0_r in c0. setoid_replace (g y) with (f y + (- (1) * f y + g y)). exact c0. rewrite <- CRopp_mult_distr_l, CRmult_1_l. rewrite <- CRplus_assoc, CRplus_opp_r. rewrite CRplus_0_l. reflexivity. Qed. corn-8.20.0/reals/stdlib/Markov.v000066400000000000000000000116531473720167500166010ustar00rootroot00000000000000(* Copyright © 2020 Vincent Semeria Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. *) (** Consequence of the Markov principle on constructive reals. *) From Coq Require Import QArith_base. From Coq Require Import ConstructiveReals. From Coq Require Import ConstructiveAbs. Local Open Scope ConstructiveReals. (* This axiom has computational content : run the unbounded search Pdec 0, Pdec 1, ... and the last hypothesis is a proof of termination. *) Definition Markov : Prop := forall (P : nat -> Prop), (forall n:nat, {P n} + {~P n}) -> (~~exists n:nat, P n) -> exists n:nat, P n. Lemma Markov_notnot_lt_0 : forall {R : ConstructiveReals} (x : CRcarrier R), Markov -> (~~CRltProp R 0 x) -> CRltProp R 0 x. Proof. intro R. assert (forall (x : CRcarrier R) (n:nat), x - CR_of_Q R (1#Pos.of_nat n) < x) as bumpDown. { intros x n. apply (CRlt_le_trans _ (x-0)). apply CRplus_lt_compat_l. apply CRopp_gt_lt_contravar, CR_of_Q_lt. reflexivity. unfold CRminus. rewrite CRopp_0, CRplus_0_r. apply CRle_refl. } intros x markov xpos. assert (exists n:nat, Qlt 0 (let (q,_) := CR_Q_dense R _ _ (bumpDown x n) in q)). { apply markov. - intro n. destruct (CR_Q_dense R _ _ (bumpDown x n)) as [q H]. destruct (Qlt_le_dec 0 q). left. exact q0. right. apply (Qle_not_lt _ _ q0). - intro abs. contradict xpos; intro xpos. apply CRltEpsilon in xpos. contradict abs. destruct (CR_archimedean R (CRinv R x (inr xpos))) as [n H]. exists (Pos.to_nat n). destruct ( CR_Q_dense R (x - CR_of_Q R (1 # Pos.of_nat (Pos.to_nat n)))%ConstructiveReals x (bumpDown x (Pos.to_nat n))) as [q H0]. apply (lt_CR_of_Q R). refine (CRle_lt_trans _ _ _ _ (fst H0)). clear H0 q. rewrite Pos2Nat.id. apply (CRplus_le_reg_r (CR_of_Q R (1#n))). unfold CRminus. rewrite CRplus_0_l. rewrite CRplus_assoc. rewrite CRplus_opp_l, CRplus_0_r. apply CRlt_asym in H. apply (CRmult_le_compat_l x) in H. rewrite CRinv_r in H. apply (CRmult_le_compat_r (CR_of_Q R (1#n))) in H. rewrite CRmult_1_l, CRmult_assoc, <- CR_of_Q_mult in H. setoid_replace ((Z.pos n # 1) * (1 # n))%Q with 1%Q in H. rewrite CRmult_1_r in H. exact H. unfold Qeq; simpl. rewrite Pos.mul_1_r, Pos.mul_1_r. reflexivity. apply CR_of_Q_le; discriminate. apply CRlt_asym, xpos. } clear xpos. destruct H as [n H]. destruct (CR_Q_dense R _ _ (bumpDown x n)) as [q H0]. apply CRltForget. apply (CRlt_trans _ (CR_of_Q R q)). apply CR_of_Q_lt, H. apply H0. Qed. Lemma Markov_notnot_lt : forall {R : ConstructiveReals} (x y : CRcarrier R), Markov -> (~~CRltProp R x y) -> CRltProp R x y. Proof. intros. apply CRltForget. apply (CRplus_lt_reg_r (-x)). apply (CRle_lt_trans _ 0). rewrite CRplus_opp_r. apply CRle_refl. apply CRltEpsilon. apply (Markov_notnot_lt_0 (y-x) H). intro abs. contradict H0; intro H0. contradict abs. apply CRltForget. apply (CRplus_lt_reg_r x). apply (CRle_lt_trans _ x). rewrite CRplus_0_l. apply CRle_refl. apply (CRlt_le_trans _ y). apply CRltEpsilon, H0. unfold CRminus. rewrite CRplus_assoc, CRplus_opp_l, CRplus_0_r. apply CRle_refl. Qed. Lemma Markov_notnot_apart_0 : forall {R : ConstructiveReals} (x : CRcarrier R), Markov -> (~(x == 0)) -> (x ≶ 0). Proof. intros. apply CRabs_appart_0. apply CRltEpsilon, (Markov_notnot_lt_0 _ H). intro abs. contradict H0. assert (CRabs R x <= 0) as H0. { intro H0. contradict abs. apply CRltForget, H0. } pose proof (CRabs_def2 x 0 H0) as [H1 H2]. rewrite CRopp_0 in H2. split; assumption. Qed. Lemma Markov_notnot_apart : forall {R : ConstructiveReals} (x y : CRcarrier R), Markov -> (~(x == y)) -> (x ≶ y). Proof. intros. apply (CRplus_appart_reg_r (-y)). rewrite CRplus_opp_r. apply (Markov_notnot_apart_0 _ H). intro abs. contradict H0. apply (CRplus_eq_reg_r (-y)). rewrite CRplus_opp_r. exact abs. Qed. corn-8.20.0/site_scons/000077500000000000000000000000001473720167500147275ustar00rootroot00000000000000corn-8.20.0/site_scons/site_tools/000077500000000000000000000000001473720167500171135ustar00rootroot00000000000000corn-8.20.0/site_scons/site_tools/Coq.py000066400000000000000000000014731473720167500202140ustar00rootroot00000000000000# -*- coding: utf-8 -*- import SCons.Defaults, SCons.Tool, SCons.Util, os def add_glob(target, source, env): base, _ = os.path.splitext(str(target[0])) target.append(base + ".glob") return target, source Coq = SCons.Builder.Builder( action = '$COQCMD', suffix = '.vo', src_suffix = '.v', emitter = add_glob) def coqdoc_gen(source, target, env, for_signature): for s in source: base, _ = os.path.splitext(str(s)) env.Depends(target, env.File(base + '.glob')) return [SCons.Defaults.Mkdir(target), 'coqdoc $COQDOCFLAGS -d $TARGET $COQFLAGS $SOURCES'] CoqDoc = SCons.Builder.Builder(generator = coqdoc_gen) def generate(env): env['COQC'] = 'coqc' env['COQCMD'] = '$COQC $COQFLAGS -q $SOURCE' env.Append(BUILDERS = {'Coq': Coq, 'CoqDoc': CoqDoc}) def exists(env): return env.Detect('coqc') corn-8.20.0/stdlib_omissions/000077500000000000000000000000001473720167500161425ustar00rootroot00000000000000corn-8.20.0/stdlib_omissions/List.v000066400000000000000000000076231473720167500172540ustar00rootroot00000000000000Require Export Coq.Lists.List. Require Import Coq.Unicode.Utf8 Coq.Setoids.Setoid Coq.Sorting.Permutation Coq.Setoids.Setoid Coq.Classes.Morphisms CoRN.stdlib_omissions.Pair. Fixpoint zip {A B} (a: list A) (b: list B): list (A * B) := match a, b with | ah :: au, bh :: bt => (ah, bh) :: zip au bt | _, _ => nil end. Lemma zip_map_snd {A B C} (a: list A) (b: list B) (f: B → C): zip a (map f b) = map (second f) (zip a b). Proof with auto. revert b. induction a; destruct b... simpl in *. intros. rewrite IHa... Qed. Lemma move_to_front {A} (x: A) (l: list A): In x l → exists l', Permutation (x :: l') l. Proof with eauto. induction l; simpl. intuition. intros [[] | D]... destruct (IHl D) as [y ?]. exists (a :: y). rewrite perm_swap... Qed. #[global] Hint Resolve nth_In. Lemma NoDup_indexed {A} (l: list A) (N: NoDup l) (d: A): forall i j: nat, i < length l → j < length l -> i <> j -> nth i l d <> nth j l d. Proof with auto with arith. intro i. revert l N. induction i; intros. destruct l; simpl. inversion H. destruct j. intuition. inversion_clear N. intro. subst... destruct l. inversion H0. inversion_clear N. simpl. destruct j... intro. subst a... Qed. #[global] Instance: forall A, Proper (@Permutation A ==> iff) (@NoDup A). Proof with auto. intro. cut (forall x y: list A, Permutation x y → NoDup x → NoDup y). intros ??? B. split. apply H... symmetry in B. apply H... intros x y P. induction P; intros... inversion_clear H. apply NoDup_cons... intro. apply H0. apply Permutation_in with l'... symmetry... inversion_clear H. inversion_clear H1. apply NoDup_cons. intros [?|?]... subst y. intuition. apply NoDup_cons... intuition. Qed. #[global] Instance: forall A, Proper (@Permutation A ==> eq) (@length A). Proof Permutation_length. Section list_eq. Context {A} (R: relation A). Fixpoint list_eq (x y: list A): Prop := match x, y with | nil, nil => True | a :: x', b :: y' => R a b ∧ list_eq x' y' | _, _ => False end. Lemma list_eq_rect (P: list A → list A → Type) (Pnil: P nil nil) (Pcons: forall a b, R a b → forall x y, list_eq x y → P x y → P (a :: x) (b :: y)): forall x y, list_eq x y → P x y. Proof. induction x; destruct y; simpl; intuition. Qed. Global Instance list_eq_refl: Reflexive R → Reflexive list_eq. Proof. intros H x. induction x; simpl; intuition; eauto. Qed. Global Instance list_eq_sym: Symmetric R → Symmetric list_eq. Proof. intros H x y E. apply (list_eq_rect (fun x y => list_eq y x)); simpl; intuition; eauto. Qed. Global Instance list_eq_trans: Transitive R → Transitive list_eq. Proof. intros H x. induction x; destruct y; destruct z; simpl; intuition; eauto. Qed. Global Instance: Equivalence R → Equivalence list_eq := {}. Lemma Perm_list_eq_commute (x y y': list A): Permutation x y → list_eq y y' → exists x', list_eq x x' ∧ Permutation x' y'. Proof with simpl; intuition. intro P. revert y'. induction P. destruct y'... exists nil... destruct y'; simpl. intuition. intros [? Rxa]. destruct (IHP y' Rxa) as [x0[??]]. exists (a :: x0). intuition. destruct y'... destruct y'... exists (a0 :: a :: y'). intuition. apply perm_swap. intros. destruct (IHP2 y' H) as [?[??]]. destruct (IHP1 x H0) as [?[??]]. exists x0... transitivity x... Qed. End list_eq. Lemma list_eq_eq {A} (x y: list A): list_eq eq x y <-> x = y. Proof with auto. split; intro. apply (@list_eq_rect A eq)... intros. subst. reflexivity. subst. reflexivity. Qed. #[global] Instance: forall A (x: A), Proper (@Permutation A ==> iff) (@In A x). Proof. pose proof Permutation_in. firstorder auto with crelations. Qed. Lemma tl_map {A B} (l: list A) (f: A → B): tl (map f l) = map f (tl l). Proof. destruct l; reflexivity. Qed. #[global] Hint Resolve in_cons. #[global] Hint Immediate in_eq. corn-8.20.0/stdlib_omissions/N.v000066400000000000000000000002151473720167500165240ustar00rootroot00000000000000Require Import CoRN.stdlib_omissions.List. Fixpoint enum (n: nat): list nat := match n with | O => nil | S n' => n' :: enum n' end. corn-8.20.0/stdlib_omissions/P.v000066400000000000000000000022731473720167500165340ustar00rootroot00000000000000 Require Import Coq.Setoids.Setoid Coq.PArith.BinPos Coq.PArith.Pnat ZArith_base. Section P_of_nat. Variables (n: nat) (E: n <> O). Lemma P_of_nat: positive. apply P_of_succ_nat. destruct n as [|p]. exfalso. apply E. reflexivity. exact p. Defined. Lemma P_of_nat_correct: nat_of_P P_of_nat = n. unfold P_of_nat. destruct n. exfalso. intuition. apply nat_of_P_o_P_of_succ_nat_eq_succ. Qed. End P_of_nat. Lemma nat_of_P_inj_iff (p q : positive): nat_of_P p = nat_of_P q <-> p = q. Proof with auto. split; intro. apply nat_of_P_inj... subst... Qed. Lemma nat_of_P_nonzero (p: positive): nat_of_P p <> 0. Proof. intro H. apply Nat.lt_irrefl with 0. rewrite <- H at 2. apply lt_O_nat_of_P. Qed. #[global] Hint Immediate nat_of_P_nonzero. Lemma Plt_lt (p q: positive): Pos.lt p q <-> (nat_of_P p < nat_of_P q). Proof. split. apply nat_of_P_lt_Lt_compare_morphism. apply nat_of_P_lt_Lt_compare_complement_morphism. Qed. Lemma Ple_le (p q: positive): Pos.le p q <-> le (nat_of_P p) (nat_of_P q). Proof. rewrite Pos.le_lteq, Plt_lt, Nat.lt_eq_cases, nat_of_P_inj_iff. reflexivity. Qed. Lemma Ple_refl p: Pos.le p p. Proof. intros. apply Pos.le_lteq. firstorder. Qed. corn-8.20.0/stdlib_omissions/Pair.v000066400000000000000000000021711473720167500172250ustar00rootroot00000000000000Require Import Coq.Unicode.Utf8 Coq.Setoids.Setoid Coq.Lists.List. Section pair_rel. Context {A B} (Ra: relation A) (Rb: relation B) `{!Equivalence Ra} `{!Equivalence Rb}. Definition pair_rel: relation (A * B) := fun a b => Ra (fst a) (fst b) /\ Rb (snd a) (snd b). Global Instance: Equivalence pair_rel. Proof. firstorder. Qed. End pair_rel. Definition first {A B C} (f: A → B) (p: A * C): B * C := (f (fst p), snd p). Definition second {A B C} (f: A → B) (p: C * A): C * B := (fst p, f (snd p)). Lemma map_fst_map_first {A B C} (l: list (A * B)) (f: A -> C): map (@fst _ _) (map (first f) l) = map f (map (@fst _ _) l). Proof. induction l; simpl; congruence. Qed. Definition curry {A B C} (f: A * B → C) (a: A) (b: B): C := f (a, b). Definition uncurry {A B C} (f: A → B → C) (p: A * B): C := f (fst p) (snd p). Definition map_pair {X Y A B} (f: X → Y) (g: A → B) (xa: X * A): Y * B := (f (fst xa), g (snd xa)). Lemma map_map_comp {A B C} (f: A → B) (g: B → C) (l: list A): map g (map f l) = map (Basics.compose g f) l. Proof. apply (map_map f g). Qed. Definition diagonal {X} (x: X): X * X := (x, x). corn-8.20.0/stdlib_omissions/Q.v000066400000000000000000000363161473720167500165420ustar00rootroot00000000000000From Coq Require Import QArith ZArith NArith Qpower Qround Qround Qabs. Require Import CoRN.stdlib_omissions.List. Require CoRN.stdlib_omissions.Z. Notation "x <= y < z" := (x <= y /\ y < z) : Q_scope. Notation "x < y <= z" := (x < y /\ y <= z) : Q_scope. Notation "x < y < z" := (x < y /\ y < z) : Q_scope. Open Scope Q_scope. Lemma Qnum_nonneg (x : Q) : (0 <= Qnum x)%Z <-> (0 <= x)%Q. Proof. destruct x as [n d]. unfold Qle. simpl. now rewrite Zmult_1_r. Qed. Lemma Qnum_nonpos (x : Q) : (Qnum x <= 0)%Z <-> (x <= 0)%Q. Proof. destruct x as [n d]. unfold Qle. simpl. now rewrite Zmult_1_r. Qed. Lemma Qle_dec x y: {Qle x y} + {~Qle x y}. intros. destruct (Qlt_le_dec y x); [right | left]; [apply Qlt_not_le |]; assumption. Defined. (* Proofs that the various injections into Q are homomorphisms w.r.t. the various operations: *) Lemma Zplus_Qplus (m n: Z): inject_Z (m + n) = inject_Z m + inject_Z n. Proof. unfold Qplus. simpl. unfold inject_Z. do 2 rewrite Zmult_1_r. reflexivity. Qed. Lemma Zsucc_Qplus (z: Z): inject_Z (Z.succ z) = inject_Z z + 1. Proof. apply Zplus_Qplus. Qed. Lemma Zmult_Qmult (x y: Z): inject_Z (x * y) = inject_Z x * inject_Z y. Proof. reflexivity. Qed. Lemma S_Qplus (n: nat): inject_Z (Z_of_nat (S n)) = inject_Z (Z_of_nat n) + 1. Proof. rewrite inj_S. apply Zplus_Qplus. Qed. Lemma Pmult_Qmult (x y: positive): inject_Z (Zpos (Pmult x y)) = inject_Z (Zpos x) * inject_Z (Zpos y). Proof. rewrite Zpos_mult_morphism. apply Zmult_Qmult. Qed. Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). Proof. unfold Qle. intros. simpl. do 2 rewrite Zmult_1_r. reflexivity. Qed. Lemma Zlt_Qlt (x y: Z): (x < y)%Z = (inject_Z x < inject_Z y). Proof. unfold Qlt. intros. simpl. do 2 rewrite Zmult_1_r. reflexivity. Qed. Lemma Zdiv_Qdiv (n m: Z): (n / m)%Z = Qfloor (inject_Z n / inject_Z m). Proof with simpl; try reflexivity. unfold Qfloor. intros. simpl. destruct m... rewrite Zdiv_0_r. rewrite Zmult_0_r... rewrite Zmult_1_r... rewrite <- Zopp_eq_mult_neg_1. rewrite <- (Z.opp_involutive (Zpos p)). rewrite Zdiv_opp_opp... Qed. Lemma Qle_nat (n: nat): 0 <= inject_Z (Z_of_nat n). Proof. rewrite <- (Zle_Qle 0). apply Zle_0_nat. Qed. Lemma inject_Z_injective (a b: Z): inject_Z a = inject_Z b <-> a = b. Proof. unfold inject_Z. split; congruence. Qed. Lemma Qeq_Zeq (a b: Z): (inject_Z a == inject_Z b) = (a = b). Proof. unfold Qeq. simpl. intros. do 2 rewrite Zmult_1_r. reflexivity. Qed. Lemma positive_nonzero_in_Q (p: positive): ~ inject_Z (Zpos p) == 0. Proof. discriminate. Qed. #[global] Hint Immediate positive_nonzero_in_Q. (* Properties of arithmetic: *) Lemma Qmult_injective_l (z: Q) (Znz: ~ z == 0): forall x y, (x * z == y * z <-> x == y). Proof. split; intro E. rewrite <- (Qmult_1_r x). rewrite <- (Qmult_1_r y). rewrite <- (Qmult_inv_r _ Znz). do 2 rewrite Qmult_assoc. rewrite E. reflexivity. rewrite E. reflexivity. Qed. Lemma Qmult_injective_r (z: Q) (Znz: ~ z == 0): forall x y, (z * x == z * y <-> x == y). Proof. intros. do 2 rewrite (Qmult_comm z). apply Qmult_injective_l. assumption. Qed. Lemma Qplus_injective_l (z: Q): forall x y, (x + z == y + z <-> x == y)%Q. Proof with intuition. split; intro E. setoid_replace x with (x + z - z)%Q by (simpl; ring). setoid_replace y with (y + z - z)%Q by (simpl; ring). rewrite E... rewrite E... Qed. Lemma Qminus_eq (x y: Q): (x - y == 0 <-> x == y)%Q. Proof. rewrite <- (Qplus_injective_l (-y) x y). rewrite Qplus_opp_r. reflexivity. Qed. Lemma Qinv_char x q: (x * q == 1) <-> (x == / q /\ ~ q == 0). Proof with auto. split. intros A. assert (~ q == 0). intro B. apply Q_apart_0_1. rewrite <- A, B. ring. intuition. apply (Qmult_injective_l q)... rewrite A. field... intros [A ?]. rewrite A. field... Qed. Lemma Qdiv_1_r (q: Q): q / 1 == q. Proof. field. Qed. Lemma show_is_Qinv x q: x * q == 1 -> x == / q. Proof. intros. apply Qinv_char. assumption. Qed. Lemma Qabs_Qinv : forall q, Qabs (/ q) == / (Qabs q). Proof. intros [n d]; simpl. unfold Qinv. case_eq n; intros; simpl in *; apply Qeq_refl. Qed. Lemma Qabs_Qminus x y: Qabs (x - y) == Qabs (y - x). Proof. unfold Qminus. intros. rewrite <- (Qopp_opp x) at 1. rewrite <- Qopp_plus. rewrite Qplus_comm. apply Qabs_opp. Qed. Lemma Qlt_floor_alt (x : Q) : x - 1 < inject_Z (Qfloor x). Proof. apply Qplus_lt_l with 1. ring_simplify. change 1 with (inject_Z 1). rewrite <-inject_Z_plus. apply Qlt_floor. Qed. Lemma Qfloor_pos (x : Q) : 1 <= x -> (0 < Qfloor x)%Z. Proof. intros E. rewrite Zlt_Qlt. apply Qle_lt_trans with (x - 1). apply Qplus_le_l with 1. now ring_simplify. apply Qlt_floor_alt. Qed. Lemma Qpower_not_0 (a : Q) (n : Z) : ~a==0 -> ~a ^ n == 0. Proof. intros E1. destruct n; simpl. discriminate. now apply Qpower_not_0_positive. intros E2. destruct (Qpower_not_0_positive a p). easy. now rewrite <-Qinv_involutive, E2. Qed. Lemma Qpower_0_lt (a : Q) (n : Z) : 0 < a -> 0 < a ^ n. Proof. intros E1. destruct (Qle_lt_or_eq 0 (a ^ n)) as [E2|E2]; try assumption. now apply Qpower_pos, Qlt_le_weak. symmetry in E2. contradict E2. apply Qpower_not_0. intros E3. symmetry in E3. now destruct (Qlt_not_eq 0 a). Qed. Lemma Qneq_symmetry (x y : Q) : ~x == y -> ~y == x. Proof. firstorder auto with crelations. Qed. Lemma Qdiv_flip_le (x y : Q) : 0 < x -> x <= y -> /y <= /x. Proof. intros E1 E2. assert (0 < y) by now apply Qlt_le_trans with x. apply Qmult_le_l with x; try assumption. apply Qmult_le_l with y; try assumption. field_simplify. now try (unfold Qdiv; rewrite 2!Qmult_1_r). now apply Qneq_symmetry, Qlt_not_eq. now apply Qneq_symmetry, Qlt_not_eq. Qed. Lemma Qdiv_flip_lt (x y : Q) : 0 < x -> x < y -> /y < /x. Proof. intros E1 E2. assert (0 < y) by now apply Qlt_trans with x. apply Qmult_lt_l with x; try assumption. apply Qmult_lt_l with y; try assumption. field_simplify. now try (unfold Qdiv; rewrite 2!Qmult_1_r). now apply Qneq_symmetry, Qlt_not_eq. now apply Qneq_symmetry, Qlt_not_eq. Qed. (* Properties of arithmetic w.r.t. order: *) Lemma Qpos_nonNeg (n d: positive): 0 <= Zpos n # d. Proof. discriminate. Qed. #[global] Hint Immediate Qpos_nonNeg. Lemma Qplus_le_l (z x y : Q): x + z <= y + z <-> x <= y. Proof with auto with *. split; intros. setoid_replace x with (x + z + -z) by (simpl; ring). setoid_replace y with (y + z + -z) by (simpl; ring). apply Qplus_le_compat... apply Qplus_le_compat... Qed. Lemma Qplus_le_r (z x y : Q): z + x <= z + y <-> x <= y. Proof. do 2 rewrite (Qplus_comm z). apply Qplus_le_l. Qed. Lemma Qplus_lt_r (x y: Q) : x < y -> forall z, z + x < z + y. Proof. intros E z. do 2 rewrite (Qplus_comm z). apply Qplus_lt_l. assumption. Qed. Lemma Qmult_le_compat_l (x y z : Q): x <= y -> 0 <= z -> z * x <= z * y. Proof. do 2 rewrite (Qmult_comm z). apply Qmult_le_compat_r. Qed. Lemma Qopp_Qlt_0_l (x: Q): 0 < -x <-> x < 0. Proof. split. rewrite <- (Qopp_opp x) at 2. apply (Qopp_lt_compat 0 (-x)). apply (Qopp_lt_compat x 0). Qed. Lemma Qopp_Qlt_0_r (x: Q): -x < 0 <-> 0 < x. Proof. rewrite <- Qopp_Qlt_0_l, Qopp_opp. reflexivity. Qed. Lemma Qmult_lt_0_compat (x y: Q): 0 < x -> 0 < y -> 0 < x * y. Proof. destruct x, y. unfold Qlt. simpl. repeat rewrite Zmult_1_r. apply Zmult_lt_0_compat. Qed. #[global] Hint Resolve Qmult_lt_0_compat. Lemma Qmult_nonneg_nonpos (x y: Q): 0 <= x -> y <= 0 -> x * y <= 0. Proof with auto. unfold Qle. simpl. repeat rewrite Zmult_1_r. intros. rewrite <- (Zmult_0_r (Qnum x)). apply (Zmult_le_compat_l (Qnum y) 0 (Qnum x))... Qed. Lemma Qmult_neg_pos (x y : Q) : x < 0 -> 0 < y -> x * y < 0. Proof. intros H1 H2. apply Qopp_Qlt_0_l. setoid_replace (- (x * y)) with ((- x) * y) by ring. apply Qmult_lt_0_compat; trivial. now apply Qopp_Qlt_0_l. Qed. Lemma Qmult_pos_neg (x y : Q) : 0 < x -> y < 0 -> x * y < 0. Proof. intros H1 H2. rewrite Qmult_comm. now apply Qmult_neg_pos. Qed. Lemma Qmult_pos_r : forall x y : Q, 0 <= x -> 0 < x * y -> 0 < y. Proof. intros x y H1 H2. destruct (Q_dec y 0) as [[? | ?] | H]; trivial. + exfalso. apply (Qlt_irrefl 0), Qlt_le_trans with (y := x * y); trivial. now apply Qmult_nonneg_nonpos; [| apply Qlt_le_weak]. + rewrite H, Qmult_0_r in H2. exfalso; now apply (Qlt_irrefl 0). Qed. Lemma Qmult_pos_l : forall x y : Q, 0 <= y -> 0 < x * y -> 0 < x. Proof. intros x y H1 H2. rewrite Qmult_comm in H2. now apply (Qmult_pos_r y x). Qed. Lemma Qplus_lt_le_0_compat x y: 0 < x -> 0 <= y -> 0 < x + y. Proof with auto. unfold Qlt, Qle. simpl. repeat rewrite Zmult_1_r. intros. apply Z.add_pos_nonneg. apply Zmult_lt_0_compat... reflexivity. apply Zmult_le_0_compat... discriminate. Qed. Lemma Qplus_le_lt_0_compat x y: 0 <= x -> 0 < y -> 0 < x + y. Proof. rewrite Qplus_comm. intros. apply (Qplus_lt_le_0_compat y x); assumption. Qed. Lemma Qplus_nonneg (x y: Q): 0 <= x -> 0 <= y -> 0 <= x + y. Proof. intros. change (0 + 0 <= x + y). apply Qplus_le_compat; assumption. Qed. Lemma Qplus_pos_compat (x y : Q) : 0 < x -> 0 < y -> 0 < x + y. Proof. intros; apply Qplus_lt_le_0_compat; [| apply Qlt_le_weak]; trivial. Qed. Lemma Qminus_less (x y : Q) : 0 <= y -> x - y <= x. Proof. intro H. rewrite <- (Qplus_0_r x) at 2. apply Qplus_le_r. change 0 with (-0). now apply Qopp_le_compat. Qed. Lemma Qabs_Qle x y: (Qabs x <= y) <-> (-y <= x <= y). Proof with intuition. split. split. rewrite <- (Qopp_opp x). apply Qopp_le_compat. apply Qle_trans with (Qabs (-x)). apply Qle_Qabs. rewrite Qabs_opp... apply Qle_trans with (Qabs x)... apply Qle_Qabs. intros. apply Qabs_case... rewrite <- (Qopp_opp y). apply Qopp_le_compat... Qed. Lemma Qabs_diff_Qle x y r: (Qabs (x - y) <= r) <-> (x - r <= y <= x + r). Proof with try ring. intros. rewrite Qabs_Qle. rewrite <- (Qplus_le_r (r + y) (-r) (x- y)). rewrite <- (Qplus_le_r (y - r) (x-y) r). setoid_replace (r + y + -r) with y... setoid_replace (r + y + (x - y)) with (x + r)... setoid_replace (y - r + (x - y)) with (x - r)... setoid_replace (y - r + r) with y... intuition. Qed. Lemma Qabs_zero (x : Q) : Qabs x == 0 <-> x == 0. Proof. split; intro H; [| now rewrite H]. destruct (Q_dec x 0) as [[x_neg | x_pos] | x_zero]; [| | trivial]. + rewrite Qabs_neg in H; [| apply Qlt_le_weak; trivial]. now rewrite <- (Qopp_involutive x), H. + rewrite Qabs_pos in H; [| apply Qlt_le_weak]; trivial. Qed. Lemma Qabs_nonpos (x : Q) : Qabs x <= 0 -> x == 0. Proof. intro H. apply Qle_lteq in H. destruct H as [H | H]. + elim (Qlt_not_le _ _ H (Qabs_nonneg x)). + now apply Qabs_zero. Qed. Lemma Qabs_le_nonneg (x y : Q) : 0 <= x -> (Qabs x <= y <-> x <= y). Proof. intro A. rewrite Qabs_Qle_condition. split; [intros [_ ?]; trivial | intro A1; split; [| trivial]]. apply Qle_trans with (y := 0); [| trivial]. apply (Qopp_le_compat 0); eapply Qle_trans; eauto. Qed. Lemma Qdiv_le_1 (x y: Q): 0 <= x <= y -> x / y <= 1. Proof with intuition. intros. assert (0 <= y) as ynnP by (apply Qle_trans with x; intuition). destruct y. destruct Qnum. change (x * 0 <= 1). rewrite Qmult_0_r... rewrite <- (Qmult_inv_r (Zpos p # Qden)). unfold Qdiv. apply Qmult_le_compat_r... discriminate. exfalso. apply ynnP... Qed. (* The following two lemmas are obtained from the lemmas with the same name in Coq.QArith.QArith_base by replacing -> with <-> *) Lemma Qle_shift_div_l : forall a b c, 0 < c -> (a * c <= b <-> a <= b / c). Proof. intros a b c A; split; [now apply Qle_shift_div_l |]. intro A1. apply (Qmult_le_r _ _ (/c)); [now apply Qinv_lt_0_compat |]. rewrite <- Qmult_assoc, Qmult_inv_r; [now rewrite Qmult_1_r | auto with qarith]. Qed. Lemma Qle_shift_div_r : forall a b c, 0 < b -> (a <= c * b <-> a / b <= c). Proof. intros a b c A; split; [now apply Qle_shift_div_r |]. intro A1. apply (Qmult_le_r _ _ (/b)); [now apply Qinv_lt_0_compat |]. rewrite <- Qmult_assoc, Qmult_inv_r; [now rewrite Qmult_1_r | auto with qarith]. Qed. Lemma Qle_div_l : forall a b c, 0 < b -> 0 < c -> (a / b <= c <-> a / c <= b). Proof. intros a b c A1 A2. rewrite <- Qle_shift_div_r; [| easy]. rewrite (Qmult_comm c b). rewrite Qle_shift_div_r; easy. Qed. Lemma Qle_div_r : forall a b c, 0 < b -> 0 < c -> (b <= a / c <-> c <= a / b). Proof. intros a b c A1 A2. rewrite <- Qle_shift_div_l; [| easy]. rewrite (Qmult_comm b c). rewrite Qle_shift_div_l; easy. Qed. Lemma Qle_half (x : Q) : 0 <= x -> (1 # 2) * x <= x. Proof. intro H. rewrite <- (Qmult_1_l x) at 2. apply Qmult_le_compat_r; auto with qarith. Qed. Lemma nat_lt_Qlt n m: (n < m)%nat -> (inject_Z (Z_of_nat n) + (1#2) < inject_Z (Z_of_nat m))%Q. Proof with intuition. unfold lt. intros. apply Qlt_le_trans with (inject_Z (Z_of_nat n) + 1). do 2 rewrite (Qplus_comm (inject_Z (Z_of_nat n))). apply Qplus_lt_l... pose proof (inj_le _ _ H). rewrite Zle_Qle in H0. rewrite <- S_Qplus... Qed. Lemma inject_Z_nonneg (z: Z): (0 <= z)%Z -> 0 <= inject_Z z. Proof with auto. intro. change (inject_Z 0 <= inject_Z z). rewrite <- Zle_Qle. assumption. Qed. #[global] Hint Resolve inject_Z_nonneg. Lemma positive_in_Q (p: positive): 0 < inject_Z (Zpos p). Proof. change (inject_Z 0 < inject_Z (Zpos p)). rewrite <- Zlt_Qlt. reflexivity. Qed. #[global] Hint Immediate positive_in_Q. Lemma Qlt_Qceiling (q : Q) : inject_Z (Qceiling q) < q + 1. Proof. apply Qplus_lt_l with (z := (-1 # 1)). setoid_replace (q + 1 + (-1 # 1))%Q with q. + assert (A := Qceiling_lt q). unfold Z.sub in A. now rewrite inject_Z_plus, inject_Z_opp in A. + now rewrite <- Qplus_assoc, Qplus_opp_r, Qplus_0_r. Qed. Lemma Zle_Qle_Qceiling (q : Q) (z : Z) : (Qceiling q <= z)%Z <-> q <= inject_Z z. Proof. split; intro A. + rewrite Zle_Qle in A. apply Qle_trans with (y := inject_Z (Qceiling q)); [apply Qle_ceiling | trivial]. + apply Z.lt_pred_le. rewrite Zlt_Qlt. now apply Qlt_le_trans with (y := q); [apply Qceiling_lt |]. Qed. Lemma le_Qle_Qceiling_to_nat (q : Q) (n : nat) : (Z.to_nat (Qceiling q) <= n)%nat <-> q <= inject_Z (Z.of_nat n). Proof. rewrite Z.le_Zle_to_nat; apply Zle_Qle_Qceiling. Qed. Lemma Qlt_Zlt_inject_Z (q : Q) (z : Z) : inject_Z z < q <-> (z < Qceiling q)%Z. Proof. assert (A : forall (x y : Q), not (x <= y)%Q <-> (y < x)%Q). + intros; split; [apply Qnot_le_lt | apply Qlt_not_le]. + assert (A1 := Zle_Qle_Qceiling q z). apply Z.iff_not in A1. now rewrite A, Z.nle_gt in A1. Qed. Lemma Qlt_lt_of_nat_inject_Z (q : Q) (n : nat) : inject_Z (Z.of_nat n) < q <-> (n < Z.to_nat (Qceiling q))%nat. Proof. rewrite (Qlt_Zlt_inject_Z q (Z.of_nat n)); apply Z.lt_Zlt_to_nat. Qed. (** NoDup isn't /directly/ useful for Q because Q does not use a canonical representation and NoDup doesn't support setoid equalities such as Qeq. However, since we have Qred, which yields canonical representations, we can use: *) Definition QNoDup (l: list Q): Prop := NoDup (map Qred l). #[global] Instance: Proper (Qeq ==> eq) Qred. Proof. repeat intro. apply Qred_complete. assumption. Qed. Lemma Qsmallest_less_average : forall a b : Q, a < b -> a < (a + b) * (1#2). Proof. intros. apply (Qmult_lt_r _ _ (2#1)). reflexivity. rewrite <- Qmult_assoc, (Qmult_comm (1#2)), Qmult_inv_r . apply (Qplus_lt_l _ _ (-a)). ring_simplify. exact H. discriminate. Qed. Lemma Qaverage_less_greatest : forall a b : Q, a < b -> (a + b) * (1#2) < b. Proof. intros. apply (Qmult_lt_r _ _ (2#1)). reflexivity. rewrite <- Qmult_assoc, (Qmult_comm (1#2)), Qmult_inv_r . apply (Qplus_lt_l _ _ (-b)). ring_simplify. exact H. discriminate. Qed. corn-8.20.0/stdlib_omissions/Z.v000066400000000000000000000053461473720167500165520ustar00rootroot00000000000000 From Coq Require Import ZArith. Require Import CoRN.stdlib_omissions.P. From Coq Require Import Lia. (*Require Import NSigNAxioms. was added in the trunk branch*) Open Scope Z_scope. Lemma iff_not (P Q : Prop) : (P <-> Q) -> (not P <-> not Q). Proof. tauto. Qed. Definition nat_of_Z (x : Z) : nat := match x with | Z0 => O | Zpos p => nat_of_P p | Zneg p => O end. Lemma nat_of_Z_nonpos (x : Z) : x <= 0 -> nat_of_Z x = 0%nat. Proof. destruct x; simpl; try reflexivity. now intros []. Qed. Lemma nat_of_Z_nonneg (x : Z) : 0 <= x -> Z_of_nat (nat_of_Z x) = x. Proof. destruct x; simpl. reflexivity. intros. apply Z_of_nat_of_P. now intros []. Qed. Definition N_of_Z (x : Z) : N := match x with | Z0 => 0%N | Zpos p => Npos p | Zneg p => 0%N end. Lemma N_of_Z_nonpos (x : Z) : x <= 0 -> N_of_Z x = 0%N. Proof. destruct x; simpl; try reflexivity. now intros []. Qed. Lemma N_of_Z_nonneg (x : Z) : 0 <= x -> Z_of_N (N_of_Z x) = x. Proof. destruct x; simpl; try reflexivity. now intros []. Qed. (* Injection from nat preserves various operations: *) Lemma P_of_succ_nat_Zplus (m: nat): Zpos (P_of_succ_nat m) = Z_of_nat m + 1. Proof. destruct m. reflexivity. simpl. destruct (P_of_succ_nat m); reflexivity. Qed. Lemma S_Zplus (n: nat): (Z_of_nat (S n) = Z_of_nat n + 1)%Z. Proof. simpl Z_of_nat. rewrite P_of_succ_nat_Zplus. reflexivity. Qed. Lemma Zto_nat_nonpos (z : Z) : z <= 0 -> Z.to_nat z = 0%nat. Proof. intro A; destruct z as [| p | p]; trivial. unfold Z.le in A; now contradict A. Qed. Lemma Ple_Zle (p q: positive): Pos.le p q <-> (Zpos p <= Zpos q). Proof. rewrite Ple_le, inj_le_iff. do 2 rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. reflexivity. Qed. Lemma Ple_Zle_to_pos (z : Z) (p : positive) : (Z.to_pos z <= p)%positive <-> z <= Zpos p. Proof. destruct z as [| q | q]; simpl. + split; intros _; [apply Zle_0_pos | apply Pos.le_1_l]. + apply Ple_Zle. + split; intros _; [apply Zle_neg_pos | apply Pos.le_1_l]. Qed. Lemma le_Zle_to_nat (n : nat) (z : Z) : (Z.to_nat z <= n)%nat <-> z <= Z.of_nat n. Proof. pose proof (Nat.le_0_l n). pose proof (Zle_0_nat n). destruct (Z.neg_nonneg_cases z). + rewrite Zto_nat_nonpos by now apply Z.lt_le_incl. split; auto with zarith. + split; intro A. - apply inj_le in A. rewrite Z2Nat.id in A; trivial. - apply Z2Nat.inj_le in A; trivial. rewrite Nat2Z.id in A; trivial. Qed. Lemma lt_Zlt_to_nat (n : nat) (z : Z) : Z.of_nat n < z <-> (n < Z.to_nat z)%nat. Proof. assert (A : forall (m n : nat), not (m <= n)%nat <-> (n < m)%nat). + intros; split; [apply not_le | apply Nat.lt_nge]. + assert (A1 := le_Zle_to_nat n z). apply iff_not in A1. now rewrite A, Z.nle_gt in A1. Qed. Lemma add_pos_nonneg (a b: Z): 0 < a -> 0 <= b -> 0 < a+b. Proof. intros. lia. Qed. corn-8.20.0/tactics/000077500000000000000000000000001473720167500142105ustar00rootroot00000000000000corn-8.20.0/tactics/AlgReflection.v000066400000000000000000000415611473720167500171240ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.logic.CLogic. Require Export Coq.Bool.Bool. Section Syntactic_Expressions. Definition varindex : Set := nat. Definition pfunindex : Set := nat. Definition unopindex : Set := nat. Definition binopindex : Set := nat. Inductive expr : Set := | expr_var : varindex -> expr | expr_int : Z -> expr | expr_plus : expr -> expr -> expr | expr_mult : expr -> expr -> expr | expr_div : expr -> expr -> expr | expr_unop : unopindex -> expr -> expr | expr_binop : binopindex -> expr -> expr -> expr | expr_part : pfunindex -> expr -> expr. Definition expr_zero : expr := expr_int 0. Definition expr_one : expr := expr_int 1. Definition expr_nat (n:nat) : expr := expr_int (Z_of_nat n). Definition expr_inv (e:expr) : expr := expr_mult e (expr_int (-1)). Definition expr_minus (e e':expr) : expr := expr_plus e (expr_inv e'). Fixpoint expr_power (n:nat) (e:expr) {struct n} : expr := match n with | O => expr_one | S m => expr_mult e (expr_power m e) end. End Syntactic_Expressions. Section Normalization_Function. Fixpoint eq_nat (n m:nat) {struct n} : bool := match n, m with | S n', S m' => eq_nat n' m' | O, O => true | _, _ => false end. Fixpoint lt_nat (n m:nat) {struct n} : bool := match n, m with | S n', S m' => lt_nat n' m' | O, S _ => true | _, _ => false end. Definition le_nat (n m:nat) := orb (eq_nat n m) (lt_nat n m). Definition eq_int (z z':Z) : bool := match z, z' with | Zpos n, Zpos m => eq_nat (nat_of_P n) (nat_of_P m) | Z0, Z0 => true | Zneg n, Zneg m => eq_nat (nat_of_P n) (nat_of_P m) | _, _ => false end. Definition lt_int (z z':Z) : bool := match z, z' with | Zpos n, Zpos m => lt_nat (nat_of_P n) (nat_of_P m) | Zpos n, _ => false | Z0, Zpos n => true | Z0, _ => false | Zneg n, Zneg m => lt_nat (nat_of_P m) (nat_of_P n) | Zneg n, _ => true end. Definition le_int (z z':Z) := orb (eq_int z z') (lt_int z z'). Fixpoint eq_expr (e f:expr) {struct e} : bool := match e, f with | expr_var n, expr_var m => eq_nat n m | expr_int z, expr_int z' => eq_int z z' | expr_plus e1 e2, expr_plus f1 f2 => andb (eq_expr e1 f1) (eq_expr e2 f2) | expr_mult e1 e2, expr_mult f1 f2 => andb (eq_expr e1 f1) (eq_expr e2 f2) | expr_div e1 e2, expr_div f1 f2 => andb (eq_expr e1 f1) (eq_expr e2 f2) | expr_unop n e', expr_unop m f' => andb (eq_nat n m) (eq_expr e' f') | expr_binop n e' e'', expr_binop m f' f'' => andb (eq_nat n m) (andb (eq_expr e' f') (eq_expr e'' f'')) | expr_part n e', expr_part m f' => andb (eq_nat n m) (eq_expr e' f') | _, _ => false end. Fixpoint lt_expr (e f:expr) {struct e} : bool := match e, f with | expr_var n, expr_var m => lt_nat n m | expr_var n, _ => true | _, expr_var n => false | expr_int z, expr_int z' => lt_int z z' | expr_int _, _ => true | _, expr_int _ => false | expr_plus e1 e2, expr_plus f1 f2 => orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2)) | expr_plus _ _, _ => true | _, expr_plus _ _ => false | expr_mult e1 e2, expr_mult f1 f2 => orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2)) | expr_mult _ _, _ => true | _, expr_mult _ _ => false | expr_div e1 e2, expr_div f1 f2 => orb (lt_expr e1 f1) (andb (eq_expr e1 f1) (lt_expr e2 f2)) | expr_div _ _, _ => true | _, expr_div _ _ => false | expr_unop n e', expr_unop m f' => orb (lt_nat n m) (andb (eq_nat n m) (lt_expr e' f')) | expr_unop _ _, _ => true | _, expr_unop _ _ => false | expr_binop n e' e'', expr_binop m f' f'' => orb (lt_nat n m) (orb (andb (eq_nat n m) (lt_expr e' f')) (andb (eq_nat n m) (andb (eq_expr e' f') (lt_expr e'' f'')))) | expr_binop _ _ _, _ => true | _, expr_binop _ _ _ => false | expr_part n e', expr_part m f' => orb (lt_nat n m) (andb (eq_nat n m) (lt_expr e' f')) end. Definition le_expr (e f:expr) := orb (eq_expr e f) (lt_expr e f). Fixpoint eq_monom (e f:expr) {struct e} : bool := match e, f with | expr_mult (expr_var n) e', expr_mult (expr_var m) f' => andb (eq_nat n m) (eq_monom e' f') | expr_mult (expr_unop n e1) e', expr_mult (expr_unop m f1) f' => andb (eq_nat n m) (andb (eq_monom e' f') (eq_expr e1 f1)) | expr_mult (expr_binop n e1 e2) e', expr_mult (expr_binop m f1 f2) f' => andb (eq_nat n m) (andb (eq_monom e' f') (andb (eq_expr e1 f1) (eq_expr e2 f2))) | expr_mult (expr_part n e1) e', expr_mult (expr_part m f1) f' => andb (eq_nat n m) (andb (eq_monom e' f') (eq_expr e1 f1)) | expr_int _, expr_int _ => true | _, _ => false end. Fixpoint lt_monom (e f:expr) {struct e} : bool := match e, f with | expr_mult (expr_var n) e', expr_mult (expr_var m) f' => ifb (eq_nat n m) (lt_monom e' f') (lt_nat n m) | expr_mult (expr_var _) _, expr_mult (expr_unop _ _) _ => true | expr_mult (expr_var _) _, expr_mult (expr_binop _ _ _) _ => true | expr_mult (expr_var _) _, expr_mult (expr_part _ _) _ => true | expr_mult (expr_unop n e1) e', expr_mult (expr_unop m f1) f' => ifb (eq_expr (expr_unop n e1) (expr_unop m f1)) ( lt_expr e' f') (lt_expr (expr_unop n e1) (expr_unop m f1)) | expr_mult (expr_unop _ _) _, expr_mult (expr_binop _ _ _) _ => true | expr_mult (expr_unop _ _) _, expr_mult (expr_part _ _) _ => true | expr_mult (expr_binop n e1 e2) e', expr_mult (expr_binop m f1 f2) f' => ifb (eq_expr (expr_binop n e1 e2) (expr_binop m f1 f2)) ( lt_expr e' f') (lt_expr (expr_binop n e1 e2) (expr_binop m f1 f2)) | expr_mult (expr_binop _ _ _) _, expr_mult (expr_part _ _) _ => true | expr_mult (expr_part n e1) e', expr_mult (expr_part m f1) f' => ifb (eq_expr (expr_part n e1) (expr_part m f1)) ( lt_expr e' f') (lt_expr (expr_part n e1) (expr_part m f1)) | _, expr_int _ => true | _, _ => false end. Fixpoint MI_mult (e f:expr) {struct e} : expr := let d := expr_mult e f in match e, f with | e, expr_int Z0 => expr_int 0 | expr_mult e1 e2, f => expr_mult e1 (MI_mult e2 f) | expr_int i, expr_int j => expr_int (i * j) | _, _ => d end. Fixpoint MV_mult (e f:expr) {struct e} : expr := let d := expr_mult e f in match e, f with | expr_mult (expr_var n) e', expr_var m => match lt_nat n m with | true => expr_mult (expr_var n) (MV_mult e' f) | false => expr_mult f e end | expr_mult (expr_var n) e', expr_unop _ _ => expr_mult (expr_var n) (MV_mult e' f) | expr_mult (expr_var n) e', expr_binop _ _ _ => expr_mult (expr_var n) (MV_mult e' f) | expr_mult (expr_var n) e', expr_part _ _ => expr_mult (expr_var n) (MV_mult e' f) | expr_mult (expr_unop _ _) e', expr_var _ => expr_mult f e | expr_mult (expr_unop n e') e0, expr_unop m f' => match lt_expr (expr_unop n e') f with | true => expr_mult (expr_unop n e') (MV_mult e0 f) | false => expr_mult f e end | expr_mult (expr_unop n e1) e', expr_binop _ _ _ => expr_mult (expr_unop n e1) (MV_mult e' f) | expr_mult (expr_unop n e1) e', expr_part _ _ => expr_mult (expr_unop n e1) (MV_mult e' f) | expr_mult (expr_binop _ _ _) e', expr_var _ => expr_mult f e | expr_mult (expr_binop _ _ _) e', expr_unop _ _ => expr_mult f e | expr_mult (expr_binop n e' e'') e0, expr_binop m f' f'' => match lt_expr (expr_binop n e' e'') f with | true => expr_mult (expr_binop n e' e'') (MV_mult e0 f) | false => expr_mult f e end | expr_mult (expr_binop n e1 e2) e', expr_part _ _ => expr_mult (expr_binop n e1 e2) (MV_mult e' f) | expr_mult (expr_part _ _) e', expr_var _ => expr_mult f e | expr_mult (expr_part _ _) e', expr_unop _ _ => expr_mult f e | expr_mult (expr_part _ _) e', expr_binop _ _ _ => expr_mult f e | expr_mult (expr_part n e') e0, expr_part m f' => match lt_expr (expr_part n e') f with | true => expr_mult (expr_part n e') (MV_mult e0 f) | false => expr_mult f e end | expr_int i, f => MI_mult (expr_mult f expr_one) e | _, _ => d end. Fixpoint MM_mult (e f:expr) {struct e} : expr := let d := expr_mult e f in match e, f with | expr_mult e1 e2, f => MV_mult (MM_mult e2 f) e1 | expr_int i, f => MI_mult f e | _, _ => d end. Fixpoint MM_plus (e f:expr) {struct e} : expr := let d := expr_plus e f in match e, f with | expr_mult (expr_var n) e', expr_mult (expr_var m) f' => match eq_nat n m with | true => MV_mult (MM_plus e' f') (expr_var n) | false => d end | expr_mult (expr_unop g arg) e', expr_mult (expr_unop h arg') f' => match eq_expr (expr_unop g arg) (expr_unop h arg') with | true => MV_mult (MM_plus e' f') (expr_unop g arg) | false => d end | expr_mult (expr_binop g e1 e2) e', expr_mult (expr_binop h f1 f2) f' => match eq_expr (expr_binop g e1 e2) (expr_binop h f1 f2) with | true => MV_mult (MM_plus e' f') (expr_binop g e1 e2) | false => d end | expr_mult (expr_part g arg) e', expr_mult (expr_part h arg') f' => match andb (eq_nat g h) (eq_expr arg arg') with | true => MV_mult (MM_plus e' f') (expr_part g arg) | false => d end | expr_int i, expr_int j => expr_int (i + j) | _, _ => d end. Fixpoint PM_plus (e f:expr) {struct e} : expr := let d := expr_plus e f in match e, f with | expr_plus e1 e2, expr_int _ => expr_plus e1 (PM_plus e2 f) | expr_int i, expr_int j => MM_plus e f | expr_plus e1 e2, f => match eq_monom e1 f with | true => PM_plus e2 (MM_plus e1 f) | false => match lt_monom e1 f with | true => expr_plus e1 (PM_plus e2 f) | false => expr_plus f e end end | expr_int i, f => expr_plus f e | _, _ => d end. Fixpoint PP_plus (e f:expr) {struct e} : expr := let d := expr_plus e f in match e, f with | expr_plus e1 e2, f => PM_plus (PP_plus e2 f) e1 | expr_int i, f => PM_plus f e | _, _ => d end. Fixpoint PM_mult (e f:expr) {struct e} : expr := let d := expr_mult e f in match e, f with | expr_plus e1 e2, f => PM_plus (PM_mult e2 f) (MM_mult e1 f) | expr_int i, _ => PM_plus (expr_int 0) (MI_mult f e) | _, _ => d end. Fixpoint PP_mult (e f:expr) {struct e} : expr := let d := expr_mult e f in match e, f with | expr_plus e1 e2, f => PP_plus (PM_mult f e1) (PP_mult e2 f) | expr_int i, f => PM_mult f e | _, _ => d end. Definition FF_plus (e f:expr) : expr := let d := expr_plus e f in match e, f with | expr_div e1 e2, expr_div f1 f2 => expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1)) (PP_mult e2 f2) | _, _ => d end. Definition FF_mult (e f:expr) : expr := let d := expr_mult e f in match e, f with | expr_div e1 e2, expr_div f1 f2 => expr_div (PP_mult e1 f1) (PP_mult e2 f2) | _, _ => d end. Definition FF_div (e f:expr) : expr := let d := expr_div e f in match e, f with | expr_div e1 e2, expr_div f1 f2 => expr_div (PP_mult e1 f2) (PP_mult e2 f1) | _, _ => d end. Fixpoint NormR (e:expr) : expr := match e with | expr_var n => expr_plus (expr_mult e expr_one) expr_zero | expr_int i => e | expr_plus e1 e2 => PP_plus (NormR e1) (NormR e2) | expr_mult e1 e2 => PP_mult (NormR e1) (NormR e2) | expr_div e1 e2 => e | expr_unop f e => expr_plus (expr_mult (expr_unop f (NormR e)) expr_one) expr_zero | expr_binop f e e' => expr_plus (expr_mult (expr_binop f (NormR e) (NormR e')) expr_one) expr_zero | expr_part f e => expr_plus (expr_mult (expr_part f (NormR e)) expr_one) expr_zero end. Definition NormG := NormR. Fixpoint NormF (e:expr) : expr := match e with | expr_var n => expr_div (expr_plus (expr_mult e expr_one) expr_zero) expr_one | expr_int i => expr_div e expr_one | expr_plus e1 e2 => FF_plus (NormF e1) (NormF e2) | expr_mult e1 e2 => FF_mult (NormF e1) (NormF e2) | expr_div e1 e2 => FF_div (NormF e1) (NormF e2) | expr_unop f e => expr_div (expr_plus (expr_mult (expr_unop f (NormF e)) expr_one) expr_zero) expr_one | expr_binop f e e' => expr_div (expr_plus (expr_mult (expr_binop f (NormF e) (NormF e')) expr_one) expr_zero) expr_one | expr_part f e => expr_div (expr_plus (expr_mult (expr_part f (NormF e)) expr_one) expr_zero) expr_one end. Definition expr_is_zero (e:expr) : bool := match e with | expr_div (expr_int Z0) _ => true | _ => false end. End Normalization_Function. Section Correctness_Results. Lemma eq_nat_corr : forall n m:nat, eq_nat n m = true -> n = m. Proof. simple induction n; simple induction m; simpl in |- *; intros. trivial. inversion H0. inversion H0. rewrite (H n1 H1). trivial. Qed. Lemma eq_int_corr : forall n m:Z, eq_int n m = true -> n = m. Proof. simple induction n; simple induction m; simpl in |- *; intros. trivial. inversion H. inversion H. inversion H. rewrite <- (convert_is_POS p). rewrite <- (convert_is_POS p0). cut (nat_of_P p = nat_of_P p0). auto. apply eq_nat_corr. assumption. inversion H. inversion H. inversion H. cut (p = p0); intros. rewrite H0; auto. rewrite (anti_convert_pred_convert p). rewrite (anti_convert_pred_convert p0). cut (nat_of_P p = nat_of_P p0). intro. auto. apply eq_nat_corr. assumption. Qed. Lemma eq_expr_corr : forall e e':expr, eq_expr e e' = true -> e = e'. Proof. simple induction e; simple induction e'; simpl in |- *; intros; try inversion H3; try inversion H2; try inversion H1; try inversion H0; try inversion H. cut (v = v0). intro. rewrite H0; auto. apply eq_nat_corr; assumption. cut (z = z0). intro. rewrite H0; auto. apply eq_int_corr; assumption. clear H1 H2. elim (andb_prop _ _ H3); intros. cut (e0 = e2). cut (e1 = e3). intros. rewrite H4; rewrite H6. auto. apply H0. assumption. apply H. assumption. clear H1 H2. elim (andb_prop _ _ H3); intros. cut (e0 = e2). cut (e1 = e3). intros. rewrite H4; rewrite H6. auto. apply H0. assumption. apply H. assumption. clear H1 H2. elim (andb_prop _ _ H3); intros. cut (e0 = e2). cut (e1 = e3). intros. rewrite H4; rewrite H6. auto. apply H0. assumption. apply H. assumption. clear H0. elim (andb_prop _ _ H1); intros. cut (u = u0). cut (e0 = e1). intros. rewrite H4. rewrite H5. auto. apply H. assumption. apply eq_nat_corr. assumption. clear H1 H2. elim (andb_prop _ _ H3). intros. elim (andb_prop _ _ H2); intros. cut (b = b0). cut (e0 = e2). cut (e1 = e3). intros. rewrite H7. rewrite H8. rewrite H9. auto. auto. auto. apply eq_nat_corr. assumption. clear H0. elim (andb_prop _ _ H1); intros. cut (p = p0). cut (e0 = e1). intros. rewrite H4. rewrite H5. auto. auto. apply eq_nat_corr. assumption. Qed. End Correctness_Results. Ltac ClosedNat t := match t with | O => constr:(true) | (S ?n) => ClosedNat n | _ => constr:(false) end. Ltac ClosedPositive t := match t with | xH => constr:(true) | (xI ?n) => ClosedPositive n | (xO ?n) => ClosedPositive n | _ => constr:(false) end. Ltac ClosedZ t := match t with | Z0 => constr:(true) | (Zpos ?n) => ClosedPositive n | (Zneg ?n) => ClosedPositive n | _ => constr:(false) end. (*To prevent universe inconsitencies, we need lists at a higher type level than the one provided in algebra/ListType *) Section MetaList. Variable A : Type. Inductive metalist : Type := | Mnil : metalist | Mcons : A -> metalist -> metalist. Fixpoint Mnth (n:nat) (l:metalist) (default:A) {struct l} : A := match n, l with | O, Mcons x l' => x | O, other => default | S m, Mnil => default | S m, Mcons x t => Mnth m t default end. End MetaList. Arguments Mcons [A]. Arguments Mnth [A]. Ltac FindIndex t l := match l with | (Mcons ?x ?xs) => match x with | t => constr:(O) | _ => let n := FindIndex t xs in constr:(S n) end end. (*To prevent universe inconsitencies, we define quadruple, rather than using the ProdT multiple times *) Section Quadruple. Variable A B C D: Type. Inductive quadruple : Type := Quad : A -> B -> C -> D -> quadruple. End Quadruple. Arguments Quad [A B C D]. (* end hide *) corn-8.20.0/tactics/CornTac.v000066400000000000000000000036331473720167500157350ustar00rootroot00000000000000(* Copyright © 2006 * Russell O’Connor * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** Generic Tacticals used by the CoRN project *) (* begin hide *) Require Import Coq.Classes.SetoidTactics. (* Replace the LHS or RHS of an expression with another expression This tactic along with the setiod functionality, basically replaces the step tactic *) Tactic Notation "replace" "LHS" "with" constr (a) "by" tactic (t) := match goal with | |-(?r ?b ?c) => let Z := fresh "Z" in (change (let Z:=b in r Z c);intro Z;setoid_replace Z with a; [unfold Z; clear Z|unfold Z; clear Z; solve [ t ]]) end. Tactic Notation "replace" "LHS" "with" constr (a) := match goal with | |-(?r ?b ?c) => let Z := fresh "Z" in (change (let Z:=b in r Z c);intro Z;setoid_replace Z with a; unfold Z; clear Z) end. Tactic Notation "replace" "RHS" "with" constr (a) "by" tactic (t) := match goal with | |-(?r ?b ?c) => let Z := fresh "Z" in (change (let Z:=c in r b Z);intro Z;setoid_replace Z with a; [unfold Z; clear Z|unfold Z; clear Z; solve [ t ]]) end. Tactic Notation "replace" "RHS" "with" constr (a) := match goal with | |-(?r ?b ?c) => let Z := fresh "Z" in (change (let Z:=c in r b Z);intro Z;setoid_replace Z with a; unfold Z; clear Z) end. (*end hide*) corn-8.20.0/tactics/DiffTactics1.v000066400000000000000000000026471473720167500166540ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Ltac Contin := auto with continuous included. Ltac Deriv := eauto with derivate continuous included. (* end hide *) (** * Search tactics for reasoning in Real Analysis The following tactics are defined: - [Contin] will solve [(Continuous_I H F)] - [Deriv] will solve [(Derivative_I H F F')]. All these tactics are defined using [eauto]. *) corn-8.20.0/tactics/DiffTactics2.v000066400000000000000000000274361473720167500166600ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.ftc.Differentiability. Section Automatizing_Continuity. Variables a b : IR. Inductive cont_function : Type := | hyp_c : forall Hab (F : PartIR), Continuous_I (a:=a) (b:=b) Hab F -> cont_function | hyp_d : forall Hab' (F F' : PartIR), Derivative_I (a:=a) (b:=b) Hab' F F' -> cont_function | hyp_d' : forall Hab' (F F' : PartIR), Derivative_I (a:=a) (b:=b) Hab' F F' -> cont_function | hyp_diff : forall Hab' (F : PartIR), Diffble_I (a:=a) (b:=b) Hab' F -> cont_function | cconst : forall c : IR, cont_function | cid : cont_function | cplus : cont_function -> cont_function -> cont_function | cinv : cont_function -> cont_function | cminus : cont_function -> cont_function -> cont_function | cmult : cont_function -> cont_function -> cont_function | cscalmult : IR -> cont_function -> cont_function | cnth : cont_function -> nat -> cont_function | cabs : cont_function -> cont_function. Fixpoint cont_to_pfunct (r : cont_function) : PartIR := match r with | hyp_c Hab F H => F | hyp_d Hab F F' H => F | hyp_d' Hab F F' H => F' | hyp_diff Hab F H => F | cconst c => [-C-]c | cid => FId | cplus f g => cont_to_pfunct f{+}cont_to_pfunct g | cinv f => {--}(cont_to_pfunct f) | cminus f g => cont_to_pfunct f{-}cont_to_pfunct g | cmult f g => cont_to_pfunct f{*}cont_to_pfunct g | cscalmult c f => c{**}cont_to_pfunct f | cnth f n => cont_to_pfunct f{^}n | cabs f => FAbs (cont_to_pfunct f) end. Lemma continuous_cont : forall Hab (f : cont_function), Continuous_I (a:=a) (b:=b) Hab (cont_to_pfunct f). Proof. intros. induction f as [Hab0 F c| Hab' F F' d| Hab' F F' d| Hab' F d| c| | f1 Hrecf1 f0 Hrecf0| f Hrecf| f1 Hrecf1 f0 Hrecf0| f1 Hrecf1 f0 Hrecf0| c f Hrecf| f Hrecf n| f Hrecf]; simpl in |- *; intros. assumption. exact (deriv_imp_contin_I _ _ _ _ _ _ d). exact (deriv_imp_contin'_I _ _ _ _ _ _ d). exact (diffble_imp_contin_I _ _ _ _ _ d). exact (Continuous_I_const _ _ _ c). exact (Continuous_I_id _ _ _). exact (Continuous_I_plus _ _ _ _ _ Hrecf1 Hrecf0). exact (Continuous_I_inv _ _ _ _ Hrecf). exact (Continuous_I_minus _ _ _ _ _ Hrecf1 Hrecf0). exact (Continuous_I_mult _ _ _ _ _ Hrecf1 Hrecf0). exact (Continuous_I_scal _ _ _ _ Hrecf _). exact (Continuous_I_nth _ _ _ _ Hrecf _). exact (Continuous_I_abs _ _ _ _ Hrecf). Qed. End Automatizing_Continuity. Ltac pfunct_to_cont a b f := match constr:(f) with | ([-C-]?X3) => constr:(cconst a b X3) | FId => constr:(cid a b) | (?X3{+}?X4) => let t1 := pfunct_to_cont a b X3 with t2 := pfunct_to_cont a b X4 in constr:(cplus a b t1 t2) | ({--}?X3) => let t1 := pfunct_to_cont a b X3 in constr:(cinv a b t1) | (?X3{-}?X4) => let t1 := pfunct_to_cont a b X3 with t2 := pfunct_to_cont a b X4 in constr:(cminus a b t1 t2) | (?X3{*}?X4) => let t1 := pfunct_to_cont a b X3 with t2 := pfunct_to_cont a b X4 in constr:(cmult a b t1 t2) | (?X3{**}?X4) => let t := pfunct_to_cont a b X4 in constr:(cscalmult a b X3 t) | (?X3{^}?X4) => let t1 := pfunct_to_cont a b X3 in constr:(cnth a b t1 X4) | (FAbs ?X3) => let t1 := pfunct_to_cont a b X3 in constr:(cabs a b t1) | ?X3 => let t := constr:(X3) in match goal with | Hab:_,H:(Continuous_I (a:=a) (b:=b) ?X1 t) |- _ => constr:(hyp_c a b X1 t H) | H:(Derivative_I (a:=a) (b:=b) ?X1 t ?X4) |- _ => constr:(hyp_d a b X1 t X4 H) | H:(Derivative_I (a:=a) (b:=b) ?X1 ?X4 t) |- _ => constr:(hyp_d' a b X1 X4 t H) | H:(Diffble_I (a:=a) (b:=b) ?X1 t) |- _ => constr:(hyp_diff a b X1 t H) end end. Ltac New_Contin := match goal with | |- (Continuous_I (a:=?X1) (b:=?X2) ?X4 ?X3) => let r := pfunct_to_cont X1 X2 X3 in let a := constr:(X1) in let b := constr:(X2) in (apply Continuous_I_wd with (cont_to_pfunct a b r); [ unfold cont_to_pfunct in |- * | apply continuous_cont ]) end. Section Automatizing_Derivatives. Variables a b : IR. Inductive deriv_function : Type := | hyp : forall Hab' (f f' : PartIR), Derivative_I (a:=a) (b:=b) Hab' f f' -> deriv_function | hyp' : forall Hab' (f : PartIR), Diffble_I (a:=a) (b:=b) Hab' f -> deriv_function | const : forall c : IR, deriv_function | id : deriv_function | rplus : deriv_function -> deriv_function -> deriv_function | rinv : deriv_function -> deriv_function | rminus : deriv_function -> deriv_function -> deriv_function | rmult : deriv_function -> deriv_function -> deriv_function | rscalmult : IR -> deriv_function -> deriv_function | rnth : deriv_function -> nat -> deriv_function. Fixpoint deriv_to_pfunct (r : deriv_function) : PartIR := match r with | hyp Hab' f f' H => f | hyp' Hab' f H => f | const c => [-C-]c | id => FId | rplus f g => deriv_to_pfunct f{+}deriv_to_pfunct g | rinv f => {--}(deriv_to_pfunct f) | rminus f g => deriv_to_pfunct f{-}deriv_to_pfunct g | rmult f g => deriv_to_pfunct f{*}deriv_to_pfunct g | rscalmult c f => c{**}deriv_to_pfunct f | rnth f n => deriv_to_pfunct f{^}n end. Fixpoint deriv_deriv (r : deriv_function) : PartIR := match r with | hyp Hab' f f' H => f' | hyp' Hab' f H => PartInt (ProjT1 H) | const c => [-C-][0] | id => [-C-][1] | rplus f g => deriv_deriv f{+}deriv_deriv g | rinv f => {--}(deriv_deriv f) | rminus f g => deriv_deriv f{-}deriv_deriv g | rmult f g => deriv_to_pfunct f{*}deriv_deriv g{+}deriv_deriv f{*}deriv_to_pfunct g | rscalmult c f => c{**}deriv_deriv f | rnth f n => match n with | O => [-C-][0] | S p => [-C-](nring (S p)){*}(deriv_deriv f{*}deriv_to_pfunct (rnth f p)) end end. Lemma deriv_restr : forall Hab' (f : deriv_function), Derivative_I (a:=a) (b:=b) Hab' (deriv_to_pfunct f) (deriv_deriv f). Proof. intros. induction f as [Hab'0 f f' d| Hab'0 f d| c| | f1 Hrecf1 f0 Hrecf0| f Hrecf| f1 Hrecf1 f0 Hrecf0| f1 Hrecf1 f0 Hrecf0| c f Hrecf| f Hrecf n]; simpl in |- *. assumption. apply projT2. exact (Derivative_I_const _ _ Hab' c). exact (Derivative_I_id _ _ Hab'). exact (Derivative_I_plus _ _ _ _ _ _ _ Hrecf1 Hrecf0). exact (Derivative_I_inv _ _ _ _ _ Hrecf). exact (Derivative_I_minus _ _ _ _ _ _ _ Hrecf1 Hrecf0). exact (Derivative_I_mult _ _ _ _ _ _ _ Hrecf1 Hrecf0). exact (Derivative_I_scal _ _ _ _ _ Hrecf _). case n. apply Derivative_I_wdl with (Fconst (S:=IR) [1]). apply FNth_zero'. exact (derivative_imp_inc _ _ _ _ _ Hrecf). exact (Derivative_I_const _ _ Hab' _). clear n; intro. exact (Derivative_I_nth _ _ _ _ _ Hrecf n). Qed. Lemma diffble_restr : forall Hab' (f : deriv_function), Diffble_I (a:=a) (b:=b) Hab' (deriv_to_pfunct f). Proof. intros. induction f as [Hab'0 f f' d| Hab'0 f d| c| | f1 Hrecf1 f0 Hrecf0| f Hrecf| f1 Hrecf1 f0 Hrecf0| f1 Hrecf1 f0 Hrecf0| c f Hrecf| f Hrecf n]; simpl in |- *. apply deriv_imp_Diffble_I with f'; assumption. assumption. exact (Diffble_I_const _ _ Hab' c). exact (Diffble_I_id _ _ Hab'). exact (Diffble_I_plus _ _ _ _ _ Hrecf1 Hrecf0). exact (Diffble_I_inv _ _ _ _ Hrecf). exact (Diffble_I_minus _ _ _ _ _ Hrecf1 Hrecf0). exact (Diffble_I_mult _ _ _ _ _ Hrecf1 Hrecf0). exact (Diffble_I_scal _ _ _ _ Hrecf _). exact (Diffble_I_nth _ _ _ _ Hrecf n). Qed. End Automatizing_Derivatives. Ltac pfunct_to_restr a b f := match constr:(f) with | ([-C-]?X3) => constr:(const a b X3) | FId => constr:(id a b) | (?X3{+}?X4) => let t1 := pfunct_to_restr a b X3 with t2 := pfunct_to_restr a b X4 in constr:(rplus a b t1 t2) | ({--}?X3) => let t1 := pfunct_to_restr a b X3 in constr:(rinv a b t1) | (?X3{-}?X4) => let t1 := pfunct_to_restr a b X3 with t2 := pfunct_to_restr a b X4 in constr:(rminus a b t1 t2) | (?X3{*}?X4) => let t1 := pfunct_to_restr a b X3 with t2 := pfunct_to_restr a b X4 in constr:(rmult a b t1 t2) | (?X3{**}?X4) => let t := pfunct_to_restr a b X4 in constr:(rscalmult a b X3 t) | (?X3{^}?X4) => let t1 := pfunct_to_restr a b X3 in constr:(rnth a b t1 X4) | ?X3 => let t := constr:(X3) in match goal with | H:(Derivative_I (a:=a) (b:=b) ?X1 t ?X4) |- _ => constr:(hyp a b X1 t X4 H) | H:(Diffble_I (a:=a) (b:=b) ?X1 t) |- _ => constr:( hyp' a b X1 t H) end end. Ltac New_Deriv := match goal with | |- (Derivative_I (a:=?X1) (b:=?X2) _ ?X3 ?X4) => let r := pfunct_to_restr X1 X2 X3 in (apply Derivative_I_wdl with (deriv_to_pfunct X1 X2 r); [ unfold deriv_to_pfunct in |- * | apply Derivative_I_wdr with (deriv_deriv X1 X2 r); [ unfold deriv_deriv, deriv_to_pfunct in |- * | apply deriv_restr ] ]) end. Ltac Differentiate := match goal with | |- (Diffble_I (a:=?X1) (b:=?X2) _ ?X3) => let r := pfunct_to_restr X1 X2 X3 in (apply Diffble_I_wd with (deriv_to_pfunct X1 X2 r); [ apply diffble_restr | unfold deriv_deriv, deriv_to_pfunct in |- * ]) end. Ltac derivative_of f := match constr:(f) with | ([-C-]?X3) => constr:([-C-]ZeroR) | FId => constr:([-C-]OneR) | (?X3{+}?X4) => let t1 := derivative_of X3 with t2 := derivative_of X4 in constr:(t1{+}t2) | ({--}?X3) => let t1 := derivative_of X3 in constr:({--}t1) | (?X3{-}?X4) => let t1 := derivative_of X3 with t2 := derivative_of X4 in constr:(t1{-}t2) | (?X3{*}?X4) => let t1 := derivative_of X3 with t2 := derivative_of X4 with t3 := constr:(X3) with t4 := constr:(X4) in constr:(t3{*}t2{+}t1{*}t4) | (?X3{**}?X4) => let t1 := derivative_of X4 with t2 := constr:(X3) in constr:(t2{**}t1) | (?X3{^}0) => constr:([-C-]ZeroR) | (?X3{^}S ?X4) => let t1 := derivative_of X3 with t2 := constr:(X3) with t3 := constr:(X4) in constr:(nring _ (S t3){**}(t1{*}t2{^}t3)) | ({1/}?X3) => let t1 := derivative_of X3 with t2 := constr:(X3) in constr:({--}(t1{/}t2{*}t2)) | (?X3{/}?X4) => let t1 := derivative_of X3 with t2 := derivative_of X4 with t3 := constr:(X3) with t4 := constr:(X4) in constr:((t1{*}t4{-}t3{*}t2){/}t4{*}t4) | (?X3[o]?X4) => let t1 := derivative_of X3 with t2 := derivative_of X4 with t3 := constr:(X3) in constr:((t3[o]t2){*}t1) | ?X3 => let t := constr:(X3) in match goal with | H:(Derivative_I (b:=t) ?X4) |- _ => let t1 := constr:(X4) in constr:(t1) end end. Ltac Deriv_I_substR := match goal with | |- (Derivative_I _ ?X1 _) => let t := derivative_of X1 in apply Derivative_I_wdr with t end. (* end hide *) corn-8.20.0/tactics/DiffTactics3.v000066400000000000000000000130021473720167500166410ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.ftc.MoreFunSeries. Require Export CoRN.ftc.Composition. Require Export CoRN.tactics.DiffTactics2. Ltac Deriv_substR := match goal with | |- (Derivative ?X1 _) => let t := derivative_of X1 in apply Derivative_wdr with t end. Inductive symbPF : Type := | shyp : forall (I : interval) (pI : proper I) (F F' : PartIR), Derivative I pI F F' -> symbPF | shyp' : forall (I : interval) (pI : proper I) (F : PartIR), Diffble I pI F -> symbPF | sconst : forall c : IR, symbPF | sid : symbPF | splus : symbPF -> symbPF -> symbPF | sinv : symbPF -> symbPF | sminus : symbPF -> symbPF -> symbPF | smult : symbPF -> symbPF -> symbPF | sscalmult : IR -> symbPF -> symbPF | snth : symbPF -> nat -> symbPF | srecip : symbPF -> symbPF | sdiv : symbPF -> symbPF -> symbPF | scomp : symbPF -> symbPF -> symbPF. (* | ssum0 : nat->(nat->symbPF)->symbPF | ssumx : (n:nat)((i:nat)(lt i n)->symbPF)->symbPF | ssum : nat->nat->(nat->symbPF)->symbPF *) Fixpoint symb_to_PartIR (r : symbPF) : PartIR := match r with | shyp _ _ f _ _ => f | shyp' _ _ f _ => f | sconst c => [-C-]c | sid => FId | splus f g => symb_to_PartIR f{+}symb_to_PartIR g | sinv f => {--}(symb_to_PartIR f) | sminus f g => symb_to_PartIR f{-}symb_to_PartIR g | smult f g => symb_to_PartIR f{*}symb_to_PartIR g | sscalmult c f => c{**}symb_to_PartIR f | snth f n => symb_to_PartIR f{^}n | srecip f => {1/}(symb_to_PartIR f) | sdiv f g => symb_to_PartIR f{/}symb_to_PartIR g | scomp f g => symb_to_PartIR f[o] symb_to_PartIR g (* | (ssum0 n f) => (FSum0 n [i:nat](symb_to_PartIR (f i))) | (ssumx n f) => (FSumx n [i:nat][Hi:(lt i n)](symb_to_PartIR (f i Hi))) | (ssum m n f) => (FSum m n [i:nat](symb_to_PartIR (f i))) *) end. Fixpoint symbPF_deriv (r : symbPF) : PartIR := match r with | shyp _ _ _ f' _ => f' | shyp' J pJ F H => Deriv J pJ F H | sconst c => [-C-][0] | sid => [-C-][1] | splus f g => symbPF_deriv f{+}symbPF_deriv g | sinv f => {--}(symbPF_deriv f) | sminus f g => symbPF_deriv f{-}symbPF_deriv g | smult f g => symb_to_PartIR f{*}symbPF_deriv g{+}symbPF_deriv f{*}symb_to_PartIR g | sscalmult c f => c{**}symbPF_deriv f | snth f n => match n with | O => [-C-][0] | S p => nring (S p){**}(symbPF_deriv f{*}symb_to_PartIR (snth f p)) end | srecip f => {--}(symbPF_deriv f{/}symb_to_PartIR f{*}symb_to_PartIR f) | sdiv f g => (symbPF_deriv f{*}symb_to_PartIR g{-}symb_to_PartIR f{*}symbPF_deriv g){/} symb_to_PartIR g{*}symb_to_PartIR g | scomp g f => (symbPF_deriv g[o]symb_to_PartIR f){*} symbPF_deriv f (* | (ssum0 n f) => (FSum0 n [i:nat](symbPF_deriv (f i))) | (ssumx n f) => (FSumx n [i:nat][Hi:(lt i n)](symbPF_deriv (f i Hi))) | (ssum m n f) => (FSum m n [i:nat](symbPF_deriv (f i))) *) end. Ltac PartIR_to_symbPF f := match constr:(f) with | ([-C-]?X3) => constr:(sconst X3) | FId => constr:(sid) | (?X3{+}?X4) => let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in constr:(splus t1 t2) | ({--}?X3) => let t1 := PartIR_to_symbPF X3 in constr:(sinv t1) | (?X3{-}?X4) => let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in constr:(sminus t1 t2) | (?X3{*}?X4) => let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in constr:(smult t1 t2) | (?X3{**}?X4) => let t := PartIR_to_symbPF X4 in constr:(sscalmult X3 t) | (?X3{^}?X4) => let t1 := PartIR_to_symbPF X3 in constr:(snth t1 X4) | ({1/}?X3) => let t1 := PartIR_to_symbPF X3 in constr:(srecip t1) | (?X3{/}?X4) => let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in constr:(sdiv t1 t2) | (?X3[o]?X4) => let t1 := PartIR_to_symbPF X3 with t2 := PartIR_to_symbPF X4 in constr:(scomp t1 t2) | ?X3 => let t := constr:(X3) in match goal with | H:(Derivative ?X1 ?X2 t ?X4) |- _ => constr:(shyp X1 X2 t X4 H) | H:(Diffble ?X1 ?X2 t) |- _ => constr:(shyp' X1 X2 t H) end end. Ltac Derivative_Help := match goal with | |- (Derivative ?X1 ?X2 ?X3 ?X4) => let r := PartIR_to_symbPF X3 in (apply Derivative_wdr with (symbPF_deriv r); [ unfold symbPF_deriv, symb_to_PartIR in |- * | simpl in |- *; Deriv ]) end. (* end hide *) corn-8.20.0/tactics/FieldReflection.v000066400000000000000000001115311473720167500174370ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.algebra.CFields. Require Export CoRN.tactics.AlgReflection. Section Field_Interpretation_Function. Variable F : CField. Variable val : varindex -> F. Variable unop : unopindex -> CSetoid_un_op F. Variable binop : binopindex -> CSetoid_bin_op F. Variable pfun : pfunindex -> PartFunct F. Inductive interpF : expr -> F -> CProp := | interpF_var : forall (i:varindex) (z:F), (val i[=]z) -> interpF (expr_var i) z | interpF_int : forall (k:Z) (z:F), (zring k[=]z) -> interpF (expr_int k) z | interpF_plus : forall (e f:expr) (x y z:F), (x[+]y[=]z) -> interpF e x -> interpF f y -> interpF (expr_plus e f) z | interpF_mult : forall (e f:expr) (x y z:F), (x[*]y[=]z) -> interpF e x -> interpF f y -> interpF (expr_mult e f) z | interpF_unop : forall (e:expr) (f:unopindex) (x z:F), (unop f x[=]z) -> interpF e x -> interpF (expr_unop f e) z | interpF_binop : forall (e e':expr) (f:binopindex) (x y z:F), (binop f x y[=]z) -> interpF e x -> interpF e' y -> interpF (expr_binop f e e') z | interpF_part : forall (e:expr) (f:pfunindex) (x z:F) (Hx:Dom (pfun f) x), (pfun f x Hx[=]z) -> interpF e x -> interpF (expr_part f e) z | interpF_div : forall (e f:expr) (x y z:F) (nzy:y[#][0]), ((x[/]y[//]nzy)[=]z) -> interpF e x -> interpF f y -> interpF (expr_div e f) z. Definition wfF (e:expr) := sigT (interpF e). Inductive xexprF : F -> Type := | xexprF_var : forall i:varindex, xexprF (val i) | xexprF_int : forall k:Z, xexprF (zring k) | xexprF_plus : forall (x y:F) (e:xexprF x) (f:xexprF y), xexprF (x[+]y) | xexprF_mult : forall (x y:F) (e:xexprF x) (f:xexprF y), xexprF (x[*]y) | xexprF_unop : forall (x:F) (f:unopindex) (e:xexprF x), xexprF (unop f x) | xexprF_binop : forall (x y:F) (f:binopindex) (e:xexprF x) (e':xexprF y), xexprF (binop f x y) | xexprF_part : forall (x:F) (f:pfunindex) (e:xexprF x) (Hx:Dom (pfun f) x), xexprF (pfun f x Hx) | xexprF_div : forall (x y (* more things rrational translates: *) :F) (e:xexprF x) (f:xexprF y) (nzy:y[#][0]), xexprF (x[/]y[//]nzy) | xexprF_zero : xexprF [0] | xexprF_one : xexprF [1] | xexprF_nat : forall n:nat, xexprF (nring n) | xexprF_inv : forall (x:F) (e:xexprF x), xexprF [--]x | xexprF_minus : forall (x y:F) (e:xexprF x) (f:xexprF y), xexprF (x[-]y) | xexprF_power : forall (x:F) (e:xexprF x) (n:nat), xexprF (x[^]n). Fixpoint xforgetF (x:F) (e:xexprF x) {struct e} : expr := match e with | xexprF_var i => expr_var i | xexprF_int k => expr_int k | xexprF_plus _ _ e f => expr_plus (xforgetF _ e) (xforgetF _ f) | xexprF_mult _ _ e f => expr_mult (xforgetF _ e) (xforgetF _ f) | xexprF_unop _ f e => expr_unop f (xforgetF _ e) | xexprF_binop _ _ f e e' => expr_binop f (xforgetF _ e) (xforgetF _ e') | xexprF_part _ f e _ => expr_part f (xforgetF _ e) | xexprF_div _ _ e f _ => expr_div (xforgetF _ e) (xforgetF _ f) | xexprF_zero => expr_zero | xexprF_one => expr_one | xexprF_nat n => expr_nat n | xexprF_inv _ e => expr_inv (xforgetF _ e) | xexprF_minus _ _ e f => expr_minus (xforgetF _ e) (xforgetF _ f) | xexprF_power _ e n => expr_power n (xforgetF _ e) end. Definition xinterpF (x:F) (e:xexprF x) := x. Lemma xexprF2interpF : forall (x:F) (e:xexprF x), interpF (xforgetF _ e) x. Proof. intros x e. induction e. apply (interpF_var i); algebra. apply (interpF_int k); algebra. apply (interpF_plus (xforgetF _ e1) (xforgetF _ e2) x y (x[+]y)); algebra. apply (interpF_mult (xforgetF _ e1) (xforgetF _ e2) x y (x[*]y)); algebra. apply (interpF_unop (xforgetF _ e) f x (unop f x)); algebra. apply (interpF_binop (xforgetF _ e1) (xforgetF _ e2) f x y (binop f x y)); algebra. eapply (interpF_part (xforgetF _ e) f x (pfun f x Hx)). apply eq_reflexive_unfolded. algebra. apply (interpF_div (xforgetF _ e1) (xforgetF _ e2) x y (x[/]y[//]nzy) nzy); algebra. apply (interpF_int 0); algebra. apply (interpF_int 1); Step_final ([1]:F). apply (interpF_int (Z_of_nat n)); algebra. apply (interpF_mult (xforgetF _ e) (expr_int (-1)) x (zring (-1)) [--]x); auto. Step_final (zring (-1)[*]x). apply (interpF_int (-1)); algebra. apply (interpF_plus (xforgetF _ e1) (xforgetF _ (xexprF_inv _ e2)) x [--]y (x[-]y)); algebra. apply (interpF_mult (xforgetF _ e2) (expr_int (-1)) y (zring (-1)) [--]y); auto. Step_final (zring (-1)[*]y). apply (interpF_int (-1)); algebra. induction n. apply (interpF_int 1); Step_final ([1]:F). apply (interpF_mult (xforgetF _ e) (expr_power n (xforgetF _ e)) x ( x[^]n) (x[^]S n)); algebra. Qed. Definition xexprF_diagram_commutes : forall (x:F) (e:xexprF x), interpF (xforgetF _ e) (xinterpF _ e) := xexprF2interpF. Lemma xexprF2wfF : forall (x:F) (e:xexprF x), wfF (xforgetF _ e). Proof. intros x e. exists x. apply xexprF2interpF. Qed. Record fexprF : Type := {finterpF : F; fexprF2xexprF : xexprF finterpF}. Definition fexprF_var (i:varindex) := Build_fexprF _ (xexprF_var i). Definition fexprF_int (k:Z) := Build_fexprF _ (xexprF_int k). Definition fexprF_plus (e e':fexprF) := Build_fexprF _ (xexprF_plus (finterpF e) (finterpF e') (fexprF2xexprF e) (fexprF2xexprF e')). Definition fexprF_mult (e e':fexprF) := Build_fexprF _ (xexprF_mult (finterpF e) (finterpF e') (fexprF2xexprF e) (fexprF2xexprF e')). Definition fforgetF (e:fexprF) := xforgetF (finterpF e) (fexprF2xexprF e). Lemma fexprF2interpF : forall e:fexprF, interpF (fforgetF e) (finterpF e). Proof. intros e. elim e. intros x e'. unfold fforgetF in |- *. simpl in |- *. apply xexprF2interpF. Qed. Lemma fexprF2wfF : forall e:fexprF, wfF (fforgetF e). Proof. intro e. unfold fforgetF in |- *. apply xexprF2wfF. Qed. Load "Opaque_algebra". Lemma refl_interpF : forall (e:expr) (x y:F), interpF e x -> interpF e y -> x[=]y. Proof. intro e. induction e. intros x y Hx Hy. inversion Hx. inversion Hy. Step_final (val v). intros x y Hx Hy. inversion Hx. inversion Hy. Step_final (zring z:F). intros x y H1 H2. inversion H1. inversion H2. astepl (x0[+]y0). Step_final (x1[+]y1). intros x y H1 H2. inversion H1. inversion H2. astepl (x0[*]y0). Step_final (x1[*]y1). intros x y H0 H1. inversion H0. inversion H1. astepl (x0[/]y0[//]nzy). Step_final (x1[/]y1[//]nzy0). intros x y H0 H1. inversion H0. inversion H1. astepl (unop u x0); Step_final (unop u x1). intros x y H0 H1. inversion H0. inversion H1. astepl (binop b x0 y0); Step_final (binop b x1 y1). intros x y H0 H1. inversion H0. inversion H1. astepl (pfun p x0 Hx); Step_final (pfun p x1 Hx0). Qed. Lemma interpF_wd : forall (e:expr) (x y:F), interpF e x -> (x[=]y) -> interpF e y. Proof. intros e x y H H0. inversion H; try (rewrite <- H2; rewrite H3 in H1). (* Compat 8.0 *) apply interpF_var. Step_final x. apply interpF_int. Step_final x. apply interpF_plus with x0 y0; auto. Step_final x. apply interpF_mult with x0 y0; auto. Step_final x. apply interpF_unop with x0; auto. Step_final x. apply interpF_binop with x0 y0; auto. Step_final x. apply interpF_part with x0 Hx; auto. Step_final x. apply interpF_div with x0 y0 nzy; auto. Step_final x. Qed. End Field_Interpretation_Function. Section Field_NormCorrect. Variable F : CField. Variable val : varindex -> F. Variable unop : unopindex -> CSetoid_un_op F. Variable binop : binopindex -> CSetoid_bin_op F. Variable pfun : pfunindex -> PartFunct F. Notation II := (interpF F val unop binop pfun). (* four kinds of exprs: I (expr_int _) V (expr_var _) M (expr_mult V M) I P (expr_plus M P) I M: sorted on V P: sorted on M, all M's not an I *) Opaque Zmult. Lemma MI_mult_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (MI_mult e f) (x[*]y). Proof. cut (forall x y:F, II (expr_int 0) y -> II (expr_int 0) (x[*]y)). cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (MI_mult e2 f) (x[*]y)) -> II (expr_mult e1 e2) x -> II f y -> II (expr_mult e1 (MI_mult e2 f)) (x[*]y)). cut (forall (i j:Z) (x y:F), II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i * j)) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)). simple induction e; simple induction f; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z0; induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. induction f; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z0; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. intros; apply interpF_mult with x y; algebra. intros; apply interpF_wd with (zring (i * j):F). apply interpF_int; algebra. inversion X. inversion X0. Step_final (zring i[*]zring j:F). intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (x0[*](y0[*]y)); algebra. apply interpF_mult with x0 (y0[*]y); algebra. Step_final (x0[*]y0[*]y). intros. inversion X. try (rewrite H in H0; rewrite H1 in H0). (* compat 8.0 *) apply interpF_wd with (zring 0:F). apply interpF_int; algebra. astepl ([0]:F). astepl (x[*][0]). Step_final (x[*]zring 0). Qed. Transparent Zmult. Opaque MI_mult. Lemma MV_mult_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (MV_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (MV_mult e2 f) (x[*]y)) -> II (expr_mult e1 e2) x -> II f y -> II (expr_mult e1 (MV_mult e2 f)) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (MI_mult (expr_mult f expr_one) e) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult f e) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 H2 e. elim e. simpl in |- *; auto. simpl in |- *; auto. intros e1 H3 e2 H4. elim e1; simpl in |- *; auto. intros e1 H3 e2 H4. elim e1; simpl in |- *; auto. intros n f. elim f; simpl in |- *; auto. intro m. elim (lt_nat n m); simpl in |- *; auto. intros u e0 H5 f. elim f; simpl in |- *; auto. intros u0 e3 H6. elim lt_nat; simpl in |- *; auto. elim andb; simpl in |- *; auto. intros b e0 H6 e3 H7 f. elim f; simpl in |- *; auto. intros b0 e4 H8 e5 H9. elim lt_nat; simpl in |- *; auto. elim andb; simpl in |- *; auto. elim andb; simpl in |- *; auto. intros n f H5 f0. elim f0; simpl in |- *; auto. intros f1 e0 H6. elim lt_nat; simpl in |- *; auto. elim andb; simpl in |- *; auto. intros. simpl in |- *. auto. intros n e0 H3 f. elim f; simpl in |- *; auto. intros n e0 H3 e1 H4 f. elim f; simpl in |- *; auto. intros n e0 H3 f. elim f; simpl in |- *; auto. intros; apply interpF_mult with x y; algebra. intros; apply interpF_wd with (y[*]x); algebra. apply interpF_mult with y x; algebra. intros; apply interpF_wd with (y[*][1][*]x). apply MI_mult_corr_F; auto. apply interpF_mult with y ([1]:F); algebra. apply (interpF_int F val unop binop pfun 1); algebra. Step_final (x[*](y[*][1])). intros. inversion X0. try (rewrite H0 in H2; rewrite H in X2; rewrite H1 in X3). (* compat 8.0 *) apply interpF_wd with (x0[*](y0[*]y)). apply interpF_mult with x0 (y0[*]y); algebra. Step_final (x0[*]y0[*]y). Qed. Transparent MI_mult. Opaque MV_mult MI_mult. Lemma MM_mult_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (MM_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (MM_mult e2 f) (x[*]y)) -> II (expr_mult e1 e2) x -> II f y -> II (MV_mult (MM_mult e2 f) e1) (x[*]y)). cut (forall (i:Z) (f:expr) (x y:F), II (expr_int i) x -> II f y -> II (MI_mult f (expr_int i)) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros; apply interpF_mult with x y; algebra. intros; apply interpF_wd with (y[*]x); algebra. apply MI_mult_corr_F; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (y0[*]y[*]x0). apply MV_mult_corr_F; auto. astepl (x0[*](y0[*]y)). Step_final (x0[*]y0[*]y). Qed. Transparent MV_mult MI_mult. Opaque MV_mult. Lemma MM_plus_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (MM_plus e f) (x[+]y). Proof. cut (forall (i j:Z) (x y:F), II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i + j)) (x[+]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)). intros H H0 e; elim e. simpl in |- *; auto. intros z f; elim f; simpl in |- *; auto. simpl in |- *; auto. intros e1 H1 e2 H2. elim e1; simpl in |- *; auto. intros n f. elim f; simpl in |- *; auto. intros f1 H3 f2 H4. elim f1; simpl in |- *; auto. intro m. cut (eq_nat n m = true -> n = m). elim (eq_nat n m); simpl in |- *; auto. intros. inversion X. try (rewrite H6 in X1; rewrite H8 in X2; rewrite H7 in H9). (* compat 8.0 *) inversion X0. try (rewrite H10 in X3; rewrite H12 in X4; rewrite H11 in H13). (* compat 8.0 *) apply interpF_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_F; auto. astepl (x0[*](y0[+]y1)). astepl (x0[*]y0[+]x0[*]y1). cut (x0[=]x1). intro. Step_final (x0[*]y0[+]x1[*]y1). apply refl_interpF with val unop binop pfun (expr_var n). assumption. rewrite (H5 (refl_equal true)). assumption. intros; apply eq_nat_corr; auto. intros u e0 H3 f. elim f; simpl in |- *; auto. intros e3 H4 e4 H5. elim e3; simpl in |- *; auto. intros u0 e5 H6. cut (andb (eq_nat u u0) (eq_expr e0 e5) = true -> u = u0). cut (andb (eq_nat u u0) (eq_expr e0 e5) = true -> e0 = e5). elim andb; simpl in |- *; auto. intros H' H''. intros. inversion X. try (rewrite H7 in X1; rewrite H9 in X2; rewrite H8 in H10). (* compat 8.0 *) inversion X0. try (rewrite H11 in X3; rewrite H13 in X4; rewrite H12 in H14). (* compat 8.0 *) apply interpF_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_F; auto. astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0). apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr. apply refl_interpF with val unop binop pfun (expr_unop u e0). auto. rewrite H'. rewrite H''. auto. auto. auto. intro. elim (andb_prop _ _ H7); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H7); intros. apply eq_nat_corr; auto. intros u e0 H3 e3 H4 f. elim f; simpl in |- *; auto. intros e4 H5 e5 H6. elim e4; simpl in |- *; auto. intros u0 e6 H7 e7 H8. cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> u = u0). cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> e0 = e6). cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> e3 = e7). elim andb; simpl in |- *; auto. intros H' H'' H'''. intros. inversion X. try (rewrite H9 in X1; rewrite H11 in X2; rewrite H10 in H12). (* compat 8.0 *) inversion X0. try (rewrite H13 in X3; rewrite H15 in X4; rewrite H14 in H16). (* compat 8.0 *) apply interpF_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_F; auto. astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0). apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr. apply refl_interpF with val unop binop pfun (expr_binop u e0 e3). auto. rewrite H'. rewrite H''. rewrite H'''. auto. auto. auto. auto. intro. elim (andb_prop _ _ H9); intros. elim (andb_prop _ _ H11); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H9); intros. elim (andb_prop _ _ H11); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H9); intros. apply eq_nat_corr; auto. intros f e0 H3. intro f0. elim f0; simpl in |- *; auto. intros e3 H4 e4 H5. elim e3; simpl in |- *; auto. intros f1 e5 H6. cut (andb (eq_nat f f1) (eq_expr e0 e5) = true -> f = f1). cut (andb (eq_nat f f1) (eq_expr e0 e5) = true -> e0 = e5). elim (andb (eq_nat f f1) (eq_expr e0 e5)); simpl in |- *; auto. intros. inversion X. try (rewrite H9 in X1; rewrite H11 in X2; rewrite H10 in H12). (* compat 8.0 *) inversion X0. try (rewrite H13 in X3; rewrite H15 in X4; rewrite H14 in H16). (* compat 8.0 *) apply interpF_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_F; auto. astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0). apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr. apply refl_interpF with val unop binop pfun (expr_part f e0). auto. rewrite H7. rewrite H8; auto. auto. intro. elim (andb_prop _ _ H7); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H7); intros. apply eq_nat_corr; auto. simpl in |- *; auto. intros u e0 H1 f. elim f; simpl in |- *; auto. intros u e0 H1 e1 H2 f. elim f; simpl in |- *; auto. intros u e0 H1 f. elim f; simpl in |- *; auto. intros; apply interpF_plus with x y; algebra. intros. inversion X. try (rewrite H1 in H0; rewrite H in H0). (* compat 8.0 *) inversion X0. try (rewrite H2 in H3; rewrite H4 in H3). (* compat 8.0 *) apply interpF_wd with (zring (i + j):F). apply interpF_int; algebra. Step_final (zring i[+]zring j:F). Qed. Transparent MV_mult. Opaque MM_plus. Lemma PM_plus_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (PM_plus e f) (x[+]y). Proof. cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PM_plus e2 f) (x[+]y)) -> II (expr_plus e1 e2) x -> II f y -> II (expr_plus e1 (PM_plus e2 f)) (x[+]y)). cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PM_plus e2 f) (x[+]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PM_plus e2 (MM_plus e1 f)) (x[+]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (MM_plus e f) (x[+]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus f e) (x[+]y)). intros H H0 H1 H2 H3 e. elim e. simpl in |- *; auto. intros z f; elim f; intros; simpl in |- *; auto. intros e1 H4 e2 H5 f. simpl in |- *. elim (lt_monom e1 f); elim (eq_monom e1 f); elim f; intros; simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. intros; apply interpF_wd with (y[+]x); algebra. apply interpF_plus with y x; algebra. intros; apply interpF_plus with x y; algebra. intros; apply MM_plus_corr_F; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (y0[+](x0[+]y)). apply X; auto. apply MM_plus_corr_F; auto. astepl (y0[+]x0[+]y). Step_final (x0[+]y0[+]y). intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (x0[+](y0[+]y)). apply interpF_plus with x0 (y0[+]y); algebra. Step_final (x0[+]y0[+]y). Qed. Transparent MM_plus. Opaque PM_plus. Lemma PP_plus_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (PP_plus e f) (x[+]y). Proof. cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PP_plus e2 f) (x[+]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PM_plus (PP_plus e2 f) e1) (x[+]y)). cut (forall (i:Z) (f:expr) (x y:F), II (expr_int i) x -> II f y -> II (PM_plus f (expr_int i)) (x[+]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros. apply interpF_plus with x y; algebra. intros. apply interpF_wd with (y[+]x); algebra. apply PM_plus_corr_F; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (y0[+]y[+]x0). apply PM_plus_corr_F; auto. astepl (x0[+](y0[+]y)). Step_final (x0[+]y0[+]y). Qed. Transparent PM_plus. Opaque PM_plus MM_mult MI_mult. Lemma PM_mult_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (PM_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PM_mult e2 f) (x[*]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PM_plus (PM_mult e2 f) (MM_mult e1 f)) (x[*]y)). cut (forall (i:Z) (f:expr) (x y:F), II (expr_int i) x -> II f y -> II (PM_plus (expr_int 0) (MI_mult f (expr_int i))) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros. apply interpF_mult with x y; algebra. intros. apply interpF_wd with (zring 0[+]y[*]x). apply PM_plus_corr_F. apply interpF_int; algebra. apply MI_mult_corr_F; auto. astepl ([0][+]y[*]x). Step_final (y[*]x). intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (y0[*]y[+]x0[*]y). apply PM_plus_corr_F; auto. apply MM_mult_corr_F; auto. astepl ((y0[+]x0)[*]y). Step_final ((x0[+]y0)[*]y). Qed. Opaque PM_mult. Lemma PP_mult_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (PP_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:F), (forall (f:expr) (x y:F), II e2 x -> II f y -> II (PP_mult e2 f) (x[*]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PP_plus (PM_mult f e1) (PP_mult e2 f)) (x[*]y)). cut (forall (i:Z) (f:expr) (x y:F), II (expr_int i) x -> II f y -> II (PM_mult f (expr_int i)) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros. apply interpF_mult with x y; algebra. intros. apply interpF_wd with (y[*]x); algebra. apply PM_mult_corr_F; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (y[*]x0[+]y0[*]y). apply PP_plus_corr_F; auto. apply PM_mult_corr_F; auto. astepl (x0[*]y[+]y0[*]y). Step_final ((x0[+]y0)[*]y). Qed. Transparent PP_plus PM_mult PP_mult PM_plus MI_mult. Lemma FF_plus_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (FF_plus e f) (x[+]y). Proof. cut (forall (e1 e2 f1 f2:expr) (x y:F), II (expr_div e1 e2) x -> II (expr_div f1 f2) y -> II (expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1)) (PP_mult e2 f2)) (x[+]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_plus e f) (x[+]y)). intros H H0 e f. elim e; elim f; intros; simpl in |- *; auto. intros. apply interpF_plus with x y; algebra. intros. inversion X. try (rewrite H in X1; rewrite H1 in X2; rewrite H0 in H2). (* compat 8.0 *) inversion X0. try (rewrite H3 in X3; rewrite H5 in X4; rewrite H4 in H6). (* compat 8.0 *) cut (y0[*]y1[#][0]). intro H13. apply interpF_div with (x0[*]y1[+]y0[*]x1) (y0[*]y1) H13; auto. astepl ((x0[*]y1[/] y0[*]y1[//]H13)[+](y0[*]x1[/] y0[*]y1[//]H13)). astepl ((x0[/] y0[//]nzy)[*](y1[/] y1[//]nzy0)[+] (y0[/] y0[//]nzy)[*](x1[/] y1[//]nzy0)). astepl ((x0[/] y0[//]nzy)[*][1][+][1][*](x1[/] y1[//]nzy0)). Step_final ((x0[/] y0[//]nzy)[+](x1[/] y1[//]nzy0)). apply PP_plus_corr_F; auto. apply PP_mult_corr_F; auto. apply PP_mult_corr_F; auto. apply PP_mult_corr_F; auto. apply mult_resp_ap_zero; auto. Qed. Lemma FF_mult_corr_F : forall (e f:expr) (x y:F), II e x -> II f y -> II (FF_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f1 f2:expr) (x y:F), II (expr_div e1 e2) x -> II (expr_div f1 f2) y -> II (expr_div (PP_mult e1 f1) (PP_mult e2 f2)) (x[*]y)). cut (forall (e f:expr) (x y:F), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 e f. elim e; elim f; intros; simpl in |- *; auto. intros. apply interpF_mult with x y; algebra. intros. inversion X. try (rewrite H in X1; rewrite H1 in X2; rewrite H0 in H2). (* compat 8.0 *) inversion X0. try (rewrite H3 in X3; rewrite H5 in X4; rewrite H4 in H6). (* compat 8.0 *) cut (y0[*]y1[#][0]). intro H13. apply interpF_div with (x0[*]x1) (y0[*]y1) H13. Step_final ((x0[/] y0[//]nzy)[*](x1[/] y1[//]nzy0)). apply PP_mult_corr_F; auto. apply PP_mult_corr_F; auto. apply mult_resp_ap_zero; auto. Qed. Transparent FF_div. Lemma FF_div_corr_F : forall (e f:expr) (x y:F) (nzy:y[#][0]), II e x -> II f y -> II (FF_div e f) (x[/]y[//]nzy). Proof. cut (forall (e1 e2 f1 f2:expr) (x y:F) (nzy:y[#][0]), II (expr_div e1 e2) x -> II (expr_div f1 f2) y -> II (expr_div (PP_mult e1 f2) (PP_mult e2 f1)) (x[/]y[//]nzy)). cut (forall (e f:expr) (x y:F) (nzy:y[#][0]), II e x -> II f y -> II (expr_div e f) (x[/]y[//]nzy)). intros H H0 e f. elim e; elim f; intros; simpl in |- *; auto. intros. apply interpF_div with x y nzy; algebra. intros. inversion X. try (rewrite H in X1; rewrite H1 in X2; rewrite H0 in H2). (* compat 8.0 *) inversion X0. try (rewrite H3 in X3; rewrite H5 in X4; rewrite H4 in H6). (* compat 8.0 *) cut (x1[#][0]). intro nzx1. cut (y0[*]x1[#][0]). intro H13. cut ((x1[/]y1[//]nzy1)[#][0]). intro H14. apply interpF_div with (x0[*]y1) (y0[*]x1) H13. astepl ((y1[*]x0)[/]y0[*]x1[//]H13). astepl (((y1[*]x0)[/]y0[//]nzy0)[/]x1[//]nzx1). astepl ((y1[*](x0[/]y0[//]nzy0))[/]x1[//]nzx1). astepl (((x0[/]y0[//]nzy0)[*]y1)[/]x1[//]nzx1). Step_final ((x0[/]y0[//]nzy0)[/]x1[/]y1[//]nzy1[//]H14). apply PP_mult_corr_F; auto. apply PP_mult_corr_F; auto. apply div_resp_ap_zero_rev; auto. apply mult_resp_ap_zero; auto. apply div_resp_ap_zero with y1 nzy1. astepl y. auto. Qed. Lemma NormF_corr : forall (e:expr) (x:F), II e x -> II (NormF e) x. Proof. intro; elim e; intros; simpl in |- *. apply (interpF_div F val unop binop pfun (expr_plus (expr_mult (expr_var v) expr_one) expr_zero) expr_one x ([1]:F) x (ring_non_triv F)). algebra. apply (interpF_plus F val unop binop pfun (expr_mult (expr_var v) expr_one) expr_zero x ([0]:F) x). algebra. apply (interpF_mult F val unop binop pfun (expr_var v) expr_one x ([1]:F) x); algebra. apply (interpF_int F val unop binop pfun 1); algebra. apply (interpF_int F val unop binop pfun 0); algebra. apply (interpF_int F val unop binop pfun 1); algebra. apply (interpF_div F val unop binop pfun (expr_int z) expr_one x ( [1]:F) x (ring_non_triv F)). algebra. algebra. apply (interpF_int F val unop binop pfun 1); algebra. inversion X1. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (x0[+]y). apply FF_plus_corr_F; auto. auto. inversion X1. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (x0[*]y). apply FF_mult_corr_F; auto. auto. inversion X1. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpF_wd with (x0[/]y[//]nzy). apply FF_div_corr_F; auto. auto. inversion X0. try (rewrite H in H2; rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *) apply (interpF_div F val unop binop pfun (expr_plus (expr_mult (expr_unop u (NormF e0)) expr_one) expr_zero) expr_one x ([1]:F) x (ring_non_triv F)). algebra. apply (interpF_plus F val unop binop pfun (expr_mult (expr_unop u (NormF e0)) expr_one) expr_zero x ( [0]:F) x). algebra. apply (interpF_mult F val unop binop pfun (expr_unop u (NormF e0)) expr_one x ([1]:F) x); algebra. apply (interpF_unop F val unop binop pfun (NormF e0) u x0); algebra. apply (interpF_int F val unop binop pfun 1); algebra. apply (interpF_int F val unop binop pfun 0); algebra. apply (interpF_int F val unop binop pfun 1); algebra. inversion X1. try (rewrite H in H3; rewrite H1 in X2; rewrite H2 in X3; rewrite H0 in H3). (* compat 8.0 *) apply (interpF_div F val unop binop pfun (expr_plus (expr_mult (expr_binop b (NormF e0) (NormF e1)) expr_one) expr_zero) expr_one x ([1]:F) x (ring_non_triv F)). algebra. apply (interpF_plus F val unop binop pfun (expr_mult (expr_binop b (NormF e0) (NormF e1)) expr_one) expr_zero x ([0]:F) x). algebra. apply (interpF_mult F val unop binop pfun (expr_binop b (NormF e0) (NormF e1)) expr_one x ([1]:F) x); algebra. apply (interpF_binop F val unop binop pfun (NormF e0) (NormF e1) b x0 y); algebra. apply (interpF_int F val unop binop pfun 1); algebra. apply (interpF_int F val unop binop pfun 0); algebra. apply (interpF_int F val unop binop pfun 1); algebra. inversion X0. try ((generalize Hx H2; clear Hx H2; rewrite H; intros Hx H2); rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *) apply (interpF_div F val unop binop pfun (expr_plus (expr_mult (expr_part p (NormF e0)) expr_one) expr_zero) expr_one x ([1]:F) x (ring_non_triv F)). algebra. apply (interpF_plus F val unop binop pfun (expr_mult (expr_part p (NormF e0)) expr_one) expr_zero x ( [0]:F) x). algebra. apply (interpF_mult F val unop binop pfun (expr_part p (NormF e0)) expr_one x ([1]:F) x); algebra. apply (interpF_part F val unop binop pfun (NormF e0) p x0) with (Hx := Hx); algebra. apply (interpF_int F val unop binop pfun 1); algebra. apply (interpF_int F val unop binop pfun 0); algebra. apply (interpF_int F val unop binop pfun 1); algebra. Qed. Lemma Norm_wfF : forall e:expr, wfF F val unop binop pfun e -> wfF F val unop binop pfun (NormF e). Proof. unfold wfF in |- *. intros. elim X. intros. exists x. apply NormF_corr. assumption. Qed. Lemma expr_is_zero_corr_F : forall e:expr, wfF F val unop binop pfun e -> expr_is_zero e = true -> II e [0]. Proof. unfold wfF in |- *. intros e H. elim H. intro. elim e; simpl in |- *; try (intros; exfalso; inversion H0; fail). intros e0 H0 e1 H1. elim e0; simpl in |- *; try (intros; exfalso; inversion H2; fail). intro. elim z; simpl in |- *; try (intros; exfalso; inversion H2; fail); intros H2 H3. inversion H2. try (rewrite H4 in X; rewrite H6 in X0; rewrite H5 in H7). (* compat 8.0 *) apply interpF_div with ([0]:F) y nzy; auto. algebra. apply (interpF_int F val unop binop pfun 0); algebra. Qed. Lemma Tactic_lemma_zero_F : forall (x:F) (e:xexprF F val unop binop pfun x), expr_is_zero (NormF (xforgetF _ _ _ _ _ _ e)) = true -> x[=][0]. Proof. intros. apply refl_interpF with val unop binop pfun (NormF (xforgetF _ _ _ _ _ _ e)). apply NormF_corr. apply xexprF2interpF. apply expr_is_zero_corr_F. apply Norm_wfF. apply xexprF2wfF. assumption. Qed. Lemma Tactic_lemmaF : forall (x y:F) (e:xexprF F val unop binop pfun x) (f:xexprF F val unop binop pfun y), expr_is_zero (NormF (xforgetF _ _ _ _ _ _ (xexprF_minus _ _ _ _ _ _ _ e f))) = true -> x[=]y. Proof. intros. apply cg_inv_unique_2. apply Tactic_lemma_zero_F with (xexprF_minus _ _ _ _ _ _ _ e f). assumption. Qed. End Field_NormCorrect. Ltac QuoteF R l t := match l with (Quad ?vl ?ul ?bl ?pl) => (let a := constr:(fun n:varindex => (Mnth n vl (cm_unit R))) in let b := constr:(fun n:unopindex => (Mnth n ul (@cg_inv R))) in let c := constr:(fun n:binopindex => (Mnth n bl (@csg_op R))) in let d := constr:(fun n:pfunindex => (Mnth n pl (total_eq_part _ (@cg_inv R)))) in match t with | (zring ?k) => match (ClosedZ k) with | true => constr:(xexprF_int R a b c d k) end | (csbf_fun _ _ _ csg_op ?x ?y) => let x' := QuoteF R l x in let y' := QuoteF R l y in constr:(xexprF_plus R a b c d _ _ x' y') | (csbf_fun _ _ _ cr_mult ?x ?y) => let x' := QuoteF R l x in let y' := QuoteF R l y in constr:(xexprF_mult R a b c d _ _ x' y') | (cf_div ?x ?y ?H) => let x' := QuoteF R l x in let y' := QuoteF R l y in constr:(xexprF_div R a b c d _ _ x' y' H) | ([0]) => constr:(xexprF_zero R a b c d) | ([1]) => constr:(xexprF_one R a b c d) | (nring ?n) => match (ClosedNat n) with | true => constr:(xexprF_nat R a b c d n) end | (csf_fun _ _ cg_inv ?x) => let x' := QuoteF R l x in constr:(xexprF_inv R a b c d _ x') | (cg_minus ?x ?y) => let x' := QuoteF R l x in let y' := QuoteF R l y in constr:(xexprF_minus R a b c d _ _ x' y') | (csf_fun _ _ (@nexp_op _ ?n) ?x) => match (ClosedNat n) with | true => let x' := QuoteF R l x in constr:(xexprF_power R a b c d _ x' n) end | (pfpfun ?f ?x ?h) => let x' := QuoteF R l x in let i := FindIndex f pl in constr:(xexprF_part R a b c d _ i x' h) | (csf_fun _ _ ?f ?x) => let x' := QuoteF R l x in let i := FindIndex f ul in constr:(xexprF_unop R a b c d _ i x') | (csbf_fun _ _ _ ?f ?x ?y) => let x' := QuoteF R l x in let y' := QuoteF R l y in let i := FindIndex f bl in constr:(xexprF_binop R a b c d _ _ i x' y') | ?t => let i := FindIndex t vl in constr:(xexprF_var R a b c d i) end) end. Ltac FindTermVariablesF t l := match t with | (zring ?k) => match (ClosedZ k) with | true => constr:(l) end | (csbf_fun _ _ _ csg_op ?x ?y) => let l1 := FindTermVariablesF x l in let l2 := FindTermVariablesF y l1 in constr:(l2) | (csbf_fun _ _ _ cr_mult ?x ?y) => let l1 := FindTermVariablesF x l in let l2 := FindTermVariablesF y l1 in constr:(l2) | (cf_div ?x ?y ?H) => let l1 := FindTermVariablesF x l in let l2 := FindTermVariablesF y l1 in constr:(l2) | ([0]) => constr:(l) | ([1]) => constr:(l) | (nring ?n) => match (ClosedNat n) with | true => constr:(l) end | (csf_fun _ _ cg_inv ?x) => let l1 := FindTermVariablesF x l in constr:(l1) | (cg_minus ?x ?y) => let l1 := FindTermVariablesF x l in let l2 := FindTermVariablesF y l1 in constr:(l2) | (csf_fun _ _ (@nexp_op _ ?n) ?x) => match (ClosedNat n) with | true => let l1 := FindTermVariablesF x l in constr:(l1) end | (pfpfun ?f ?x ?h) => let l1 := FindTermVariablesF x l in match l1 with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl ul bl (Mcons f pl)) end | (csf_fun _ _ ?f ?x) => let l1 := FindTermVariablesF x l in match l1 with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl (Mcons f ul) bl pl) end | (csbf_fun _ _ _ ?f ?x ?y) => let l1 := FindTermVariablesF x l in let l2 := FindTermVariablesF y l1 in match l2 with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl ul (Mcons f bl) pl) end | ?t => match l with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad (Mcons t vl) ul bl pl) end end. Ltac FindTermsVariablesF fn t1 t2 := let l1 := FindTermVariablesF t1 (Quad (Mnil fn) (Mnil (CSetoid_un_op fn)) (Mnil (CSetoid_bin_op fn)) (Mnil (PartFunct fn))) in let l2 := FindTermVariablesF t2 l1 in constr:(l2). Ltac rationalF F x y := let l:=FindTermsVariablesF F x y in let t1:=(QuoteF F l x) in let t2:=(QuoteF F l y) in eapply Tactic_lemmaF with (e:=t1) (f:=t2) ; reflexivity. (* end hide *) corn-8.20.0/tactics/Qauto.v000066400000000000000000000036401473720167500154730ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.model.ordfields.Qordfield. Require Import CoRN.algebra.COrdFields2. From Coq Require Import Qpower. From Coq Require Import Qabs. (*Require Import CoRN.tactics.CornTac. was removed in the trunk branch *) Ltac Qauto_pos := repeat (first [ assumption | constructor | apply Q.Qplus_pos_compat | apply Q.Qmult_lt_0_compat | apply Qinv_lt_0_compat]); auto with *. Ltac Qauto_nonneg := repeat (first [assumption |discriminate |apply: Qabs_nonneg |apply: Qsqr_nonneg |apply: plus_resp_nonneg;simpl |apply: mult_resp_nonneg;simpl |apply: Qle_shift_div_l;[Qauto_pos|ring_simplify] |apply: Qle_shift_inv_l;[Qauto_pos|ring_simplify]]); auto with *. Ltac Qauto_le := rewrite -> Qle_minus_iff;ring_simplify;Qauto_nonneg. corn-8.20.0/tactics/Rational.v000066400000000000000000000041521473720167500161520ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.tactics.FieldReflection. Require Export CoRN.tactics.RingReflection. Require Export CoRN.algebra.CRing_as_Ring. Inductive AlgebraName : Type := |cfield : CField -> AlgebraName |cring : CRing -> AlgebraName. Ltac GetStructureName t := match t with | (csg_crr (cm_crr (cg_crr (cag_crr (cr_crr ?r))))) => match r with | (cf_crr ?q) => constr:(cfield q) | _ => constr:(cring r) end end. (* Ltac legacy_rational:= match goal with [|-@cs_eq (cs_crr ?T) ?x ?y] => match GetStructureName T with |(cfield ?F) => rationalF F x y |(cring ?R) => rationalR R x y end end. *) Ltac rational := match goal with [|-@cs_eq (cs_crr ?T) ?x ?y] => match GetStructureName T with |(cfield ?F) => rationalF F x y |(cring ?R) => (repeat (try apply csf_fun_wd);simpl;ring) (* |(cring ?R) => (try (repeat (try apply csf_fun_wd);simpl;ring));rationalR R x y *)(* Perhaps we should add wd for partial functions too *) end end. Tactic Notation "rstepl" constr(c) := stepl c;[idtac|rational]. Tactic Notation "rstepr" constr(c) := stepr c;[idtac|rational]. corn-8.20.0/tactics/RingReflection.v000066400000000000000000001006071473720167500173150ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Require Export CoRN.algebra.CRings. Require Export CoRN.tactics.AlgReflection. Section Ring_Interpretation_Function. Variable R : CRing. Variable val : varindex -> R. Variable unop : unopindex -> CSetoid_un_op R. Variable binop : binopindex -> CSetoid_bin_op R. Variable pfun : pfunindex -> PartFunct R. Inductive interpR : expr -> R -> CProp := | interpR_var : forall (i:varindex) (z:R), (val i[=]z) -> interpR (expr_var i) z | interpR_int : forall (k:Z) (z:R), (zring k[=]z) -> interpR (expr_int k) z | interpR_plus : forall (e f:expr) (x y z:R), (x[+]y[=]z) -> interpR e x -> interpR f y -> interpR (expr_plus e f) z | interpR_mult : forall (e f:expr) (x y z:R), (x[*]y[=]z) -> interpR e x -> interpR f y -> interpR (expr_mult e f) z | interpR_unop : forall (e:expr) (f:unopindex) (x z:R), (unop f x[=]z) -> interpR e x -> interpR (expr_unop f e) z | interpR_binop : forall (e e':expr) (f:binopindex) (x y z:R), (binop f x y[=]z) -> interpR e x -> interpR e' y -> interpR (expr_binop f e e') z | interpR_part : forall (e:expr) (f:pfunindex) (x z:R) (Hx:Dom (pfun f) x), (pfun f x Hx[=]z) -> interpR e x -> interpR (expr_part f e) z. Definition wfR (e:expr) := sigT (interpR e). Inductive xexprR : R -> Type := | xexprR_var : forall i:varindex, xexprR (val i) | xexprR_int : forall k:Z, xexprR (zring k) | xexprR_plus : forall (x y:R) (e:xexprR x) (f:xexprR y), xexprR (x[+]y) | xexprR_mult : forall (x y:R) (e:xexprR x) (f:xexprR y), xexprR (x[*]y) | xexprR_unop : forall (x:R) (f:unopindex) (e:xexprR x), xexprR (unop f x) | xexprR_binop : forall (x y:R) (f:binopindex) (e:xexprR x) (e':xexprR y), xexprR (binop f x y) | xexprR_part : forall (x:R) (f:pfunindex) (e:xexprR x) (Hx:Dom (pfun f) x), xexprR (pfun f x Hx) (* more things rrational translates: *) | xexprR_zero : xexprR [0] | xexprR_one : xexprR [1] | xexprR_nat : forall n:nat, xexprR (nring n) | xexprR_inv : forall (x:R) (e:xexprR x), xexprR [--]x | xexprR_minus : forall (x y:R) (e:xexprR x) (f:xexprR y), xexprR (x[-]y) | xexprR_power : forall (x:R) (e:xexprR x) (n:nat), xexprR (x[^]n). Fixpoint xforgetR (x:R) (e:xexprR x) {struct e} : expr := match e with | xexprR_var i => expr_var i | xexprR_int k => expr_int k | xexprR_plus _ _ e f => expr_plus (xforgetR _ e) (xforgetR _ f) | xexprR_mult _ _ e f => expr_mult (xforgetR _ e) (xforgetR _ f) | xexprR_unop _ f e => expr_unop f (xforgetR _ e) | xexprR_binop _ _ f e e' => expr_binop f (xforgetR _ e) (xforgetR _ e') | xexprR_part _ f e _ => expr_part f (xforgetR _ e) | xexprR_zero => expr_zero | xexprR_one => expr_one | xexprR_nat n => expr_nat n | xexprR_inv _ e => expr_inv (xforgetR _ e) | xexprR_minus _ _ e f => expr_minus (xforgetR _ e) (xforgetR _ f) | xexprR_power _ e n => expr_power n (xforgetR _ e) end. Definition xinterpR (x:R) (e:xexprR x) := x. Lemma xexprR2interpR : forall (x:R) (e:xexprR x), interpR (xforgetR _ e) x. Proof. intros x e. induction e. apply (interpR_var i); algebra. apply (interpR_int k); algebra. apply (interpR_plus (xforgetR _ e1) (xforgetR _ e2) x y (x[+]y)); algebra. apply (interpR_mult (xforgetR _ e1) (xforgetR _ e2) x y (x[*]y)); algebra. apply (interpR_unop (xforgetR _ e) f x (unop f x)); algebra. apply (interpR_binop (xforgetR _ e1) (xforgetR _ e2) f x y (binop f x y)); algebra. eapply (interpR_part (xforgetR _ e) f x (pfun f x Hx)). apply eq_reflexive_unfolded. algebra. apply (interpR_int 0); algebra. apply (interpR_int 1); Step_final ([1]:R). apply (interpR_int (Z_of_nat n)); algebra. apply (interpR_mult (xforgetR _ e) (expr_int (-1)) x (zring (-1)) [--]x); auto. Step_final (zring (-1)[*]x). apply (interpR_int (-1)); algebra. apply (interpR_plus (xforgetR _ e1) (xforgetR _ (xexprR_inv _ e2)) x [--]y (x[-]y)); algebra. apply (interpR_mult (xforgetR _ e2) (expr_int (-1)) y (zring (-1)) [--]y); auto. Step_final (zring (-1)[*]y). apply (interpR_int (-1)); algebra. induction n. apply (interpR_int 1); Step_final ([1]:R). apply (interpR_mult (xforgetR _ e) (expr_power n (xforgetR _ e)) x ( x[^]n) (x[^]S n)); algebra. Qed. Definition xexprR_diagram_commutes : forall (x:R) (e:xexprR x), interpR (xforgetR _ e) (xinterpR _ e) := xexprR2interpR. Lemma xexprR2wfR : forall (x:R) (e:xexprR x), wfR (xforgetR _ e). Proof. intros x e. exists x. apply xexprR2interpR. Qed. Record fexprR : Type := {finterpR : R; fexprR2xexprR : xexprR finterpR}. Definition fexprR_var (i:varindex) := Build_fexprR _ (xexprR_var i). Definition fexprR_int (k:Z) := Build_fexprR _ (xexprR_int k). Definition fexprR_plus (e e':fexprR) := Build_fexprR _ (xexprR_plus (finterpR e) (finterpR e') (fexprR2xexprR e) (fexprR2xexprR e')). Definition fexprR_mult (e e':fexprR) := Build_fexprR _ (xexprR_mult (finterpR e) (finterpR e') (fexprR2xexprR e) (fexprR2xexprR e')). Definition fforgetR (e:fexprR) := xforgetR (finterpR e) (fexprR2xexprR e). Lemma fexprR2interp : forall e:fexprR, interpR (fforgetR e) (finterpR e). Proof. intros e. elim e. intros x e'. unfold fforgetR in |- *. simpl in |- *. apply xexprR2interpR. Qed. Lemma fexprR2wf : forall e:fexprR, wfR (fforgetR e). Proof. intro e. unfold fforgetR in |- *. apply xexprR2wfR. Qed. Opaque csg_crr. Opaque cm_crr. Opaque cg_crr. Opaque cr_crr. Opaque csf_fun. Opaque csbf_fun. Opaque csr_rel. Opaque cs_eq. Opaque cs_neq. Opaque cs_ap. Opaque cm_unit. Opaque csg_op. Opaque cg_inv. Opaque cg_minus. Opaque cr_one. Opaque cr_mult. Opaque nexp_op. Lemma refl_interpR : forall (e:expr) (x y:R), interpR e x -> interpR e y -> x[=]y. Proof. intro e. induction e. intros x y Hx Hy. inversion Hx. inversion Hy. Step_final (val v). intros x y Hx Hy. inversion Hx. inversion Hy. Step_final (zring z:R). intros x y H1 H2. inversion H1. inversion H2. astepl (x0[+]y0). Step_final (x1[+]y1). intros x y H1 H2. inversion H1. inversion H2. astepl (x0[*]y0). Step_final (x1[*]y1). intros x y H0 H1. inversion H0. intros x y H0 H1. inversion H0. inversion H1. astepl (unop u x0); Step_final (unop u x1). intros x y H0 H1. inversion H0. inversion H1. astepl (binop b x0 y0); Step_final (binop b x1 y1). intros x y H0 H1. inversion H0. inversion H1. astepl (pfun p x0 Hx); Step_final (pfun p x1 Hx0). Qed. Lemma interpR_wd : forall (e:expr) (x y:R), interpR e x -> (x[=]y) -> interpR e y. Proof. intros e x y H H0. inversion H; (* inversion bug fixed in V8.1 makes these rewritings useless *) try (rewrite <- H2; rewrite H3 in H1). apply interpR_var. Step_final x. apply interpR_int. Step_final x. apply interpR_plus with x0 y0; auto. Step_final x. apply interpR_mult with x0 y0; auto. Step_final x. apply interpR_unop with x0; auto. Step_final x. apply interpR_binop with x0 y0; auto. Step_final x. apply interpR_part with x0 Hx; auto. Step_final x. Qed. End Ring_Interpretation_Function. Section Ring_NormCorrect. Variable R : CRing. Variable val : varindex -> R. Variable unop : unopindex -> CSetoid_un_op R. Variable binop : binopindex -> CSetoid_bin_op R. Variable pfun : pfunindex -> PartFunct R. Notation II := (interpR R val unop binop pfun). (* four kinds of exprs: I (expr_int _) V (expr_var _) M (expr_mult V M) I P (expr_plus M P) I M: sorted on V P: sorted on M, all M's not an I *) Opaque Zmult. Lemma MI_mult_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (MI_mult e f) (x[*]y). Proof. cut (forall x y:R, II (expr_int 0) y -> II (expr_int 0) (x[*]y)). cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (MI_mult e2 f) (x[*]y)) -> II (expr_mult e1 e2) x -> II f y -> II (expr_mult e1 (MI_mult e2 f)) (x[*]y)). cut (forall (i j:Z) (x y:R), II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i * j)) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult e f) (x[*]y)). simple induction e; simple induction f; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z0; induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. induction f; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z0; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. simple induction z; simpl in |- *; auto. intros; apply interpR_mult with x y; algebra. intros; apply interpR_wd with (zring (i * j):R). apply interpR_int; algebra. inversion X. inversion X0. Step_final (zring i[*]zring j:R). intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (x0[*](y0[*]y)); algebra. apply interpR_mult with x0 (y0[*]y); algebra. Step_final (x0[*]y0[*]y). intros. inversion X. try (rewrite H in H0; rewrite H1 in H0). (* compat 8.0 *) apply interpR_wd with (zring 0:R). apply interpR_int; algebra. astepl ([0]:R). astepl (x[*][0]). Step_final (x[*]zring 0). Qed. Transparent Zmult. Opaque MI_mult. Lemma MV_mult_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (MV_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (MV_mult e2 f) (x[*]y)) -> II (expr_mult e1 e2) x -> II f y -> II (expr_mult e1 (MV_mult e2 f)) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (MI_mult (expr_mult f expr_one) e) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult f e) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 H2 e. elim e. simpl in |- *; auto. simpl in |- *; auto. intros e1 H3 e2 H4. elim e1; simpl in |- *; auto. intros e1 H3 e2 H4. elim e1; simpl in |- *; auto. intros n f. elim f; simpl in |- *; auto. intro m. elim (lt_nat n m); simpl in |- *; auto. intros u e0 H5 f. elim f; simpl in |- *; auto. intros u0 e3 H6. elim lt_nat; simpl in |- *; auto. elim andb; simpl in |- *; auto. intros b e0 H6 e3 H7 f. elim f; simpl in |- *; auto. intros b0 e4 H8 e5 H9. elim lt_nat; simpl in |- *; auto. elim andb; simpl in |- *; auto. elim andb; simpl in |- *; auto. intros n f H5 f0. elim f0; simpl in |- *; auto. intros f1 e0 H6. elim lt_nat; simpl in |- *; auto. elim andb; simpl in |- *; auto. intros. inversion X1. intros n e0 H3 f. elim f; simpl in |- *; auto. intros n e0 H3 e1 H4 f. elim f; simpl in |- *; auto. intros n e0 H3 f. elim f; simpl in |- *; auto. intros; apply interpR_mult with x y; algebra. intros; apply interpR_wd with (y[*]x); algebra. apply interpR_mult with y x; algebra. intros; apply interpR_wd with (y[*][1][*]x). apply MI_mult_corr_R; auto. apply interpR_mult with y ([1]:R); algebra. apply (interpR_int R val unop binop pfun 1); algebra. Step_final (x[*](y[*][1])). intros. inversion X0. try (rewrite H0 in H2; rewrite H in X2; rewrite H1 in X3). (* compat 8.0 *) apply interpR_wd with (x0[*](y0[*]y)). apply interpR_mult with x0 (y0[*]y); algebra. Step_final (x0[*]y0[*]y). Qed. Transparent MI_mult. Opaque MV_mult MI_mult. Lemma MM_mult_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (MM_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (MM_mult e2 f) (x[*]y)) -> II (expr_mult e1 e2) x -> II f y -> II (MV_mult (MM_mult e2 f) e1) (x[*]y)). cut (forall (i:Z) (f:expr) (x y:R), II (expr_int i) x -> II f y -> II (MI_mult f (expr_int i)) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros; apply interpR_mult with x y; algebra. intros; apply interpR_wd with (y[*]x); algebra. apply MI_mult_corr_R; auto. intros. inversion X0. try (rewrite H0 in H2; rewrite H in X2; rewrite H1 in X3). (* compat 8.0 *) apply interpR_wd with (y0[*]y[*]x0). apply MV_mult_corr_R; auto. astepl (x0[*](y0[*]y)). Step_final (x0[*]y0[*]y). Qed. Transparent MV_mult MI_mult. Opaque MV_mult. Lemma MM_plus_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (MM_plus e f) (x[+]y). Proof. cut (forall (i j:Z) (x y:R), II (expr_int i) x -> II (expr_int j) y -> II (expr_int (i + j)) (x[+]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_plus e f) (x[+]y)). intros H H0 e; elim e. simpl in |- *; auto. intros z f; elim f; simpl in |- *; auto. simpl in |- *; auto. intros e1 H1 e2 H2. elim e1; simpl in |- *; auto. intros n f. elim f; simpl in |- *; auto. intros f1 H3 f2 H4. elim f1; simpl in |- *; auto. intro m. cut (eq_nat n m = true -> n = m). elim (eq_nat n m); simpl in |- *; auto. intros. inversion X. try (rewrite H6 in X1; rewrite H8 in X2; rewrite H7 in H9). (* compat 8.0 *) inversion X0. try (rewrite H10 in X3; rewrite H12 in X4; rewrite H11 in H13). (* compat 8.0 *) apply interpR_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_R; auto. astepl (x0[*](y0[+]y1)). astepl (x0[*]y0[+]x0[*]y1). cut (x0[=]x1). intro. Step_final (x0[*]y0[+]x1[*]y1). apply refl_interpR with val unop binop pfun (expr_var n). assumption. rewrite (H5 (refl_equal true)). assumption. intros; apply eq_nat_corr; auto. intros u e0 H3 f. elim f; simpl in |- *; auto. intros e3 H4 e4 H5. elim e3; simpl in |- *; auto. intros u0 e5 H6. cut (andb (eq_nat u u0) (eq_expr e0 e5) = true -> u = u0). cut (andb (eq_nat u u0) (eq_expr e0 e5) = true -> e0 = e5). elim andb; simpl in |- *; auto. intros H' H''. intros. inversion X. try (rewrite -> H7 in X1; rewrite H9 in X2; rewrite H8 in H10). (* compat 8.0 *) inversion X0. try (rewrite H11 in X3; rewrite H13 in X4; rewrite H12 in H14). (* compat 8.0 *) apply interpR_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_R; auto. astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0). apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr. apply refl_interpR with val unop binop pfun (expr_unop u e0). auto. rewrite H'. rewrite H''. auto. auto. auto. intro. elim (andb_prop _ _ H7); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H7); intros. apply eq_nat_corr; auto. intros u e0 H3 e3 H4 f. elim f; simpl in |- *; auto. intros e4 H5 e5 H6. elim e4; simpl in |- *; auto. intros u0 e6 H7 e7 H8. cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> u = u0). cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> e0 = e6). cut (andb (eq_nat u u0) (andb (eq_expr e0 e6) (eq_expr e3 e7)) = true -> e3 = e7). elim andb; simpl in |- *; auto. intros H' H'' H'''. intros. inversion X. try (rewrite H9 in X1; rewrite H11 in X2; rewrite H10 in H12). (* compat 8.0 *) inversion X0. try (rewrite H13 in X3; rewrite H15 in X4; rewrite H14 in H16). (* compat 8.0 *) apply interpR_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_R; auto. astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0). apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr. apply refl_interpR with val unop binop pfun (expr_binop u e0 e3). auto. rewrite H'. rewrite H''. rewrite H'''. auto. auto. auto. auto. intro. elim (andb_prop _ _ H9); intros. elim (andb_prop _ _ H11); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H9); intros. elim (andb_prop _ _ H11); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H9); intros. apply eq_nat_corr; auto. intros f e0 H3. intro f0. elim f0; simpl in |- *; auto. intros e3 H4 e4 H5. elim e3; simpl in |- *; auto. intros f1 e5 H6. cut (andb (eq_nat f f1) (eq_expr e0 e5) = true -> f = f1). cut (andb (eq_nat f f1) (eq_expr e0 e5) = true -> e0 = e5). elim (andb (eq_nat f f1) (eq_expr e0 e5)); simpl in |- *; auto. intros. inversion X. try (rewrite H9 in X1; rewrite H11 in X2; rewrite H10 in H12). (* compat 8.0 *) inversion X0. try (rewrite H13 in X3; rewrite H15 in X4; rewrite H14 in H16). (* compat 8.0 *) apply interpR_wd with ((y0[+]y1)[*]x0). apply MV_mult_corr_R; auto. astepr (x0[*]y0[+]x1[*]y1). astepl (y0[*]x0[+]y1[*]x0). apply bin_op_wd_unfolded. algebra. astepr (y1[*]x1). apply mult_wdr. apply refl_interpR with val unop binop pfun (expr_part f e0). auto. rewrite H7. rewrite H8; auto. auto. intro. elim (andb_prop _ _ H7); intros. apply eq_expr_corr; auto. intro. elim (andb_prop _ _ H7); intros. apply eq_nat_corr; auto. simpl in |- *; auto. intros u e0 H1 f. elim f; simpl in |- *; auto. intros u e0 H1 e1 H2 f. elim f; simpl in |- *; auto. intros u e0 H1 f. elim f; simpl in |- *; auto. intros; apply interpR_plus with x y; algebra. intros. inversion X. try (rewrite H1 in H0; rewrite H in H0). (* compat 8.0 *) inversion X0. try (rewrite H2 in H3; rewrite H4 in H3). (* compat 8.0 *) apply interpR_wd with (zring (i + j):R). apply interpR_int; algebra. Step_final (zring i[+]zring j:R). Qed. Transparent MV_mult. Opaque MM_plus. Lemma PM_plus_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (PM_plus e f) (x[+]y). Proof. cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (PM_plus e2 f) (x[+]y)) -> II (expr_plus e1 e2) x -> II f y -> II (expr_plus e1 (PM_plus e2 f)) (x[+]y)). cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (PM_plus e2 f) (x[+]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PM_plus e2 (MM_plus e1 f)) (x[+]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (MM_plus e f) (x[+]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_plus e f) (x[+]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_plus f e) (x[+]y)). intros H H0 H1 H2 H3 e. elim e. simpl in |- *; auto. intros z f; elim f; intros; simpl in |- *; auto. intros e1 H4 e2 H5 f. simpl in |- *. elim (lt_monom e1 f); elim (eq_monom e1 f); elim f; intros; simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. simpl in |- *; auto. intros; apply interpR_wd with (y[+]x); algebra. apply interpR_plus with y x; algebra. intros; apply interpR_plus with x y; algebra. intros; apply MM_plus_corr_R; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (y0[+](x0[+]y)). apply X; auto. apply MM_plus_corr_R; auto. astepl (y0[+]x0[+]y). Step_final (x0[+]y0[+]y). intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (x0[+](y0[+]y)). apply interpR_plus with x0 (y0[+]y); algebra. Step_final (x0[+]y0[+]y). Qed. Transparent MM_plus. Opaque PM_plus. Lemma PP_plus_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (PP_plus e f) (x[+]y). Proof. cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (PP_plus e2 f) (x[+]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PM_plus (PP_plus e2 f) e1) (x[+]y)). cut (forall (i:Z) (f:expr) (x y:R), II (expr_int i) x -> II f y -> II (PM_plus f (expr_int i)) (x[+]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_plus e f) (x[+]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros. apply interpR_plus with x y; algebra. intros. apply interpR_wd with (y[+]x); algebra. apply PM_plus_corr_R; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (y0[+]y[+]x0). apply PM_plus_corr_R; auto. astepl (x0[+](y0[+]y)). Step_final (x0[+]y0[+]y). Qed. Transparent PM_plus. Opaque PM_plus MM_mult MI_mult. Lemma PM_mult_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (PM_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (PM_mult e2 f) (x[*]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PM_plus (PM_mult e2 f) (MM_mult e1 f)) (x[*]y)). cut (forall (i:Z) (f:expr) (x y:R), II (expr_int i) x -> II f y -> II (PM_plus (expr_int 0) (MI_mult f (expr_int i))) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros. apply interpR_mult with x y; algebra. intros. apply interpR_wd with (zring 0[+]y[*]x). apply PM_plus_corr_R. apply interpR_int; algebra. apply MI_mult_corr_R; auto. astepl ([0][+]y[*]x). Step_final (y[*]x). intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (y0[*]y[+]x0[*]y). apply PM_plus_corr_R; auto. apply MM_mult_corr_R; auto. astepl ((y0[+]x0)[*]y). Step_final ((x0[+]y0)[*]y). Qed. Opaque PM_mult. Lemma PP_mult_corr_R : forall (e f:expr) (x y:R), II e x -> II f y -> II (PP_mult e f) (x[*]y). Proof. cut (forall (e1 e2 f:expr) (x y:R), (forall (f:expr) (x y:R), II e2 x -> II f y -> II (PP_mult e2 f) (x[*]y)) -> II (expr_plus e1 e2) x -> II f y -> II (PP_plus (PM_mult f e1) (PP_mult e2 f)) (x[*]y)). cut (forall (i:Z) (f:expr) (x y:R), II (expr_int i) x -> II f y -> II (PM_mult f (expr_int i)) (x[*]y)). cut (forall (e f:expr) (x y:R), II e x -> II f y -> II (expr_mult e f) (x[*]y)). intros H H0 H1 e. elim e; intros; simpl in |- *; auto. intros. apply interpR_mult with x y; algebra. intros. apply interpR_wd with (y[*]x); algebra. apply PM_mult_corr_R; auto. intros. inversion X0. try (rewrite H in X2; rewrite H1 in X3; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (y[*]x0[+]y0[*]y). apply PP_plus_corr_R; auto. apply PM_mult_corr_R; auto. astepl (x0[*]y[+]y0[*]y). Step_final ((x0[+]y0)[*]y). Qed. (* Transparent PP_plus PM_mult PP_mult PM_plus MI_mult. Lemma FF_plus_corr_R : (e,f:expr; x,y:R) (II e x)->(II f y)->(II (FF_plus e f) x[+]y). Cut (e1,e2,f1,f2:expr; x,y:R) (II (expr_div e1 e2) x) ->(II (expr_div f1 f2) y) ->(II (expr_div (PP_plus (PP_mult e1 f2) (PP_mult e2 f1)) (PP_mult e2 f2)) x[+]y). Cut (e,f:expr; x,y:R)(II e x)->(II f y)->(II (expr_plus e f) x[+]y). Intros H H0 e f. Elim e; Elim f; Intros; Simpl; Auto. Intros. Apply interpR_plus with x y; algebra. Intros. Inversion H. Inversion H0. Apply interpR_div_one with x[+]y. algebra. Apply interpR_wd with x0[*][1][+][1][*]x1. Apply PP_plus_corr_R; Apply PP_mult_corr_R; Auto; Apply interpR_int with k:=`1`; algebra. Step_final x0[+]x1. Apply interpR_wd with ([1]::R)[*][1]; algebra. Apply PP_mult_corr_R; Auto. Qed. Lemma FF_mult_corr_R : (e,f:expr; x,y:R) (II e x)->(II f y)->(II (FF_mult e f) x[*]y). Cut (e1,e2,f1,f2:expr; x,y:R) (II (expr_div e1 e2) x) ->(II (expr_div f1 f2) y) ->(II (expr_div (PP_mult e1 f1) (PP_mult e2 f2)) x[*]y). Cut (e,f:expr; x,y:R)(II e x)->(II f y)->(II (expr_mult e f) x[*]y). Intros H H0 e f. Elim e; Elim f; Intros; Simpl; Auto. Intros. Apply interpR_mult with x y; algebra. Intros. Inversion H. Inversion H0. Apply interpR_div_one with x0[*]x1. algebra. Apply PP_mult_corr_R; Auto. Apply interpR_wd with ([1]::R)[*][1]; algebra. Apply PP_mult_corr_R; Auto. Qed. Transparent FF_div. Lemma FF_div_corr_R : (e,f:expr; x:R) (II (expr_div e f) x)->(II (FF_div e f) x). Intro e; Case e; Simpl; Auto. Intros e0 e1 f; Case f; Simpl; Auto. Intros. Inversion H; Simpl. Inversion H3; Inversion H5. Apply interpR_div_one with x1[*][1]. astepl x1. Step_final x0. Apply PP_mult_corr_R; Auto. Apply interpR_wd with [1][*]x2. Apply PP_mult_corr_R; Auto. Step_final x2. Qed. *) Lemma NormR_corr : forall (e:expr) (x:R), II e x -> II (NormR e) x. Proof. intro; induction e; intros; simpl in |- *. apply (interpR_plus R val unop binop pfun (expr_mult (expr_var v) expr_one) expr_zero x ([0]:R) x). algebra. apply (interpR_mult R val unop binop pfun (expr_var v) expr_one x ([1]:R) x); algebra. apply (interpR_int R val unop binop pfun 1); algebra. apply (interpR_int R val unop binop pfun 0); algebra. assumption. inversion X. try (rewrite H in X0; rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (x0[+]y). apply PP_plus_corr_R; auto. auto. inversion X. try (rewrite H in X0; rewrite H1 in X1; rewrite H0 in H2). (* compat 8.0 *) apply interpR_wd with (x0[*]y). apply PP_mult_corr_R; auto. auto. assumption. inversion X. try (rewrite H in H2; rewrite H1 in X0; rewrite H0 in H2). (* compat 8.0 *) apply (interpR_plus R val unop binop pfun (expr_mult (expr_unop u (NormR e)) expr_one) expr_zero x ( [0]:R) x). algebra. apply (interpR_mult R val unop binop pfun (expr_unop u (NormR e)) expr_one x ([1]:R) x); algebra. apply (interpR_unop R val unop binop pfun (NormR e) u x0); algebra. apply (interpR_int R val unop binop pfun 1); algebra. apply (interpR_int R val unop binop pfun 0); algebra. inversion X. (* compat 8.0 *) try (rewrite H in H3; rewrite H1 in X0; rewrite H2 in X1; rewrite H0 in H3). apply (interpR_plus R val unop binop pfun (expr_mult (expr_binop b (NormR e1) (NormR e2)) expr_one) expr_zero x ([0]:R) x). algebra. apply (interpR_mult R val unop binop pfun (expr_binop b (NormR e1) (NormR e2)) expr_one x ([1]:R) x); algebra. apply (interpR_binop R val unop binop pfun (NormR e1) (NormR e2) b x0 y); algebra. apply (interpR_int R val unop binop pfun 1); algebra. apply (interpR_int R val unop binop pfun 0); algebra. inversion X. try ((generalize Hx H2; clear Hx H2; rewrite H; intros Hx H2); rewrite H1 in X0; rewrite H0 in H2). (* compat 8.0 *) apply (interpR_plus R val unop binop pfun (expr_mult (expr_part p (NormR e)) expr_one) expr_zero x ( [0]:R) x). algebra. apply (interpR_mult R val unop binop pfun (expr_part p (NormR e)) expr_one x ([1]:R) x); algebra. apply (interpR_part R val unop binop pfun (NormR e) p x0) with (Hx := Hx); algebra. apply (interpR_int R val unop binop pfun 1); algebra. apply (interpR_int R val unop binop pfun 0); algebra. Qed. Lemma Tactic_lemmaR : forall (x y:R) (e:xexprR R val unop binop pfun x) (f:xexprR R val unop binop pfun y), eq_expr (NormR (xforgetR _ _ _ _ _ _ e)) (NormR (xforgetR _ _ _ _ _ _ f)) = true -> x[=]y. Proof. intros x y e f H. apply refl_interpR with val unop binop pfun (NormR (xforgetR _ _ _ _ _ _ e)). apply NormR_corr; apply xexprR2interpR. rewrite (eq_expr_corr _ _ H). apply NormR_corr; apply xexprR2interpR. Qed. End Ring_NormCorrect. Ltac QuoteR R l t := match l with (Quad ?vl ?ul ?bl ?pl) => (let a := constr:(fun n:varindex => (Mnth n vl (cm_unit R))) in let b := constr:(fun n:unopindex => (Mnth n ul (@cg_inv R))) in let c := constr:(fun n:binopindex => (Mnth n bl (@csg_op R))) in let d := constr:(fun n:pfunindex => (Mnth n pl (total_eq_part _ (@cg_inv R)))) in match t with | (zring ?k) => match (ClosedZ k) with | true => constr:(xexprR_int R a b c d k) end | (csbf_fun _ _ _ csg_op ?x ?y) => let x' := QuoteR R l x in let y' := QuoteR R l y in constr:(xexprR_plus R a b c d _ _ x' y') | (csbf_fun _ _ _ cr_mult ?x ?y) => let x' := QuoteR R l x in let y' := QuoteR R l y in constr:(xexprR_mult R a b c d _ _ x' y') | ([0]) => constr:(xexprR_zero R a b c d) | ([1]) => constr:(xexprR_one R a b c d) | (nring ?n) => match (ClosedNat n) with | true => constr:(xexprR_nat R a b c d n) end | (csf_fun _ _ cg_inv ?x) => let x' := QuoteR R l x in constr:(xexprR_inv R a b c d _ x') | (cg_minus ?x ?y) => let x' := QuoteR R l x in let y' := QuoteR R l y in constr:(xexprR_minus R a b c d _ _ x' y') | (csf_fun _ _ (@nexp_op _ ?n) ?x) => match (ClosedNat n) with | true => let x' := QuoteR R l x in constr:(xexprR_power R a b c d _ x' n) end | (pfpfun ?f ?x ?h) => let x' := QuoteR R l x in let i := FindIndex f pl in constr:(xexprR_part R a b c d _ i x' h) | (csf_fun _ _ ?f ?x) => let x' := QuoteR R l x in let i := FindIndex f ul in constr:(xexprR_unop R a b c d _ i x') | (csbf_fun _ _ _ ?f ?x ?y) => let x' := QuoteR R l x in let y' := QuoteR R l y in let i := FindIndex f bl in constr:(xexprR_binop R a b c d _ _ i x' y') | ?t => let i := FindIndex t vl in constr:(xexprR_var R a b c d i) end) end. Ltac FindTermVariablesR t l := match t with | (zring ?k) => match (ClosedZ k) with | true => constr:(l) end | (csbf_fun _ _ _ csg_op ?x ?y) => let l1 := FindTermVariablesR x l in let l2 := FindTermVariablesR y l1 in constr:(l2) | (csbf_fun _ _ _ cr_mult ?x ?y) => let l1 := FindTermVariablesR x l in let l2 := FindTermVariablesR y l1 in constr:(l2) | ([0]) => constr:(l) | ([1]) => constr:(l) | (nring ?n) => match (ClosedNat n) with | true => constr:(l) end | (csf_fun _ _ cg_inv ?x) => let l1 := FindTermVariablesR x l in constr:(l1) | (cg_minus ?x ?y) => let l1 := FindTermVariablesR x l in let l2 := FindTermVariablesR y l1 in constr:(l2) | (csf_fun _ _ (@nexp_op _ ?n) ?x) => match (ClosedNat n) with | true => let l1 := FindTermVariablesR x l in constr:(l1) end | (pfpfun ?f ?x ?h) => let l1 := FindTermVariablesR x l in match l1 with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl ul bl (Mcons f pl)) end | (csf_fun _ _ ?f ?x) => let l1 := FindTermVariablesR x l in match l1 with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl (Mcons f ul) bl pl) end | (csbf_fun _ _ _ ?f ?x ?y) => let l1 := FindTermVariablesR x l in let l2 := FindTermVariablesR y l1 in match l2 with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad vl ul (Mcons f bl) pl) end | ?t => match l with (Quad ?vl ?ul ?bl ?pl) => constr:(Quad (Mcons t vl) ul bl pl) end end. Ltac FindTermsVariablesR fn t1 t2 := let l1 := FindTermVariablesR t1 (Quad (Mnil fn) (Mnil (CSetoid_un_op fn)) (Mnil (CSetoid_bin_op fn)) (Mnil (PartFunct fn))) in let l2 := FindTermVariablesR t2 l1 in constr:(l2). Ltac rationalR R x y := let l:=FindTermsVariablesR R x y in let t1:=(QuoteR R l x) in let t2:=(QuoteR R l y) in eapply Tactic_lemmaR with (e:=t1) (f:=t2) ; reflexivity. (* end hide *) corn-8.20.0/tactics/Step.v000066400000000000000000000025661473720167500153230ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (* begin hide *) Ltac algebra := auto with algebra_r algebra algebra_c algebra_s. Ltac astepl x := stepl x; [idtac | algebra]. Ltac astepr x := stepr x; [idtac | algebra]. Tactic Notation "astepl" constr(c) := astepl c. Tactic Notation "astepr" constr(c) := astepr c. Ltac Included := eauto with included. corn-8.20.0/tactics/csetoid_rewrite.v000066400000000000000000001626701473720167500176060ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** 200904: first experimental version submitted to corn; things need to be improved and cleaned up!; hendriks@cs.ru.nl *) (* 110204: renamed setoid_rewrite into csetoid_rewrite in order to avoid name clashes with setoid_rewrite in Coq's initial environment. *) Ltac typeof x := type of x. (* Quickly secure "type of" before the following Require brings in ssreflect which destroys it. *) Require Export CoRN.algebra.CSetoidFun. Section move_us. Lemma csr_wd : forall (S:CSetoid) (R:CSetoid_relation S) (x1 x2 y1 y2:S), R x1 x2 -> (x1[=]y1) -> (x2[=]y2) -> R y1 y2. Proof fun S R x1 x2 y1 y2 h h0 h1 => csr_wdl S R x1 y2 y1 (csr_wdr S R x1 x2 y2 h h1) h0. Lemma Ccsr_wd : forall (S:CSetoid) (R:CCSetoid_relation S) (x1 x2 y1 y2:S), R x1 x2 -> (x1[=]y1) -> (x2[=]y2) -> R y1 y2. Proof fun S R x1 x2 y1 y2 h h0 h1 => Ccsr_wdl S R x1 y2 y1 (Ccsr_wdr S R x1 x2 y2 h h1) h0. Lemma eq_wd : forall (S:CSetoid) (x1 x2 y1 y2:S), (x1[=]x2) -> (x1[=]y1) -> (x2[=]y2) -> y1[=]y2. Proof fun S x1 x2 y1 y2 h h0 h1 => eq_transitive S y1 x1 y2 (eq_symmetric S x1 y1 h0) (eq_transitive S x1 x2 y2 h h1). Lemma ap_wd : forall (S:CSetoid) (x1 x2 y1 y2:S), (x1[#]x2) -> (x1[=]y1) -> (x2[=]y2) -> y1[#]y2. Proof fun S x1 x2 y1 y2 h h0 h1 => ap_wdl S x1 y2 y1 (ap_wdr S x1 x2 y2 h h1) h0. Lemma CAnd_proj1 : forall A B:CProp, A and B -> A. Proof. intros A B h; elim h; exact (fun a _ => a). Qed. Lemma CAnd_proj2 : forall A B:CProp, A and B -> B. Proof. intros A B h; elim h; exact (fun _ b => b). Qed. Lemma COr_elim : forall A B C:CProp, (A -> C) -> (B -> C) -> A or B -> C. Proof. intros A B C H H0 H1. elim H1; intro H2; [ exact (H H2) | exact (H0 H2) ]. Qed. End move_us. (** Definition of [csetoid_rewrite]: a rewrite tactic for setoid equality; it rewrites within formulae of type [Prop] and [CProp], built up from connectives [->], [and], [CAnd], [or], [COr], [iff], [Iff], [not], [Not], [CNot], and atomic formulae [(P t)], [(R t s)], [t[=]s], [t[#]s] for [T:CSetoid], [t,s:T], [P:(CSetoid_predicate T)], [R:(CSetoid_relation T)], [R:(CCSetoid_relation T)]. Note that atoms are built up from predicates and relations that are well-defined with respect to setoid equality. Setoid terms of type [T] are terms constructed by [(f s)], [(g s s')], [(h s s_)], where [f:(CSetoid_fun S T)], [g:(CSetoid_bin_fun S S' T)], [h:(CSetoid_part_fun S T)], [s:S], [s':S'], [s_:(cspf_dom S T f s)]; needless to say, those setoid functions respect setoid equality. Tactic [csetoid_rewrite] is composed of tactics [total_csetoid_rewrite] and [partial_csetoid_rewrite]. The former is applied in case there are no partial setoid functions present in the goal. The latter if there are. We further explain this separation. To define the rewrite tactic we use the method of reflection, see [1]. Because we have to deal with partial functions (see the definition of [CSetoid_part_fun] in file [CSetoids.v]), we use %\emph{partial}% #partial# reflection, see [2]. Partial reflection means to have an interpretation %\emph{relation}%#relation# instead of an interpretation function. Unfortunately, we were unable to define our tactic for the most general case, that is, for terms that contain both partial functions as well as setoid functions whose domain(s) and co-domain are not necessarily the same. When proving lemmas involving statements [e II^r t] (saying [t] is an interpretation of syntactic expression [e] under the variable assigment [r], one often needs to reason by induction over [e] and then inverting the so obtained instances of the inductively defined [e II^rho t]. However, in the general case where we have to deal with functions whose domain and co-domain differ, inversion doesn't yield the desired result. Consider, for instance, [var II^r t]. Here, we want to perform inversion and obtain [t=r], for [var II^r r] is a defining clause of [II] and moreover the only one mentioning [var]. However, inversion returns somthing like [ = ]. This has got to do with the so-called elimination predicate which predicts the type of the outcome of a case analysis dependent on the destructed variable. For more info ask the author and see his related # mail# to the coq-club. We opted for the next best option of using two tactics, one using total reflection, its application being restricted to terms constructed from total functions (domain(s) and co-domain are allowed to be distinct). The other using partial reflection, its application being restricted to terms built up from (partial as well as total) %\emph{operations}% #operations# (i.e.%\% functions whose domain(s) and co-domain are equal). References: [1] Boutin, "Using Reflection to Build Efficient and Certified Decision Procedures", TACS, LNCS 1281, pp.%\% 515--529, 1997. [2] Geuvers, Wiedijk and Zwanenburg, "Equational Reasoning via Partial Reflection", TPHOLs, LNCS 1896, pp.%\% 162--178, 2000. *) (*Section total_csetoid_rewrite.*) Section syntactic_total_setoid_expressions. (** Syntactic setoid expressions reflecting setoid terms built from total setoid functions. [S] is the setoid of the subterm to be replaced. *) Inductive tot_set_exp (S:CSetoid) : CSetoid -> Type := | tse_var : tot_set_exp S S | tse_fun : forall T1 T2:CSetoid, CSetoid_fun T1 T2 -> tot_set_exp S T1 -> tot_set_exp S T2 | tse_bfun : forall T1 T2 T3:CSetoid, CSetoid_bin_fun T1 T2 T3 -> tot_set_exp S T1 -> tot_set_exp S T2 -> tot_set_exp S T3 | tse_con : forall T:CSetoid, T -> tot_set_exp S T. (** Interpretation of `total' setoid expressions. *) Fixpoint tse_int (S T:CSetoid) (r:S) (e:tot_set_exp S T) {struct e} : T := match e with | tse_var _ => r | tse_fun _ T1 T2 f e0 => f (tse_int S T1 r e0) | tse_bfun _ T1 T2 T3 f e1 e2 => f (tse_int S T1 r e1) (tse_int S T2 r e2) | tse_con _ T t => t end. (** [tse_int] is well-defined. *) Lemma tse_int_wd : forall (S T:CSetoid) (r1 r2:S), (r1[=]r2) -> forall e:tot_set_exp S T, tse_int S T r1 e[=]tse_int S T r2 e. Proof. intros S T r1 r2 h. induction e; simpl in |- *. exact h. apply csf_wd; assumption. apply csbf_wd; assumption. apply eq_reflexive. Qed. End syntactic_total_setoid_expressions. (** The `quote function' maps setoid terms [t:T] to syntactic expressions [(tot_set_exp S T)]; term [r:S] (supposed to be a subterm of [t:T] to be replaced later on) is mapped to [(tse_var r)]. Other `leafs' [t0:T'] of [t] are mapped to [(tse_con S T' t0)]. *) Ltac tse_quote S T r t := match constr:(t) with | r => constr:(tse_var S) | (csf_fun ?X1 ?X2 ?X3 ?X4) => let T1 := constr:(X1) with T2 := constr:(X2) with f := constr:(X3) with t0 := constr:(X4) in let e := tse_quote S T1 r t0 in constr:(tse_fun S T1 T2 f e) | (csbf_fun ?X1 ?X2 ?X3 ?X4 ?X5 ?X6) => let T1 := constr:(X1) with T2 := constr:(X2) with T3 := constr:(X3) with f := constr:(X4) with t1 := constr:(X5) with t2 := constr:(X6) in let e1 := tse_quote S T1 r t1 with e2 := tse_quote S T2 r t2 in constr:(tse_bfun S T1 T2 T3 f e1 e2) | ?X1 => let t0 := constr:(X1) in constr:(tse_con S T t0) end. (** Given [S:CSetoid;r1,r2:S] and [A:Prop] or [A:CProp], [(replace_in_formula1 S r1 r2 A)] replaces all occurrences of subterm [r1] in [A] by [r2]. *) Ltac tot_repl_in_form S r1 r2 A := match constr:(A) with | (csp_pred ?X1 ?X2 ?X3) => let T := constr:(X1) with P := constr:(X2) with t := constr:(X3) in let e := tse_quote S T r1 t in let r := constr:(tse_int S T r2 e) in constr:(P r) | (csr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) in constr:(R r1 r2) | (Ccsr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) in constr:(R r1 r2) | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) in constr:(cs_eq (r:=T) r1 r2) | (cs_ap (c:=?X1) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) in constr:(cs_ap (c:=T) r1 r2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(B1 -> B2) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(B1 /\ B2) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(B1 and B2) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(B1 \/ B2) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(B1 or B2) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(B1 <-> B2) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := tot_repl_in_form S r1 r2 A1 with B2 := tot_repl_in_form S r1 r2 A2 in constr:(Iff B1 B2) | (~ ?X1) => let A0 := constr:(X1) in let B0 := tot_repl_in_form S r1 r2 A0 in constr:(~ B0) | (Not ?X1) => let A0 := constr:(X1) in let B0 := tot_repl_in_form S r1 r2 A0 in constr:(Not B0) (* | (CNot ?X1) => let A0 := constr:X1 in let B0 := tot_repl_in_form S r1 r2 A0 in constr:(CNot B0)*) | ?X1 => let A0 := constr:(X1) in constr:(A0) end. (** Given [S:CSetoid;r1,r2:S;h:r1[=]r2;h0:r2[=]r1] and [A:CProp] or [A:Prop], we get [(tot_set_rewr_prf1 S r1 r2 h h0 A) : A->A[r1:=r2]] and [(tot_set_rewr_prf2 S r1 r2 h h0 A) : A[r1:=r2]->A] where [A[r1:=r2]] denotes [(tot_repl_in_form S r1 r2 A)]. The argument [h0:r2[=]r1] is present to avoid iterated application of [eq_symmetric]. *) Ltac tot_set_rewr_prf1 S r1 r2 h h0 A := match constr:(A) with | (csp_pred ?X1 ?X2 ?X3) => let T := constr:(X1) with P := constr:(X2) with t := constr:(X3) in let e := tse_quote S T r1 t in let s := constr:(tse_int S T r1 e) with r := constr:(tse_int S T r2 e) with d := constr:(tse_int_wd S T r1 r2 h e) in constr:(fun a:P s => csp_wd T P s r a d) | (csr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r1 r2 h e1) with d2 := constr:(tse_int_wd S T r1 r2 h e2) in constr:(fun a:R s1 s2 => csr_wd T R s1 s2 r1 r2 a d1 d2) | (Ccsr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r1 r2 h e1) with d2 := constr:(tse_int_wd S T r1 r2 h e2) in constr:(fun a:R s1 s2 => Ccsr_wd T R s1 s2 r1 r2 a d1 d2) | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r1 r2 h e1) with d2 := constr:(tse_int_wd S T r1 r2 h e2) in constr:(fun a:cs_eq (r:=T) s1 s2 => eq_wd T s1 s2 r1 r2 a d1 d2) | (cs_ap (c:=?X1) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r1 r2 h e1) with d2 := constr:(tse_int_wd S T r1 r2 h e2) in constr:(fun a:cs_ap (c:=T) s1 s2 => ap_wd T s1 s2 r1 r2 a d1 d2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf1 S r1 r2 h h0 A2 with d2 := tot_set_rewr_prf2 S r1 r2 h h0 A1 in constr:(fun (p:A1 -> A2) b => d1 (p (d2 b))) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 in constr:(fun p:A1 /\ A2 => conj (d1 (fst p)) (d2 (snd p))) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 in constr:(fun p:A1 and A2 => pair _ _ (d1 (CAnd_proj1 _ _ p)) (d2 (CAnd_proj2 _ _ p))) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 in constr:(or_ind (fun a => or_introl _ (d1 a)) (fun a => or_intror _ (d2 a))) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 in constr:(COr_elim A1 A2 _ (fun a => inl _ _ (d1 a)) (fun a => inr _ _ (d2 a))) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with ab2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 with ba1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with ba2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun p:A1 <-> A2 => conj (fun b1 => ab2 (fst p (ba1 b1))) (fun b2 => ab1 (snd p (ba2 b2)))) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with ab2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 with ba1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with ba2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun p:Iff A1 A2 => pair (fun b1 => ab2 (CAnd_proj1 _ _ p (ba1 b1))) (fun b2 => ab1 (CAnd_proj2 _ _ p (ba2 b2)))) | (~ ?X1) => let A0 := constr:(X1) in let d := tot_set_rewr_prf2 S r1 r2 h h0 A0 in constr:(fun (p:~ A0) b => p (d b)) | (Not ?X1) => let A0 := constr:(X1) in let d := tot_set_rewr_prf2 S r1 r2 h h0 A0 in constr:(fun (p:Not A0) b => p (d b)) (* | (CNot ?X1) => let A0 := constr:X1 in let d := tot_set_rewr_prf2 S r1 r2 h h0 A0 in constr:(fun (p:CNot A0) b => p (d b)) *) | ?X1 => let A0 := constr:(X1) in constr:(fun a:A0 => a) end with tot_set_rewr_prf2 S r1 r2 h h0 A := match constr:(A) with | (csp_pred ?X1 ?X2 ?X3) => let T := constr:(X1) with P := constr:(X2) with t := constr:(X3) in let e := tse_quote S T r1 t in let s := constr:(tse_int S T r1 e) with r := constr:(tse_int S T r2 e) with d := constr:(tse_int_wd S T r2 r1 h0 e) in constr:(fun b:P r => csp_wd T P r s b d) | (csr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r2 r1 h0 e1) with d2 := constr:(tse_int_wd S T r2 r1 h0 e2) in constr:(fun b:R r1 r2 => csr_wd T R r1 r2 s1 s2 b d1 d2) | (Ccsr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r2 r1 h0 e1) with d2 := constr:(tse_int_wd S T r2 r1 h0 e2) in constr:(fun b:R r1 r2 => Ccsr_wd T R r1 r2 s1 s2 b d1 d2) | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r2 r1 h0 e1) with d2 := constr:(tse_int_wd S T r2 r1 h0 e2) in constr:(fun b:cs_eq (r:=T) r1 r2 => eq_wd T r1 r2 s1 s2 b d1 d2) | (cs_ap (c:=?X1) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := tse_quote S T r1 t1 with e2 := tse_quote S T r1 t2 in let s1 := constr:(tse_int S T r1 e1) with s2 := constr:(tse_int S T r1 e2) with r1 := constr:(tse_int S T r2 e1) with r2 := constr:(tse_int S T r2 e2) with d1 := constr:(tse_int_wd S T r2 r1 h0 e1) with d2 := constr:(tse_int_wd S T r2 r1 h0 e2) in constr:(fun b:cs_ap (c:=T) r1 r2 => ap_wd T r1 r2 s1 s2 b d1 d2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun q (a:A1) => d2 (q (d1 a))) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun q:_ /\ _ => conj (d1 (fst q)) (d2 (snd q))) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun q:_ and _ => @pair A1 A2 (d1 (CAnd_proj1 _ _ q)) (d2 (CAnd_proj2 _ _ q))) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(or_ind (fun b => or_introl A2 (d1 b)) (fun b => or_intror A1 (d2 b))) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with d2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(COr_elim _ _ (A1 or A2) (fun b => inl A1 A2 (d1 b)) (fun b => inr A1 A2 (d2 b))) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with ab2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 with ba1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with ba2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun q:_ <-> _ => conj (fun a1:A1 => ba2 (fst q (ab1 a1))) (fun a2:A2 => ba1 (snd q (ab2 a2)))) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := tot_set_rewr_prf1 S r1 r2 h h0 A1 with ab2 := tot_set_rewr_prf1 S r1 r2 h h0 A2 with ba1 := tot_set_rewr_prf2 S r1 r2 h h0 A1 with ba2 := tot_set_rewr_prf2 S r1 r2 h h0 A2 in constr:(fun q:Iff _ _ => pair (fun a1:A1 => ba2 (CAnd_proj1 _ _ q (ab1 a1))) (fun a2:A2 => ba1 (CAnd_proj2 _ _ q (ab2 a2)))) | (~ ?X1) => let A0 := constr:(X1) in let d := tot_set_rewr_prf1 S r1 r2 h h0 A0 in constr:(fun (q:~ _) (a:A0) => q (d a)) | (Not ?X1) => let A0 := constr:(X1) in let d := tot_set_rewr_prf1 S r1 r2 h h0 A0 in constr:(fun (q:Not _) (a:A0) => q (d a)) (* | (CNot ?X1) => let A0 := constr:X1 in let d := tot_set_rewr_prf1 S r1 r2 h h0 A0 in constr:(fun (q:CNot _) (a:A0) => q (d a))*) | ?X1 => let A0 := constr:(X1) in constr:(fun a:A0 => a) end. (* rewrite -> h *) Ltac total_csetoid_rewrite h := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let S := constr:(X1) with r1 := constr:(X2) with r2 := constr:(X3) in let h0 := constr:(eq_symmetric S r1 r2 h) in match goal with | |- ?X1 => let A := constr:(X1) in let B := tot_repl_in_form S r1 r2 A with d := tot_set_rewr_prf2 S r1 r2 h h0 A in ((*:B->A*) cut B; [ exact d | unfold tse_int in |- * ]) end end. (* rewrite <- h *) Ltac total_csetoid_rewrite_rev h := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let S := constr:(X1) with r2 := constr:(X2) with r1 := constr:(X3) in let h0 := constr:(eq_symmetric S r2 r1 h) in match goal with | |- ?X1 => let A := constr:(X1) in let B := tot_repl_in_form S r1 r2 A with d := tot_set_rewr_prf2 S r1 r2 h0 h A in ((*:B->A*) cut B; [ exact d | unfold tse_int in |- * ]) end end. (* rewrite -> h in h0 *) Ltac total_csetoid_rewrite_cxt h h0 := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let S := constr:(X1) with r1 := constr:(X2) with r2 := constr:(X3) in let h1 := constr:(eq_symmetric S r1 r2 h) with A := typeof h0 in let B := tot_repl_in_form S r1 r2 A with d := tot_set_rewr_prf1 S r1 r2 h h1 A in ((*:A->B*) cut B; [ unfold tse_int in |- *; clear h0; intro h0 | exact (d h0) ]) end. (* rewrite <- h in h0 *) Ltac total_csetoid_rewrite_cxt_rev h h0 := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let S := constr:(X1) with r2 := constr:(X2) with r1 := constr:(X3) in let h1 := constr:(eq_symmetric S r2 r1 h) with A := typeof h0 in let B := tot_repl_in_form S r1 r2 A with d := tot_set_rewr_prf1 S r1 r2 h1 h A in ((*:A->B*) cut B; [ unfold tse_int in |- *; clear h0; intro h0 | exact (d h0) ]) end. (* replace x with y *) Ltac total_setoid_replace x y := let h := fresh in (cut (x[=]y); [ intro h; total_csetoid_rewrite h; clear h | idtac ]). (* replace x with y in h *) Ltac total_setoid_replace_cxt x y h := let h0 := fresh in (cut (x[=]y); [ intro h0; total_csetoid_rewrite_cxt h0 h; clear h0 | idtac ]). (*End total_csetoid_rewrite.*) (*Section partial_csetoid_rewrite.*) (* tbd: new CSetoids.v: *) Definition CSetoid_part_op := PartFunct. Definition cspf_dom (T _:CSetoid) := pfdom T. Definition cspf_dom_wd (T _:CSetoid) := dom_wd T. Definition cspf_wd (T:CSetoid) := pfwdef T. (* to avoid universe inconsistencies (tbd: explain *) Inductive my_sigT (A:Type) (P:A -> Type) : Type := my_existT : forall x:A, P x -> my_sigT A P. Definition proj1_my_sigT (A:Type) (P:A -> Type) (e:my_sigT A P) := match e with | my_existT _ _ a b => a end. Definition proj2_my_sigT (A:Type) (P:A -> Type) (e:my_sigT A P) := match e return P (proj1_my_sigT A P e) with | my_existT _ _ a b => b end. Set Implicit Arguments. Unset Strict Implicit. Section syntactic_partial_setoid_expressions. Variable T : CSetoid. Inductive part_set_exp : Type := | pse_var : part_set_exp | pse_uop : CSetoid_un_op T -> part_set_exp -> part_set_exp | pse_bop : CSetoid_bin_op T -> part_set_exp -> part_set_exp -> part_set_exp | pse_pop : CSetoid_part_op T -> part_set_exp -> part_set_exp | pse_con : T -> part_set_exp. (** Interpretation as a relation between syntactic expressions and (semantical) setoid terms; [r] is the term to be replaced (later on). *) Variable r : T. Inductive pse_int : part_set_exp -> T -> Type := | pse_int_var : pse_int pse_var r | pse_int_uop : forall (F:CSetoid_un_op T) (e:part_set_exp) (t:T), pse_int e t -> pse_int (pse_uop F e) (F t) | pse_int_bop : forall (F:CSetoid_bin_op T) (e1 e2:part_set_exp) (t1 t2:T), pse_int e1 t1 -> pse_int e2 t2 -> pse_int (pse_bop F e1 e2) (F t1 t2) | pse_int_pop : forall (F:CSetoid_part_op T) (e:part_set_exp) (t:T), pse_int e t -> forall Ht:cspf_dom T T F t, pse_int (pse_pop F e) (F t Ht) | pse_int_con : forall t:T, pse_int (pse_con t) t. (** `Heavy' syntactic expressions, carrying their own interpretation. *) Inductive part_set_xexp : T -> Type := | psxe_var : part_set_xexp r | psxe_uop : forall (F:CSetoid_un_op T) (t:T), part_set_xexp t -> part_set_xexp (F t) | psxe_bop : forall (F:CSetoid_bin_op T) (t1 t2:T), part_set_xexp t1 -> part_set_xexp t2 -> part_set_xexp (F t1 t2) | psxe_pop : forall (F:CSetoid_part_op T) (t:T) (Ht:cspf_dom T T F t), part_set_xexp t -> part_set_xexp (F t Ht) | psxe_con : forall t:T, part_set_xexp t. (** Interpretation of proof loaded (`heavy') syntactic expressions; extracts the semantical component from heavy expressions. *) Definition psxe_int t (_:part_set_xexp t) := t. (** The forgetful mapping from heavy to light syntactic expressions; extracts the syntactical component from heavy expressions. *) Fixpoint forget (t:T) (e:part_set_xexp t) {struct e} : part_set_exp := match e with | psxe_var => pse_var | @psxe_uop F t0 e0 => pse_uop F (forget e0) | @psxe_bop F t1 t2 e1 e2 => pse_bop F (forget e1) (forget e2) | @psxe_pop F t0 H e0 => pse_pop F (forget e0) | @psxe_con t => pse_con t end. (** The second extraction of an heavy expression is an interpretation of its first extraction (note [(xexp_int t e)=t]). *) Lemma extract_correct : forall (t:T) (e:part_set_xexp t), pse_int (forget e) t. Proof. simple induction e; clear e t; simpl in |- *. exact pse_int_var. intros F t e h. apply pse_int_uop; exact h. intros F t1 t2 e1 h1 e2 h2. apply pse_int_bop with (1 := h1) (2 := h2). intros F t Ht e h. apply pse_int_pop; exact h. exact pse_int_con. Defined. Lemma pse_int_var_inv : forall t:T, pse_int pse_var t -> t = r. Proof. intros t h; inversion h; reflexivity. Defined. Lemma pse_int_con_inv : forall c t:T, pse_int (pse_con c) t -> t = c. Proof. intros c t h; inversion h; reflexivity. Defined. (** The interpretation relation [pse_int] is a partial function. *) Lemma pse_int_ext : forall (e:part_set_exp) (t t':T), pse_int e t -> pse_int e t' -> t[=]t'. Proof. simple induction e; clear e. intros t t' h h0. rewrite (pse_int_var_inv h). rewrite (pse_int_var_inv h0). apply eq_reflexive. intros F e IH t t' h h0. inversion_clear h; inversion_clear h0. apply csf_wd; apply IH; assumption. intros F e1 IH1 e2 IH2 t t' h h0. inversion_clear h; inversion_clear h0. apply csbf_wd; [ apply IH1 | apply IH2 ]; assumption. intros F e IH t t' h h0. inversion_clear h; inversion_clear h0. apply cspf_wd; apply IH; assumption. intros c t t' h h0. rewrite (pse_int_con_inv h). rewrite (pse_int_con_inv h0). apply eq_reflexive. Qed. End syntactic_partial_setoid_expressions. (** [pse_int] is well-founded. *) Lemma pse_int_wd : forall (T:CSetoid) (r r':T), (r[=]r') -> forall (e:part_set_exp T) (t t':T), pse_int r e t -> pse_int r' e t' -> t[=]t'. Proof. intros T r r' h. simple induction e; clear e. intros t t' h0 h1. rewrite (pse_int_var_inv h0). rewrite (pse_int_var_inv h1). exact h. intros F e IH t t' h0 h1. inversion_clear h0; inversion_clear h1. apply csf_wd; apply IH; assumption. intros F e1 IH1 e2 IH2 t t' h0 h1. inversion_clear h0; inversion_clear h1. apply csbf_wd; [ apply IH1 | apply IH2 ]; assumption. intros F e IH t t' h0 h1. inversion_clear h0; inversion_clear h1. apply cspf_wd; apply IH; assumption. intros c t t' h0 h1. rewrite (pse_int_con_inv h0). rewrite (pse_int_con_inv h1). apply eq_reflexive. Defined. (** The following lemma states that if [r1[=]r2] and [t1] is an interpretation of [e] under the variable assigment [r1], then there exists an interpretation [t2] of [e] under the assignment [r2]. *) Lemma replacement_lemma : forall (T:CSetoid) (e:part_set_exp T) (r1 r2 t1:T), (r1[=]r2) -> pse_int r1 e t1 -> my_sigT T (pse_int r2 e). Proof. intros T e r1 r2 t1 H H0. elim H0; clear H0 e t1. exists r2. apply pse_int_var. intros F e a1 Ha1 IH. elim IH; intros a2 Ha2. exists (F a2); apply pse_int_uop with (1 := Ha2). intros F ea a1 eb b1 Ha1 IHa Hb1 IHb. elim IHa; intros a2 Ha2. elim IHb; intros b2 Hb2. exists (F a2 b2); apply pse_int_bop with (1 := Ha2) (2 := Hb2). intros F e a1 Ha1 IH Da1. elim IH; intros a2 Ha2. assert (Da2 := cspf_dom_wd T T F a1 a2 Da1 (pse_int_wd H Ha1 Ha2)). exists (F a2 Da2). apply pse_int_pop with (1 := Ha2). intro t; exists t; apply pse_int_con. Defined. (** Given [H:r1[=]r2] and [H0:(pse_int r1 e t1)], the first projection of [(replacement_lemma H H0)] is the term [t2] obtained by replacing in [t1] subterm [r1] by [r2]. The second projection is the proof of [(pse_int r2 e t2)]. *) Definition replace_in_term (T:CSetoid) (r1 r2 t1:T) (e:part_set_exp T) (H:r1[=]r2) (H0:pse_int r1 e t1) := proj1_my_sigT T (pse_int r2 e) (replacement_lemma H H0). Definition replace_in_term_proof (T:CSetoid) (r1 r2 t1:T) (e:part_set_exp T) (H:r1[=]r2) (H0:pse_int r1 e t1) := proj2_my_sigT T (pse_int r2 e) (replacement_lemma H H0). Set Strict Implicit. Unset Implicit Arguments. (** The `quote function' maps from the semantical level to heavy syntactic expressions: given a setoid term [t:T], [psxe_quote] yields a [(part_set_xexp T)]. Term [r:T] (supposed to be a subterm of [t:T] to be replaced later on) is mapped to [(psxe_var r)]. Other `leafs' [t0] of [t] are mapped to [(psxe_con r t0)]. *) Ltac psxe_quote r t := match constr:(t) with | r => constr:(psxe_var r) | (csf_fun ?X1 ?X1 ?X2 ?X3) => let F := constr:(X2) with t0 := constr:(X3) in let e := psxe_quote r t0 in constr:(psxe_uop F e) | (csbf_fun ?X1 ?X1 ?X1 ?X2 ?X3 ?X4) => let F := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r t1 with e2 := psxe_quote r t2 in constr:(psxe_bop F e1 e2) (* | [(cspf_fun ?1 ?1 ?2 ?3 ?4)] -> *) | (Part ?X2 ?X3 ?X4) => let F := constr: (*1*) (X2) with t0 := constr:(X3) with Ht0 := constr:(X4) in let e := psxe_quote r t0 in constr:(psxe_pop (F:=F) Ht0 e) | ?X1 => let t0 := constr:(X1) in constr:(psxe_con r t0) end. (** Given [H:r1[=]r2] and [A:Prop] or [A:CProp], [(replace_in_formula2 H A)] replaces all occurrences of subterm [r1] in [A] by [r2]. *) Ltac part_repl_in_form H A := let type_of_H := typeof H in match constr:(type_of_H) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let r1 := constr:(X2) with r2 := constr:(X3) in match constr:(A) with | (csp_pred ?X1 ?X2 ?X3) => let P := constr:(X2) with t := constr:(X3) in let e := psxe_quote r1 t in let Ht := constr:(extract_correct e) in let s := constr:(replace_in_term H Ht) in constr:(P s) | (csr_rel ?X1 ?X2 ?X3 ?X4) => let R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) in constr:(R s1 s2) | (Ccsr_rel ?X1 ?X2 ?X3 ?X4) => let R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) in constr:(R s1 s2) | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) in constr:(cs_eq (r:=T) s1 s2) | (cs_ap (c:=?X1) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) in constr:(cs_ap (c:=T) s1 s2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(B1 -> B2) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(B1 /\ B2) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(B1 and B2) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(B1 \/ B2) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(B1 or B2) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(B1 <-> B2) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let B1 := part_repl_in_form H A1 with B2 := part_repl_in_form H A2 in constr:(Iff B1 B2) | (~ ?X1) => let A0 := constr:(X1) in let B0 := part_repl_in_form H A0 in constr:(~ B0) | (Not ?X1) => let A0 := constr:(X1) in let B0 := part_repl_in_form H A0 in constr:(Not B0) (* | (CNot ?X1) => let A0 := constr:X1 in let B0 := part_repl_in_form H A0 in constr:(CNot B0)*) | ?X1 => let A0 := constr:(X1) in constr:(A0) end end. (** Given [T:CSetoid;r1,r2:T;H:r1[=]r2;H0:r2[=]r1] (checked by main call) and [A:CProp] or [A:Prop], we get [(part_set_rewr_prf1 H H0 A) : A->A[r2/r1]] and [(part_set_rewr_prf2 r1 r2 H H0 A) : A[r2/r1]->A] where [A[r2/r1]] denotes [(part_repl_in_form H A)]. The argument [H0:r2[=]r1] is present to avoid iterated application of [eq_symmetric]. *) Ltac part_set_rewr_prf1 r1 r2 H H0 A := match constr:(A) with | (csp_pred ?X1 ?X2 ?X3) => let T := constr:(X1) with P := constr:(X2) with t := constr:(X3) in let e := psxe_quote r1 t in let Ht := constr:(extract_correct e) in let s := constr:(replace_in_term H Ht) with Hs := constr:(replace_in_term_proof H Ht) in let d := constr:(pse_int_wd H Ht Hs) in constr:(fun a:P t => csp_wd T P t s a d) | (csr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H Ht1 Hs1) with d2 := constr:(pse_int_wd H Ht2 Hs2) in constr:(fun a:R t1 t2 => csr_wd T R t1 t2 s1 s2 a d1 d2) | (Ccsr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H Ht1 Hs1) with d2 := constr:(pse_int_wd H Ht2 Hs2) in constr:(fun a:R t1 t2 => Ccsr_wd T R t1 t2 s1 s2 a d1 d2) | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H Ht1 Hs1) with d2 := constr:(pse_int_wd H Ht2 Hs2) in constr:(fun a:cs_eq (r:=T) t1 t2 => eq_wd T t1 t2 s1 s2 a d1 d2) | (cs_ap (c:=?X1) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H Ht1 Hs1) with d2 := constr:(pse_int_wd H Ht2 Hs2) in constr:(fun a:cs_ap (c:=T) t1 t2 => ap_wd T t1 t2 s1 s2 a d1 d2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf1 r1 r2 H H0 A2 with d2 := part_set_rewr_prf2 r1 r2 H H0 A1 in constr:(fun (p:A1 -> A2) b => d1 (p (d2 b))) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf1 r1 r2 H H0 A1 with d2 := part_set_rewr_prf1 r1 r2 H H0 A2 in constr:(fun p:A1 /\ A2 => conj (d1 (fst p)) (d2 (snd p))) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf1 r1 r2 H H0 A1 with d2 := part_set_rewr_prf1 r1 r2 H H0 A2 in constr:(fun p:A1 and A2 => pair (d1 (CAnd_proj1 _ _ p)) (d2 (CAnd_proj2 _ _ p))) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf1 r1 r2 H H0 A1 with d2 := part_set_rewr_prf1 r1 r2 H H0 A2 in constr:(or_ind (fun a => or_introl _ (d1 a)) (fun a => or_intror _ (d2 a))) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf1 r1 r2 H H0 A1 with d2 := part_set_rewr_prf1 r1 r2 H H0 A2 in constr:(COr_elim A1 A2 _ (fun a => inl _ _ (d1 a)) (fun a => inr _ _ (d2 a))) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := part_set_rewr_prf1 r1 r2 H H0 A1 with ab2 := part_set_rewr_prf1 r1 r2 H H0 A2 with ba1 := part_set_rewr_prf2 r1 r2 H H0 A1 with ba2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun p:A1 <-> A2 => conj (fun b1 => ab2 (fst p (ba1 b1))) (fun b2 => ab1 (snd p (ba2 b2)))) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := part_set_rewr_prf1 r1 r2 H H0 A1 with ab2 := part_set_rewr_prf1 r1 r2 H H0 A2 with ba1 := part_set_rewr_prf2 r1 r2 H H0 A1 with ba2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun p:Iff A1 A2 => pair (fun b1 => ab2 (CAnd_proj1 _ _ p (ba1 b1))) (fun b2 => ab1 (CAnd_proj2 _ _ p (ba2 b2)))) | (~ ?X1) => let A0 := constr:(X1) in let d := part_set_rewr_prf2 r1 r2 H H0 A0 in constr:(fun (p:~ A0) b => p (d b)) | (Not ?X1) => let A0 := constr:(X1) in let d := part_set_rewr_prf2 r1 r2 H H0 A0 in constr:(fun (p:Not A0) b => p (d b)) (* | (CNot ?X1) => let A0 := constr:X1 in let d := part_set_rewr_prf2 r1 r2 H H0 A0 in constr:(fun (p:CNot A0) b => p (d b))*) | ?X1 => let A0 := constr:(X1) in constr:(fun a:A0 => a) end with part_set_rewr_prf2 r1 r2 H H0 A := match constr:(A) with | (csp_pred ?X1 ?X2 ?X3) => let T := constr:(X1) with P := constr:(X2) with t := constr:(X3) in let e := psxe_quote r1 t in let Ht := constr:(extract_correct e) in let s := constr:(replace_in_term H Ht) with Hs := constr:(replace_in_term_proof H Ht) in let d := constr:(pse_int_wd H0 Hs Ht) in constr:(fun b:P s => csp_wd T P s t b d) | (csr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H0 Hs1 Ht1) with d2 := constr:(pse_int_wd H0 Hs2 Ht2) in constr:(fun b:R s1 s2 => csr_wd T R s1 s2 t1 t2 b d1 d2) | (Ccsr_rel ?X1 ?X2 ?X3 ?X4) => let T := constr:(X1) with R := constr:(X2) with t1 := constr:(X3) with t2 := constr:(X4) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H0 Hs1 Ht1) with d2 := constr:(pse_int_wd H0 Hs2 Ht2) in constr:(fun b:R s1 s2 => Ccsr_wd T R s1 s2 t1 t2 b d1 d2) | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H0 Hs1 Ht1) with d2 := constr:(pse_int_wd H0 Hs2 Ht2) in constr:(fun b:cs_eq (r:=T) s1 s2 => eq_wd T s1 s2 t1 t2 b d1 d2) | (cs_ap (c:=?X1) ?X2 ?X3) => let T := constr:(X1) with t1 := constr:(X2) with t2 := constr:(X3) in let e1 := psxe_quote r1 t1 with e2 := psxe_quote r1 t2 in let Ht1 := constr:(extract_correct e1) with Ht2 := constr:(extract_correct e2) in let s1 := constr:(replace_in_term H Ht1) with s2 := constr:(replace_in_term H Ht2) with Hs1 := constr:(replace_in_term_proof H Ht1) with Hs2 := constr:(replace_in_term_proof H Ht2) in let d1 := constr:(pse_int_wd H0 Hs1 Ht1) with d2 := constr:(pse_int_wd H0 Hs2 Ht2) in constr:(fun b:cs_ap (c:=T) s1 s2 => ap_wd T s1 s2 t1 t2 b d1 d2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf1 r1 r2 H H0 A1 with d2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun q (a:A1) => d2 (q (d1 a))) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf2 r1 r2 H H0 A1 with d2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun q:_ /\ _ => conj (d1 (fst q)) (d2 (snd q))) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf2 r1 r2 H H0 A1 with d2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun q:_ and _ => @pair A1 A2 (d1 (CAnd_proj1 _ _ q)) (d2 (CAnd_proj2 _ _ q))) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf2 r1 r2 H H0 A1 with d2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(or_ind (fun b => or_introl A2 (d1 b)) (fun b => or_intror A1 (d2 b))) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let d1 := part_set_rewr_prf2 r1 r2 H H0 A1 with d2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(COr_elim _ _ (A1 or A2) (fun b => inl A1 A2 (d1 b)) (fun b => inr A1 A2 (d2 b))) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := part_set_rewr_prf1 r1 r2 H H0 A1 with ab2 := part_set_rewr_prf1 r1 r2 H H0 A2 with ba1 := part_set_rewr_prf2 r1 r2 H H0 A1 with ba2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun q:_ <-> _ => conj (fun a1:A1 => ba2 (fst q (ab1 a1))) (fun a2:A2 => ba1 (snd q (ab2 a2)))) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let ab1 := part_set_rewr_prf1 r1 r2 H H0 A1 with ab2 := part_set_rewr_prf1 r1 r2 H H0 A2 with ba1 := part_set_rewr_prf2 r1 r2 H H0 A1 with ba2 := part_set_rewr_prf2 r1 r2 H H0 A2 in constr:(fun q:Iff _ _ => pair (fun a1:A1 => ba2 (CAnd_proj1 _ _ q (ab1 a1))) (fun a2:A2 => ba1 (CAnd_proj2 _ _ q (ab2 a2)))) | (~ ?X1) => let A0 := constr:(X1) in let d := part_set_rewr_prf1 r1 r2 H H0 A0 in constr:(fun (q:~ _) (a:A0) => q (d a)) | (Not ?X1) => let A0 := constr:(X1) in let d := part_set_rewr_prf1 r1 r2 H H0 A0 in constr:(fun (q:Not _) (a:A0) => q (d a)) (* | (CNot ?X1) => let A0 := constr:X1 in let d := part_set_rewr_prf1 r1 r2 H H0 A0 in constr:(fun (q:CNot _) (a:A0) => q (d a)) *) | ?X1 => let A0 := constr:(X1) in constr:(fun a:A0 => a) end. Ltac Unfold_partial_csetoid_rewrite_stuff := unfold replace_in_term, proj1_my_sigT, replacement_lemma, extract_correct, pse_int_rect, part_set_xexp_rect, my_sigT_rect in |- *. (* rewrite -> h *) Ltac partial_csetoid_rewrite h := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with r1 := constr:(X2) with r2 := constr:(X3) in let h0 := constr:(eq_symmetric T r1 r2 h) in match goal with | |- ?X1 => let A := constr:(X1) in let B := part_repl_in_form h A with d := part_set_rewr_prf2 r1 r2 h h0 A in ((*:B->A*) cut B; [ exact d | Unfold_partial_csetoid_rewrite_stuff ]) end end. (* rewrite <- h *) Ltac partial_csetoid_rewrite_rev h := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with r2 := constr:(X2) with r1 := constr:(X3) in let h0 := constr:(eq_symmetric T r2 r1 h) in match goal with | |- ?X1 => let A := constr:(X1) in let B := part_repl_in_form h A with d := part_set_rewr_prf2 r1 r2 h0 h A in ((*:B->A*) cut B; [ exact d | Unfold_partial_csetoid_rewrite_stuff ]) end end. (* rewrite -> h in h0 *) Ltac partial_csetoid_rewrite_cxt h h0 := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with r1 := constr:(X2) with r2 := constr:(X3) in let h1 := constr:(eq_symmetric T r1 r2 h) with A := typeof h0 in let B := part_repl_in_form h A with d := part_set_rewr_prf1 r1 r2 h h1 A in ((*:A->B*) cut B; [ Unfold_partial_csetoid_rewrite_stuff; clear h0; intro h0 | exact (d h0) ]) end. (* rewrite <- h in h0 *) Ltac partial_csetoid_rewrite_cxt_rev h h0 := let type_of_h := typeof h in match constr:(type_of_h) with | (cs_eq (r:=(cs_crr ?X1)) ?X2 ?X3) => let T := constr:(X1) with r2 := constr:(X2) with r1 := constr:(X3) in let h1 := constr:(eq_symmetric T r2 r1 h) with A := typeof h0 in let B := part_repl_in_form h A with d := part_set_rewr_prf1 r1 r2 h1 h A in ((*:A->B*) cut B; [ Unfold_partial_csetoid_rewrite_stuff; clear h0; intro h0 | exact (d h0) ]) end. (* replace x with y *) Ltac partial_setoid_replace x y := let h := fresh in (cut (x[=]y); [ intro h; partial_csetoid_rewrite h; clear h | idtac ]). (* replace x with y in h *) Ltac partial_setoid_replace_cxt x y h := let h0 := fresh in (cut (x[=]y); [ intro h0; partial_csetoid_rewrite_cxt h0 h; clear h0 | idtac ]). (*End partial_csetoid_rewrite.*) Require Export Coq.Bool.Bool. Ltac term_cont_part t := match constr:(t) with | (Part _ _ _) => constr:(true) | (csf_fun _ _ _ ?X4) => let t0 := constr:(X4) in let b := term_cont_part t0 in constr:(b) | (csbf_fun _ _ _ _ ?X5 ?X6) => let t1 := constr:(X5) with t2 := constr:(X6) in let b1 := term_cont_part t1 with b2 := term_cont_part t2 in constr:(orb b1 b2) | _ => constr:(false) end. Ltac form_cont_part A := match constr:(A) with | (csp_pred _ _ ?X3) => let t := constr:(X3) in let b := term_cont_part t in constr:(b) | (csr_rel _ _ ?X3 ?X4) => let t1 := constr:(X3) with t2 := constr:(X4) in let b1 := term_cont_part t1 with b2 := term_cont_part t2 in constr:(orb b1 b2) | (Ccsr_rel _ _ ?X3 ?X4) => let t1 := constr:(X3) with t2 := constr:(X4) in let b1 := term_cont_part t1 with b2 := term_cont_part t2 in constr:(orb b1 b2) | (?X2[=]?X3) => let t1 := constr:(X2) with t2 := constr:(X3) in let b1 := term_cont_part t1 with b2 := term_cont_part t2 in constr:(orb b1 b2) | (?X2[#]?X3) => let t1 := constr:(X2) with t2 := constr:(X3) in let b1 := term_cont_part t1 with b2 := term_cont_part t2 in constr:(orb b1 b2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in let b1 := form_cont_part A1 with b2 := form_cont_part A2 in constr:(orb b1 b2) | (~ ?X1) => let A0 := constr:(X1) in let b := form_cont_part A0 in constr:(b) | (Not ?X1) => let A0 := constr:(X1) in let b := form_cont_part A0 in constr:(b) (* | (CNot ?X1) => let A0 := constr:(X1) in let b := form_cont_part A0 in constr:(b) *) | _ => constr:(false) end. Ltac fold_cspf_dom_in_term t := match constr:(t) with | (Part _ ?X3 ?X4) => let t0 := constr:(X3) with h := constr:(X4) in let H := fresh in (set (H := h) in *; fold_cspf_dom_in_term t0; clearbody H) | (csf_fun _ _ _ ?X4) => let t0 := constr:(X4) in fold_cspf_dom_in_term t0 | (csbf_fun _ _ _ _ ?X5 ?X6) => let t1 := constr:(X5) with t2 := constr:(X6) in (fold_cspf_dom_in_term t1; fold_cspf_dom_in_term t2) | _ => idtac end. Ltac fold_cspf_dom_in_form A := match constr:(A) with | (csp_pred _ _ ?X3) => let t := constr:(X3) in fold_cspf_dom_in_term t | (csr_rel _ _ ?X3 ?X4) => let t1 := constr:(X3) with t2 := constr:(X4) in (fold_cspf_dom_in_term t1; fold_cspf_dom_in_term t2) | (Ccsr_rel _ _ ?X3 ?X4) => let t1 := constr:(X3) with t2 := constr:(X4) in (fold_cspf_dom_in_term t1; fold_cspf_dom_in_term t2) | (?X2[=]?X3) => let t1 := constr:(X2) with t2 := constr:(X3) in (fold_cspf_dom_in_term t1; fold_cspf_dom_in_term t2) | (?X2[#]?X3) => let t1 := constr:(X2) with t2 := constr:(X3) in (fold_cspf_dom_in_term t1; fold_cspf_dom_in_term t2) | (?X1 -> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (?X1 /\ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (?X1 and ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (?X1 \/ ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (?X1 or ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (?X1 <-> ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (Iff ?X1 ?X2) => let A1 := constr:(X1) with A2 := constr:(X2) in (fold_cspf_dom_in_form A1; fold_cspf_dom_in_form A2) | (~ ?X1) => let A0 := constr:(X1) in fold_cspf_dom_in_form A0 | (Not ?X1) => let A0 := constr:(X1) in fold_cspf_dom_in_form A0 (* | (CNot ?X1) => let A0 := constr:X1 in fold_cspf_dom_in_form A0 *) | _ => idtac end. Ltac fold_cspf_dom := match goal with | |- ?X1 => let A := constr:(X1) in fold_cspf_dom_in_form A end. Ltac csetoid_rewrite h := match goal with | |- ?X1 => let A := constr:(X1) in let b := form_cont_part A in let c := eval compute in b in match constr:(c) with | true => partial_csetoid_rewrite h; fold_cspf_dom | false => total_csetoid_rewrite h end end. Ltac csetoid_rewrite_rev h := match goal with | |- ?X1 => let A := constr:(X1) in let b := form_cont_part A in let c := eval compute in b in match constr:(c) with | true => partial_csetoid_rewrite_rev h; fold_cspf_dom | false => total_csetoid_rewrite_rev h end end. Ltac csetoid_rewrite_cxt h h0 := let A := typeof h0 in let b := form_cont_part A in let c := eval compute in b in match constr:(c) with | true => partial_csetoid_rewrite_cxt h h0; fold_cspf_dom_in_form A | false => total_csetoid_rewrite_cxt h h0 end. Ltac csetoid_rewrite_cxt_rev h h0 := let A := typeof h0 in let b := form_cont_part A in let c := eval compute in b in match constr:(c) with | true => partial_csetoid_rewrite_cxt_rev h h0; fold_cspf_dom_in_form A | false => total_csetoid_rewrite_cxt_rev h h0 end. Ltac csetoid_replace x y := let h := fresh in (cut (x[=]y); [ intro h; csetoid_rewrite h; clear h | idtac ]). Ltac csetoid_replace_cxt x y h0 := let h := fresh in (cut (x[=]y); [ intro h; csetoid_rewrite_cxt h h0; clear h | idtac ]). corn-8.20.0/tools/000077500000000000000000000000001473720167500137165ustar00rootroot00000000000000corn-8.20.0/tools/COPYING000066400000000000000000000431351473720167500147570ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. corn-8.20.0/tools/DepsToDot.hs000077500000000000000000000050761473720167500161320ustar00rootroot00000000000000#! /usr/bin/env runhaskell {-# LANGUAGE UnicodeSyntax, ViewPatterns #-} {-# OPTIONS_GHC -Wall #-} import Data.Graph.Inductive (reachable, delEdge, mkGraph, nmap, Edge, Gr, DynGraph, UEdge, LEdge, efilter, LNode, labNodes, Graph, delNodes) import Data.GraphViz (Attribute(..), Label(..), printDotGraph, nonClusteredParams, graphToDot, fmtNode, Color(..), X11Color(..)) import Data.List (nub, elemIndex, isSuffixOf, isPrefixOf, stripPrefix) import Control.Monad (liftM2) import Data.Maybe (fromJust) import Prelude hiding ((.)) (.) :: Functor f ⇒ (a → b) → (f a → f b) (.) = fmap dropBack :: Int → [a] → [a] dropBack n = reverse . drop n . reverse uedge :: LEdge a → Edge uedge (x, y, _) = (x, y) nfilter :: Graph gr ⇒ (LNode a → Bool) → gr a b → gr a b nfilter p g = delNodes (map fst $ filter (not . p) $ labNodes g) g untransitive :: DynGraph gr ⇒ gr a b → gr a b untransitive g = efilter (not . redundant . uedge) g where redundant e@(from, to) = to `elem` reachable from (delEdge e g) read_deps :: String → Gr FilePath () read_deps input = mkGraph (zip [0..] nodes) edges where content :: [(FilePath, FilePath)] content = do (left, _ : right) ← break (==':') . lines input liftM2 (,) (words left) (words right) nodes :: [FilePath] nodes = nub $ map fst content ++ map snd content edges :: [UEdge] edges = map (\(from, to) → (fromJust $ elemIndex from nodes, fromJust $ elemIndex to nodes, ())) content cut_dotvo :: String → String cut_dotvo = dropBack 3 label :: FilePath → [Attribute] label (stripPrefix "MathClasses/" → Just rest) = [Label (StrLabel (cut_dotvo rest))] label p = [ Label (StrLabel (cut_dotvo p)) , Color [X11Color color] , LabelFontColor (X11Color color) ] where color :: X11Color color | "model/" `isPrefixOf` p = Magenta | "ftc/" `isPrefixOf` p = Gold3 | "fta/" `isPrefixOf` p = Green | "reals/" `isPrefixOf` p = Cyan4 | "transc/" `isPrefixOf` p = Blue | "reals/fast/" `isPrefixOf` p = Blue4 | "complex/" `isPrefixOf` p = BlueViolet | "metric2/" `isPrefixOf` p = Red | "metrics/" `isPrefixOf` p = Red4 | "tactics/" `isPrefixOf` p = Gray | "logic/" `isPrefixOf` p = Chocolate | "raster/" `isPrefixOf` p = Yellow | "order/" `isPrefixOf` p = Orange | "coq_reals/" `isPrefixOf` p = OliveDrab | otherwise = Black main :: IO () main = interact $ printDotGraph . graphToDot (nonClusteredParams {fmtNode = snd}) . nmap label . untransitive . nfilter (isSuffixOf ".vo" . snd) . read_deps corn-8.20.0/tools/coq.mim000077500000000000000000000153571473720167500152220ustar00rootroot00000000000000;; Usage: copy to /usr/share/m17n/ (input-method t coq) (description "Input method for Coq") (title "Coq") (map (trans ;; Coq built-ins: ("\\forall" ?∀) ("\\fun" ?λ) ;; From Unicode.Utf8: ("\\exists" ?∃) ("\\not" ?¬) ("\\/" ?∨) ("/\\" ?∧) ("->" "→") ("<->" "↔") ;; Our notations: ("-->" "⟶") ;; long arrow. not ideal, but should be sufficiently distinguishable from short arrow. ("\\catcomp" ?◎) ("\\==" ?≡) ("\\/==" ?≢) ("/=" ?≠) ("<=" ?≤) ("\\approx" ?≈) ("\\apart" ?⪥) ("\\shiftl" ?≪) ("\\shiftr" ?≫) ("__0" ?₀) ("__1" ?₁) ("__2" ?₂) ("__3" ?₃) ("__4" ?₄) ("^+" ?⁺) ("_+" ?₊) ("^-" ?⁻) ("\\infty" ?∞) ("\\prf" ?↾) ("\\in" "∈") ("\\has" "∋") ("\\cup" "∪") ("\\cap" "∩") ("\\setminus" "∖") ("\\subset" "⊂") ("\\supset" "⊃") ("\\superset" "⊃") ("\\strictsubset" "⊊") ("\\strictsupset" "⊋") ("\\strictsuperset" "⊋") ("\\ssubset" "⊊") ("\\ssupset" "⊋") ("\\empty" "∅") ;; From Program.Basics: ("\\comp" ?∘) ("\\Alpha" "Α") ("\\alpha" "α") ("\\Beta" "Β") ("\\beta" "β") ("\\Gamma" "Γ") ("\\gamma" "γ") ("\\Delta" "Δ") ("\\delta" "δ") ("\\Epsilon" "Ε") ("\\epsilon" "ε") ("\\Zeta" "Ζ") ("\\zeta" "ζ") ("\\Eta" "Η") ("\\eta" "η") ("\\Theta" "Θ") ("\\theta" "θ") ("\\Iota" "Ι") ("\\iota" "ι") ("\\Kappa" "Κ") ("\\kappa" "κ") ("\\Lamda" "Λ") ("\\lamda" "λ") ("\\Lambda" "Λ") ("\\lambda" "λ") ("\\Mu" "Μ") ("\\mu" "μ") ("\\Nu" "Ν") ("\\nu" "ν") ("\\Xi" "Ξ") ("\\xi" "ξ") ("\\Omicron" "Ο") ("\\omicron" "ο") ("\\Pi" "Π") ("\\pi" "π") ("\\Rho" "Ρ") ("\\rho" "ρ") ("\\Sigma" "Σ") ("\\sigma" "ς") ("\\Tau" "Τ") ("\\tau" "τ") ("\\Upsilon" "Υ") ("\\upsilon" "υ") ("\\Phi" "Φ") ("\\phi" "φ") ("\\Chi" "Χ") ("\\chi" "χ") ("\\Psi" "Ψ") ("\\psi" "ψ") ("\\Omega" "Ω") ("\\omega" "ω") ("\\bA" "𝐀") ("\\iA" "𝐴") ("\\sA" "𝒜") ("\\fA" "𝔄") ("\\dA" "𝔸") ("\\bB" "𝐁") ("\\iB" "𝐵") ("\\sB" "ℬ") ("\\fB" "𝔅") ("\\dB" "𝔹") ("\\bC" "𝐂") ("\\iC" "𝐶") ("\\sC" "𝒞") ("\\fC" "ℭ") ("\\dC" "ℂ") ("\\bD" "𝐃") ("\\iD" "𝐷") ("\\sD" "𝒟") ("\\fD" "𝔇") ("\\dD" "𝔻") ("\\bE" "𝐄") ("\\iE" "𝐸") ("\\sE" "ℰ") ("\\fE" "𝔈") ("\\dE" "𝔼") ("\\bF" "𝐅") ("\\iF" "𝐹") ("\\sF" "ℱ") ("\\fF" "𝔉") ("\\dF" "𝔽") ("\\bG" "𝐆") ("\\iG" "𝐺") ("\\sG" "𝒢") ("\\fG" "𝔊") ("\\dG" "𝔾") ("\\bH" "𝐇") ("\\iH" "𝐻") ("\\sH" "ℋ") ("\\fH" "ℌ") ("\\dH" "ℍ") ("\\bI" "𝐈") ("\\iI" "𝐼") ("\\sI" "ℐ") ("\\fI" "ℑ") ("\\dI" "𝕀") ("\\bJ" "𝐉") ("\\iJ" "𝐽") ("\\sJ" "𝒥") ("\\fJ" "𝔍") ("\\dJ" "𝕁") ("\\bK" "𝐊") ("\\iK" "𝐾") ("\\sK" "𝒦") ("\\fK" "𝔎") ("\\dK" "𝕂") ("\\bL" "𝐋") ("\\iL" "𝐿") ("\\sL" "ℒ") ("\\fL" "𝔏") ("\\dL" "𝕃") ("\\bM" "𝐌") ("\\iM" "𝑀") ("\\sM" "ℳ") ("\\fM" "𝔐") ("\\dM" "𝕄") ("\\bN" "𝐍") ("\\iN" "𝑁") ("\\sN" "𝒩") ("\\fN" "𝔑") ("\\dN" "ℕ") ("\\bO" "𝐎") ("\\iO" "𝑂") ("\\sO" "𝒪") ("\\fO" "𝔒") ("\\dO" "𝕆") ("\\bP" "𝐏") ("\\iP" "𝑃") ("\\sP" "𝒫") ("\\fP" "𝔓") ("\\dP" "ℙ") ("\\bQ" "𝐐") ("\\iQ" "𝑄") ("\\sQ" "𝒬") ("\\fQ" "𝔔") ("\\dQ" "ℚ") ("\\bR" "𝐑") ("\\iR" "𝑅") ("\\sR" "ℛ") ("\\fR" "ℜ") ("\\dR" "ℝ") ("\\bS" "𝐒") ("\\iS" "𝑆") ("\\sS" "𝒮") ("\\fS" "𝔖") ("\\dS" "𝕊") ("\\bT" "𝐓") ("\\iT" "𝑇") ("\\sT" "𝒯") ("\\fT" "𝔗") ("\\dT" "𝕋") ("\\bU" "𝐔") ("\\iU" "𝑈") ("\\sU" "𝒰") ("\\fU" "𝔘") ("\\dU" "𝕌") ("\\bV" "𝐕") ("\\iV" "𝑉") ("\\sV" "𝒱") ("\\fV" "𝔙") ("\\dV" "𝕍") ("\\bW" "𝐖") ("\\iW" "𝑊") ("\\sW" "𝒲") ("\\fW" "𝔚") ("\\dW" "𝕎") ("\\bX" "𝐗") ("\\iX" "𝑋") ("\\sX" "𝒳") ("\\fX" "𝔛") ("\\dX" "𝕏") ("\\bY" "𝐘") ("\\iY" "𝑌") ("\\sY" "𝒴") ("\\fY" "𝔜") ("\\dY" "𝕐") ("\\bZ" "𝐙") ("\\iZ" "𝑍") ("\\sZ" "𝒵") ("\\fZ" "ℨ") ("\\dZ" "ℤ") ("\\ba" "𝐚") ("\\ia" "𝑎") ("\\sa" "𝒶") ("\\fa" "𝔞") ("\\da" "𝕒") ("\\bb" "𝐛") ("\\ib" "𝑏") ("\\sb" "𝒷") ("\\fb" "𝔟") ("\\db" "𝕓") ("\\bc" "𝐜") ("\\ic" "𝑐") ("\\sc" "𝒸") ("\\fc" "𝔠") ("\\dc" "𝕔") ("\\bd" "𝐝") ("\\id" "𝑑") ("\\sd" "𝒹") ("\\fd" "𝔡") ("\\dd" "𝕕") ("\\be" "𝐞") ("\\ie" "𝑒") ("\\se" "ℯ") ("\\fe" "𝔢") ("\\de" "𝕖") ("\\bf" "𝐟") ("\\if" "𝑓") ("\\sf" "𝒻") ("\\ff" "𝔣") ("\\df" "𝕗") ("\\bg" "𝐠") ("\\ig" "𝑔") ("\\sg" "ℊ") ("\\fg" "𝔤") ("\\dg" "𝕘") ("\\bh" "𝐡") ("\\ih" "ℎ") ("\\sh" "𝒽") ("\\fh" "𝔥") ("\\dh" "𝕙") ("\\bi" "𝐢") ("\\ii" "𝑖") ("\\si" "𝒾") ("\\fi" "𝔦") ("\\di" "𝕚") ("\\bj" "𝐣") ("\\ij" "𝑗") ("\\sj" "𝒿") ("\\fj" "𝔧") ("\\dj" "𝕛") ("\\bk" "𝐤") ("\\ik" "𝑘") ("\\sk" "𝓀") ("\\fk" "𝔨") ("\\dk" "𝕜") ("\\bl" "𝐥") ("\\il" "𝑙") ("\\sl" "𝓁") ("\\fl" "𝔩") ("\\dl" "𝕝") ("\\bm" "𝐦") ("\\im" "𝑚") ("\\sm" "𝓂") ("\\fm" "𝔪") ("\\dm" "𝕞") ("\\bn" "𝐧") ("\\in" "𝑛") ("\\sn" "𝓃") ("\\fn" "𝔫") ("\\dn" "𝕟") ("\\bo" "𝐨") ("\\io" "𝑜") ("\\so" "ℴ") ("\\fo" "𝔬") ("\\do" "𝕠") ("\\bp" "𝐩") ("\\ip" "𝑝") ("\\sp" "𝓅") ("\\fp" "𝔭") ("\\dp" "𝕡") ("\\bq" "𝐪") ("\\iq" "𝑞") ("\\sq" "𝓆") ("\\fq" "𝔮") ("\\dq" "𝕢") ("\\br" "𝐫") ("\\ir" "𝑟") ("\\sr" "𝓇") ("\\fr" "𝔯") ("\\dr" "𝕣") ("\\bs" "𝐬") ("\\is" "𝑠") ("\\ss" "𝓈") ("\\fs" "𝔰") ("\\ds" "𝕤") ("\\bt" "𝐭") ("\\it" "𝑡") ("\\st" "𝓉") ("\\ft" "𝔱") ("\\dt" "𝕥") ("\\bu" "𝐮") ("\\iu" "𝑢") ("\\su" "𝓊") ("\\fu" "𝔲") ("\\du" "𝕦") ("\\bv" "𝐯") ("\\iv" "𝑣") ("\\sv" "𝓋") ("\\fv" "𝔳") ("\\dv" "𝕧") ("\\bw" "𝐰") ("\\iw" "𝑤") ("\\sw" "𝓌") ("\\fw" "𝔴") ("\\dw" "𝕨") ("\\bx" "𝐱") ("\\ix" "𝑥") ("\\sx" "𝓍") ("\\fx" "𝔵") ("\\dx" "𝕩") ("\\by" "𝐲") ("\\iy" "𝑦") ("\\sy" "𝓎") ("\\fy" "𝔶") ("\\dy" "𝕪") ("\\bz" "𝐳") ("\\iz" "𝑧") ("\\sz" "𝓏") ("\\fz" "𝔷") ("\\dz" "𝕫") ("\\b0" "𝟎") ("\\d0" "𝟘") ("\\b1" "𝟏") ("\\d1" "𝟙") ("\\b2" "𝟐") ("\\d2" "𝟚") ("\\b3" "𝟑") ("\\d3" "𝟛") ("\\b4" "𝟒") ("\\d4" "𝟜") ("\\b5" "𝟓") ("\\d5" "𝟝") ("\\b6" "𝟔") ("\\d6" "𝟞") ("\\b7" "𝟕") ("\\d7" "𝟟") ("\\b8" "𝟖") ("\\d8" "𝟠") ("\\b9" "𝟗") ("\\d9" "𝟡") ("\\vdash" "⊢") ("\\Vdash" "⊨") ("\\vDash" "⊩") ("\\Vvdash" "⊪") ("\\VDash" "⊫") )) (state (init (trans))) corn-8.20.0/tools/coqindenter000066400000000000000000000070721473720167500161620ustar00rootroot00000000000000#!/usr/bin/python # -*- coding: utf-8 -*- import os, sys, time, re from subprocess import Popen, PIPE, STDOUT from optparse import OptionParser parser = OptionParser(usage= "usage: %prog [options] coqtop-invocation < input.v > output.v") parser.add_option('-i', '--subgoal-indent', default=' ', metavar='STR', dest='subgoal_indentation', help='indent each additional subgoal by STR (default: "%default")') parser.add_option('-w', '--wrap', metavar='N', type='int', dest='wrap', help='wrap at natural break points after N columns') parser.add_option('--erase-empty-lines', default=False, dest='eraseEmptyLines', action='store_true', help='erase empty lines in proof scripts') parser.add_option("--add-proof", default=False, dest='addProof', action='store_true', help='begin multi-line proofs with "Proof."') (options, remaining_args) = parser.parse_args() if remaining_args == []: parser.error("Missing coqtop-invocation.") coq = Popen(remaining_args, stdin=PIPE, stdout=PIPE, stderr=STDOUT) sgre = re.compile('^(\d+) subgoal') is_prompt = re.compile("((\\n)|^)[\\w_']+ < $") def readuntilprompt(): s = "" while True: s += coq.stdout.read(1) if s.endswith(" < ") and is_prompt.search(s): return s # Looking at " < " is not enough, because it occurs in "x < y". Having the test obviously does make a huge speed difference. def split_indent(s): i = 0 while i != len(s) and s[i].isspace(): i += 1 return (s[:i], s[i:]) def to_be_continued(l): return not (l.endswith('.\n') or l.endswith("*)\n")) subgoals = 0 extra = 0 seen_Proof = False line_cont = None pending_line = None base_indentation = '' def subgoals_changed(new_subgoals): global subgoals global pending_line if subgoals == new_subgoals + 1: if pending_line: lstripped = pending_line.lstrip() spl = lstripped.split(". ") print ' ' * (len(pending_line) - len(lstripped) - 1), lstripped pending_line = None subgoals = new_subgoals def print_Proof_if_necessary(): global seen_Proof if options.addProof and not seen_Proof: print base_indentation + "Proof." seen_Proof = True def subgoal_indentation(): return base_indentation + options.subgoal_indentation * subgoals for l in sys.stdin: l = l.rstrip() + '\n' prompt = readuntilprompt() m = sgre.search(prompt) if prompt.find("Proof completed.") != -1 or prompt.find(" is defined") != -1: subgoals_changed(0) seen_Proof = False elif m: subgoals_changed(int(m.group(1))) # "Proof completed." is not printed when the proof is "Proof ." if pending_line: print pending_line; pending_line = None (indentation, content) = split_indent(l) if content.startswith("Proof"): seen_Proof = True if content[:1].isupper() and subgoals == 0: base_indentation = indentation if content == '': if subgoals == 0 or not options.eraseEmptyLines: print elif subgoals == 0 or content.startswith("Proof"): print l, else: if line_cont != None: if options.wrap and len(line_cont + l.strip()) > options.wrap: print_Proof_if_necessary() print subgoal_indentation() + line_cont extra += 1 line_cont = ' ' * extra + l.strip() else: line_cont += ' ' + l.strip() if not to_be_continued(l): print subgoal_indentation() + line_cont line_cont = None extra = 0 else: if not to_be_continued(l): print_Proof_if_necessary() pending_line = subgoal_indentation() + ' ' * extra + l.strip() else: line_cont = l.strip() coq.stdin.write(l) assert(subgoals == 0) if pending_line: print pending_line corn-8.20.0/transc/000077500000000000000000000000001473720167500140505ustar00rootroot00000000000000corn-8.20.0/transc/ArTanH.v000066400000000000000000000373561473720167500153720ustar00rootroot00000000000000(* Copyright © 1998-2006 * Russell O’Connor * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.Exponential. Require Import CoRN.tactics.CornTac. (** * Inverse Hyperbolic Tangent Function The definition of the inverse hyperbolic tangent function. area tangens hyperbolicus *) Definition ArTangH : PartIR := Half{**}(Logarithm[o](([-C-][1]{+}FId){/}([-C-][1]{-}FId))). Definition DomArTanH := olor ([--][1]) [1]. Lemma proper_DomArTanH : proper DomArTanH. Proof. simpl. apply shift_zero_less_minus'. rstepr (Two:IR). apply pos_two. Qed. Lemma DomArTanH_Dom_ArTanH : included DomArTanH (Dom ArTangH). Proof. intros x Hx. split. constructor. assert (X:Dom (([-C-][1]{+}FId){/}([-C-][1]{-}FId)) x). split. repeat constructor. split. repeat constructor. simpl. intros _. apply Greater_imp_ap. apply shift_zero_less_minus. destruct Hx; assumption. exists X. simpl. apply div_resp_pos. apply shift_zero_less_minus. destruct Hx; assumption. rstepr (x[-][--][1]). apply shift_zero_less_minus. destruct Hx; assumption. Qed. Lemma Dom_ArTanH_DomArTanH : included (Dom ArTangH) DomArTanH. Proof. intros x [_ [Hx0 Hx1]]. simpl in Hx1. assert (Hx:=Hx0). destruct Hx as [_ [_ H]]. simpl in H. assert (Hx:[1][-]x[#][0]). apply H. repeat constructor. clear H. destruct (ap_imp_less _ _ _ Hx) as [H|H]. elim (less_irreflexive IR [0]). eapply less_transitive_unfolded. apply Hx1. apply mult_cancel_less with (x[-][1]). apply inv_cancel_less. rstepl ([1][-]x). rstepr ([0]:IR). assumption. rstepr ([0][+][--][0]:IR). rstepl ([1][-]x[+][--]Two). apply plus_resp_less_both. assumption. apply inv_resp_less. apply pos_two. split. apply shift_zero_less_minus'. rstepr ([1][+]x). rstepl ([0][*]([1][-]x)). eapply shift_mult_less. assumption. apply Hx1. apply shift_zero_less_minus'. assumption. Qed. Definition ArTanH (x:IR) (Hx:DomArTanH x) := ArTangH x (DomArTanH_Dom_ArTanH x Hx). Lemma ArTanH_wd : forall (x y : IR) Hx Hy, x[=]y -> ArTanH x Hx[=]ArTanH y Hy. Proof. intros x y Hx Hy H. apply pfwdef. assumption. Qed. Lemma ArTanH_maps_compact_lemma : maps_compacts_into DomArTanH (openl [0]) (([-C-][1]{+}FId){/}([-C-][1]{-}FId)). Proof. intros a b Hab H. assert (Ha : [0][<][1][-]a). apply shift_zero_less_minus. destruct (H _ (compact_inc_lft _ _ Hab)) as [_ A]. assumption. assert (Ha' : [1][-]a[#][0]). apply Greater_imp_ap. assumption. exists ([1][+]a[/]_[//]Ha'). assert (Hb : [0][<][1][-]b). apply shift_zero_less_minus. destruct (H _ (compact_inc_rht _ _ Hab)) as [_ A]. assumption. assert (Hb' : [1][-]b[#][0]). apply Greater_imp_ap. assumption. exists ([1][+]([1][+]b[/]_[//]Hb')). assert (Hcd : ([1][+]a[/]_[//]Ha')[<]([1][+]([1][+]b[/]_[//]Hb'))). rstepl ([0][+]([1][+]a[/]_[//]Ha')). apply plus_resp_less_leEq. apply pos_one. apply shift_leEq_div; try assumption. rstepl ((([1][-]a[*]b)[+](a[-]b))[/]_[//]Ha'). apply shift_div_leEq; try assumption. rstepr (([1][-]a[*]b)[+](b[-]a)). apply plus_resp_leEq_lft. apply shift_minus_leEq. rstepr (Two[*]b[-]a). apply shift_leEq_minus. rstepl (Two[*]a). apply mult_resp_leEq_lft; try assumption. apply less_leEq; apply pos_two. exists Hcd. split. intros y [Hy _]. eapply less_leEq_trans ;[|apply Hy]. apply div_resp_pos. assumption. destruct (H _ (compact_inc_lft _ _ Hab)) as [A _]. rstepr (a[-][--][1]). apply shift_zero_less_minus. assumption. intros x Hx H0. simpl. assert ([0][<][1][-]x). destruct (H0) as [_ A]. rstepr (([1][-]b)[+](b[-]x)). rstepl ([0][+][0]:IR). apply plus_resp_less_leEq. assumption. apply shift_zero_leEq_minus. assumption. split. apply shift_leEq_div; try assumption. rstepl ((([1][-]x[*]a)[+](a[-]x))[/]_[//]Ha'). apply shift_div_leEq; try assumption. rstepr (([1][-]x[*]a)[+](x[-]a)). apply plus_resp_leEq_lft. apply shift_minus_leEq. rstepr (Two[*]x[-]a). apply shift_leEq_minus. rstepl (Two[*]a). apply mult_resp_leEq_lft; try assumption. destruct H0; assumption. apply less_leEq; apply pos_two. apply leEq_transitive with ([0][+]([1][+]b[/]_[//]Hb')). apply shift_div_leEq; try assumption. rstepr ((([1][-]x[*]b)[+](b[-]x))[/]_[//]Hb'). apply shift_leEq_div; try assumption. rstepl (([1][-]x[*]b)[+](x[-]b)). apply plus_resp_leEq_lft. apply shift_minus_leEq. rstepr (Two[*]b[-]x). apply shift_leEq_minus. rstepl (Two[*]x). apply mult_resp_leEq_lft; try assumption. destruct H0; assumption. apply less_leEq; apply pos_two. apply plus_resp_leEq. apply less_leEq; apply pos_one. Qed. Lemma Derivative_ArTanH : forall H, Derivative DomArTanH H ArTangH (Frecip ([-C-][1]{-}FId{^}2)). Proof. intros H. assert (bnd_away_zero_in_P ([-C-][1]{-}FId) DomArTanH). clear H. intros a b Hab H. split. Included. exists ([1][-]b). destruct (H _ (compact_inc_rht _ _ Hab)) as [_ A]. apply shift_zero_less_minus. assumption. intros y Hy H0. simpl. eapply leEq_transitive;[|apply leEq_AbsIR]. apply plus_resp_leEq_lft. apply inv_resp_leEq. destruct H0; assumption. unfold ArTangH. unfold Half. eapply Derivative_wdr; [|apply Derivative_scal; eapply (Derivative_comp DomArTanH (openl [0]) H I);[apply ArTanH_maps_compact_lemma | Derivative_Help; apply Feq_reflexive|Deriv]]. FEQ. apply included_FScalMult. apply included_FMult. apply included_FComp. Included. intros x Hx Hx0. split. repeat constructor. simpl; intros _. apply div_resp_ap_zero_rev. apply Greater_imp_ap. rstepr (x[-][--][1]). apply shift_zero_less_minus. destruct Hx0; assumption. apply included_FDiv. repeat constructor. repeat constructor. intros x Hx0 Hx. simpl. apply Greater_imp_ap. rstepr (([1][-]x)[^]2). apply pos_square. apply Greater_imp_ap. apply shift_zero_less_minus. destruct Hx0; assumption. apply included_FRecip. repeat constructor. intros x Hx0 Hx. simpl. rstepl (([1][-]x)[*](x[-][--][1])). apply Greater_imp_ap. apply mult_resp_pos; apply shift_zero_less_minus; destruct Hx0; assumption. apply included_FDiv. repeat constructor. repeat constructor. intros x H0 Hx. simpl. rstepl (([1][-]x)[^]2). apply Greater_imp_ap. apply pos_square. apply Greater_imp_ap. apply shift_zero_less_minus. destruct H0; assumption. Qed. Lemma Continuous_ArTanH : Continuous DomArTanH ArTangH. Proof. eapply Derivative_imp_Continuous with (pI:=proper_DomArTanH). apply Derivative_ArTanH. Qed. (* begin hide *) #[global] Hint Resolve ArTanH_wd: algebra. #[global] Hint Resolve Continuous_ArTanH: continuous. #[global] Hint Resolve Derivative_ArTanH: derivate. (* end hide *) (** Properties ofthe Inverse Hyperbolic Tangent Function. *) Lemma ArTanH_inv : forall x Hx Hx', ArTanH [--]x Hx[=][--](ArTanH x Hx'). Proof. intros x Hx Hx'. unfold ArTanH, ArTangH. generalize (DomArTanH_Dom_ArTanH). intros X. simpl in X. set (A:=(ProjT2 (Prj2 (X [--]x Hx)))). set (B:=(ProjT2 (Prj2 (X x Hx')))). change (Half (R:=IR)[*]Log _ A[=][--](Half (R:=IR)[*]Log _ B)). generalize A B. clear A B. intros A B. rstepr (Half[*][--](Log _ B)). apply mult_wdr. apply cg_inv_unique. assert (C:=mult_resp_pos _ _ _ B A). astepl (Log _ C). astepr (Log _ (pos_one IR)). apply Log_wd. rational. Qed. Lemma ArTanH_zero : forall H, ArTanH [0] H[=][0]. Proof. intros H. apply mult_cancel_lft with (Two:IR). apply nringS_ap_zero. rstepr ([0]:IR). rstepl (ArTanH [0] H[+]ArTanH [0] H). assert (X:DomArTanH [--][0]). eapply iprop_wd. apply H. rational. astepl (ArTanH [0] H[+]ArTanH _ X). csetoid_rewrite (ArTanH_inv _ X H). rational. Qed. (** PowerSeries for the Inverse Hyperbolic Tangent Function. *) Lemma ArTanH_series_coef_lemma : forall (R:COrdField) n, Nat.Odd n -> (nring (R:=R) n)[#][0]. Proof. intros R [|n] H%Nat.odd_spec; [discriminate H |]. apply nringS_ap_zero. Qed. Definition ArTanH_series_coef (n:nat) := match (CLogic.Even_Odd_dec n) with | left _ => [0] | right H => [1][/](nring n)[//](ArTanH_series_coef_lemma IR n H) end. Definition ArTanH_ps := FPowerSeries [0] ArTanH_series_coef. Lemma ArTanH_series_lemma : forall n : nat, Feq DomArTanH (Half (R:=IR){**} ((Log_ps n[o][-C-][1]{+}FId){-}(Log_ps n[o][-C-][1]{-}FId))) (ArTanH_ps n). Proof. unfold Log_ps, ArTanH_ps. unfold FPowerSeries. intros n. FEQ. apply included_FScalMult. apply included_FMinus; apply included_FComp; Included; repeat constructor. simpl. change (Half (R:=IR)[*] (Log_series_coef n[*]([1][+]x[-][1])[^]n[-] Log_series_coef n[*]([1][-]x[-][1])[^]n)[=] ArTanH_series_coef n[*]nexp IR n (x[-][0])). unfold ArTanH_series_coef. destruct n as [|n]. destruct (CLogic.Even_Odd_dec 0) as [A|A]; [simpl; rational | exfalso; destruct A as [k B]; rewrite Nat.add_1_r in B; discriminate B ]. rstepl (Half (R:=IR)[*] (Log_series_coef (S n)[*](x[^]S n[-]([--]x)[^]S n))). destruct (CLogic.Even_Odd_dec (S n)) as [A|A]; unfold cg_minus. csetoid_rewrite (inv_nexp_even _ x _ A). rational. csetoid_rewrite (inv_nexp_odd _ x _ A). unfold Half. rstepl (Log_series_coef (S n)[*](x[^]S n)). apply mult_wd;[|change (x[^]S n[=](x[+][--][0])[^]S n); rational]. unfold Log_series_coef. apply div_wd; try apply eq_reflexive. apply Nat.Even_succ in A. csetoid_rewrite (inv_nexp_even IR [1] _ A). algebra. Qed. Lemma ArTanH_series_lemma2 : fun_series_convergent_IR DomArTanH (fun n : nat => Half (R:=IR){**} ((Log_ps n[o][-C-][1]{+}FId){-}(Log_ps n[o][-C-][1]{-}FId))). Proof. apply FSeries_Sum_scal_conv;[|Contin]. apply FSeries_Sum_minus_conv; apply FSeries_Sum_comp_conv with (olor [0] Two); try apply Log_series_convergent_IR; try Contin; intros a b Hab H; simpl. exists ([1][+]a); exists ([1][+]b). assert (H0:[1][+]a[<=][1][+]b). apply plus_resp_leEq_lft; assumption. exists H0. split. intros c [Hc0 Hc1]. split. eapply less_leEq_trans;[|apply Hc0]. destruct (H _ (compact_inc_lft _ _ Hab)) as [A _]. apply shift_less_plus'. rstepl ([--][1]:IR). assumption. eapply leEq_less_trans;[apply Hc1|]. rstepr ([1][+][1]:IR). apply plus_resp_less_lft. destruct (H _ (compact_inc_rht _ _ Hab)) as [_ A]. assumption. intros x _ [Hx0 Hx1]. split; apply plus_resp_leEq_lft; assumption. exists ([1][-]b); exists ([1][-]a). assert (H0:[1][-]b[<=][1][-]a). apply plus_resp_leEq_lft. apply inv_resp_leEq; assumption. exists H0. split. intros c [Hc0 Hc1]. split. eapply less_leEq_trans;[|apply Hc0]. destruct (H _ (compact_inc_rht _ _ Hab)) as [_ A]. apply shift_zero_less_minus. assumption. eapply leEq_less_trans;[apply Hc1|]. rstepr ([1][+][--][--][1]:IR). apply plus_resp_less_lft. apply inv_resp_less. destruct (H _ (compact_inc_lft _ _ Hab)) as [A _]. assumption. intros x _ [Hx0 Hx1]. split; apply plus_resp_leEq_lft; apply inv_resp_leEq; assumption. Qed. Lemma ArTanH_series_convergent_IR : fun_series_convergent_IR DomArTanH ArTanH_ps. Proof. eapply fun_series_convergent_wd_IR;[|apply ArTanH_series_lemma2]. apply ArTanH_series_lemma. Qed. Lemma ArTanH_series : forall c : IR, forall (Hs:fun_series_convergent_IR DomArTanH ArTanH_ps) Hc0 Hc1, FSeries_Sum Hs c Hc0[=]ArTanH c Hc1. Proof. intros c Hs Hc0 Hc1. unfold ArTanH. set (F:=([-C-](Half (R:=IR)){*} ((Logarithm[o][-C-][1]{+}FId){-}(Logarithm[o][-C-][1]{-}FId)))). assert (F0:Dom F c). destruct Hc0 as [A B]. repeat (constructor || exists (I, I)); simpl. apply shift_less_plus'. rstepl ([--][1]:IR). assumption. apply shift_zero_less_minus. assumption. apply eq_transitive with (F c F0). apply (Feq_imp_eq DomArTanH); try assumption. eapply Feq_transitive. apply Feq_symmetric. apply (FSeries_Sum_wd' _ _ _ ArTanH_series_lemma2 Hs ArTanH_series_lemma). assert (B0:maps_compacts_into_weak DomArTanH (olor [0] Two) ([-C-][1]{+}FId)). intros a b Hab H; simpl. exists ([1][+]a); exists ([1][+]b). assert (H0:[1][+]a[<=][1][+]b). apply plus_resp_leEq_lft; assumption. exists H0. split. clear c Hc0 Hc1 F0. intros c [Hc0 Hc1]. split. eapply less_leEq_trans;[|apply Hc0]. destruct (H _ (compact_inc_lft _ _ Hab)) as [A _]. apply shift_less_plus'. rstepl ([--][1]:IR). assumption. eapply leEq_less_trans;[apply Hc1|]. rstepr ([1][+][1]:IR). apply plus_resp_less_lft. destruct (H _ (compact_inc_rht _ _ Hab)) as [_ A]. assumption. intros x _ [Hx0 Hx1]. split; apply plus_resp_leEq_lft; assumption. assert (A0:fun_series_convergent_IR DomArTanH (fun n : nat => Log_ps n[o]([-C-][1]{+}FId))). apply FSeries_Sum_comp_conv with (olor [0] Two); try apply Log_series_convergent_IR; try Contin. assert (B1:maps_compacts_into_weak DomArTanH (olor [0] Two) ([-C-][1]{-}FId)). intros a b Hab H; simpl. exists ([1][-]b); exists ([1][-]a). assert (H0:[1][-]b[<=][1][-]a). apply plus_resp_leEq_lft. apply inv_resp_leEq; assumption. exists H0. split. clear c Hc0 Hc1 F0. intros c [Hc0 Hc1]. split. eapply less_leEq_trans;[|apply Hc0]. destruct (H _ (compact_inc_rht _ _ Hab)) as [_ A]. apply shift_zero_less_minus. assumption. eapply leEq_less_trans;[apply Hc1|]. rstepr ([1][+][--][--][1]:IR). apply plus_resp_less_lft. apply inv_resp_less. destruct (H _ (compact_inc_lft _ _ Hab)) as [A _]. assumption. intros x _ [Hx0 Hx1]. split; apply plus_resp_leEq_lft; apply inv_resp_leEq; assumption. assert (A1:fun_series_convergent_IR DomArTanH (fun n : nat => Log_ps n[o]([-C-][1]{-}FId))). apply FSeries_Sum_comp_conv with (olor [0] Two); try apply Log_series_convergent_IR; try Contin. assert (A2:fun_series_convergent_IR DomArTanH (fun n : nat => ((Log_ps n[o][-C-][1]{+}FId){-}(Log_ps n[o][-C-][1]{-}FId)))). apply FSeries_Sum_minus_conv; assumption. assert (A3:Feq (olor [0] Two) (FSeries_Sum (J:=olor [0] Two) (f:=Log_ps) Log_series_convergent_IR) Logarithm). split. Included. split. intros x [H _]. assumption. intros; apply Log_series. eapply Feq_transitive. unfold Fscalmult. eapply (FSeries_Sum_scal _ _ A2). Contin. unfold F. apply Feq_mult. apply Feq_reflexive. repeat constructor. eapply Feq_transitive. apply (FSeries_Sum_minus _ _ _ A0 A1). apply Feq_minus. eapply Feq_transitive. apply (FSeries_Sum_comp DomArTanH (olor [0] Two)); try assumption. Contin. assert (X:forall (x : IR) (Hx : Dom ([-C-][1]{+}FId) x), DomArTanH x -> olor [0] Two (([-C-][1]{+}FId) x Hx)). intros x Hx [C0 C1]. simpl; split. apply shift_less_plus'. rstepl ([--][1]:IR). assumption. rstepr ([1][+][1]:IR). apply plus_resp_less_lft. assumption. eapply Feq_comp; try apply A3; try (apply Feq_reflexive; Included); assumption. eapply Feq_transitive. apply (FSeries_Sum_comp DomArTanH (olor [0] Two)); try assumption. Contin. assert (X:forall (x : IR) (Hx : Dom ([-C-][1]{-}FId) x), DomArTanH x -> olor [0] Two (([-C-][1]{-}FId) x Hx)). intros x Hx [C0 C1]. simpl; split. apply shift_less_minus. rstepl (x:IR). assumption. rstepr ([1][-][--][1]:IR). apply plus_resp_less_lft. apply inv_resp_less. assumption. eapply Feq_comp; try apply A3; try (apply Feq_reflexive; Included); assumption. apply: mult_wdr. apply eq_symmetric. apply: Log_div. Qed. corn-8.20.0/transc/Exponential.v000066400000000000000000001207201473720167500165270ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.TaylorSeries. Opaque Min Max. (** * Exponential and Logarithmic Functions The main properties of the exponential and logarithmic functions. ** Properties of Exponential Exponential is strongly extensional and well defined. *) Lemma Exp_strext : forall x y : IR, Exp x [#] Exp y -> x [#] y. Proof. intros x y H. exact (un_op_strext_unfolded _ _ _ _ H). Qed. Lemma Exp_wd : forall x y : IR, x [=] y -> Exp x [=] Exp y. Proof. intros x y H. unfold Exp in |- *; algebra. Qed. #[global] Hint Resolve Exp_wd: algebra. Lemma Exp_zero : Exp [0] [=] [1]. Proof. unfold Exp in |- *; simpl in |- *. set (h := (fun n : nat => match n with | O => [1] | S p => [0] end):nat -> IR) in *. cut (forall n : nat, h n [=] ([1][/] _[//]nring_fac_ap_zero _ n) [*]nexp _ n ([0][-][0])). intro H. cut (convergent h). intro H0. apply eq_transitive_unfolded with (series_sum h H0). apply series_sum_wd; algebra. unfold series_sum in |- *. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply Lim_const. apply Lim_seq_eq_Lim_subseq with (f := fun n : nat => S n). auto with arith. intro n; exists (S n); split; auto with arith. intro n; simpl in |- *. induction n as [| n Hrecn]; simpl in |- *; [ algebra | Step_final (OneR[+][0]) ]. apply convergent_wd with (fun n : nat => ([1][/] _[//]nring_fac_ap_zero IR n) [*]nexp _ n ([0][-][0])). algebra. exact (fun_series_conv_imp_conv [0] [0] (leEq_reflexive IR [0]) Exp_ps (Exp_conv [0] [0] (leEq_reflexive IR [0]) (compact_single_iprop realline [0] I)) [0] (compact_single_prop [0]) (fun_series_inc_IR realline Exp_ps Exp_conv [0] I)). simple destruct n; simpl in |- *; intros; rational. Qed. (** $e^1=e$#e1=e#, where [e] was defined a long time ago. *) Lemma Exp_one : Exp [1] [=] E. Proof. unfold E, Exp, e_series in |- *; simpl in |- *. apply series_sum_wd; intro n. astepr (([1][/] _[//]nring_fac_ap_zero IR n) [*][1]); apply mult_wdr. astepl (([1][+][--]ZeroR) [^]n). eapply eq_transitive_unfolded. 2: apply (one_nexp IR n). apply nexp_wd; rational. Qed. #[global] Hint Resolve Exp_zero Exp_one: algebra. (** The exponential function is its own derivative, and continuous. *) Lemma Derivative_Exp : forall H, Derivative realline H Expon Expon. Proof. intro H. unfold Expon, Exp_ps in |- *. cut (fun_series_convergent_IR realline (FPowerSeries' [0] (fun n : nat => (fun _ : nat => [1]) (S n)))). intro H0. eapply Derivative_wdr. 2: apply Derivative_FPowerSeries1' with (a := fun _ : nat => OneR) (Hg := H0). FEQ. simpl in |- *. apply series_sum_wd; algebra. fold Exp_ps in |- *; apply Exp_conv. Qed. #[global] Hint Resolve Derivative_Exp: derivate. Lemma Continuous_Exp : Continuous realline Expon. Proof. apply Derivative_imp_Continuous with I Expon. apply Derivative_Exp. Qed. #[global] Hint Resolve Continuous_Exp: continuous. (** Negative numbers are projected into the interval [[0,1]]. *) Lemma One_less_Exp : forall x : IR, [0] [<] x -> [1] [<] Exp x. Proof. unfold Exp in |- *; simpl in |- *; intros x H. unfold series_sum in |- *. apply less_leEq_trans with ([1][+]x). astepl (OneR[+][0]); apply plus_resp_less_lft; auto. apply str_leEq_seq_so_leEq_Lim. exists 2; intros i Hi. simpl in |- *. unfold seq_part_sum in |- *. induction i as [| i Hreci]. exfalso; inversion Hi. clear Hreci. induction i as [| i Hreci]. exfalso; inversion Hi; inversion H1. clear Hreci. induction i as [| i Hreci]. simpl in |- *. apply eq_imp_leEq; rational. eapply leEq_transitive. apply Hreci; auto with arith. clear Hreci. eapply leEq_wdl. 2: apply cm_rht_unit_unfolded. set (j := S (S i)) in *; clearbody j. simpl in |- *; apply plus_resp_leEq_lft. apply less_leEq; apply mult_resp_pos. apply recip_resp_pos; apply pos_nring_fac. astepr ((x[+][--][0]) [^]j); apply nexp_resp_pos. rstepr x; auto. Qed. Lemma One_leEq_Exp : forall x : IR, [0] [<=] x -> [1] [<=] Exp x. Proof. intros x H. astepl (Exp [0]). apply resp_leEq_char; auto. algebra. intro H0; astepl OneR. apply One_less_Exp; auto. Qed. Lemma Exp_pos' : forall x : IR, [0] [<] x -> [0] [<] Exp x. Proof. intros x H. apply less_leEq_trans with OneR. apply pos_one. apply One_leEq_Exp; apply less_leEq; auto. Qed. (** Exponential is the unique function which evaluates to 1 at 0 and is its own derivative. *) Lemma Exp_unique_lemma : forall H F, Derivative realline H F F -> forall n, Derivative_n n realline H F F. Proof. intros H F H0 n; induction n as [| n Hrecn]. apply Derivative_n_O; Included. apply Derivative_n_plus with n 1 F; auto. apply Derivative_n_1; auto. Qed. Lemma Exp_bnd : Taylor_bnd (fun n => Expon). Proof. apply bnd_imp_Taylor_bnd with Expon. intros n x Hx Hx'; apply eq_imp_leEq; algebra. Contin. Included. Qed. Lemma Exp_unique : forall F, Derivative realline I F F -> (forall H1, F [0] H1 [=] [1]) -> Feq realline Expon F. Proof. intros F H H0. cut (forall n : nat, Derivative_n n realline I Expon Expon). intro derF. cut (Taylor_bnd (fun n : nat => Expon)); [ intro bndf | apply Exp_bnd ]. cut (forall n : nat, Derivative_n n realline I F F). intros derG. apply Taylor_unique_crit with (f := fun _ : nat => Expon) (a := ZeroR) (g := fun n : nat => F) (bndf := bndf) (derF := derF); auto. apply bnd_imp_Taylor_bnd with F. intros; apply eq_imp_leEq; algebra. apply Derivative_n_imp_Continuous with I 1 F; auto with arith. intro n. change (included realline (Dom F)) in |- *. apply Derivative_n_imp_inc with I 1 F; auto with arith. intros; astepr OneR. astepr (Exp [0]). Opaque Expon. unfold Exp in |- *; simpl in |- *; algebra. Transparent Expon. apply Taylor_Series_conv_to_fun; auto. apply Exp_unique_lemma; auto. apply Exp_unique_lemma; apply Derivative_Exp. Qed. Opaque Expon. Lemma Exp_plus_pos : forall z, [0] [<] z -> forall x, Exp (x[+]z) [=] Exp x[*]Exp z. Proof. intros z H x. set (F := ([1][/] _[//]pos_ap_zero _ _ (Exp_pos' _ H)) {**} (Expon[o]FId{+}[-C-]z)) in *. apply eq_symmetric_unfolded. rstepr ((Exp (x[+]z) [/] _[//]pos_ap_zero _ _ (Exp_pos' _ H)) [*]Exp z). apply mult_wdl. unfold Exp at 1 in |- *. simpl in |- *. assert (H0 : Dom F x). repeat split; exists (I, I); apply Exp_domain. apply eq_transitive_unfolded with (Part F x H0). 2: unfold F, Exp in |- *; simpl in |- *; rational. apply Feq_imp_eq with realline. apply Exp_unique. assert (H1 : Derivative realline I Expon Expon). apply Derivative_Exp. unfold F in |- *; Derivative_Help. apply eq_imp_Feq. apply included_FScalMult; apply included_FMult. apply included_FComp; Included. Included. apply included_FScalMult; apply included_FComp; Included. intros; simpl in |- *; rational. apply Derivative_scal. apply Derivative_comp with realline I; Deriv. red in |- *; intros a b Hab H2. exists (a[+]z); exists (b[+]z[+][1]). cut (a[+]z [<] b[+]z[+][1]). intro H3. exists H3; repeat split; simpl in |- *; try rename H4 into X; elim X; try intros H5 H6. apply plus_resp_leEq; auto. apply leEq_transitive with (b[+]z). apply plus_resp_leEq; auto. apply less_leEq; apply less_plusOne. apply leEq_less_trans with (b[+]z). apply plus_resp_leEq; auto. apply less_plusOne. intro H1; simpl in |- *. rational. split. Qed. (** The usual rules for computing the exponential of a sum. *) Lemma Exp_plus : forall x y : IR, Exp (x[+]y) [=] Exp x[*]Exp y. Proof. intros x y. set (z := Max [1] ([1][-]y)) in *. cut ([0] [<] z). intro H. apply mult_cancel_rht with (Exp z). apply Greater_imp_ap; apply Exp_pos'; auto. eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply Exp_plus_pos; auto. astepl (Exp (x[+] (y[+]z))). eapply eq_transitive_unfolded. apply Exp_plus_pos. 2: astepr (Exp x[*] (Exp y[*]Exp z)); apply mult_wdr; apply Exp_plus_pos; auto. unfold z in |- *. apply shift_less_plus'; astepl ( [--]y). apply less_leEq_trans with ([1][-]y). eapply less_wdr. apply less_plusOne. rational. apply rht_leEq_Max. apply less_leEq_trans with OneR. apply pos_one. unfold z in |- *; apply lft_leEq_Max. Qed. #[global] Hint Resolve Exp_plus: algebra. Lemma Exp_plus' : forall x y z : IR, z [=] x[+]y -> Exp z [=] Exp x[*]Exp y. Proof. intros x y z H. Step_final (Exp (x[+]y)). Qed. Lemma Exp_inv_char : forall x : IR, Exp x[*]Exp [--]x [=] [1]. Proof. intro x. astepr (Exp [0]). apply eq_symmetric_unfolded; apply Exp_plus'. algebra. Qed. #[global] Hint Resolve Exp_inv_char: algebra. (** The exponential of any number is always positive---and thus apart from zero. *) Lemma Exp_pos : forall x : IR, [0] [<] Exp x. Proof. intro x. cut (Exp x[*]Exp [--]x [=] [1]); [ intro | apply Exp_inv_char ]. cut ( [--][1] [<=] OneR). intro H0. cut (Continuous_I H0 Expon). intro H1. elim H1; intros Hinc contExp. elim (contExp _ (pos_half IR)); clear H1 Hinc contExp; intros d H1 H2. cut ([0] [<] Min d [1]); [ intro H3 | apply less_Min; auto; apply pos_one ]. cut ( [--] (Min d [1]) [<] [0]); [ intro H4 | astepr ( [--]ZeroR); apply inv_resp_less; auto ]. elim (less_cotransitive _ _ _ H4 x); intro H5. elim (less_cotransitive _ _ _ H3 x); intro H6. apply Exp_pos'; auto. apply less_leEq_trans with (Half:IR). apply pos_half. apply leEq_wdl with ([1][-] (Half:IR)). 2: unfold Half in |- *; rational. apply shift_minus_leEq; apply shift_leEq_plus'. astepl (Exp [0][-]Exp x). eapply leEq_transitive. apply leEq_AbsIR. simpl in |- *; apply H2. split; apply less_leEq. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. apply pos_one. split; apply less_leEq. apply leEq_less_trans with ( [--] (Min d [1])). apply inv_resp_leEq; apply Min_leEq_rht. auto. apply less_leEq_trans with (Min d [1]). auto. apply Min_leEq_rht. astepl (AbsIR [--]x). eapply leEq_wdl. 2: apply AbsIR_inv. simpl in |- *; unfold ABSIR in |- *; apply less_leEq; apply Max_less. apply less_leEq_trans with (Min d [1]); auto; apply Min_leEq_lft. apply less_leEq_trans with ( [--][--] (Min d [1])). apply inv_resp_less; auto. astepl (Min d [1]); apply Min_leEq_lft. clear H4 H3 H2 H1 d H0. apply mult_cancel_less with (Exp [--]x). apply Exp_pos'. astepl ( [--]ZeroR); apply inv_resp_less; auto. astepl ZeroR; astepr OneR; apply pos_one. apply included_imp_Continuous with realline; [ apply Continuous_Exp | repeat split ]. apply leEq_transitive with ZeroR; [ astepr ( [--]ZeroR) | apply less_leEq; apply pos_one ]. apply inv_resp_leEq; apply less_leEq; apply pos_one. Qed. Lemma Exp_ap_zero : forall x : IR, Exp x [#] [0]. Proof. intro; apply Greater_imp_ap; apply Exp_pos. Qed. Lemma pos_E : [0] [<] E. Proof. astepr (Exp [1]). apply Exp_pos. Qed. (** And the rules for the exponential of differences. *) Lemma Exp_inv : forall x : IR, Exp [--]x [=] ([1][/] _[//]Exp_ap_zero x). Proof. intro x. apply mult_cancel_lft with (Exp x). apply Exp_ap_zero. rstepr OneR; algebra. Qed. #[global] Hint Resolve Exp_inv: algebra. Lemma Exp_minus : forall x y : IR, Exp (x[-]y) [=] (Exp x[/] _[//]Exp_ap_zero y). Proof. intros x y. unfold cg_minus in |- *; astepl (Exp x[*]Exp [--]y). rstepr (Exp x[*] ([1][/] _[//]Exp_ap_zero y)). algebra. Qed. #[global] Hint Resolve Exp_minus: algebra. Lemma Exp_inv' : forall x y : IR, y [=] [--]x -> Exp y [=] ([1][/] _[//]Exp_ap_zero x). Proof. intros x y Hxy. Step_final (Exp [--]x). Qed. Lemma Exp_minus' : forall x y z : IR, z [=] x[-]y -> Exp z [=] (Exp x[/] Exp y[//]Exp_ap_zero _). Proof. intros x y z H. Step_final (Exp (x[-]y)). Qed. (** Exponential is a monotonous function. *) Lemma Exp_less_One : forall x : IR, x [<] [0] -> Exp x [<] [1]. Proof. intros x H. astepr (Exp x[*]Exp [--]x). astepl (Exp x[*][1]). apply mult_resp_less_lft. apply One_less_Exp; astepl ( [--]ZeroR); apply inv_resp_less; auto. apply Exp_pos. Qed. Lemma Exp_leEq_One : forall x : IR, x [<=] [0] -> Exp x [<=] [1]. Proof. intros x H. astepr (Exp x[*]Exp [--]x). astepl (Exp x[*][1]). apply mult_resp_leEq_lft. apply One_leEq_Exp; astepl ( [--]ZeroR); apply inv_resp_leEq; auto. apply less_leEq; apply Exp_pos. Qed. Lemma Exp_resp_less : forall x y : IR, x [<] y -> Exp x [<] Exp y. Proof. intros x y H. apply less_wdr with (Exp (x[+] (y[-]x))). 2: apply Exp_wd; rational. astepr (Exp x[*]Exp (y[-]x)). astepl (Exp x[*][1]). apply mult_resp_less_lft. apply One_less_Exp. apply shift_less_minus; astepl x; auto. apply Exp_pos. Qed. Lemma Exp_resp_leEq : forall x y : IR, x [<=] y -> Exp x [<=] Exp y. Proof. intros x y; apply resp_leEq_char. algebra. intro H; apply Exp_resp_less; auto. Qed. (** ** Properties of Logarithm The logarithm is a continuous function with derivative [[1][/]x]. *) Lemma Derivative_Log : forall H, Derivative (openl [0]) H Logarithm {1/}FId. Proof. intro H. unfold Logarithm in |- *. Deriv. Qed. #[global] Hint Resolve Derivative_Log: derivate. Lemma Continuous_Log : Continuous (openl [0]) Logarithm. Proof. apply Derivative_imp_Continuous with I ( {1/} (Fid IR)). Deriv. Qed. #[global] Hint Resolve Continuous_Log: continuous. (** Logarithm of [[1]]. *) Lemma Log_one : forall H, Log [1] H [=] [0]. Proof. intro H; unfold Log in |- *; simpl in |- *. apply Integral_empty; algebra. Qed. #[global] Hint Resolve Log_one: algebra. (** The logarithm is (strongly) extensional. *) Lemma Log_strext : forall (x y : IR) Hx Hy, Log x Hx [#] Log y Hy -> x [#] y. Proof. intros x y Hx Hy H. unfold Log in H. exact (pfstrx _ _ _ _ _ _ H). Qed. Lemma Log_wd : forall (x y : IR) Hx Hy, x [=] y -> Log x Hx [=] Log y Hy. Proof. intros x y Hx Hy H. unfold Log in |- *; algebra. Qed. #[global] Hint Resolve Log_wd: algebra. (** The rule for the logarithm of the product. *) Lemma Log_mult : forall x y Hx Hy Hxy, Log (x[*]y) Hxy [=] Log x Hx[+]Log y Hy. Proof. intros x y Hx Hy Hxy. set (G := (Logarithm[o]y{**}FId) {-}[-C-] (Log y Hy)) in *. cut (proper (openl [0])); [ intro H | simpl in |- *; auto ]. cut (Derivative (openl [0]) H G {1/}FId). intro H0. cut (Derivative (openl [0]) H Logarithm {1/}FId); [ intro H1 | Deriv ]. elim (FTC2 (openl [0]) {1/}FId log_defn_lemma [1] (pos_one IR) H G H0); intros c Hc. fold Logarithm in Hc. elim Hc; intros H2' H2''. elim H2''; intros H2 H5. clear Hc H2 H2' H2''. cut (c [=] [0]). intro H2. cut (forall z w t : IR, w[-] (z[-]t) [=] [0] -> z [=] w[+]t). intro H3. apply H3; clear H3. astepr c; clear H2. cut (Dom (Logarithm{-}G) x); [ intro H2 | repeat split; simpl in |- *; auto ]. eapply eq_transitive_unfolded. 2: apply (H5 x Hx H2 I). Opaque Logarithm. simpl in |- *; algebra. clear H5. exists (I, I); apply mult_resp_pos; auto. intros z w t H3. rstepl (z[-]t[+]t). apply bin_op_wd_unfolded. 2: algebra. apply cg_inv_unique_2. astepr ( [--]ZeroR). rstepl ( [--] (w[-] (z[-]t))). apply un_op_wd_unfolded; auto. cut (Dom (Logarithm{-}G) [1]); [ intro H2 | repeat split; simpl in |- *; auto ]. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply (H5 [1] (pos_one IR) H2 I). simpl in |- *. rstepl ([0][-] (Log y Hy[-]Log y Hy)). algebra. Transparent Logarithm. simpl in |- *; apply pos_one. exists (I, I); simpl in |- *; apply mult_resp_pos; auto; apply pos_one. unfold G in |- *. cut (Derivative (openl [0]) H Logarithm {1/}FId); [ intro H0 | unfold Logarithm in |- *; apply FTC1 ]. Derivative_Help. apply eq_imp_Feq. repeat split. exists (I, I); simpl in |- *. repeat split. intros; apply Greater_imp_ap; apply mult_resp_pos; auto. Included. intros; simpl in |- *; rational. apply Derivative_minus. apply Derivative_comp with (openl [0]) H; Deriv. clear H0; red in |- *; intros a b Hab H0. simpl in |- *; exists (y[*]a); exists (y[*]b[+][1]). cut (y[*]a [<] y[*]b[+][1]). intro H1; exists H1; split. intros x0 H2. elim H2; intros H3 H4; simpl in |- *. apply less_leEq_trans with (y[*]a). apply mult_resp_pos; auto. apply H0; apply compact_inc_lft. auto. intros x0 Hx0 H2; elim H2; intros H3 H4; split. apply mult_resp_leEq_lft; auto. apply less_leEq; auto. apply leEq_transitive with (y[*]b). apply mult_resp_leEq_lft; auto. apply less_leEq; auto. apply less_leEq; apply less_plusOne. apply leEq_less_trans with (y[*]b). apply mult_resp_leEq_lft; auto. apply less_leEq; auto. apply less_plusOne. Deriv. Qed. #[global] Hint Resolve Log_mult: algebra. Lemma Log_mult' : forall x y z Hx Hy Hz, z [=] x[*]y -> Log z Hz [=] Log x Hx[+]Log y Hy. Proof. intros. Step_final (Log (x[*]y) (mult_resp_pos _ _ _ Hx Hy)). Qed. Lemma Log_nexp : forall x n Hx Hxn, Log (x[^]n) Hxn [=] (nring n)[*]Log x Hx. Proof. induction n. intros Hx Hn. simpl. rstepr ([0]:IR). apply Log_one. intros Hx Hn. assert (X:[0][<]x[^]n). apply nexp_resp_pos. assumption. stepl (Log _ X[+]Log x Hx); [| apply eq_symmetric; apply (Log_mult _ _ X Hx)]. astepr ((nring n [+] [1])[*]Log x Hx). rstepr (nring n[*]Log x Hx[+]Log x Hx). apply bin_op_wd_unfolded; try apply eq_reflexive. apply IHn. Qed. #[global] Hint Resolve Log_nexp: algebra. (** A characterization of the domain of the logarithm. *) Lemma Log_domain : forall x : IR, [0] [<] x -> Dom Logarithm x. Proof. intros; auto. Qed. Opaque Expon Logarithm. (** $\log(e^x)=x$#log(ex)=x# for all [x], both as a numerical and as a functional equation. *) Lemma Log_Exp_inv : Feq realline (Logarithm[o]Expon) FId. Proof. apply Feq_criterium with I (Fconst (S:=IR) [1]) ZeroR. cut (Derivative realline I Expon Expon); [ intro H | apply Derivative_Exp ]. cut (Derivative (openl [0]) I Logarithm {1/}FId); [ intro H0 | apply Derivative_Log ]. Derivative_Help. apply eq_imp_Feq. split; auto. exists I. split; auto. intro; simpl in |- *; apply Greater_imp_ap. apply less_wdr with (Exp x); [ apply Exp_pos | simpl in |- *; algebra ]. Included. intros; simpl in |- *; rational. apply Derivative_comp with (openl [0]) I; Deriv. red in |- *; intros a b Hab H1. exists (Exp a); exists (Exp b[+][1]); exists (leEq_less_trans _ _ _ _ (Exp_resp_leEq _ _ Hab) (less_plusOne _ _)). split. red in |- *; intros x H2. elim H2; intros H3 H4. simpl in |- *. apply less_leEq_trans with (Exp a); auto. apply Exp_pos. intros x Hx H2; elim H2; intros H3 H4; split. apply leEq_wdr with (Exp x). apply Exp_resp_leEq; auto. simpl in |- *; algebra. apply less_leEq; apply leEq_less_trans with (Exp b). apply leEq_wdl with (Exp x). apply Exp_resp_leEq; auto. simpl in |- *; algebra. apply less_plusOne. Deriv. split. intros; simpl in |- *. astepr (Log [1] (pos_one _)). unfold Log in |- *; apply pfwdef. astepr (Exp [0]). simpl in |- *; algebra. Qed. Lemma Log_Exp : forall x H, Log (Exp x) H [=] x. Proof. intros x H. cut (Dom (Logarithm[o]Expon) x). intro H0. unfold Log in |- *; simpl in |- *; apply eq_transitive_unfolded with (Part _ _ H0). simpl in |- *; algebra. astepr (Part FId x I). apply Feq_imp_eq with realline. apply Log_Exp_inv. split. exists I. apply Log_domain. apply less_wdr with (Exp x); auto. simpl in |- *; algebra. Qed. Transparent Logarithm. #[global] Hint Resolve Log_Exp: algebra. Lemma Exp_Log_lemma : forall x y Hx Hy, [0] [=] Log y Hy[-]Log x Hx -> y [<=] x. Proof. intros x y Hx Hy H; rewrite -> leEq_def; intro H0. cut ((y[-]x[/] _[//]pos_ap_zero _ _ Hy) [<=] [0]). intro H1. apply less_irreflexive_unfolded with (x := x). apply less_leEq_trans with y; auto. astepr (x[+][0]); apply shift_leEq_plus'. rstepl ((y[-]x[/] _[//]pos_ap_zero _ _ Hy) [*]y). apply shift_mult_leEq with (pos_ap_zero _ _ Hy); auto. rstepr ZeroR; auto. astepr (Log y Hy[-]Log x Hx). unfold Log in |- *; simpl in |- *. apply leEq_wdr with (Integral (prim_lemma _ _ log_defn_lemma x Hx y Hy)). 2: rstepl (Integral (prim_lemma _ _ log_defn_lemma [1] (pos_one _) x Hx) [+] Integral (prim_lemma _ _ log_defn_lemma x Hx y Hy) [-] Integral (prim_lemma _ _ log_defn_lemma [1] (pos_one _) x Hx)). 2: apply cg_minus_wd; algebra. 2: apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 [1] y x). 2: apply included_imp_Continuous with (openl [0]); [ apply log_defn_lemma | intros x0 H1; inversion_clear H1 ]. 2: simpl in |- *; apply less_leEq_trans with (Min (Min [1] y) x); auto; repeat apply less_Min; auto; apply pos_one. cut (Continuous_I (less_leEq _ _ _ H0) {1/}FId). intro H1. apply leEq_wdr with (integral _ _ _ _ H1). 2: apply eq_symmetric_unfolded; apply Integral_integral. rstepl (([1][/] _[//]pos_ap_zero _ _ Hy) [*] (y[-]x)). apply lb_integral. intros x0 H2 Hx0; simpl in |- *. elim H2; intros H3 H4; apply recip_resp_leEq; auto. apply less_leEq_trans with x; auto. apply included_imp_Continuous with (openl [0]); [ apply log_defn_lemma | red in |- *; intros x0 X ]. inversion_clear X; simpl in |- *; apply less_leEq_trans with x; auto. Qed. (** The converse expression. *) Lemma Exp_Log : forall x H, Exp (Log x H) [=] x. Proof. intros x H. set (y := Exp (Log x H)) in *. cut ([0] [<] y); [ intro H0 | unfold y in |- *; apply Exp_pos ]. cut (Log y H0 [=] Log x H); [ intro H1 | unfold y in |- *; algebra ]. cut ([0] [=] Log y H0[-]Log x H); [ clear H1; intro H1 | apply eq_symmetric_unfolded; apply x_minus_x; auto ]. apply leEq_imp_eq. apply Exp_Log_lemma with H H0; auto. apply Exp_Log_lemma with H0 H. astepl ( [--]ZeroR); rstepr ( [--] (Log y H0[-]Log x H)); algebra. Qed. #[global] Hint Resolve Exp_Log: algebra. (** Exponential and logarithm are injective. *) Lemma Exp_cancel : forall x y : IR, Exp x [=] Exp y -> x [=] y. Proof. intros. astepl (Log (Exp x) (Exp_pos x)); Step_final (Log (Exp y) (Exp_pos y)). Qed. Lemma Log_cancel : forall (x y : IR) Hx Hy, Log x Hx [=] Log y Hy -> x [=] y. Proof. intros. astepl (Exp (Log x Hx)); Step_final (Exp (Log y Hy)). Qed. Opaque Logarithm. (** And the final characterization as inverse functions. *) Lemma Exp_Log_inv : Feq (openl [0]) (Expon[o]Logarithm) FId. Proof. apply eq_imp_Feq. red in |- *; intros x H. simpl in H; exists H; apply Exp_domain. Included. intros x H Hx Hx'; simpl in |- *. astepr (Exp (Log x H)). unfold Log in |- *; simpl in |- *; algebra. Qed. Lemma Log_E : forall He, Log E He [=] [1]. Proof. intro. Step_final (Log (Exp [1]) (Exp_pos [1])). Qed. #[global] Hint Resolve Log_E: algebra. (** Several rules regarding inequalities. *) Lemma Log_cancel_less : forall x y Hx Hy, Log x Hx [<] Log y Hy -> x [<] y. Proof. intros x y Hx Hy H. astepl (Exp (Log x Hx)). astepr (Exp (Log y Hy)). apply Exp_resp_less; auto. Qed. Lemma Log_cancel_leEq : forall x y Hx Hy, Log x Hx [<=] Log y Hy -> x [<=] y. Proof. intros x y Hx Hy H. astepl (Exp (Log x Hx)). astepr (Exp (Log y Hy)). apply Exp_resp_leEq; auto. Qed. Lemma Log_resp_less : forall (x y : IR) Hx Hy, x [<] y -> Log x Hx [<] Log y Hy. Proof. intros x y Hx Hy H. unfold Log in |- *; apply Derivative_imp_resp_less with (openl [0]) I ( {1/} (Fid IR)); simpl in |- *; auto. apply Derivative_Log. intro contF. apply less_wdr with ([1][/] _[//]pos_ap_zero _ _ Hy). apply recip_resp_pos; auto. apply glb_charact. split. intros z Hz. elim Hz; intros t H1. elim H1; intros H2 H3. elim H3; clear Hz H1 H3; intros H1 H3. assert (H0 := H3 H1); simpl in H0. astepr ([1][/] t[//]ext2 (P:=fun _ : IR => True) H1). elim H2; intros HMin HMax. apply recip_resp_leEq; auto. apply less_leEq_trans with (Min x y); auto. apply less_Min; auto. apply leEq_wdr with (Max x y); auto. apply leEq_imp_Max_is_rht; apply less_leEq; auto. intros e He. exists ([1][/] _[//]pos_ap_zero _ _ Hy). exists y. split. split; [ apply Min_leEq_rht | apply rht_leEq_Max ]. repeat split. intro; simpl in |- *; apply pos_ap_zero; auto. simpl in |- *; algebra. astepl ZeroR; auto. Qed. Lemma Log_resp_leEq : forall (x y : IR) Hx Hy, x [<=] y -> Log x Hx [<=] Log y Hy. Proof. intros x y Hx Hy; apply resp_leEq_char' with (P := fun x : IR => [0] [<] x). algebra. apply Log_resp_less. Qed. Lemma Exp_cancel_less : forall x y, Exp x [<] Exp y -> x [<] y. Proof. intros x y H. astepl (Log (Exp x) (Exp_pos x)). astepr (Log (Exp y) (Exp_pos y)). apply Log_resp_less; auto. Qed. Lemma Exp_cancel_leEq : forall x y : IR, Exp x [<=] Exp y -> x [<=] y. Proof. intros x y H. astepl (Log (Exp x) (Exp_pos x)). astepr (Log (Exp y) (Exp_pos y)). apply Log_resp_leEq; auto. Qed. Lemma Log_less_Zero : forall (x : IR) Hx, x [<] [1] -> Log x Hx [<] [0]. Proof. intros x Hx H. astepr (Log (Exp [0]) (Exp_pos [0])). apply Log_resp_less. astepr OneR; auto. Qed. Lemma Log_leEq_Zero : forall (x : IR) Hx, x [<=] [1] -> Log x Hx [<=] [0]. Proof. intros x Hx H. astepr (Log (Exp [0]) (Exp_pos [0])). apply Log_resp_leEq. astepr OneR; auto. Qed. Lemma Zero_less_Log : forall (x : IR) Hx, [1] [<] x -> [0] [<] Log x Hx. Proof. intros x Hx H. astepl (Log (Exp [0]) (Exp_pos [0])). apply Log_resp_less. astepl OneR; auto. Qed. Lemma Zero_leEq_Log : forall (x : IR) Hx, [1] [<=] x -> [0] [<=] Log x Hx. Proof. intros x Hx H. astepl (Log (Exp [0]) (Exp_pos [0])). apply Log_resp_leEq. astepl OneR; auto. Qed. (** Finally, rules for logarithm of quotients. *) Lemma Log_recip_char : forall x Hx Hx' Hx'', Log ([1][/] x[//]Hx) Hx'[+]Log x Hx'' [=] [0]. Proof. intros x Hx Hx' Hx''. astepl (Log _ (mult_resp_pos _ _ _ Hx' Hx'')). astepr (Log _ (pos_one IR)). apply Log_wd; rational. Qed. Lemma Log_recip : forall x Hx Hx' Hx'', Log ([1][/] x[//]Hx) Hx' [=] [--] (Log x Hx''). Proof. intros x Hx Hx' Hx''. apply cg_inv_unique'; apply Log_recip_char. Qed. #[global] Hint Resolve Log_recip: algebra. Lemma Log_recip' : forall x y Hx Hx' Hy, y [=] ([1][/] x[//]Hx) -> Log y Hy [=] [--] (Log x Hx'). Proof. intros x y Hx Hx' Hy H. Step_final (Log ([1][/] _[//]Hx) (recip_resp_pos _ _ Hx Hx')). Qed. Lemma Log_div : forall x y Hx Hy Hy' Hxy, Log (x[/] y[//]Hy') Hxy [=] Log x Hx[-]Log y Hy. Proof. intros x y Hx Hy Hy' Hxy. unfold cg_minus in |- *. apply eq_transitive_unfolded with (Log _ (mult_resp_pos _ _ _ Hx (recip_resp_pos _ _ Hy' Hy))). apply Log_wd; rational. Step_final (Log _ Hx[+]Log _ (recip_resp_pos _ _ Hy' Hy)). Qed. #[global] Hint Resolve Log_div: algebra. Lemma Log_div' : forall x y z Hx Hy Hy' Hz, z [=] (x[/] y[//]Hy') -> Log z Hz [=] Log x Hx[-]Log y Hy. Proof. intros x y z Hx Hy Hy' Hz H. Step_final (Log _ (div_resp_pos _ _ _ Hy' Hy Hx)). Qed. Lemma Log_zexp : forall x n Hx Hx0 Hxn, Log ((x[//]Hx0)[^^]n) Hxn [=] (zring n)[*]Log x Hx. Proof. intros x [|n|n] Hx Hx0 Hxn. simpl. rstepr ([0]:IR). algebra. assert (X:[0][<]x[^](nat_of_P n)). astepr ((x[//]Hx0)[^^]n). assumption. change (Log (x[^](nat_of_P n)) Hxn[=]zring (R:=IR) n[*]Log x Hx). astepl (nring (nat_of_P n)[*]Log x Hx). apply mult_wdl. apply eq_symmetric. rewrite <- inject_nat_convert. refine (zring_plus_nat IR (nat_of_P n)). simpl. change (Log (([1][/]x[//]Hx0)[^](nat_of_P n)) Hxn[=][--](zring n)[*]Log x Hx). assert (X:[0][<]([1][/]x[//]Hx0)). apply recip_resp_pos. assumption. astepl ((nring (nat_of_P n))[*](Log _ X)). astepl ((nring (nat_of_P n))[*]([--](Log _ Hx))). rstepl ([--](nring (nat_of_P n))[*](Log x Hx)). apply mult_wdl. apply un_op_wd_unfolded. rewrite <- inject_nat_convert. apply eq_symmetric. refine (zring_plus_nat IR (nat_of_P n)). Qed. #[global] Hint Resolve Log_zexp: algebra. Section Log_Series. Definition Log_series_coef (n:nat) := match n with | O => [0] | (S n') => ([--][1])[^](S (S n'))[/](nring (S n'))[//]nringS_ap_zero IR n' end. Definition Log_ps := FPowerSeries [1] Log_series_coef. Lemma Log_series_convergent_IR : fun_series_convergent_IR (olor [0] Two) Log_ps. Proof. intros a b Hab Hinc. apply fun_ratio_test_conv. unfold Log_ps; unfold FPowerSeries; Contin. exists 1. pose (c:=Max (AbsIR (a[-][1])) (AbsIR (b[-][1]))). assert (Z0:c[<][1]). unfold c. destruct (Hinc _ (compact_inc_lft _ _ Hab)). destruct (Hinc _ (compact_inc_rht _ _ Hab)). apply Max_less; apply AbsIR_less; first [apply shift_minus_less; rstepr (Two:IR) |apply shift_less_minus; rstepl ([0]:IR)]; assumption. assert (Z1:[0][<=]c). unfold c. eapply leEq_transitive. apply AbsIR_nonneg. apply lft_leEq_Max. exists c. assumption. split. assumption. intros x [Hx0 Hx1] n Hn Hx Hx'. destruct n. exfalso; auto with *. unfold Log_ps, FPowerSeries, Log_series_coef. generalize (nringS_ap_zero IR (S n)). generalize (nringS_ap_zero IR (n)). intros Y0 Y1. stepl ( (nexp IR (S (S n)) (AbsIR (x[-][1])))[/]nring (R:=IR) (S (S n))[//]Y1). apply shift_div_leEq. apply nring_pos; auto with *. stepr ((((nexp IR (S n) (AbsIR (x[-][1]))[*]c)[*](nring (R:=IR) (S (S n))))[/]nring (R:=IR) (S n)[//]Y0)). apply shift_leEq_div. apply nring_pos; auto with *. apply mult_resp_leEq_both. apply (nexp_resp_nonneg _ (AbsIR (x[-][1])) (S (S n))). apply AbsIR_nonneg. apply nring_nonneg; auto with *. change (nexp IR (S (S n)) (AbsIR (x[-][1]))) with ((nexp IR (S n) (AbsIR (x[-][1])))[*](AbsIR (x[-][1]))). apply mult_resp_leEq_lft. apply AbsSmall_imp_AbsIR. split. apply shift_zero_leEq_minus'. rstepr (c[-]([--](x[-][1]))). apply shift_zero_leEq_minus. unfold c. eapply leEq_transitive;[|apply lft_leEq_Max]. eapply leEq_transitive;[|apply inv_leEq_AbsIR]. apply inv_resp_leEq. apply minus_resp_leEq. assumption. unfold c. eapply leEq_transitive;[|apply rht_leEq_Max]. eapply leEq_transitive;[|apply leEq_AbsIR]. apply minus_resp_leEq. assumption. apply (nexp_resp_nonneg _ (AbsIR (x[-][1])) (S n)). apply AbsIR_nonneg. apply nring_leEq; auto with *. rstepl (c[*](nexp IR (S n) (AbsIR (x[-][1]))[/] nring (R:=IR) (S n)[//]Y0)[*]nring (R:=IR) (S (S n))). apply mult_wdl. apply mult_wdr. stepl (AbsIR ((x[-][1])[^](S n))[/]_[//](AbsIR_resp_ap_zero _ Y0)). eapply eq_transitive. apply eq_symmetric. apply (AbsIR_division ((x[-][1])[^]S n) _ Y0). stepr (AbsIR (([--][1])[^](S (S n)))[*]AbsIR ((x[-][1])[^]S n[/]nring (R:=IR) (S n)[//]Y0)). rstepl ([1][*]AbsIR ((x[-][1])[^]S n[/]nring (R:=IR) (S n)[//]Y0)). apply mult_wdl. csetoid_rewrite (AbsIR_nexp_op (S (S n)) ([--][1])). csetoid_replace (AbsIR ([--][1])) ([1]:IR). apply eq_symmetric. apply (one_nexp IR (S (S n))). rstepr ([--][--][1]:IR). apply AbsIR_eq_inv_x. apply shift_zero_leEq_minus'. rstepr ([1]:IR). apply less_leEq; apply pos_one. eapply eq_transitive. apply eq_symmetric; apply AbsIR_resp_mult. apply AbsIR_wd. change ((([--][1][^]S (S n)[/]nring (R:=IR) (S n)[//]Y0){**}(FId{-}[-C-][1]){^}S n) x Hx) with ((([--][1][^]S (S n)[/]nring (R:=IR) (S n)[//]Y0)[*](x[-][1])[^]S n)). rational. apply div_wd. apply (AbsIR_nexp (x[-][1]) (S n)). apply AbsIR_eq_x. apply nring_nonneg. stepl (AbsIR ((x[-][1])[^](S (S n)))[/]_[//](AbsIR_resp_ap_zero _ Y1)). eapply eq_transitive. apply eq_symmetric. apply (AbsIR_division ((x[-][1])[^]S (S n)) _ Y1). stepr (AbsIR (([--][1][^]S (S (S n))[*]((x[-][1])[^]S (S n)[/]_[//]Y1)))). eapply eq_transitive;[|apply eq_symmetric; apply AbsIR_resp_mult]. rstepl ([1][*]AbsIR ((x[-][1])[^]S (S n)[/]nring (R:=IR) (S (S n))[//]Y1)). apply mult_wdl. csetoid_rewrite (AbsIR_nexp_op (S (S (S n))) [--][1]). csetoid_replace (AbsIR ([--][1])) ([1]:IR). apply eq_symmetric. apply (one_nexp IR). rstepr ([--][--][1]:IR). apply AbsIR_eq_inv_x. apply shift_zero_leEq_minus'. rstepr ([1]:IR). apply less_leEq; apply pos_one. apply AbsIR_wd. change ((([--][1][^]S (S (S n))[/]nring (R:=IR) (S (S n))[//]Y1){**}(FId{-}[-C-][1]){^}S (S n)) x Hx') with ((([--][1][^]S (S (S n))[/]nring (R:=IR) (S (S n))[//]Y1)[*](x[-][1])[^]S (S n))). rational. apply div_wd. apply (AbsIR_nexp (x[-][1]) (S (S n))). apply AbsIR_eq_x. apply nring_nonneg. Qed. Lemma Log_series : forall c : IR, forall (Hs:fun_series_convergent_IR (olor [0] Two) Log_ps) Hc0 Hc1, FSeries_Sum Hs c Hc0[=]Log c Hc1. Proof. intros c Hs Hc0 Hc1. Transparent Logarithm. assert (Z:fun_series_convergent_IR (olor [0] Two) (fun n : nat => Log_ps (S n))). generalize Log_ps Hs. intros p Hp; clear - Hp. intros a b Hab Hinc. destruct (Hp a b Hab Hinc) as [A B]. exists (fun n => (A (S n))). intros e He. destruct (B e He) as [C D]. exists (C). intros m n Hm Hn x Hx. assert (D' := (D (S m) (S n))). stepl (AbsIR (fun_seq_part_sum p (S m) x (contin_imp_inc a b Hab (fun_seq_part_sum p (S m)) (fun_seq_part_sum_cont a b Hab p A (S m)) x Hx)[-] fun_seq_part_sum p (S n) x (contin_imp_inc a b Hab (fun_seq_part_sum p (S n)) (fun_seq_part_sum_cont a b Hab p A (S n)) x Hx))). apply D'; auto with *. apply AbsIR_wd. set (g:=(fun (y n0 : nat) => Part (p n0) x (contin_imp_inc a b Hab (fun_seq_part_sum p y) (fun_seq_part_sum_cont a b Hab p A y) x Hx n0))). set (g':=(fun y n0 : nat => Part (p (S n0)) x (contin_imp_inc a b Hab (fun_seq_part_sum (fun n1 : nat => p (S n1)) y) (fun_seq_part_sum_cont a b Hab (fun n1 : nat => p (S n1)) (fun n1 : nat => A (S n1)) y) x Hx n0))). change (Sum0 (G:=IR) (S m) (g (S m))[-](Sum0 (G:=IR) (S n) (g (S n)))[=] Sum0 (G:=IR) m (g' m)[-]Sum0 (G:=IR) n (g' n)). stepr ((g (S m) 0[+]Sum0 (G:=IR) m (g' m))[-](g (S n) 0[+]Sum0 (G:=IR) n (g' n))). unfold cg_minus. apply eq_symmetric; apply bin_op_wd_unfolded; try apply un_op_wd_unfolded; apply Sum0_shift; intros i; unfold g', g; apply pfwdef; apply eq_reflexive. apply cg_cancel_lft with (g (S n) 0[-](Sum0 (G:=IR) m (g' m)[-]Sum0 (G:=IR) n (g' n))). rstepr (g (S n) 0). rstepl (g (S m) 0). unfold g; apply pfwdef; apply eq_reflexive. assert (Z0:=insert_series_sum _ _ Z). set (Hs':=(insert_series_conv (olor [0] Two) (fun n : nat => Log_ps (S n)) Z)) in *. apply eq_transitive with (FSeries_Sum (J:=olor [0] Two) (f:=insert_series (fun n : nat => Log_ps (S n))) Hs' c Hc0). simpl. apply series_sum_wd. intros [|n]. simpl; rational. simpl; rational. apply eq_transitive with (FSeries_Sum Z c Hc0). apply Feq_imp_eq with (olor [0] Two). apply Feq_symmetric. apply (insert_series_sum _ _ Z). assumption. simpl. unfold series_sum. apply eq_symmetric. apply Limits_unique. simpl. unfold Log, Logarithm. simpl. assert (X:forall n, Continuous_I (Min_leEq_Max [1] c) (([-C-][1]{-}FId){^}n)). Contin. apply Cauchy_Lim_prop2_wd with (fun n => Integral (fun_seq_part_sum_cont _ _ _ _ X n)). assert (A0:Continuous (olor [0] Two) ({1/}FId)). apply Continuous_recip. Contin. intros a b Hab Hinc. split. Included. exists a. destruct (Hinc _ (compact_inc_lft _ _ Hab)); assumption. simpl. intros y _ Hy. stepr y. destruct Hy; assumption. apply eq_symmetric. apply AbsIR_eq_x. apply less_leEq; destruct (Hinc _ Hy); assumption. assert (A1:forall n : nat, Continuous (olor [0] Two) (fun_seq_part_sum (Fnth (R:=IR) ([-C-][1]{-}FId)) n)). intros n. split. repeat constructor. intros a b Hab Hinc. Contin. eapply (limit_of_Integral (olor [0] Two) _ _ A1 A0). unfold fun_seq_part_sum. assert (A2:fun_series_convergent_IR (olor [0] Two) (Fnth (R:=IR) ([-C-][1]{-}FId))). cut (fun_series_convergent_IR (olor [0] Two) (fun n => FId{^}n[o]([-C-][1]{-}FId))). apply fun_series_convergent_wd_IR. intros n. FEQ. intros x Hx. assert (W:Dom ([-C-][1]{-}FId) x). repeat constructor. exists W. repeat constructor. apply FSeries_Sum_comp_conv with (olor [--][1] [1]). intros a b Hab Hinc. exists ([1][-]b). exists ([1][-]a). assert (W:[1][-]b[<=][1][-]a). unfold cg_minus. apply plus_resp_leEq_lft. apply inv_resp_leEq. assumption. exists W. split. intros x [Hx0 Hx1]. split. eapply less_leEq_trans;[|apply Hx0]. apply shift_less_minus. apply shift_plus_less'. rstepr (Two:IR). destruct (Hinc _ (compact_inc_rht _ _ Hab)); assumption. eapply leEq_less_trans;[apply Hx1|]. apply shift_minus_less. apply shift_less_plus'. rstepl ([0]:IR). destruct (Hinc _ (compact_inc_lft _ _ Hab)); assumption. intros x Hx [Hx0 Hx1]. split; simpl. apply shift_leEq_minus'. apply shift_plus_leEq. rstepr b. assumption. apply shift_leEq_minus'. apply shift_plus_leEq. rstepr x. assumption. Contin. apply fun_power_series_conv_IR. assert (A3:Continuous (olor [0] Two) (FSeries_Sum (J:=olor [0] Two) (f:=Fnth (R:=IR) ([-C-][1]{-}FId)) A2)). Contin. eapply (conv_fun_seq'_wdr_IR);[|apply (FSeries_conv _ _ A2 A1 A3)]. FEQ. assert (Y:AbsIR ([1][-]x)[<][1]). destruct X0. apply AbsIR_less. apply shift_minus_less. apply shift_less_plus'. rstepl ([0]:IR); assumption. apply shift_less_minus'. apply shift_plus_less. rstepr (Two:IR); assumption. assert (Y0:[1][-]([1][-]x)[#][0]). rstepl (x). apply Greater_imp_ap. destruct X0; assumption. apply eq_transitive with ([1][/]_[//]Y0). eapply eq_transitive;[|apply (power_series_sum _ Y Y0 (power_series_conv _ Y))]. simpl. apply series_sum_wd. intros n; apply eq_reflexive. simpl. rational. intros x [Hx0 Hx1]. split. apply less_leEq_trans with (Min [1] c); try assumption. apply less_Min; try assumption. apply pos_one. apply leEq_less_trans with (Max [1] c); try assumption. destruct Hc0. apply Max_less; try assumption. apply one_less_two. intros n. induction n. simpl. rstepr ([0][*](c[-][1])). eapply eq_transitive;[|apply (Integral_const _ _ (Min_leEq_Max [1] c) [0] (Continuous_I_const _ _ _ _))]. apply Integral_wd. FEQ. auto with *. simpl. csetoid_rewrite_rev IHn. assert (Y:Continuous_I (Min_leEq_Max [1] c) (([-C-][1]{-}FId){^}n)). Contin. csetoid_replace ((nexp IR n [--][1][*][--][1][*][--][1][/]nring (R:=IR) n[+][1][//] nringS_ap_zero IR n)[*](nexp IR n (c[-][1])[*](c[-][1]))) (Integral Y). assert (Y0:=Continuous_I_plus _ _ _ _ _ (fun_seq_part_sum_cont (Min [1] c) (Max [1] c) (Min_leEq_Max [1] c) (Fnth (R:=IR) ([-C-][1]{-}FId)) X n) Y). stepl (Integral Y0). apply Integral_plus. apply Integral_wd. apply eq_imp_Feq; try Included. intros x Hx; split; constructor. intros x H Hx Hx'. simpl. apply eq_reflexive. rstepl ((nexp IR n [--][1][/]nring (R:=IR) n[+][1][//] nringS_ap_zero IR n)[*](nexp IR n (c[-][1])[*](c[-][1]))). change ((nexp IR n [--][1][/]nring (R:=IR) n[+][1][//]nringS_ap_zero IR n)[*] (nexp IR n (c[-][1])[*](c[-][1]))) with (([--][1][^]n[/]_[//]nringS_ap_zero IR n)[*](c[-][1])[^](S n)). pose (G:=(([--][1][/]_[//]nringS_ap_zero IR n){**}([-C-][1]{-}FId){^}(S n))). assert (X0:Derivative (olor [0] Two) (pos_two IR) G (([-C-][1]{-}FId){^}n)). unfold G. eapply Derivative_wdr; simpl in |- *; [|apply Derivative_scal;refine (Derivative_nth _ _ _ _ _ _);Deriv]. FEQ. repeat constructor. assert (X1:Continuous (olor [0] Two) (([-C-][1]{-}FId){^}n)). Contin. assert (X2:(olor [0] Two [1])). split. apply pos_one. apply one_less_two. eapply eq_transitive. 2:apply eq_symmetric. 2:apply (fun A => Barrow (olor [0] Two) _ X1 _ _ X0 _ _ A X2 Hc0). simpl. rstepr (([--][1][/]nring (R:=IR) n[+][1][//]nringS_ap_zero IR n)[*] (nexp IR n ([1][-]c)[*]([1][-]c))). change (([--][1][^]n[/]_[//]nringS_ap_zero IR n)[*] ((c[-][1])[^](S n))[=] ([--][1][/]_[//]nringS_ap_zero IR n)[*] (([1][-]c)[^](S n))). rstepr (([--][1][/]nring (R:=IR) (S n)[//]nringS_ap_zero IR n)[*] ([--][1][*](c[-][1]))[^]S n). csetoid_rewrite (mult_nexp IR ([--][1]) (c[-][1]) (S n)). simpl. rational. Qed. End Log_Series. corn-8.20.0/transc/InvTrigonom.v000066400000000000000000001165031473720167500165200ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.RealPowers. Require Export CoRN.transc.TrigMon. Require Export CoRN.ftc.StrongIVT. (** printing ArcSin %\ensuremath{\arcsin}% *) (** printing ArcCos %\ensuremath{\arccos}% *) (** printing ArcTan %\ensuremath{\arctan}% *) (** * Inverse Trigonometric Functions ** Definitions We will now define arcsine, arccosine and arctangent as indefinite integrals and prove their main properties. We begin by proving that the appropriate indefinite integrals can be defined, then prove the main properties of the function. Arccosine is defined in terms of arcsine by the relation [ArcCos(x)=Pi[/]Two-ArcSin(x)]. *** Arcsine *) Opaque Sine Cosine Expon Logarithm. Lemma ArcSin_def_lemma : Continuous (olor [--][1] [1]) (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)). Proof. split. unfold FPower in |- *. apply included_FComp. apply included_FMult. Included. apply included_FComp. Included. intros; apply Log_domain. inversion_clear X. simpl in |- *; apply shift_less_minus; astepl (x[^]2). astepr (OneR[^]2). apply AbsIR_less_square. simpl in |- *; unfold ABSIR in |- *; apply Max_less; auto. apply inv_cancel_less; astepr x; auto. intros; apply Exp_domain. intros a b Hab H. apply continuous_I_power. Contin. Contin. split. Included. simpl in H. set (c := Max (AbsIR a) (AbsIR b)) in *. cut ([0] [<=] c); intros. 2: unfold c in |- *; apply leEq_transitive with (AbsIR a); [ apply AbsIR_nonneg | apply lft_leEq_Max ]. elim (H _ (compact_inc_lft _ _ Hab)); intros. elim (H _ (compact_inc_rht _ _ Hab)); intros. assert (H1 : c [<] [1]). unfold c in |- *. apply Max_less; simpl in |- *; unfold ABSIR in |- *; apply Max_less; auto; apply inv_cancel_less. astepr a; auto. astepr b; auto. assert (Hc : [--]c [<=] c). apply leEq_transitive with ZeroR; auto. astepr ( [--]ZeroR); apply inv_resp_leEq; auto. cut (included (Compact Hab) (Compact Hc)). intro H2. exists ([1][-]c[^]2). apply shift_less_minus. astepl (c[^]2); astepr (OneR[^]2). apply nexp_resp_less; auto. intros y H3 Hy. astepr ([1][-]y[^]2). apply minus_resp_leEq_both. apply leEq_reflexive. apply AbsIR_leEq_square. elim (H2 _ H3); intros. simpl in |- *; unfold ABSIR in |- *; apply Max_leEq; auto. astepr ( [--] [--]c); apply inv_resp_leEq; auto. intros x H2. inversion_clear H2; unfold c in |- *; split. astepr ( [--] [--]x); apply inv_resp_leEq. apply leEq_transitive with ( [--]a). apply inv_resp_leEq; auto. eapply leEq_transitive; [ apply inv_leEq_AbsIR | apply lft_leEq_Max ]. apply leEq_transitive with b; auto. eapply leEq_transitive; [ apply leEq_AbsIR | apply rht_leEq_Max ]. Qed. Lemma ArcSin_def_zero : olor [--][1] [1] [0]. Proof. split. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. apply pos_one. Qed. Definition ArcSin := ( [-S-]ArcSin_def_lemma) _ ArcSin_def_zero. Lemma ArcSin_domain : forall x, [--][1] [<] x -> x [<] [1] -> Dom ArcSin x. Proof. intros; split; auto. Qed. Lemma Continuous_ArcSin : Continuous (olor [--][1] [1]) ArcSin. Proof. unfold ArcSin in |- *; apply Continuous_prim. Qed. Lemma Derivative_ArcSin : forall H, Derivative (olor [--][1] [1]) H ArcSin (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)). Proof. intros; unfold ArcSin in |- *. apply FTC1. Qed. #[global] Hint Resolve Derivative_ArcSin: derivate. #[global] Hint Resolve Continuous_ArcSin: continuous. (** *** Arccosine *) Definition ArcCos := [-C-] (Pi [/]TwoNZ) {-}ArcSin. Lemma ArcCos_domain : forall x : IR, [--][1] [<] x -> x [<] [1] -> Dom ArcCos x. Proof. intros; repeat split; auto. Qed. Lemma Continuous_ArcCos : Continuous (olor [--][1] [1]) ArcCos. Proof. unfold ArcCos in |- *; Contin. Qed. Lemma Derivative_ArcCos : forall H, Derivative (olor [--][1] [1]) H ArcCos {--} (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)). Proof. intros; unfold ArcCos in |- *. apply Derivative_wdr with ( [-C-][0]{-} ( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)). 2: Deriv. apply eq_imp_Feq. apply included_FMinus. Included. apply Continuous_imp_inc; apply ArcSin_def_lemma. apply included_FInv. apply Continuous_imp_inc; apply ArcSin_def_lemma. intros. astepl (Part _ _ (ProjIR1 Hx) [-]Part _ _ (ProjIR2 Hx)). astepl ([0][-]Part _ _ (ProjIR2 Hx)). astepl ( [--] (Part _ _ (ProjIR2 Hx))). Step_final ( [--] ((( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)) x Hx')). Qed. (** *** Arctangent *) Lemma ArcTan_def_lemma : Continuous realline {1/} ( [-C-][1]{+}FId{^}2). Proof. apply Continuous_recip. Contin. red in |- *; intros. split. Included. exists OneR. apply pos_one. intros; simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. apply shift_leEq_plus'. astepl ZeroR; astepr (y[^]2). apply sqr_nonneg. Qed. Definition ArcTang := ( [-S-]ArcTan_def_lemma) [0] I. Lemma ArcTan_domain : forall x : IR, Dom ArcTang x. Proof. intros; simpl in |- *; auto. Qed. Definition ArcTan (x : IR) := ArcTang x I. Lemma Continuous_ArcTan : Continuous realline ArcTang. Proof. unfold ArcTang in |- *; Contin. Qed. Lemma Derivative_ArcTan : forall H, Derivative realline H ArcTang {1/} ( [-C-][1]{+}FId{^}2). Proof. intros; unfold ArcTang in |- *; apply FTC1. Qed. Lemma ArcTan_wd : forall x y, x[=]y -> ArcTan x [=] ArcTan y. Proof. intros. refine (pfwdef _ _ _ _ _ _ _). assumption. Qed. #[global] Hint Resolve ArcTan_wd: algebra. #[global] Hint Resolve Derivative_ArcCos Derivative_ArcTan: derivate. #[global] Hint Resolve Continuous_ArcCos Continuous_ArcTan: continuous. Section Inverses. (** ** Composition properties We now prove that this functions are in fact inverses to the corresponding trigonometric functions. *** Sine and Arcsine *) Lemma maps_Sin : maps_compacts_into (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) (olor [--][1] [1]) Sine. Proof. intros a b Hab H. set (min := Min (Sin a) [--] ([1] [/]TwoNZ)) in *. set (max := Max (Sin b) ([1] [/]TwoNZ)) in *. cut (min [<] max). intro H0. exists min; exists max; exists H0. elim (H _ (compact_inc_lft _ _ Hab)); intros Ha1 Ha2. elim (H _ (compact_inc_rht _ _ Hab)); intros Hb1 Hb2. split. intros x H1. unfold Nat.min, Nat.max in H1; inversion_clear H1; split. apply less_leEq_trans with min. unfold Nat.min in |- *; apply less_Min. apply inv_cancel_less; astepr OneR. eapply leEq_less_trans. apply inv_leEq_AbsIR. apply Abs_Sin_less_One; auto. apply inv_resp_less; apply (half_lt1 IR). auto. eapply leEq_less_trans. apply H3. apply Max_less. eapply leEq_less_trans. apply leEq_AbsIR. apply Abs_Sin_less_One; auto. apply (half_lt1 IR). intros x Hx H1. apply compact_wd with (Sin x). 2: simpl in |- *; algebra. unfold Nat.min, Nat.max in |- *; inversion_clear H1. split. eapply leEq_transitive; [ apply Min_leEq_lft | apply Sin_resp_leEq; auto ]. apply less_leEq; auto. apply less_leEq; apply leEq_less_trans with b; auto. eapply leEq_transitive. 2: apply lft_leEq_Max. apply Sin_resp_leEq; auto. apply leEq_transitive with a; auto; apply less_leEq; auto. apply less_leEq; auto. unfold Nat.min, Nat.max in |- *; apply less_transitive_unfolded with ZeroR. eapply leEq_less_trans. apply Min_leEq_rht. astepr ( [--][0]:IR); apply inv_resp_less; apply (pos_half IR). eapply less_leEq_trans; [ apply (pos_half IR) | apply rht_leEq_Max ]. Qed. Lemma ArcSin_Sin_inv : Feq (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) (ArcSin[o]Sine) FId. Proof. set (HPi1 := pos_HalfPi) in *. set (HPi2 := neg_invHalfPi) in *. set (H := invHalfPi_less_HalfPi:proper (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ))) in *. apply Feq_criterium with H ( [-C-][1]:PartIR) ZeroR. assert (H0 : Derivative _ H Sine Cosine). apply Included_imp_Derivative with realline I; Deriv. assert (H1 : [--][1] [<] OneR). set (H' := pos_one IR) in *; apply less_transitive_unfolded with ZeroR; auto. astepr ( [--]ZeroR); apply inv_resp_less; auto. set (H2 := Derivative_ArcSin H1) in *. eapply Derivative_wdr. 2: apply (Derivative_comp _ _ _ _ _ _ _ _ maps_Sin H0 H2). apply eq_imp_Feq. apply included_FMult. apply included_FComp. Included. intros. unfold FPower in |- *. cut (Dom ( [-C-] [--] ([1] [/]TwoNZ) {*} (Logarithm[o] [-C-][1]{-}FId{^}2)) (Part _ _ Hx)). intro H3. exists H3; apply Exp_domain. split. auto. exists (I, I). apply Log_domain. astepr ([1][-]Sine x Hx[^]2). astepl (OneR[-][1]). unfold cg_minus in |- *; apply plus_resp_less_lft. apply inv_resp_less. astepr (OneR[^]2); apply AbsIR_less_square. apply less_wdl with (AbsIR (Sin x)). inversion_clear X; apply Abs_Sin_less_One; auto. apply AbsIR_wd; simpl in |- *; algebra. split. split. intros x H3 Hx Hx'. astepr OneR. cut ([0] [<] [1][-]Sin x[^]2). intro H4. apply eq_transitive_unfolded with (([1][-]Sin x[^]2) [!] [--] ([1] [/]TwoNZ) [//]H4[*]Cos x). unfold power, FPower in |- *. unfold FPower in Hx. astepl (Part _ _ (ProjIR1 Hx) [*]Part _ _ (ProjIR2 Hx)). apply mult_wd. 2: simpl in |- *; algebra. elim Hx; clear Hx; intros Hx Hx1. astepl (Part _ _ Hx); clear Hx1. astepl (Part _ _ (ProjT2 Hx)). elim Hx; clear Hx; intros Hx1 Hx2. astepl (Part _ _ Hx2). astepl (Part _ _ (ProjT2 Hx2)). simpl in |- *; apply pfwdef. elim Hx2; intros Hx3 Hx4. astepl (Part _ _ Hx3). clear Hx4 Hx2. astepl ( [--] ([1] [/]TwoNZ) [*]Part _ _ (ProjIR2 Hx3)). elim Hx3; clear Hx3; intros Hx2 Hx3. astepl ( [--] ([1] [/]TwoNZ) [*]Part _ _ Hx3). apply mult_wdr. astepl (Part _ _ (ProjT2 Hx3)). unfold Log in |- *; apply pfwdef. elim Hx3; intros Hx4 Hx5. astepl (Part _ _ Hx4). astepl (Part _ _ (ProjIR1 Hx4) [-]Part _ _ (ProjIR2 Hx4)). elim Hx4; clear Hx5 Hx4 Hx3 Hx2; intros Hx2 Hx3. astepl (Part _ _ Hx2[-]Part _ _ Hx3). apply cg_minus_wd. algebra. simpl in |- *; algebra. unfold RealPowers.power in |- *. astepl (Exp [--] ([1] [/]TwoNZ[*]Log _ H4) [*]Cos x). astepl (([1][/] _[//]Exp_ap_zero ([1] [/]TwoNZ[*]Log _ H4)) [*]Cos x). astepr (Exp ([1] [/]TwoNZ[*]Log _ H4) [/] _[//]Exp_ap_zero ([1] [/]TwoNZ[*]Log _ H4)). rstepl (Cos x[/] _[//]Exp_ap_zero ([1] [/]TwoNZ[*]Log _ H4)). apply div_wd. 2: algebra. astepr (Exp (Log _ H4[*][1] [/]TwoNZ)). assert (H5 : [0] [<] Cos x). inversion_clear H3; apply Cos_pos; auto. astepl (Exp (Log _ H5)). apply Exp_wd. rstepl ((Log _ H5[+]Log _ H5) [/]TwoNZ). rstepr (Log _ H4 [/]TwoNZ). apply div_wd. 2: algebra. astepl (Log _ (mult_resp_pos _ _ _ H5 H5)). astepl (Log _ (pos_square _ _ (pos_ap_zero _ _ H5))). apply Log_wd. astepr (Cos x[^]2[+]Sin x[^]2[-]Sin x[^]2); rational. astepl (OneR[-][1]). unfold cg_minus in |- *. apply plus_resp_less_lft. apply inv_resp_less. astepr (OneR[^]2); apply AbsIR_less_square. inversion_clear H3; apply Abs_Sin_less_One; auto. Deriv. split; auto. intros; simpl in |- *; apply Integral_empty. astepl (Sin [0]); simpl in |- *; algebra. Qed. Opaque ArcSin. Lemma ArcSin_Sin : forall x, [--] (Pi [/]TwoNZ) [<] x -> x [<] Pi [/]TwoNZ -> forall H, ArcSin (Sin x) H [=] x. Proof. intros. unfold Sin in |- *. astepr (FId x I). cut (Dom (ArcSin[o]Sine) x). intro H2. apply eq_transitive_unfolded with ((ArcSin[o]Sine) x H2). simpl in |- *; algebra. apply Feq_imp_eq with (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)). apply ArcSin_Sin_inv. split; auto. exists I; auto. Qed. Lemma ArcSin_range : forall x Hx, [--] (Pi [/]TwoNZ) [<] ArcSin x Hx and ArcSin x Hx [<] Pi [/]TwoNZ. Proof. intros. Transparent ArcSin. cut {y : IR | olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) y | forall Hy, Sine y Hy [=] x}. intros H; elim H; clear H; intros y H H0. elim H; clear H; intros H1 H2. assert (H : Sin y [=] x). simpl in |- *; algebra. assert (H3 : Dom ArcSin (Sin y)). apply dom_wd with x; algebra. split. astepr (ArcSin _ H3). apply less_wdr with y; auto. apply eq_symmetric_unfolded; apply ArcSin_Sin; auto. astepl (ArcSin _ H3). apply less_wdl with y; auto. apply eq_symmetric_unfolded; apply ArcSin_Sin; auto. elim Hx; intros H H0. set (H1 := less_leEq _ _ _ invHalfPi_less_HalfPi) in *. cut (Continuous_I H1 Sine). intro H2. apply IVT'_I with H1 H2; auto. PiSolve. intros x0 y H3 H4 H5 Hx0 Hy. 2: astepl (Sine [--] (Pi [/]TwoNZ) I); astepl (Sin [--] (Pi [/]TwoNZ)); astepl ( [--] (Sin (Pi [/]TwoNZ))); astepl ( [--]OneR); auto. 2: astepr (Sine (Pi [/]TwoNZ) I); astepr (Sin (Pi [/]TwoNZ)); astepr OneR; auto. 2: apply included_imp_Continuous with realline; Contin. apply less_wdl with (Sin x0). 2: simpl in |- *; algebra. apply less_wdr with (Sin y). 2: simpl in |- *; algebra. inversion_clear H3; inversion_clear H4; apply Sin_resp_less; auto. Qed. Lemma Sin_ArcSin : forall (x : IR) Hx, x [=] Sin (ArcSin x Hx). Proof. intros. set (y := Sin (ArcSin x Hx)) in *. cut (Dom ArcSin y). intro H. cut (ArcSin x Hx [=] ArcSin y H). intro H0. 2: unfold y in |- *; inversion_clear H. 2: apply eq_symmetric_unfolded. Transparent ArcSin. simpl in H0. unfold y in H0. cut (Continuous_I (Min_leEq_Max x y) (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ))). intro H1. cut (Integral H1 [=] [0]). intro H2. clear H0. elim H; intros H0 H3. elim Hx; clear H; intros H H4. apply Integral_eq_zero with (contF := H1) (x := x). exact (pair (Min_leEq_lft x y) (lft_leEq_Max x y)). unfold FPower in |- *; intros. astepr (Part _ _ (ProjT2 Hx0)). apply less_wdr with (Exp (Part _ _ (ProjT1 Hx0))). apply Exp_pos. simpl in |- *; algebra. unfold FPower in |- *; intros. apply less_leEq; astepr (Part _ _ (ProjT2 Hx0)). apply less_wdr with (Exp (Part _ _ (ProjT1 Hx0))). apply Exp_pos. simpl in |- *; algebra. auto. apply eq_transitive_unfolded with (ArcSin y H[-]ArcSin x Hx). rstepl (ArcSin x Hx[+]Integral H1[-]ArcSin x Hx). apply cg_minus_wd; [ simpl in |- * | algebra ]. apply eq_symmetric_unfolded; apply Integral_plus_Integral with (Min3_leEq_Max3 [0] y x). apply included_imp_Continuous with (olor [--][1] [1]). exact ArcSin_def_lemma. apply included3_interval; auto. split. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. apply pos_one. apply x_minus_x; simpl in |- *; algebra. apply included_imp_Continuous with (olor [--][1] [1]). exact ArcSin_def_lemma. apply included_interval; auto. elim (ArcSin_range x Hx); intros; apply ArcSin_Sin; auto. elim (ArcSin_range x Hx); intros; apply ArcSin_domain. unfold y in |- *. astepr ( [--] [--] (Sin (ArcSin x Hx))); astepr ( [--] (Sin [--] (ArcSin x Hx))); apply inv_resp_less. apply Sin_less_One. apply Cos_pos. apply inv_resp_less; auto. astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; auto. unfold y in |- *; apply Sin_less_One. apply Cos_pos; auto. Qed. Lemma Sin_ArcSin_inv : Feq (olor [--][1] [1]) (Sine[o]ArcSin) FId. Proof. apply eq_imp_Feq. apply included_FComp. Included. intros; apply sin_domain. Included. intros x H Hx Hx'. elim Hx; intros x0 H0. astepr x; astepl (Part _ _ (ProjT2 Hx)); astepl (Part _ _ H0). apply eq_transitive_unfolded with (Sin (ArcSin x x0)). simpl in |- *; algebra. apply eq_symmetric_unfolded; apply Sin_ArcSin. algebra. Qed. Lemma ArcSin_resp_leEq : forall x y, [--][1] [<] x -> x [<=] y -> y [<] [1] -> forall Hx Hy, ArcSin x Hx [<=] ArcSin y Hy. Proof. intros x y H H0 H1 Hx Hy. assert (H2 : [--][1] [<] OneR). apply less_transitive_unfolded with ZeroR; [ astepr ( [--]ZeroR); apply inv_resp_less | idtac ]; apply pos_one. apply Derivative_imp_resp_leEq with (olor [--][1] [1]) H2 (( [-C-][1]{-}FId{^}2) {!} [-C-] [--] ([1] [/]TwoNZ)); Deriv. intros; apply leEq_glb; intro z; intros. elim Hy0; intros. apply leEq_wdr with (Exp (( [-C-] [--] ([1] [/]TwoNZ) {*} (Logarithm[o] [-C-][1]{-}FId{^}2)) z x0)). apply less_leEq; apply Exp_pos. simpl in |- *; algebra. Qed. (** *** Cosine and Arcosine *) Lemma ArcCos_Cos : forall x, [0] [<] x -> x [<] Pi -> forall H, ArcCos (Cos x) H [=] x. Proof. intros x H H0 H1. assert (H2 : Dom ArcCos (Sin (Pi [/]TwoNZ[-]x))). apply dom_wd with (Cos x); algebra. astepl (Part _ _ H2). unfold ArcCos in |- *. astepl (Pi [/]TwoNZ[-]Part _ _ (ProjIR2 H2)). rstepr (Pi [/]TwoNZ[-] (Pi [/]TwoNZ[-]x)). apply cg_minus_wd. algebra. apply ArcSin_Sin. apply shift_less_minus; apply shift_plus_less'. rstepr Pi; auto. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; auto. Qed. Lemma Cos_ArcCos : forall (x : IR) Hx, x [=] Cos (ArcCos x Hx). Proof. intros. unfold ArcCos in |- *. astepr (Cos (Pi [/]TwoNZ[-]ArcSin x (ProjIR2 Hx))). astepr (Sin (ArcSin x (ProjIR2 Hx))). apply Sin_ArcSin. Qed. Lemma ArcCos_Cos_inv : Feq (olor [0] Pi) (ArcCos[o]Cosine) FId. Proof. apply eq_imp_Feq. apply included_FComp. Included. intros. apply ArcCos_domain. apply less_wdr with (Cos x). 2: simpl in |- *; algebra. apply inv_cancel_less. astepr OneR. eapply leEq_less_trans. apply inv_leEq_AbsIR. inversion_clear X; apply Abs_Cos_less_One; auto. apply less_wdl with (Cos x). 2: simpl in |- *; algebra. eapply leEq_less_trans. apply leEq_AbsIR. inversion_clear X; apply Abs_Cos_less_One; auto. Included. intros. astepl (Part _ _ (ProjT2 Hx)); astepr x. cut (Dom ArcCos (Cos x)). intro H0. apply eq_transitive_unfolded with (ArcCos (Cos x) H0). apply pfwdef; simpl in |- *; algebra. inversion_clear X; apply ArcCos_Cos; auto. inversion_clear Hx. apply dom_wd with (Cosine x x0); auto. simpl in |- *; algebra. Qed. Lemma Cos_ArcCos_inv : Feq (olor [--][1] [1]) (Cosine[o]ArcCos) FId. Proof. apply eq_imp_Feq. apply included_FComp. unfold ArcCos in |- *; Included. intros; apply cos_domain. Included. intros. inversion_clear Hx. astepr x; astepl (Part _ _ (ProjT2 Hx)); astepl (Part _ _ X0). apply eq_transitive_unfolded with (Cos (ArcCos x x0)). simpl in |- *; algebra. apply eq_symmetric_unfolded; apply Cos_ArcCos. Qed. Lemma ArcCos_resp_leEq : forall x y, [--][1] [<] x -> x [<=] y -> y [<] [1] -> forall Hx Hy, ArcCos y Hy [<=] ArcCos x Hx. Proof. intros. Opaque ArcSin. simpl in |- *; unfold cg_minus in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq; apply ArcSin_resp_leEq; auto. Qed. (** *** Tangent and Arctangent *) Lemma maps_Tan : maps_compacts_into (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) realline Tang. Proof. intros a b Hab H. elim (H _ (compact_inc_lft _ _ Hab)); intros Ha1 Ha2. elim (H _ (compact_inc_rht _ _ Hab)); intros Hb1 Hb2. cut (Dom Tang b). cut (Dom Tang a). intros H0 H1. set (min := Min (Tan a H0) [0]) in *. set (max := Max (Tan b H1) [1]) in *. cut (min [<] max). intro H2. exists min; exists max; exists H2. split. Included. intros x Hx H3. fold (Tan x Hx) in |- *. unfold Nat.min, Nat.max in |- *; inversion_clear H3. split. eapply leEq_transitive; [ apply Min_leEq_lft | apply Tan_resp_leEq; auto ]. apply leEq_less_trans with b; auto. eapply leEq_transitive. 2: apply lft_leEq_Max. apply Tan_resp_leEq; auto. apply less_leEq_trans with a; auto. unfold Nat.min, Nat.max in |- *. eapply leEq_less_trans. apply Min_leEq_rht. eapply less_leEq_trans; [ apply pos_one | apply rht_leEq_Max ]. split. apply sin_domain. split. apply cos_domain. intros; apply ap_wdl with (Cos a). apply Greater_imp_ap; apply Cos_pos; auto. simpl in |- *; algebra. split. apply sin_domain. split. apply cos_domain. intros; apply ap_wdl with (Cos b). apply Greater_imp_ap; apply Cos_pos; auto. simpl in |- *; algebra. Qed. Lemma ArcTan_Tan_inv : Feq (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) (ArcTang[o]Tang) FId. Proof. set (HPi1 := pos_HalfPi) in *. set (HPi2 := neg_invHalfPi) in *. set (H := invHalfPi_less_HalfPi) in *. apply Feq_criterium with H ( [-C-][1]:PartIR) ZeroR. set (H0 := Derivative_Tan_2 H) in *. set (H2 := Derivative_ArcTan I) in *. Derivative_Help. apply eq_imp_Feq. apply included_FMult. apply included_FComp. Included. intros. split. repeat split. intros. astepl ([1][+]Tang x Hx[^]2). apply pos_ap_zero. astepl (ZeroR[+][0]); apply plus_resp_less_leEq. apply pos_one. apply sqr_nonneg. Included. Included. intros. astepr OneR. astepl (Part _ _ (ProjIR1 Hx) [*]Part _ _ (ProjIR2 Hx)). elim Hx; intros H3 H4. astepl (Part _ _ H3[*]Part _ _ H4). astepl (Part _ _ (ProjT2 H3) [*] (Part _ _ (ProjIR1 H4) [+]Part _ _ (ProjIR2 H4))). elim H3; intros x0 H5; elim H4; intros H6 H7. astepl (Part _ _ H5[*] (Part _ _ H6[+]Part _ _ H7)). astepl (Part _ _ H5[*] ([1][+]Tang x H7[^]2)). simpl in |- *; rational. apply Derivative_comp with realline I. apply maps_Tan. Deriv. Deriv. Deriv. split; auto. intros. astepr ZeroR. inversion_clear Hx. Opaque Tang. simpl in |- *. apply Integral_empty. algebra. Qed. Transparent Tang. Opaque ArcTang. Lemma ArcTan_Tan : forall x, [--] (Pi [/]TwoNZ) [<] x -> x [<] Pi [/]TwoNZ -> forall H, ArcTan (Tan x H) [=] x. Proof. intros. unfold Tan, ArcTan in |- *. astepr (FId x I). cut (Dom (ArcTang[o]Tang) x). intro H2. apply eq_transitive_unfolded with ((ArcTang[o]Tang) x H2). simpl in |- *; algebra. apply Feq_imp_eq with (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)). apply ArcTan_Tan_inv. split; auto. exists H; apply I. Qed. Lemma Tan_ilim : forall x, {y : IR | olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) y | forall Hy, x [<=] Tan y Hy}. Proof. intros. set (aux_val := sqrt _ (less_leEq _ _ _ (pos_two IR)) [/]TwoNZ) in *. assert (H : [0] [<] aux_val). unfold aux_val in |- *. apply shift_less_div; [ apply pos_two | apply power_cancel_less with 2 ]. apply sqrt_nonneg. astepl (ZeroR[^]2); astepl ZeroR; astepr (Two:IR); apply pos_two. assert (H0 : sqrt _ (less_leEq _ _ _ (pos_two _)) [#] [0]). apply mult_cancel_ap_zero_lft with (OneR [/]TwoNZ). eapply ap_wdl_unfolded; [ apply pos_ap_zero; apply H | unfold aux_val in |- *; rational ]. assert (H1 : aux_val [=] ([1][/] _[//]H0)). unfold aux_val in |- *. apply eq_div; astepr (Two:IR); Step_final (sqrt _ (less_leEq _ _ _ (pos_two _)) [^]2). assert (H2 : aux_val [<] [1]). apply power_cancel_less with 2. apply less_leEq; apply pos_one. unfold aux_val in |- *; rstepl ((sqrt _ (less_leEq _ _ _ (pos_two IR)) [^]2) [/]FourNZ); astepr OneR. apply shift_div_less; [ apply pos_four | astepl (Two:IR); astepr (Four:IR) ]; apply two_less_four. elim (less_cotransitive_unfolded _ _ _ H2 x); intros. 2: exists (Pi [/]FourNZ); repeat split; PiSolve. 2: intro; astepr OneR; apply less_leEq; auto. assert (H3 : Two[*]x [#] [0]). apply mult_resp_ap_zero. apply two_ap_zero. apply pos_ap_zero; apply less_transitive_unfolded with aux_val; auto. assert (H4 : Dom ArcCos ([1][/] _[//]H3)). repeat split. apply less_transitive_unfolded with ZeroR; [ astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one | apply recip_resp_pos ]. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. apply shift_div_less. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. astepr (Two[*]x); apply less_transitive_unfolded with (Two[*]aux_val). 2: apply mult_resp_less_lft; auto; apply pos_two. unfold aux_val in |- *; rstepr (sqrt _ (less_leEq _ _ _ (pos_two _))). apply power_cancel_less with 2. apply sqrt_nonneg. astepl OneR; astepr (Two:IR); apply one_less_two. assert (H5 : Pi [/]FourNZ [<=] ArcCos _ H4). assert (H5 : Dom ArcCos aux_val). repeat split; auto; unfold aux_val in |- *. apply less_transitive_unfolded with ZeroR; auto; astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. apply leEq_wdl with (ArcCos _ H5). 2: assert (H6 : Dom ArcCos (Cos (Pi [/]FourNZ))). 2: apply dom_wd with aux_val; auto. 2: Step_final ([1][/] _[//]H0). 2: apply eq_transitive_unfolded with (ArcCos _ H6). 3: apply ArcCos_Cos; PiSolve. 2: apply pfwdef; unfold aux_val in |- *. 2: Step_final ([1][/] _[//]H0). apply ArcCos_resp_leEq. apply less_transitive_unfolded with ZeroR. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. apply recip_resp_pos; apply mult_resp_pos; try apply pos_two; apply less_transitive_unfolded with aux_val; auto. apply shift_div_leEq. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. apply leEq_wdl with (aux_val[*] (Two[*]aux_val)). repeat apply mult_resp_leEq_lft; apply less_leEq; auto; apply pos_two. unfold aux_val in |- *. rstepl ((sqrt _ (less_leEq _ _ _ (pos_two _)) [^]2) [/]TwoNZ). Step_final ((Two:IR) [/]TwoNZ). auto. exists (ArcCos _ H4). Opaque iprop. unfold ArcCos in |- *; simpl in |- *. Transparent iprop. elim H4; intros H6' H7; elim H7; intros. apply iprop_wd with (Pi [/]TwoNZ[-]ArcSin _ H7). 2: algebra. elim (ArcSin_range _ H7); intros; split. apply shift_less_minus; apply shift_plus_less'. rstepr Pi; apply less_transitive_unfolded with (Pi [/]TwoNZ); PiSolve. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR. assert (H6 : Dom ArcSin (Sin [0])). apply dom_wd with ZeroR; [ split | algebra ]; [ astepr ( [--]ZeroR); apply inv_resp_less | idtac ]; apply pos_one. apply less_wdl with (ArcSin _ H6). 2: apply ArcSin_Sin; PiSolve. apply leEq_not_eq. apply ArcSin_resp_leEq; auto. astepr ZeroR; astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. astepl ZeroR; apply less_leEq; apply recip_resp_pos. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. apply pfstrx with Sine I I. apply ap_wdl_unfolded with ZeroR. apply ap_wdr_unfolded with ([1][/] _[//]H3). apply ap_symmetric_unfolded; apply pos_ap_zero; apply recip_resp_pos. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. apply eq_transitive_unfolded with (Sin (ArcSin _ H7)); [ apply Sin_ArcSin | simpl in |- *; algebra ]. apply eq_transitive_unfolded with (Sin (ArcSin _ H6)); [ astepl (Sin [0]); apply Sin_ArcSin | simpl in |- *; algebra ]. intros; unfold Tan, Tang in |- *. assert (H6 : Cos (ArcCos _ H4) [#] [0]). eapply ap_wdl_unfolded. 2: apply Cos_ArcCos. apply recip_ap_zero; auto. apply leEq_wdr with (Sin (ArcCos _ H4) [/] _[//]H6). 2: simpl in |- *; algebra. apply shift_leEq_div. Opaque Cos. unfold ArcCos in |- *; simpl in |- *. astepr (Sin (ArcSin _ (ProjIR2 H4))). eapply less_wdr. 2: apply Sin_ArcSin. apply recip_resp_pos; apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. apply leEq_wdl with (x[*] ([1][/] _[//]H3)). 2: apply mult_wdr; apply Cos_ArcCos. rstepl (OneR [/]TwoNZ). apply leEq_transitive with ([1][/] _[//]H0). apply recip_resp_leEq. astepl (ZeroR[*]Two); apply shift_mult_less with (two_ap_zero IR); auto; apply pos_two. apply power_cancel_leEq with 2; auto. apply less_leEq; apply pos_two. astepl (Two:IR); rstepr (Four:IR); apply less_leEq; apply two_less_four. astepl (Sin (Pi [/]FourNZ)); apply Sin_resp_leEq. PiSolve. astepl (Pi [/]TwoNZ[-]ArcSin _ (ProjIR2 H4)). apply shift_minus_leEq; apply shift_leEq_plus'; astepl ZeroR. assert (H7 : Dom ArcSin (Sin [0])). apply dom_wd with ZeroR; [ split | algebra ]; [ astepr ( [--]ZeroR); apply inv_resp_less | idtac ]; apply pos_one. apply leEq_wdl with (ArcSin _ H7). 2: apply ArcSin_Sin; PiSolve. apply ArcSin_resp_leEq. astepr ZeroR; astepr ( [--]ZeroR); apply inv_resp_less; apply pos_one. astepl ZeroR; apply less_leEq; apply recip_resp_pos. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. apply shift_div_less. apply mult_resp_pos; [ apply pos_two | apply less_transitive_unfolded with aux_val; auto ]. astepr (Two[*]x); apply less_transitive_unfolded with (Two[*]aux_val). 2: apply mult_resp_less_lft; auto; apply pos_two. unfold aux_val in |- *; rstepr (sqrt _ (less_leEq _ _ _ (pos_two _))). apply power_cancel_less with 2. apply sqrt_nonneg. astepl OneR; astepr (Two:IR); apply one_less_two. auto. Qed. Opaque Min. Transparent Cos. Section ArcTan_Range. Variable x : IR. (* begin hide *) Let min := proj1_sig2T _ _ _ (Tan_ilim x). Let max := proj1_sig2T _ _ _ (Tan_ilim [--]x). Let min1 : [--] (Pi [/]TwoNZ) [<] min. Proof. elim (proj2a_sig2T _ _ _ (Tan_ilim x)); auto. Qed. Let min2 : min [<] Pi [/]TwoNZ. Proof. elim (proj2a_sig2T _ _ _ (Tan_ilim x)); auto. Qed. Let min3 : Dom Tang min. Proof. split. apply sin_domain. split. apply cos_domain. intro; apply ap_wdl_unfolded with (Cos min). 2: simpl in |- *; algebra. apply pos_ap_zero; apply Cos_pos. apply min1. apply min2. Qed. Let min4 : x [<=] Tan min min3 := proj2b_sig2T _ _ _ (Tan_ilim x) min3. Let max1 : [--] (Pi [/]TwoNZ) [<] max. Proof. elim (proj2a_sig2T _ _ _ (Tan_ilim [--]x)); auto. Qed. Let max2 : max [<] Pi [/]TwoNZ. Proof. elim (proj2a_sig2T _ _ _ (Tan_ilim [--]x)); auto. Qed. Let max3 : Dom Tang max. Proof. split. apply sin_domain. split. apply cos_domain. intro; apply ap_wdl_unfolded with (Cos max). 2: simpl in |- *; algebra. apply pos_ap_zero; apply Cos_pos. apply max1. apply max2. Qed. Let max4 : [--]x [<=] Tan max max3 := proj2b_sig2T _ _ _ (Tan_ilim [--]x) max3. Let min5 : Dom Tang [--]min. Proof. split. apply sin_domain. split. apply cos_domain. intro; apply ap_wdl_unfolded with (Cos [--]min). 2: simpl in |- *; algebra. astepl (Cos min). apply pos_ap_zero; apply Cos_pos. apply min1. apply min2. Qed. Let min6 : Tan [--]min min5 [<=] [--]x. Proof. astepl ( [--] (Tan _ min3)); apply inv_resp_leEq. apply min4. Qed. Let max5 : Dom Tang [--]max. Proof. split. apply sin_domain. split. apply cos_domain. intro; apply ap_wdl_unfolded with (Cos [--]max). 2: simpl in |- *; algebra. astepl (Cos max). apply pos_ap_zero; apply Cos_pos. apply max1. apply max2. Qed. Let max6 : Tan [--]max max5 [<=] x. Proof. astepl ( [--] (Tan _ max3)); astepr ( [--] [--]x); apply inv_resp_leEq. apply max4. Qed. Let a := ( [--] (Pi [/]TwoNZ) [+] Min [--] (Pi [/]FourNZ) (Min (Min min [--]min) (Min max [--]max))) [/]TwoNZ. Let a1 : [--] (Pi [/]TwoNZ) [<] a. Proof. unfold a in |- *; clear a. apply shift_less_div. apply pos_two. apply shift_less_plus'; rstepl ( [--] (Pi [/]TwoNZ)). repeat apply less_Min. PiSolve. apply min1. apply inv_resp_less; apply min2. apply max1. apply inv_resp_less; apply max2. Qed. Let a2 : a [<] min. Proof. unfold a in |- *. apply shift_div_less. apply pos_two. apply shift_plus_less'. eapply leEq_less_trans. apply Min_leEq_rht. eapply leEq_less_trans. apply Min_leEq_lft. eapply leEq_less_trans. apply Min_leEq_lft. apply shift_less_minus; apply shift_plus_less'. rstepr min; apply min1. Qed. Let a3 : a [<] [--]min. Proof. unfold a in |- *. apply shift_div_less. apply pos_two. apply shift_plus_less'. eapply leEq_less_trans. apply Min_leEq_rht. eapply leEq_less_trans. apply Min_leEq_lft. eapply leEq_less_trans. apply Min_leEq_rht. apply shift_less_minus; apply shift_plus_less'. rstepr ( [--]min); apply inv_resp_less; apply min2. Qed. Let a4 : a [<] max. Proof. unfold a in |- *. apply shift_div_less. apply pos_two. apply shift_plus_less'. eapply leEq_less_trans. apply Min_leEq_rht. eapply leEq_less_trans. apply Min_leEq_rht. eapply leEq_less_trans. apply Min_leEq_lft. apply shift_less_minus; apply shift_plus_less'. rstepr max; apply max1. Qed. Let a5 : a [<] [--]max. Proof. unfold a in |- *. apply shift_div_less. apply pos_two. apply shift_plus_less'. eapply leEq_less_trans. apply Min_leEq_rht. eapply leEq_less_trans. apply Min_leEq_rht. eapply leEq_less_trans. apply Min_leEq_rht. apply shift_less_minus; apply shift_plus_less'. rstepr ( [--]max); apply inv_resp_less; apply max2. Qed. Let b := (Pi [/]TwoNZ[+]Max (Pi [/]FourNZ) (Max (Max min [--]min) (Max max [--]max))) [/]TwoNZ. Let b1 : b [<] Pi [/]TwoNZ. Proof. unfold b in |- *. apply shift_div_less. apply pos_two. apply shift_plus_less'; rstepr (Pi [/]TwoNZ). repeat apply Max_less. PiSolve. apply min2. astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply min1. apply max2. astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply max1. Qed. Let b2 : min [<] b. Proof. unfold b in |- *. apply shift_less_div. apply pos_two. apply shift_less_plus'. eapply less_leEq_trans. 2: apply rht_leEq_Max. eapply less_leEq_trans. 2: apply lft_leEq_Max. eapply less_leEq_trans. 2: apply lft_leEq_Max. apply shift_minus_less; apply shift_less_plus'. rstepl min; apply min2. Qed. Let b3 : [--]min [<] b. Proof. unfold b in |- *. apply shift_less_div. apply pos_two. apply shift_less_plus'. eapply less_leEq_trans. 2: apply rht_leEq_Max. eapply less_leEq_trans. 2: apply lft_leEq_Max. eapply less_leEq_trans. 2: apply rht_leEq_Max. apply shift_minus_less; apply shift_less_plus'. rstepl ( [--]min); astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply min1. Qed. Let b4 : max [<] b. Proof. unfold b in |- *. apply shift_less_div. apply pos_two. apply shift_less_plus'. eapply less_leEq_trans. 2: apply rht_leEq_Max. eapply less_leEq_trans. 2: apply rht_leEq_Max. eapply less_leEq_trans. 2: apply lft_leEq_Max. apply shift_minus_less; apply shift_less_plus'. rstepl max; apply max2. Qed. Let b5 : [--]max [<] b. Proof. unfold b in |- *. apply shift_less_div. apply pos_two. apply shift_less_plus'. eapply less_leEq_trans. 2: apply rht_leEq_Max. eapply less_leEq_trans. 2: apply rht_leEq_Max. eapply less_leEq_trans. 2: apply rht_leEq_Max. apply shift_minus_less; apply shift_less_plus'. rstepl ( [--]max); astepr ( [--] [--] (Pi [/]TwoNZ)); apply inv_resp_less; apply max1. Qed. Let ab : a [<] b. Proof. apply less_transitive_unfolded with min; [ apply a2 | apply b2 ]. Qed. Lemma ArcTan_range_lemma : {y : IR | olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) y | forall Hy, Tang y Hy [=] x}. Proof. assert (H : Continuous (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) Tang). eapply Derivative_imp_Continuous; apply (Derivative_Tan_1 invHalfPi_less_HalfPi). assert (H0 : Continuous_I (less_leEq _ _ _ ab) Tang). eapply included_imp_Continuous; [ apply H | apply compact_included ]. split; [ apply a1 | apply less_transitive_unfolded with b; [ apply ab | apply b1 ] ]. split; [ apply less_transitive_unfolded with a; [ apply a1 | apply ab ] | apply b1 ]. elim IVT'_I with (contF := H0) (z := x). intros y H1 H2; exists y; auto. inversion_clear H1; split. apply less_transitive_unfolded with a; auto; apply a1. apply less_transitive_unfolded with b; auto; apply b1. apply ab. intros x0 y H1 H2 H3 Hx Hy. fold (Tan x0 Hx) in |- *; fold (Tan y Hy) in |- *. inversion_clear H1; inversion_clear H2; apply Tan_resp_less; auto. apply less_leEq_trans with a; auto; apply a1. apply leEq_less_trans with b; auto; apply b1. fold (Tan a (contin_imp_inc _ _ _ _ H0 _ (compact_inc_lft _ _ _))) in |- *. apply less_leEq_trans with (Tan [--]max max5). apply Tan_resp_less. apply a1. apply less_transitive_unfolded with b; [ apply b5 | apply b1 ]. apply a5. apply max6. fold (Tan b (contin_imp_inc _ _ _ _ H0 _ (compact_inc_rht _ _ _))) in |- *. apply leEq_less_trans with (Tan min min3). apply min4. apply Tan_resp_less. apply min1. apply b1. apply b2. Qed. (* end hide *) Lemma ArcTan_range : [--] (Pi [/]TwoNZ) [<] ArcTan x and ArcTan x [<] Pi [/]TwoNZ. Proof. intros. Transparent ArcTang. elim ArcTan_range_lemma; intros y H H0. elim H; intros. cut (Dom Tang y). intro H1. assert (H2 : Tan y H1 [=] x). unfold Tan in |- *; algebra. split. apply less_wdr with y; auto. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply ArcTan_Tan with (H := H1); auto. unfold ArcTan in |- *; algebra. apply less_wdl with y; auto. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply ArcTan_Tan with (H := H1); auto. unfold ArcTan in |- *; algebra. repeat split. intro; apply Greater_imp_ap. apply less_wdr with (Cos y); [ apply Cos_pos; auto | simpl in |- *; algebra ]. Qed. End ArcTan_Range. Lemma Tan_ArcTan : forall (x : IR) Hx, x [=] Tan (ArcTan x) Hx. Proof. intros. set (y := Tan (ArcTan x) Hx) in *. assert (H : ArcTan x [=] ArcTan y). unfold y in |- *; apply eq_symmetric_unfolded; elim ArcTan_range with x; intros; apply ArcTan_Tan; auto. Transparent ArcTang. cut (Continuous_I (Min_leEq_Max x y) {1/} ( [-C-][1]{+}FId{^}2)). intro H0. cut (Integral H0 [=] [0]). intro H1. elim Hx; intros H2 H3. apply Integral_eq_zero with (contF := H0) (x := x). exact (pair (Min_leEq_lft x y) (lft_leEq_Max x y)). intros. simpl in |- *; apply recip_resp_pos. astepl (ZeroR[+][0]); apply plus_resp_less_leEq. apply pos_one. astepr (x[^]2); apply sqr_nonneg. intros x0 H4 Hx0; simpl in |- *. apply less_leEq; apply recip_resp_pos. astepl (ZeroR[+][0]); apply plus_resp_less_leEq. apply pos_one. astepr (x0[^]2); apply sqr_nonneg. auto. apply eq_transitive_unfolded with (ArcTan y[-]ArcTan x). rstepl (ArcTan x[+]Integral H0[-]ArcTan x). apply cg_minus_wd; [ simpl in |- * | algebra ]. apply eq_symmetric_unfolded; unfold ArcTan in |- *; simpl in |- *. apply Integral_plus_Integral with (Min3_leEq_Max3 [0] y x). apply included_imp_Continuous with realline. exact ArcTan_def_lemma. apply included3_interval; split. apply x_minus_x; simpl in |- *; algebra. apply included_imp_Continuous with realline. exact ArcTan_def_lemma. apply included_interval; split. Qed. Lemma Tan_ArcTan_inv : Feq realline (Tang[o]ArcTang) FId. Proof. apply eq_imp_Feq. apply included_FComp. Included. intros; split. auto. split. auto. intros. apply ap_wdl with (Cos (ArcTan x)). Opaque ArcTang. 2: unfold ArcTan in |- *; simpl in |- *; algebra. elim ArcTan_range with x; intros. apply pos_ap_zero; apply Cos_pos; auto. Included. intros; inversion_clear Hx. astepr x; astepl (Part _ _ (ProjT2 Hx)); astepl (Part _ _ X0). cut (Dom Tang (ArcTan x)); intros. apply eq_transitive_unfolded with (Tan (ArcTan x) X1). unfold Tan, ArcTan in |- *; algebra. apply eq_symmetric_unfolded; apply Tan_ArcTan. apply dom_wd with (ArcTang x x0); auto. unfold ArcTan in |- *; algebra. Qed. End Inverses. corn-8.20.0/transc/MoreArcTan.v000066400000000000000000000463701473720167500162440ustar00rootroot00000000000000(* Copyright © 2006 Russell O’Connor Permission is hereby granted, free of charge, to any person obtaining a copy of this proof and associated documentation files (the "Proof"), to deal in the Proof without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Proof, and to permit persons to whom the Proof is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Proof. THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF. *) Require Export CoRN.transc.InvTrigonom. Require Import CoRN.tactics.CornTac. (** Various properties of ArcTangent.*) Lemma Dom_Tang_ArcTan : forall x, (Dom Tang (ArcTan x)). Proof. intros x. apply Tang_Domain'. apply ArcTan_range. Qed. Lemma ArcTan_zero : ArcTan [0][=][0]. Proof. assert (Z:Dom Tang [0]). apply Tang_Domain'. split; auto with *. stepl (ArcTan (Tan _ Z)). apply ArcTan_Tan; auto with *. apply pfwdef. apply Tan_zero. Qed. Lemma ArcTan_one : ArcTan [1][=]Pi[/]FourNZ. Proof. assert (Z:Dom Tang (Pi[/]FourNZ)). apply Tang_Domain'. split; auto with *. stepl (ArcTan (Tan _ Z)). apply ArcTan_Tan; auto with *. apply pfwdef. apply Tan_QuarterPi. Qed. #[global] Hint Resolve ArcTan_zero ArcTan_one: algebra. Lemma ArcTan_inv : forall x, ArcTan [--]x[=][--](ArcTan x). Proof. intros x. stepr (ArcTan [--](Tan (ArcTan x) (Dom_Tang_ArcTan x))). apply ArcTan_wd. apply un_op_wd_unfolded. apply Tan_ArcTan. assert (H:(olor ([--](Pi[/]TwoNZ)) (Pi[/]TwoNZ) [--](ArcTan x))). destruct (ArcTan_range x). split. apply inv_resp_less; assumption. rstepr ([--][--](Pi[/]TwoNZ)). apply inv_resp_less; assumption. stepr (ArcTan (Tan _ (Tang_Domain' _ H))). apply ArcTan_wd. apply eq_symmetric. apply Tan_inv. destruct H. apply ArcTan_Tan; assumption. Qed. Lemma ArcTan_resp_less : forall x y, x[<]y -> ArcTan x[<]ArcTan y. Proof. intros x y H. unfold ArcTan. eapply (Derivative_imp_resp_less realline I). apply Derivative_ArcTan. assumption. constructor. constructor. intros contF'. set (F:={1/}([-C-][1]{+}FId{^}2):PartIR) in *. assert (Hz0:forall z:IR, [0][<][1][+][1][*]z[*]z). intros z. apply less_leEq_trans with [1]. apply pos_one. apply shift_leEq_plus'. rstepl ([0]:IR). rstepr (z[^]2). apply sqr_nonneg. assert (Hz:forall z, Dom F z). intros z. repeat constructor. simpl. intros _. apply Greater_imp_ap. apply Hz0. set (z:=Max (AbsIR x) (AbsIR y)). apply less_leEq_trans with (F z (Hz z)). simpl. apply shift_less_div. apply Hz0. rstepl ([0]:IR). apply pos_one. apply leEq_glb. simpl. intros a [Ha0 Ha1] H0. apply recip_resp_leEq. apply Hz0. clear H0 contF' F Hz. apply plus_resp_leEq_lft. apply shift_leEq_rht. rstepr ((z[-]a)[*](z[-][--]a)). unfold z. apply mult_resp_nonneg; apply shift_leEq_lft; eapply leEq_transitive. apply Ha1. apply Max_leEq; (eapply leEq_transitive;[apply leEq_AbsIR|]). apply lft_leEq_Max. apply rht_leEq_Max. apply inv_resp_leEq. apply Ha0. unfold MIN, Min. rstepl (Max [--]x [--]y). apply Max_leEq; (eapply leEq_transitive;[apply inv_leEq_AbsIR|]). apply lft_leEq_Max. apply rht_leEq_Max. Qed. Lemma ArcTan_resp_leEq : forall x y, x[<=]y -> ArcTan x[<=]ArcTan y. Proof. intros x y Hxy. rewrite -> leEq_def. intros H. apply (leEq_less_or_equal _ _ _ Hxy). intros H0. generalize H; clear H. change (Not (ArcTan y[<]ArcTan x)). rewrite <- leEq_def. destruct H0. apply less_leEq. apply ArcTan_resp_less. assumption. stepr (ArcTan x). apply leEq_reflexive. apply ArcTan_wd. assumption. Qed. Lemma ArcTan_pos : forall x, [0][<]x -> [0][<]ArcTan x. Proof. intros x Hx. csetoid_rewrite_rev ArcTan_zero. apply ArcTan_resp_less. assumption. Qed. Lemma ArcTan_recip : forall x Hx, [0][<]x -> ArcTan ([1][/]x[//]Hx)[=]Pi[/]TwoNZ[-](ArcTan x). Proof. intros x Hx Hx0. assert (H0:olor [--](Pi [/]TwoNZ) (Pi [/]TwoNZ) ([--](ArcTan x)[+]Pi[/]TwoNZ)). split. apply shift_less_plus. rstepl ([--]Pi). apply inv_resp_less. apply less_transitive_unfolded with (Pi[/]TwoNZ). destruct (ArcTan_range x); assumption. auto with *. apply shift_plus_less. rstepr ([--][0]:IR). apply inv_resp_less. apply ArcTan_pos. assumption. rstepr ([--](ArcTan x)[+]Pi[/]TwoNZ). stepr (ArcTan (Tan _ (Tang_Domain' _ H0))); [| now destruct H0; apply ArcTan_Tan; assumption]. apply ArcTan_wd. apply eq_symmetric. assert (H1:Dom Tang ([--](ArcTan x))). apply Tang_Domain'. destruct (ArcTan_range x). split. apply inv_resp_less; assumption. rstepr ([--][--](Pi[/]TwoNZ)). apply inv_resp_less. assumption. assert (H2:(Tan [--](ArcTan x) H1)[#][0]). stepl ([--](Tan (ArcTan x) (Dom_Tang_ArcTan x))); [| now apply eq_symmetric; apply Tan_inv]. rstepr ([--][0]:IR). apply inv_resp_ap. apply Greater_imp_ap. csetoid_rewrite_rev (Tan_ArcTan x (Dom_Tang_ArcTan x)). assumption. eapply eq_transitive. apply (Tan_plus_HalfPi _ (Tang_Domain' _ H0) H1 H2). apply mult_cancel_lft with (Tan [--](ArcTan x) H1). assumption. apply mult_cancel_lft with x. apply Greater_imp_ap; assumption. rstepl ([--]x:IR). rstepr (Tan [--](ArcTan x) H1). stepr ([--](Tan (ArcTan x) (Dom_Tang_ArcTan x))). apply un_op_wd_unfolded. apply Tan_ArcTan. apply eq_symmetric. apply Tan_inv. Qed. Lemma ArcTan_plus_ArcTan : forall x y Hxy, ([--][1][<=]x) -> (x[<=][1]) -> ([--][1][<=]y) -> (y[<=][1]) -> ArcTan x [+] ArcTan y [=] ArcTan ((x[+]y)[/]([1][-]x[*]y)[//]Hxy). Proof. cut (forall x y Hxy, ([--][1][<=]x) -> (x[<=][1]) -> ([--][1][<=]y) -> (y[<][1]) -> ArcTan x [+] ArcTan y [=] ArcTan ((x[+]y)[/]([1][-]x[*]y)[//]Hxy)). intros G x y Hxy Hx0 Hx1 Hy0 Hy1. apply (not_ap_imp_eq). intros H. apply (leEq_less_or_equal _ _ _ Hx1). intros Hx1'. apply (leEq_less_or_equal _ _ _ Hy1). intros Hy1'. generalize H; clear H. apply (eq_imp_not_ap). clear Hy1. destruct Hy1' as [Hy1|Hy1]. apply G; assumption. assert (Hxy':([1][-]y[*]x)[#][0]). rstepl ([1][-]x[*]y). assumption. rstepl (ArcTan y[+]ArcTan x). stepr (ArcTan ((y[+]x)[/]([1][-]y[*]x)[//]Hxy')); [| now apply ArcTan_wd; rational]. apply G; try assumption. stepl ([1]:IR); [| now apply eq_symmetric; assumption]. apply leEq_reflexive. destruct Hx1' as [c|c]; try assumption. exfalso. refine (eq_imp_not_ap _ _ _ _ Hxy'). unfold cg_minus. csetoid_rewrite c. csetoid_rewrite Hy1. rstepl ([0]:IR). apply eq_reflexive. cut (forall x y Hxy, ([--][1][<=]x) -> (x[<=][1]) -> ([--][1][<]y) -> (y[<][1]) -> ArcTan x [+] ArcTan y [=] ArcTan ((x[+]y)[/]([1][-]x[*]y)[//]Hxy)). intros G x y Hxy Hx0 Hx1 Hy0 Hy1. apply (not_ap_imp_eq). intros H. apply (leEq_less_or_equal _ _ _ Hx0). intros Hx0'. apply (leEq_less_or_equal _ _ _ Hx1). intros Hx1'. apply (leEq_less_or_equal _ _ _ Hy0). intros Hy0'. generalize H; clear H. apply (eq_imp_not_ap). clear Hy0. destruct Hy0' as [Hy0|Hy0]. apply G; assumption. assert (Hxy':([1][-]y[*]x)[#][0]). rstepl ([1][-]x[*]y). assumption. destruct Hx0' as [Hx0'|Hx0']; destruct Hx1' as [Hx1'|Hx1']. rstepl (ArcTan y[+]ArcTan x). stepr (ArcTan ((y[+]x)[/]([1][-]y[*]x)[//]Hxy')); [| now apply ArcTan_wd; rational]. apply G; try assumption. stepr ([--][1]:IR); [| easy ]. apply leEq_reflexive. stepl ([--][1]:IR); [| easy ]. apply shift_zero_leEq_minus'. rstepr (Two:IR). apply less_leEq; apply pos_two. csetoid_replace (ArcTan y) ([--](ArcTan x)). rstepl ([0]:IR). stepl (ArcTan [0]); [| now apply ArcTan_zero]. apply ArcTan_wd. rstepl ([0][/]([1][-]x[*]y)[//]Hxy). apply div_wd. csetoid_rewrite Hx1'. csetoid_rewrite_rev Hy0. rational. apply eq_reflexive. stepl (ArcTan ([--]x)). apply ArcTan_inv. apply ArcTan_wd. csetoid_rewrite Hx1'. assumption. exfalso. refine (eq_imp_not_ap _ _ _ _ Hxy'). unfold cg_minus. csetoid_rewrite_rev Hx0'. csetoid_rewrite_rev Hy0. rational. exfalso. refine (eq_imp_not_ap _ [--][1] [1] _ _). 1: now stepr x. apply ap_symmetric. apply zero_minus_apart. rstepl (Two:IR). apply two_ap_zero. intros x y Hxy Hx0 Hx1 Hy0 Hy1. assert (X:olor [--](Pi [/]TwoNZ) (Pi [/]TwoNZ) (ArcTan x[+]ArcTan y)). split. rstepl ([--](Pi[/]FourNZ)[+][--](Pi[/]FourNZ)). csetoid_rewrite_rev (ArcTan_one). csetoid_replace ([--](ArcTan [1])) (ArcTan ([--][1])). apply plus_resp_leEq_less. apply ArcTan_resp_leEq; assumption. apply ArcTan_resp_less; assumption. apply eq_symmetric; apply ArcTan_inv. rstepr ((Pi[/]FourNZ)[+](Pi[/]FourNZ)). csetoid_rewrite_rev (ArcTan_one). apply plus_resp_leEq_less. apply ArcTan_resp_leEq; assumption. apply ArcTan_resp_less; assumption. elim X; intros X0 X1. csetoid_rewrite_rev (ArcTan_Tan _ X0 X1 (Tang_Domain' _ X)). apply ArcTan_wd. assert (Y:([1][-]Tan _ (Dom_Tang_ArcTan x)[*]Tan _ (Dom_Tang_ArcTan y))[#][0]). unfold cg_minus. csetoid_rewrite_rev (Tan_ArcTan _ (Dom_Tang_ArcTan x)). csetoid_rewrite_rev (Tan_ArcTan _ (Dom_Tang_ArcTan y)). assumption. stepr (Tan _ (Dom_Tang_ArcTan x)[+]Tan _ (Dom_Tang_ArcTan y)[/]_[//]Y). apply Tan_plus. apply div_wd; unfold cg_minus; csetoid_rewrite_rev (Tan_ArcTan _ (Dom_Tang_ArcTan x)); csetoid_rewrite_rev (Tan_ArcTan _ (Dom_Tang_ArcTan y)); apply eq_reflexive. Qed. Section ArcTan_Series. (** ** ArcTan Series In this section we show the convergence of ArcTan's power series. First we show the convergence of the series for 1/(1+x^2) *) Lemma bellcurve_series_convergent_IR : fun_series_convergent_IR (olor ([--][1]) [1]) (fun (i:nat) => ([--][1])[^]i{**}Fid IR{^}(2*i)). Proof. apply fun_series_convergent_wd_IR with (fun i => Fid IR{^}i[o]({--}(Fid IR{^}2))). intros n. FEQ. change ([--]([1][*]x[*]x)[^]n[=]([--][1])[^]n[*]x[^](2*n)). rstepl (([--][1][*](x[*]x))[^]n). stepl (([--][1])[^]n[*]((x[*]x)[^]n)); [| now apply eq_symmetric; apply mult_nexp]. apply mult_wdr. replace (2*n)%nat with (n+n)%nat by auto with *. eapply eq_transitive. apply mult_nexp. apply nexp_plus. apply FSeries_Sum_comp_conv with (olor [--][1] [1]); [|Contin|apply fun_power_series_conv_IR]. intros a b Hab Hinc. set (c:=Max (AbsIR a) (AbsIR b)). exists ([--](c[^]2)). exists (c[^]2). assert (X:[--](c[^]2)[<=]c[^]2). apply leEq_transitive with ([0]:IR). rstepr ([--][0]:IR). apply inv_resp_leEq. apply sqr_nonneg. apply sqr_nonneg. exists X. assert (A0:(c[^]2)[<][1]). rstepr ([1][^]2:IR). unfold c. apply nexp_resp_less. auto with *. eapply leEq_transitive. apply AbsIR_nonneg. apply lft_leEq_Max. apply Max_less; [destruct (Hinc _ (compact_inc_lft _ _ Hab)) |destruct (Hinc _ (compact_inc_rht _ _ Hab))]; apply AbsIR_less; assumption. assert (A1:[--][1][<][--](c[^]2)). apply inv_resp_less. assumption. split. intros d [Hd0 Hd1]. split. apply less_leEq_trans with ([--](c[^]2)); assumption. apply leEq_less_trans with (c[^]2); assumption. intros x Hx [Hx0 Hx1]. simpl. cut (AbsSmall (c[^]2) ([--](x[^]2))). intros [A B]; split; assumption. apply inv_resp_AbsSmall. rstepl (c[*]c). rstepr (x[*]x). cut (AbsSmall c x). intros; apply mult_AbsSmall; assumption. unfold c. split. rstepr ([--][--]x). apply inv_resp_leEq. eapply leEq_transitive;[|apply lft_leEq_Max]. eapply leEq_transitive;[|apply inv_leEq_AbsIR]. apply inv_resp_leEq. assumption. eapply leEq_transitive;[|apply rht_leEq_Max]. eapply leEq_transitive;[|apply leEq_AbsIR]. assumption. Qed. Lemma bellcurve_series : forall (Hs:fun_series_convergent_IR (olor ([--][1]) [1]) (fun (i:nat) => ([--][1])[^]i{**}Fid IR{^}(2*i))), Feq (olor ([--][1]) [1]) (FSeries_Sum Hs) ({1/}([-C-][1]{+}FId{^}2)). Proof. intros Hs. split. simpl. apply included_refl. split. apply included_trans with realline. intros x _; constructor. apply Continuous_imp_inc. apply ArcTan_def_lemma. intros c [Hc0 Hc1] D0 D1. assert (X:AbsIR ([--](c[^]2))[<][1]). csetoid_rewrite_rev (AbsIR_inv (c[^]2)). csetoid_rewrite (AbsIR_nexp_op 2 c). rstepr ([1][^]2:IR). apply nexp_resp_less. auto with *. apply AbsIR_nonneg. apply AbsIR_less; assumption. simpl. generalize (ext2 (S:=IR) (P:=Conj (fun _ : IR => True) (fun _ : IR => True)) (R:=fun (x : IR) (_ : Conj (fun _ : IR => True) (fun _ : IR => True) x) => [1][+][1][*]x[*]x[#][0]) (x:=c) D1). intros H. assert (Y:[1][-]([--](c[^]2))[#][0]). rstepl ([1][+][1][*]c[*]c). assumption. rstepr ([1][/]([1][-]([--](c[^]2)))[//]Y). stepr (series_sum (power_series [--](c[^]2)) (power_series_conv [--](c[^]2) X)); [| now apply (power_series_sum ([--](c[^]2)) X Y (power_series_conv _ X))]. apply series_sum_wd. intros n. simpl. change ((([--][1])[^]n)[*]c[^](2*n)[=][--]([1][*]c[*]c)[^]n). rstepr ((([--][1])[*]c[*]c)[^]n). csetoid_rewrite_rev (nexp_mult _ c 2 n). csetoid_rewrite_rev (mult_nexp _ ([--][1]) (c[^]2) n). rational. Qed. (** Finally we show the convergence of the series for arctan.*) (* Although the series converges on the closed interval [-1,1], this proof only shows convergence on the open interval (-1,1). *) Lemma arctan_series_convergent_IR : fun_series_convergent_IR (olor ([--][1]) [1]) (fun (i:nat) => (([--][1])[^]i[/]nring (S (2*i))[//]nringS_ap_zero _ (2*i)){**}Fid IR{^}(2*i+1)). Proof. intros y z Hyz Hinc. pose (C:=Max (AbsIR y) (AbsIR z)). assert (C[<][1]). unfold C. destruct (Hinc _ (compact_inc_lft _ _ Hyz)). destruct (Hinc _ (compact_inc_rht _ _ Hyz)). apply Max_less; apply AbsIR_less; assumption. assert ([0][<=]C). unfold C. eapply leEq_transitive. apply AbsIR_nonneg. apply lft_leEq_Max. apply fun_ratio_test_conv. intros n. Contin. exists 0. exists C. assumption. split. assumption. intros x Hx n _ Hx0 Hx1. generalize (nringS_ap_zero IR (2 * S n)). generalize (nringS_ap_zero IR (2 * n)). intros Z0 Z1. set (a := S (2 * S n)). set (b := 2*S n + 1). set (c:= S (2 * n)). set (d:= 2*n + 1). change (AbsIR (([--][1][^]S n[/]nring (R:=IR) a[//]Z1)[*]x[^]b)[<=] C[*]AbsIR (([--][1][^]n[/]nring (R:=IR) c[//]Z0)[*]x[^]d)). stepl (AbsIR (([--][1][^]S n[/]nring (R:=IR) a[//]Z1))[*]AbsIR (x[^]b)); [| now apply eq_symmetric; apply AbsIR_resp_mult]. stepr (C[*](AbsIR (([--][1][^]n[/]nring (R:=IR) c[//]Z0))[*]AbsIR(x[^]d))); [| now apply mult_wdr; apply eq_symmetric; apply AbsIR_resp_mult]. rstepr (AbsIR (([--][1][^]n[/]nring (R:=IR) c[//]Z0))[*](C[*]AbsIR(x[^]d))). apply mult_resp_leEq_both; try apply AbsIR_nonneg. stepl (AbsIR ([--][1][^]S n)[/]_[//](AbsIR_resp_ap_zero _ Z1)); [| now apply eq_symmetric; apply AbsIR_division]. stepr ((AbsIR ([--][1][^]n)[/]_[//](AbsIR_resp_ap_zero _ Z0))); [| now apply eq_symmetric; apply AbsIR_division]. assert (H0:forall n, AbsIR([--][1][^]n)[=][1]). intros i. csetoid_rewrite (AbsIR_nexp_op i ([--][1]:IR)). csetoid_rewrite_rev (AbsIR_inv [1]). stepl (([1]:IR)[^]i). apply one_nexp. apply nexp_wd. apply eq_symmetric; apply AbsIR_eq_x. apply less_leEq; apply pos_one. stepl ([1][/]AbsIR (nring (R:=IR) (S (2 * S n)))[//] AbsIR_resp_ap_zero (nring (R:=IR) (S (2 * S n))) Z1); [| now apply div_wd; try apply eq_reflexive; apply eq_symmetric; apply H0]. stepr ([1][/]AbsIR (nring (R:=IR) (S (2 * n)))[//] AbsIR_resp_ap_zero (nring (R:=IR) (S (2 * n))) Z0); [| now apply div_wd; try apply eq_reflexive; apply eq_symmetric; apply H0]. apply recip_resp_leEq; try (apply AbsIR_pos; assumption). eapply leEq_transitive;[|apply leEq_AbsIR]. apply AbsSmall_imp_AbsIR. apply leEq_imp_AbsSmall. apply nring_nonneg. apply nring_leEq. auto with *. replace b with (2+d);[|unfold b, d; auto with *]. stepl (AbsIR x[^](2+d)); [| now apply eq_symmetric; apply AbsIR_nexp_op]. stepl (AbsIR x[^]2[*]AbsIR x[^]d); [| now apply nexp_plus]. stepr (C[*]AbsIR x[^]d); [| now apply mult_wdr; apply eq_symmetric; apply AbsIR_nexp_op]. apply mult_resp_leEq_rht; try (apply nexp_resp_nonneg; apply AbsIR_nonneg). apply leEq_transitive with (C[^]2). stepl (AbsIR(x[^]2)); [| now apply AbsIR_nexp_op]. stepl (x[^]2); [| now apply eq_symmetric; apply AbsIR_eq_x; apply sqr_nonneg]. apply shift_zero_leEq_minus'. rstepr ((C[-]x)[*](C[-][--]x)). unfold C. destruct Hx as [Y0 Y1]. apply mult_resp_nonneg; apply shift_zero_leEq_minus. eapply leEq_transitive. apply Y1. eapply leEq_transitive. apply leEq_AbsIR. apply rht_leEq_Max. eapply leEq_transitive. apply inv_resp_leEq. apply Y0. eapply leEq_transitive. apply inv_leEq_AbsIR. apply lft_leEq_Max. rstepl (C[*]C). rstepr (C[*][1]). apply mult_resp_leEq_lft. apply less_leEq; assumption. assumption. Qed. Lemma arctan_series : forall c : IR, forall (Hs:fun_series_convergent_IR (olor ([--][1]) [1]) (fun (i:nat) => (([--][1])[^]i[/]nring (S (2*i))[//]nringS_ap_zero _ (2*i)){**}Fid IR{^}(2*i+1))) Hc, FSeries_Sum Hs c Hc[=]ArcTan c. Proof. intros c Hs Hc. set (J:=olor [--][1] [1]). assert (HJ:proper J). simpl. apply shift_zero_less_minus'. rstepr (Two:IR). apply pos_nring_S. assert (Y0 : included J realline). intros a b; constructor. assert (Y1 : J [0]). split;[rstepr ([--][0]:IR);apply inv_resp_less|]; apply pos_one. stepl (([-S-] Included_imp_Continuous realline {1/}([-C-][1]{+}FId{^}2) ArcTan_def_lemma J Y0) [0] Y1 c Hc). apply: Integral_wd. apply Feq_reflexive. intros d Hd. eapply Continuous_imp_inc. apply ArcTan_def_lemma. constructor. apply cg_inv_unique_2. cut (Derivative J HJ (FSeries_Sum Hs) {1/}([-C-][1]{+}FId{^}2)). intros X. destruct (FTC2 J _ (Included_imp_Continuous _ _ ArcTan_def_lemma J Y0) [0] Y1 _ _ X) as [z Hz]. clear X. apply eq_transitive with z. eapply eq_transitive; [|apply (Feq_imp_eq _ _ _ Hz _ Hc (Hc, Hc) I)]. apply: bin_op_wd_unfolded;[|apply un_op_wd_unfolded]; apply pfwdef; apply eq_reflexive. apply eq_symmetric. eapply eq_transitive; [|apply (Feq_imp_eq _ _ _ Hz _ Y1 (Y1, Y1) I)]. rstepl ([0][-][0]:IR). apply: cg_minus_wd. stepr (ArcTan [0]). assert (Z:Dom Tang [0]). repeat split; try constructor. intros []. stepl ([1]:IR). apply ring_non_triv. apply eq_symmetric. apply Cos_zero. stepl (ArcTan (Tan _ Z)). apply pfwdef. apply Tan_zero. apply ArcTan_Tan; [rstepr ([--][0]:IR); apply inv_resp_less|]; apply pos_HalfPi. unfold ArcTan, ArcTang. apply: Integral_wd. apply Feq_reflexive. intros d Hd. eapply Continuous_imp_inc. apply ArcTan_def_lemma. constructor. eapply eq_transitive. apply eq_symmetric. eapply (series_sum_zero conv_zero_series). simpl; apply series_sum_wd. intros n. eapply eq_transitive. apply eq_symmetric. apply cring_mult_zero. apply mult_wdr. apply eq_symmetric. apply (zero_nexp IR (2*n+1)). auto with *. clear -J. eapply Derivative_wdr. apply (bellcurve_series bellcurve_series_convergent_IR). apply Derivative_FSeries. intros n. rewrite Nat.add_comm. simpl. Derivative_Help; [|apply Derivative_scal;apply Derivative_nth;Deriv..]. FEQ. Qed. End ArcTan_Series. corn-8.20.0/transc/Pi.v000066400000000000000000000764131473720167500146220ustar00rootroot00000000000000(* Copyright © 1998-2008 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Cezary Kaliszyk * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Import CoRN.tactics.CornTac. Require Export CoRN.transc.SinCos. Section Properties_of_Pi. (** printing Pi %\ensuremath{\pi}% #π# *) (** ** Definition of Pi [Pi] is defined as twice the first positive zero of the cosine. In order to do this, we follow the construction described in Bishop 1969, section 7. *) Fixpoint pi_seq (n : nat) : IR := match n with | O => [0] | S p => pi_seq p[+]Cos (pi_seq p) end. Opaque Cosine. (* begin hide *) Lemma pi_seq_lemma : forall n, [0] [<=] pi_seq n and (forall t : IR, [0] [<=] t -> t [<=] pi_seq n -> [0] [<] Cos t). Proof. intro; induction n as [| n Hrecn]. split; intros. simpl in |- *; apply leEq_reflexive. simpl in H0. cut (t [=] [0]); [ intro | apply leEq_imp_eq; auto ]. astepr (Cos [0]). astepr OneR. apply pos_one. inversion_clear Hrecn; split. astepr (pi_seq n[+]Cos (pi_seq n)). astepl (ZeroR[+][0]); apply plus_resp_leEq_both. auto. apply less_leEq; apply X; auto. apply leEq_reflexive. simpl in |- *. rename X into H0. intros t H1 H2. apply Continuous_imp_pos with (Hac := leEq_transitive _ _ _ _ H1 H2) (b := pi_seq n); auto. simpl in |- *. apply shift_less_plus'; astepl ZeroR. simpl in H0; apply H0; auto. apply leEq_reflexive. apply included_imp_Continuous with realline; Contin. intros. apply less_wdr with (Cos t0). 2: simpl in |- *; algebra. auto. clear H2 H1 t; intros t H1 H2 Ht. set (x := pi_seq n) in *. apply less_wdr with (Cosine x I[+] ( {--}Cosine x I[-] {--}Cosine t Ht)). 2: simpl in |- *; rational. assert (H3 : Derivative realline I {--}Cosine Sine). apply Derivative_wdr with ( {--}{--}Sine). Opaque Sine. FEQ. Deriv. assert (H4 : Continuous_I (Min_leEq_Max x t) Sine). apply included_imp_Continuous with realline; Contin. set (B := Barrow _ _ Continuous_Sin I {--}Cosine) in *. set (B' := B H3 x t H4 I I) in *. apply less_wdr with (Cosine x I[-]Integral H4). 2: unfold cg_minus at 1 in |- *; apply bin_op_wd_unfolded. 2: algebra. 2: rstepr ( [--] ( {--}Cosine t Ht[-] {--}Cosine x I)). 2: apply un_op_wd_unfolded; eapply eq_transitive. 2: apply B'. 2: algebra. clear B' B H3. apply less_wdl with (Cos (pi_seq n) [-] (pi_seq (S n) [-]pi_seq n)). 2: simpl in |- *; rational. unfold cg_minus at 1 3 in |- *. apply plus_resp_less_lft. apply inv_resp_less. apply less_leEq_trans with (t[-]x). 2: apply minus_resp_leEq; auto. eapply leEq_less_trans. apply leEq_AbsIR. eapply less_leEq_trans. apply (ub_Integral _ _ _ _ H4 (less_imp_ap _ _ _ H1) [1]) with x I. intros. apply leEq_wdl with (AbsIR (Sin x0)). apply AbsIR_Sin_leEq_One. apply AbsIR_wd; simpl in |- *; algebra. apply compact_map2 with (Hab := less_leEq _ _ _ H1). apply compact_inc_lft. apply less_wdl with (AbsIR (Sin x)). 2: simpl in |- *; algebra. apply AbsIR_Sin_less_One. apply H0; auto. apply leEq_reflexive. apply eq_imp_leEq. astepl (AbsIR (t[-]x)). apply AbsIR_eq_x. apply shift_leEq_minus; apply less_leEq. astepl x; auto. Qed. (* end hide *) (** This sequence is nonnegative and the cosine of any number between [[0]] and any of its values is strictly positive; therefore the sequence is strictly increasing. *) Lemma pi_seq_nonneg : forall n : nat, [0] [<=] pi_seq n. Proof. intro; elim (pi_seq_lemma n); auto. Qed. Lemma cos_pi_seq_pos : forall n t, [0] [<=] t -> t [<=] pi_seq n -> [0] [<] Cos t. Proof. intro; elim (pi_seq_lemma n); auto. Qed. Lemma pi_seq_incr : forall n : nat, pi_seq n [<] pi_seq (S n). Proof. intro; astepr (pi_seq n[+]Cos (pi_seq n)). apply shift_less_plus'; astepl ZeroR. apply cos_pi_seq_pos with n. apply pi_seq_nonneg. apply leEq_reflexive. Qed. (** Trivial---but useful---consequences. *) Lemma sin_pi_seq_mon : forall x y n, [0] [<=] x -> x [<=] y -> y [<=] pi_seq n -> Sin x [<=] Sin y. Proof. intros; simpl in |- *. apply Derivative_imp_resp_leEq with realline I Cosine. Deriv. auto. simpl in |- *; auto. simpl in |- *; auto. intros. apply leEq_glb. intros y0 H2 Hy. apply less_leEq. apply less_wdr with (Cos y0). 2: simpl in |- *; algebra. inversion_clear H2. apply cos_pi_seq_pos with n. apply leEq_transitive with x; auto. eapply leEq_wdl. apply H3. eapply eq_transitive. apply Min_comm. apply leEq_imp_Min_is_lft; auto. apply leEq_transitive with y; auto. eapply leEq_wdr. apply H4. eapply eq_transitive. apply Max_comm. apply leEq_imp_Max_is_rht; auto. Qed. Lemma sin_pi_seq_nonneg : forall n : nat, [0] [<=] Sin (pi_seq n). Proof. intro. astepl (Sin [0]). apply sin_pi_seq_mon with n. apply leEq_reflexive. apply pi_seq_nonneg. apply leEq_reflexive. Qed. Lemma sin_pi_seq_gt_one : forall t n, [1] [<=] t -> t [<=] pi_seq (S n) -> Sin [1] [<=] Sin t. Proof. intros. apply sin_pi_seq_mon with (S n); auto. apply less_leEq; apply pos_one. Qed. Lemma cos_pi_seq_mon : forall x y n, [0] [<=] x -> x [<=] y -> y [<=] pi_seq n -> Cos y [<=] Cos x. Proof. intros. apply power_cancel_leEq with 2. auto. apply less_leEq; apply cos_pi_seq_pos with n. auto. apply leEq_transitive with y; auto. apply inv_cancel_leEq. rstepl ([1][-]Cos x[^]2[-][1]). rstepr ([1][-]Cos y[^]2[-][1]). apply minus_resp_leEq. apply leEq_wdl with (Sin x[^]2). apply leEq_wdr with (Sin y[^]2). apply nexp_resp_leEq. astepl (Sin [0]); apply sin_pi_seq_mon with n. apply leEq_reflexive. auto. apply leEq_transitive with y; auto. apply sin_pi_seq_mon with n; auto. astepl (Sin y[^]2[+]Cos y[^]2[-]Cos y[^]2). apply cg_minus_wd. Step_final (Cos y[^]2[+]Sin y[^]2). algebra. astepl (Sin x[^]2[+]Cos x[^]2[-]Cos x[^]2). apply cg_minus_wd. Step_final (Cos x[^]2[+]Sin x[^]2). algebra. Qed. (* begin hide *) Lemma pi_seq_gt_one : forall n : nat, [1] [<=] pi_seq (S n). Proof. intros. apply leEq_wdl with (pi_seq 1). 2: simpl in |- *. 2: Step_final (Cos [0]). apply local_mon_imp_mon'. intro; apply pi_seq_incr; auto. auto with arith. Qed. Lemma pi_seq_bnd : forall n : nat, pi_seq (S (S (S n))) [-]pi_seq (S (S n)) [<=] ([1][-]Sin [1]) [*] (pi_seq (S (S n)) [-]pi_seq (S n)). Proof. intros. set (F := FId{+}Cosine) in *. assert (H : Derivative realline I F ( [-C-][1]{+}{--}Sine)). unfold F in |- *; Deriv. astepr ([0][+] ([1][-]Sin [1]) [*] (pi_seq (S (S n)) [-]pi_seq (S n))). apply shift_leEq_plus. apply approach_zero_weak; intros e H0. elim (Law_of_the_Mean _ _ _ _ H (pi_seq (S n)) (pi_seq (S (S n)))) with e. 2: simpl in |- *; auto. 2: simpl in |- *; auto. 2: auto. intros t H1 H2. unfold F in H2. apply leEq_transitive with (pi_seq (S (S (S n))) [-]pi_seq (S (S n)) [-] ([1][-]Sin t) [*] (pi_seq (S (S n)) [-]pi_seq (S n))). unfold cg_minus at 1 5 in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq. apply mult_resp_leEq_rht. unfold cg_minus in |- *; apply plus_resp_leEq_lft. apply inv_resp_leEq; inversion_clear H1. apply sin_pi_seq_gt_one with (S (S n)). eapply leEq_transitive. 2: apply H3. apply leEq_Min; apply pi_seq_gt_one. eapply leEq_transitive. apply H4. apply Max_leEq; apply less_leEq. eapply less_transitive_unfolded; apply pi_seq_incr. apply pi_seq_incr. apply shift_leEq_minus; apply less_leEq. astepl (pi_seq (S n)); apply pi_seq_incr. eapply leEq_transitive. apply leEq_AbsIR. set (H3 := (I, I)) in *. eapply leEq_wdl. apply (H2 H3 H3 H3). apply AbsIR_wd. Opaque Sine Cosine. simpl in |- *; rational. Qed. Lemma pi_seq_bnd' : forall n : nat, pi_seq (S (S (S n))) [-]pi_seq (S (S n)) [<=] ([1][-]Sin [1]) [^]S n[*] (pi_seq 2[-]pi_seq 1). Proof. intro; induction n as [| n Hrecn]. eapply leEq_wdr. apply pi_seq_bnd. algebra. eapply leEq_transitive. apply pi_seq_bnd. apply leEq_wdr with (([1][-]Sin [1]) [*] (([1][-]Sin [1]) [^]S n[*] (pi_seq 2[-]pi_seq 1))). 2: simpl in |- *; rational. apply mult_resp_leEq_lft. auto. apply shift_leEq_minus; astepl (Sin [1]). eapply leEq_transitive. apply leEq_AbsIR. apply AbsIR_Sin_leEq_One. Qed. Lemma pi_seq_bnd'' : forall n : nat, 2 <= n -> pi_seq (S n) [-]pi_seq n [<=] ([1][-]Sin [1]) [^]pred n[*] (pi_seq 2[-]pi_seq 1). Proof. intro; case n. intros; exfalso; inversion H. clear n. intro; case n; intros. exfalso; inversion H; inversion H1. eapply leEq_wdr. apply pi_seq_bnd'. algebra. Qed. (* end hide *) (** An auxiliary result. *) Lemma Sin_One_pos : [0] [<] Sin [1]. Proof. astepl (Sin [0]). simpl in |- *. apply Derivative_imp_resp_less with realline I Cosine. Deriv. apply pos_one. simpl in |- *; auto. simpl in |- *; auto. intros. apply less_leEq_trans with (Cos [1]). apply less_wdr with (Cos (pi_seq 1)). 2: astepl (Cos ([0][+]Cos [0])); apply Cos_wd; Step_final (Cos [0]). apply cos_pi_seq_pos with 1. simpl in |- *. astepr (Cos [0]); astepr OneR. apply less_leEq; apply pos_one. apply leEq_reflexive. apply leEq_glb. intros y H Hy; apply leEq_wdr with (Cos y). 2: simpl in |- *; algebra. inversion_clear H. apply cos_pi_seq_mon with 1. eapply leEq_wdl. apply H0. apply leEq_imp_Min_is_lft; apply less_leEq; apply pos_one. eapply leEq_wdr. apply H1. apply leEq_imp_Max_is_rht; apply less_leEq; apply pos_one. apply eq_imp_leEq; simpl in |- *. Step_final (Cos [0]). Qed. (** We can now prove that this is a Cauchy sequence. We define [Pi] as twice its limit. *) Lemma pi_seq_Cauchy : Cauchy_prop pi_seq. Proof. intros e H. cut ([0] [<] pi_seq 2[-]pi_seq 1). intro H0. assert (H1 : pi_seq 2[-]pi_seq 1 [#] [0]). apply Greater_imp_ap; auto. cut (Sin [1] [<] [1]). intro Sin_One_less_One. elim qi_yields_zero with (e := Sin [1][*]e[/] _[//]H1) (q := [1][-]Sin [1]). intros N HN. exists (S (S N)); intros. apply AbsIR_imp_AbsSmall. apply leEq_wdl with (pi_seq m[-]pi_seq (S (S N))). 2: apply eq_symmetric; apply AbsIR_eq_x. 2: apply shift_leEq_minus; astepl (pi_seq (S (S N))). 2: apply local_mon_imp_mon'. 2: intro; apply pi_seq_incr; auto. 2: auto. cut (m = S (pred m)); [ intro | symmetry; apply Nat.lt_succ_pred with (S N); auto ]. apply leEq_wdl with (Sum (S (S N)) (pred m) (fun i : nat => pi_seq (S i) [-]pi_seq i)). 2: eapply eq_transitive. 2: apply Mengolli_Sum_gen with (f := pi_seq). 2: algebra. 2: auto with arith. 2: rewrite <- H3; algebra. set (z := [1][-]Sin [1]) in *. apply leEq_transitive with (Sum (S (S N)) (pred m) (fun i : nat => z[^]pred i[*] (pi_seq 2[-]pi_seq 1))). apply Sum_resp_leEq. rewrite <- H3; auto. intros; apply pi_seq_bnd''. apply Nat.le_trans with (S (S N)); auto with arith. eapply leEq_wdl. 2: apply eq_symmetric; apply Sum_comm_scal with (s := fun i : nat => z[^]pred i). rstepl (Sum (S (S N)) (pred m) (fun i : nat => z[^]pred i) [*] (pi_seq 2[-]pi_seq 1)). apply shift_mult_leEq with H1. auto. apply leEq_wdl with (Sum (S N) (pred (pred m)) (fun i : nat => z[^]i)). 2: cut (pred m = S (pred (pred m))); [ intro | symmetry; apply Nat.lt_succ_pred with N; auto with arith ]. 2: pattern (pred m) at 2 in |- *; rewrite H4. 2: apply Sum_shift; algebra. cut (z[-][1] [#] [0]). intro H4. eapply leEq_wdl. 2: apply eq_symmetric; apply Sum_c_exp with (H := H4). rstepl ((z[^]S (pred (pred m)) [/] _[//]H4) [-] (z[^]S N[/] _[//]H4)). apply leEq_transitive with ( [--] (z[^]S N) [/] _[//]H4). apply shift_minus_leEq; rstepr ZeroR; apply less_leEq. unfold z in |- *. rstepl ( [--] (([1][-]Sin [1]) [^]S (pred (pred m))) [/] Sin [1][//] pos_ap_zero _ _ Sin_One_pos). apply shift_div_less. apply Sin_One_pos. astepr ZeroR; astepr ( [--]ZeroR). apply inv_resp_less. apply less_wdl with (ZeroR[^]S (pred (pred m))). 2: simpl in |- *; algebra. apply nexp_resp_less. auto with arith. apply leEq_reflexive. apply shift_less_minus; astepl (Sin [1]). auto. unfold z at 2 in |- *. rstepl (z[^]S N[/] _[//]pos_ap_zero _ _ Sin_One_pos). apply shift_div_leEq. apply Sin_One_pos. eapply leEq_transitive. eapply leEq_transitive. 2: apply HN. simpl in |- *. astepr (nexp IR N z[*][1]); apply mult_resp_leEq_lft. unfold z in |- *. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; apply less_leEq; apply Sin_One_pos. astepr (z[^]N); apply nexp_resp_nonneg. unfold z in |- *. apply shift_leEq_minus; astepl (Sin [1]). apply less_leEq; auto. apply eq_imp_leEq. rational. unfold z in |- *. rstepl ( [--] (Sin [1])). apply inv_resp_ap_zero. apply Greater_imp_ap; apply Sin_One_pos. apply shift_leEq_minus. apply less_leEq; astepl (Sin [1]); auto. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; apply Sin_One_pos. apply div_resp_pos. auto. apply mult_resp_pos; auto. apply Sin_One_pos. apply Sin_less_One. apply cos_pi_seq_pos with 1. apply less_leEq; apply pos_one. simpl in |- *. apply eq_imp_leEq; Step_final (Cos [0]). apply shift_less_minus; astepl (pi_seq 1). apply pi_seq_incr; auto. Qed. Definition Pi := Two[*]Lim (Build_CauchySeq _ _ pi_seq_Cauchy). (** For $x\in[0,\frac{\pi}2)$#x∈[0,π/2)#, [(Cos x) [>] 0]; $\cos(\frac{pi}2)=0$#cos(π/2)=0#. *) Lemma pos_cos : forall x, [0] [<=] x -> x [<] Pi [/]TwoNZ -> [0] [<] Cos x. Proof. intros x H H0. assert (H1 : x [<] Lim (Build_CauchySeq _ _ pi_seq_Cauchy)). apply less_wdr with (Pi [/]TwoNZ); auto; unfold Pi in |- *; rational. elim (less_Lim_so_less_seq _ _ H1); intros N HN. apply cos_pi_seq_pos with N. auto. apply less_leEq; auto. Qed. Lemma Cos_HalfPi : Cos (Pi [/]TwoNZ) [=] [0]. Proof. transitivity (Cos (Lim (Build_CauchySeq _ _ pi_seq_Cauchy))). apply Cos_wd; unfold Pi in |- *; rational. astepr (Lim (Build_CauchySeq _ _ pi_seq_Cauchy) [-] Lim (Build_CauchySeq _ _ pi_seq_Cauchy)). assert (H : Cauchy_prop (fun n : nat => pi_seq (S n))). apply conv_seq_imp_conv_subseq with pi_seq S; auto with arith. intro; exists (S n); split; apply Nat.lt_succ_diag_r. simpl in |- *; auto. algebra. apply pi_seq_Cauchy. transitivity (Lim (Build_CauchySeq _ _ H) [-]Lim (Build_CauchySeq _ _ pi_seq_Cauchy)). 2: apply cg_minus_wd; algebra. 2: apply Lim_subseq_eq_Lim_seq with S; auto with arith. 2: intro; exists (S n); split; apply Nat.lt_succ_diag_r. 2: simpl in |- *; auto. 2: algebra. 2: left; intros; simpl in |- *. 2: apply local_mon_imp_mon'; auto; apply pi_seq_incr. eapply eq_transitive. 2: apply Lim_minus. assert (H0 : Cauchy_prop (fun n : nat => Cosine (pi_seq n) (cos_domain _))). apply Cauchy_prop_wd with (fun n : nat => pi_seq (S n) [-]pi_seq n). 2: intros; simpl in |- *; rational. exact (Cauchy_minus (Build_CauchySeq _ _ H) (Build_CauchySeq _ _ pi_seq_Cauchy)). transitivity (Lim (Build_CauchySeq _ _ H0)). 2: apply Lim_wd'; intros; simpl in |- *; rational. simpl in |- *. apply Continuous_imp_comm_Lim with (e := OneR) (x := Build_CauchySeq _ _ pi_seq_Cauchy) (Hxn := fun n : nat => cos_domain (pi_seq n)). apply pos_one. apply Included_imp_Continuous with realline; Contin. Qed. (** Convergence to [Pi [/] Two] is increasing; therefore, [Pi] is positive. *) Lemma HalfPi_gt_pi_seq : forall n : nat, pi_seq n [<] Pi [/]TwoNZ. Proof. intros. unfold Pi in |- *. rstepr (Lim (Build_CauchySeq _ _ pi_seq_Cauchy)). apply less_leEq_trans with (pi_seq (S n)). apply pi_seq_incr. apply str_leEq_seq_so_leEq_Lim. exists (S n); intros. apply local_mon_imp_mon'. apply pi_seq_incr. auto. Qed. Lemma pos_Pi : [0] [<] Pi. Proof. astepr (Two[*]Pi [/]TwoNZ). apply mult_resp_pos. apply pos_two. astepl (pi_seq 0). apply HalfPi_gt_pi_seq. Qed. End Properties_of_Pi. #[global] Hint Resolve Cos_HalfPi: algebra. Section Pi_and_Order. (** ** Properties of Pi The following are trivial ordering properties of multiples of [Pi] that will be used so often that it is convenient to state as lemmas; also, we define a hint database that automatically tries to apply this lemmas, to make proof development easier. A summary of what is being proved is simply: [[ [--]Pi [<] [--]Pi[/]Two [<] [--] Pi[/]Four [<] [0] [<] Pi[/]Four [<] Pi[/]Two [<] Pi ]] [PiSolve] will prove any of these inequalities. *) Lemma pos_HalfPi : [0] [<] Pi [/]TwoNZ. Proof. apply pos_div_two; apply pos_Pi. Qed. Lemma pos_QuarterPi : [0] [<] Pi [/]FourNZ. Proof. apply pos_div_four; apply pos_Pi. Qed. Lemma QuarterPi_less_HalfPi : Pi [/]FourNZ [<] Pi [/]TwoNZ. Proof. rstepl ((Pi [/]TwoNZ) [/]TwoNZ). apply pos_div_two'; apply pos_HalfPi. Qed. Lemma HalfPi_less_Pi : Pi [/]TwoNZ [<] Pi. Proof. apply pos_div_two'; apply pos_Pi. Qed. Lemma QuarterPi_less_Pi : Pi [/]FourNZ [<] Pi. Proof. apply pos_div_four'; apply pos_Pi. Qed. Lemma neg_invPi : [--]Pi [<] [0]. Proof. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_Pi. Qed. Lemma neg_invHalfPi : [--] (Pi [/]TwoNZ) [<] [0]. Proof. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_HalfPi. Qed. Lemma neg_invQuarterPi : [--] (Pi [/]FourNZ) [<] [0]. Proof. astepr ( [--]ZeroR); apply inv_resp_less; apply pos_QuarterPi. Qed. Lemma invHalfPi_less_invQuarterPi : [--] (Pi [/]TwoNZ) [<] [--] (Pi [/]FourNZ). Proof. apply inv_resp_less; apply QuarterPi_less_HalfPi. Qed. Lemma invPi_less_invHalfPi : [--]Pi [<] [--] (Pi [/]TwoNZ). Proof. apply inv_resp_less; apply HalfPi_less_Pi. Qed. Lemma invPi_less_invQuarterPi : [--]Pi [<] [--] (Pi [/]FourNZ). Proof. apply inv_resp_less; apply QuarterPi_less_Pi. Qed. Lemma invPi_less_Pi : [--]Pi [<] Pi. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invPi. apply pos_Pi. Qed. Lemma invPi_less_HalfPi : [--]Pi [<] Pi [/]TwoNZ. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invPi. apply pos_HalfPi. Qed. Lemma invPi_less_QuarterPi : [--]Pi [<] Pi [/]FourNZ. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invPi. apply pos_QuarterPi. Qed. Lemma invHalfPi_less_Pi : [--] (Pi [/]TwoNZ) [<] Pi. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invHalfPi. apply pos_Pi. Qed. Lemma invHalfPi_less_HalfPi : [--] (Pi [/]TwoNZ) [<] Pi [/]TwoNZ. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invHalfPi. apply pos_HalfPi. Qed. Lemma invHalfPi_less_QuarterPi : [--] (Pi [/]TwoNZ) [<] Pi [/]FourNZ. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invHalfPi. apply pos_QuarterPi. Qed. Lemma invQuarterPi_less_Pi : [--] (Pi [/]FourNZ) [<] Pi. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invQuarterPi. apply pos_Pi. Qed. Lemma invQuarterPi_less_HalfPi : [--] (Pi [/]FourNZ) [<] Pi [/]TwoNZ. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invQuarterPi. apply pos_HalfPi. Qed. Lemma invQuarterPi_less_QuarterPi : [--] (Pi [/]FourNZ) [<] Pi [/]FourNZ. Proof. apply less_transitive_unfolded with ZeroR. apply neg_invQuarterPi. apply pos_QuarterPi. Qed. End Pi_and_Order. #[global] Hint Resolve pos_Pi pos_HalfPi pos_QuarterPi QuarterPi_less_HalfPi HalfPi_less_Pi QuarterPi_less_Pi neg_invPi neg_invHalfPi neg_invQuarterPi invHalfPi_less_invQuarterPi invPi_less_invHalfPi invPi_less_invQuarterPi invPi_less_Pi invPi_less_HalfPi invPi_less_QuarterPi invHalfPi_less_Pi invHalfPi_less_HalfPi invHalfPi_less_QuarterPi invQuarterPi_less_Pi invQuarterPi_less_HalfPi invQuarterPi_less_QuarterPi: piorder. (* begin hide *) Ltac PiSolve := try apply less_leEq; auto with piorder. (* end hide *) Section Sin_And_Cos. (** ** More formulas We now move back to trigonometric identities: sine, cosine and tangent of the double. *) Lemma Cos_double : forall x : IR, Cos (Two[*]x) [=] Two[*]Cos x[^]2[-][1]. Proof. intros. astepl (Cos (x[+]x)). astepl (Cos x[*]Cos x[-]Sin x[*]Sin x). astepl (Cos x[^]2[-]Sin x[^]2). rstepr (Cos x[^]2[-] ([1][-]Cos x[^]2)). apply cg_minus_wd; algebra. astepr (Cos x[^]2[+]Sin x[^]2[-]Cos x[^]2); rational. Qed. Lemma Sin_double : forall x : IR, Sin (Two[*]x) [=] Two[*]Sin x[*]Cos x. Proof. intros. astepl (Sin (x[+]x)). eapply eq_transitive_unfolded. apply Sin_plus. rational. Qed. Lemma Tan_double : forall x Hx Hx' H, Tan (Two[*]x) Hx' [=] (Two[*]Tan x Hx[/] [1][-]Tan x Hx[^]2[//]H). Proof. intros. cut (Dom Tang (x[+]x)). intro H0. astepl (Tan (x[+]x) H0). cut ([1][-]Tan x Hx[*]Tan x Hx [#] [0]). intro H1. eapply eq_transitive_unfolded. apply Tan_plus with (Hx := Hx) (Hy := Hx) (H := H1). simpl in |- *; rational. astepl ([1][-]Tan x Hx[^]2). auto. apply dom_wd with (Two[*]x); algebra. Qed. (* begin hide *) Lemma sqrt_lemma : forall Hpos H, [1] [/]TwoNZ [=] ([1][/] sqrt Two Hpos[//]H) [^]2. Proof. intros. Step_final ([1][^]2[/] _[//]nexp_resp_ap_zero 2 H). Qed. (* end hide *) (** Value of trigonometric functions at [Pi[/]Four]. *) Lemma Cos_QuarterPi : forall Hpos H, Cos (Pi [/]FourNZ) [=] ([1][/] sqrt Two Hpos[//]H). Proof. intros. apply square_eq_pos. apply recip_resp_pos. apply power_cancel_less with 2. apply sqrt_nonneg. astepr (Two:IR). simpl in |- *; fold (Two:IR) in |- *; astepl ZeroR. apply pos_two. apply pos_cos; PiSolve. eapply eq_transitive_unfolded. 2: apply sqrt_lemma. astepr ((ZeroR[+][1]) [/]TwoNZ). astepr ((Cos (Pi [/]TwoNZ) [+][1]) [/]TwoNZ). rstepl ((Two[*]Cos (Pi [/]FourNZ) [^]2[-][1][+][1]) [/]TwoNZ). apply div_wd. 2: algebra. apply bin_op_wd_unfolded. 2: algebra. transitivity (Cos (Two[*]Pi [/]FourNZ)). apply eq_symmetric_unfolded; apply Cos_double. apply Cos_wd; rational. Qed. Lemma Sin_QuarterPi : forall Hpos H, Sin (Pi [/]FourNZ) [=] ([1][/] sqrt Two Hpos[//]H). Proof. intros. apply square_eq_pos. apply recip_resp_pos. apply power_cancel_less with 2. apply sqrt_nonneg. astepr (Two:IR). simpl in |- *; fold (Two:IR) in |- *; astepl ZeroR. apply pos_two. apply less_leEq_trans with (Sin ([1] [/]TwoNZ)). cut ([0] [<] Cos ([1] [/]TwoNZ)). intro H0. apply less_wdr with ((Sin [1][/] _[//]pos_ap_zero _ _ H0) [/]TwoNZ). apply pos_div_two. apply div_resp_pos. auto. apply Sin_One_pos. rstepr ((Two[*]Sin ([1] [/]TwoNZ) [*]Cos ([1] [/]TwoNZ) [/] _[//]pos_ap_zero _ _ H0) [/]TwoNZ). repeat apply div_wd. astepl (Sin (Two[*][1] [/]TwoNZ)). apply Sin_double. algebra. algebra. apply pos_cos; PiSolve. apply pos_div_two; apply pos_one. apply less_transitive_unfolded with (pi_seq 1). simpl in |- *; astepr (Cos [0]); astepr OneR. astepl (OneR [/]TwoNZ); apply pos_div_two'; apply pos_one. apply HalfPi_gt_pi_seq. elim (less_Lim_so_less_seq (Build_CauchySeq _ _ pi_seq_Cauchy) (Pi [/]FourNZ)). intros N HN; apply sin_pi_seq_mon with N. apply less_leEq; apply pos_div_two; apply pos_one. apply shift_div_leEq. apply pos_two. astepl (Cos [0]); astepl ([0][+]Cos [0]). rstepr (Pi [/]TwoNZ). apply less_leEq; apply (HalfPi_gt_pi_seq 1). apply less_leEq; auto. eapply less_wdr. apply QuarterPi_less_HalfPi. unfold Pi in |- *; rational. eapply eq_transitive_unfolded. 2: apply sqrt_lemma. rstepr ([1][-]OneR [/]TwoNZ). astepr (Cos (Pi [/]FourNZ) [^]2[+]Sin (Pi [/]FourNZ) [^]2[-][1] [/]TwoNZ). rstepl (([1][/] _[//]H) [^]2[+]Sin (Pi [/]FourNZ) [^]2[-] ([1][/] _[//]H) [^]2). apply cg_minus_wd. apply bin_op_wd_unfolded. apply nexp_wd. apply eq_symmetric; apply Cos_QuarterPi. algebra. apply eq_symmetric; apply sqrt_lemma. Qed. Hint Resolve Sin_QuarterPi Cos_QuarterPi: algebra. Opaque Sine Cosine. Lemma Tan_QuarterPi : forall H, Tan (Pi [/]FourNZ) H [=] [1]. Proof. intros. set (pos2 := less_leEq _ _ _ (pos_two IR)) in *. cut (sqrt Two pos2 [#] [0]). 2: apply Greater_imp_ap. 2: apply power_cancel_less with 2. 2: apply sqrt_nonneg. 2: apply less_wdl with ZeroR. 2: astepr (Two:IR); apply pos_two. 2: simpl in |- *; algebra. intro H0. unfold Tan in |- *; simpl in |- *. astepr (([1][/] _[//]H0) [/] _[//]recip_ap_zero _ _ H0). apply div_wd. astepr (Sin (Pi [/]FourNZ)). simpl in |- *; algebra. astepr (Cos (Pi [/]FourNZ)). simpl in |- *; algebra. Qed. (** Shifting sine and cosine by [Pi[/]Two] and [Pi]. *) Lemma Sin_HalfPi : Sin (Pi [/]TwoNZ) [=] [1]. Proof. transitivity (Sin (Two[*]Pi [/]FourNZ)). apply Sin_wd; rational. eapply eq_transitive. apply Sin_double. astepr ((Two:IR) [*][1] [/]TwoNZ). eapply eq_transitive. apply eq_symmetric; apply CRings.mult_assoc. apply mult_wdr. cut (sqrt _ (less_leEq _ _ _ (pos_two IR)) [#] [0]). intro H. eapply eq_transitive. 2: symmetry; apply (sqrt_lemma _ H). simpl in |- *. eapply eq_transitive. 2: apply CRings.mult_assoc. eapply eq_transitive. apply eq_symmetric; apply one_mult. apply mult_wdr. apply mult_wd. apply Sin_QuarterPi. apply Cos_QuarterPi. apply Greater_imp_ap; apply sqrt_less. simpl in |- *; astepl ZeroR; apply (pos_two IR). Qed. Hint Resolve Sin_HalfPi: algebra. Lemma Sin_plus_HalfPi : forall x : IR, Sin (x[+]Pi [/]TwoNZ) [=] Cos x. Proof. intro. eapply eq_transitive. apply Sin_plus. astepl (Sin x[*][0][+]Cos x[*][1]). Step_final ([0][+]Cos x). Qed. Lemma Sin_HalfPi_minus : forall x : IR, Sin (Pi [/]TwoNZ[-]x) [=] Cos x. Proof. intros. unfold cg_minus in |- *. astepl (Sin ( [--]x[+]Pi [/]TwoNZ)). eapply eq_transitive. apply Sin_plus_HalfPi. algebra. Qed. Lemma Cos_plus_HalfPi : forall x : IR, Cos (x[+]Pi [/]TwoNZ) [=] [--] (Sin x). Proof. intro. eapply eq_transitive. apply Cos_plus. astepl (Cos x[*][0][-]Sin x[*][1]). Step_final ([0][-]Sin x). Qed. Lemma Cos_HalfPi_minus : forall x : IR, Cos (Pi [/]TwoNZ[-]x) [=] Sin x. Proof. intros. unfold cg_minus in |- *. astepl (Cos ( [--]x[+]Pi [/]TwoNZ)). eapply eq_transitive. apply Cos_plus_HalfPi. Step_final (Sin [--][--]x). Qed. Lemma Sin_Pi : Sin Pi [=] [0]. Proof. transitivity (Sin (Pi [/]TwoNZ[+]Pi [/]TwoNZ)). apply Sin_wd; rational. eapply eq_transitive_unfolded. apply Sin_plus_HalfPi. algebra. Qed. Lemma Cos_Pi : Cos Pi [=] [--][1]. Proof. transitivity (Cos (Pi [/]TwoNZ[+]Pi [/]TwoNZ)). apply Cos_wd; rational. eapply eq_transitive. apply Cos_plus_HalfPi. algebra. Qed. Lemma Sin_plus_Pi : forall x : IR, Sin (x[+]Pi) [=] [--] (Sin x). Proof. intros. transitivity (Sin (x[+]Pi [/]TwoNZ[+]Pi [/]TwoNZ)). apply Sin_wd; rational. eapply eq_transitive. apply Sin_plus_HalfPi. apply Cos_plus_HalfPi. Qed. Lemma Cos_plus_Pi : forall x : IR, Cos (x[+]Pi) [=] [--] (Cos x). Proof. intros. transitivity (Cos (x[+]Pi [/]TwoNZ[+]Pi [/]TwoNZ)). apply Cos_wd; rational. eapply eq_transitive. apply Cos_plus_HalfPi. apply un_op_wd_unfolded; apply Sin_plus_HalfPi. Qed. Lemma Tan_plus_HalfPi : forall x Hx Hx' H, Tan (x[+]Pi[/]TwoNZ) Hx[=]([--][1][/](Tan x Hx')[//]H). Proof. intros x Hy Hx H. set (y:=x[+]Pi [/]TwoNZ) in *. assert (H0:Cos y[#][0]). destruct Hy as [[] [[] Hy]]. apply (Hy I). assert (H1:Cos x[#][0]). clear H. destruct Hx as [[] [[] Hx]]. apply (Hx I). rewrite (Tan_Sin_over_Cos y Hy H0). unfold y. assert (H2:([--](Sin x))[#][0]) by (now csetoid_rewrite_rev (Cos_plus_HalfPi x)). stepr (Cos x[/]([--](Sin x))[//]H2). apply div_wd. apply Sin_plus_HalfPi. apply Cos_plus_HalfPi. clear H0. rstepl (((Cos x[/][--](Sin x)[//]H2)[*](Tan x Hx))[/](Tan x Hx)[//]H). apply div_wd;[|apply eq_reflexive]. rewrite (Tan_Sin_over_Cos x Hx H1). rational. Qed. Hint Resolve Sin_plus_Pi Cos_plus_Pi: algebra. (** Sine and cosine have period [Two Pi], tangent has period [Pi]. *) Lemma Sin_periodic : forall x : IR, Sin (x[+]Two[*]Pi) [=] Sin x. Proof. intro. transitivity (Sin (x[+]Pi[+]Pi)). apply Sin_wd; rational. astepl ( [--] (Sin (x[+]Pi))). Step_final ( [--][--] (Sin x)). Qed. Lemma Cos_periodic : forall x : IR, Cos (x[+]Two[*]Pi) [=] Cos x. Proof. intro. transitivity (Cos (x[+]Pi[+]Pi)). apply Cos_wd; rational. astepl ( [--] (Cos (x[+]Pi))). Step_final ( [--][--] (Cos x)). Qed. Lemma Sin_periodic_Z : forall (x : IR) z, Sin (x[+]zring z[*](Two[*]Pi)) [=] Sin x. Proof. intros x z; revert x; induction z using Zind; intros x. rational. unfold Z.succ. rewrite -> zring_plus. rstepl (Sin (x[+]zring z[*](Two[*]Pi)[+]Two[*]Pi)). rewrite -> Sin_periodic. auto. unfold Z.pred. rewrite -> zring_plus. rstepl (Sin (x[-]Two[*]Pi[+]zring z[*](Two[*]Pi))). rstepr (Sin (x[-]Two[*]Pi[+]Two[*]Pi)). rewrite -> Sin_periodic. auto. Qed. Lemma Cos_periodic_Z : forall (x : IR) z, Cos (x[+]zring z[*](Two[*]Pi)) [=] Cos x. Proof. intros x z; revert x; induction z using Zind; intros x. rational. unfold Z.succ. rewrite -> zring_plus. rstepl (Cos (x[+]zring z[*](Two[*]Pi)[+]Two[*]Pi)). rewrite -> Cos_periodic. auto. unfold Z.pred. rewrite -> zring_plus. rstepl (Cos (x[-]Two[*]Pi[+]zring z[*](Two[*]Pi))). rstepr (Cos (x[-]Two[*]Pi[+]Two[*]Pi)). rewrite -> Cos_periodic. auto. Qed. Lemma Tan_periodic : forall (x : IR) Hx Hx', Tan (x[+]Pi) Hx' [=] Tan x Hx. Proof. intros. cut (Cos x [#] [0]). intro H. assert (H0 : [--] (Cos x) [#] [0]). apply inv_resp_ap_zero; auto. transitivity (Sin x[/] _[//]H). 2: unfold Tan, Tang in |- *; simpl in |- *; algebra. rstepr ( [--] (Sin x) [/] _[//]H0). assert (H1 : Cos (x[+]Pi) [#] [0]). astepl ( [--] (Cos x)); auto. astepr (Sin (x[+]Pi) [/] _[//]H1). unfold Tan, Tang in |- *; simpl in |- *; algebra. inversion_clear Hx. inversion_clear X0. simpl in |- *; auto. Qed. Lemma Cos_one_gt_0 : [0] [<] Cos [1]. Proof. apply cos_pi_seq_pos with (1%nat). apply less_leEq. apply pos_one. unfold pi_seq. rewrite -> Cos_zero. apply eq_imp_leEq. rational. Qed. Lemma Pi_gt_2 : Two [<] Pi. Proof. unfold Pi. rstepl (Two [*] [1]:IR). apply mult_resp_less_lft. apply less_leEq_trans with ([1] [+] (Cos [1])). rstepl ([1] [+] [0]:IR). apply plus_resp_leEq_less. apply eq_imp_leEq. reflexivity. apply Cos_one_gt_0. apply str_leEq_seq_so_leEq_Lim. exists (2%nat). intros i iH. change ([1] [+] Cos [1][<=] pi_seq i). induction i. exfalso. auto with *. clear IHi. induction i. exfalso. auto with *. clear iH. clear IHi. induction i. unfold pi_seq. rewrite -> Cos_zero. setoid_replace ([0] [+] [1]:IR) with ([1]:IR); [|rational]. apply eq_imp_leEq. reflexivity. apply leEq_transitive with (pi_seq (S (S i))). assumption. apply less_leEq. apply pi_seq_incr. apply pos_two. Qed. End Sin_And_Cos. #[global] Hint Resolve Cos_double Sin_double Tan_double Cos_QuarterPi Sin_QuarterPi Tan_QuarterPi Sin_Pi Cos_Pi Sin_HalfPi Sin_plus_HalfPi Sin_HalfPi_minus Cos_plus_HalfPi Cos_HalfPi_minus Sin_plus_Pi Cos_plus_Pi Sin_periodic Cos_periodic Tan_periodic: algebra. corn-8.20.0/transc/PowerSeries.v000066400000000000000000000427351473720167500165210ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing Exp %\ensuremath{\exp}% *) (** printing Sin %\ensuremath{\sin}% *) (** printing Cos %\ensuremath{\cos}% *) (** printing Log %\ensuremath{\log}% *) (** printing Tan %\ensuremath{\tan}% *) Require Export CoRN.ftc.FTC. (** * More on Power Series We will now formally define an operator that defines a function as the sum of some series given a number sequence. Along with it, we will prove some important properties of these entities. *) Section Power_Series. (** ** General results %\begin{convention}% Let [J : interval] and [x0 : IR] be a point of [J]. Let [a : nat -> IR]. %\end{convention}% *) Variable J : interval. Variable x0 : IR. Hypothesis Hx0 : J x0. Variable a : nat -> IR. Definition FPowerSeries (n : nat) := a n{**} (FId{-} [-C-]x0) {^}n. (** The most important convergence criterium specifically for power series is the Dirichlet criterium. *) (* begin show *) Hypothesis Ha : {r : IR | {H : [0] [<] r | {N : nat | forall n, N <= n -> AbsIR (a (S n)) [<=] ([1][/] r[//]pos_ap_zero _ _ H) [*]AbsIR (a n)}}}. Let r := ProjT1 Ha. Let Hr := ProjT1 (ProjT2 Ha). (* end show *) Lemma Dirichlet_crit : fun_series_abs_convergent_IR (olor (x0[-]r) (x0[+]r)) FPowerSeries. Proof. fold r in (value of Hr). red in |- *; intros. red in |- *; intros. apply fun_ratio_test_conv. intro. unfold FPowerSeries in |- *; Contin. elim (ProjT2 (ProjT2 Ha)); intros N HN. exists N. cut {z : IR | [0] [<] z and z [<] r | forall x : IR, Compact Hab x -> AbsIR (x[-]x0) [<=] z}. intro H. elim H; intros z Hz. elim Hz; clear Hz; intros H0z Hzr Hz. clear H. exists (([1][/] r[//]pos_ap_zero _ _ Hr) [*]z). apply shift_mult_less with (pos_ap_zero _ _ H0z). assumption. apply recip_resp_less; assumption. split. apply less_leEq; apply mult_resp_pos. apply recip_resp_pos; assumption. assumption. intros. astepl (AbsIR (FPowerSeries (S n) x (ProjIR1 Hx'))). apply leEq_wdl with (AbsIR (a (S n)) [*]AbsIR (x[-]x0) [*]AbsIR ((x[-]x0) [^]n)). apply leEq_wdr with (([1][/] r[//]pos_ap_zero _ _ Hr) [*]z[*]AbsIR (a n) [*] AbsIR ((x[-]x0) [^]n)). apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. rstepr (([1][/] r[//]pos_ap_zero _ _ Hr) [*]AbsIR (a n) [*]z). apply mult_resp_leEq_both; try apply AbsIR_nonneg. apply HN; assumption. apply Hz; auto. rstepl (([1][/] r[//]pos_ap_zero _ _ Hr) [*]z[*](AbsIR (a n) [*]AbsIR ((x[-]x0) [^]n))). apply mult_wdr. astepr (AbsIR (FPowerSeries n x (ProjIR1 Hx))). simpl in |- *; apply eq_symmetric_unfolded; apply AbsIR_resp_mult. simpl in |- *. apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. apply AbsIR_resp_mult. apply eq_transitive_unfolded with (AbsIR (a (S n)) [*](AbsIR ((x[-]x0) [^]n) [*]AbsIR (x[-]x0))). apply mult_wdr; apply AbsIR_resp_mult. simpl in |- *; rational. clear HN. cut ((forall x : IR, Compact Hab x -> a0 [<=] x) /\ (forall x : IR, Compact Hab x -> x [<=] b)); intros. inversion_clear H. exists (Max (Max (b[-]x0) (x0[-]a0)) (r [/]TwoNZ)). repeat split. eapply less_leEq_trans. 2: apply rht_leEq_Max. apply pos_div_two; auto. repeat apply Max_less. apply shift_minus_less'. elim (Hinc _ (compact_inc_rht _ _ Hab)); auto. apply shift_minus_less; apply shift_less_plus'; elim (Hinc _ (compact_inc_lft _ _ Hab)); auto. apply pos_div_two'; auto. intros. simpl in |- *; unfold ABSIR in |- *; apply Max_leEq. apply leEq_transitive with (b[-]x0). apply minus_resp_leEq; apply H1; auto. eapply leEq_transitive. 2: apply lft_leEq_Max. apply lft_leEq_Max. apply leEq_transitive with (x0[-]a0). rstepr ([--](a0[-]x0)); apply inv_resp_leEq. apply minus_resp_leEq; apply H0; auto. eapply leEq_transitive. 2: apply lft_leEq_Max. apply rht_leEq_Max. split; intros x H; elim H; auto. Qed. (** When defining a function using its Taylor series as a motivation, the following operator can be of use. *) Definition FPowerSeries' n := (a n[/] _[//]nring_fac_ap_zero _ n) {**} (FId{-} [-C-]x0) {^}n. (** This function is also continuous and has a good convergence ratio. *) Lemma FPowerSeries'_cont : forall n, Continuous realline (FPowerSeries' n). Proof. intros; unfold FPowerSeries' in |- *. Contin. Qed. Lemma included_FPowerSeries' : forall n P, included P (Dom (FPowerSeries' n)). Proof. repeat split. Qed. (* begin show *) Hypothesis Ha' : {N : nat | {c : IR | [0] [<] c | forall n, N <= n -> AbsIR (a (S n)) [<=] c[*]AbsIR (a n)}}. (* end show *) Lemma FPowerSeries'_conv' : fun_series_abs_convergent_IR realline FPowerSeries'. Proof. clear Hr r Ha. red in |- *; intros. red in |- *; intros. apply fun_ratio_test_conv. intro. unfold FPowerSeries' in |- *; Contin. elim Ha'; intros N HN. elim HN; intros c H H0. clear HN Ha'. elim (Archimedes (Max (Max b x0[-]Min a0 x0) [1][*]Two[*]c)); intros y Hy. exists (Nat.max N y); exists (Half:IR); repeat split. unfold Half in |- *. apply pos_div_two'; apply pos_one. apply less_leEq; apply pos_half. intros x H1; intros. astepl (AbsIR (FPowerSeries' (S n) x (ProjIR1 Hx'))). astepr (Half[*]AbsIR (FPowerSeries' n x (ProjIR1 Hx))). simpl in |- *. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply leEq_wdl with ((AbsIR (a (S n)) [/] _[//]nring_fac_ap_zero _ (S n)) [*] (AbsIR ((x[-]x0) [^]n) [*]AbsIR (x[-]x0))). 2: apply mult_wd. 2: apply eq_transitive_unfolded with (AbsIR (a (S n)) [/] _[//] AbsIR_resp_ap_zero _ (nring_fac_ap_zero _ (S n))). 3: apply eq_symmetric_unfolded; apply AbsIR_division. 2: apply div_wd; algebra. 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x; apply nring_nonneg. 2: apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 2: apply AbsIR_resp_mult. 2: apply mult_wd; apply AbsIR_wd; simpl in |- *; algebra. apply leEq_wdr with ([1] [/]TwoNZ[*](AbsIR (a n) [/] _[//]nring_fac_ap_zero _ n) [*] AbsIR ((x[-]x0) [^]n)). 2: apply eq_symmetric_unfolded; eapply eq_transitive_unfolded. 3: apply mult_assoc_unfolded. 2: apply mult_wdr. 2: eapply eq_transitive_unfolded. 2: apply AbsIR_resp_mult. 2: apply mult_wdl; simpl in |- *; algebra. 2: apply eq_transitive_unfolded with (AbsIR (a n) [/] _[//]AbsIR_resp_ap_zero _ (nring_fac_ap_zero _ n)). 2: apply AbsIR_division. 2: apply div_wd; algebra. 2: apply AbsIR_eq_x; apply nring_nonneg. rstepl (AbsIR (a (S n)) [*]AbsIR (x[-]x0) [*]AbsIR ((x[-]x0) [^]n) [/] _[//] nring_fac_ap_zero _ (S n)). apply shift_div_leEq. apply pos_nring_fac. rstepr ([1] [/]TwoNZ[*] (AbsIR (a n) [*]nring (fact (S n)) [/] _[//]nring_fac_ap_zero _ n) [*] AbsIR ((x[-]x0) [^]n)). apply leEq_wdr with ([1] [/]TwoNZ[*](AbsIR (a n) [*]nring (S n)) [*]AbsIR ((x[-]x0) [^]n)). 2: apply mult_wdl; apply mult_wdr. 2: rstepr (AbsIR (a n) [*](nring (fact (S n)) [/] _[//]nring_fac_ap_zero _ n)). 2: apply mult_wdr. 2: astepr (nring (S n * fact n) [/] _[//]nring_fac_ap_zero IR n). 2: astepr (nring (S n) [*]nring (fact n) [/] _[//]nring_fac_ap_zero IR n); rational. rstepr ([1] [/]TwoNZ[*]nring (S n) [*]AbsIR (a n) [*]AbsIR ((x[-]x0) [^]n)). apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. apply leEq_transitive with (AbsIR (a (S n)) [*]AbsIR (Max b x0[-]Min a0 x0)). apply mult_resp_leEq_lft. cut (Min a0 x0 [<=] Max b x0). intro H3. apply compact_elements with H3. inversion_clear H1; split. apply leEq_transitive with a0; auto; apply Min_leEq_lft. apply leEq_transitive with b; auto; apply lft_leEq_Max. split. apply Min_leEq_rht. apply rht_leEq_Max. apply leEq_transitive with x0. apply Min_leEq_rht. apply rht_leEq_Max. apply AbsIR_nonneg. apply leEq_transitive with (AbsIR (a (S n)) [*]Max (Max b x0[-]Min a0 x0) [1]). apply mult_resp_leEq_lft. 2: apply AbsIR_nonneg. eapply leEq_wdl. apply lft_leEq_Max. apply eq_symmetric_unfolded; apply AbsIR_eq_x. apply shift_leEq_minus; astepl (Min a0 x0). apply leEq_transitive with x0. apply Min_leEq_rht. apply rht_leEq_Max. apply shift_mult_leEq with (max_one_ap_zero (Max b x0[-]Min a0 x0)). apply pos_max_one. apply leEq_transitive with (c[*]AbsIR (a n)). apply H0. apply Nat.le_trans with (Nat.max N y); auto; apply Nat.le_max_l. apply shift_leEq_div. apply pos_max_one. rstepl (c[*]Max (Max b x0[-]Min a0 x0) [1][*]AbsIR (a n)). apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. rstepr (nring (R:=IR) (S n) [/]TwoNZ); apply shift_leEq_div. apply pos_two. apply less_leEq; apply leEq_less_trans with (nring (R:=IR) y). eapply leEq_wdl. apply Hy. rational. apply nring_less. red in |- *. cut (y <= n); intros; auto with arith. apply Nat.le_trans with (Nat.max N y); auto with arith. Qed. Lemma FPowerSeries'_conv : fun_series_convergent_IR realline FPowerSeries'. Proof. apply abs_imp_conv_IR. apply FPowerSeries'_cont. apply FPowerSeries'_conv'. Qed. End Power_Series. #[global] Hint Resolve FPowerSeries'_cont: continuous. Section More_on_PowerSeries. (** %\begin{convention}% Let [F] and [G] be the power series defined respectively by [a] and by [fun n => (a (S n))]. %\end{convention}% *) Variable x0 : IR. Variable a : nat -> IR. (* begin hide *) Let F := FPowerSeries' x0 a. Let G := FPowerSeries' x0 (fun n => a (S n)). (* end hide *) (* begin show *) Variable J : interval. Hypothesis Hf : fun_series_convergent_IR J F. Hypothesis Hf' : fun_series_abs_convergent_IR J F. Hypothesis Hg : fun_series_convergent_IR J G. (* end show *) (** We get a comparison test for power series. *) Lemma FPowerSeries'_comp : forall b, (forall n, AbsIR (b n) [<=] a n) -> fun_series_convergent_IR J (FPowerSeries' x0 b). Proof. intros. apply fun_comparison_IR with (fun n : nat => FAbs (FPowerSeries' x0 a n)). intros n. apply Included_imp_Continuous with realline;[Contin | auto with *]. auto. intros. apply leEq_wdr with (AbsIR (FPowerSeries' x0 a n x (ProjIR1 Hx'))). 2: apply eq_symmetric_unfolded; apply FAbs_char. simpl in |- *. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_division with (y__ := AbsIR_resp_ap_zero _ (nring_fac_ap_zero IR n)). eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_division with (y__ := AbsIR_resp_ap_zero _ (nring_fac_ap_zero IR n)). apply div_resp_leEq. eapply less_leEq_trans. apply (pos_nring_fac IR n). apply leEq_AbsIR. apply leEq_transitive with (a n); [ auto | apply leEq_AbsIR ]. Qed. (** And a rule for differentiation. *) Lemma Derivative_FPowerSeries1' : forall H, Derivative J H (FSeries_Sum Hf) (FSeries_Sum Hg). Proof. intro. eapply Derivative_wdr. apply Feq_symmetric; apply (insert_series_sum _ _ Hg). apply Derivative_FSeries. intro; case n; clear n; intros. simpl in |- *. apply Derivative_wdl with (Fconst (S:=IR) (a 0)). FEQ. Deriv. simpl in |- *. Opaque nring fact. unfold F, G, FPowerSeries' in |- *; simpl in |- *. Derivative_Help. apply eq_imp_Feq. apply included_FScalMult; apply included_FScalMult. apply included_FMult; Included. apply included_FScalMult; Included. intros; simpl in |- *. set (y := nexp _ n (x[-]x0)) in *. rstepl (a (S n) [*]y[*](nring (S n) [/] _[//]nring_fac_ap_zero _ (S n))). rstepr (a (S n) [*]y[*] (nring (S n) [/] _[//] mult_resp_ap_zero _ _ _ (pos_ap_zero _ _ (pos_nring_S _ n)) (nring_fac_ap_zero _ n))). apply mult_wdr. apply div_wd; algebra. Step_final (nring (R:=IR) (S n * fact n)). Qed. End More_on_PowerSeries. Section Definitions. (** ** Function definitions through power series We now define the exponential, sine and cosine functions as power series, and prove their convergence. Tangent is defined as the quotient of sine over cosine. *) Definition Exp_ps := FPowerSeries' [0] (fun n : nat => [1]). Definition sin_seq : nat -> IR. Proof. intro n; elim (even_or_odd_plus n); intros k Hk; inversion_clear Hk. apply ZeroR. apply ([--]OneR[^]k). Defined. Definition sin_ps := FPowerSeries' [0] sin_seq. Definition cos_seq : nat -> IR. Proof. intro n; elim (even_or_odd_plus n); intros k Hk; inversion_clear Hk. apply ([--]OneR[^]k). apply ZeroR. Defined. Definition cos_ps := FPowerSeries' [0] cos_seq. Lemma Exp_conv' : fun_series_abs_convergent_IR realline Exp_ps. Proof. unfold Exp_ps in |- *. apply FPowerSeries'_conv'. exists 0; exists OneR. apply pos_one. intros; apply eq_imp_leEq; algebra. Qed. Lemma Exp_conv : fun_series_convergent_IR realline Exp_ps. Proof. unfold Exp_ps in |- *. apply FPowerSeries'_conv. exists 0; exists OneR. apply pos_one. intros; apply eq_imp_leEq; algebra. Qed. Lemma sin_conv : fun_series_convergent_IR realline sin_ps. Proof. unfold sin_ps in |- *; apply FPowerSeries'_comp with (fun n : nat => OneR). apply Exp_conv'. intros; unfold sin_seq in |- *. elim even_or_odd_plus; intros k Hk; simpl in |- *. elim Hk; simpl in |- *; intro. eapply leEq_wdl; [ apply less_leEq; apply pos_one | apply eq_symmetric_unfolded; apply AbsIRz_isz ]. apply eq_imp_leEq. destruct (even_or_odd_plus k) as [j [H | H]]. apply eq_transitive_unfolded with (AbsIR [1]). apply AbsIR_wd; astepl ([--]OneR[^]k); apply inv_one_even_nexp; auto. exists j; rewrite H; ring. apply AbsIR_eq_x; apply less_leEq; apply pos_one. apply eq_transitive_unfolded with (AbsIR [--][1]). apply AbsIR_wd; astepl ([--]OneR[^]k); apply inv_one_odd_nexp; auto. exists j; rewrite H; ring. astepr ([--][--]OneR); apply AbsIR_eq_inv_x; apply less_leEq. astepr ([--]ZeroR); apply inv_resp_less; apply pos_one. Qed. Lemma cos_conv : fun_series_convergent_IR realline cos_ps. Proof. unfold cos_ps in |- *; apply FPowerSeries'_comp with (fun n : nat => OneR). apply Exp_conv'. intros; unfold cos_seq in |- *. elim even_or_odd_plus; intros k Hk; simpl in |- *. elim Hk; simpl in |- *; intro. apply eq_imp_leEq. destruct (even_or_odd_plus k) as [j [Hj | Hj]]. apply eq_transitive_unfolded with (AbsIR [1]). apply AbsIR_wd; astepl ([--]OneR[^]k); apply inv_one_even_nexp; auto. exists j; rewrite Hj; ring. apply AbsIR_eq_x; apply less_leEq; apply pos_one. apply eq_transitive_unfolded with (AbsIR [--][1]). apply AbsIR_wd; astepl ([--]OneR[^]k); apply inv_one_odd_nexp; auto. exists j; rewrite Hj; ring. astepr ([--][--]OneR); apply AbsIR_eq_inv_x; apply less_leEq. astepr ([--]ZeroR); apply inv_resp_less; apply pos_one. eapply leEq_wdl; [ apply less_leEq; apply pos_one | apply eq_symmetric_unfolded; apply AbsIRz_isz ]. Qed. Definition Expon := FSeries_Sum Exp_conv. Definition Sine := FSeries_Sum sin_conv. Definition Cosine := FSeries_Sum cos_conv. Definition Tang := Sine{/}Cosine. (** Some auxiliary domain results. *) Lemma Exp_domain : forall x : IR, Dom Expon x. Proof. intros; simpl in |- *; auto. Qed. Lemma sin_domain : forall x : IR, Dom Sine x. Proof. intros; simpl in |- *; auto. Qed. Lemma cos_domain : forall x : IR, Dom Cosine x. Proof. intros; simpl in |- *; auto. Qed. Lemma included_Exp : forall P, included P (Dom Expon). Proof. intro; simpl in |- *; Included. Qed. Lemma included_Sin : forall P, included P (Dom Sine). Proof. intro; simpl in |- *; Included. Qed. Lemma included_Cos : forall P, included P (Dom Cosine). Proof. intro; simpl in |- *; Included. Qed. (** Definition of the logarithm. *) Lemma log_defn_lemma : Continuous (openl [0]) {1/}FId. Proof. apply Continuous_recip. apply Continuous_id. intros a b Hab H. split. Included. assert (H0 : [0] [<] a). apply H; apply compact_inc_lft. exists a. auto. intros y Hy H1; inversion_clear H1. apply leEq_transitive with y. auto. apply leEq_AbsIR. Qed. Definition Logarithm := ( [-S-]log_defn_lemma) [1] (pos_one IR). End Definitions. #[global] Hint Resolve included_Exp included_Sin included_Cos: included. (** As most of these functions are total, it makes sense to treat them as setoid functions on the reals. In the case of logarithm and tangent, this is not possible; however, we still define some abbreviations for aesthetical reasons. *) Definition Exp : CSetoid_un_op IR. Proof. red in |- *. apply Build_CSetoid_fun with (fun x : IR => Expon x I). intros x y H. exact (pfstrx _ _ _ _ _ _ H). Defined. Definition Sin : CSetoid_un_op IR. Proof. red in |- *. apply Build_CSetoid_fun with (fun x : IR => Sine x I). intros x y H. exact (pfstrx _ _ _ _ _ _ H). Defined. Definition Cos : CSetoid_un_op IR. Proof. red in |- *. apply Build_CSetoid_fun with (fun x : IR => Cosine x I). intros x y H. exact (pfstrx _ _ _ _ _ _ H). Defined. Definition Log x (Hx : [0] [<] x) := Logarithm x Hx. Definition Tan x Hx := Tang x Hx. corn-8.20.0/transc/RealPowers.v000066400000000000000000000505421473720167500163300ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) (** printing [!] %\ensuremath{\hat{\ }}% #^# *) (** printing {!} %\ensuremath{\hat{\ }}% #^# *) Require Export CoRN.transc.Exponential. Opaque Expon. (** * Arbitrary Real Powers ** Powers of Real Numbers We now define $x^y=e^{y\times\log(x)}$#xy=ey*log(x)#, whenever [x [>] 0], inspired by the rules for manipulating these expressions. *) Definition power x y (Hx : [0] [<] x) := Exp (y[*]Log x Hx). Notation "x [!] y [//] Hy" := (power x y Hy) (at level 20). (** This definition yields a well defined, strongly extensional function which extends the algebraic exponentiation to an integer power and still has all the good properties of that operation; when [x [=] e] it coincides with the exponential function. *) Lemma power_wd : forall x x' y y' Hx Hx', x [=] x' -> y [=] y' -> x[!]y[//]Hx [=] x'[!]y'[//]Hx'. Proof. intros. unfold power in |- *; algebra. Qed. Lemma power_strext : forall x x' y y' Hx Hx', x[!]y[//]Hx [#] x'[!]y'[//]Hx' -> x [#] x' or y [#] y'. Proof. intros. cut (Log x Hx [#] Log x' Hx' or y [#] y'). intro H0. elim H0; intro H1; [ left | right ]; auto; exact (Log_strext _ _ _ _ H1). apply bin_op_strext_unfolded with (cr_mult (c:=IR)). astepl (y[*]Log x Hx); astepr (y'[*]Log x' Hx'). apply Exp_strext; auto. Qed. Lemma power_plus : forall x y z Hx, x[!]y[+]z[//]Hx [=] x[!]y[//]Hx[*]x[!]z[//]Hx. Proof. intros. unfold power in |- *. Step_final (Exp (y[*]Log x Hx[+]z[*]Log x Hx)). Qed. Lemma power_inv : forall x y Hx Hxy, x[!] [--]y[//]Hx [=] ([1][/] x[!]y[//]Hx[//]Hxy). Proof. intros; unfold power in |- *. rstepr ([1][/] _[//]Exp_ap_zero (y[*]Log x Hx)). Step_final (Exp [--] (y[*]Log x Hx)). Qed. #[global] Hint Resolve power_wd power_plus power_inv: algebra. Lemma power_minus : forall x y z Hx Hxz, x[!]y[-]z[//]Hx [=] (x[!]y[//]Hx[/] x[!]z[//]Hx[//]Hxz). Proof. intros. unfold cg_minus in |- *. astepl (x[!]y[//]Hx[*]x[!][--]z[//]Hx). rstepr (x[!]y[//]Hx[*] ([1][/] _[//]Hxz)). algebra. Qed. Lemma power_nat : forall x n Hx, x[!]nring n[//]Hx [=] x[^]n. Proof. intros; unfold power in |- *. induction n as [| n Hrecn]. simpl in |- *; astepr (Exp [0]); simpl in |- *; algebra. simpl in |- *. astepr (Exp (nring n[*]Log x Hx) [*]Exp (Log x Hx)). astepr (Exp (nring n[*]Log x Hx[+]Log x Hx)). simpl in |- *; rational. Qed. #[global] Hint Resolve power_minus power_nat: algebra. Lemma power_zero : forall (x : IR) Hx, x[!][0][//]Hx [=] [1]. Proof. intros. astepl (x[!]nring 0[//]Hx). Step_final (x[^]0). Qed. Lemma power_one : forall (x : IR) Hx, x[!][1][//]Hx [=] x. Proof. intros. astepr (x[^]1). astepr (x[!]nring 1[//]Hx). simpl in |- *; algebra. Qed. Lemma one_power : forall (x : IR) H, [1][!]x[//]H [=] [1]. Proof. intros x H. unfold power. astepl (Exp (x[*][0])). rstepl (Exp ([0])). algebra. Qed. #[global] Hint Resolve power_zero power_one one_power: algebra. Opaque nexp_op. Lemma power_int : forall x z Hx Hx', x[!]zring z[//]Hx [=] (x[//]Hx') [^^] (z). Proof. intros; induction z as [| p| p]. simpl in |- *. Step_final (x[!][0][//]Hx). simpl in |- *. Step_final (x[!]nring (nat_of_P p) [//]Hx). simpl in |- *. astepl (x[!][--] (nring (nat_of_P p)) [//]Hx). astepl ([1][/] x[!]nring (nat_of_P p) [//]Hx[//]Exp_ap_zero _). Step_final ([1][/] x[^]nat_of_P p[//]nexp_resp_ap_zero _ Hx'). Qed. #[global] Hint Resolve power_int: algebra. Lemma Exp_power : forall (x : IR) He, E[!]x[//]He [=] Exp x. Proof. intros; unfold power in |- *. Step_final (Exp (x[*][1])). Qed. Lemma mult_power : forall x y z Hx Hy Hxy, (x[*]y) [!]z[//]Hxy [=] x[!]z[//]Hx[*]y[!]z[//]Hy. Proof. intros; unfold power in |- *. astepr (Exp (z[*]Log _ Hx[+]z[*]Log _ Hy)). Step_final (Exp (z[*] (Log _ Hx[+]Log _ Hy))). Qed. Lemma recip_power : forall x y Hx Hx' Hx'' Hxy, ([1][/] x[//]Hx') [!]y[//]Hx'' [=] ([1][/] x[!]y[//]Hx[//]Hxy). Proof. intros; unfold power in |- *. rstepr ([1][/] _[//]Exp_ap_zero (y[*]Log x Hx)). astepr (Exp [--] (y[*]Log _ Hx)). Step_final (Exp (y[*][--] (Log _ Hx))). Qed. #[global] Hint Resolve Exp_power mult_power recip_power: algebra. Lemma div_power : forall x y z Hx Hy Hy' Hxy Hyz, (x[/] y[//]Hy') [!]z[//]Hxy [=] (x[!]z[//]Hx[/] y[!]z[//]Hy[//]Hyz). Proof. intros. apply eq_transitive_unfolded with ((x[*] ([1][/] _[//]Hy')) [!]z[//] mult_resp_pos _ _ _ Hx (recip_resp_pos _ _ Hy' Hy)). apply power_wd; rational. rstepr (x[!]z[//]Hx[*] ([1][/] _[//]Hyz)). Step_final (x[!]z[//]Hx[*]_[!]z[//]recip_resp_pos _ _ Hy' Hy). Qed. #[global] Hint Resolve div_power: algebra. Lemma power_ap_zero : forall (x y : IR) Hx, x[!]y[//]Hx [#] [0]. Proof. intros; unfold power in |- *. apply Exp_ap_zero. Qed. Lemma power_mult : forall x y z Hx Hxy, x[!]y[*]z[//]Hx [=] (x[!]y[//]Hx) [!]z[//]Hxy. Proof. intros; unfold power in |- *. apply Exp_wd. astepl (z[*]y[*]Log x Hx). astepl (z[*] (y[*]Log x Hx)). algebra. Qed. Lemma power_pos : forall (x y : IR) Hx, [0] [<] x[!]y[//]Hx. Proof. intros; unfold power in |- *. apply Exp_pos. Qed. #[global] Hint Resolve power_mult: algebra. Lemma power_recip : forall x q Hx (Hx' : [0] [<=] x) Hq (Hq' : 0 < q), x[!][1][/] nring q[//]Hq[//]Hx [=] NRoot Hx' Hq'. Proof. intros. apply NRoot_unique. apply less_leEq; apply power_pos. apply power_pos. astepr (x[!][1][//]Hx). astepl (_[!]nring q[//]power_pos _ ([1][/] _[//]Hq) Hx). Step_final (x[!] ([1][/] _[//]Hq) [*]nring q[//]Hx). Qed. #[global] Hint Resolve power_recip: algebra. Lemma power_div : forall x p q Hx (Hx' : [0] [<=] x) Hq (Hq' : 0 < q), x[!]nring p[/] nring q[//]Hq[//]Hx [=] (NRoot Hx' Hq') [^]p. Proof. intros. apply eq_transitive_unfolded with (x[!] ([1][/] _[//]Hq) [*]nring p[//]Hx). apply power_wd; rational. astepr (NRoot Hx' Hq'[!]nring p[//]NRoot_pos _ Hx' _ Hq' Hx). Step_final ((x[!][1][/] _[//]Hq[//]Hx) [!]nring p[//]power_pos _ _ _). Qed. #[global] Hint Resolve power_div: algebra. Lemma real_power_resp_leEq_rht : forall x y p Hx Hy, [0][<=] p -> x[<=]y -> x[!]p[//]Hx [<=] y[!]p[//]Hy. Proof. intros x y p Hp Hx Hy H. unfold power. apply Exp_resp_leEq. apply mult_resp_leEq_lft; try assumption. apply Log_resp_leEq. assumption. Qed. Lemma real_power_resp_less_rht : forall x y p Hx Hy, [0][<] p -> x[<]y -> x[!]p[//]Hx [<] y[!]p[//]Hy. Proof. intros x y p Hp Hx Hy H. unfold power. apply Exp_resp_less. apply mult_resp_less_lft; try assumption. apply Log_resp_less. assumption. Qed. Lemma real_power_resp_leEq_lft : forall x p q Hx Hx', [1][<=]x -> p[<=]q -> x[!]p[//]Hx [<=] x[!]q[//]Hx'. Proof. intros x p q Hx Hx' Hx0 H. unfold power. apply Exp_resp_leEq. stepr (q[*]Log x Hx); [| now csetoid_rewrite (Log_wd x x Hx Hx' (eq_reflexive IR x)); apply eq_reflexive]. apply mult_resp_leEq_rht; try assumption. apply Zero_leEq_Log. assumption. Qed. Lemma real_power_resp_less_lft : forall x p q Hx Hx', [1][<]x -> p[<]q -> x[!]p[//]Hx [<] x[!]q[//]Hx'. Proof. intros x p q Hx Hx' Hx0 H. unfold power. apply Exp_resp_less. stepr (q[*]Log x Hx); [| now csetoid_rewrite (Log_wd x x Hx Hx' (eq_reflexive IR x)); apply eq_reflexive]. apply mult_resp_less; try assumption. apply Zero_less_Log. assumption. Qed. Lemma real_power_resp_leEq_both : forall x y p q Hx Hy', [1][<=]x -> [0] [<=] p -> x[<=]y -> p[<=]q -> x[!]p[//]Hx [<=] y[!]q[//]Hy'. Proof. intros x y p q Hx Hy Hx0 Hp H0 H1. apply leEq_transitive with (y[!]p[//]Hy). apply real_power_resp_leEq_rht; assumption. apply real_power_resp_leEq_lft; try assumption. apply leEq_transitive with x; assumption. Qed. Lemma real_power_resp_less_both : forall x y p q Hx Hy', [1][<]x -> [0] [<] p -> x[<]y -> p[<]q -> x[!]p[//]Hx [<] y[!]q[//]Hy'. Proof. intros x y p q Hx Hy Hx0 Hp H0 H1. apply less_transitive_unfolded with (y[!]p[//]Hy). apply real_power_resp_less_rht; assumption. apply real_power_resp_less_lft; try assumption. apply less_transitive_unfolded with x; assumption. Qed. Section Power_Function. (** ** Power Function This operation on real numbers gives birth to an analogous operation on partial functions which preserves continuity. %\begin{convention}% Let [F, G : PartIR]. %\end{convention}% *) Variable J : interval. Variables F G : PartIR. Definition FPower := Expon[o]G{*} (Logarithm[o]F). Lemma FPower_domain : forall x, Dom F x -> Dom G x -> (forall Hx, [0] [<] F x Hx) -> Dom FPower x. Proof. intros x H H0 H1. simpl in |- *. cut (Conj (Dom G) (fun y : IR => {Hx : _ | [0] [<] Part F y Hx}) x). intro H2. exists H2; split. split; auto. exists H; auto. Qed. Lemma Continuous_power : positive_fun J F -> Continuous J F -> Continuous J G -> Continuous J FPower. Proof. intros H H0 H1. unfold FPower in |- *. apply Continuous_comp with realline. 3: apply Continuous_Exp. 2: apply Continuous_mult; [ apply H1 | apply Continuous_comp with (openl [0]); auto ]. 3: apply Continuous_Log. apply maps_compacts_into_strict_imp_weak; apply Continuous_imp_maps_compacts_into. apply Continuous_mult; auto. apply Continuous_comp with (openl [0]); auto. 2: apply Continuous_Log. apply maps_compacts_into_strict_imp_weak; apply positive_imp_maps_compacts_into; auto. apply maps_compacts_into_strict_imp_weak; apply positive_imp_maps_compacts_into; auto. Qed. End Power_Function. Notation "F {!} G" := (FPower F G) (at level 20). Section More_on_Power_Function. Opaque Expon Logarithm. (** From global continuity we can obviously get local continuity: *) Lemma continuous_I_power : forall F G a b Hab, Continuous_I Hab F -> Continuous_I Hab G -> positive_fun (compact a b Hab) F -> Continuous_I Hab (F{!}G). Proof. intros. apply (Int_Continuous (clcr a b) Hab). apply Continuous_power. auto. apply Continuous_Int with Hab Hab; auto. apply Continuous_Int with Hab Hab; auto. Qed. (** The rule for differentiation is a must. *) Lemma Derivative_power : forall (J : interval) pJ F F' G G', positive_fun J F -> Derivative J pJ F F' -> Derivative J pJ G G' -> Derivative J pJ (F{!}G) (G{*} (F{!} (G{-} [-C-][1]) {*}F') {+}F{!}G{*} (G'{*} (Logarithm[o]F))). Proof. intros J pJ F F' G G' H H0 H1. unfold FPower in |- *. assert (H2 : Derivative (openl [0]) I Logarithm {1/}FId). apply Derivative_Log. assert (H3 : Derivative realline I Expon Expon). apply Derivative_Exp. elim H; intros incF H'. elim H'; intros c H4 H5; clear incF H'. Derivative_Help. apply eq_imp_Feq. apply included_FMult. apply included_FComp. intros x H6. repeat split. apply (Derivative_imp_inc _ _ _ _ H1); auto. simpl in |- *. exists (Derivative_imp_inc _ _ _ _ H0 _ H6). apply Log_domain; apply less_leEq_trans with c; auto. intros; apply Exp_domain. intros x H6; simpl in |- *; repeat split. apply (Derivative_imp_inc _ _ _ _ H1); auto. exists (Derivative_imp_inc _ _ _ _ H0 _ H6). repeat split. intros; simpl in |- *. apply Greater_imp_ap; apply less_leEq_trans with c; auto. apply (Derivative_imp_inc' _ _ _ _ H0); auto. apply (Derivative_imp_inc' _ _ _ _ H1); auto. exists (Derivative_imp_inc _ _ _ _ H0 _ H6). intros; apply Log_domain; apply less_leEq_trans with c; auto. apply included_FPlus. apply included_FMult. Included. apply included_FMult. apply included_FComp. apply included_FMult. Included. apply included_FComp. Included. intros; apply Log_domain; apply less_leEq_trans with c; auto. intros; apply Exp_domain. Included. apply included_FMult. apply included_FComp. apply included_FMult. Included. apply included_FComp. Included. intros; apply Log_domain; apply less_leEq_trans with c; auto. intros; apply Exp_domain. apply included_FMult. Included. apply included_FComp. Included. intros; apply Log_domain; apply less_leEq_trans with c; auto. intros. astepl (Part _ _ (ProjIR1 Hx) [*]Part _ _ (ProjIR2 Hx)). elim Hx; intros Hx1 Hx2; clear Hx. astepl (Part _ _ Hx1[*]Part _ _ Hx2). astepl (Part _ _ (ProjT2 Hx1) [*]Part _ _ Hx2). elim Hx1; clear Hx1; intros Hx1 Hx3. astepl (Part _ (Part _ _ Hx1) Hx3[*]Part _ _ Hx2). generalize Hx3; clear Hx3. elim Hx1; intros Hx4 Hx5. intro; astepl (Part _ (Part _ _ (ProjIR1 (Hx4, Hx5)) [*] Part _ _ (ProjIR2 (Hx4, Hx5))) Hx3[*] Part _ _ Hx2). cut (Dom Expon (Part _ _ Hx4[*]Part _ _ Hx5)). intro H7. 2: apply dom_wd with (x := Part _ _ (ProjIR1 (Hx4, Hx5)) [*] Part _ _ (ProjIR2 (Hx4, Hx5))); algebra. astepl (Part _ (Part _ _ Hx4[*]Part _ _ Hx5) H7[*]Part _ _ Hx2). clear Hx3; rename H7 into Hx3. astepl (Part _ (Part _ _ Hx4[*]Part _ _ (ProjT2 Hx5)) Hx3[*]Part _ _ Hx2). generalize Hx3; clear Hx3. elim Hx5; intros Hx6 Hx7. intro; astepl (Part _ (Part _ _ Hx4[*]Part _ _ Hx7) Hx3[*]Part _ _ Hx2). set (A := Part _ (Part _ _ Hx4[*]Part _ _ Hx7) Hx3) in *. astepl (A[*] (Part _ _ (ProjIR1 Hx2) [+]Part _ _ (ProjIR2 Hx2))). elim Hx2; intros Hx8 Hx9. astepl (A[*] (Part _ _ Hx8[+]Part _ _ Hx9)). astepl (A[*] (Part _ _ (ProjIR1 Hx8) [*]Part _ _ (ProjIR2 Hx8) [+]Part _ _ Hx9)). elim Hx8; intros Hx10 Hx11. astepl (A[*] (Part _ _ Hx10[*]Part _ _ Hx11[+]Part _ _ Hx9)). astepl (A[*] (Part _ _ Hx10[*]Part _ _ Hx11[+] Part _ _ (ProjIR1 Hx9) [*]Part _ _ (ProjIR2 Hx9))). elim Hx9; intros Hx12 Hx13. astepl (A[*] (Part _ _ Hx10[*]Part _ _ Hx11[+]Part _ _ Hx12[*]Part _ _ Hx13)). astepl (A[*] (Part _ _ Hx10[*] (Part _ _ (ProjIR1 Hx11) [*]Part _ _ (ProjIR2 Hx11)) [+] Part _ _ Hx12[*]Part _ _ Hx13)). elim Hx11; intros Hx14 Hx15. apply eq_transitive_unfolded with (A[*] (Part _ _ Hx10[*] (Part _ _ Hx14[*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ Hx13)). apply mult_wd; algebra. astepl (A[*] (Part _ _ Hx10[*] (Part _ _ Hx14[*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ (ProjT2 Hx13))). elim Hx13; intros Hx16 Hx17. astepl (A[*] (Part _ _ Hx10[*] (Part _ _ Hx14[*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ Hx17)). astepl (A[*] (Part _ _ Hx10[*] (Part _ _ (ProjT2 Hx14) [*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ Hx17)). elim Hx14; intros Hx18 Hx19. astepl (A[*] (Part _ _ Hx10[*] (Part _ _ Hx19[*]Part _ _ Hx15) [+] Part _ _ Hx12[*]Part _ _ Hx17)). elim Hx19; intros Hx20 Hx21. assert (H7 : Dom G x). auto. assert (H8 : Dom F x). auto. cut ([0] [<] Part _ _ H8). intro H9. assert (H10 : Part _ _ H8 [#] [0]). apply Greater_imp_ap; auto. assert (H11 : Dom F' x). auto. assert (H12 : Dom G' x). auto. apply eq_transitive_unfolded with (Exp (Part _ _ H7[*]Log _ H9) [*] (Part _ _ H7[*] (([1][/] _[//]H10) [*]Part _ _ H11) [+] Part _ _ H12[*]Log _ H9)). unfold A, Log in |- *; simpl in |- *. repeat first [apply mult_wd | apply pfwdef | apply bin_op_wd_unfolded]; try reflexivity. clear Hx21 Hx20 Hx19 Hx18 Hx17 Hx16 Hx15 Hx14 Hx13 Hx12 Hx11 Hx10 Hx9 Hx8 A Hx3 Hx7 Hx6 Hx5 Hx4 Hx1 Hx2. astepr (Part _ _ (ProjIR1 Hx') [+]Part _ _ (ProjIR2 Hx')). elim Hx'; clear Hx'; intros Hx1 Hx2. astepr (Part _ _ Hx1[+]Part _ _ Hx2). astepr (Part _ _ Hx1[+]Part _ _ (ProjIR1 Hx2) [*]Part _ _ (ProjIR2 Hx2)). elim Hx2; clear Hx2; intros Hx2 Hx3. astepr (Part _ _ Hx1[+]Part _ _ Hx2[*]Part _ _ Hx3). astepr (Part _ _ Hx1[+] Part _ _ Hx2[*] (Part _ _ (ProjIR1 Hx3) [*]Part _ _ (ProjIR2 Hx3))). elim Hx3; clear Hx3; intros Hx3 Hx4. astepr (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Part _ _ Hx4)); clear Hx3. astepr (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Part _ _ (ProjT2 Hx4))). elim Hx4; clear Hx4; intros Hx3 Hx4. astepr (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Part _ _ Hx4)). apply eq_transitive_unfolded with (Part _ _ Hx1[+]Part _ _ Hx2[*] (Part _ _ H12[*]Log _ H9)). 2: unfold Log in |- *; apply bin_op_wd_unfolded; algebra. clear Hx3 Hx4. astepr (Part _ _ Hx1[+]Part _ _ (ProjT2 Hx2) [*] (Part _ _ H12[*]Log _ H9)). elim Hx2; clear Hx2; intros Hx2 Hx3. astepr (Part _ _ Hx1[+]Part _ _ Hx3[*] (Part _ _ H12[*]Log _ H9)). generalize Hx3; clear Hx3. elim Hx2; clear Hx2; intros Hx4 Hx5 Hx3. assert (H13 : Dom Expon (Part _ _ Hx4[*]Part _ _ Hx5)). apply Exp_domain. astepr (Part _ _ Hx1[+] Part _ (Part _ _ (ProjIR1 (Hx4, Hx5)) [*] Part _ _ (ProjIR2 (Hx4, Hx5))) Hx3[*] (Part _ _ H12[*]Log _ H9)). apply eq_transitive_unfolded with (Part _ _ Hx1[+]Part _ _ H13[*] (Part _ _ H12[*]Log _ H9)). 2: apply bin_op_wd_unfolded; algebra. generalize H13; clear H13 Hx3. elim Hx5; clear Hx5; intros Hx5 Hx6 Hx3. astepr (Part _ _ Hx1[+] Part _ (Part _ _ Hx4[*]Part _ _ Hx6) Hx3[*] (Part _ _ H12[*]Log _ H9)). apply eq_transitive_unfolded with (Part _ _ Hx1[+]Exp (Part _ _ H7[*]Log _ H9) [*] (Part _ _ H12[*]Log _ H9)). 2: apply bin_op_wd_unfolded; [ algebra | unfold Log in |- *; simpl in |- * ]. 2: apply bin_op_wd_unfolded; algebra. eapply eq_transitive_unfolded. apply ring_dist_unfolded. apply bin_op_wd_unfolded. 2: apply eq_reflexive_unfolded. clear Hx3 Hx6 Hx5 Hx4. astepr (Part _ _ (ProjIR1 Hx1) [*]Part _ _ (ProjIR2 Hx1)). elim Hx1; clear Hx1; intros Hx1 Hx2. astepr (Part _ _ Hx1[*]Part _ _ Hx2). astepr (Part _ _ H7[*] (Part _ _ (ProjIR1 Hx2) [*]Part _ _ (ProjIR2 Hx2))). elim Hx2; clear Hx2 Hx1; intros Hx1 Hx2. astepr (Part _ _ H7[*] (Part _ _ Hx1[*]Part _ _ H11)). astepr (Part _ _ H7[*] (Part _ _ (ProjT2 Hx1) [*]Part _ _ H11)). elim Hx1; clear Hx1 Hx2; intros Hx1 Hx2. astepr (Part _ _ H7[*] (Part _ _ Hx2[*]Part _ _ H11)). apply eq_transitive_unfolded with (Part _ _ H7[*] (Exp (Part _ _ Hx1) [*]Part _ _ H11)). 2: simpl in |- *; algebra. clear Hx2. apply eq_transitive_unfolded with (Part _ _ H7[*] (Exp (Part _ _ (ProjIR1 Hx1) [*]Part _ _ (ProjIR2 Hx1)) [*]Part _ _ H11)). 2: apply mult_wdr; algebra. elim Hx1; clear Hx1; intros Hx1 Hx2. apply eq_transitive_unfolded with (Part _ _ H7[*] (Exp (Part _ _ Hx1[*]Part _ _ Hx2) [*]Part _ _ H11)). 2: apply mult_wdr; algebra. apply eq_transitive_unfolded with (Part _ _ H7[*] (Exp ((Part _ _ H7[-][1]) [*]Log _ H9) [*]Part _ _ H11)). 2: unfold Log in |- *; simpl in |- *. 2: apply mult_wdr; apply mult_wd; algebra. clear Hx1 Hx2. rstepl ((Exp (Part _ _ H7[*]Log _ H9) [/] _[//]H10) [*] (Part _ _ H7[*]Part _ _ H11)). rstepr (Exp ((Part _ _ H7[-][1]) [*]Log _ H9) [*] (Part _ _ H7[*]Part _ _ H11)). apply mult_wdl. apply eq_transitive_unfolded with (Exp (Part _ _ H7[*]Log _ H9[-]Log _ H9)). 2: apply Exp_wd; rational. astepr (Exp (G x H7[*]Log _ H9) [/] _[//]Exp_ap_zero (Log _ H9)). algebra. Transparent Logarithm. astepr (Part _ _ Hx16); auto. Opaque Logarithm. apply Derivative_comp with realline I; Deriv. apply Continuous_imp_maps_compacts_into. apply Continuous_mult. apply Derivative_imp_Continuous with pJ G'; auto. apply Continuous_comp with (openl [0]). apply maps_compacts_into_strict_imp_weak; apply positive_imp_maps_compacts_into; auto. apply Derivative_imp_Continuous with pJ F'; auto. apply Derivative_imp_Continuous with pJ F'; auto. apply Continuous_Log. apply Derivative_mult. auto. apply Derivative_comp with (openl [0]) I; Deriv. apply positive_imp_maps_compacts_into; auto. apply Derivative_imp_Continuous with pJ F'; auto. Qed. Lemma Diffble_power : forall (J : interval) pJ F G, positive_fun J F -> Diffble J pJ F -> Diffble J pJ G -> Diffble J pJ (F{!}G). Proof. intros J pJ F G H H0 H1. set (F1 := Deriv _ _ _ H0) in *. set (G1 := Deriv _ _ _ H1) in *. eapply Derivative_imp_Diffble. apply Derivative_power with (F' := F1) (G' := G1). auto. unfold F1 in |- *; apply Deriv_lemma. unfold G1 in |- *; apply Deriv_lemma. Qed. End More_on_Power_Function. #[global] Hint Resolve Derivative_power: derivate. corn-8.20.0/transc/SinCos.v000066400000000000000000000252251473720167500154430ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.Trigonometric. Section Sum_and_so_on. Opaque Sine Cosine. (* begin hide *) Let F (y : IR) := Sine[o]FId{+} [-C-]y. Let G (y : IR) := Sine{*}[-C-] (Cos y) {+}Cosine{*}[-C-] (Sin y). Let F' (y : IR) := (fix funct (n : nat) : PartIR := match n with | O => Sine[o]FId{+}[-C-]y | S O => Cosine[o]FId{+}[-C-]y | S (S O) => {--} (Sine[o]FId{+}[-C-]y) | S (S (S O)) => {--} (Cosine[o]FId{+}[-C-]y) | S (S (S (S p))) => funct p end). Let G' (y : IR) := (fix funct (n : nat) : PartIR := match n with | O => Sine{*}[-C-] (Cos y) {+}Cosine{*}[-C-] (Sin y) | S O => Cosine{*}[-C-] (Cos y) {-}Sine{*}[-C-] (Sin y) | S (S O) => {--} (Sine{*}[-C-] (Cos y) {+}Cosine{*}[-C-] (Sin y)) | S (S (S O)) => Sine{*}[-C-] (Sin y) {-}Cosine{*}[-C-] (Cos y) | S (S (S (S p))) => funct p end). (* end hide *) Lemma Sin_plus : forall x y : IR, Sin (x[+]y) [=] Sin x[*]Cos y[+]Cos x[*]Sin y. Proof. intros. cut (Feq realline (F y) (G y)). intro H. cut (Dom (F y) x). intro H0. cut (Dom (G y) x). intro H1. cut (Part _ _ H0 [=] Part _ _ H1). intro H2. simpl in H2. simpl in |- *. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply H2. algebra. algebra. apply Feq_imp_eq with (fun x : IR => True); auto. repeat split. now exists (I, I). unfold F, G in |- *; apply Sin_plus_fun. Qed. Lemma Cos_plus : forall x y : IR, Cos (x[+]y) [=] Cos x[*]Cos y[-]Sin x[*]Sin y. Proof. intros. elim (Cos_plus_fun y). intros. elim b; intros H H0. cut (Dom (Cosine[o]FId{+}[-C-]y) x). intro H1. cut (Dom (Cosine{*}[-C-] (Cos y) {-}Sine{*}[-C-] (Sin y)) x). intro H2. simpl in H0. simpl in |- *. eapply eq_transitive_unfolded. eapply eq_transitive_unfolded. 2: apply (H0 x I H1 H2). algebra. algebra. repeat split. now exists (I, I). Qed. Opaque Sine Cosine. Hint Resolve Cos_plus Sin_plus: algebra. (** As a corollary we get the rule for the tangent of the sum. *) Lemma Tan_plus : forall x y Hx Hy Hxy H, Tan (x[+]y) Hxy [=] (Tan x Hx[+]Tan y Hy[/] [1][-]Tan x Hx[*]Tan y Hy[//]H). Proof. intros. cut (Cos (x[+]y) [#] [0]). cut (Cos y [#] [0]). cut (Cos x [#] [0]). intros H0 H1 H2. apply eq_transitive_unfolded with (Sin (x[+]y) [/] _[//]H2). unfold Tan in |- *; simpl in |- *; algebra. rstepr ((Tan x Hx[+]Tan y Hy) [*]Cos x[*]Cos y[/] _[//] mult_resp_ap_zero _ _ _ H (mult_resp_ap_zero _ _ _ H0 H1)). apply div_wd. astepl (Sin x[*]Cos y[+]Cos x[*]Sin y). unfold Tan, Tang in |- *; simpl in |- *. unfold Sin, Cos in |- *; rational. astepl (Cos x[*]Cos y[-]Sin x[*]Sin y). unfold Tan, Tang in |- *; simpl in |- *; rational. inversion_clear Hx. inversion_clear X0. simpl in |- *; auto. inversion_clear Hy. inversion_clear X0. simpl in |- *; auto. inversion_clear Hxy. inversion_clear X0. simpl in |- *; auto. Qed. Transparent Sine Cosine. (** Sine, cosine and tangent of [[--]x]. *) Lemma Cos_inv : forall x : IR, Cos [--]x [=] Cos x. Proof. intros. simpl in |- *. apply series_sum_wd. intro. unfold cos_seq in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. 2: rational. apply mult_wdr. astepl (( [--]x[-][0]) [^]n); astepr ((x[-][0]) [^]n). rewrite a. eapply eq_transitive_unfolded. 2: apply inv_nexp_even; apply even_plus_n_n. apply nexp_wd; rational. Qed. Lemma Sin_inv : forall x : IR, Sin [--]x [=] [--] (Sin x). Proof. intros. simpl in |- *. assert (H : forall (x : nat -> IR) (convX : convergent x), series_sum _ (conv_series_inv _ convX) [=] [--] (series_sum x convX)). intros; apply series_sum_inv. eapply eq_transitive_unfolded. 2: apply H. apply series_sum_wd. intro. unfold sin_seq in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. rational. apply eq_transitive_unfolded with ( [--][1][^]x0[*] ( [--]x[-][0]) [^]n[/] _[//]nring_fac_ap_zero IR n). simpl in |- *; rational. apply eq_transitive_unfolded with ( [--][1][^]x0[*][--] ((x[-][0]) [^]n) [/] _[//]nring_fac_ap_zero IR n). 2: simpl in |- *; rational. apply div_wd. 2: algebra. apply mult_wdr. rewrite b. eapply eq_transitive_unfolded. 2: apply inv_nexp_odd; apply Nat.Odd_succ; apply even_plus_n_n. apply nexp_wd; rational. Qed. Opaque Sine Cosine. Hint Resolve Cos_inv Sin_inv: algebra. Lemma Tan_inv : forall x Hx Hx', Tan [--]x Hx' [=] [--] (Tan x Hx). Proof. intros; unfold Tan, Tang in |- *. cut (Cos x [#] [0]). cut (Cos [--]x [#] [0]). intros H H0. apply eq_transitive_unfolded with (Sin [--]x[/] _[//]H). simpl in |- *; algebra. astepl ( [--] (Sin x) [/] _[//]H0). rstepl ( [--] (Sin x[/] _[//]H0)). simpl in |- *; algebra. inversion_clear Hx'. inversion_clear X0. simpl in |- *; auto. inversion_clear Hx. inversion_clear X0. simpl in |- *; auto. Qed. Transparent Sine Cosine. (** The fundamental formulas of trigonometry: $\cos(x)^2+\sin(x)^2=1$#cos(x)2+sin(x)2=1# and, equivalently, $1+\tan(x)^2=\frac1{\cos(x)^2}$#1+tan(x)2=1/(cos(x)2)#. *) Hint Resolve Cos_zero: algebra. Theorem FFT : forall x : IR, Cos x[^]2[+]Sin x[^]2 [=] [1]. Proof. intros. astepl (Cos x[*]Cos x[+]Sin x[*]Sin x). astepr (Cos [0]). apply eq_transitive_unfolded with (Cos (x[+][--]x)). 2: algebra. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. apply Cos_plus. unfold cg_minus in |- *. apply bin_op_wd_unfolded. algebra. astepl (Sin x[*][--] (Sin [--]x)). Step_final (Sin x[*][--][--] (Sin x)). Qed. Opaque Sine Cosine. Hint Resolve FFT: algebra. Lemma FFT' : forall x Hx H, [1][+]Tan x Hx[^]2 [=] ([1][/] Cos x[^]2[//]H). Proof. intros. unfold Tan, Tang in |- *. apply eq_transitive_unfolded with ([1][+] (Sin x[^]2[/] _[//]H)). simpl in |- *; rational. astepr (Cos x[^]2[+]Sin x[^]2[/] _[//]H). rational. Qed. End Sum_and_so_on. #[global] Hint Resolve Derivative_Sin Derivative_Cos: derivate. #[global] Hint Resolve Continuous_Sin Continuous_Cos: continuous. #[global] Hint Resolve Sin_zero Cos_zero Tan_zero Sin_plus Cos_plus Tan_plus Sin_inv Cos_inv Tan_inv FFT FFT': algebra. Opaque Min Sine Cosine. Section Basic_Properties. (** ** Basic properties We now prove most of the usual trigonometric (in)equalities. Sine, cosine and tangent are strongly extensional and well defined. *) Lemma Sin_strext : forall x y : IR, Sin x [#] Sin y -> x [#] y. Proof. intros x y H. unfold Sin in H; exact (un_op_strext_unfolded _ _ _ _ H). Qed. Lemma Cos_strext : forall x y : IR, Cos x [#] Cos y -> x [#] y. Proof. intros x y H. unfold Cos in H; exact (un_op_strext_unfolded _ _ _ _ H). Qed. Lemma Tan_strext : forall x y Hx Hy, Tan x Hx [#] Tan y Hy -> x [#] y. Proof. intros x y Hx Hy H. unfold Tan in H; exact (pfstrx _ _ _ _ _ _ H). Qed. Lemma Sin_wd : forall x y : IR, x [=] y -> Sin x [=] Sin y. Proof. intros; algebra. Qed. Lemma Cos_wd : forall x y : IR, x [=] y -> Cos x [=] Cos y. Proof. intros; algebra. Qed. Lemma Tan_wd : forall x y Hx Hy, x [=] y -> Tan x Hx [=] Tan y Hy. Proof. intros; unfold Tan in |- *; algebra. Qed. Lemma Tan_Sin_over_Cos : forall x Hx H, Tan x Hx[=](Sin x[/]Cos x[//]H). Proof. intros x Hx H. change ((Sine x (prj1 IR _ _ _ Hx)[/] Cosine x (ProjT1 (ext2_a IR (Dom Cosine) (fun (x0 : IR) (Hx0 : Dom Cosine x0) => Cosine x0 Hx0[#][0]) x (prj2 IR _ _ _ Hx)))[//] ext2 (S:=IR) (P:=Dom Cosine) (R:=fun (x0 : IR) (Hx0 : Dom Cosine x0) => Cosine x0 Hx0[#][0]) (x:=x) (prj2 _ _ _ _ Hx))[=](Sine x I[/]Cosine x I[//]H)). algebra. Qed. (** The sine and cosine produce values in [[-1,1]]. *) Lemma AbsIR_Sin_leEq_One : forall x : IR, AbsIR (Sin x) [<=] [1]. Proof. intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_sqrt_sqr with (x2pos := sqr_nonneg _ (Sin x)). apply power_cancel_leEq with 2. auto with arith. apply less_leEq; apply pos_one. astepl (Sin x[^]2). astepr OneR. eapply leEq_wdr. 2: apply FFT with (x := x). apply shift_leEq_plus. astepl ZeroR. apply sqr_nonneg. Qed. Lemma AbsIR_Cos_leEq_One : forall x : IR, AbsIR (Cos x) [<=] [1]. Proof. intros. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_sqrt_sqr with (x2pos := sqr_nonneg _ (Cos x)). apply power_cancel_leEq with 2. auto with arith. apply less_leEq; apply pos_one. astepl (Cos x[^]2). astepr OneR. eapply leEq_wdr. 2: apply FFT with (x := x). apply shift_leEq_plus'. astepl ZeroR. apply sqr_nonneg. Qed. Lemma Sin_leEq_One : forall x : IR, Sin x [<=] [1]. Proof. intro. eapply leEq_transitive. apply leEq_AbsIR. apply AbsIR_Sin_leEq_One. Qed. Lemma Cos_leEq_One : forall x : IR, Cos x [<=] [1]. Proof. intro. eapply leEq_transitive. apply leEq_AbsIR. apply AbsIR_Cos_leEq_One. Qed. (** If the cosine is positive then the sine is in [(-1,1)]. *) Lemma Sin_less_One : forall x : IR, [0] [<] Cos x -> Sin x [<] [1]. Proof. intros. apply power_cancel_less with 2. auto. apply less_leEq; apply pos_one. astepr OneR. eapply less_wdr. 2: apply (FFT x). apply shift_less_plus. astepl ZeroR. apply pos_square; apply Greater_imp_ap; auto. Qed. Lemma AbsIR_Sin_less_One : forall x : IR, [0] [<] Cos x -> AbsIR (Sin x) [<] [1]. Proof. intros. apply power_cancel_less with 2. auto. apply less_leEq; apply pos_one. astepr OneR. eapply less_wdr. 2: apply (FFT x). apply shift_less_plus. apply less_wdl with ZeroR. apply pos_square; apply Greater_imp_ap; auto. apply eq_symmetric_unfolded; apply x_minus_x. eapply eq_transitive_unfolded. 2: apply AbsIR_eq_x. 2: apply sqr_nonneg. apply eq_symmetric_unfolded; apply AbsIR_nexp_op. Qed. End Basic_Properties. #[global] Hint Resolve Sin_wd Cos_wd Tan_wd: algebra. corn-8.20.0/transc/TaylorSeries.v000066400000000000000000000541231473720167500166710ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.PowerSeries. Require Export CoRN.ftc.Taylor. (** * Taylor Series We now generalize our work on Taylor's theorem to define the Taylor series of an infinitely many times differentiable function as a power series. We prove convergence (always) of the Taylor series and give criteria for when the sum of this series is the original function. ** Definitions %\begin{convention}% Let [J] be a proper interval and [F] an infinitely many times differentiable function in [J]. Let [a] be a point of [J]. %\end{convention}% *) Section Definitions. Variable J : interval. Hypothesis pJ : proper J. Variable F : PartIR. Hypothesis diffF : forall n : nat, Diffble_n n J pJ F. Variable a : IR. Hypothesis Ha : J a. Definition Taylor_Series' := FPowerSeries' a (fun n : nat => N_Deriv _ _ _ _ (diffF n) a Ha). (** %\begin{convention}% Assume also that [f] is the sequence of derivatives of [F]. %\end{convention}% *) Variable f : nat -> PartIR. Hypothesis derF : forall n, Derivative_n n J pJ F (f n). Definition Taylor_Series := FPowerSeries' a (fun n => f n a (Derivative_n_imp_inc' _ _ _ _ _ (derF n) _ Ha)). Opaque N_Deriv. (** Characterizations of the Taylor remainder. *) Lemma Taylor_Rem_char : forall n H x Hx Hx' Hx'', F x Hx[-]FSum0 (S n) Taylor_Series x Hx' [=] Taylor_Rem J pJ F a x Ha Hx'' n H. Proof. intros; unfold Taylor_Rem in |- *; repeat apply cg_minus_wd. algebra. simpl in |- *. apply bin_op_wd_unfolded. 2: apply mult_wdl. apply eq_symmetric_unfolded. cut (ext_fun_seq' (fun (i : nat) (l : i < n) => [-C-] (N_Deriv _ _ _ _ (le_imp_Diffble_n _ _ _ _ (proj1 (Nat.lt_succ_r _ _) (Nat.lt_lt_succ_r _ _ l)) _ H) a Ha[/] _[//]nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i)). intro H0. apply eq_transitive_unfolded with (Sumx (fun (i : nat) (Hi : i < n) => Part ( [-C-] (N_Deriv _ _ _ _ (le_imp_Diffble_n _ _ _ _ (proj1 (Nat.lt_succ_r _ _) (Nat.lt_lt_succ_r _ _ Hi)) _ H) a Ha[/] _[//]nring_fac_ap_zero _ i) {*} (FId{-} [-C-]a) {^}i) x (FSumx_pred _ _ H0 _ (ProjIR1 (TaylorB _ _ _ a x Ha _ H)) i Hi))). exact (FSumx_char _ _ _ _ H0). apply Sumx_Sum0. intros; simpl in |- *. apply mult_wdl; apply div_wd. 2: algebra. apply Feq_imp_eq with J; auto. apply Derivative_n_unique with pJ i F; auto. apply N_Deriv_lemma. red in |- *; do 3 intro. rewrite H0; intros; simpl in |- *; auto. apply div_wd. 2: algebra. apply Feq_imp_eq with J; auto. apply Derivative_n_unique with pJ n F; auto. Deriv. Qed. Lemma abs_Taylor_Rem_char : forall n H x Hx Hx' Hx'', AbsIR (F x Hx[-]FSum0 (S n) Taylor_Series x Hx') [=] AbsIR (Taylor_Rem J pJ F a x Ha Hx'' n H). Proof. intros; apply AbsIR_wd; apply Taylor_Rem_char. Qed. End Definitions. Section Convergence_in_IR. (** ** Convergence Our interval is now the real line. We begin by proving some helpful continuity properties, then define a boundedness condition for the derivatives of [F] that guarantees convergence of its Taylor series to [F]. *) Hypothesis H : proper realline. Variable F : PartIR. Variable a : IR. Hypothesis Ha : realline a. Variable f : nat -> PartIR. Hypothesis derF : forall n, Derivative_n n realline H F (f n). Lemma Taylor_Series_imp_cont : Continuous realline F. Proof. apply Derivative_n_imp_Continuous with H 1 (f 1); auto. Qed. Lemma Taylor_Series_lemma_cont : forall r n, Continuous realline ((r[^]n[/] _[//]nring_fac_ap_zero _ n) {**}f n). Proof. intros. apply Continuous_scal; case n. apply Continuous_wd with F. apply Derivative_n_unique with H 0 F; auto. apply Derivative_n_O. apply Derivative_n_imp_inc with H n (f n); auto. apply Taylor_Series_imp_cont. clear n; intros. apply Derivative_n_imp_Continuous' with H (S n) F; auto with arith. Qed. Definition Taylor_bnd := forall r H, conv_fun_seq'_IR realline (fun n => (r[^]n[/] _[//]nring_fac_ap_zero _ n) {**}f n) _ H (Continuous_const _ [0]). (* begin show *) Hypothesis bndf : Taylor_bnd. (* end show *) Opaque nexp_op fact. (* begin hide *) Let H1 : forall n, Two[^]n [#] ZeroR. Proof. intro; apply nexp_resp_ap_zero; apply two_ap_zero. Qed. Lemma Taylor_Series_conv_lemma1 : forall t x y Hxy (e : IR) (He : [0] [<] e), {N : nat | forall n : nat, N <= n -> forall w z : IR, compact x y Hxy z -> Compact (Min_leEq_Max' x y t) w -> forall Hw Hz, AbsIR (((Part _ _ (Derivative_n_imp_inc' _ _ _ _ _ (derF (S n)) w Hw) [/] _[//] nring_fac_ap_zero _ (S n)) {**} ((FId{-} [-C-]w) {^}n{*} (FId{-} [-C-]a))) z Hz) [<=] (e[/] _[//]H1 (S n))}. Proof. intros. set (r := Max y (Max a t) [-]Min x (Min a t)) in *. cut (Min x (Min a t) [<=] Max y (Max a t)). intro Hxy'; cut (included (Compact (Min_leEq_Max' x y t)) (Compact Hxy')). intro Hinc'. cut (forall w z : IR, Compact Hxy z -> Compact Hxy' w -> AbsIR (z[+][--]w) [<=] r). intro. 2: intros w z H0 H2; fold (z[-]w) in |- *; unfold r in |- *. set (r' := Two[*]Max r [1]) in *. set (H' := Taylor_Series_lemma_cont r') in *. elim (bndf r' H' _ _ (Min_leEq_Max' x y t) (included_interval' realline _ _ _ _ I I I I _) e He); intros N HN. exists N. intros n H2 w z H3 H4 Hw Hz. simpl in |- *; fold (Two:IR) in |- *. assert (H5 : forall n : nat, [0] [<] r'[^]n). intro; unfold r' in |- *; apply nexp_resp_pos; unfold r' in |- *; apply mult_resp_pos; [ apply pos_two | apply pos_max_one ]. apply leEq_transitive with ((e[/] _[//]pos_ap_zero _ _ (H5 (S n))) [*] AbsIR ((z[+][--]w) [^]n[*] (z[+][--]a))). eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_rht. 2: apply AbsIR_nonneg. apply shift_leEq_div. auto. clear Hz H3 z. eapply leEq_transitive. 2: apply (HN (S n) (le_S _ _ H2) w H4). simpl in |- *. cut (forall z : IR, AbsIR z [=] AbsIR (z[-][0])); intros. 2: apply AbsIR_wd; algebra. eapply leEq_wdr. 2: apply H3. clear H3; eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_mult_pos'. eapply leEq_wdr. 2: apply mult_commutes. cut (forall z : IR, AbsIR (z[/] _[//]nring_fac_ap_zero _ (S n)) [*]r'[^]S n [=] AbsIR z[*] (r'[^]S n[/] _[//]nring_fac_ap_zero _ (S n))); intros. eapply leEq_wdr. 2: apply H3. clear H3; apply mult_resp_leEq_rht. apply eq_imp_leEq; apply AbsIR_wd; algebra. apply less_leEq; auto. rstepr ((AbsIR z[/] _[//]nring_fac_ap_zero _ (S n)) [*]r'[^]S n). apply mult_wdl. eapply eq_transitive_unfolded. apply AbsIR_division with (y__ := AbsIR_resp_ap_zero _ (nring_fac_ap_zero _ (S n))). apply div_wd. algebra. apply AbsIR_eq_x. apply nring_nonneg. apply less_leEq; apply div_resp_pos; [ apply pos_nring_fac | auto ]. Transparent nexp_op. apply shift_leEq_div. apply nexp_resp_pos; apply pos_two. unfold r' in |- *. apply leEq_wdl with (e[*] (AbsIR ((z[+][--]w) [^]n[*] (z[+][--]a)) [/] _[//] nexp_resp_ap_zero (S n) (max_one_ap_zero r))). astepr (e[*][1]). apply mult_resp_leEq_lft. 2: apply less_leEq; auto. apply shift_div_leEq. apply nexp_resp_pos; apply pos_max_one. astepr (Max r [1][^]S n). eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. astepr (Max r [1][^]n[*]Max r [1]). apply mult_resp_leEq_both; try apply AbsIR_nonneg. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_nexp_op. apply nexp_resp_leEq. apply AbsIR_nonneg. apply leEq_transitive with r; auto. apply lft_leEq_Max. apply leEq_transitive with r. apply H0; auto. split. eapply leEq_transitive. apply Min_leEq_rht. apply Min_leEq_lft. eapply leEq_transitive. 2: apply rht_leEq_Max. apply lft_leEq_Max. apply lft_leEq_Max. rstepl ((e[/] _[//] mult_resp_ap_zero _ _ _ (nexp_resp_ap_zero (S n) (max_one_ap_zero r)) (H1 (S n))) [*]AbsIR ((z[+][--]w) [^]n[*] (z[+][--]a)) [*] Two[^]S n). repeat apply mult_wdl. apply div_wd; algebra. eapply eq_transitive_unfolded. 2: apply eq_symmetric_unfolded; apply mult_nexp. algebra. apply leEq_wdr with (AbsIR (Max y (Max a t) [-]Min x (Min a t))). apply compact_elements with Hxy'; auto. inversion_clear H0; split. apply leEq_transitive with x; auto; apply Min_leEq_lft. apply leEq_transitive with y; auto; apply lft_leEq_Max. apply AbsIR_eq_x. apply shift_leEq_minus; astepl (Min x (Min a t)); auto. red in |- *; intros z Hz. inversion_clear Hz; split. eapply leEq_transitive. 2: apply H0. apply leEq_Min. apply Min_leEq_lft. eapply leEq_transitive; apply Min_leEq_rht. eapply leEq_transitive. apply H2. apply Max_leEq. apply lft_leEq_Max. eapply leEq_transitive. 2: apply rht_leEq_Max. apply rht_leEq_Max. apply leEq_transitive with t. eapply leEq_transitive; apply Min_leEq_rht. eapply leEq_transitive. 2: apply rht_leEq_Max. apply rht_leEq_Max. Qed. Lemma Taylor_Series_conv_lemma2 : forall x y Hxy (e : IR) (He : [0] [<] e), {N : nat | forall n : nat, N <= n -> forall z : IR, compact x y Hxy z -> forall Hz, AbsIR (Taylor_Series _ _ _ a Ha _ derF n z Hz) [<=] (e[/] _[//]H1 n)}. Proof. intros. elim Taylor_Series_conv_lemma1 with (t := a) (Hxy := Hxy) (e := e); auto. intros N HN; exists (S N). intros n H0 z H2 Hz. assert (n = S (pred n)). symmetry; apply Nat.lt_succ_pred with N; auto with arith. set (p := pred n) in *. assert (N <= p). unfold p in |- *; apply le_S_n; rewrite Nat.lt_succ_pred with N n; auto with arith. clearbody p; rewrite H3. assert (H5 : forall c d : IR, Dom (c{**} ((FId{-} [-C-]d) {^}p{*} (FId{-} [-C-]a))) z). repeat split. assert (H6 : Compact (Min_leEq_Max' x y a) a). split; [ apply Min_leEq_rht | apply rht_leEq_Max ]. eapply leEq_wdl. apply (HN p H4 a z H2 H6 Ha (H5 (Part _ _ (Derivative_n_imp_inc' _ _ _ _ _ (derF (S p)) a Ha) [/] _[//] nring_fac_ap_zero _ (S p)) a)). apply AbsIR_wd; algebra. Qed. (* end hide *) (** The Taylor series always converges on the realline. *) Lemma Taylor_Series_conv_IR : fun_series_convergent_IR realline (Taylor_Series _ _ _ a Ha _ derF). Proof. red in |- *; intros. unfold Taylor_Series, FPowerSeries' in |- *. apply fun_str_comparison with (fun n : nat => Fconst (S:=IR) (([1] [/]TwoNZ) [^]n)). Contin. apply conv_fun_const_series with (x := fun n : nat => (OneR [/]TwoNZ) [^]n). apply ratio_test_conv. exists 0; exists (OneR [/]TwoNZ); repeat split. apply pos_div_two'; apply pos_one. apply less_leEq; fold (Half:IR) in |- *; apply pos_half. intros; apply eq_imp_leEq. eapply eq_transitive_unfolded. 2: apply mult_commutes. eapply eq_transitive_unfolded. 2: apply AbsIR_mult_pos; apply less_leEq; fold (Half (R:=IR)) in |- *; apply pos_half. Transparent nexp_op. apply AbsIR_wd; simpl in |- *; rational. Opaque nexp_op. elim (Taylor_Series_conv_lemma2 _ _ Hab [1] (pos_one _)); intros N HN; exists N; intros n H0 x X Hx Hx'. eapply leEq_wdr. eapply leEq_wdl. apply (HN _ H0 _ X Hx). apply AbsIR_wd; algebra. simpl in |- *; algebra. Qed. (* begin hide *) Lemma Taylor_majoration_lemma : forall (n : nat) (e : IR), [0] [<] e -> e[*] (nring n[/] _[//]H1 n) [<=] e. Proof. intro; case n. intros; simpl in |- *; rstepl ZeroR; apply less_leEq; auto. clear n; intro; induction n as [| n Hrecn]. intros; simpl in |- *. eapply leEq_wdl. apply less_leEq; apply pos_div_two'; auto. rational. intros e H0. eapply leEq_transitive. 2: apply Hrecn; auto. apply mult_resp_leEq_lft. 2: apply less_leEq; auto. apply shift_div_leEq. repeat apply mult_resp_pos; try apply nexp_resp_pos; apply pos_two. rstepr (nring (S n) [*]Two[^]S (S n) [/] _[//]H1 (S n)). apply shift_leEq_div. apply nexp_resp_pos; apply pos_two. Transparent nexp_op. set (p := S n) in *. cut (p = S n); [ intro | auto ]. clear H0; clearbody p. simpl in |- *; fold (Two:IR) in |- *. rstepl (nring (R:=IR) p[*]nexp _ p Two[+]nring 1[*]nexp _ p Two). rstepr (nring (R:=IR) p[*]nexp _ p Two[+]nring p[*]nexp _ p Two). apply plus_resp_leEq_lft. apply mult_resp_leEq_rht. apply nring_leEq; rewrite H2; auto with arith. astepr ((Two:IR) [^]p); apply nexp_resp_nonneg. apply less_leEq; apply pos_two. Qed. Opaque N_Deriv. Lemma Taylor_Series_conv_lemma3 : forall a' b d c e a'' x : IR, a' [=] a'' -> x [=] b[*]e -> [0] [<=] e -> forall Hb He Hx, (AbsIR (a'[*] ([1][/] b[//]Hb) [*]c[*]d) [/] e[//]He) [=] AbsIR ((a''[/] x[//]Hx) [*] (c[*]d)). Proof. intros. astepr (AbsIR ((a''[/] x[//]Hx) [*]c[*]d)). apply eq_transitive_unfolded with (AbsIR a'[*] ([1][/] _[//]AbsIR_resp_ap_zero _ Hb) [*]AbsIR c[*]AbsIR d[/] e[//]He). apply div_wd; algebra. repeat (eapply eq_transitive_unfolded; [ apply AbsIR_resp_mult | apply mult_wdl ]). eapply eq_transitive_unfolded; [ apply AbsIR_resp_mult | apply mult_wdr ]. apply AbsIR_recip. rstepl ((AbsIR a'[/] _[//]mult_resp_ap_zero _ _ _ (AbsIR_resp_ap_zero _ Hb) He) [*] AbsIR c[*]AbsIR d). apply eq_symmetric_unfolded. repeat (eapply eq_transitive_unfolded; [ apply AbsIR_resp_mult | apply mult_wdl ]). eapply eq_transitive_unfolded; [ apply AbsIR_division with (y__ := AbsIR_resp_ap_zero _ Hx) | apply div_wd; algebra ]. eapply eq_transitive_unfolded. 2: apply AbsIR_mult_pos; auto. algebra. Qed. (* end hide *) (** We now prove that, under our assumptions, it actually converges to the original function. For generality and also usability, however, we will separately assume convergence. *) (* begin show *) Hypothesis Hf : fun_series_convergent_IR realline (Taylor_Series _ _ _ a Ha _ derF). (* end show *) Lemma Taylor_Series_conv_to_fun : Feq realline F (FSeries_Sum Hf). Proof. cut (Continuous realline (FSeries_Sum Hf)). intro H0. cut (forall n : nat, Continuous realline (FSum0 n (Taylor_Series _ _ _ _ Ha _ derF))). intro H2. cut (Continuous realline F). intro H3. eapply FLim_unique_IR with (HG := H0) (HF := H3) (f := fun n : nat => FSum0 n (Taylor_Series _ _ _ _ Ha _ derF)) (contf := H2). 2: apply FSeries_conv. 3: Contin. 2: apply Derivative_imp_Continuous with H (f 1). 2: apply Derivative_n_Sn with F 0. 2: apply Derivative_n_O; eapply Derivative_n_imp_inc; apply (derF 0). 2: auto. 2: unfold Taylor_Series in |- *; Contin. intros a0 b Hab Hinc e H4. set (Hab' := Min_leEq_Max' a0 b a) in *. elim (Taylor_Series_conv_lemma1 a _ _ Hab _ (pos_div_two _ _ H4)); intros N HN. exists (S N); intros p Hp. cut (p = S (pred p)); [ intro Hn | symmetry; apply Nat.lt_succ_pred with N; auto ]. set (n := pred p) in *; clearbody n. generalize Hp; clear Hp; rewrite Hn; clear Hn p. intros. cut ([0] [<] nring (S n) [*]e [/]TwoNZ); [ intro He | apply mult_resp_pos ]. 2: apply pos_nring_S. 2: apply pos_div_two; auto. elim (Taylor' _ _ _ _ _ Ha (Hinc x Hx) n (Derivative_n_imp_Diffble_n _ _ _ _ _ (derF (S n))) (Derivative_n_imp_Diffble_n _ _ _ _ _ (derF n)) _ ( pos_div_two _ _ H4)). intros y H5 H6. set (H7 := pair (I, I) (I, I) :Dom (N_Deriv _ _ _ _ (Derivative_n_imp_Diffble_n _ _ _ _ _ (derF (S n))) {*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]x{-}FId) {^}n) y) in *. eapply leEq_wdl. 2: apply AbsIR_minus. cut (forall z w : IR, AbsIR z [<=] AbsIR (z[-]w) [+]AbsIR w); intros. 2: eapply leEq_wdl. 2: apply triangle_IR. 2: apply AbsIR_wd; rational. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply (abs_Taylor_Rem_char realline H F a Ha f derF n (Derivative_n_imp_Diffble_n _ _ _ _ _ (derF n)) x (contin_imp_inc _ _ _ _ (included_imp_Continuous _ _ H3 _ _ _ Hinc) _ Hx) (contin_imp_inc _ _ _ _ (included_imp_Continuous _ _ (H2 (S n)) _ _ _ Hinc) _ Hx) (Hinc _ Hx)). rstepr (e [/]TwoNZ[+]e [/]TwoNZ). eapply leEq_transitive. apply H8 with (w := Part (N_Deriv _ _ _ _ (Derivative_n_imp_Diffble_n _ _ _ _ _ (derF (S n))) {*} [-C-] ([1][/] _[//]nring_fac_ap_zero _ n) {*} ( [-C-]x{-}FId) {^}n) y H7[*] (x[-]a)). apply plus_resp_leEq_both; auto. eapply leEq_transitive. 2: apply Taylor_majoration_lemma with (n := S n); apply pos_div_two; auto. rstepr (nring (S n) [*] (e [/]TwoNZ[/] _[//]H1 (S n))). apply shift_leEq_mult' with (pos_ap_zero _ _ (pos_nring_S IR n)). apply pos_nring_S. set (H9 := pair I (pair (I, I) (I, I))) in *. eapply leEq_wdl. apply HN with (n := n) (w := y) (z := x) (Hw := I) (Hz := H9); auto with arith. inversion_clear Hx; inversion_clear H5; split. apply leEq_transitive with (Min a x); auto. apply leEq_Min. apply Min_leEq_rht. apply leEq_transitive with a0; auto. apply Min_leEq_lft. apply leEq_transitive with (Max a x); auto. apply Max_leEq. apply rht_leEq_Max. apply leEq_transitive with b; auto. apply lft_leEq_Max. simpl in |- *. unfold Taylor_Rem in |- *; simpl in |- *. clear H8 H6 H4 He Hx Hp HN Hab' H3 H2 H0 bndf. set (fy := Part _ _ (Derivative_n_imp_inc' _ _ _ _ _ (derF (S n)) y I)) in *. set (Fy := Part (N_Deriv _ _ _ _ (Derivative_n_imp_Diffble_n _ _ _ _ _ (derF (S n)))) y (ProjIR1 (ProjIR1 H7))) in *. astepr (AbsIR (Fy[*] ([1][/] _[//]nring_fac_ap_zero _ n) [*] (x[+][--]y) [^]n[*] (x[-]a)) [/] _[//]pos_ap_zero _ _ (pos_nring_S _ n)). unfold cg_minus in |- *. apply eq_symmetric_unfolded; apply Taylor_Series_conv_lemma3. unfold fy, Fy in |- *. apply Feq_imp_eq with realline; auto. apply Derivative_n_unique with H (S n) F; Deriv. eapply eq_transitive_unfolded. 2: apply nring_comm_mult. Transparent fact. replace (fact (S n)) with (fact n * S n). algebra. Opaque mult. unfold fact in |- *; fold (fact n) in |- *. auto with arith. apply nring_nonneg. Qed. End Convergence_in_IR. Section Other_Results. (** The condition for the previous lemma is not very easy to prove. We give some helpful lemmas. *) Lemma Taylor_bnd_trans : forall f g : nat -> PartIR, (forall n x Hx Hx', AbsIR (f n x Hx) [<=] AbsIR (g n x Hx')) -> (forall n, Continuous realline (g n)) -> Taylor_bnd g -> Taylor_bnd f. Proof. intros f g bndf contg Gbnd r H a b Hab Hinc e H0. elim (Gbnd r (fun n : nat => Continuous_scal _ _ (contg n) _) _ _ _ Hinc e H0); intros N HN. exists N; intros. eapply leEq_transitive. 2: apply HN with (n := n) (Hx := Hx); auto. cut (forall (z t : IR) Ht, AbsIR z [=] AbsIR (z[-][-C-][0] t Ht)); intros. 2: simpl in |- *; apply AbsIR_wd; algebra. eapply leEq_wdl. 2: apply H2. eapply leEq_wdr. 2: apply H2. simpl in |- *. eapply leEq_wdl. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply mult_resp_leEq_lft; auto. apply AbsIR_nonneg. Qed. (* begin hide *) Lemma convergence_lemma : forall r : IR, conv_fun_seq'_IR realline (fun n : nat => [-C-] (r[^]n[/] _[//]nring_fac_ap_zero IR n)) [-C-][0] (fun n : nat => Continuous_const realline _) (Continuous_const realline _). Proof. red in |- *; intros. apply seq_conv_imp_fun_conv with (x := fun n : nat => r[^]n[/] _[//]nring_fac_ap_zero _ n). clear Hinc Hab b a. apply series_seq_Lim. assert (H : forall n : nat, Dom (Exp_ps n) r). repeat split. apply convergent_wd with (fun n : nat => Part (Exp_ps n) r (H n)). Opaque nexp_op. intros; simpl in |- *. rstepl ((r[-][0]) [^]n[/] _[//]nring_fac_ap_zero _ n). algebra. apply fun_series_conv_imp_conv_IR with realline. apply Exp_conv. split. Qed. (* end hide *) Lemma bnd_imp_Taylor_bnd : forall (f : nat -> PartIR) (F : PartIR), (forall n x Hx Hx', AbsIR (f n x Hx) [<=] AbsIR (F x Hx')) -> Continuous realline F -> (forall n, included (fun _ => True) (Dom (f n))) -> Taylor_bnd f. Proof. intros f F H H0 H1. apply Taylor_bnd_trans with (fun n : nat => F); auto. red in |- *; intros. unfold Fscalmult in |- *. apply conv_fun_seq'_wdr'_IR with (contF := Continuous_mult _ _ _ (Continuous_const _ [0]) H0). FEQ. apply fun_Lim_seq_mult'_IR with (f := fun n : nat => [-C-] (r[^]n[/] _[//]nring_fac_ap_zero _ n)) (contf := fun n : nat => Continuous_const realline (r[^]n[/] _[//]nring_fac_ap_zero _ n)) (g := fun n : nat => F) (contg := fun n : nat => H0) (contF := Continuous_const realline [0]) (contG := H0). apply convergence_lemma. apply fun_Lim_seq_const_IR. Qed. (** Finally, a uniqueness criterium: two functions [F] and [G] are equal, provided that their derivatives coincide at a given point and their Taylor series converge to themselves. *) Variables F G : PartIR. Variable a : IR. Variables f g : nat -> PartIR. Hypothesis derF : forall n, Derivative_n n realline I F (f n). Hypothesis derG : forall n, Derivative_n n realline I G (g n). Hypothesis bndf : Taylor_bnd f. Hypothesis bndg : Taylor_bnd g. (* begin show *) Hypothesis Heq : forall n HaF HaG, f n a HaF [=] g n a HaG. (* end show *) (* begin hide *) Let Hf := Taylor_Series_conv_IR I F a I f derF bndf. (* end hide *) Lemma Taylor_unique_crit : Feq realline F (FSeries_Sum Hf) -> Feq realline F G. Proof. intro H. cut (fun_series_convergent_IR realline (Taylor_Series realline I G a I g derG)). intro Hg. apply Feq_transitive with (FSeries_Sum Hf); auto. apply Feq_transitive with (FSeries_Sum Hg). apply eq_imp_Feq; simpl in |- *; Included. intros; apply series_sum_wd. intros; algebra. apply Feq_symmetric; apply Taylor_Series_conv_to_fun; auto. apply Taylor_Series_conv_IR; auto. Qed. End Other_Results. corn-8.20.0/transc/TrigMon.v000066400000000000000000000623111473720167500156210ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.Pi. Require Import CoRN.tactics.CornTac. Opaque Sine Cosine. (** Sign properties: cosine is positive in $(-\frac{\pi}2,\frac{\pi}2)$#(-π/2,π/2)#, sine in $(0,\pi)$#(0,π)# and tangent in $(0,\frac{\pi}2)$#0,π/2)#. *) Lemma Cos_pos : forall x, [--] (Pi [/]TwoNZ) [<] x -> x [<] Pi [/]TwoNZ -> [0] [<] Cos x. Proof. intros x H H0. assert (H1 : Continuous_I (less_leEq _ _ _ (less_transitive_unfolded _ _ _ _ H H0)) Cosine). apply included_imp_Continuous with realline; Contin. elim (contin_prop _ _ _ _ H1 Half (pos_half _)); intros d H2 H3. elim (less_cotransitive_unfolded _ _ _ H2 x); intros. apply pos_cos; try apply less_leEq; auto. assert (H4 : [--]d [<] [0]). astepr ( [--]ZeroR); apply inv_resp_less; auto. elim (less_cotransitive_unfolded _ _ _ H4 x); intros. 2: astepr (Cos [--]x); apply pos_cos. 2: astepl ( [--]ZeroR); apply inv_resp_leEq; apply less_leEq; auto. 2: apply inv_cancel_less; astepr x; auto. clear H4 H2 H1. astepl (OneR[-][1]). apply shift_minus_less; apply shift_less_plus'. apply leEq_less_trans with (Half:IR). 2: apply half_lt1. astepl (Cos [0][-]Cos x). eapply leEq_transitive. apply leEq_AbsIR. simpl in |- *; apply H3. split; PiSolve. split; apply less_leEq; auto. apply less_leEq; simpl in |- *; unfold ABSIR in |- *. apply Max_less. apply shift_minus_less; apply shift_less_plus'. astepl ( [--]d); auto. rstepl x; auto. Qed. Lemma Sin_pos : forall x : IR, [0] [<] x -> x [<] Pi -> [0] [<] Sin x. Proof. intros. astepr (Cos (Pi [/]TwoNZ[-]x)). apply Cos_pos. apply shift_less_minus; apply shift_plus_less'. unfold cg_minus in |- *; rstepr Pi; auto. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; auto. Qed. Lemma Tan_pos : forall x, [0] [<] x -> x [<] Pi [/]TwoNZ -> forall Hx, [0] [<] Tan x Hx. Proof. intros. unfold Tan, Tang in |- *; simpl in |- *. apply shift_less_div. apply less_wdr with (Cos x). apply Cos_pos; auto. apply less_transitive_unfolded with ZeroR; PiSolve. simpl in |- *; algebra. astepl ZeroR; apply less_wdr with (Sin x). apply Sin_pos; auto. apply less_transitive_unfolded with (Pi [/]TwoNZ); PiSolve. simpl in |- *; algebra. Qed. Lemma Cos_nonneg : forall x, [--] (Pi [/]TwoNZ) [<=] x -> x [<=] Pi [/]TwoNZ -> [0] [<=] Cos x. Proof. simpl in |- *. intros; apply olor_pos_clcr_nonneg with ( [--] (Pi [/]TwoNZ)) (Pi [/]TwoNZ) I I. PiSolve. intros x0 H1 Hx; inversion_clear H1. apply less_wdr with (Cos x0); [ apply Cos_pos; auto | simpl in |- *; algebra ]. astepr (Cos [--] (Pi [/]TwoNZ)); apply eq_imp_leEq; Step_final (Cos (Pi [/]TwoNZ)). fold (Cos (Pi [/]TwoNZ)) in |- *; apply eq_imp_leEq; algebra. split; auto. Qed. Lemma Sin_nonneg : forall x, [0] [<=] x -> x [<=] Pi -> [0] [<=] Sin x. Proof. simpl in |- *. intros; apply olor_pos_clcr_nonneg with ZeroR Pi I I. PiSolve. intros x0 H1 Hx; inversion_clear H1. apply less_wdr with (Sin x0); [ apply Sin_pos; auto | simpl in |- *; algebra ]. fold (Sin [0]) in |- *; apply eq_imp_leEq; algebra. fold (Sin Pi) in |- *; apply eq_imp_leEq; algebra. split; auto. Qed. (** Consequences. *) Lemma Abs_Sin_less_One : forall x, [--] (Pi [/]TwoNZ) [<] x -> x [<] Pi [/]TwoNZ -> AbsIR (Sin x) [<] [1]. Proof. intros. apply power_cancel_less with 2. apply less_leEq; apply pos_one. astepr OneR. astepr (Cos x[^]2[+]Sin x[^]2). apply less_wdl with (Sin x[^]2). astepl ([0][+]Sin x[^]2). apply plus_resp_less_rht. apply pos_square. apply Greater_imp_ap; apply Cos_pos; auto. apply eq_symmetric_unfolded. eapply eq_transitive_unfolded. 2: apply AbsIR_eq_x; apply sqr_nonneg. apply eq_symmetric_unfolded; apply AbsIR_nexp_op. Qed. Lemma Abs_Cos_less_One : forall x, [0] [<] x -> x [<] Pi -> AbsIR (Cos x) [<] [1]. Proof. intros. astepl (AbsIR (Sin (Pi [/]TwoNZ[-]x))). apply Abs_Sin_less_One. apply shift_less_minus; apply shift_plus_less'. unfold cg_minus in |- *; rstepr Pi; auto. apply shift_minus_less; apply shift_less_plus'. astepl ZeroR; auto. Qed. (** Sine is (strictly) increasing in [[ [--]Pi[/]Two,Pi[/]Two]]; cosine is (strictly) decreasing in [[[0],Pi]]. *) Lemma Sin_resp_leEq : forall x y, [--] (Pi [/]TwoNZ) [<=] x -> y [<=] Pi [/]TwoNZ -> x [<=] y -> Sin x [<=] Sin y. Proof. intros; simpl in |- *. cut ( [--] (Pi [/]TwoNZ) [<] Pi [/]TwoNZ). intro H2. apply Derivative_imp_resp_leEq with (clcr [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) H2 Cosine; auto. apply Included_imp_Derivative with realline I; Deriv. split; auto; apply leEq_transitive with y; auto. split; auto; apply leEq_transitive with x; auto. intros. apply leEq_glb. intros y0 H3 Hy. apply leEq_wdr with (Cos y0). inversion_clear H3. apply Cos_nonneg. apply leEq_transitive with (Min y x); try apply leEq_Min; auto; apply leEq_transitive with x; auto. apply leEq_transitive with (Max y x); try apply Max_leEq; auto; apply leEq_transitive with y; auto. simpl in |- *; algebra. PiSolve. Qed. Lemma Cos_resp_leEq : forall x y, [0] [<=] x -> y [<=] Pi -> x [<=] y -> Cos y [<=] Cos x. Proof. intros. astepl (Sin (Pi [/]TwoNZ[-]y)); astepr (Sin (Pi [/]TwoNZ[-]x)). apply Sin_resp_leEq. apply shift_leEq_minus; apply shift_plus_leEq'. unfold cg_minus in |- *; rstepr Pi; auto. apply shift_minus_leEq; apply shift_leEq_plus'. astepl ZeroR; auto. apply minus_resp_leEq_both. apply leEq_reflexive. auto. Qed. (* begin hide *) Lemma Cos_resp_less_aux : forall x y : IR, [0] [<] x -> x [<] y -> y [<=] Pi [/]TwoNZ -> Cos y [<] Cos x. Proof. intros x y H H0 H1. astepl (Cos y[+][0]). apply shift_plus_less'. assert (H2 : Continuous_I (less_leEq _ _ _ H0) Sine). apply included_imp_Continuous with realline; Contin. assert (H3 : Continuous_I (Min_leEq_Max x y) Sine). apply included_imp_Continuous with realline; Contin. assert (H4 : Continuous_I (Min_leEq_Max y x) Sine). apply included_imp_Continuous with realline; Contin. assert (H5 : Continuous_I (Min_leEq_Max y x) {--}Sine). apply included_imp_Continuous with realline; Contin. apply less_leEq_trans with (Sin x[*] (y[-]x)). apply mult_resp_pos. apply Sin_pos; auto. apply less_transitive_unfolded with (Pi [/]TwoNZ). apply less_leEq_trans with y; auto. PiSolve. apply shift_less_minus; astepl x; auto. apply leEq_wdr with (Integral H3). eapply leEq_wdr. 2: apply eq_symmetric_unfolded; apply (Integral_integral _ _ _ _ H3 _ H2). apply lb_integral. intros z H6 Hx. apply leEq_wdr with (Sin z). 2: simpl in |- *; algebra. cut ( [--] (Pi [/]TwoNZ) [<=] x); intros. inversion_clear H6; apply Sin_resp_leEq; auto. apply leEq_transitive with y; auto. apply leEq_transitive with ZeroR; PiSolve. astepl ( [--][--] (Integral H3)). apply eq_transitive_unfolded with ( [--] (Integral H4)). apply un_op_wd_unfolded; apply eq_symmetric_unfolded; apply Integral_op. apply eq_transitive_unfolded with (Integral H5). apply eq_symmetric_unfolded; apply Integral_inv. assert (H6 : Derivative realline I Cosine {--}Sine). Deriv. eapply eq_transitive_unfolded. apply Barrow with (derG0 := H6) (Ha := I) (Hb := I) (pJ := I); Contin; split. simpl in |- *; algebra. Qed. Lemma Cos_resp_less_aux' : forall x y : IR, [0] [<=] x -> x [<] y -> y [<=] Pi [/]TwoNZ -> Cos y [<] Cos x. Proof. intros. apply less_leEq_trans with (Cos ((x[+]y) [/]TwoNZ)). apply Cos_resp_less_aux; auto. apply pos_div_two; astepl (ZeroR[+][0]); apply plus_resp_leEq_less; try apply leEq_less_trans with x; auto. apply shift_div_less; [ apply pos_two | apply shift_plus_less ]. rstepr y; auto. apply Cos_resp_leEq; auto. apply shift_div_leEq. apply pos_two. rstepr (Pi [/]TwoNZ[+]Pi [/]TwoNZ[+]Pi). astepl (x[+]y[+][0]). repeat apply plus_resp_leEq_both; auto. apply less_leEq; apply less_leEq_trans with y; auto. PiSolve. apply shift_leEq_div; [ apply pos_two | apply shift_leEq_plus' ]. rstepl x; apply less_leEq; auto. Qed. (* end hide *) Lemma Cos_resp_less : forall x y, [0] [<=] x -> x [<] y -> y [<=] Pi -> Cos y [<] Cos x. Proof. intros x y H H0 H1. simpl in |- *. assert (Hab : [0] [<=] Pi [/]TwoNZ). apply less_leEq; apply pos_div_two; apply pos_Pi. assert (Hbc : Pi [/]TwoNZ [<=] Pi). apply less_leEq; apply pos_div_two'; apply pos_Pi. assert (Hac : [0] [<=] Pi). apply leEq_transitive with (Pi [/]TwoNZ); auto. apply strict_dec_glues with (Hab := Hab) (Hbc := Hbc) (Hac := Hac). Included. intros x0 y0 H2 H3 H4 Hx Hy. apply less_wdl with (Cos x0); [ apply less_wdr with (Cos y0) | idtac ]; [ idtac | simpl in |- *; algebra | simpl in |- *; algebra ]. inversion_clear H2; inversion_clear H3; apply Cos_resp_less_aux'; auto. intros x0 y0 H2 H3 H4 Hx Hy. apply less_wdl with (Cos x0); [ apply less_wdr with (Cos y0) | idtac ]; [ idtac | simpl in |- *; algebra | simpl in |- *; algebra ]. astepl (Cos [--]x0); astepl ( [--][--] (Cos [--]x0)); astepl ( [--] (Cos ( [--]x0[+]Pi))). apply less_wdl with ( [--] (Cos (Pi[-]x0))). 2: apply un_op_wd_unfolded; apply Cos_wd; rational. astepr (Cos [--]y0); astepr ( [--][--] (Cos [--]y0)); astepr ( [--] (Cos ( [--]y0[+]Pi))). apply less_wdr with ( [--] (Cos (Pi[-]y0))). 2: apply un_op_wd_unfolded; apply Cos_wd; rational. apply inv_resp_less. inversion_clear H2; inversion_clear H3; apply Cos_resp_less_aux'. apply shift_leEq_minus; astepl x0; auto. unfold cg_minus in |- *; apply plus_resp_leEq_less; [ apply leEq_reflexive | apply inv_resp_less; auto ]. apply shift_minus_leEq; apply shift_leEq_plus'; rstepl (Pi [/]TwoNZ); auto. split; auto; apply less_leEq; apply leEq_less_trans with x; auto. split; auto; apply less_leEq; apply less_leEq_trans with y; auto. auto. Qed. Lemma Sin_resp_less : forall x y, [--] (Pi [/]TwoNZ) [<=] x -> x [<] y -> y [<=] Pi [/]TwoNZ -> Sin x [<] Sin y. Proof. intros. astepl (Cos (Pi [/]TwoNZ[-]x)); astepr (Cos (Pi [/]TwoNZ[-]y)). apply Cos_resp_less; auto. apply shift_leEq_minus; astepl y; auto. unfold cg_minus in |- *; apply plus_resp_leEq_less; [ apply leEq_reflexive | apply inv_resp_less; auto ]. apply shift_minus_leEq; apply shift_leEq_plus'; rstepl ( [--] (Pi [/]TwoNZ)); auto. Qed. Lemma Sin_ap_Zero : forall x:IR, (forall z, x[#](zring z)[*]Pi) -> Sin x [#] [0]. Proof. cut (forall x : IR, [0][<]x -> (forall n : nat, x[#]nring (R:=IR) n[*]Pi) -> Sin x[#][0]). intros X x Hx. destruct (ap_imp_less _ _ _ (Hx 0)). rstepl ([--][--](Sin x)). rstepr ([--][0]:IR). apply inv_resp_ap. csetoid_rewrite_rev (Sin_inv x). apply X. rstepl ([--]([0][*]Pi):IR). apply inv_resp_less. assumption. intros n. csetoid_rewrite_rev (zring_plus_nat IR n). replace (n:Z) with (- - n)%Z by ring. csetoid_rewrite (zring_inv IR (- n)%Z). rstepr ([--](zring (-n)[*]Pi)). apply inv_resp_ap. apply Hx. apply X. rstepl ([0][*]Pi). assumption. intros n. csetoid_rewrite_rev (zring_plus_nat IR n). apply Hx. cut (forall x : IR, [0][<]x -> x[<]Two[*]Pi -> (x[#]Pi) -> Sin x[#][0]). intros X x Hx0 Hx1. assert (Hpi : ([0][<]Two[*]Pi)). apply mult_resp_pos. apply (nring_pos); auto with *. auto with *. destruct (Archimedes' (x[/](Two[*]Pi)[//](Greater_imp_ap _ _ _ Hpi))) as [n Hn]. generalize x Hx0 Hx1 Hn. clear x Hx0 Hx1 Hn. induction n; intros x Hx0 Hx1 Hn. elim (less_antisymmetric_unfolded _ _ _ Hn). apply div_resp_pos; assumption. destruct (ap_imp_less _ _ _ (Hx1 (2*n))). apply IHn; try assumption. apply shift_div_less'. assumption. rstepr ((nring 2[*]nring n)[*]Pi). stepr (nring (R:=IR) (2 * n)[*]Pi). assumption. apply mult_wdl. apply nring_comm_mult. destruct n as [|n]. apply X; try assumption. rstepr ((Two[*]Pi)[*][1]). eapply shift_less_mult'. assumption. rstepr (nring 1:IR). apply Hn. rstepr ((nring 1:IR)[*]Pi). apply Hx1. rstepl (Sin (x[-]Two[*]Pi[+]Two[*]Pi)). csetoid_rewrite (Sin_periodic (x[-]Two[*]Pi)). apply IHn. apply shift_zero_less_minus. eapply leEq_less_trans;[|apply c]. stepr ((Two:IR)[*]nring (S n)[*]Pi); [|csetoid_rewrite (nring_comm_mult IR (2%nat) (S n)); apply eq_reflexive]. rstepl (Two[*]Pi[*]nring 1). rstepr (Two[*]Pi[*]nring (S n)). apply mult_resp_leEq_lft. apply nring_leEq; auto with *. apply less_leEq; assumption. intros i. apply zero_minus_apart. rstepl (x[-]((nring 2[+]nring i)[*]Pi)). apply minus_ap_zero. csetoid_rewrite_rev (nring_comm_plus IR 2 i). apply Hx1. rstepl ((x[/](Two[*]Pi)[//]Greater_imp_ap IR (Two[*]Pi) [0] Hpi)[-](nring 1)). apply shift_minus_less. csetoid_rewrite_rev (nring_comm_plus IR (S n) 1). rewrite Nat.add_comm. assumption. intros x Hx0 Hx1 Hx2. destruct (ap_imp_less _ _ _ Hx2). apply Greater_imp_ap. apply Sin_pos; assumption. rstepl (Sin (x[-]Pi[+]Pi)). csetoid_rewrite (Sin_plus_Pi (x[-]Pi)). rstepr ([--][0]:IR). apply inv_resp_ap. apply Greater_imp_ap. apply Sin_pos. apply shift_zero_less_minus. assumption. apply shift_minus_less. rstepr (Two[*]Pi). assumption. Qed. Lemma Cos_ap_Zero : forall x:IR, (forall z, x[#]Pi[/]TwoNZ[+](zring z)[*]Pi) -> Cos x [#] [0]. Proof. intros x Hx. stepl (Cos (x[-](Pi[/]TwoNZ)[+](Pi[/]TwoNZ))); [| now apply Cos_wd; rational]. csetoid_rewrite (Cos_plus_HalfPi (x[-](Pi[/]TwoNZ))). rstepr ([--][0]:IR). apply inv_resp_ap. apply Sin_ap_Zero. intros i. apply zero_minus_apart. rstepl (x[-](Pi[/]TwoNZ[+]zring i[*]Pi)). apply minus_ap_zero. apply Hx. Qed. Section Tangent. Lemma Tang_Domain : forall x:IR, (forall z, x[#]Pi[/]TwoNZ[+](zring z)[*]Pi) -> Dom Tang x. Proof. intros. repeat split; try constructor. intros []. apply: Cos_ap_Zero. assumption. Qed. Lemma Tang_Domain' : included (olor ([--](Pi[/]TwoNZ)) (Pi[/]TwoNZ)) (Dom Tang). Proof. intros x [Hx0 Hx1]. apply Tang_Domain. intros z. destruct (Z_lt_le_dec z 0). apply Greater_imp_ap. eapply leEq_less_trans;[|apply Hx0]. rstepr ([--][0][*]Pi[-]Pi[/]TwoNZ). apply shift_leEq_minus. rstepl (((zring z)[+](zring 1))[*]Pi). apply mult_resp_leEq_rht;[|apply less_leEq; auto with *]. stepl (zring (z+1):IR); [| now apply zring_plus]. replace (z+1)%Z with (-(-z-1))%Z by ring. assert (0<=-z-1)%Z. auto with *. rewrite (Z_to_nat_correct H). stepl ([--](nring (Z_to_nat H)):IR); [| now apply eq_symmetric; apply zring_inv_nat]. apply inv_resp_leEq. apply nring_nonneg. apply less_imp_ap. eapply less_leEq_trans. apply Hx1. rstepl (Pi[/]TwoNZ[+][0]). apply plus_resp_leEq_lft. apply mult_resp_nonneg;[|apply less_leEq; auto with *]. rewrite (Z_to_nat_correct l). stepr (nring (Z_to_nat l):IR); [| now auto with *]. apply nring_nonneg. Qed. (** ** Derivative of Tangent Finally, two formulas for the derivative of the tangent function and monotonicity properties. *) Lemma bnd_Cos : bnd_away_zero_in_P Cosine (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)). Proof. intros a b Hab H. split. Included. set (pos2 := less_leEq _ _ _ (pos_two IR)) in *. assert (H0 : [0] [<] sqrt Two pos2). apply power_cancel_less with 2. apply sqrt_nonneg. astepl ZeroR; astepr (Two:IR); apply pos_two. set (Hsqrt := pos_ap_zero _ _ H0) in *. exists (Min (Min (Cos a) (Cos b)) ([1][/] _[//]Hsqrt)). elim (H _ (compact_inc_lft _ _ Hab)); intros. elim (H _ (compact_inc_rht _ _ Hab)); intros. repeat apply less_Min; try apply Cos_pos; auto. apply recip_resp_pos. apply power_cancel_less with 2. apply sqrt_nonneg. astepl ZeroR; astepr (Two:IR); apply pos_two. intros y Hy X. apply leEq_wdr with (Cos y). 2: apply eq_transitive_unfolded with (AbsIR (Cos y)). 2: apply eq_symmetric_unfolded; apply AbsIR_eq_x. 2: apply less_leEq; elim (H y X); intros; apply Cos_pos; auto. 2: apply AbsIR_wd; simpl in |- *; algebra. elim (less_cotransitive_unfolded _ _ _ pos_QuarterPi y); intros. eapply leEq_transitive. apply Min_leEq_lft. apply leEq_transitive with (Cos b). apply Min_leEq_rht. elim (H _ (compact_inc_rht _ _ Hab)); elim (H y X); intros. inversion_clear X. apply Cos_resp_leEq; auto; apply less_leEq; auto. apply less_transitive_unfolded with (Pi [/]TwoNZ); PiSolve. elim (less_cotransitive_unfolded _ _ _ neg_invQuarterPi y); intros. 2: eapply leEq_transitive. 2: apply Min_leEq_lft. 2: apply leEq_transitive with (Cos a). 2: apply Min_leEq_lft. 2: astepl (Cos [--]a); astepr (Cos [--]y). 2: elim (H _ (compact_inc_lft _ _ Hab)); elim (H y X); intros. 2: inversion_clear X. 2: apply Cos_resp_leEq; auto. 2: astepl ( [--]ZeroR); apply less_leEq; apply inv_resp_less; auto. 2: apply less_leEq; apply less_transitive_unfolded with (Pi [/]TwoNZ). 2: astepr ( [--][--] (Pi [/]TwoNZ)); apply inv_resp_less; auto. 2: PiSolve. 2: apply inv_resp_leEq; auto. eapply leEq_transitive. apply Min_leEq_rht. apply leEq_wdr with (([1][/] _[//]Hsqrt) [*] (Cos (y[+]Pi [/]FourNZ) [+]Sin (y[+]Pi [/]FourNZ))). apply shift_div_leEq; auto. rstepr (Cos (y[+]Pi [/]FourNZ) [+]Sin (y[+]Pi [/]FourNZ)). set (z := y[+]Pi [/]FourNZ) in *. cut ([0] [<] z); intros. 2: unfold z in |- *; apply shift_less_plus. 2: astepl ( [--] (Pi [/]FourNZ)); auto. cut (z [<] Pi [/]TwoNZ); intros. 2: unfold z in |- *; apply shift_plus_less. 2: rstepr (Pi [/]FourNZ); auto. apply power_cancel_leEq with 2. auto. astepl (ZeroR[+][0]); apply plus_resp_leEq_both. apply less_leEq; apply pos_cos; try apply less_leEq; auto. apply less_leEq; apply Sin_pos; try apply less_leEq; auto. apply less_transitive_unfolded with (Pi [/]TwoNZ); PiSolve. simpl in |- *. astepl ([1][*]OneR); astepl OneR. apply leEq_wdr with (Cos z[^]2[+]Sin z[^]2[+]Two[*]Sin z[*]Cos z). 2: simpl in |- *; rational. astepr ([1][+]Sin (Two[*]z)). astepl ([1][+]ZeroR); apply less_leEq. apply plus_resp_leEq_less. apply leEq_reflexive. apply Sin_pos. apply shift_less_mult' with (two_ap_zero IR). apply pos_two. astepl ZeroR; auto. astepl (z[*]Two). apply shift_mult_less with (two_ap_zero IR). apply pos_two. auto. apply eq_transitive_unfolded with (Cos (y[+]Pi [/]FourNZ[+][--] (Pi [/]FourNZ))). 2: apply Cos_wd; rational. astepl (([1][/] _[//]Hsqrt) [*]Cos (y[+]Pi [/]FourNZ) [+] ([1][/] _[//]Hsqrt) [*]Sin (y[+]Pi [/]FourNZ)). astepl (Cos (Pi [/]FourNZ) [*]Cos (y[+]Pi [/]FourNZ) [+] Sin (Pi [/]FourNZ) [*]Sin (y[+]Pi [/]FourNZ)). astepl (Cos (Pi [/]FourNZ) [*]Cos (y[+]Pi [/]FourNZ) [+] [--][--] (Sin (Pi [/]FourNZ) [*]Sin (y[+]Pi [/]FourNZ))). astepl (Cos [--] (Pi [/]FourNZ) [*]Cos (y[+]Pi [/]FourNZ) [+] [--] ( [--] (Sin (Pi [/]FourNZ)) [*]Sin (y[+]Pi [/]FourNZ))). astepl (Cos [--] (Pi [/]FourNZ) [*]Cos (y[+]Pi [/]FourNZ) [+] [--] (Sin [--] (Pi [/]FourNZ) [*]Sin (y[+]Pi [/]FourNZ))). astepl (Cos [--] (Pi [/]FourNZ) [*]Cos (y[+]Pi [/]FourNZ) [-] Sin [--] (Pi [/]FourNZ) [*]Sin (y[+]Pi [/]FourNZ)). astepl (Cos (y[+]Pi [/]FourNZ) [*]Cos [--] (Pi [/]FourNZ) [-] Sin (y[+]Pi [/]FourNZ) [*]Sin [--] (Pi [/]FourNZ)). apply eq_symmetric_unfolded; apply Cos_plus. Qed. Opaque Sine Cosine. Lemma Derivative_Tan_1 : forall H, Derivative (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) H Tang {1/} (Cosine{^}2). Proof. intros. assert (H0 : Derivative _ H Sine Cosine). apply Included_imp_Derivative with realline I; Deriv. assert (H1 : Derivative _ H Cosine {--}Sine). apply Included_imp_Derivative with realline I; Deriv. assert (H2 : forall x : IR, olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) x -> Cos x [#] [0]). intros x H2; apply Greater_imp_ap; inversion_clear H2; apply Cos_pos; auto. unfold Tang in |- *. Derivative_Help. apply eq_imp_Feq. apply included_FDiv. apply included_FMinus; Included. Included. intros; simpl in |- *; apply ap_wdl with (Cos x[*]Cos x). apply mult_resp_ap_zero; auto. simpl in |- *; algebra. apply included_FRecip. Included. intros; simpl in |- *; apply ap_wdl with (Cos x[*]Cos x). apply mult_resp_ap_zero; auto. astepl ([1][*]Cos x[*]Cos x); simpl in |- *; algebra. intros x H3 Hx Hx'. apply eq_transitive_unfolded with (Cos x[*]Cos x[-]Sin x[*][--] (Sin x) [/] _[//] mult_resp_ap_zero _ _ _ (H2 x H3) (H2 x H3)). elim Hx; intros H4 H5. astepl (Part _ _ (ProjIR1 (H4, H5)) [/] _[//] ext2 (S:=IR) (ProjIR2 (H4, H5))). astepl (Part _ _ H4[/] _[//]ext2 (S:=IR) H5); clear Hx. apply div_wd. simpl in |- *. astepl (Part _ _ (ProjIR1 H4) [-]Part _ _ (ProjIR2 H4)). elim H4; clear H4; intros H6 H7. astepl (Part _ _ H6[-]Part _ _ H7). apply cg_minus_wd; simpl in |- *; algebra. elim H5; clear H5; intros H6 H7. astepl (Part _ _ H6). simpl in |- *; algebra. apply eq_transitive_unfolded with ([1][/] _[//]mult_resp_ap_zero _ _ _ (H2 x H3) (H2 x H3)). apply div_wd. 2: simpl in |- *; algebra. astepr (Cos x[^]2[+]Sin x[^]2); simpl in |- *; rational. simpl in Hx'; astepr ([1][/] _[//]ext2 (S:=IR) Hx'). apply div_wd. algebra. astepl ([1][*]Cos x[*]Cos x); simpl in |- *; algebra. apply Derivative_div. Deriv. Deriv. apply bnd_Cos. Qed. Lemma Derivative_Tan_2 : forall H, Derivative (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) H Tang ( [-C-][1]{+}Tang{^}2). Proof. intros. eapply Derivative_wdr. 2: apply Derivative_Tan_1. assert (H0 : forall x : IR, olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ) x -> Cos x [#] [0]). intros x H0; apply Greater_imp_ap; inversion_clear H0; apply Cos_pos; auto. apply eq_imp_Feq. apply included_FRecip. Included. intros; simpl in |- *; apply ap_wdl with (Cos x[*]Cos x). apply mult_resp_ap_zero; auto. astepl ([1][*]Cos x[*]Cos x); simpl in |- *; algebra. apply included_FPlus. Included. apply included_FNth. unfold Tang in |- *; apply included_FDiv. Included. Included. intros; simpl in |- *; astepl (Cos x). algebra. simpl in |- *; algebra. intros x H1 Hx Hx'. apply eq_transitive_unfolded with ([1][/] _[//]mult_resp_ap_zero _ _ _ (H0 x H1) (H0 x H1)). simpl in |- *; apply div_wd. algebra. astepr ([1][*]Cos x[*]Cos x); simpl in |- *; algebra. astepl (Cos x[^]2[+]Sin x[^]2[/] _[//]mult_resp_ap_zero _ _ _ (H0 x H1) (H0 x H1)). apply eq_transitive_unfolded with ([1][+][1][*] (Sin x[/] _[//]H0 x H1) [*] (Sin x[/] _[//]H0 x H1)). 2: simpl in |- *; apply bin_op_wd_unfolded. 2: algebra. 2: repeat simple apply mult_wd; try apply div_wd; algebra. simpl in |- *. rational. Qed. Lemma Tan_resp_less : forall x y, [--] (Pi [/]TwoNZ) [<] x -> y [<] Pi [/]TwoNZ -> forall Hx Hy, x [<] y -> Tan x Hx [<] Tan y Hy. Proof. intros x y H H0 Hx Hy H1. assert (H2 : [--] (Pi [/]TwoNZ) [<] Pi [/]TwoNZ). apply less_transitive_unfolded with x; auto; apply less_transitive_unfolded with y; auto. unfold Tan in |- *. apply Derivative_imp_resp_less with (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) H2 ( {1/} (Cosine{^}2)). apply Derivative_Tan_1. auto. split; auto; apply less_transitive_unfolded with y; auto. split; auto; apply less_transitive_unfolded with x; auto. intros. apply less_leEq_trans with OneR. apply pos_one. apply leEq_glb. intros y0 H3 Hy0. cut (Cos y0 [#] [0]). intro H4. apply leEq_wdr with ([1][/] _[//]mult_resp_ap_zero _ _ _ H4 H4). 2: simpl in |- *; rational. apply shift_leEq_div. astepr (Cos y0[^]2); apply pos_square; auto. astepl (Cos y0[*]Cos y0). apply leEq_wdl with (AbsIR (Cos y0) [^]2). astepr (OneR[^]2). apply nexp_resp_leEq. apply AbsIR_nonneg. apply AbsIR_Cos_leEq_One. astepl (AbsIR (Cos y0) [*]AbsIR (Cos y0)). eapply eq_transitive_unfolded. apply eq_symmetric_unfolded; apply AbsIR_resp_mult. apply AbsIR_eq_x. astepr (Cos y0[^]2); apply sqr_nonneg. inversion_clear Hy0. apply cring_mult_ap_zero_op with OneR. apply cring_mult_ap_zero with (Cos y0). simpl in |- *; simpl in X0; auto. Qed. Lemma Tan_resp_leEq : forall x y, [--] (Pi [/]TwoNZ) [<] x -> y [<] Pi [/]TwoNZ -> forall Hx Hy, x [<=] y -> Tan x Hx [<=] Tan y Hy. Proof. intros x y H H0 Hx Hy H1. unfold Tan in |- *. set (H2 := invHalfPi_less_HalfPi) in *. apply Derivative_imp_resp_leEq with (olor [--] (Pi [/]TwoNZ) (Pi [/]TwoNZ)) H2 ( {1/} (Cosine{^}2)). apply Derivative_Tan_1. auto. split; auto; apply leEq_less_trans with y; auto. split; auto; apply less_leEq_trans with x; auto. intros. apply leEq_glb. intros y0 H3 Hy0. cut (Cos y0 [#] [0]). intro H4. apply leEq_wdr with (([1][/] _[//]H4) [^]2). apply sqr_nonneg. simpl in |- *; rational. inversion_clear Hy0. apply cring_mult_ap_zero_op with OneR. apply cring_mult_ap_zero with (Cos y0). simpl in |- *; simpl in X0; auto. Qed. End Tangent. #[global] Hint Resolve Derivative_Tan_1 Derivative_Tan_2: derivate. corn-8.20.0/transc/Trigonometric.v000066400000000000000000000515501473720167500170720ustar00rootroot00000000000000(* Copyright © 1998-2006 * Henk Barendregt * Luís Cruz-Filipe * Herman Geuvers * Mariusz Giero * Rik van Ginneken * Dimitri Hendriks * Sébastien Hinderer * Bart Kirkels * Pierre Letouzey * Iris Loeb * Lionel Mamane * Milad Niqui * Russell O’Connor * Randy Pollack * Nickolay V. Shmyrev * Bas Spitters * Dan Synek * Freek Wiedijk * Jan Zwanenburg * * This work is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This work is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License along * with this work; if not, write to the Free Software Foundation, Inc., * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. *) Require Export CoRN.transc.TaylorSeries. From Coq Require Import Lia. (** * The Trigonometric Functions In this section, we explore the properties of the trigonometric functions which we previously defined. *) Section Lemmas. (** First, we need a lemma on mappings. *) Lemma maps_translation : forall y, maps_compacts_into realline realline (FId{+} [-C-]y). Proof. intros y a b Hab H. exists (a[+]y); exists (b[+]y[+][1]). cut (a[+]y [<] b[+]y[+][1]). intro H0. exists H0. split. split. intros x Hx H1; simpl in |- *; inversion_clear H1; split. apply plus_resp_leEq; auto. apply less_leEq; apply leEq_less_trans with (b[+]y). apply plus_resp_leEq; auto. apply less_plusOne. apply leEq_less_trans with (b[+]y). apply plus_resp_leEq; auto. apply less_plusOne. Qed. End Lemmas. Section Sine_and_Cosine. (** Sine, cosine and tangent at [[0]]. *) Lemma Sin_zero : Sin [0] [=] [0]. Proof. simpl in |- *. eapply eq_transitive_unfolded. 2: apply (series_sum_zero conv_zero_series). apply series_sum_wd; intros; simpl in |- *. case n. unfold sin_seq in |- *; simpl in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. rational. exfalso; inversion b. clear n; intro; simpl in |- *. rational. Qed. Lemma Cos_zero : Cos [0] [=] [1]. Proof. simpl in |- *. unfold series_sum in |- *. apply eq_symmetric_unfolded; apply Limits_unique. intros eps H. exists 1; intros. apply AbsSmall_wdr_unfolded with ZeroR. apply zero_AbsSmall; apply less_leEq; auto. simpl in |- *. unfold seq_part_sum in |- *. induction m as [| m Hrecm]. exfalso; inversion H0. clear Hrecm; induction m as [| m Hrecm]. simpl in |- *. unfold cos_seq in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. cut (x = 0); [ intro | lia ]. rewrite H1; simpl in |- *; rational. exfalso; inversion b. set (n := S m) in *. cut (1 <= n); [ intro | unfold n in |- *; auto with arith ]. cut (n = S m); [ intro | auto ]. clearbody n. simpl in |- *. set (h := fun i : nat => (cos_seq i[/] _[//]nring_fac_ap_zero _ i) [*]nexp IR i ([0][-][0])) in *. fold (h n) in |- *. rstepr (h n[+] (Sum0 n h[-][1])). astepl (ZeroR[+][0]). apply bin_op_wd_unfolded. 2: auto. unfold h, cos_seq in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. 2: rational. apply eq_symmetric_unfolded; apply x_mult_zero. rewrite H2; simpl in |- *; rational. Qed. Hint Resolve Sin_zero Cos_zero: algebra. Opaque Sine Cosine. Lemma Tan_zero : forall H, Tan [0] H [=] [0]. Proof. intros; unfold Tan, Tang in |- *. simpl in |- *. astepr (ZeroR [/]OneNZ); apply div_wd. astepr (Sin [0]); simpl in |- *; algebra. astepr (Cos [0]); simpl in |- *; algebra. Qed. Transparent Sine Cosine. (** Continuity of sine and cosine are trivial. *) Lemma Continuous_Sin : Continuous realline Sine. Proof. unfold Sine in |- *; Contin. Qed. Lemma Continuous_Cos : Continuous realline Cosine. Proof. unfold Cosine in |- *; Contin. Qed. (** The rules for the derivative of the sine and cosine function; we begin by proving that their defining sequences can be expressed in terms of one another. *) Lemma cos_sin_seq : forall n : nat, cos_seq n [=] sin_seq (S n). Proof. intro. apply eq_symmetric_unfolded. unfold sin_seq, cos_seq in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p0; intros; simpl in |- *. exfalso; lia. algebra. elim even_or_odd_plus; intros; simpl in |- *. elim p0; intros; simpl in |- *. cut (x0 = x); [ intro | lia ]. rewrite H; algebra. exfalso; lia. Qed. Lemma sin_cos_seq : forall n : nat, sin_seq n [=] [--] (cos_seq (S n)). Proof. intros. unfold sin_seq, cos_seq in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p; intros; simpl in |- *. elim even_or_odd_plus; intros; simpl in |- *. elim p0; intros; simpl in |- *. exfalso; lia. algebra. elim even_or_odd_plus; intros; simpl in |- *. elim p0; intros; simpl in |- *. cut (S x = x0); [ intro | lia ]. rewrite <- H; simpl in |- *; rational. exfalso; lia. Qed. Lemma Derivative_Sin : forall H, Derivative realline H Sine Cosine. Proof. intro. unfold Sine, Cosine, sin_ps, cos_ps in |- *. cut (fun_series_convergent_IR realline (FPowerSeries' [0] (fun n : nat => sin_seq (S n)))). intro H0. eapply Derivative_wdr. 2: apply Derivative_FPowerSeries1' with (Hg := H0). FEQ. simpl in |- *. apply series_sum_wd; intros. apply mult_wdl. apply div_wd. apply eq_symmetric_unfolded; apply cos_sin_seq. algebra. apply fun_series_convergent_wd_IR with (FPowerSeries' [0] cos_seq). intros; FEQ. repeat split. repeat split. simpl in |- *. apply mult_wdl. apply div_wd. apply cos_sin_seq. algebra. apply cos_conv. Qed. Lemma Derivative_Cos : forall H, Derivative realline H Cosine {--}Sine. Proof. intro. unfold Sine, Cosine, sin_ps, cos_ps in |- *. cut (fun_series_convergent_IR realline (FPowerSeries' [0] (fun n : nat => cos_seq (S n)))). intro H0. eapply Derivative_wdr. 2: apply Derivative_FPowerSeries1' with (Hg := H0). FEQ. simpl in |- *. apply eq_transitive_unfolded with (series_sum _ (conv_series_inv _ (fun_series_conv_imp_conv _ _ (leEq_reflexive _ x) _ (sin_conv _ _ (leEq_reflexive _ x) (compact_single_iprop realline x Hx')) x (compact_single_prop x) (fun_series_inc_IR realline _ sin_conv x Hx')))). apply series_sum_wd; intros. simpl in |- *. rstepr (( [--] (sin_seq n) [/] _[//]nring_fac_ap_zero _ n) [*]nexp IR n (x[-][0])). apply mult_wdl. apply div_wd. apply eq_symmetric_unfolded. astepr ( [--][--] (cos_seq (S n))); apply un_op_wd_unfolded. apply sin_cos_seq. algebra. simpl in |- *. apply series_sum_inv with (x := fun n : nat => (sin_seq n[/] _[//]nring_fac_ap_zero IR n) [*]nexp IR n (x[-][0])). apply fun_series_convergent_wd_IR with (fun n : nat => {--} (FPowerSeries' [0] sin_seq n)). intros; FEQ. repeat split. repeat split. simpl in |- *. rstepl (( [--] (sin_seq n) [/] _[//]nring_fac_ap_zero _ n) [*]nexp IR n (x[-][0])). apply mult_wdl. apply div_wd. astepr ( [--][--] (cos_seq (S n))); apply un_op_wd_unfolded. apply sin_cos_seq. algebra. apply FSeries_Sum_inv_conv. apply sin_conv. Qed. Hint Resolve Derivative_Sin Derivative_Cos: derivate. Hint Resolve Continuous_Sin Continuous_Cos: continuous. Section Sine_of_Sum. (** We now prove the rule for the sine and cosine of the sum. These rules have to be proved first as functional equalities, which is why we also state the results in a function form (which we won't do in other situations). %\begin{convention}% Let: - [F := fun y => Sine[o] (FId{+} [-C-]y)]; - [G := fun y => (Sine{*} [-C-] (Cos y)) {+} (Cosine{*} [-C-] (Sin y))]. %\end{convention}% *) (* begin hide *) Let F (y : IR) := Sine[o]FId{+} [-C-]y. Let G (y : IR) := Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y). Let F' (y : IR) := (fix funct (n : nat) : PartIR := match n with | O => Sine[o]FId{+} [-C-]y | S O => Cosine[o]FId{+} [-C-]y | S (S O) => {--} (Sine[o]FId{+} [-C-]y) | S (S (S O)) => {--} (Cosine[o]FId{+} [-C-]y) | S (S (S (S p))) => funct p end). Let G' (y : IR) := (fix funct (n : nat) : PartIR := match n with | O => Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y) | S O => Cosine{*} [-C-] (Cos y) {-}Sine{*} [-C-] (Sin y) | S (S O) => {--} (Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y)) | S (S (S O)) => Sine{*} [-C-] (Sin y) {-}Cosine{*} [-C-] (Cos y) | S (S (S (S p))) => funct p end). (* end hide *) Opaque Sine Cosine. Lemma Sin_plus_Taylor_bnd_lft : forall y : IR, Taylor_bnd (F' y). Proof. clear F G G'; intros. apply bnd_imp_Taylor_bnd with (FAbs (Sine[o]FId{+} [-C-]y) {+}FAbs (Cosine[o]FId{+} [-C-]y)). intro; apply four_ind with (P := fun n : nat => forall (x : IR) Hx Hx', AbsIR (F' y n x Hx) [<=] AbsIR ((FAbs (Sine[o]FId{+} [-C-]y) {+}FAbs (Cosine[o]FId{+} [-C-]y)) x Hx')). intros. unfold F' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl (AbsIR (Sine (x[+]y) (ProjT2 Hx)) [+][0]). apply plus_resp_leEq_both. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR1 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. apply FAbs_nonneg. intros. unfold F' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl ([0][+]AbsIR (Cosine (x[+]y) (ProjT2 Hx))). apply plus_resp_leEq_both. apply FAbs_nonneg. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR2 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. intros. unfold F' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl (AbsIR [--] (Sine (x[+]y) (ProjT2 Hx)) [+][0]). apply leEq_wdl with (AbsIR (Sine (x[+]y) (ProjT2 Hx)) [+][0]). apply plus_resp_leEq_both. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR1 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. apply FAbs_nonneg. apply bin_op_wd_unfolded. apply AbsIR_inv. algebra. intros. unfold F' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl ([0][+]AbsIR [--] (Cosine (x[+]y) (ProjT2 Hx))). apply leEq_wdl with ([0][+]AbsIR (Cosine (x[+]y) (ProjT2 Hx))). apply plus_resp_leEq_both. apply FAbs_nonneg. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR2 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. apply bin_op_wd_unfolded. algebra. apply AbsIR_inv. auto. cut (maps_compacts_into_weak realline realline (Fid IR{+} [-C-]y)); intros. apply Continuous_plus; apply Continuous_abs; apply Continuous_comp with realline; Contin. intros a b Hab H. exists (a[+]y); exists (b[+]y). cut (a[+]y [<=] b[+]y). intro H0. exists H0. split. Included. intros x Hx H1; inversion_clear H1. split. simpl in |- *; apply plus_resp_leEq; auto. simpl in |- *; apply plus_resp_leEq; auto. apply plus_resp_leEq; auto. apply four_induction with (P := fun n : nat => included (fun _ : IR => True) (Dom (F' y n))); auto; unfold F' in |- *; Included. Qed. Lemma Sin_plus_Taylor_bnd_rht : forall y : IR, Taylor_bnd (G' y). Proof. clear F G F'; intros. apply bnd_imp_Taylor_bnd with (FAbs (Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y)) {+} FAbs (Cosine{*} [-C-] (Cos y) {-}Sine{*} [-C-] (Sin y))). intro; apply four_ind with (P := fun n : nat => forall (x : IR) Hx Hx', AbsIR (G' y n x Hx) [<=] AbsIR ((FAbs (Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y)) {+} FAbs (Cosine{*} [-C-] (Cos y) {-}Sine{*} [-C-] (Sin y))) x Hx')). intros. unfold G' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl (AbsIR (Sine x (ProjIR1 (ProjIR1 Hx)) [*]Cos y[+] Cosine x (ProjIR1 (ProjIR2 Hx)) [*]Sin y) [+][0]). apply plus_resp_leEq_both. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR1 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. apply FAbs_nonneg. intros. unfold G' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl ([0][+] AbsIR (Cosine x (ProjIR1 (ProjIR1 Hx)) [*]Cos y[-] Sine x (ProjIR1 (ProjIR2 Hx)) [*]Sin y)). apply plus_resp_leEq_both. apply FAbs_nonneg. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR2 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. intros. unfold G' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl (AbsIR [--] (Sine x (ProjIR1 (ProjIR1 Hx)) [*]Cos y[+] Cosine x (ProjIR1 (ProjIR2 Hx)) [*]Sin y) [+][0]). apply leEq_wdl with (AbsIR (Sine x (ProjIR1 (ProjIR1 Hx)) [*]Cos y[+] Cosine x (ProjIR1 (ProjIR2 Hx)) [*]Sin y) [+][0]). apply plus_resp_leEq_both. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR1 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. apply FAbs_nonneg. apply bin_op_wd_unfolded. apply AbsIR_inv. algebra. intros. unfold G' in |- *. Opaque FAbs. simpl in |- *. eapply leEq_transitive. 2: apply leEq_AbsIR. astepl ([0][+] AbsIR (Sine x (ProjIR1 (ProjIR1 Hx)) [*]Sin y[-] Cosine x (ProjIR1 (ProjIR2 Hx)) [*]Cos y)). apply leEq_wdl with ([0][+] AbsIR (Cosine x (ProjIR1 (ProjIR2 Hx)) [*]Cos y[-] Sine x (ProjIR1 (ProjIR1 Hx)) [*]Sin y)). apply plus_resp_leEq_both. apply FAbs_nonneg. apply eq_imp_leEq; apply eq_symmetric_unfolded. Transparent FAbs. apply eq_transitive_unfolded with (AbsIR (Part _ _ (ProjIR1 (ProjIR2 Hx')))). apply FAbs_char. apply AbsIR_wd; simpl in |- *; rational. apply bin_op_wd_unfolded. algebra. apply AbsIR_minus. auto. Contin. apply four_induction with (P := fun n : nat => included (fun _ : IR => True) (Dom (G' y n))); auto; unfold G' in |- *. apply included_FPlus; Included. apply included_FMinus; Included. apply included_FInv; apply included_FPlus; Included. apply included_FMinus; Included. Qed. Lemma Sin_plus_eq : forall y n HaF HaG, F' y n [0] HaF [=] G' y n [0] HaG. Proof. do 2 intro; apply four_ind with (P := fun n : nat => forall HaF HaG, F' y n [0] HaF [=] G' y n [0] HaG). intros; simpl in |- *. apply eq_transitive_unfolded with (Sin y). simpl in |- *; rational. apply eq_transitive_unfolded with (Sin [0][*]Cos y[+]Cos [0][*]Sin y). 2: simpl in |- *; algebra. rstepl ([0][*]Cos y[+][1][*]Sin y). algebra. intros; simpl in |- *. apply eq_transitive_unfolded with (Cos y). simpl in |- *; rational. apply eq_transitive_unfolded with (Cos [0][*]Cos y[-]Sin [0][*]Sin y). 2: simpl in |- *; algebra. rstepl ([1][*]Cos y[-][0][*]Sin y). algebra. intros; simpl in |- *. apply un_op_wd_unfolded. apply eq_transitive_unfolded with (Sin y). simpl in |- *; rational. apply eq_transitive_unfolded with (Sin [0][*]Cos y[+]Cos [0][*]Sin y). 2: simpl in |- *; algebra. rstepl ([0][*]Cos y[+][1][*]Sin y). algebra. intros; simpl in |- *. apply eq_transitive_unfolded with ( [--] (Cos y)). simpl in |- *; rational. apply eq_transitive_unfolded with (Sin [0][*]Sin y[-]Cos [0][*]Cos y). 2: simpl in |- *; algebra. rstepl ([0][*]Sin y[-][1][*]Cos y). algebra. intros. simpl in |- *; auto. Qed. Lemma Sin_plus_der_lft : forall y n, Derivative_n n realline I (F y) (F' y n). Proof. intro; apply Derivative_n_chain. simpl in |- *; unfold F in |- *. apply Feq_reflexive. apply included_FComp; Included. intro. cut (maps_compacts_into realline realline (FId{+} [-C-]y)); [ intro | apply maps_translation ]. cut (Derivative realline I (FId{+} [-C-]y) [-C-][1]); intros. 2: apply Derivative_wdr with ( [-C-][1]{+} [-C-][0]:PartIR). 2: FEQ. 2: Deriv. apply four_induction with (P := fun n : nat => Derivative realline I (F' y n) (F' y (S n))). simpl in |- *. apply Derivative_wdr with ((Cosine[o]FId{+} [-C-]y) {*} [-C-][1]). FEQ. apply Derivative_comp with realline I; auto. Deriv. simpl in |- *. apply Derivative_wdr with (( {--}Sine[o]FId{+} [-C-]y) {*} [-C-][1]). FEQ. apply Derivative_comp with realline I; auto. Deriv. simpl in |- *. apply Derivative_inv. apply Derivative_wdr with ((Cosine[o]FId{+} [-C-]y) {*} [-C-][1]). FEQ. apply Derivative_comp with realline I; auto. Deriv. simpl in |- *. apply Derivative_wdr with ( {--} (( {--}Sine[o]FId{+} [-C-]y) {*} [-C-][1])). FEQ. apply Derivative_inv. apply Derivative_comp with realline I; auto. Deriv. intros. auto. Qed. Lemma Sin_plus_der_rht : forall y n, Derivative_n n realline I (G y) (G' y n). Proof. intro; apply Derivative_n_chain. simpl in |- *; unfold G in |- *. apply Feq_reflexive. apply included_FPlus; Included. intro. cut (Derivative realline I Sine Cosine); [ intro | Deriv ]. cut (Derivative realline I Cosine {--}Sine); [ intro | Deriv ]. apply four_induction with (P := fun n : nat => Derivative realline I (G' y n) (G' y (S n))). simpl in |- *. let r := PartIR_to_symbPF (Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y)) in apply Derivative_wdr with (symbPF_deriv r). simpl in |- *. apply eq_imp_Feq. repeat split. repeat split. intros; simpl in |- *; rational. simpl in |- *; Deriv. simpl in |- *. let r := PartIR_to_symbPF (Cosine{*} [-C-] (Cos y) {-}Sine{*} [-C-] (Sin y)) in apply Derivative_wdr with (symbPF_deriv r). simpl in |- *. apply eq_imp_Feq. repeat split. repeat split. intros; simpl in |- *; rational. simpl in |- *; Deriv. simpl in |- *. let r := PartIR_to_symbPF ( {--} (Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y))) in apply Derivative_wdr with (symbPF_deriv r). simpl in |- *. apply eq_imp_Feq. repeat split. repeat split. intros; simpl in |- *; rational. simpl in |- *; Deriv. simpl in |- *. let r := PartIR_to_symbPF (Sine{*} [-C-] (Sin y) {-}Cosine{*} [-C-] (Cos y)) in apply Derivative_wdr with (symbPF_deriv r). simpl in |- *. apply eq_imp_Feq. repeat split. repeat split. intros; simpl in |- *; rational. simpl in |- *; Deriv. auto. Qed. Lemma Sin_plus_fun : forall y : IR, Feq realline (F y) (G y). Proof. intro. cut (Taylor_bnd (F' y)). intro H. cut (Taylor_bnd (G' y)). intro H0. cut (forall n : nat, Continuous realline (G' y n)). intro H1; apply Taylor_unique_crit with ZeroR (F' y) (G' y) (Sin_plus_der_lft y) H. exact (Sin_plus_der_rht y). auto. apply Sin_plus_eq. apply Taylor_Series_conv_to_fun. auto. apply four_induction with (P := fun n : nat => Continuous realline (G' y n)). simpl in |- *; Contin. simpl in |- *; Contin. simpl in |- *; Contin. simpl in |- *; Contin. auto. apply Sin_plus_Taylor_bnd_rht. apply Sin_plus_Taylor_bnd_lft. Qed. End Sine_of_Sum. Opaque Sine Cosine. Lemma Cos_plus_fun : forall y, Feq realline (Cosine[o]FId{+} [-C-]y) (Cosine{*} [-C-] (Cos y) {-}Sine{*} [-C-] (Sin y)). Proof. intro. assert (H : Derivative realline I Sine Cosine). Deriv. assert (H0 : Derivative realline I Cosine {--}Sine). Deriv. apply Derivative_unique with I (Sine[o]FId{+} [-C-]y). Derivative_Help. FEQ. apply Derivative_comp with realline I. apply maps_translation. Deriv. Deriv. apply Derivative_wdl with (Sine{*} [-C-] (Cos y) {+}Cosine{*} [-C-] (Sin y)). apply Feq_symmetric; apply Sin_plus_fun. apply Derivative_wdl with (Cos y{**}Sine{+}Sin y{**}Cosine). apply eq_imp_Feq. apply included_FPlus; Included. apply included_FPlus; Included. intros; simpl in |- *; rational. apply Derivative_wdr with (Cos y{**}Cosine{+}Sin y{**}{--}Sine). apply eq_imp_Feq. apply included_FPlus; Included. apply included_FMinus; Included. intros; simpl in |- *; rational. Deriv. Qed. End Sine_and_Cosine. corn-8.20.0/util/000077500000000000000000000000001473720167500135335ustar00rootroot00000000000000corn-8.20.0/util/Container.v000066400000000000000000000004121473720167500156410ustar00rootroot00000000000000Require Import MathClasses.interfaces.canonical_names. Class Container (Elem C: Type) := In: C → Elem → Prop. #[global] Hint Unfold In. Notation "x ∈ y" := (In y x) (at level 70). Notation "x ∉ y" := (¬In y x) (at level 70). Notation "(∈ y )" := (In y). corn-8.20.0/util/Extract.v000066400000000000000000000075631473720167500153470ustar00rootroot00000000000000From Coq Require Import Extraction. Require Import CoRN.reals.fast.CRtrans. Extraction Language Haskell. Extract Inductive bool => Bool [ True False ]. Extract Inductive option => Maybe [ Just Nothing ]. Extract Inductive list => "([])" [ "[]" "( : )" ]. Extract Inlined Constant List.tl => "tail". Extract Inlined Constant List.hd => "head". Extract Inlined Constant List.map => "map". Extract Inductive CoqStreams.Stream => "([])" ["( : )"]. Extract Inlined Constant CoqStreams.tl => "tail". Extract Inlined Constant CoqStreams.hd => "head". Extract Inlined Constant CoqStreams.map => "map". Extract Inlined Constant CoqStreams.zipWith => "zipWith". Extract Inductive sum => "( :+: )" [ "Inl" "Inr" ]. Extract Inductive prod => "( , )" [ "( , )" ]. Extract Inlined Constant fst => "fst". Extract Inlined Constant snd => "snd". Extract Inductive sumbool => Bool [ True False ]. Extraction Inline sumbool_rec. Extract Inductive comparison => Ordering [ EQ LT GT ]. (* Misc *) Extraction Inline eq_rect. Extraction Inline eq_rec. Extraction Inline eq_rec_r. Extraction Inline proj1_sig. (* nat *) Extract Inductive nat => Integer [ "0" "succ" ] "(\ fO fS n -> if n == 0 then fO () else fS (n - 1))". Extract Inlined Constant plus => "(+)". Extract Inlined Constant pred => "fun n -> max 0 (pred n)". Extract Inlined Constant minus => "fun n m -> max 0 (n - m)". Extract Inlined Constant mult => "(*)". Extract Inlined Constant max => max. Extract Inlined Constant min => min. Extract Inlined Constant Nat.eqb => "(==)". Extract Inlined Constant EqNat.eq_nat_decide => "(==)". Extract Inlined Constant Peano_dec.eq_nat_dec => "(==)". (* ZArith *) Extract Inductive positive => Integer [ "(\p -> 1+2*p)" "(\p -> 2*p)" "1" ] "(\f2p1 f2p f1 p -> if p <= 1 then f1 () else if p`mod` 2 == 0 then f2p (p `div` 2) else f2p1 (p `div` 2))". Extract Inductive Z => Integer [ "0" "" "negate" ] "(\f0 fp fn z -> if z == 0 then f0 () else if z > 0 then fp z else fn (negate z))". Extract Inlined Constant Pplus => "(+)". Extract Inlined Constant Pos.succ => "succ". Extract Inlined Constant Pos.pred => "pred". Extract Inlined Constant Pminus => "\n m -> max 1 (n - m)". Extract Inlined Constant Pmult => "(*)". Extract Inlined Constant Pos.min => "min". Extract Inlined Constant Pos.max => "max". (* Probably a change in the way Coq handles numbers, ask PL. Extract Inlined Constant Pcompare => "compare".*) Extract Inlined Constant positive_eq_dec => "(==)". Extraction Inline positive_rec. Extract Inlined Constant Zplus => "(+)". Extract Inlined Constant Z.succ => "succ". Extract Inlined Constant Z.pred => "pred". Extract Inlined Constant Zminus => "(-)". Extract Inlined Constant Zmult => "(*)". Extract Inlined Constant Z.opp => "negate". Extract Inlined Constant Z.abs => "abs". Extract Inlined Constant Z.min => "min". Extract Inlined Constant Z.max => "max". Extract Inlined Constant Z.compare => "compare". Extract Inlined Constant Z.eq_dec => "(==)". Extraction Inline Z_rec. Extract Inlined Constant Z_of_nat => "id". (* QArith *) Extract Inductive Q => Rational [ "( :% )" ]. Extract Inlined Constant Qnum => "numerator". Extract Inlined Constant Qden => "denominator". Extract Inlined Constant Qplus => "(+)". Extract Inlined Constant Qplus' => "(+)". Extract Inlined Constant Qopp => "negate". Extract Inlined Constant QMinMax.Qmin => "min". Extract Inlined Constant Qminus' => "min". Extract Inlined Constant QMinMax.Qmax => "max". Extract Inlined Constant Qmult => "(*)". Extract Inlined Constant Qmult' => "(*)". Extract Inlined Constant Qinv => "recip". Extract Inlined Constant Qcompare => "compare". Extract Inlined Constant inject_Z => "fromInteger". Extract Inlined Constant Qeq_dec => "(==)". (* Definition answer (n:positive) (r:CR) : Z := let m := (iter_pos n _ (Pmult 10) 1%positive) in let (a,b) := (approximate r (1#m)%Qpos)*m in Zdiv a b. Definition test := answer 10 (exp ('1))%CR. Recursive Extraction test. *) corn-8.20.0/util/PointFree.v000066400000000000000000000056731473720167500156300ustar00rootroot00000000000000From Coq Require Import Program Utf8. Require Import CoRN.stdlib_omissions.Pair. Generalizable All Variables. (** In the following type class, r is an "output parameter" in the sense that we will have unification infer it. We cannot turn r into a field instead, because that would hide it behind a projection, which hinders further scrutiny. *) Class PointFree {T} (f r: T): Prop := pointfree_eq: f = r. (** If no other instances match, give up and declare the thing point-free: *) #[global] Instance proper_pf {T} (x: T): PointFree x x | 9. Proof. firstorder. Qed. (** Instances for various forms of lambdas: *) #[global] Instance eta_pf {A B} (f: A → B) `{!PointFree f f'}: PointFree (λ x, f x) (f' ∘ id) | 10. Proof. firstorder. Qed. #[global] Instance const_pf {A B} (b: B): PointFree (λ _: A, b) (const b). Proof. firstorder. Qed. #[global] Instance id_pf {A}: PointFree (λ x: A, x) id. Proof. firstorder. Qed. #[global] Instance pair_pf {A B C} (f: A → B) (g: A → C) `{!PointFree f f'} `{!PointFree g g'}: PointFree (λ x: A, (f x, g x)) (map_pair f' g' ∘ diagonal). Proof. compute. rewrite PointFree0, PointFree1. reflexivity. Qed. (* This one may not be strictly needed in the presence of binapp_pf below. *) #[global] Instance compose_pf {A B C} (f: B → C) (g: A → B) `{!PointFree f f'} `{!PointFree g g'}: PointFree (λ x, f (g x)) (f' ∘ g'). Proof. compute. rewrite PointFree0, PointFree1. reflexivity. Qed. #[global] Instance binapp_pf {A B C D} (f: A → B → C) (g: D → A) (h: D → B) `{!PointFree f f'} `{!PointFree g g'} `{!PointFree h h'}: PointFree (λ x: D, f (g x) (h x)) (uncurry f' ∘ map_pair g' h' ∘ diagonal). Proof. compute. rewrite PointFree0, PointFree1, PointFree2. reflexivity. Qed. #[global] Instance uncur_pf {A B C} (f: A → B → C) `{!PointFree (λ p, f (fst p) (snd p)) f'}: PointFree (uncurry (λ x: A, f x)) f'. Proof. compute. rewrite <- PointFree0. reflexivity. Qed. (* (* In the following tests, the Print's should show that the second argument inferred for PointFree is actually point-free. *) Definition test0: PointFree (@fst (unit*unit) unit) _ := _. Check test0. Definition test1: PointFree (λ x: unit * unit * unit, fst x) _ := _. Check test1. Definition test2: PointFree (λ x: unit * unit * unit, fst (fst x)) _ := _. Check test2. Definition test3: PointFree (λ x: unit, (x, x)) _ := _. Check test3. Definition test4: PointFree (λ x: unit, const x (const x x)) _ := _. Check test4. Definition test5: PointFree (uncurry (λ x y: unit, const x (const y x))) _ := _. Check test5. Definition test6: PointFree (uncurry (λ x y: unit, id y)) _ := _. Check test6. Definition test7: PointFree (uncurry (λ x y: unit, x)) _ := _. Check test7. (* Todo: The set of instances currently generates "uncurry const" (which is equivalent to "fst") sometimes (e.g. for test4 above). If this turns out to be annoying, we can probably get rid of it by adding more specialized and prioritized instances. *) *) corn-8.20.0/util/Qdlog.v000066400000000000000000000232071473720167500147740ustar00rootroot00000000000000(* Discrete logarithm with base 2 and 4 on [Q] *) From Coq Require Import ZArith QArith Qround. Require Import CoRN.stdlib_omissions.Q MathClasses.interfaces.abstract_algebra MathClasses.interfaces.additional_operations MathClasses.interfaces.orders MathClasses.theory.int_pow MathClasses.orders.rationals MathClasses.implementations.stdlib_rationals MathClasses.implementations.positive_semiring_elements. Definition Qdlog2 (x : Q) : Z := match decide_rel (≤) x 1 with | left _ => -Z.log2_up (Qround.Qceiling (/x)) | right _ => Z.log2 (Qround.Qfloor x) end. #[global] Instance: Proper (=) Qdlog2. Proof. intros ? ? E. unfold Qdlog2. do 2 case (decide_rel _); rewrite E; intros; easy. Qed. Lemma Qdlog2_spec (x : Q) : 0 < x → 2 ^ Qdlog2 x ≤ x ∧ x < 2 ^ (1 + Qdlog2 x). Proof. intros E1. unfold Qdlog2. case (decide_rel _); intros E2. destruct (decide (x = 1)) as [E3|E3]. rewrite E3. compute; repeat split; discriminate. assert (1 < Qceiling (/x))%Z. apply (strictly_order_reflecting (cast Z Q)). apply orders.lt_le_trans with (/x). apply dec_fields.flip_lt_dec_recip_r; trivial. apply orders.lt_iff_le_ne. tauto. now apply Qle_ceiling. split. setoid_rewrite int_pow_negate. apply dec_fields.flip_le_dec_recip_l; trivial. transitivity ('Qceiling (/x)). now apply Qle_ceiling. change 2 with ('(2 : Z)). rewrite <-Qpower.Zpower_Qpower. apply (order_preserving _). now apply Z.log2_up_spec. now apply Z.log2_up_nonneg. mc_setoid_replace (1 - Z.log2_up (Qceiling (/x))) with (-Z.pred (Z.log2_up (Qceiling (/x)))). rewrite int_pow_negate. apply dec_fields.flip_lt_dec_recip_r. solve_propholds. apply orders.le_lt_trans with ('Z.pred (Qceiling (/x))). change 2 with ('(2 : Z)). rewrite <-Qpower.Zpower_Qpower. apply (order_preserving _). now apply Z.lt_le_pred, Z.log2_up_spec. now apply Z.lt_le_pred, Z.log2_up_pos. rewrite <-Z.sub_1_r. now apply Qceiling_lt. rewrite <-Z.sub_1_r. change (1 - Z.log2_up (Qceiling (/ x)) = -(Z.log2_up (Qceiling (/ x)) - 1)). now rewrite <-rings.negate_swap_l, commutativity. apply orders.le_flip in E2. split. transitivity ('Qfloor x). change 2 with ('(2 : Z)). rewrite <-Qpower.Zpower_Qpower. apply (order_preserving _). now apply Z.log2_spec, Qfloor_pos. now apply Z.log2_nonneg. now apply Qfloor_le. apply orders.lt_le_trans with ('Z.succ (Qfloor x)). rewrite <-Z.add_1_r. now apply Qlt_floor. rewrite Z.add_1_l. change 2 with ('(2 : Z)). rewrite <-Qpower.Zpower_Qpower. apply (order_preserving _). now apply Z.le_succ_l, Z.log2_spec, Qfloor_pos. now apply Zle_le_succ, Z.log2_nonneg. Qed. Lemma Qdlog2_nonneg (x : Q) : 1 ≤ x → 0 ≤ Qdlog2 x. Proof. intros E. unfold Qdlog2. case (decide_rel _); intros. now mc_setoid_replace x with (1:Q) by now apply (antisymmetry (≤)). apply Z.log2_nonneg. Qed. Lemma Qdlog2_nonpos (x : Q) : x ≤ 1 → Qdlog2 x ≤ 0. Proof. intros E. unfold Qdlog2. case (decide_rel _); intros. apply Z.opp_nonpos_nonneg. now apply Z.log2_up_nonneg. contradiction. Qed. Lemma Qdlog2_0 (x : Q) : 0 < x → Qdlog2 x = 0 → x < 2. Proof. intros E1 E2. pose proof (Qdlog2_spec x E1) as E3. now rewrite E2 in E3. Qed. Lemma Qpos_dlog2_spec (x : Q₊) : '(2 ^ Qdlog2 ('x)) ≤ ('x : Q) ∧ 'x < '(2 ^ (1 + Qdlog2 ('x))). Proof. unfold cast. simpl. split; apply Qdlog2_spec; now destruct x. Qed. Lemma Qdlog2_unique (x : Q) (y : Z) : 0 < x → 2 ^ y ≤ x ∧ x < 2 ^ (1 + y) → y = Qdlog2 x. Proof. intros. apply (antisymmetry (≤)). apply nat_int.le_iff_lt_plus_1. rewrite commutativity. apply int_pow_exp_lt_back with (2%mc : Q); [ apply semirings.lt_1_2 |]. apply orders.le_lt_trans with x; [ intuition |]. now apply Qdlog2_spec. apply nat_int.le_iff_lt_plus_1. rewrite commutativity. apply int_pow_exp_lt_back with (2%mc : Q); [ apply semirings.lt_1_2 |]. apply orders.le_lt_trans with x; [|intuition]. now apply Qdlog2_spec. Qed. Lemma Qdlog2_mult_pow2 (x : Q) (n : Z) : 0 < x → Qdlog2 x + n = Qdlog2 (mult x (2 ^ n)). Proof. intros E. apply Qdlog2_unique. apply pos_mult_compat; [easy | solve_propholds]. split. rewrite int_pow_exp_plus by solve_propholds. apply (order_preserving (.* 2 ^ n)). now apply Qdlog2_spec. rewrite associativity. rewrite int_pow_exp_plus by solve_propholds. apply (strictly_order_preserving (.* 2 ^ n)). now apply Qdlog2_spec. Qed. Lemma Qdlog2_half (x : Q) : 0 < x → Qdlog2 x - 1 = Qdlog2 (mult x (/2)). Proof. intros E. now rewrite Qdlog2_mult_pow2. Qed. Lemma Qdlog2_double (x : Q) : 0 < x → Qdlog2 x + 1 = Qdlog2 (mult x 2). Proof. intros E. now rewrite Qdlog2_mult_pow2. Qed. Lemma Qdlog2_preserving (x y : Q) : 0 < x → x ≤ y → Qdlog2 x ≤ Qdlog2 y. Proof. intros E1 E2. apply nat_int.le_iff_lt_plus_1. rewrite commutativity. apply int_pow_exp_lt_back with (2%mc:Q); [ apply semirings.lt_1_2 |]. apply orders.le_lt_trans with x; [now apply Qdlog2_spec | ]. apply orders.le_lt_trans with y; [assumption |]. apply Qdlog2_spec. now apply orders.lt_le_trans with x. Qed. (* This function computes log n by repeatedly dividing by n. Warning, it only works in case 1 ≤ x and 2 ≤ n. *) Fixpoint Qdlog_bounded (b : nat) (n : Z) (x : Q) : Z := match b with | O => 0 | S c => if (decide_rel (<) x ('n:Q)) then 0 else 1 + Qdlog_bounded c n (x / ('n:Q)) end. Definition Qdlog (n : Z) (x : Q) : Z := Qdlog_bounded (Z.abs_nat (Qdlog2 x)) n x. Lemma Qdlog_bounded_nonneg (b : nat) (n : Z) (x : Q) : 0 ≤ Qdlog_bounded b n x. Proof. revert x. induction b; unfold Qdlog_bounded; [reflexivity |]. intros. case (decide_rel); intros; [reflexivity |]. apply semirings.nonneg_plus_compat ; [easy | apply IHb]. Qed. Lemma Qdlog2_le1 (n : Z) (x : Q) : 2 ≤ n → x ≤ 1 → Qdlog n x = 0. Proof. intros En Ex. unfold Qdlog. generalize (Z.abs_nat (Qdlog2 x)). intros b. induction b; simpl; [reflexivity |]. case (decide_rel); intros E; [reflexivity |]. destruct E. apply orders.le_lt_trans with 1; try assumption. apply orders.lt_le_trans with 2. now apply semirings.lt_1_2. now apply (order_preserving (cast Z Q)) in En. Qed. #[global] Instance: Proper ((=) ==> (=)) Qdlog_bounded. Proof. intros b1 b2 Eb n1 n2 En x1 x2 Ex. change (b1 ≡ b2) in Eb. change (n1 ≡ n2) in En. subst. revert x1 x2 Ex. induction b2; simpl; [reflexivity |]. intros x1 x2 Ex. case (decide_rel); case (decide_rel); intros E1 E2. reflexivity. destruct E1. now rewrite <-Ex. destruct E2. now rewrite Ex. rewrite IHb2; [reflexivity| now rewrite Ex]. Qed. #[global] Instance: Proper ((=) ==> (=)) Qdlog. Proof. unfold Qdlog. intros ? ? E1 ? ? E2. now rewrite E1, E2. Qed. Lemma Qdlog_spec_bounded (b : nat) (n : Z) (x : Q) : 2 ≤ n → Qdlog2 x ≤ ('b) → 1 ≤ x → 'n ^ Qdlog_bounded b n x ≤ x ∧ x < 'n ^ (1 + Qdlog_bounded b n x). Proof. intros En Eb Ex. apply (order_preserving (cast Z Q)) in En. assert (0 < ('n : Q)) by (apply orders.lt_le_trans with 2; [solve_propholds | assumption]). revert x Eb Ex. induction b. intros x Eb Ex. split; [assumption|]. apply orders.lt_le_trans with 2; try assumption. apply Qdlog2_0. apply orders.lt_le_trans with 1; [ solve_propholds | easy]. apply (antisymmetry (≤)); try assumption. now apply Qdlog2_nonneg. intros x Eb Ex. unfold Qdlog_bounded. case (decide_rel); [intuition |]; intros E. apply orders.not_lt_le_flip in E. assert (x = 'n * (x / 'n)) as Ex2. rewrite (commutativity x), associativity. rewrite dec_recip_inverse, rings.mult_1_l; [reflexivity |]. now apply orders.lt_ne_flip. rewrite peano_naturals.S_nat_plus_1, rings.preserves_plus, rings.preserves_1 in Eb. assert (1 ≤ x / 'n). apply (order_reflecting (('n:Q) *.)). now rewrite <-Ex2, rings.mult_1_r. destruct (IHb (x / 'n)); trivial. transitivity (Qdlog2 (x /2)%mc). apply Qdlog2_preserving. apply orders.lt_le_trans with 1; [solve_propholds | assumption]. apply (maps.order_preserving_nonneg (.*.) x). now transitivity (1:Q). apply dec_fields.flip_le_dec_recip; [solve_propholds | assumption]. rewrite <-Qdlog2_half. now apply rings.flip_le_minus_l. now apply orders.lt_le_trans with 1; [solve_propholds | assumption]. fold Qdlog_bounded. setoid_rewrite int_pow_S_nonneg at 1. 2: apply Qdlog_bounded_nonneg. setoid_rewrite int_pow_S_nonneg. 2: (apply semirings.nonneg_plus_compat; [easy | now apply Qdlog_bounded_nonneg]). setoid_rewrite Ex2 at 2 3. split. now apply (order_preserving (('n:Q) *.)). now apply (strictly_order_preserving (('n:Q) *.)). Qed. Lemma Qdlog_spec (n : Z) (x : Q) : 2 ≤ n → 1 ≤ x → 'n ^ Qdlog n x ≤ x ∧ x < 'n ^ (1 + Qdlog n x). Proof. intros. apply Qdlog_spec_bounded; trivial. rewrite inj_Zabs_nat, Z.abs_eq; [reflexivity |]. now apply Qdlog2_nonneg. Qed. Definition Qdlog4 (x : Q) : Z := Z.div (Qdlog2 x) 2. #[global] Instance: Proper (=) Qdlog4. Proof. unfold Qdlog4. intros ? ? E. now rewrite E. Qed. Lemma Qdlog4_spec (x : Q) : 0 < x → 4 ^ Qdlog4 x ≤ x ∧ x < 4 ^ (1 + Qdlog4 x). Proof. intros E1. unfold Qdlog4. change (4%mc:Q) with ((2%mc:Q) ^ (2:Z))%mc. rewrite <-2!int_pow_exp_mult. split. etransitivity. 2: now apply Qdlog2_spec. apply int_pow_exp_le; [easy|]. now apply Z.mul_div_le. eapply orders.lt_le_trans. now apply Qdlog2_spec. apply int_pow_exp_le; [apply semirings.le_1_2 |]. apply nat_int.le_iff_lt_plus_1. rewrite commutativity. apply (strictly_order_preserving (+1)). change (1 + (Qdlog2 x / 2)%Z) with (1 + Z.div (Qdlog2 x) 2)%Z. rewrite (Z.add_1_l (Z.div (Qdlog2 x) 2)). now apply Z.mul_succ_div_gt. Qed. corn-8.20.0/util/Qgcd.v000066400000000000000000000051641473720167500146060ustar00rootroot00000000000000From Coq Require Import QArith. Require Import CoRN.model.Zmod.ZGcd CoRN.model.totalorder.QposMinMax CoRN.stdlib_omissions.Q. Open Scope Q_scope. Definition Qgcd (a b: Q): Q := Zgcd_nat (Qnum a * Qden b) (Qnum b * Qden a) # (Qden a * Qden b). Lemma Qgcd_sym (a b: Q): Qgcd a b = Qgcd b a. Proof. unfold Qgcd. intros. rewrite Zgcd_nat_sym. rewrite Pmult_comm. reflexivity. Qed. Lemma Qgcd_divides (a b: Q): exists c: Z, inject_Z c * Qgcd a b == a. Proof. revert a b. intros [an ad] [bn bd]. unfold Qgcd. simpl. destruct (Zgcd_nat_divides (an * bd) (bn * ad)) as [c E]. exists c. unfold Qmult, Qeq. simpl. rewrite E, Zpos_mult_morphism. ring. Qed. Lemma Qgcd_nonneg a b: 0 <= Qgcd a b. Proof. revert a b. intros [an ad] [bn bd]. simpl. unfold Qle. simpl. auto with *. Qed. #[global] Hint Immediate Qgcd_nonneg. Program Definition Qcd_pos: Qpos -> Qpos -> Qpos := Qgcd. Next Obligation. Proof with auto. simpl. destruct (Qle_lt_or_eq 0 _ (Qgcd_nonneg (proj1_sig x) (proj1_sig x0))) as [| B]... exfalso. destruct x. destruct (Qgcd_divides x (proj1_sig x0)) as [? E]. simpl in *. revert q. rewrite <- E, <- B, Qmult_0_r. apply Qlt_irrefl. Qed. Lemma Qgcd_pos_divides (a b: Qpos): exists c: positive, inject_Z c * proj1_sig (Qcd_pos a b) == proj1_sig a. Proof with auto with *. revert a b. intros [a ap] [b bp]. simpl. destruct (Qgcd_divides a b) as [x E]. destruct x. exfalso. ring_simplify in E. revert ap. rewrite E. apply Qlt_irrefl. exists p... exfalso. rewrite <- E in ap. apply (Qlt_irrefl 0). apply Qlt_le_trans with (inject_Z (Zneg p) * Qgcd a b)... rewrite Qmult_comm. apply Qmult_nonneg_nonpos... Qed. Lemma Qpos_gcd3 (a b c: Qpos): exists g: Qpos, exists i: positive, inject_Z i * proj1_sig g == proj1_sig a /\ exists j: positive, inject_Z j * proj1_sig g == proj1_sig b /\ exists k: positive, inject_Z k * proj1_sig g == proj1_sig c. Proof with auto. intros. exists (Qcd_pos a (Qcd_pos b c)). destruct (Qgcd_pos_divides b c) as [x E]. destruct (Qgcd_pos_divides c b) as [x0 F]. simpl in F. rewrite Qgcd_sym in F. change (inject_Z x0 * proj1_sig (Qcd_pos b c) == proj1_sig c) in F. revert E F. generalize (Qcd_pos b c). intros. destruct (Qgcd_pos_divides a q) as [x1 G]. destruct (Qgcd_pos_divides q a) as [x2 H]. simpl in H. rewrite Qgcd_sym in H. change (inject_Z x2 * proj1_sig (Qcd_pos a q) == proj1_sig q) in H. exists x1. revert G H. generalize (Qcd_pos a q). split... exists (x * x2)%positive. split. rewrite Q.Pmult_Qmult. rewrite <- Qmult_assoc. rewrite H... exists (x0 * x2)%positive. rewrite Q.Pmult_Qmult. rewrite <- Qmult_assoc. rewrite H... Qed. corn-8.20.0/util/Qsums.v000066400000000000000000000153731473720167500150430ustar00rootroot00000000000000From Coq Require Import ZArith. Require Import CoRN.stdlib_omissions.List. From Coq Require Import QArith Qabs. Require Import CoRN.model.totalorder.QposMinMax CoRN.model.metric2.Qmetric. From Coq Require Import Program. Require Import CoRN.stdlib_omissions.N CoRN.stdlib_omissions.Z CoRN.stdlib_omissions.Q. Open Scope Q_scope. Definition Qsum := fold_right Qplus 0. Definition Σ (n: nat) (f: nat -> Q) := Qsum (map f (enum n)). (** Properties of Σ: *) Lemma Σ_sub f g n: Σ n f - Σ n g == Σ n (fun x => f x - g x). Proof. unfold Σ. induction n. reflexivity. simpl. rewrite <- IHn. ring. Qed. Lemma Σ_mult n f k: Σ n f * k == Σ n (Qmult k ∘ f). Proof. unfold Σ, Basics.compose. induction n. reflexivity. intros. simpl. rewrite <- IHn. ring. Qed. Lemma Σ_constant x n f: (forall i, (i < n)%nat -> f i == x) -> Σ n f == inject_Z (Z.of_nat n) * x. Proof with auto. unfold Σ. induction n. reflexivity. simpl. intro E. rewrite IHn... rewrite E... rewrite P_of_succ_nat_Zplus. rewrite Q.Zplus_Qplus. ring. Qed. Lemma Σ_const x n: Σ n (fun _ => x) == inject_Z (Z.of_nat n) * x. Proof. apply Σ_constant. reflexivity. Qed. Lemma Σ_S_bound_back f n: Σ (S n) f == Σ n f + f n. Proof. unfold Σ. simpl. ring. Qed. Lemma Σ_S_bound_front n f: Σ (S n) f == Σ n (f ∘ S) + f O. Proof. unfold Σ, Basics.compose. induction n; intros; simpl in *. ring. rewrite IHn. ring. Qed. Lemma Σ_S_bound_rev n f: Σ n (f ∘ S) == Σ (S n) f - f O. Proof. rewrite Σ_S_bound_front. ring. Qed. Lemma Σ_le f n (b: Q): (forall x, (x < n)%nat -> f x <= b) -> Σ n f <= inject_Z (Z.of_nat n) * b. Proof. induction n. discriminate. intro. rewrite Q.S_Qplus. change (f n + Σ n f <= (inject_Z (Z.of_nat n) + 1) * b)%Q. assert ((inject_Z (Z.of_nat n) + 1) * b == b + inject_Z (Z.of_nat n) * b)%Q as E. ring. rewrite E. apply Qplus_le_compat; auto. Qed. Lemma Σ_abs_le f n (b: Q): (forall x, (x < n)%nat -> Qabs (f x) <= b) -> Qabs (Σ n f) <= inject_Z (Z.of_nat n) * b. Proof. induction n. discriminate. intros. rewrite S_Zplus. rewrite Q.Zplus_Qplus. change (Qabs (f n + Σ n f) <= (inject_Z (Z.of_nat n) + 1) * b)%Q. assert ((inject_Z (Z.of_nat n) + 1) * b == b + inject_Z (Z.of_nat n) * b)%Q. ring. rewrite H0. clear H0. apply Qle_trans with (Qabs (f n) + Qabs (Σ n f))%Q. apply Qabs_triangle. apply Qplus_le_compat; auto. Qed. Lemma Σ_wd f g n (H: forall x, (x < n)%nat -> f x == g x): Σ n f == Σ n g. Proof with auto with *. unfold Σ. induction n; simpl... rewrite IHn... rewrite H... Qed. Lemma Σ_plus_bound m n f: Σ (m + n) f == Σ n f + Σ m (f ∘ plus n). Proof with try reflexivity. induction m; simpl; intros. unfold Σ. simpl. ring. do 2 rewrite Σ_S_bound_back. rewrite Qplus_assoc. rewrite <- IHm. unfold Basics.compose. replace (f (m + n)%nat) with (f (n + m)%nat)... rewrite Nat.add_comm... Qed. Lemma Σ_mult_bound n m f: Σ (n * m) f == Σ n (fun i => Σ m (fun j => f (i * m + j)%nat)). Proof. induction n; intros. reflexivity. unfold Σ in *. simpl. rewrite <- IHn. change (Σ (m + n * m) f == Σ m (fun j => f (n * m + j)%nat) + Σ (n * m) f). rewrite Σ_plus_bound. unfold Basics.compose. ring. Qed. Lemma Σ_Qball (f g: nat -> Q) (e: Q) (n: nat): 0 <= e -> (forall i: nat, (i < n)%nat -> Qabs (f i - g i) <= e / inject_Z (Z.of_nat n)) -> Qball e (Σ n f) (Σ n g). Proof with auto. intros epos H. apply Qball_Qabs. destruct n. simpl. exact epos. rewrite Σ_sub. setoid_replace e with (inject_Z (Z.of_nat (S n)) * (/ inject_Z (Z.of_nat (S n)) * e)). apply Σ_abs_le. intros ? E. specialize (H x E). rewrite Qmult_comm. assumption. unfold canonical_names.equiv, stdlib_rationals.Q_eq. field. discriminate. Qed. Lemma Σ_Qball_pos_bounds (f g: nat -> Q) (e: Q) (n: positive): (forall i: nat, (i < Pos.to_nat n)%nat -> Qball (e * (1#n)) (f i) (g i)) -> Qball e (Σ (Pos.to_nat n) f) (Σ (Pos.to_nat n) g). Proof with intuition. intros. assert (0 <= e). { specialize (H O (Pos2Nat.is_pos n)). apply (msp_nonneg (msp (Q_as_MetricSpace))) in H. rewrite <- (Qmult_0_l (1#n)) in H. apply Qmult_le_r in H. exact H. reflexivity. } apply Σ_Qball. exact H0. intros. setoid_replace (e / inject_Z (Z.of_nat (nat_of_P n))) with (e * (1#n)). apply Qball_Qabs... unfold canonical_names.equiv, stdlib_rationals.Q_eq. rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P... Qed. Lemma Qmult_Σ (f: nat -> Q) n (k: nat): Σ n f * inject_Z (Z.of_nat k) == Σ (k * n) (f ∘ flip Nat.div k). Proof with auto with *. unfold Basics.compose. rewrite Nat.mul_comm. rewrite Σ_mult_bound. unfold Qdiv. rewrite Σ_mult. apply Σ_wd. intros. unfold Basics.compose. rewrite (Σ_constant (f x))... intros. unfold flip. replace ((x * k + i) / k)%nat with x... apply (Nat.div_unique (x * k + i)%nat k x i)... Qed. Lemma Σ_multiply_bound (n:nat) (k: positive) (f: nat -> Q): Σ n f == Σ (Pos.to_nat k * n) (f ∘ flip Nat.div (Pos.to_nat k)) / inject_Z (Zpos k). Proof. rewrite <- Qmult_Σ. rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. field. discriminate. Qed. Lemma Qball_hetero_Σ (n m: positive) f g (e:Q): (forall i: nat, (i < Pos.to_nat (n * m)%positive)%nat -> Qball (e * (1# (n * m)%positive)) (/ inject_Z (Zpos m) * f (i / Pos.to_nat m)%nat) (/ inject_Z (Zpos n) * g (i / Pos.to_nat n)%nat)) -> Qball e (Σ (Pos.to_nat n) f) (Σ (Pos.to_nat m) g). Proof. intros. rewrite (Σ_multiply_bound (Pos.to_nat n) m). rewrite (Σ_multiply_bound (nat_of_P m) n). rewrite Nat.mul_comm. rewrite <- nat_of_P_mult_morphism. unfold Qdiv. rewrite Σ_mult. rewrite Σ_mult. apply Σ_Qball_pos_bounds. intros. unfold Basics.compose. unfold flip. auto. Qed. (** Σ was defined above straightforwardly in terms of ordinary lists and without any efficiency consideration. In practice, building up a list with enum only to break it down immediately with Qsum is wasteful, and I strongly doubt Coq does list deforestation/fusion. Also, summing many Q's quickly yields large numerators and denominators. Hence, we now define a faster version which avoids the intermediate lists and uses Qred. The idea is to use fastΣ in the actual definition of operations, and to immediately rewrite it to Σ (using the correctness property) when doing proofs about said operations. *) Section fastΣ. Fixpoint fast (f: nat -> Q) (left: nat) (sofar: Q): Q := match left with | O => sofar | S n => fast f n (Qred (sofar + f n)) end. Definition fastΣ (n: nat) (f: nat -> Q): Q := fast f n 0. Lemma fastΣ_correct n f: fastΣ n f == Σ n f. Proof. intros. rewrite <- (Qplus_0_r (Σ n f)). unfold Σ, fastΣ. generalize 0. induction n; intros. simpl. ring. change (fast f n (Qred (q + f n)) == Qsum (map f (enum (S n))) + q). rewrite IHn. rewrite Qred_correct. simpl. ring. Qed. End fastΣ. corn-8.20.0/util/SetoidPermutation.v000066400000000000000000000072001473720167500174000ustar00rootroot00000000000000Require Import Coq.Unicode.Utf8 Coq.Setoids.Setoid CoRN.stdlib_omissions.List Coq.Sorting.Permutation Coq.Setoids.Setoid Coq.Classes.Morphisms. (** The standard Permutation property is not setoid-aware, so we introduce a variant that is. *) Section def. Context {A: Type} (e: relation A) `{!Equivalence e}. Inductive SetoidPermutation: list A → list A → Prop := | s_perm_nil : SetoidPermutation nil nil | s_perm_skip x y: e x y -> ∀ l l', SetoidPermutation l l' → SetoidPermutation (x :: l) (y :: l') | s_perm_swap x y l: SetoidPermutation (y :: x :: l) (x :: y :: l) | s_perm_trans l l' l'': SetoidPermutation l l' → SetoidPermutation l' l'' → SetoidPermutation l l''. Hint Constructors SetoidPermutation. Global Instance: Equivalence SetoidPermutation. Proof with eauto; intuition. constructor... intro l. induction l... intros x y H. induction H... Qed. Global Instance: Proper (list_eq e ==> list_eq e ==> iff) SetoidPermutation. Proof with eauto. assert (forall a b, list_eq e a b → SetoidPermutation a b). intros ?? E. apply (@list_eq_rect _ e SetoidPermutation); auto. intros ?? E ?? F. split; intro. symmetry in E... symmetry in F... Qed. End def. #[global] Hint Constructors SetoidPermutation Permutation. Lemma SetoidPermutation_stronger {A} (R U: relation A): (forall x y: A, R x y → U x y) → forall a b, SetoidPermutation R a b → SetoidPermutation U a b. Proof. intros ??? P. induction P; eauto. Qed. (** With eq for the element relation, SetoidPermutation is directly equivalent to Permutation: *) Lemma SetoidPermutation_eq {A} (a b: list A): SetoidPermutation eq a b ↔ Permutation a b. Proof. split; intro; induction H; eauto. subst; eauto. Qed. (** And since eq is stronger than any other equivalence, SetoidPermutation always follows from Permutation: *) Lemma SetoidPermutation_from_Permutation {A} (e: relation A) `{!Reflexive e} (a b: list A): Permutation a b → SetoidPermutation e a b. Proof. intro. apply SetoidPermutation_stronger with eq. intros. subst. reflexivity. apply SetoidPermutation_eq. assumption. Qed. (** In general, SetoidPermutation is equivalent to Permutation modulo setoid list equivalence: *) Lemma SetoidPermutation_meaning {A} (R: relation A) `{!Equivalence R} (x y: list A): SetoidPermutation R x y ↔ ∃ y', list_eq R x y' ∧ Permutation y y'. Proof with auto. split. intro H. induction H. exists nil. intuition. destruct IHSetoidPermutation as [?[??]]. exists (y :: x0). repeat split... exists (y :: x :: l). split... reflexivity. destruct IHSetoidPermutation1 as [x [H1 H3]]. destruct IHSetoidPermutation2 as [x0 [H2 H4]]. symmetry in H3. destruct (Perm_list_eq_commute R x l' x0 H3 H2). exists x1. split. transitivity x; intuition. transitivity x0; intuition. intros [?[E?]]. rewrite E. symmetry. apply SetoidPermutation_from_Permutation... apply _. Qed. #[global] Instance map_perm_proper {A B} (Ra: relation A) (Rb: relation B): Equivalence Ra → Equivalence Rb → Proper ((Ra ==> Rb) ==> SetoidPermutation Ra ==> SetoidPermutation Rb) (@map A B). Proof with simpl; auto; try reflexivity. intros ??????? X. induction X; simpl... apply s_perm_trans with (x y0 :: x x0 :: map y l). apply s_perm_skip... apply s_perm_skip... induction l... intuition. apply s_perm_trans with (y y0 :: y x0 :: map y l)... unfold respectful in *. apply s_perm_skip. intuition. apply s_perm_skip... intuition. apply s_perm_trans with (map y l')... apply s_perm_trans with (map x l')... clear IHX1 IHX2 X1 X2. induction l'... constructor. now symmetry; apply H1. easy. Qed. corn-8.20.0/write_image/000077500000000000000000000000001473720167500150525ustar00rootroot00000000000000corn-8.20.0/write_image/README000066400000000000000000000003451473720167500157340ustar00rootroot00000000000000write_image writes a CoRN "sparse_raster" to a file in PPM (portable pixmap) format. Usage: Require Import CoRN.write_image.WritePPM. Elpi WritePPM ".ppm" ( ). corn-8.20.0/write_image/WritePPM.v000066400000000000000000000142711473720167500167150ustar00rootroot00000000000000(** * Write a CoRN sparse-raster as PPM file (portable pix map) *) (* The conversion from a sparse-raster to a 2D list of bools is done as Coq program. *) (* The output of the Pixmap to a file in PPM is done as Elpi program (Elpi is correctly the only tactic language which allows to write files) *) From CoRN Require Import Plot RasterQ Qmetric. Require Import ZArith. Require Import Orders. Require Import Mergesort. Require Import List. Import ListNotations. Require Import Lia. Require Import elpi.elpi. (** A module for sorting the points of the sparse raster first by y and then by x coordinate *) Module SparseRasterOrder <: TotalLeBool. Definition t := (Z*Z)%type. Definition leb (x y : t) := let (x1,x2):=x in let (y1,y2):=y in Z.ltb x1 y1 || (Z.eqb x1 y1) && (Z.leb x2 y2). Theorem leb_total : forall x y : t, (eq (leb x y) true) \/ (eq (leb y x) true). Proof. intros x y. unfold leb. destruct x as [x1 x2], y as [y1 y2]. lia. (* I love lia so much! *) Qed. End SparseRasterOrder. Module Import SparseRasterSort := Sort SparseRasterOrder. (* The function sorts a list of (x,y) pairs first be y and then by x coordinate *) Local Example SparseRasterSort'Ex1: eq (SparseRasterSort.sort [(2, 1); (2, 2); (0, 2); (0, 1); (1, 1); (1, 0)]%Z) [(0, 1); (0, 2); (1, 0); (1, 1); (2, 1); (2, 2)]%Z. Proof. reflexivity. Qed. Fixpoint sparseRasterSorted_getLine (data : list (Z*Z)) (row : Z) : (list Z) * (list (Z*Z)) := match data with | [] => ([], []) | (y,x)::t => if Z.eqb y row then let (current,rest) := sparseRasterSorted_getLine t row in (x::current, rest) else ([],data) end. (* If row matches the y coordinate of the first element, the function returns the list of the x coordinates of the leading elements with this y coordinate and the remaining (x,y) pairs *) Local Example sparseRasterSorted_getLine'Ex1: eq (sparseRasterSorted_getLine [(0, 1); (0, 2); (1, 0); (1, 1); (2, 1); (2, 2)]%Z 0) ([1; 2]%Z, [(1, 0); (1, 1); (2, 1); (2, 2)]%Z). Proof. reflexivity. Qed. (* Otherwise the x coordinate list is empty and the (x,y) pair list is returned unaltered *) Local Example sparseRasterSorted_getLine'Ex2: eq (sparseRasterSorted_getLine [(0, 1); (0, 2); (1, 0); (1, 1); (2, 1); (2, 2)]%Z 1) ([], [(0, 1); (0, 2); (1, 0); (1, 1); (2, 1); (2, 2)]%Z). Proof. reflexivity. Qed. Definition listSorted_removeDuplicates {T : Type} (eqb : T->T->bool) (data : list T) := let fix aux (data : list T) := match data with | [] => data | [a] => data | a::(b::t) as t'=> if eqb a b then aux t' else a::(aux t') end in aux data. Local Example listSorted_removeDuplicates'Ex1: eq (listSorted_removeDuplicates Z.eqb [1;2;2;3;3;3]%Z) [1;2;3]%Z. Proof. reflexivity. Qed. Definition sparseRasterLine_rasterize (width : positive) (row : list Z) : list bool := let fix aux (width : nat) (x : Z) (row : list Z) : list bool := match width, row with | O, _ => [] | S w', [] => false :: (aux w' 0%Z row) | S w', h::t => if Z.eqb h x then true :: (aux w' (x+1)%Z t) else false :: (aux w' (x+1)%Z row) end in aux (Pos.to_nat width) 0%Z (listSorted_removeDuplicates Z.eqb row). Local Example sparseRasterLine_rasterize'Ex1: eq (sparseRasterLine_rasterize 10%positive [2;4;4;5]%Z) [false; false; true; false; true; true; false; false; false; false]. Proof. reflexivity. Qed. Definition sparseRaster_rasterize {width height : positive} (sr : sparse_raster width height) : positive * positive * list (list bool) := let '(sparse_raster_data _ _ data) := sr in let data_sorted := SparseRasterSort.sort data in let fix aux (nrows : nat) (irow : Z) (rest : list (Z*Z)) := match nrows with | O => [] | S nrows' => let (row, rest') := sparseRasterSorted_getLine rest irow in let rownd := listSorted_removeDuplicates Z.eqb row in sparseRasterLine_rasterize width row :: aux nrows' (irow+1)%Z rest' end in (width, height, aux (Pos.to_nat height) 0%Z data_sorted). Local Example sparseRaster_rasterize'Ex1 : eq (sparseRaster_rasterize (sparse_raster_data 3 4 [(3, 1); (3, 2); (0, 2); (0, 1); (1, 1); (1, 0)]%Z)) (3%positive, 4%positive, [ [false; true; true ]; [true; true; false]; [false; false; false]; [false; true; true ] ] ). Proof. reflexivity. Qed. Elpi Command WritePPM. Elpi Accumulate lp:{{ % Convert a Coq positive to an ELpi int pred coq-pos->elpi-int i:term, o:int. coq-pos->elpi-int {{ xH }} 1 :- !. coq-pos->elpi-int {{ xO lp:X }} Y :- calc (2 * { coq-pos->elpi-int X} ) Y, !. coq-pos->elpi-int {{ xI lp:X }} Y :- calc (2 * { coq-pos->elpi-int X} + 1) Y, !. coq-pos->elpi-int T I :- coq.say "coq-pos->elpi-int: Unexpected term" T I, !. % Convert a CoRN "sparse_raster" to a 2D Coq list of booleans pred sparse-raster-rasterize i:term, o:int, o:int, o:term. sparse-raster-rasterize DC NRE NCE DCR :- coq.reduction.vm.norm {{ sparseRaster_rasterize lp:DC }} _ {{ (lp:NRC, lp:NCC, lp:DCR) }}, coq-pos->elpi-int NRC NRE, coq-pos->elpi-int NCC NCE, !. sparse-raster-rasterize T _ _ _ :- coq.say "sparse-raster-rasterize: Unexpected term" T, !. % Convert a Coq list of booleans to an Elpi 01 string with "\n" termination pred raster-row-to-string i:term, o:string. raster-row-to-string {{ [] }} "\n". raster-row-to-string {{ false :: lp:T }} S :- raster-row-to-string T TS, calc ("0" ^ TS) S. raster-row-to-string {{ true :: lp:T }} S :- raster-row-to-string T TS, calc ("1" ^ TS) S. raster-row-to-string T _ :- coq.say "raster-row-to-string: Unexpected term" T. % Write a Coq 2D list of booleans as lines of 01 data to an output stream pred raster-write-rows i:out_stream, i:term. raster-write-rows _ {{ [] }}. raster-write-rows OS {{ lp:ROW :: lp:T }} :- raster-row-to-string ROW ROWS, output OS ROWS, raster-write-rows OS T. % Main function of command main [str FILEPATH, trm PM] :- sparse-raster-rasterize PM PMNR PMNC PMData, % Write PPM header open_out FILEPATH OSTREAM, output OSTREAM "P1\n", output OSTREAM { calc (int_to_string PMNR) }, output OSTREAM " ", output OSTREAM { calc (int_to_string PMNC) }, output OSTREAM "\n", % Write PPM data raster-write-rows OSTREAM PMData, close_out OSTREAM . }}. corn-8.20.0/write_image/_CoqProject000066400000000000000000000000421473720167500172010ustar00rootroot00000000000000-R . CoRN.write_image WritePPM.v