pax_global_header00006660000000000000000000000064147054763130014524gustar00rootroot0000000000000052 comment=b169373158ea42e3f98bc8ac733d13129acf6155 interval-4.11.1/000077500000000000000000000000001470547631300134345ustar00rootroot00000000000000interval-4.11.1/AUTHORS000066400000000000000000000010511470547631300145010ustar00rootroot00000000000000Guillaume Melquiond The following people have made major contributions to CoqInterval: Érik Martin-Dorel Pierre Roux Thomas Sibut-Pinote The following people are the original authors of CoqApprox (src/Poly): Érik Martin-Dorel Micaela Mayero Ioana Pasca Laurence Rideau Laurent Théry interval-4.11.1/COPYING000066400000000000000000000525471470547631300145040ustar00rootroot00000000000000 CeCILL-C FREE SOFTWARE LICENSE AGREEMENT Notice This Agreement is a Free Software license agreement that is the result of discussions between its authors in order to ensure compliance with the two main principles guiding its drafting: * firstly, compliance with the principles governing the distribution of Free Software: access to source code, broad rights granted to users, * secondly, the election of a governing law, French law, with which it is conformant, both as regards the law of torts and intellectual property law, and the protection that it offers to both authors and holders of the economic rights over software. The authors of the CeCILL-C (for Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) license are: Commissariat à l'Energie Atomique - CEA, a public scientific, technical and industrial research establishment, having its principal place of business at 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris, France. Centre National de la Recherche Scientifique - CNRS, a public scientific and technological establishment, having its principal place of business at 3 rue Michel-Ange, 75794 Paris cedex 16, France. Institut National de Recherche en Informatique et en Automatique - INRIA, a public scientific and technological establishment, having its principal place of business at Domaine de Voluceau, Rocquencourt, BP 105, 78153 Le Chesnay cedex, France. Preamble The purpose of this Free Software license agreement is to grant users the right to modify and re-use the software governed by this license. The exercising of this right is conditional upon the obligation to make available to the community the modifications made to the source code of the software so as to contribute to its evolution. In consideration of access to the source code and the rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the software's author, the holder of the economic rights, and the successive licensors only have limited liability. In this respect, the risks associated with loading, using, modifying and/or developing or reproducing the software by the user are brought to the user's attention, given its Free Software status, which may make it complicated to use, with the result that its use is reserved for developers and experienced professionals having in-depth computer knowledge. Users are therefore encouraged to load and test the suitability of the software as regards their requirements in conditions enabling the security of their systems and/or data to be ensured and, more generally, to use and operate it in the same conditions of security. This Agreement may be freely reproduced and published, provided it is not altered, and that no provisions are either added or removed herefrom. This Agreement may apply to any or all software for which the holder of the economic rights decides to submit the use thereof to its provisions. Article 1 - DEFINITIONS For the purpose of this Agreement, when the following expressions commence with a capital letter, they shall have the following meaning: Agreement: means this license agreement, and its possible subsequent versions and annexes. Software: means the software in its Object Code and/or Source Code form and, where applicable, its documentation, "as is" when the Licensee accepts the Agreement. Initial Software: means the Software in its Source Code and possibly its Object Code form and, where applicable, its documentation, "as is" when it is first distributed under the terms and conditions of the Agreement. Modified Software: means the Software modified by at least one Integrated Contribution. Source Code: means all the Software's instructions and program lines to which access is required so as to modify the Software. Object Code: means the binary files originating from the compilation of the Source Code. Holder: means the holder(s) of the economic rights over the Initial Software. Licensee: means the Software user(s) having accepted the Agreement. Contributor: means a Licensee having made at least one Integrated Contribution. Licensor: means the Holder, or any other individual or legal entity, who distributes the Software under the Agreement. Integrated Contribution: means any or all modifications, corrections, translations, adaptations and/or new functions integrated into the Source Code by any or all Contributors. Related Module: means a set of sources files including their documentation that, without modification to the Source Code, enables supplementary functions or services in addition to those offered by the Software. Derivative Software: means any combination of the Software, modified or not, and of a Related Module. Parties: mean both the Licensee and the Licensor. These expressions may be used both in singular and plural form. Article 2 - PURPOSE The purpose of the Agreement is the grant by the Licensor to the Licensee of a non-exclusive, transferable and worldwide license for the Software as set forth in Article 5 hereinafter for the whole term of the protection granted by the rights over said Software. Article 3 - ACCEPTANCE 3.1 The Licensee shall be deemed as having accepted the terms and conditions of this Agreement upon the occurrence of the first of the following events: * (i) loading the Software by any or all means, notably, by downloading from a remote server, or by loading from a physical medium; * (ii) the first time the Licensee exercises any of the rights granted hereunder. 3.2 One copy of the Agreement, containing a notice relating to the characteristics of the Software, to the limited warranty, and to the fact that its use is restricted to experienced users has been provided to the Licensee prior to its acceptance as set forth in Article 3.1 hereinabove, and the Licensee hereby acknowledges that it has read and understood it. Article 4 - EFFECTIVE DATE AND TERM 4.1 EFFECTIVE DATE The Agreement shall become effective on the date when it is accepted by the Licensee as set forth in Article 3.1. 4.2 TERM The Agreement shall remain in force for the entire legal term of protection of the economic rights over the Software. Article 5 - SCOPE OF RIGHTS GRANTED The Licensor hereby grants to the Licensee, who accepts, the following rights over the Software for any or all use, and for the term of the Agreement, on the basis of the terms and conditions set forth hereinafter. Besides, if the Licensor owns or comes to own one or more patents protecting all or part of the functions of the Software or of its components, the Licensor undertakes not to enforce the rights granted by these patents against successive Licensees using, exploiting or modifying the Software. If these patents are transferred, the Licensor undertakes to have the transferees subscribe to the obligations set forth in this paragraph. 5.1 RIGHT OF USE The Licensee is authorized to use the Software, without any limitation as to its fields of application, with it being hereinafter specified that this comprises: 1. permanent or temporary reproduction of all or part of the Software by any or all means and in any or all form. 2. loading, displaying, running, or storing the Software on any or all medium. 3. entitlement to observe, study or test its operation so as to determine the ideas and principles behind any or all constituent elements of said Software. This shall apply when the Licensee carries out any or all loading, displaying, running, transmission or storage operation as regards the Software, that it is entitled to carry out hereunder. 5.2 RIGHT OF MODIFICATION The right of modification includes the right to translate, adapt, arrange, or make any or all modifications to the Software, and the right to reproduce the resulting software. It includes, in particular, the right to create a Derivative Software. The Licensee is authorized to make any or all modification to the Software provided that it includes an explicit notice that it is the author of said modification and indicates the date of the creation thereof. 5.3 RIGHT OF DISTRIBUTION In particular, the right of distribution includes the right to publish, transmit and communicate the Software to the general public on any or all medium, and by any or all means, and the right to market, either in consideration of a fee, or free of charge, one or more copies of the Software by any means. The Licensee is further authorized to distribute copies of the modified or unmodified Software to third parties according to the terms and conditions set forth hereinafter. 5.3.1 DISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION The Licensee is authorized to distribute true copies of the Software in Source Code or Object Code form, provided that said distribution complies with all the provisions of the Agreement and is accompanied by: 1. a copy of the Agreement, 2. a notice relating to the limitation of both the Licensor's warranty and liability as set forth in Articles 8 and 9, and that, in the event that only the Object Code of the Software is redistributed, the Licensee allows effective access to the full Source Code of the Software at a minimum during the entire period of its distribution of the Software, it being understood that the additional cost of acquiring the Source Code shall not exceed the cost of transferring the data. 5.3.2 DISTRIBUTION OF MODIFIED SOFTWARE When the Licensee makes an Integrated Contribution to the Software, the terms and conditions for the distribution of the resulting Modified Software become subject to all the provisions of this Agreement. The Licensee is authorized to distribute the Modified Software, in source code or object code form, provided that said distribution complies with all the provisions of the Agreement and is accompanied by: 1. a copy of the Agreement, 2. a notice relating to the limitation of both the Licensor's warranty and liability as set forth in Articles 8 and 9, and that, in the event that only the object code of the Modified Software is redistributed, the Licensee allows effective access to the full source code of the Modified Software at a minimum during the entire period of its distribution of the Modified Software, it being understood that the additional cost of acquiring the source code shall not exceed the cost of transferring the data. 5.3.3 DISTRIBUTION OF DERIVATIVE SOFTWARE When the Licensee creates Derivative Software, this Derivative Software may be distributed under a license agreement other than this Agreement, subject to compliance with the requirement to include a notice concerning the rights over the Software as defined in Article 6.4. In the event the creation of the Derivative Software required modification of the Source Code, the Licensee undertakes that: 1. the resulting Modified Software will be governed by this Agreement, 2. the Integrated Contributions in the resulting Modified Software will be clearly identified and documented, 3. the Licensee will allow effective access to the source code of the Modified Software, at a minimum during the entire period of distribution of the Derivative Software, such that such modifications may be carried over in a subsequent version of the Software; it being understood that the additional cost of purchasing the source code of the Modified Software shall not exceed the cost of transferring the data. 5.3.4 COMPATIBILITY WITH THE CeCILL LICENSE When a Modified Software contains an Integrated Contribution subject to the CeCILL license agreement, or when a Derivative Software contains a Related Module subject to the CeCILL license agreement, the provisions set forth in the third item of Article 6.4 are optional. Article 6 - INTELLECTUAL PROPERTY 6.1 OVER THE INITIAL SOFTWARE The Holder owns the economic rights over the Initial Software. Any or all use of the Initial Software is subject to compliance with the terms and conditions under which the Holder has elected to distribute its work and no one shall be entitled to modify the terms and conditions for the distribution of said Initial Software. The Holder undertakes that the Initial Software will remain ruled at least by this Agreement, for the duration set forth in Article 4.2. 6.2 OVER THE INTEGRATED CONTRIBUTIONS The Licensee who develops an Integrated Contribution is the owner of the intellectual property rights over this Contribution as defined by applicable law. 6.3 OVER THE RELATED MODULES The Licensee who develops a Related Module is the owner of the intellectual property rights over this Related Module as defined by applicable law and is free to choose the type of agreement that shall govern its distribution under the conditions defined in Article 5.3.3. 6.4 NOTICE OF RIGHTS The Licensee expressly undertakes: 1. not to remove, or modify, in any manner, the intellectual property notices attached to the Software; 2. to reproduce said notices, in an identical manner, in the copies of the Software modified or not; 3. to ensure that use of the Software, its intellectual property notices and the fact that it is governed by the Agreement is indicated in a text that is easily accessible, specifically from the interface of any Derivative Software. The Licensee undertakes not to directly or indirectly infringe the intellectual property rights of the Holder and/or Contributors on the Software and to take, where applicable, vis-à-vis its staff, any and all measures required to ensure respect of said intellectual property rights of the Holder and/or Contributors. Article 7 - RELATED SERVICES 7.1 Under no circumstances shall the Agreement oblige the Licensor to provide technical assistance or maintenance services for the Software. However, the Licensor is entitled to offer this type of services. The terms and conditions of such technical assistance, and/or such maintenance, shall be set forth in a separate instrument. Only the Licensor offering said maintenance and/or technical assistance services shall incur liability therefor. 7.2 Similarly, any Licensor is entitled to offer to its licensees, under its sole responsibility, a warranty, that shall only be binding upon itself, for the redistribution of the Software and/or the Modified Software, under terms and conditions that it is free to decide. Said warranty, and the financial terms and conditions of its application, shall be subject of a separate instrument executed between the Licensor and the Licensee. Article 8 - LIABILITY 8.1 Subject to the provisions of Article 8.2, the Licensee shall be entitled to claim compensation for any direct loss it may have suffered from the Software as a result of a fault on the part of the relevant Licensor, subject to providing evidence thereof. 8.2 The Licensor's liability is limited to the commitments made under this Agreement and shall not be incurred as a result of in particular: (i) loss due the Licensee's total or partial failure to fulfill its obligations, (ii) direct or consequential loss that is suffered by the Licensee due to the use or performance of the Software, and (iii) more generally, any consequential loss. In particular the Parties expressly agree that any or all pecuniary or business loss (i.e. loss of data, loss of profits, operating loss, loss of customers or orders, opportunity cost, any disturbance to business activities) or any or all legal proceedings instituted against the Licensee by a third party, shall constitute consequential loss and shall not provide entitlement to any or all compensation from the Licensor. Article 9 - WARRANTY 9.1 The Licensee acknowledges that the scientific and technical state-of-the-art when the Software was distributed did not enable all possible uses to be tested and verified, nor for the presence of possible defects to be detected. In this respect, the Licensee's attention has been drawn to the risks associated with loading, using, modifying and/or developing and reproducing the Software which are reserved for experienced users. The Licensee shall be responsible for verifying, by any or all means, the suitability of the product for its requirements, its good working order, and for ensuring that it shall not cause damage to either persons or properties. 9.2 The Licensor hereby represents, in good faith, that it is entitled to grant all the rights over the Software (including in particular the rights set forth in Article 5). 9.3 The Licensee acknowledges that the Software is supplied "as is" by the Licensor without any other express or tacit warranty, other than that provided for in Article 9.2 and, in particular, without any warranty as to its commercial value, its secured, safe, innovative or relevant nature. Specifically, the Licensor does not warrant that the Software is free from any error, that it will operate without interruption, that it will be compatible with the Licensee's own equipment and software configuration, nor that it will meet the Licensee's requirements. 9.4 The Licensor does not either expressly or tacitly warrant that the Software does not infringe any third party intellectual property right relating to a patent, software or any other property right. Therefore, the Licensor disclaims any and all liability towards the Licensee arising out of any or all proceedings for infringement that may be instituted in respect of the use, modification and redistribution of the Software. Nevertheless, should such proceedings be instituted against the Licensee, the Licensor shall provide it with technical and legal assistance for its defense. Such technical and legal assistance shall be decided on a case-by-case basis between the relevant Licensor and the Licensee pursuant to a memorandum of understanding. The Licensor disclaims any and all liability as regards the Licensee's use of the name of the Software. No warranty is given as regards the existence of prior rights over the name of the Software or as regards the existence of a trademark. Article 10 - TERMINATION 10.1 In the event of a breach by the Licensee of its obligations hereunder, the Licensor may automatically terminate this Agreement thirty (30) days after notice has been sent to the Licensee and has remained ineffective. 10.2 A Licensee whose Agreement is terminated shall no longer be authorized to use, modify or distribute the Software. However, any licenses that it may have granted prior to termination of the Agreement shall remain valid subject to their having been granted in compliance with the terms and conditions hereof. Article 11 - MISCELLANEOUS 11.1 EXCUSABLE EVENTS Neither Party shall be liable for any or all delay, or failure to perform the Agreement, that may be attributable to an event of force majeure, an act of God or an outside cause, such as defective functioning or interruptions of the electricity or telecommunications networks, network paralysis following a virus attack, intervention by government authorities, natural disasters, water damage, earthquakes, fire, explosions, strikes and labor unrest, war, etc. 11.2 Any failure by either Party, on one or more occasions, to invoke one or more of the provisions hereof, shall under no circumstances be interpreted as being a waiver by the interested Party of its right to invoke said provision(s) subsequently. 11.3 The Agreement cancels and replaces any or all previous agreements, whether written or oral, between the Parties and having the same purpose, and constitutes the entirety of the agreement between said Parties concerning said purpose. No supplement or modification to the terms and conditions hereof shall be effective as between the Parties unless it is made in writing and signed by their duly authorized representatives. 11.4 In the event that one or more of the provisions hereof were to conflict with a current or future applicable act or legislative text, said act or legislative text shall prevail, and the Parties shall make the necessary amendments so as to comply with said act or legislative text. All other provisions shall remain effective. Similarly, invalidity of a provision of the Agreement, for any reason whatsoever, shall not cause the Agreement as a whole to be invalid. 11.5 LANGUAGE The Agreement is drafted in both French and English and both versions are deemed authentic. Article 12 - NEW VERSIONS OF THE AGREEMENT 12.1 Any person is authorized to duplicate and distribute copies of this Agreement. 12.2 So as to ensure coherence, the wording of this Agreement is protected and may only be modified by the authors of the License, who reserve the right to periodically publish updates or new versions of the Agreement, each with a separate number. These subsequent versions may address new issues encountered by Free Software. 12.3 Any Software distributed under a given version of the Agreement may only be subsequently distributed under the same version of the Agreement or a subsequent version. Article 13 - GOVERNING LAW AND JURISDICTION 13.1 The Agreement is governed by French law. The Parties agree to endeavor to seek an amicable solution to any disagreements or disputes that may arise during the performance of the Agreement. 13.2 Failing an amicable solution within two (2) months as from their occurrence, and unless emergency proceedings are necessary, the disagreements or disputes shall be referred to the Paris Courts having jurisdiction, by the more diligent Party. Version 1.0 dated 2006-09-05. interval-4.11.1/INSTALL.md000066400000000000000000000025271470547631300150720ustar00rootroot00000000000000Prerequisites ------------- In addition to the [Coq proof assistant](https://coq.inria.fr/) (>= 8.13.1), you need the following libraries: - [Mathematical Components](https://math-comp.github.io/) (>= 1.12), - [Flocq](https://flocq.gitlabpages.inria.fr/) (>= 3.2), - [Coquelicot](http://coquelicot.saclay.inria.fr/) (>= 3.1) - [BigNums](https://github.com/coq/bignums/) The `.tar.gz` file is distributed with a working set of configure files. They are not in the git repository though. Consequently, if you are building from git, you will need `autoconf` (>= 2.59). Configuring, compiling and installing ------------------------------------- Ideally, you should just have to type: ./configure && ./remake --jobs=2 && ./remake install The environment variable `COQC` can be passed to the configure script in order to set the Coq compiler command. The configure script defaults to `coqc`. Similarly, `COQDEP` can be used to specify the location of `coqdep`. The `COQBIN` environment variable can be used to set both variables at once. The library files are compiled at the logical location `Interval`. The `COQUSERCONTRIB` environment variable can be used to override the physical location where the `Interval` directory containing these files will be installed by `./remake install`. By default, the target directory is `` `$COQC -where`/user-contrib ``. interval-4.11.1/NEWS.md000066400000000000000000000162431470547631300145400ustar00rootroot00000000000000Version 4.11.1 -------------- * worked around some impedance mismatch between `Do` and Coq 8.20.0 (fixed in 8.20.1) * proved the correctness of function `lookup` * tightened the enclosure of `exp` in case of overflow Version 4.11.0 -------------- * added commands `Def` and `Do` to ease the use of degenerate forms of tactics * made the tactics recognize `F2R` from Flocq * added tactic `assert_float` in `Language` * minimal Coq version is now 8.13 Version 4.10.0 -------------- * ensured compatibility from Coq 8.11 to 8.19 * optimized `exp` for native floating-point numbers * allowed goals with strict inequalities, e.g., `f1 < e <= f2` * strengthened specifications of `FloatOps.{mul,div}_{DN,UP}` Version 4.9.0 ------------- * added support for fixed-point rounding operators from Flocq * made the tactics recognize the elementary error `round x - x` * tightened enclosures of floating-point rounding operators and errors Version 4.8.1 ------------- * ensured compatibilty from Coq 8.11 to 8.18 Version 4.8.0 ------------- * tightened enclosures of rounding operators and errors * added an experimental framework for verification of floating-point expressions in `Language` Version 4.7.0 ------------- * ensured compatibility from Coq 8.11 to 8.17 * made the tactics a bit more robust against unknown symbols * changed the degenerate tactics so that they always use `i_delay` Version 4.6.1 ------------- * ensured compatibility from Coq 8.8 to 8.17 * made `integral` a bit more lenient on `(ln t)^n` bounding integrands Version 4.6.0 ------------- * added option `i_decimal` for producing decimal enclosures * added support for floating-point rounding operators from Flocq Version 4.5.2 ------------- * ensured compatibility from Coq 8.8 to 8.16 Version 4.5.1 ------------- * fixed behavior of `root` on unbounded intervals Version 4.5.0 ------------- * added tactics `root` and `root_intro` for refining enclosures using Newton's method * improved behavior of `exp` in case of overflow Version 4.4.0 ------------- * ensured compatibility from Coq 8.8 to 8.15 * made `interval` and `integral` usable in tactic-in-term contexts Version 4.3.1 ------------- * made plotting more reliable when an output bound is close to zero Version 4.3.0 ------------- * ensured compatibility from Coq 8.8 to 8.14 * made reification unfold transparent constants * added reification of `Q2R` and thus of rational literals Version 4.2.0 ------------- * added tactic `plot` for computing a function graph * added command `Plot` for passing a function graph to Gnuplot (requires Coq >= 8.11) Version 4.1.1 ------------- * made reification of `IZR`, `pow`, `powerRZ`, and `bpow`, more robust Version 4.1.0 ------------- * ensured compatibility from Coq 8.8 to 8.13 * added support for strict inequalities in hypotheses Version 4.0.0 ------------- * ensured compatibility from Coq 8.8 to 8.12 * made native floating-point computations the default: - they are enabled when `i_prec` is not specified - this requires support from both Coq (e.g., 8.11) and Flocq (e.g., 3.3) - if support is missing, the tactic behaves as if passed `i_prec 53` * improved handling of bisection: - `i_bisect` can now be passed several times, to split along several variables - automatic differentiation is now enabled by `i_autodiff` (was `i_bisect_diff`) - Taylor models are enabled by `i_taylor` (was `i_bisect_taylor`) - automatic differentiation and Taylor models no longer implies bisection, so `i_bisect` should also be passed if needed * moved support of integrals from `interval` to a dedicated tactic `integral`: - only one integral can occur in the goal, but its enclosure is refined until the goal is proved - bisection is not supported - `i_fuel` controls the maximal number of sub-intervals (replaces `i_integral_depth`) - `i_degree` controls the size of the polynomials (was `i_integral_deg`) * moved support of integrals from `interval_intro` to a dedicated tactic `integral_intro`: - the expression has to be an integral - `i_width` controls the width of the computed enclosure (was `i_integral_width`) - `i_relwidth` controls the accuracy of the computed enclosure (was `i_integral_prec`) Version 3.4.2 ------------- * ensured compatibility from Coq 8.7 to 8.11 Version 3.4.1 ------------- * ensured compatibility from Coq 8.7 to 8.10 Version 3.4.0 ------------- * moved to Flocq 3.0; minimal Coq version is now 8.7 * added support for `Ztrunc`, `Zfloor`, etc * added support for constants written using `bpow radix2` Version 3.3.0 ------------- * added option `i_integral_width` for absolute width of integrals * added option `i_native_compute` to use `native_compute` instead of `vm_compute` * added option `i_delay` to avoid immediate check (mostly useful for `interval_intro`) * improved accuracy for interval `cos` and `sin` away from zero * ensured compatibility from Coq 8.5 to Coq 8.7 Version 3.2.0 ------------- * added support for some improper integrals using `RInt_gen` Version 3.1.1 ------------- * ensured compatibility with Coq 8.6 Version 3.1.0 ------------- * improved tactic so that it can be used with backtracking tacticals (`try`, `||`) * fixed ineffective computation of integrals with reversed or overlapping bounds Version 3.0.0 ------------- * added support for integrals using Coquelicot's `RInt` operator * improved support for Taylor models Version 2.2.1 ------------- * moved to MathComp 1.6 Version 2.2.0 ------------- * improved tactic so that it handles goals with non floating-point bounds * added a dependency on Coquelicot to remove an assumption about `ln` Version 2.1.0 ------------- * moved to Flocq 2.5 Version 2.0.0 ------------- * added support for Taylor models (`i_bisect_taylor`) * added support for `ln` * improved tactic so that it handles hypotheses with non floating-point bounds Version 1.1.0 ------------- * moved to Flocq 2.4 * added support for disequalities to the tactic * added support for the `PI` symbol * enlarged the domain of the interval versions of `cos` and `sin` Version 1.0.0 ------------- * removed remaining axioms Version 0.16.2 -------------- * fixed install rule on case-insensitive filesystems Version 0.16.1 -------------- * removed the custom definition of `atan` and used the one from Coq 8.4 Version 0.16.0 -------------- * switched build system to `remake` * moved to Coq 8.4 Version 0.15.1 -------------- * fixed failures when combining `interval_intro` with `i_bisect*` Version 0.15.0 -------------- * added support for strict inequalities to the tactic * added support for integer power to the tactic * improved support for absolute value in the tactic * improved tactic so that it directly handles `e1 <= e2` Version 0.14.0 -------------- * sped up square root for `Z`-based floating-point numbers * improved readability of the error messages for the tactic * modularized the tactic so that other specializations are available to user code * moved to Flocq 2.0 Version 0.13.0 -------------- * moved to Coq 8.3 Version 0.12.1 -------------- * fixed an incompatibility with Flocq 1.2 Version 0.12 ------------ * added a dependency on the Flocq library Version 0.11 ------------ * removed `i_nocheck` parameter as computations are no longer done at `Qed` time interval-4.11.1/README.md000066400000000000000000000375221470547631300147240ustar00rootroot00000000000000CoqInterval =========== This library provides vernacular files containing tactics for simplifying the proofs of inequalities on expressions of real numbers for the [Coq proof assistant](https://coq.inria.fr/). This package is free software; you can redistribute it and/or modify it under the terms of CeCILL-C Free Software License (see the [COPYING](COPYING) file). Main author is Guillaume Melquiond . See the file [INSTALL.md](INSTALL.md) for installation instructions. Project Home ------------ Homepage: https://coqinterval.gitlabpages.inria.fr/ Repository: https://gitlab.inria.fr/coqinterval/interval Bug tracker: https://gitlab.inria.fr/coqinterval/interval/issues Invocation ---------- In order to use the tactics of the library, one has to import the `Interval.Tactic` file into a Coq proof script. The main tactic is named `interval`. The tactic can be applied on a goal of the form `c1 <= e <= c2` with `e` an expression involving real-valued operators. Sub-expressions that are not recognized by the tactic should be either terms `t` appearing in hypothesis inequalities `c3 <= t <= c4` or simple integers. The bounds `c1`, `c2`, etc, are expressions that contain only constant leaves, e.g., `5 / sqrt (1 + PI)`. The complete list of recognized goals is as follows: - `c1 <= e <= c2`; - `e <= c1`, `c1 <= e`, `e >= c1`, and `c1 >= e`; - `e < c1`, `c1 < e`, `e > c1`, and `c1 > e`; - `e <> c1` and `c1 <> e`; - `Rabs e <= c1`, handled as `-c1 <= e <= c1`. The complete list of recognized hypotheses is as follows: - `c1 <= t <= c2`, `c1 <= e < c2`, `c1 < e <= c2`, and `c1 < e < c2`; - `t <= c1`, `c1 <= t`, `t >= c1`, and `c1 >= t`; - `t < c1`, `c1 < t`, `t > c1`, and `c1 > t`; - `Rabs t <= c1` and `Rabs t < c1`, handled as `-c1 <= e <= c1`. The tactic recognizes the following operators: `PI`, `Ropp`, `Rabs`, `Rinv`, `Rsqr`, `sqrt`, `cos`, `sin`, `tan`, `atan`, `exp`, `ln`, `pow`, `Rpower`, `powerRZ`, `Rplus`, `Rminus`, `Rmult`, `Rdiv`. Flocq's operators `Zfloor`, `Zceil`, `Ztrunc`, `ZnearestE` (composed with `IZR`) are also recognized. Flocq's operator `Generic_fmt.round` with format `FLT_exp` is also supported. There are some restrictions on the domain of a few functions: `pow` and `powerRZ` should be written with a numeric exponent; the input of `cos` and `sin` should be between `-2*PI` and `2*PI`; the input of `tan` should be between `-PI/2` and `PI/2`. Outside of these domains, the trigonometric functions return tight results only for singleton input intervals. A helper tactic `interval_intro e` is also available. Instead of proving the current goal, it computes an enclosure of the expression `e` passed as argument and it introduces the resulting inequalities into the proof context. If only one bound is needed, the keywords `lower` and `upper` can be passed to the tactic, so that it does not perform useless computations. For example, `interval_intro e lower` introduces only the inequality corresponding to the lower bound of `e` in the context. The `interval_intro` tactic uses a fresh name for the generated inequalities, unless one uses `as` followed by an intro pattern. The `integral` tactic is a specialized version of `interval` that can be used when the target enclosure involves an expression containing an integral. Such an integral should be expressed using `RInt`; its bounds should be constant; and its integrand should be an expression containing only constant leaves except for the integration variable. Improper integrals are also supported, when expressed using `RInt_gen`. The supported bounds are then `(at_right 0) (at_point _)` and `(at_point _) (Rbar_locally p_infty)`. In the improper case, the integrand should be of the form `(fun t => f t * g t)` with `f` a function bounded on the integration domain and `g t` one of the following expressions: - `(ln t) ^ _`, - `powerRZ t _ * (ln t) ^ _`, - `/ (t * (ln t) ^ _)`. The `root H` tactic is a specialized version of `interval` that can be used when the target enclosure involves an expression that is constrained by an equation whose proof is `H`. Rather than an equality proof, the tactic can also be passed an equality statement or even just a real expression (then assumed to be zero), in which case the tactic generates a new goal that asks for a proof of this equality. The helper tactic `integral_intro` is the counterpart of `interval_intro`, but for introducing enclosures of integrals into the proof context. As with `interval_intro`, keywords `lower`, `upper`, and `as`, are supported. Similarly, `root_intro` introduces enclosures of roots into the proof context. Only `as` is supported in that case. When an equality (rather than a proof) is passed to `root_intro`, no new goal is generated, but the introduced hypothesis uses the equality as its antecedent. Tactics `interval_intro`, `integral_intro`, and `root_intro` are available as degenerate forms that unify the obtained enclosure with the current goal. They are meant to be used when the goal is an existential variable, e.g., in a tactic-in-term context. Those degenerate forms are named `interval`, `integral`, and `root`, for conciseness, but they should not be confused with the original tactics. For all intents and purposes, they behave like the `*_intro` tactics. The `plot` tactic produces correct function graphs, that is, two curves that are guaranteed to enclose the given function on the given input interval. It is invoked as `plot f x1 x2`. An output range can optionally be passed: `plot f x1 x2 y1 y2`. If not, it is computed on the fly. The `Interval.Plot` file provides a `Plot` command that can be used to display a function graph. This is done by invoking the `gnuplot` command, which thus needs to be installed. If a string is passed as an optional argument, instead of invoking `gnuplot`, a file is created with the corresponding Gnuplot script. This file also provides a `Def` command, which has a syntax similar to the `Definition`, except that the right-hand side is not a Gallina term but an Ltac term. This command is meant to be used in conjunction with the degenerate forms of the tactics `interval`, `integral`, and `root`. If the name given to the term does not matter, the simpler `Do` command can be used instead. Both commands display the type of the generated term with some syntactic sugar. If the type is a function graph (as produced by `plot`), then the command `Plot` is invoked on it. Fine-tuning ----------- The behavior of the tactics can be tuned by passing an optional set of parameters `with (param1, param2, ...)`. These parameters are parsed from left to right. If some parameters are conflicting, the earlier ones are discarded. Available parameters are as follows (with the type of their arguments, if any): - `i_prec (p:positive)` Set the precision used to emulate floating-point computations. If this parameter is not specified, the tactics perform computations using machine floating-point numbers, when available. Otherwise, the tactic defaults to using `i_prec 53`. Note that, in some corner cases, the tactics might fail when using native numbers, despite the goals being provable using a 53-bit emulation. - `i_native_compute` Perform computations using `native_compute` instead of `vm_compute`. This greatly increases the startup time of the tactics, but makes the computations faster. This is useful only for computationally-intensive proofs. - `i_bisect (x:R)` Instruct the tactics to split the interval enclosing `x` until the goal is proved on all the sub-intervals. Several `i_bisect` parameters can be given. In that case, the tactic cycles through all of them, splitting the input domain along the corresponding variable. Computation time is more or less proportional to the final number of sub-domains. This parameter is only meaningful for the `interval` and `interval_intro` tactics. - `i_depth (n:nat)` Set the maximal bisection depth. Setting it to a nonzero value has no effect unless `i_bisect` parameters are also passed. If the maximal depth is `n`, the tactic will consider up to `2^n` sub-domains in the worst case. As with `i_bisect`, this parameter is only meaningful for the `interval` and `interval_intro` tactics. The maximal depth defaults to `15` for `interval`, and to `5` for `interval_intro`. Note that `interval_intro` computes the best enclosure that could be verified by `interval` using the same maximal depth. - `i_autodiff (x:R)` Instruct the tactics to perform an automatic differentiation of the target expression with respect to `x`. This makes the tactic about twice slower on each sub-domain. But it makes it possible to detect some monotony properties of the target expression, thus reducing the amount of sub-domains that need to be considered. Note that this is only useful if there are several occurrences of `x` in the goal. This parameter is only meaningful for the `interval` and `interval_intro` tactics. It is mutually exclusive with `i_taylor`. This parameter can also be used with the `root` and `root_intro` tactics, if they did not guess the correct target variable. - `i_taylor (x:R)` Instruct the tactics to compute a reliable polynomial enclosure of the target expression using Taylor models in `x`. As with `i_autodiff`, this is useful only if `x` occurs several times in the goal. Computing polynomial enclosures is much slower than automatic differentiation, but it can reduce the final number of sub-domains even further, thus speeding up proofs. Note that it might fail to prove goals that are feasible using automatic differentiation. As with `i_autodiff`, the `i_taylor` parameter is only meaningful for the `interval` and `interval_intro` tactics. It is implicit for the `integral`, `integral_intro`, and `plot` tactics, as Taylor models of the integrand (respectively, plotted function) are computed with respect to its variable. - `i_degree (d:nat)` Set the degree of polynomials used as enclosures. The default degree is 10. For `interval` and `interval_intro`, this parameter is only meaningful in conjunction with `i_taylor`. - `i_fuel (n:positive)` Set the maximum number of sub-domains considered when bounding integrals. The tactics maintain a set of integration sub-domains; it splits the sub-domains that contribute the most to the inaccuracy of the integral until its enclosure is tight enough to satisfy the goal. By default, the tactics will split the integration domain into at most 100 sub-domains. This parameter is only meaningful for the `integral` and `integral_intro` tactics. - `i_width (p:Z)` Instruct the `integral_intro` tactic to compute an enclosure of the integral that is no larger than `2^p`. The tactic will split the integration domain until the resulting enclosure reaches this width or `i_fuel` is exhausted. This parameter is meaningless for the other tactics. It is mutually exclusive with `i_relwidth`. - `i_relwidth (p:positive)` Instruct the `integral_intro` tactic to compute an enclosure of the integral whose relative width is no larger than `2^-p`. This parameter is meaningless for the other tactics. It defaults to 10. This means that, if neither `i_width` nor `i_relwidth` is used, `integral_intro` will compute an enclosure of the integral accurate to three decimal digits, assuming `i_fuel` is large enough. - `i_size (w h:positive)` Instruct the `plot` tactic to target a resolution of `w` by `h` pixels. This parameter is meaningless for the other tactics. It defaults to a resolution of `512x384`. The tactic will subdivide the input interval into `w` subintervals, and it will try to ensure that the function graph is no larger than a few pixels vertically. - `i_delay` Prevent Coq from verifying the generated proof at invocation time. Instead, Coq will check the proof term at `Qed` time. This makes the tactics `interval`, `integral`, and `root` instant. But it also means that failures, if any, will only be detected at `Qed` time, possibly with an inscrutable error message. This parameter is thus meant to be used when editing a proof script for which the tactics are already known to succeed. For the tactics `interval_intro`, `integral_intro`, and `root_intro`, computations are performed anyway (the risk of failure is thus negligible), but the `i_delay` parameter postpones their verification until `Qed` time. This makes these tactics twice as fast and is especially useful when optimizing the arguments of `i_prec`, `i_degree`, etc. For the degenerate forms of `interval_intro`, `integral_intro`, and `root_intro`, the `i_delay` parameter is always passed implicitly. - `i_decimal` Instruct the tactics to output interval bounds using a decimal representation. This parameter is only meaningful for the tactics `interval_intro`, `integral_intro`, and `root_intro`, as well as the corresponding degenerate tactics. Examples -------- ```coq From Coq Require Import Reals Lra. From Interval Require Import Tactic. Open Scope R_scope. Notation "x = y ± z" := (Rle (Rabs (x - y)) z) (at level 70, y at next level). (* Tactic interval *) Goal forall x, -1 <= x <= 1 -> sqrt (1 - x) <= 3/2. Proof. intros. interval. Qed. Goal forall x, -1 <= x <= 1 -> sqrt (1 - x) <= 141422/100000. Proof. intros. interval. Qed. Goal forall x, -1 <= x <= 1 -> sqrt (1 - x) <= 141422/100000. Proof. intros. interval_intro (sqrt (1 - x)) upper as H'. apply Rle_trans with (1 := H'). lra. Qed. Goal forall x, 3/2 <= x <= 2 -> forall y, 1 <= y <= 33/32 -> sqrt(1 + x/sqrt(x+y)) = 144/1000*x + 118/100 ± 71/32768. Proof. intros. interval with (i_prec 19, i_bisect x). Qed. Goal forall x, 1/2 <= x <= 2 -> sqrt x = ((((122 / 7397 * x + (-1733) / 13547) * x + 529 / 1274) * x + (-767) / 999) * x + 407 / 334) * x + 227 / 925 ± 5/65536. Proof. intros. interval with (i_bisect x, i_taylor x, i_degree 3). Qed. Goal forall x, -1 <= x -> x < 1 + powerRZ x 3. Proof. intros. apply Rminus_lt. interval with (i_bisect x, i_autodiff x). Qed. From Flocq Require Import Core. Notation rnd := (round radix2 (FLT_exp (-1074) 53) ZnearestE). Goal forall x, -1 <= x <= 1 -> rnd (1 + rnd (x * rnd (1 + rnd (x * (922446257493983/2251799813685248))))) = exp x ± 31/100. Proof. intros. interval with (i_taylor x). Qed. (* Tactic integral *) From Coquelicot Require Import Coquelicot. Goal RInt (fun x => atan (sqrt (x*x + 2)) / (sqrt (x*x + 2) * (x*x + 1))) 0 1 = 5/96*PI*PI ± 1/1000. Proof. integral with (i_fuel 2, i_degree 5). Qed. Goal RInt_gen (fun x => 1 * (powerRZ x 3 * ln x^2)) (at_right 0) (at_point 1) = 1/32. Proof. refine ((fun H => Rle_antisym _ _ (proj2 H) (proj1 H)) _). integral with (i_prec 10). Qed. (* Tactic root *) Goal forall x:R, 999 <= x <= 1000 -> sin x = 0 -> x = 318 * PI ± 1/1000. Proof. intros x Hx Hs. root Hs. Qed. (* Degenerate forms *) Definition equal_1 x `(0 <= x <= PI/2) := ltac:(interval ((cos x)² + (sin x)²) with (i_taylor x)). Definition equal_PI_over_4 := ltac:(integral (RInt (fun x => 1 / (1+x*x)) 0 1)). Definition equal_0_442854401002 x := ltac:(root (exp x = 2 - x) with i_decimal). (* Tactic plot and command Plot *) From Interval Require Import Plot. Definition p1 := ltac:(plot (fun x => x^2 * sin (x^2)) (-4) 4). Plot p1. Definition p2 := ltac:( plot (fun x => sin (x + exp x)) 0 6 (-5/4) (5/4) with (i_size 120 90, i_degree 6)). Plot p2 as "picture.gnuplot". Plot ltac:(plot (fun x => sqrt (1 - x^2) * sin (x * 200)) (-1) 1 with (i_degree 1, i_size 100 300)). (* Commands Do and Def *) Do interval (PI²/6). Do integral (RInt_gen (fun x => 1/(1 + x)^2 * (ln x)^2) (at_right 0) (at_point 1)) with (i_relwidth 30). Def quintic x := root (x^5 - x = 1). ``` interval-4.11.1/Remakefile.in000066400000000000000000000136031470547631300160330ustar00rootroot00000000000000FILES = \ Tactic \ Eval/Eval \ Eval/Prog \ Eval/Reify \ Eval/Tree \ Float/Basic \ Float/Generic \ Float/Generic_ops \ Float/Generic_proof \ Float/Specific_bigint \ Float/Specific_ops \ Float/Specific_sig \ Float/Specific_stdz \ Float/Sig \ Integral/Bertrand \ Integral/Integral \ Integral/Priority \ Integral/Refine \ Interval/Interval \ Interval/Interval_compl \ Interval/Float \ Interval/Float_full \ Interval/Transcend \ Interval/Univariate_sig \ @LANG_FILES@ \ Missing/Coquelicot \ Missing/MathComp@MATHCOMP_1_OR_2@ \ Missing/MathComp1or2 \ Missing/MathComp \ Missing/Stdlib \ Poly/Basic_rec \ Poly/Bound \ Poly/Bound_quad \ Poly/Datatypes \ Poly/Taylor_model \ Poly/Taylor_model_sharp \ Poly/Taylor_poly \ Real/Taylor \ Real/Xreal \ Real/Xreal_derive \ Tactics/Integral_helper \ Tactics/Interval_helper \ Tactics/Plot_helper \ Tactics/Root_helper \ Tactic_float \ @PLOT@ \ @PRIM_FLOAT@ VFILES = $(addprefix src/,$(addsuffix .v,$(FILES))) VOFILES = $(addprefix src/,$(addsuffix .vo,$(FILES))) GLOBS = $(addprefix src/,$(addsuffix .glob,$(FILES))) .PHONY: all check clean dist install all: $(VOFILES) clean: src/clean testsuite/clean CONFIGURED_FILES = Remakefile src/Plot.v src/Missing/Int63Compat.v src/Missing/MathComp1or2.v $(CONFIGURED_FILES): %: %.in config.status ./config.status $@ configure config.status: configure.in autoconf ./config.status --recheck src/Tactic_float.v: @PRIM_FLOAT_TAC@ Remakefile cp @PRIM_FLOAT_TAC@ src/Tactic_float.v %.vo: %.v | src/Tactic_float.v src/Plot.v src/Missing/Int63Compat.v src/Missing/MathComp1or2.v @COQDEP@ -R src Interval $< | @REMAKE@ -r $@ @COQC@ @COQEXTRAFLAGS@ -R src Interval $< COQPKGS = clib engine kernel interp lib library parsing pretyping printing proofs tactics toplevel vernac plugins.ltac PACKAGES = $(addprefix -package @COQROOT@., $(COQPKGS)) -package zarith src/Plot/interval_plot.ml: src/Plot/plot.c Remakefile @CPP@ -DCOQVERSION=@COQVERSION@ -DPLOTPLUGIN=\"@PLOTPLUGIN@\" $< -o $@ src/Plot/interval_plot.cmo: src/Plot/interval_plot.ml @OCAMLFIND@ ocamlc -rectypes -thread $(PACKAGES) -c $< -o $@ src/Plot/interval_plot.cmxs: src/Plot/interval_plot.ml @OCAMLFIND@ ocamlopt -rectypes -thread $(PACKAGES) -shared $< -o $@ MLTARGETS = $(addprefix src/Plot/, @TACTIC_TARGETS@) src/Plot.vo: src/Plot.v $(MLTARGETS) @COQC@ @COQEXTRAFLAGS@ @TACTIC_PARAM@ -R src Interval -I src/Plot $< src/clean: rm -f $(VOFILES) $(GLOBS) cd src rm -f *.vo* */*.vo* for d in */; do \ rm -f $d/.coq-native/*.o $d/.coq-native/*.cm*; done find . -type d -name ".coq-native" -empty -prune -exec rmdir "{}" \; rm -f Missing/Int63Compat.v Plot/interval_plot.ml Plot/interval_plot.cm* Plot/interval_plot.o Plot.v check: src/Tactic.vo src/Plot.vo set +e cd testsuite logfile="failures-`date '+%Y-%m-%d'`.log" cat /dev/null > log.tmp cat /dev/null > "$logfile" rm -f check_tmp.v for f in *.v; do cp "$f" check_tmp.v @COQC@ -R ../src Interval -I ../src/Plot check_tmp.v > output.tmp 2>&1 return_code=$? if [ ${return_code} -ne 0 ]; then (echo "*** $f exited with error code ${return_code}"; cat output.tmp; echo) >> "$logfile" echo "$f exited with error code ${return_code}" >> log.tmp fi rm -f picture.gnuplot rm -f check_tmp.v check_tmp.vo check_tmp.glob .check_tmp.aux output.tmp rm -f .coq-native/N*check_tmp.o .coq-native/N*check_tmp.cm* done return_code=0 if [ -s log.tmp ]; then echo "*** Failures:" cat log.tmp return_code=1 else rm "$logfile" fi rm log.tmp exit ${return_code} testsuite/clean: rm -f testsuite/failures-*.log deps.dot: $(VFILES) (echo "digraph interval_deps {" ; echo "node [shape=ellipse, style=filled, URL=\"html/Interval.\N.html\", color=black];"; (cd src ; @COQDEP@ -m Plot/META.coq-interval -R . Interval $(addsuffix .v,$(FILES))) | sed -n -e 's,/,.,g;s/[.]vo.*: [^ ]*[.]v//p' | grep -v META | while read src dst; do color=$$(echo "$src" | sed -e 's,Real.*,turquoise,;s,Interval[.].*,plum,;s,Integral.*,lightcoral,;s,Poly.*,yellow,;s,Float.*,lightskyblue,;s,Eval.*,lawngreen,;s,Language.*,khaki,;s,Tactics.*,lightcyan,;s,Missing.*,lightgrey,;s,[A-Z].*,white,') echo "\"$src\" [fillcolor=$color];" for d in $dst; do echo "\"$src\" -> \"${d%.vo}\" ;" done done; echo "}") | tred > $@ deps.png: deps.dot dot -T png deps.dot > deps.png deps.map: deps.dot dot -T cmap deps.dot | sed -e 's,>$,/>,' > deps.map html/index.html: $(VOFILES) rm -rf html mkdir -p html @COQDOC@ -toc -interpolate -utf8 -html -g -R src Interval -d html \ --coqlib_url https://coq.inria.fr/distrib/current/stdlib \ --external https://math-comp.github.io/htmldoc mathcomp \ --external https://flocq.gitlabpages.inria.fr/flocq/html Flocq \ --external https://coquelicot.gitlabpages.inria.fr/coquelicot Coquelicot \ $(VFILES) for f in html/*.html; do sed -e 's;Index;Go back to the Main page or Index.;' -i $f done doc: html/index.html public: deps.png deps.map html/index.html mkdir -p public sed -e '/#include deps.map/r deps.map' misc/template.html > public/index.html cp -r html deps.png public/ install: dir="${DESTDIR}@COQUSERCONTRIB@/Interval" mkdir -p $dir for d in Eval Float Integral Interval Language Missing Poly Real Tactics; do mkdir -p $dir/$d; done for f in $(FILES); do cp src/$f.vo $dir/$f.vo; done ( cd src && find . -type d -name ".coq-native" -exec cp -RT "{}" "$dir/{}" \; ) dir="${DESTDIR}@COQINTERVALLIB@" mkdir -p $dir test -n "$(MLTARGETS)" && cp $(MLTARGETS) $dir/ cat src/Plot/META.coq-interval | grep -v 'directory *=' > $dir/META EXTRA_DIST = \ configure dist: $(EXTRA_DIST) PACK=@PACKAGE_TARNAME@-@PACKAGE_VERSION@ rm -f $PACK.tar.gz git archive --format=tar --prefix=$PACK/ -o $PACK.tar HEAD tar rf $PACK.tar --transform="s,^,$PACK/," --mtime="`git show -s --format=%ci`" --owner=0 --group=0 $(EXTRA_DIST) gzip -n -f --best $PACK.tar interval-4.11.1/_CoqProject000066400000000000000000000000341470547631300155640ustar00rootroot00000000000000-R src Interval -I src/Plot interval-4.11.1/configure.in000066400000000000000000000205071470547631300157510ustar00rootroot00000000000000AC_INIT([Interval], [4.11.1], [Guillaume Melquiond ], [interval]) m4_divert_push(99) if test "$ac_init_help" = "long"; then ac_init_help=short fi m4_divert_pop(99) AC_PROG_CPP native_tactic=yes byte_tactic=yes AC_ARG_VAR(COQBIN, [path to Coq executables [empty]]) if test ${COQBIN##*/}; then COQBIN=$COQBIN/; fi AC_ARG_VAR(COQC, [Coq compiler command [coqc]]) AC_MSG_CHECKING([for coqc]) if test ! "$COQC"; then COQC=`which ${COQBIN}coqc` if test ! "$COQC"; then AC_MSG_RESULT([not found]) AC_MSG_ERROR([missing Coq compiler]) fi fi AC_MSG_RESULT([$COQC]) AC_SUBST(COQVERSION) AC_MSG_CHECKING([Coq version]) COQVERSION=[`$COQC -v | sed -n -e 's/^.*version \([0-9][0-9.]*\).*$/\1/p' | awk -F. '{ printf("%d%02d%02d\n", $1,$2,$3); }'`] if test "$COQVERSION" -lt 81301; then AC_MSG_ERROR([must be at least 8.13.1 (you have version $COQVERSION).]) fi AC_MSG_RESULT($COQVERSION) if test "$COQVERSION" -lt 81400; then COQROOT=coq INT63_EXPORT="From Coq Require Export Int63." INT63_FILE="" else COQROOT=coq-core INT63_EXPORT="Require Export Int63Copy." INT63_FILE="Missing/Int63Copy" fi AC_SUBST(COQROOT) AC_SUBST(INT63_EXPORT) AC_ARG_VAR(COQDEP, [Coq dependency analyzer command [coqdep]]) AC_MSG_CHECKING([for coqdep]) if test ! "$COQDEP"; then COQDEP=`which ${COQBIN}coqdep` if test ! "$COQDEP"; then AC_MSG_RESULT([not found]) AC_MSG_ERROR([missing Coq dependency analyzer]) fi fi AC_MSG_RESULT([$COQDEP]) AC_ARG_VAR(COQDOC, [Coq documentation generator command [coqdoc]]) AC_MSG_CHECKING([for coqdoc]) if test ! "$COQDOC"; then COQDOC=`which ${COQBIN}coqdoc` if test ! "$COQDOC"; then AC_MSG_RESULT([not found]) fi fi AC_MSG_RESULT([$COQDOC]) AC_ARG_VAR(COQEXTRAFLAGS, [extra flags passed to Coq compiler [empty]]) AC_ARG_VAR(OCAMLFIND, [OCaml package manager [ocamlfind]]) AC_MSG_CHECKING([for ocamlfind]) if test ! "$OCAMLFIND"; then OCAMLFIND=`$COQC -config | sed -n -e 's/^OCAMLFIND=\(.*\)/\1/p'` if test ! "$OCAMLFIND"; then OCAMLFIND=ocamlfind; fi OCAMLFIND=`which $OCAMLFIND` fi AC_MSG_RESULT([$OCAMLFIND]) if test ! "$OCAMLFIND"; then OCAMLFIND=ocamlfind; fi AC_MSG_CHECKING([for Flocq]) AS_IF( [ echo "Require Import Flocq.Version BinNat." \ "Goal (30200 <= Flocq_version)%N. easy. Qed." > conftest.v $COQC conftest.v 2> conftest.err ], [ AC_MSG_RESULT([yes]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([ *** Unable to find library Flocq >= 3.2 (http://flocq.gitlabpages.inria.fr/)])]) rm -f conftest.v conftest.vo conftest.err AC_MSG_CHECKING([for Flocq >= 4.1]) AS_IF( [ echo "Require Import Flocq.Version BinNat." \ "Goal (40100 <= Flocq_version)%N. easy. Qed." > conftest.v $COQC conftest.v 2> conftest.err ], [ lang_tac=yes ], [ lang_tac=no ]) rm -f conftest.v conftest.vo conftest.err AC_MSG_RESULT([$lang_tac]) AC_MSG_CHECKING([for primitive floats]) AS_IF( [ echo "Require Import Flocq.IEEE754.PrimFloat." > conftest.v $COQC conftest.v 2> conftest.err ], [prim_float=yes], [prim_float=no]) rm -f conftest.v conftest.vo conftest.err AC_MSG_RESULT([$prim_float]) AC_MSG_CHECKING([for Ssreflect]) AS_IF( [ echo "Require Import mathcomp.ssreflect.ssreflect." > conftest.v $COQC conftest.v 2> conftest.err ], [ AC_MSG_RESULT([yes]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([ *** Unable to find library mathcomp.ssreflect (http://math-comp.github.io/math-comp/)])]) rm -f conftest.v conftest.vo conftest.err # meet_morphism is a random constant that only exists in MathComp 2 AC_MSG_CHECKING([for MathComp version]) AS_IF( [ echo "Require Import mathcomp.ssreflect.order. Definition foo := Order.meet_morphism." > conftest.v $COQC conftest.v 2> conftest.err ], [ AC_MSG_RESULT([2]) MATHCOMP_1_OR_2=2 ], [ AC_MSG_RESULT([1]) MATHCOMP_1_OR_2=1 ]) rm -f conftest.v conftest.vo conftest.err AC_SUBST(MATHCOMP_1_OR_2) AC_MSG_CHECKING([for Coquelicot]) AS_IF( [ echo "Require Import Coquelicot.Coquelicot." \ "Check (RInt (V := R_CompleteNormedModule))." > conftest.v $COQC conftest.v > conftest.err 2>&1 ], [ AC_MSG_RESULT([yes]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([ *** Unable to find library Coquelicot (http://coquelicot.saclay.inria.fr/)])]) rm -f conftest.v conftest.vo conftest.err AC_MSG_CHECKING([for Bignums]) AS_IF( [ echo "Require Import Bignums.BigZ.BigZ." > conftest.v $COQC conftest.v 2> conftest.err ], [ AC_MSG_RESULT([yes]) ], [ AC_MSG_RESULT([no]) AC_MSG_ERROR([ *** Unable to find library Bignums (https://github.com/coq/bignums/)])]) rm -f conftest.v conftest.vo conftest.err AC_ARG_ENABLE([tactic], AS_HELP_STRING([--disable-tactic], [do not compile a "plot" tactic]), [if test "$enable_tactic" = "no"; then native_tactic=no ; byte_tactic=no ; fi], []) AC_ARG_ENABLE([native-tactic], AS_HELP_STRING([--disable-native-tactic], [do not compile a native "plot" tactic]), [if test "$enable_native_tactic" = "no"; then native_tactic=no ; fi], []) AC_ARG_ENABLE([byte-tactic], AS_HELP_STRING([--disable-byte-tactic], [do not compile a bytecode "plot" tactic]), [if test "$enable_byte_tactic" = "no"; then byte_tactic=no ; fi], []) if test "$native_tactic" = yes; then AC_MSG_CHECKING([for native development files]) AS_IF( [ echo "let _ = (Evd.empty, Big_int_Z.zero_big_int)" > conftest.ml $OCAMLFIND ocamlopt -rectypes -thread -package $COQROOT.engine -package zarith -shared conftest.ml -o conftest.cmxs ], [ AC_MSG_RESULT(yes) ], [ AC_MSG_RESULT(no) AC_MSG_ERROR([ *** Failed to compile a native OCaml library ]) ]) fi if test "$byte_tactic" = yes; then AC_MSG_CHECKING([for bytecode development files]) AS_IF( [ echo "let _ = (Evd.empty, Big_int_Z.zero_big_int)" > conftest.ml $OCAMLFIND ocamlc -rectypes -thread -package $COQROOT.engine -package zarith -c conftest.ml -o conftest.cmo ], [ AC_MSG_RESULT(yes) ], [ AC_MSG_RESULT(no) AC_MSG_ERROR([ *** Failed to compile a bytecode OCaml library ]) ]) fi AC_SUBST(TACTIC_TARGETS) AC_SUBST(TACTIC_PARAM) tactic_mode="" if test "$native_tactic" = yes; then tactic_mode="$tactic_mode native" TACTIC_TARGETS="$TACTIC_TARGETS interval_plot.cmxs" if test "$byte_tactic" = no; then TACTIC_PARAM="-opt" fi fi if test "$byte_tactic" = yes; then tactic_mode="$tactic_mode bytecode" TACTIC_TARGETS="$TACTIC_TARGETS interval_plot.cmo" if test "$native_tactic" = no; then TACTIC_PARAM="-byte" fi fi AC_SUBST(PLOT) if test -z "$tactic_mode"; then tactic_mode=" none" PLOT="" else PLOT=Plot fi AC_ARG_VAR(COQUSERCONTRIB, [installation directory [`$COQC -where`/user-contrib]]) if test -z "$COQUSERCONTRIB"; then COQUSERCONTRIB="`$COQC -where | tr -d '\r' | tr '\\\\' '/'`/user-contrib" fi if test "$COQVERSION" -ge 81600; then COQINTERVALLIB=`$OCAMLFIND printconf destdir`/coq-interval PLOTPLUGIN="coq-interval.plot" else COQINTERVALLIB=$COQUSERCONTRIB/Interval PLOTPLUGIN="interval_plot" fi AC_SUBST(COQINTERVALLIB) AC_SUBST(PLOTPLUGIN) if test "$COQVERSION" -lt 81600; then lang_tac=no fi if test "$lang_tac" = "yes"; then LANG_FILES="Language/Lang_expr Language/Lang_simpl Language/Lang_tac" else LANG_FILES= fi AC_SUBST([LANG_FILES]) if test "$prim_float" = "yes"; then PRIM_FLOAT="$INT63_FILE Missing/Int63Compat Missing/Flocq Float/Primitive_ops" if test "$lang_tac" = "yes"; then PRIM_FLOAT="$PRIM_FLOAT Interval/Float_full_primfloat" PRIM_FLOAT_TAC=src/Tactic_primfloat_opt.v else PRIM_FLOAT_TAC=src/Tactic_primfloat.v fi else PRIM_FLOAT= PRIM_FLOAT_TAC=src/Tactic_bignum.v fi AC_SUBST(PRIM_FLOAT) AC_SUBST(PRIM_FLOAT_TAC) AC_ARG_VAR(REMAKE, [Remake [vendored version]]) if test -z "$REMAKE"; then AC_PROG_CXX AC_MSG_NOTICE([building remake...]) case `$CXX -v 2>&1 | grep -e "^Target:"` in *mingw*) $CXX -Wall -O2 -o remake.exe remake.cpp -lws2_32 if test $? != 0; then AC_MSG_FAILURE([failed]); fi REMAKE=./remake.exe ;; *) $CXX -Wall -O2 -o remake remake.cpp if test $? != 0; then AC_MSG_FAILURE([failed]); fi REMAKE=./remake ;; esac fi echo echo "=== Summary ===" echo "Vernacular directory $COQUSERCONTRIB/Interval" echo "Plugin directory $COQINTERVALLIB" echo "Primitive floats $prim_float" echo "Language tactics $lang_tac" echo "Plot tactic $tactic_mode" echo AC_CONFIG_FILES([Remakefile src/Plot.v src/Missing/Int63Compat.v src/Missing/MathComp1or2.v]) AC_OUTPUT interval-4.11.1/remake.cpp000066400000000000000000002424161470547631300154150ustar00rootroot00000000000000/* -*- mode: C++; indent-tabs-mode: t; c-basic-offset: 8; -*- */ /** @mainpage Remake, a build system that bridges the gap between make and redo. As with make, remake uses a centralized rule file, which is named Remakefile. It contains rules with a make-like syntax: @verbatim target1 target2 ... : prerequisite1 prerequisite2 ... shell script that builds the targets @endverbatim A target is known to be up-to-date if all its prerequisites are. If it has no known prerequisites yet the file already exits, it is assumed to be up-to-date. Obsolete targets are rebuilt thanks to the shell script provided by the rule. As with redo, remake supports dynamic dependencies in addition to these static dependencies. Whenever a script executes `remake prerequisite4 prerequisite5 ...`, these prerequisites are rebuilt if they are obsolete. (So remake acts like redo-ifchange.) Moreover, all the dependencies are stored in file .remake so that they are remembered in subsequent runs. Note that dynamic dependencies from previous runs are only used to decide whether a target is obsolete; they are not automatically rebuilt when they are obsolete yet a target depends on them. They will only be rebuilt once the dynamic call to remake is executed. In other words, the following two rules have almost the same behavior. @verbatim target1 target2 ... : prerequisite1 prerequisite2 ... shell script target1 target2 ... : remake prerequisite1 prerequisite2 ... shell script @endverbatim (There is a difference if the targets already exist, have never been built before, and the prerequisites are either younger or obsolete, since the targets will not be rebuilt in the second case.) The above usage of dynamic dependencies is hardly useful. Their strength lies in the fact that they can be computed on the fly: @verbatim %.o : %.c gcc -MMD -MF $@.d -o $@ -c $< remake -r < $@.d rm $@.d %.cmo : %.ml ocamldep $< | remake -r $@ ocamlc -c $< after.xml: before.xml rules.xsl xsltproc --load-trace -o after.xml rules.xsl before.xml 2> deps remake `sed -n -e "\\,//,! s,^.*URL=\"\\([^\"]*\\).*\$,\\1,p" deps` rm deps @endverbatim Note that the first rule fails if any of the header files included by a C source file has to be automatically generated. In that case, one should perform a first call to remake them before calling the compiler. (Dependencies from several calls to remake are cumulative, so they will all be remembered the next time.) \section sec-usage Usage Usage: remake options targets Options: - `-B`, `--always-make`: Unconditionally make all targets. - `-d`: Echo script commands. - `-f FILE`: Read `FILE` as Remakefile. - `-j[N]`, `--jobs=[N]`: Allow `N` jobs at once; infinite jobs with no argument. - `-k`, `--keep-going`: Keep going when some targets cannot be made. - `-r`: Look up targets from the dependencies on standard input. - `-s`, `--silent`, `--quiet`: Do not echo targets. \section sec-syntax Syntax Lines starting with a space character or a tabulation are assumed to be rule scripts. They are only allowed after a rule header. Lines starting with `#` are considered to be comments and are ignored. They do interrupt rule scripts though. Any other line is either a variable definition or a rule header. If such a line ends with a backslash, the following line break is ignored and the line extends to the next one. Variable definitions are a single name followed by equal followed by a list of names, possibly empty. Rule headers are a nonempty list of names, followed by a colon, followed by another list of names, possibly empty. Basically, the syntax of a rule is as follows: @verbatim targets : prerequisites shell script @endverbatim List of names are space-separated sequences of names. If a name contains a space character, it should be put into double quotes. Names cannot be any of the following special characters `:$(),="`. Again, quotation should be used. Quotation marks can be escaped by a backslash inside quoted names. \subsection sec-variables Variables Variables can be used to factor lists of targets or prerequisites. They are expanded as they are encountered during Remakefile parsing. @verbatim VAR2 = a VAR1 = c d VAR2 += $(VAR1) b $(VAR2) e : @endverbatim Variable assignments can appear instead of prerequisites inside non-generic rules with no script. They are then expanded inside the corresponding generic rule. @verbatim foo.o: CFLAGS += -DBAR %.o : %.c gcc $(CFLAGS) -MMD -MF $@.d -o $@ -c $< remake -r < $@.d rm $@.d @endverbatim Note: contrarily to make, variable names have to be enclosed in parentheses. For instance, `$y` is not a shorthand for \$(y) and is left unexpanded. \subsection sec-autovars Automatic variables The following special symbols can appear inside scripts: - `$<` expands to the first static prerequisite of the rule. - `$^` expands to all the static prerequisites of the rule, including duplicates if any. - `$@` expands to the first target of the rule. - `$*` expands to the string that matched `%` in a generic rule. - `$$` expands to a single dollar symbol. Note: contrarily to make, there are no corresponding variables. For instance, `$^` is not a shorthand for `$(^)`. Another difference is that `$@` is always the first target, not the one that triggered the rule. \subsection sec-functions Built-in functions remake also supports a few built-in functions inspired from make. - $(addprefix prefix, list) returns the list obtained by prepending its first argument to each element of its second argument. - $(addsuffix suffix, list) returns the list obtained by appending its first argument to each element of its second argument. \subsection sec-order Order-only prerequisites If the static prerequisites of a rule contain a pipe symbol, prerequisites on its right do not cause the targets to become obsolete if they are newer (unless they are also dynamically registered as dependencies). They are meant to be used when the targets do not directly depend on them, but the computation of their dynamic dependencies does. @verbatim %.o : %.c | parser.h gcc -MMD -MF $@.d -o $@ -c $< remake -r < $@.d rm $@.d parser.c parser.h: parser.y yacc -d -o parser.c parser.y @endverbatim \subsection sec-static-pattern Static pattern rules A rule with the following structure is expanded into several rules, one per target. @verbatim targets: pattern1 pattern2 ...: prerequisites @endverbatim Every target is matched against one of the patterns containing the `%` character. A rule is then created using the patterns as targets, after having substituted `%` in the patterns and prerequisites. The automatic variable `$*` can be used in the script of the rule. \subsection sec-special-tgt Special targets Target `.PHONY` marks its prerequisites as being always obsolete. \subsection sec-special-var Special variables Variable `.OPTIONS` is handled specially. Its content enables some features of remake that are not enabled by default. - `variable-propagation`: When a variable is set in the prerequisite part of a rule, it is propagated to the rules of all the targets this rule depends on. This option also enables variables to be set on the command line. Note that, as in make, this features introduces non-determinism: the content of some variables will depend on the build order. \section sec-semantics Semantics \subsection src-obsolete When are targets obsolete? A target is obsolete: - if there is no file corresponding to the target, or to one of its siblings in a multi-target rule, - if any of its dynamic prerequisites from a previous run or any of its static prerequisites is obsolete, - if the latest file corresponding to its siblings or itself is older than any of its dynamic prerequisites or static prerequisites. In all the other cases, it is assumed to be up-to-date (and so are all its siblings). Note that the last rule above says "latest" and not "earliest". While it might cause some obsolete targets to go unnoticed in corner cases, it allows for the following kind of rules: @verbatim config.h stamp-config_h: config.h.in config.status ./config.status config.h touch stamp-config_h @endverbatim A `config.status` file generally does not update header files (here `config.h`) if they would not change. As a consequence, if not for the `stamp-config_h` file above, a header would always be considered obsolete once one of its prerequisites is modified. Note that touching `config.h` rather than `stamp-config_h` would defeat the point of not updating it in the first place, since the program files would need to be rebuilt. Once all the static prerequisites of a target have been rebuilt, remake checks whether the target still needs to be built. If it was obsolete only because its prerequisites needed to be rebuilt and none of them changed, the target is assumed to be up-to-date. \subsection sec-rules How are targets (re)built? There are two kinds of rules. If any of the targets or prerequisites contains a `%` character, the rule is said to be generic. All the targets of the rule shall then contain a single `%` character. All the other rules are said to be specific. A rule is said to match a given target: - if it is specific and the target appears inside its target list, - if it is generic and there is a way to replace the `%` character from one of its targets so that it matches the given target. When remake tries to build a given target, it looks for a specific rule that matches it. If there is one and its script is nonempty, it uses it to rebuild the target. Otherwise, it looks for a generic rule that matches the target. If there are several matching rules, it chooses the one with the shortest pattern (and if there are several ones, the earliest one). It then looks for specific rules that match each target of the generic rule. All the prerequisites of these specific rules are added to those of the generic rule. The script of the generic rule is used to build the target. Example: @verbatim t%1 t2%: p1 p%2 commands building t%1 and t2% t2z: p4 commands building t2z ty1: p3 # t2x is built by the first rule (which also builds tx1) and its prerequisites are p1, px2 # t2y is built by the first rule (which also builds ty1) and its prerequisites are p1, py2, p3 # t2z is built by the second rule and its prerequisite is p4 @endverbatim The set of rules from Remakefile is ill-formed: - if any specific rule matching a target of the generic rule has a nonempty script, - if any target of the generic rule is matched by a generic rule with a shorter pattern. \section sec-compilation Compilation - On Linux, MacOSX, and BSD: `g++ -o remake remake.cpp` - On Windows: `g++ -o remake.exe remake.cpp -lws2_32` Installing remake is needed only if Remakefile does not specify the path to the executable for its recursive calls. Thanks to its single source file, remake can be shipped inside other packages and built at configuration time. \section sec-differences Differences with other build systems Differences with make: - Dynamic dependencies are supported. - For rules with multiple targets, the shell script is executed only once and is assumed to build all the targets. There is no need for convoluted rules that are robust enough for parallel builds. For generic rules, this is similar to the behavior of pattern rules from gmake. - As with redo, only one shell is run when executing a script, rather than one per script line. Note that the shells are run with option `-e`, thus causing them to exit as soon as an error is encountered. - The prerequisites of generic rules (known as implicit rules in make lingo) are not used to decide between several of them, which means that remake does not select one for which it could satisfy the dependencies. - Variables and built-in functions are expanded as they are encountered during Remakefile parsing. - Target-specific variables are not propagated, unless specifically enabled, since this causes non-deterministic builds. This is the same for variables set on the command line. Differences with redo: - As with make, it is possible to write the following kind of rules in remake. @verbatim Remakefile: Remakefile.in ./config.status ./config.status Remakefile @endverbatim - If a target is already built the first time remake runs, it still uses the static prerequisites of rules mentioning it to check whether it needs to be rebuilt. It does not assume it to be up-to-date. As with redo though, if its obsolete status would be due to a dynamic prerequisite, it will go unnoticed; it should be removed beforehand. - Multiple targets are supported. - remake has almost no features: no checksum-based dependencies, no compatibility with job servers, etc. \section sec-limitations Limitations - If a rule script calls remake, the current working directory should be the directory containing Remakefile (or the working directory from the original remake if it was called with option `-f`). - As with make, variables passed on the command line should keep the same values, to ensure deterministic builds. - Some cases of ill-formed rules are not caught by remake and can thus lead to unpredictable behaviors. \section sec-links Links @see http://cr.yp.to/redo.html for the philosophy of redo and https://github.com/apenwarr/redo for an implementation and some comprehensive documentation. \section sec-licensing Licensing @author Guillaume Melquiond @version 0.15 @date 2012-2020 @copyright 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 3 of the License, or (at your option) any later version. \n 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. \section sec-internals Internals The parent remake process acts as a server. The other ones have a REMAKE_SOCKET environment variable that tells them how to contact the server. They send the content of the REMAKE_JOB_ID environment variable, so that the server can associate the child targets to the jobs that spawned them. They then wait for completion and exit with the status returned by the server. This is handled by #client_mode. The server calls #load_dependencies and #save_dependencies to serialize dynamic dependencies from .remake. It loads Remakefile with #load_rules. It then runs #server_mode, which calls #server_loop. When building a target, the following sequence of events happens: - #start calls #find_rule (and #find_generic_rule) to get the rule. - It then creates a pseudo-client if the rule has static dependencies, or calls #run_script otherwise. In both cases, a new job is created; the rule and the variables are stored into #jobs. - #run_script creates a shell process and stores it in #job_pids. It increases #running_jobs. - The child process possibly calls remake with a list of targets. - #accept_client receives a build request from a child process and adds it to #clients. It also records the new dependencies of the job into #dependencies. It increases #waiting_jobs. - #handle_clients uses #get_status to look up the obsoleteness of the targets. - Once the targets of a request have been built or one of them has failed, #handle_clients calls #complete_request and removes the request from #clients. - If the build targets come from a pseudo-client, #complete_request calls #run_script. Otherwise it sends the reply to the corresponding child process and decreases #waiting_jobs. - When a child process ends, #server_loop calls #finalize_job, which removes the process from #job_pids, decreases #running_jobs, and calls #complete_job. - #complete_job removes the job from #jobs and calls #update_status to change the status of the targets. It also removes the target files in case of failure. */ #ifdef _WIN32 #define WIN32_LEAN_AND_MEAN #define WINDOWS #endif #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #include #ifdef __APPLE__ #define MACOSX #endif #ifdef __linux__ #define LINUX #endif #ifdef WINDOWS #include #include #include #define pid_t HANDLE typedef SOCKET socket_t; #else #include #include #include typedef int socket_t; enum { INVALID_SOCKET = -1 }; extern char **environ; #endif #if (defined(WINDOWS) || defined(MACOSX)) && !defined(MSG_NOSIGNAL) enum { MSG_NOSIGNAL = 0 }; #endif typedef std::list string_list; typedef std::set string_set; /** * Reference-counted shared object. * @note The default constructor delays the creation of the object until it * is first dereferenced. */ template struct ref_ptr { struct content { size_t cnt; T val; content(): cnt(1) {} content(T const &t): cnt(1), val(t) {} }; mutable content *ptr; ref_ptr(): ptr(NULL) {} ref_ptr(T const &t): ptr(new content(t)) {} ref_ptr(ref_ptr const &p): ptr(p.ptr) { if (ptr) ++ptr->cnt; } ~ref_ptr() { if (ptr && --ptr->cnt == 0) delete ptr; } ref_ptr &operator=(ref_ptr const &p) { if (ptr == p.ptr) return *this; if (ptr && --ptr->cnt == 0) delete ptr; ptr = p.ptr; if (ptr) ++ptr->cnt; return *this; } T &operator*() const { if (!ptr) ptr = new content; return ptr->val; } T *operator->() const { return &**this; } }; struct dependency_t { string_list targets; string_set deps; }; typedef std::map > dependency_map; typedef std::map variable_map; /** * Build status of a target. */ enum status_e { Uptodate, ///< Target is up-to-date. Todo, ///< Target is missing or obsolete. Recheck, ///< Target has an obsolete dependency. Running, ///< Target is being rebuilt. RunningRecheck, ///< Static prerequisites are being rebuilt. Remade, ///< Target was successfully rebuilt. Failed ///< Build failed for target. }; /** * Build status of a target. */ struct status_t { status_e status; ///< Actual status. time_t last; ///< Last-modified date. }; typedef std::map status_map; /** * Delayed assignment to a variable. */ struct assign_t { bool append; string_list value; }; typedef std::map assign_map; /** * A rule loaded from Remakefile. */ struct rule_t { string_list targets; ///< Files produced by this rule. string_list deps; ///< Dependencies used for an implicit call to remake at the start of the script. string_list wdeps; ///< Like #deps, except that they are not registered as dependencies. assign_map assigns; ///< Assignment of variables. std::string stem; ///< Stem used to instantiate the rule, if any. std::string script; ///< Shell script for building the targets. }; typedef std::list rule_list; typedef std::map > rule_map; /** * A job created from a set of rules. */ struct job_t { rule_t rule; ///< Original rule. variable_map vars; ///< Values of local variables. }; typedef std::map job_map; typedef std::map pid_job_map; /** * Client waiting for a request to complete. * * There are two kinds of clients: * - real clients, which are instances of remake created by built scripts, * - pseudo clients, which are created by the server to build specific targets. * * Among pseudo clients, there are two categories: * - original clients, which are created for the targets passed on the * command line by the user or for the initial regeneration of the rule file, * - dependency clients, which are created to handle rules that have * explicit dependencies and thus to emulate a call to remake. */ struct client_t { socket_t socket; ///< Socket used to reply to the client (invalid for pseudo clients). int job_id; ///< Job for which the built script called remake and spawned the client (negative for original clients). bool failed; ///< Whether some targets failed in mode -k. string_list pending; ///< Targets not yet started. string_set running; ///< Targets being built. variable_map vars; ///< Variables set on request. bool delayed; ///< Whether it is a dependency client and a script has to be started on request completion. client_t(): socket(INVALID_SOCKET), job_id(-1), failed(false), delayed(false) {} }; typedef std::list client_list; /** * Map from variable names to their content. * Initialized with the values passed on the command line. */ static variable_map variables; /** * Map from targets to their known dependencies. */ static dependency_map dependencies; /** * Map from targets to their build status. */ static status_map status; /** * Set of generic rules loaded from Remakefile. */ static rule_list generic_rules; /** * Map from targets to specific rules loaded from Remakefile. */ static rule_map specific_rules; /** * Map of jobs being built. */ static job_map jobs; /** * Map from jobs to shell pids. */ static pid_job_map job_pids; /** * List of clients waiting for a request to complete. * New clients are put to front, so that the build process is depth-first. */ static client_list clients; /** * Maximum number of parallel jobs (non-positive if unbounded). * Can be modified by the -j option. */ static int max_active_jobs = 1; /** * Whether to keep building targets in case of failure. * Can be modified by the -k option. */ static bool keep_going = false; /** * Number of jobs currently running: * - it increases when a process is created in #run_script, * - it decreases when a completion message is received in #finalize_job. * * @note There might be some jobs running while #clients is empty. * Indeed, if a client requested two targets to be rebuilt, if they * are running concurrently, if one of them fails, the client will * get a failure notice and might terminate before the other target * finishes. */ static int running_jobs = 0; /** * Number of jobs currently waiting for a build request to finish: * - it increases when a build request is received in #accept_client * (since the client is presumably waiting for the reply), * - it decreases when a reply is sent in #complete_request. */ static int waiting_jobs = 0; /** * Global counter used to produce increasing job numbers. * @see jobs */ static int job_counter = 0; /** * Socket on which the server listens for client request. */ static socket_t socket_fd; /** * Whether the request of an original client failed. */ static bool build_failure; #ifndef WINDOWS /** * Name of the server socket in the file system. */ static char *socket_name; #endif /** * Name of the first target of the first specific rule, used for default run. */ static std::string first_target; /** * Whether a short message should be displayed for each target. */ static bool show_targets = true; /** * Whether script commands are echoed. */ static bool echo_scripts = false; /** * Time at the start of the program. */ static time_t now = time(NULL); /** * Directory with respect to which command-line names are relative. */ static std::string working_dir; /** * Directory with respect to which targets are relative. */ static std::string prefix_dir; /** * Whether the prefix directory is different from #working_dir. */ static bool changed_prefix_dir; /** * Whether target-specific variables are propagated to prerequisites. */ static bool propagate_vars = false; /** * Whether targets are unconditionally obsolete. */ static bool obsolete_targets = false; #ifndef WINDOWS static sigset_t old_sigmask; static volatile sig_atomic_t got_SIGCHLD = 0; static void sigchld_handler(int) { got_SIGCHLD = 1; } static void sigint_handler(int) { // Child processes will receive the signal too, so just prevent // new jobs from starting and wait for the running jobs to fail. keep_going = false; } #endif struct log { bool active, open; int depth; log(): active(false), open(false), depth(0) { } std::ostream &operator()() { if (open) std::cerr << std::endl; assert(depth >= 0); std::cerr << std::string(depth * 2, ' '); open = false; return std::cerr; } std::ostream &operator()(bool o) { if (o && open) std::cerr << std::endl; if (!o) --depth; assert(depth >= 0); if (o || !open) std::cerr << std::string(depth * 2, ' '); if (o) ++depth; open = o; return std::cerr; } }; static struct log debug; struct log_auto_close { bool still_open; log_auto_close(): still_open(true) { } ~log_auto_close() { if (debug.active && still_open) debug(false) << "done\n"; } }; #define DEBUG if (debug.active) debug() #define DEBUG_open log_auto_close auto_close; if (debug.active) debug(true) #define DEBUG_close if ((auto_close.still_open = false), debug.active) debug(false) /** * Strong typedef for strings that need escaping. * @note The string is stored as a reference, so the constructed object is * meant to be immediately consumed. */ struct escape_string { std::string const &input; escape_string(std::string const &s): input(s) {} }; /** * Write the string in @a se to @a out if it does not contain any special * characters, a quoted and escaped string otherwise. */ static std::ostream &operator<<(std::ostream &out, escape_string const &se) { std::string const &s = se.input; char const *quoted_char = ",: '"; char const *escaped_char = "\"\\$!"; bool need_quotes = false; char *buf = NULL; size_t len = s.length(), last = 0, j = 0; for (size_t i = 0; i < len; ++i) { if (strchr(escaped_char, s[i])) { need_quotes = true; if (!buf) buf = new char[len * 2]; memcpy(&buf[j], &s[last], i - last); j += i - last; buf[j++] = '\\'; buf[j++] = s[i]; last = i + 1; } if (!need_quotes && strchr(quoted_char, s[i])) need_quotes = true; } if (!need_quotes) return out << s; out << '"'; if (!buf) return out << s << '"'; out.write(buf, j); out.write(&s[last], len - last); delete[] buf; return out << '"'; } /** * @defgroup paths Path helpers * * @{ */ /** * Initialize #working_dir. */ static void init_working_dir() { char buf[1024]; char *res = getcwd(buf, sizeof(buf)); if (!res) { perror("Failed to get working directory"); exit(EXIT_FAILURE); } working_dir = buf; #ifdef WINDOWS for (size_t i = 0, l = working_dir.size(); i != l; ++i) { if (working_dir[i] == '\\') working_dir[i] = '/'; } #endif prefix_dir = working_dir; } /** * Initialize #prefix_dir and switch to it. */ static void init_prefix_dir() { for (;;) { struct stat s; if (stat((prefix_dir + "/Remakefile").c_str(), &s) == 0) { if (!changed_prefix_dir) return; if (chdir(prefix_dir.c_str())) { perror("Failed to change working directory"); exit(EXIT_FAILURE); } if (show_targets) { std::cout << "remake: Entering directory `" << prefix_dir << '\'' << std::endl; } return; } size_t pos = prefix_dir.find_last_of('/'); if (pos == std::string::npos) { std::cerr << "Failed to locate Remakefile in the current directory or one of its parents" << std::endl; exit(EXIT_FAILURE); } prefix_dir.erase(pos); changed_prefix_dir = true; } } /** * Normalize an absolute path with respect to @a p. * Paths outside the subtree are left unchanged. */ static std::string normalize_abs(std::string const &s, std::string const &p) { size_t l = p.length(); if (s.compare(0, l, p)) return s; size_t ll = s.length(); if (ll == l) return "."; if (s[l] != '/') { size_t pos = s.rfind('/', l); assert(pos != std::string::npos); return s.substr(pos + 1); } if (ll == l + 1) return "."; return s.substr(l + 1); } /** * Normalize path @a s (possibly relative to @a w) with respect to @a p. * * - If both @a p and @a w are empty, the function just removes ".", "..", "//". * - If only @a p is empty, the function returns an absolute path. */ static std::string normalize(std::string const &s, std::string const &w, std::string const &p) { #ifdef WINDOWS char const *delim = "/\\"; #else char delim = '/'; #endif size_t pos = s.find_first_of(delim); if (pos == std::string::npos && w == p) return s; bool absolute = pos == 0; if (!absolute && w != p && !w.empty()) return normalize(w + '/' + s, w, p); size_t prev = 0, len = s.length(); string_list l; for (;;) { if (pos != prev) { std::string n = s.substr(prev, pos - prev); if (n == "..") { if (!l.empty()) l.pop_back(); else if (!absolute && !w.empty()) return normalize(w + '/' + s, w, p); } else if (n != ".") l.push_back(n); } ++pos; if (pos >= len) break; prev = pos; pos = s.find_first_of(delim, prev); if (pos == std::string::npos) pos = len; } string_list::const_iterator i = l.begin(), i_end = l.end(); if (i == i_end) return absolute ? "/" : "."; std::string n; if (absolute) n.push_back('/'); n.append(*i); for (++i; i != i_end; ++i) { n.push_back('/'); n.append(*i); } if (absolute && !p.empty()) return normalize_abs(n, p); return n; } /** * Normalize the content of a list of targets. */ static void normalize_list(string_list &l, std::string const &w, std::string const &p) { for (string_list::iterator i = l.begin(), i_end = l.end(); i != i_end; ++i) { *i = normalize(*i, w, p); } } /** @} */ /** * @defgroup lexer Lexer * * @{ */ /** * Skip spaces. */ static void skip_spaces(std::istream &in) { char c; while (strchr(" \t", (c = in.get()))) {} if (in.good()) in.putback(c); } /** * Skip empty lines. */ static void skip_empty(std::istream &in) { char c; while (strchr("\r\n", (c = in.get()))) {} if (in.good()) in.putback(c); } /** * Skip end of line. If @a multi is true, skip the following empty lines too. * @return true if there was a line to end. */ static bool skip_eol(std::istream &in, bool multi = false) { char c = in.get(); if (c == '\r') c = in.get(); if (c != '\n' && in.good()) in.putback(c); if (c != '\n' && !in.eof()) return false; if (multi) skip_empty(in); return true; } enum { Unexpected = 0, Word = 1 << 1, Colon = 1 << 2, Equal = 1 << 3, Dollarpar = 1 << 4, Rightpar = 1 << 5, Comma = 1 << 6, Plusequal = 1 << 7, Pipe = 1 << 8, }; /** * Skip spaces and peek at the next token. * If it is one of @a mask, skip it (if it is not Word) and return it. * @note For composite tokens allowed by @a mask, input characters might * have been eaten even for an Unexpected result. */ static int expect_token(std::istream &in, int mask) { while (true) { skip_spaces(in); char c = in.peek(); if (!in.good()) return Unexpected; int tok; switch (c) { case '\r': case '\n': return Unexpected; case ':': tok = Colon; break; case ',': tok = Comma; break; case '=': tok = Equal; break; case ')': tok = Rightpar; break; case '|': tok = Pipe; break; case '$': if (!(mask & Dollarpar)) return Unexpected; in.ignore(1); tok = Dollarpar; if (in.peek() != '(') return Unexpected; break; case '+': if (!(mask & Plusequal)) return Unexpected; in.ignore(1); tok = Plusequal; if (in.peek() != '=') return Unexpected; break; case '\\': in.ignore(1); if (skip_eol(in)) continue; in.putback('\\'); return mask & Word ? Word : Unexpected; default: return mask & Word ? Word : Unexpected; } if (!(tok & mask)) return Unexpected; in.ignore(1); return tok; } } /** * Read a (possibly quoted) word. */ static std::string read_word(std::istream &in, bool detect_equal = true) { int c = in.peek(); std::string res; if (!in.good()) return res; char const *separators = " \t\r\n$(),:"; bool quoted = c == '"'; if (quoted) in.ignore(1); bool plus = false; while (true) { c = in.peek(); if (!in.good()) return res; if (quoted) { in.ignore(1); if (c == '\\') res += in.get(); else if (c == '"') quoted = false; else res += c; continue; } if (detect_equal && c == '=') { if (plus) in.putback('+'); return res; } if (plus) { res += '+'; plus = false; } if (strchr(separators, c)) return res; in.ignore(1); if (detect_equal && c == '+') plus = true; else res += c; } } /** @} */ /** * @defgroup stream Token streams * * @{ */ /** * Possible results from word producers. */ enum input_status { Success, SyntaxError, Eof }; /** * Interface for word producers. */ struct generator { virtual ~generator() {} virtual input_status next(std::string &) = 0; }; /** * Generator for the words of a variable. */ struct variable_generator: generator { std::string name; string_list::const_iterator vcur, vend; variable_generator(std::string const &, variable_map const *); input_status next(std::string &); }; variable_generator::variable_generator(std::string const &n, variable_map const *local_variables): name(n) { if (local_variables) { variable_map::const_iterator i = local_variables->find(name); if (i != local_variables->end()) { vcur = i->second.begin(); vend = i->second.end(); return; } } variable_map::const_iterator i = variables.find(name); if (i == variables.end()) return; vcur = i->second.begin(); vend = i->second.end(); } input_status variable_generator::next(std::string &res) { if (vcur != vend) { res = *vcur; ++vcur; return Success; } return Eof; } /** * Generator for the words of an input stream. */ struct input_generator { std::istream ∈ generator *nested; variable_map const *local_variables; bool earliest_exit, done; input_generator(std::istream &i, variable_map const *lv, bool e = false) : in(i), nested(NULL), local_variables(lv), earliest_exit(e), done(false) {} input_status next(std::string &); ~input_generator() { assert(!nested); } }; static generator *get_function(input_generator const &, std::string const &); input_status input_generator::next(std::string &res) { if (nested) { restart: input_status s = nested->next(res); if (s == Success) return Success; delete nested; nested = NULL; if (s == SyntaxError) return SyntaxError; } if (done) return Eof; if (earliest_exit) done = true; switch (expect_token(in, Word | Dollarpar)) { case Word: res = read_word(in, false); return Success; case Dollarpar: { std::string name = read_word(in, false); if (name.empty()) return SyntaxError; if (expect_token(in, Rightpar)) nested = new variable_generator(name, local_variables); else { nested = get_function(*this, name); if (!nested) return SyntaxError; } goto restart; } default: return Eof; } } /** * Read a list of words from an input generator. * @return false if a syntax error was encountered. */ static bool read_words(input_generator &in, string_list &res) { while (true) { res.push_back(std::string()); input_status s = in.next(res.back()); if (s == Success) continue; res.pop_back(); return s == Eof; } } static bool read_words(std::istream &in, string_list &res) { input_generator gen(in, NULL); return read_words(gen, res); } /** * Generator for the result of function addprefix. */ struct addprefix_generator: generator { input_generator gen; string_list pre; string_list::const_iterator prei; size_t prej, prel; std::string suf; addprefix_generator(input_generator const &, bool &); input_status next(std::string &); }; addprefix_generator::addprefix_generator(input_generator const &top, bool &ok) : gen(top.in, top.local_variables) { if (!read_words(gen, pre)) return; if (!expect_token(gen.in, Comma)) return; prej = 0; prel = pre.size(); ok = true; } input_status addprefix_generator::next(std::string &res) { if (prej) { produce: if (prej == prel) { res = *prei + suf; prej = 0; } else { res = *prei++; ++prej; } return Success; } switch (gen.next(res)) { case Success: if (!prel) return Success; prei = pre.begin(); prej = 1; suf = res; goto produce; case Eof: return expect_token(gen.in, Rightpar) ? Eof : SyntaxError; default: return SyntaxError; } } /** * Generator for the result of function addsuffix. */ struct addsuffix_generator: generator { input_generator gen; string_list suf; string_list::const_iterator sufi; size_t sufj, sufl; std::string pre; addsuffix_generator(input_generator const &, bool &); input_status next(std::string &); }; addsuffix_generator::addsuffix_generator(input_generator const &top, bool &ok) : gen(top.in, top.local_variables) { if (!read_words(gen, suf)) return; if (!expect_token(gen.in, Comma)) return; sufj = 0; sufl = suf.size(); ok = true; } input_status addsuffix_generator::next(std::string &res) { if (sufj) { if (sufj != sufl) { res = *sufi++; ++sufj; return Success; } sufj = 0; } switch (gen.next(res)) { case Success: if (!sufl) return Success; sufi = suf.begin(); sufj = 1; res += *sufi++; return Success; case Eof: return expect_token(gen.in, Rightpar) ? Eof : SyntaxError; default: return SyntaxError; } } /** * Return a generator for function @a name. */ static generator *get_function(input_generator const &in, std::string const &name) { skip_spaces(in.in); generator *g = NULL; bool ok = false; if (name == "addprefix") g = new addprefix_generator(in, ok); else if (name == "addsuffix") g = new addsuffix_generator(in, ok); if (!g || ok) return g; delete g; return NULL; } /** @} */ /** * @defgroup database Dependency database * * @{ */ /** * Load dependencies from @a in. */ static void load_dependencies(std::istream &in) { if (false) { error: std::cerr << "Failed to load database" << std::endl; exit(EXIT_FAILURE); } while (!in.eof()) { string_list targets; if (!read_words(in, targets)) goto error; if (in.eof()) return; if (targets.empty()) goto error; DEBUG << "reading dependencies of target " << targets.front() << std::endl; if (in.get() != ':') goto error; ref_ptr dep; dep->targets = targets; string_list deps; if (!read_words(in, deps)) goto error; dep->deps.insert(deps.begin(), deps.end()); for (string_list::const_iterator i = targets.begin(), i_end = targets.end(); i != i_end; ++i) { dependencies[*i] = dep; } skip_empty(in); } } /** * Load known dependencies from file `.remake`. */ static void load_dependencies() { DEBUG_open << "Loading database... "; std::ifstream in(".remake"); if (!in.good()) { DEBUG_close << "not found\n"; return; } load_dependencies(in); } /** * Save all the dependencies in file `.remake`. */ static void save_dependencies() { DEBUG_open << "Saving database... "; std::ofstream db(".remake"); while (!dependencies.empty()) { ref_ptr dep = dependencies.begin()->second; for (string_list::const_iterator i = dep->targets.begin(), i_end = dep->targets.end(); i != i_end; ++i) { db << escape_string(*i) << ' '; dependencies.erase(*i); } db << ':'; for (string_set::const_iterator i = dep->deps.begin(), i_end = dep->deps.end(); i != i_end; ++i) { db << ' ' << escape_string(*i); } db << std::endl; } } /** @} */ static void merge_rule(rule_t &dest, rule_t const &src); static void instantiate_rule(std::string const &target, rule_t const &src, rule_t &dst); /** * @defgroup parser Rule parser * * @{ */ /** * Register a specific rule with an empty script: * * - Check that none of the targets already has an associated rule with a * nonempty script. * - Create a new rule with a single target for each target, if needed. * - Add the prerequisites of @a rule to all these associated rules. */ static void register_transparent_rule(rule_t const &rule, string_list const &targets) { assert(rule.script.empty()); for (string_list::const_iterator i = targets.begin(), i_end = targets.end(); i != i_end; ++i) { std::pair j = specific_rules.insert(std::make_pair(*i, ref_ptr())); ref_ptr &r = j.first->second; if (j.second) { r = ref_ptr(rule); r->targets = string_list(1, *i); continue; } if (!r->script.empty()) { std::cerr << "Failed to load rules: " << *i << " cannot be the target of several rules" << std::endl; exit(EXIT_FAILURE); } assert(r->targets.size() == 1 && r->targets.front() == *i); merge_rule(*r, rule); } for (string_list::const_iterator i = targets.begin(), i_end = targets.end(); i != i_end; ++i) { ref_ptr &dep = dependencies[*i]; if (dep->targets.empty()) dep->targets.push_back(*i); dep->deps.insert(rule.deps.begin(), rule.deps.end()); } } /** * Register a specific rule with a nonempty script: * * - Check that none of the targets already has an associated rule. * - Create a single shared rule and associate it to all the targets. * - Merge the prerequisites of all the targets into a single set and * add the prerequisites of the rule to it. (The preexisting * prerequisites, if any, come from a previous run.) */ static void register_scripted_rule(rule_t const &rule) { ref_ptr r(rule); for (string_list::const_iterator i = rule.targets.begin(), i_end = rule.targets.end(); i != i_end; ++i) { std::pair j = specific_rules.insert(std::make_pair(*i, r)); if (j.second) continue; std::cerr << "Failed to load rules: " << *i << " cannot be the target of several rules" << std::endl; exit(EXIT_FAILURE); } ref_ptr dep; dep->targets = rule.targets; dep->deps.insert(rule.deps.begin(), rule.deps.end()); for (string_list::const_iterator i = rule.targets.begin(), i_end = rule.targets.end(); i != i_end; ++i) { ref_ptr &d = dependencies[*i]; dep->deps.insert(d->deps.begin(), d->deps.end()); d = dep; } } /** * Register a specific rule. */ static void register_rule(rule_t const &rule) { if (!rule.script.empty()) { register_scripted_rule(rule); } else { // Swap away the targets to avoid costly copies when registering. rule_t &r = const_cast(rule); string_list targets; targets.swap(r.targets); register_transparent_rule(r, targets); targets.swap(r.targets); } // If there is no default target yet, mark it as such. if (first_target.empty()) first_target = rule.targets.front(); } /** * Read a rule starting with target @a first, if nonempty. * Store into #generic_rules or #specific_rules depending on its genericity. */ static void load_rule(std::istream &in, std::string const &first) { DEBUG_open << "Reading rule for target " << first << "... "; if (false) { error: DEBUG_close << "failed\n"; std::cerr << "Failed to load rules: syntax error" << std::endl; exit(EXIT_FAILURE); } // Read targets and check genericity. string_list targets; if (!read_words(in, targets)) goto error; if (!first.empty()) targets.push_front(first); else if (targets.empty()) goto error; else DEBUG << "actual target: " << targets.front() << std::endl; bool generic = false; normalize_list(targets, "", ""); for (string_list::const_iterator i = targets.begin(), i_end = targets.end(); i != i_end; ++i) { if (i->empty()) goto error; if ((i->find('%') != std::string::npos) != generic) { if (i == targets.begin()) generic = true; else goto error; } } skip_spaces(in); if (in.get() != ':') goto error; bool assignment = false, static_pattern = false; rule_t rule; rule.targets.swap(targets); // Read dependencies. { string_list v; if (expect_token(in, Word)) { std::string d = read_word(in); if (int tok = expect_token(in, Equal | Plusequal)) { if (!read_words(in, v)) goto error; assign_t &a = rule.assigns[d]; a.append = tok == Plusequal; a.value.swap(v); assignment = true; goto end_line; } v.push_back(d); } if (!read_words(in, v)) goto error; normalize_list(v, "", ""); rule.deps.swap(v); if (expect_token(in, Colon)) { if (!read_words(in, v)) goto error; normalize_list(v, "", ""); targets.swap(rule.targets); rule.targets.swap(rule.deps); rule.deps.swap(v); if (rule.targets.empty()) goto error; for (string_list::const_iterator i = rule.targets.begin(), i_end = rule.targets.end(); i != i_end; ++i) { if (i->find('%') == std::string::npos) goto error; } generic = false; static_pattern = true; } if (expect_token(in, Pipe)) { if (!read_words(in, v)) goto error; normalize_list(v, "", ""); rule.wdeps.swap(v); } } end_line: skip_spaces(in); if (!skip_eol(in, true)) goto error; // Read script. std::ostringstream buf; while (true) { char c = in.get(); if (!in.good()) break; if (c == '\t' || c == ' ') { in.get(*buf.rdbuf()); if (in.fail() && !in.eof()) in.clear(); } else if (c == '\r' || c == '\n') buf << c; else { in.putback(c); break; } } rule.script = buf.str(); // Register phony targets. if (rule.targets.front() == ".PHONY") { for (string_list::const_iterator i = rule.deps.begin(), i_end = rule.deps.end(); i != i_end; ++i) { status[*i].status = Todo; } return; } // Add generic rules to the correct set. if (generic) { if (assignment) goto error; generic_rules.push_back(rule); return; } if (!static_pattern) { if (!rule.script.empty() && assignment) goto error; register_rule(rule); return; } for (string_list::const_iterator i = targets.begin(), i_end = targets.end(); i != i_end; ++i) { rule_t r; instantiate_rule(*i, rule, r); if (!r.stem.empty()) register_rule(r); } } /** * Load rules from @a remakefile. * If some rules have dependencies and non-generic targets, add these * dependencies to the targets. */ static void load_rules(std::string const &remakefile) { DEBUG_open << "Loading rules... "; if (false) { error: std::cerr << "Failed to load rules: syntax error" << std::endl; exit(EXIT_FAILURE); } std::ifstream in(remakefile.c_str()); if (!in.good()) { std::cerr << "Failed to load rules: no Remakefile found" << std::endl; exit(EXIT_FAILURE); } skip_empty(in); string_list options; // Read rules while (in.good()) { char c = in.peek(); if (c == '#') { while (in.get() != '\n') {} skip_empty(in); continue; } if (c == ' ' || c == '\t') goto error; if (expect_token(in, Word)) { std::string name = read_word(in); if (name.empty()) goto error; if (int tok = expect_token(in, Equal | Plusequal)) { DEBUG << "Assignment to variable " << name << std::endl; string_list value; if (!read_words(in, value)) goto error; string_list &dest = *(name == ".OPTIONS" ? &options : &variables[name]); if (tok == Equal) dest.swap(value); else dest.splice(dest.end(), value); if (!skip_eol(in, true)) goto error; } else load_rule(in, name); } else load_rule(in, std::string()); } // Set actual options. for (string_list::const_iterator i = options.begin(), i_end = options.end(); i != i_end; ++i) { if (*i == "variable-propagation") propagate_vars = true; else { std::cerr << "Failed to load rules: unrecognized option" << std::endl; exit(EXIT_FAILURE); } } } /** @} */ /** * @defgroup rules Rule resolution * * @{ */ static void merge_rule(rule_t &dest, rule_t const &src) { dest.deps.insert(dest.deps.end(), src.deps.begin(), src.deps.end()); dest.wdeps.insert(dest.wdeps.end(), src.wdeps.begin(), src.wdeps.end()); for (assign_map::const_iterator i = src.assigns.begin(), i_end = src.assigns.end(); i != i_end; ++i) { if (!i->second.append) { new_assign: dest.assigns[i->first] = i->second; continue; } assign_map::iterator j = dest.assigns.find(i->first); if (j == dest.assigns.end()) goto new_assign; j->second.value.insert(j->second.value.end(), i->second.value.begin(), i->second.value.end()); } } /** * Substitute a pattern into a list of strings. */ static void substitute_pattern(std::string const &pat, string_list const &src, string_list &dst) { for (string_list::const_iterator i = src.begin(), i_end = src.end(); i != i_end; ++i) { size_t pos = i->find('%'); if (pos == std::string::npos) dst.push_back(*i); else dst.push_back(i->substr(0, pos) + pat + i->substr(pos + 1)); } } /** * Instantiate a specific rule, given a target and a generic rule. * If the rule @a dst already contains a stem longer than the one found, * it is left unchanged. */ static void instantiate_rule(std::string const &target, rule_t const &src, rule_t &dst) { size_t tlen = target.length(), plen = dst.stem.length(); for (string_list::const_iterator j = src.targets.begin(), j_end = src.targets.end(); j != j_end; ++j) { size_t len = j->length(); if (tlen < len) continue; if (plen && plen <= tlen - (len - 1)) continue; size_t pos = j->find('%'); if (pos == std::string::npos) continue; size_t len2 = len - (pos + 1); if (j->compare(0, pos, target, 0, pos) || j->compare(pos + 1, len2, target, tlen - len2, len2)) continue; plen = tlen - (len - 1); dst = rule_t(); dst.stem = target.substr(pos, plen); dst.script = src.script; substitute_pattern(dst.stem, src.targets, dst.targets); substitute_pattern(dst.stem, src.deps, dst.deps); substitute_pattern(dst.stem, src.wdeps, dst.wdeps); break; } } /** * Find a generic rule matching @a target: * - the one leading to shorter matches has priority, * - among equivalent rules, the earliest one has priority. */ static void find_generic_rule(job_t &job, std::string const &target) { for (rule_list::const_iterator i = generic_rules.begin(), i_end = generic_rules.end(); i != i_end; ++i) { instantiate_rule(target, *i, job.rule); } } /** * Find a specific rule matching @a target. Return a generic one otherwise. * If there is both a specific rule with an empty script and a generic rule, the * generic one is returned after adding the dependencies of the specific one. */ static void find_rule(job_t &job, std::string const &target) { rule_map::const_iterator i = specific_rules.find(target), i_end = specific_rules.end(); // If there is a specific rule with a script, return it. if (i != i_end && !i->second->script.empty()) { job.rule = *i->second; return; } find_generic_rule(job, target); // If there is no generic rule, return the specific rule (no script), if any. if (job.rule.targets.empty()) { if (i != i_end) { job.rule = *i->second; return; } } // Optimize the lookup when there is only one target (already looked up). if (job.rule.targets.size() == 1) { if (i == i_end) return; merge_rule(job.rule, *i->second); return; } // Add the dependencies of the specific rules of every target to the // generic rule. If any of those rules has a nonempty script, error out. for (string_list::const_iterator j = job.rule.targets.begin(), j_end = job.rule.targets.end(); j != j_end; ++j) { i = specific_rules.find(*j); if (i == i_end) continue; if (!i->second->script.empty()) return; merge_rule(job.rule, *i->second); } } /** @} */ /** * @defgroup status Target status * * @{ */ /** * Compute and memoize the status of @a target: * - if the file does not exist, the target is obsolete, * - if any dependency is obsolete or younger than the file, it is obsolete, * - otherwise it is up-to-date. * * @note For rules with multiple targets, all the targets share the same * status. (If one is obsolete, they all are.) The second rule above * is modified in that case: the latest target is chosen, not the oldest! */ static status_t const &get_status(std::string const &target) { std::pair i = status.insert(std::make_pair(target, status_t())); status_t &ts = i.first->second; if (!i.second) return ts; DEBUG_open << "Checking status of " << target << "... "; dependency_map::const_iterator j = dependencies.find(target); if (j == dependencies.end()) { struct stat s; if (stat(target.c_str(), &s) != 0) { DEBUG_close << "missing\n"; ts.status = Todo; ts.last = 0; return ts; } DEBUG_close << "up-to-date\n"; ts.status = Uptodate; ts.last = s.st_mtime; return ts; } if (obsolete_targets) { DEBUG_close << "forcefully obsolete\n"; ts.status = Todo; ts.last = 0; return ts; } dependency_t const &dep = *j->second; status_e st = Uptodate; time_t latest = 0; for (string_list::const_iterator k = dep.targets.begin(), k_end = dep.targets.end(); k != k_end; ++k) { struct stat s; if (stat(k->c_str(), &s) != 0) { if (st == Uptodate) DEBUG_close << *k << " missing\n"; s.st_mtime = 0; st = Todo; } status[*k].last = s.st_mtime; if (s.st_mtime > latest) latest = s.st_mtime; } if (st != Uptodate) goto update; for (string_set::const_iterator k = dep.deps.begin(), k_end = dep.deps.end(); k != k_end; ++k) { status_t const &ts_ = get_status(*k); if (latest < ts_.last) { DEBUG_close << "older than " << *k << std::endl; st = Todo; goto update; } if (ts_.status != Uptodate && st != Recheck) { DEBUG << "obsolete dependency " << *k << std::endl; st = Recheck; } } if (st == Uptodate) DEBUG_close << "all siblings up-to-date\n"; update: for (string_list::const_iterator k = dep.targets.begin(), k_end = dep.targets.end(); k != k_end; ++k) { status[*k].status = st; } return ts; } /** * Change the status of @a target to #Remade or #Uptodate depending on whether * its modification time changed. */ static void update_status(std::string const &target) { DEBUG_open << "Rechecking status of " << target << "... "; status_map::iterator i = status.find(target); assert(i != status.end()); status_t &ts = i->second; ts.status = Remade; if (ts.last >= now) { DEBUG_close << "possibly remade\n"; return; } struct stat s; if (stat(target.c_str(), &s) != 0) { DEBUG_close << "missing\n"; ts.last = 0; } else if (s.st_mtime != ts.last) { DEBUG_close << "remade\n"; ts.last = s.st_mtime; } else { DEBUG_close << "unchanged\n"; ts.status = Uptodate; } } /** * Check whether all the prerequisites of @a target ended being up-to-date. */ static bool still_need_rebuild(std::string const &target) { status_map::const_iterator i = status.find(target); assert(i != status.end()); if (i->second.status != RunningRecheck) return true; DEBUG_open << "Rechecking obsoleteness of " << target << "... "; dependency_map::const_iterator j = dependencies.find(target); assert(j != dependencies.end()); dependency_t const &dep = *j->second; for (string_set::const_iterator k = dep.deps.begin(), k_end = dep.deps.end(); k != k_end; ++k) { if (status[*k].status != Uptodate) return true; } for (string_list::const_iterator k = dep.targets.begin(), k_end = dep.targets.end(); k != k_end; ++k) { status[*k].status = Uptodate; } DEBUG_close << "no longer obsolete\n"; return false; } /** @} */ /** * @defgroup server Server * * @{ */ /** * Handle job completion. */ static void complete_job(int job_id, bool success, bool started = true) { DEBUG << "Completing job " << job_id << '\n'; job_map::iterator i = jobs.find(job_id); assert(i != jobs.end()); string_list const &targets = i->second.rule.targets; if (success) { bool show = show_targets && started; if (show) std::cout << "Finished"; for (string_list::const_iterator j = targets.begin(), j_end = targets.end(); j != j_end; ++j) { update_status(*j); if (show) std::cout << ' ' << *j; } if (show) std::cout << std::endl; } else { std::cerr << "Failed to build"; for (string_list::const_iterator j = targets.begin(), j_end = targets.end(); j != j_end; ++j) { std::cerr << ' ' << *j; update_status(*j); status_e &s = status[*j].status; if (s != Uptodate) { DEBUG << "Removing " << *j << '\n'; remove(j->c_str()); } s = Failed; } std::cerr << std::endl; } jobs.erase(i); } /** * Return the script obtained by substituting variables. */ static std::string prepare_script(job_t const &job) { std::string const &s = job.rule.script; std::istringstream in(s); std::ostringstream out; size_t len = s.size(); while (!in.eof()) { size_t pos = in.tellg(), p = s.find('$', pos); if (p == std::string::npos || p == len - 1) p = len; out.write(&s[pos], p - pos); if (p == len) break; ++p; switch (s[p]) { case '$': out << '$'; in.seekg(p + 1); break; case '<': if (!job.rule.deps.empty()) out << job.rule.deps.front(); in.seekg(p + 1); break; case '^': { bool first = true; for (string_list::const_iterator i = job.rule.deps.begin(), i_end = job.rule.deps.end(); i != i_end; ++i) { if (first) first = false; else out << ' '; out << *i; } in.seekg(p + 1); break; } case '@': assert(!job.rule.targets.empty()); out << job.rule.targets.front(); in.seekg(p + 1); break; case '*': out << job.rule.stem; in.seekg(p + 1); break; case '(': { in.seekg(p - 1); bool first = true; input_generator gen(in, &job.vars, true); while (true) { std::string w; input_status s = gen.next(w); if (s == SyntaxError) { // TODO return "false"; } if (s == Eof) break; if (first) first = false; else out << ' '; out << w; } break; } default: // Let dollars followed by an unrecognized character // go through. This differs from Make, which would // use a one-letter variable. out << '$'; in.seekg(p); } } return out.str(); } /** * Execute the script from @a rule. */ static status_e run_script(int job_id, job_t const &job) { ref_ptr dep; dep->targets = job.rule.targets; dep->deps.insert(job.rule.deps.begin(), job.rule.deps.end()); if (show_targets) std::cout << "Building"; for (string_list::const_iterator i = job.rule.targets.begin(), i_end = job.rule.targets.end(); i != i_end; ++i) { dependencies[*i] = dep; if (show_targets) std::cout << ' ' << *i; } if (show_targets) std::cout << std::endl; std::string script = prepare_script(job); std::ostringstream job_id_buf; job_id_buf << job_id; std::string job_id_ = job_id_buf.str(); DEBUG_open << "Starting script for job " << job_id << "... "; if (script.empty()) { DEBUG_close << "no script\n"; complete_job(job_id, true); return Remade; } if (false) { error: DEBUG_close << "failed\n"; complete_job(job_id, false); return Failed; } #ifdef WINDOWS HANDLE pfd[2]; if (false) { error2: CloseHandle(pfd[0]); CloseHandle(pfd[1]); goto error; } if (!CreatePipe(&pfd[0], &pfd[1], NULL, 0)) goto error; if (!SetHandleInformation(pfd[0], HANDLE_FLAG_INHERIT, HANDLE_FLAG_INHERIT)) goto error2; STARTUPINFO si; ZeroMemory(&si, sizeof(STARTUPINFO)); si.cb = sizeof(STARTUPINFO); si.hStdError = GetStdHandle(STD_ERROR_HANDLE); si.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); si.hStdInput = pfd[0]; si.dwFlags |= STARTF_USESTDHANDLES; PROCESS_INFORMATION pi; ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); if (!SetEnvironmentVariable("REMAKE_JOB_ID", job_id_.c_str())) goto error2; char const *argv = echo_scripts ? "SH.EXE -e -s -v" : "SH.EXE -e -s"; if (!CreateProcess(NULL, (char *)argv, NULL, NULL, true, 0, NULL, NULL, &si, &pi)) { goto error2; } CloseHandle(pi.hThread); DWORD len = script.length(), wlen; if (!WriteFile(pfd[1], script.c_str(), len, &wlen, NULL) || wlen < len) std::cerr << "Unexpected failure while sending script to shell" << std::endl; CloseHandle(pfd[0]); CloseHandle(pfd[1]); ++running_jobs; job_pids[pi.hProcess] = job_id; return Running; #else int pfd[2]; if (false) { error2: close(pfd[0]); close(pfd[1]); goto error; } if (pipe(pfd) == -1) goto error; if (setenv("REMAKE_JOB_ID", job_id_.c_str(), 1)) goto error2; if (pid_t pid = vfork()) { if (pid == -1) goto error2; ssize_t len = script.length(); if (write(pfd[1], script.c_str(), len) < len) std::cerr << "Unexpected failure while sending script to shell" << std::endl; close(pfd[0]); close(pfd[1]); ++running_jobs; job_pids[pid] = job_id; return Running; } // Child process starts here. Notice the use of vfork above. char const *argv[5] = { "sh", "-e", "-s", NULL, NULL }; if (echo_scripts) argv[3] = "-v"; close(pfd[1]); if (pfd[0] != 0) { dup2(pfd[0], 0); close(pfd[0]); } sigprocmask(SIG_SETMASK, &old_sigmask, NULL); execve("/bin/sh", (char **)argv, environ); _exit(EXIT_FAILURE); #endif } /** * Create a job for @a target according to the loaded rules. * Mark all the targets from the rule as running and reset their dependencies. * Inherit variables from @a current, if enabled. * If the rule has dependencies, create a new client to build them just * before @a current, and change @a current so that it points to it. */ static status_e start(std::string const &target, client_list::iterator ¤t) { int job_id = job_counter++; DEBUG_open << "Starting job " << job_id << " for " << target << "... "; job_t &job = jobs[job_id]; find_rule(job, target); if (job.rule.targets.empty()) { status[target].status = Failed; DEBUG_close << "failed\n"; std::cerr << "No rule for building " << target << std::endl; return Failed; } bool has_deps = !job.rule.deps.empty() || !job.rule.wdeps.empty(); status_e st = Running; if (has_deps && status[target].status == Recheck) st = RunningRecheck; for (string_list::const_iterator i = job.rule.targets.begin(), i_end = job.rule.targets.end(); i != i_end; ++i) { status[*i].status = st; } if (propagate_vars) job.vars = current->vars; for (assign_map::const_iterator i = job.rule.assigns.begin(), i_end = job.rule.assigns.end(); i != i_end; ++i) { std::pair k = job.vars.insert(std::make_pair(i->first, string_list())); string_list &v = k.first->second; if (i->second.append) { if (k.second) { variable_map::const_iterator j = variables.find(i->first); if (j != variables.end()) v = j->second; } } else if (!k.second) v.clear(); v.insert(v.end(), i->second.value.begin(), i->second.value.end()); } if (has_deps) { current = clients.insert(current, client_t()); current->job_id = job_id; current->pending = job.rule.deps; current->pending.insert(current->pending.end(), job.rule.wdeps.begin(), job.rule.wdeps.end()); if (propagate_vars) current->vars = job.vars; current->delayed = true; return RunningRecheck; } return run_script(job_id, job); } /** * Send a reply to a client then remove it. * If the client was a dependency client, start the actual script. */ static void complete_request(client_t &client, bool success) { DEBUG_open << "Completing request from client of job " << client.job_id << "... "; if (client.delayed) { assert(client.socket == INVALID_SOCKET); if (success) { job_map::const_iterator i = jobs.find(client.job_id); assert(i != jobs.end()); if (still_need_rebuild(i->second.rule.targets.front())) run_script(client.job_id, i->second); else complete_job(client.job_id, true, false); } else complete_job(client.job_id, false); } else if (client.socket != INVALID_SOCKET) { char res = success ? 1 : 0; send(client.socket, &res, 1, MSG_NOSIGNAL); #ifdef WINDOWS closesocket(client.socket); #else close(client.socket); #endif --waiting_jobs; } if (client.job_id < 0 && !success) build_failure = true; } /** * Return whether there are slots for starting new jobs. */ static bool has_free_slots() { if (max_active_jobs <= 0) return true; return running_jobs - waiting_jobs < max_active_jobs; } /** * Handle client requests: * - check for running targets that have finished, * - start as many pending targets as allowed, * - complete the request if there are neither running nor pending targets * left or if any of them failed. * * @return true if some child processes are still running. * * @post If there are pending requests, at least one child process is running. * * @invariant New free slots cannot appear during a run, since the only way to * decrease #running_jobs is #finalize_job and the only way to * increase #waiting_jobs is #accept_client. None of these functions * are called during a run. So breaking out as soon as there are no * free slots left is fine. */ static bool handle_clients() { DEBUG_open << "Handling client requests... "; restart: bool need_restart = false; for (client_list::iterator i = clients.begin(), i_next = i, i_end = clients.end(); i != i_end; i = i_next) { if (!has_free_slots()) break; ++i_next; DEBUG_open << "Handling client from job " << i->job_id << "... "; // Remove running targets that have finished. for (string_set::iterator j = i->running.begin(), j_next = j, j_end = i->running.end(); j != j_end; j = j_next) { ++j_next; status_map::const_iterator k = status.find(*j); assert(k != status.end()); switch (k->second.status) { case Running: case RunningRecheck: break; case Failed: i->failed = true; if (!keep_going) goto complete; // fallthrough case Uptodate: case Remade: i->running.erase(j); break; case Recheck: case Todo: assert(false); } } // Start pending targets. while (!i->pending.empty()) { std::string target = i->pending.front(); i->pending.pop_front(); switch (get_status(target).status) { case Running: case RunningRecheck: i->running.insert(target); break; case Failed: pending_failed: i->failed = true; if (!keep_going) goto complete; // fallthrough case Uptodate: case Remade: break; case Recheck: case Todo: client_list::iterator j = i; switch (start(target, i)) { case Failed: goto pending_failed; case Running: // A shell was started, check for free slots. j->running.insert(target); if (!has_free_slots()) return true; break; case RunningRecheck: // Switch to the dependency client that was inserted. j->running.insert(target); i_next = j; break; case Remade: // Nothing to run. need_restart = true; break; default: assert(false); } } } // Try to complete the request. // (This might start a new job if it was a dependency client.) if (i->running.empty() || i->failed) { complete: complete_request(*i, !i->failed); DEBUG_close << (i->failed ? "failed\n" : "finished\n"); clients.erase(i); need_restart = true; } } if (running_jobs != waiting_jobs) return true; if (running_jobs == 0 && clients.empty()) return false; if (need_restart) goto restart; // There is a circular dependency. // Try to break it by completing one of the requests. assert(!clients.empty()); std::cerr << "Circular dependency detected" << std::endl; client_list::iterator i = clients.begin(); complete_request(*i, false); clients.erase(i); goto restart; } /** * Create a named unix socket that listens for build requests. Also set * the REMAKE_SOCKET environment variable that will be inherited by all * the job scripts. */ static void create_server() { if (false) { error: perror("Failed to create server"); #ifndef WINDOWS error2: #endif exit(EXIT_FAILURE); } DEBUG_open << "Creating server... "; #ifdef WINDOWS // Prepare a windows socket. struct sockaddr_in socket_addr; socket_addr.sin_family = AF_INET; socket_addr.sin_addr.s_addr = inet_addr("127.0.0.1"); socket_addr.sin_port = 0; // Create and listen to the socket. socket_fd = socket(AF_INET, SOCK_STREAM, 0); if (socket_fd == INVALID_SOCKET) goto error; if (!SetHandleInformation((HANDLE)socket_fd, HANDLE_FLAG_INHERIT, 0)) goto error; if (bind(socket_fd, (struct sockaddr *)&socket_addr, sizeof(sockaddr_in))) goto error; int len = sizeof(sockaddr_in); if (getsockname(socket_fd, (struct sockaddr *)&socket_addr, &len)) goto error; std::ostringstream buf; buf << socket_addr.sin_port; if (!SetEnvironmentVariable("REMAKE_SOCKET", buf.str().c_str())) goto error; if (listen(socket_fd, 1000)) goto error; #else // Set signal handlers for SIGCHLD and SIGINT. // Block SIGCHLD (unblocked during select). sigset_t sigmask; sigemptyset(&sigmask); sigaddset(&sigmask, SIGCHLD); if (sigprocmask(SIG_BLOCK, &sigmask, &old_sigmask) == -1) goto error; struct sigaction sa; sa.sa_flags = 0; sigemptyset(&sa.sa_mask); sa.sa_handler = &sigchld_handler; if (sigaction(SIGCHLD, &sa, NULL) == -1) goto error; sa.sa_handler = &sigint_handler; if (sigaction(SIGINT, &sa, NULL) == -1) goto error; // Prepare a named unix socket in temporary directory. socket_name = tempnam(NULL, "rmk-"); if (!socket_name) goto error2; struct sockaddr_un socket_addr; size_t len = strlen(socket_name); if (len >= sizeof(socket_addr.sun_path) - 1) goto error2; socket_addr.sun_family = AF_UNIX; strcpy(socket_addr.sun_path, socket_name); len += sizeof(socket_addr.sun_family); if (setenv("REMAKE_SOCKET", socket_name, 1)) goto error; // Create and listen to the socket. #ifdef LINUX socket_fd = socket(AF_UNIX, SOCK_STREAM | SOCK_CLOEXEC, 0); if (socket_fd == INVALID_SOCKET) goto error; #else socket_fd = socket(AF_UNIX, SOCK_STREAM, 0); if (socket_fd == INVALID_SOCKET) goto error; if (fcntl(socket_fd, F_SETFD, FD_CLOEXEC) < 0) goto error; #endif if (bind(socket_fd, (struct sockaddr *)&socket_addr, len)) goto error; if (listen(socket_fd, 1000)) goto error; #endif } /** * Accept a connection from a client, get the job it spawned from, * get the targets, and mark them as dependencies of the job targets. */ static void accept_client() { DEBUG_open << "Handling client request... "; // Accept connection. #ifdef WINDOWS socket_t fd = accept(socket_fd, NULL, NULL); if (fd == INVALID_SOCKET) return; if (!SetHandleInformation((HANDLE)fd, HANDLE_FLAG_INHERIT, 0)) { error2: std::cerr << "Unexpected failure while setting connection with client" << std::endl; closesocket(fd); return; } // WSAEventSelect puts sockets into nonblocking mode, so disable it here. u_long nbio = 0; if (ioctlsocket(fd, FIONBIO, &nbio)) goto error2; #elif defined(LINUX) int fd = accept4(socket_fd, NULL, NULL, SOCK_CLOEXEC); if (fd < 0) return; #else int fd = accept(socket_fd, NULL, NULL); if (fd < 0) return; if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) return; #endif clients.push_front(client_t()); client_list::iterator proc = clients.begin(); if (false) { error: DEBUG_close << "failed\n"; std::cerr << "Received an ill-formed client message" << std::endl; #ifdef WINDOWS closesocket(fd); #else close(fd); #endif clients.erase(proc); return; } // Receive message. Stop when encountering two nuls in a row. std::vector buf; size_t len = 0; while (len < sizeof(int) + 2 || buf[len - 1] || buf[len - 2]) { buf.resize(len + 1024); ssize_t l = recv(fd, &buf[0] + len, 1024, 0); if (l <= 0) goto error; len += l; } // Parse job that spawned the client. int job_id; memcpy(&job_id, &buf[0], sizeof(int)); proc->socket = fd; proc->job_id = job_id; job_map::const_iterator i = jobs.find(job_id); if (i == jobs.end()) goto error; DEBUG << "receiving request from job " << job_id << std::endl; if (propagate_vars) proc->vars = i->second.vars; // Parse the targets and the variable assignments. // Mark the targets as dependencies of the job targets. dependency_t &dep = *dependencies[i->second.rule.targets.front()]; string_list *last_var = NULL; char const *p = &buf[0] + sizeof(int); while (true) { len = strlen(p); if (len == 0) { ++waiting_jobs; break; } switch (*p) { case 'T': { if (len == 1) goto error; std::string target(p + 1, p + len); DEBUG << "adding dependency " << target << " to job\n"; proc->pending.push_back(target); dep.deps.insert(target); break; } case 'V': { if (len == 1) goto error; std::string var(p + 1, p + len); DEBUG << "adding variable " << var << " to job\n"; last_var = &proc->vars[var]; last_var->clear(); break; } case 'W': { if (!last_var) goto error; last_var->push_back(std::string(p + 1, p + len)); break; } default: goto error; } p += len + 1; } if (!propagate_vars && !proc->vars.empty()) { std::cerr << "Assignments are ignored unless 'variable-propagation' is enabled" << std::endl; proc->vars.clear(); } } /** * Handle child process exit status. */ static void finalize_job(pid_t pid, bool res) { pid_job_map::iterator i = job_pids.find(pid); assert(i != job_pids.end()); int job_id = i->second; job_pids.erase(i); --running_jobs; complete_job(job_id, res); } /** * Loop until all the jobs have finished. * * @post There are no client requests left, not even virtual ones. */ static void server_loop() { while (handle_clients()) { DEBUG_open << "Handling events... "; #ifdef WINDOWS size_t len = job_pids.size() + 1; HANDLE h[len]; int num = 0; for (pid_job_map::const_iterator i = job_pids.begin(), i_end = job_pids.end(); i != i_end; ++i, ++num) { h[num] = i->first; } WSAEVENT aev = WSACreateEvent(); h[num] = aev; WSAEventSelect(socket_fd, aev, FD_ACCEPT); DWORD w = WaitForMultipleObjects(len, h, false, INFINITE); WSAEventSelect(socket_fd, aev, 0); WSACloseEvent(aev); if (len <= w) continue; if (w == len - 1) { accept_client(); continue; } pid_t pid = h[w]; DWORD s = 0; bool res = GetExitCodeProcess(pid, &s) && s == 0; CloseHandle(pid); finalize_job(pid, res); #else sigset_t emptymask; sigemptyset(&emptymask); fd_set fdset; FD_ZERO(&fdset); FD_SET(socket_fd, &fdset); int ret = pselect(socket_fd + 1, &fdset, NULL, NULL, NULL, &emptymask); if (ret > 0 /* && FD_ISSET(socket_fd, &fdset)*/) accept_client(); if (!got_SIGCHLD) continue; got_SIGCHLD = 0; pid_t pid; int status; while ((pid = waitpid(-1, &status, WNOHANG)) > 0) { bool res = WIFEXITED(status) && WEXITSTATUS(status) == 0; finalize_job(pid, res); } #endif } assert(clients.empty()); } /** * Load dependencies and rules, listen to client requests, and loop until * all the requests have completed. * If Remakefile is obsolete, perform a first run with it only, then reload * the rules, and perform a second with the original clients. */ static void server_mode(std::string const &remakefile, string_list const &targets) { load_dependencies(); load_rules(remakefile); create_server(); if (get_status(remakefile).status != Uptodate) { clients.push_back(client_t()); clients.back().pending.push_back(remakefile); server_loop(); if (build_failure) goto early_exit; variables.clear(); specific_rules.clear(); generic_rules.clear(); first_target.clear(); load_rules(remakefile); } clients.push_back(client_t()); if (!targets.empty()) clients.back().pending = targets; else if (!first_target.empty()) clients.back().pending.push_back(first_target); server_loop(); early_exit: close(socket_fd); #ifndef WINDOWS remove(socket_name); free(socket_name); #endif save_dependencies(); if (show_targets && changed_prefix_dir) { std::cout << "remake: Leaving directory `" << prefix_dir << '\'' << std::endl; } exit(build_failure ? EXIT_FAILURE : EXIT_SUCCESS); } /** @} */ /** * @defgroup client Client * * @{ */ /** * Connect to the server @a socket_name, send a request for building @a targets * with some @a variables, and exit with the status returned by the server. */ static void client_mode(char *socket_name, string_list const &targets) { if (false) { error: perror("Failed to send targets to server"); exit(EXIT_FAILURE); } if (targets.empty()) exit(EXIT_SUCCESS); DEBUG_open << "Connecting to server... "; // Connect to server. #ifdef WINDOWS struct sockaddr_in socket_addr; socket_fd = socket(AF_INET, SOCK_STREAM, 0); if (socket_fd == INVALID_SOCKET) goto error; socket_addr.sin_family = AF_INET; socket_addr.sin_addr.s_addr = inet_addr("127.0.0.1"); socket_addr.sin_port = atoi(socket_name); if (connect(socket_fd, (struct sockaddr *)&socket_addr, sizeof(sockaddr_in))) goto error; #else struct sockaddr_un socket_addr; size_t len = strlen(socket_name); if (len >= sizeof(socket_addr.sun_path) - 1) exit(EXIT_FAILURE); socket_fd = socket(AF_UNIX, SOCK_STREAM, 0); if (socket_fd == INVALID_SOCKET) goto error; socket_addr.sun_family = AF_UNIX; strcpy(socket_addr.sun_path, socket_name); if (connect(socket_fd, (struct sockaddr *)&socket_addr, sizeof(socket_addr.sun_family) + len)) goto error; #ifdef MACOSX int set_option = 1; if (setsockopt(socket_fd, SOL_SOCKET, SO_NOSIGPIPE, &set_option, sizeof(set_option))) goto error; #endif #endif // Send current job id. char *id = getenv("REMAKE_JOB_ID"); int job_id = id ? atoi(id) : -1; if (send(socket_fd, (char *)&job_id, sizeof(job_id), MSG_NOSIGNAL) != sizeof(job_id)) goto error; // Send targets. for (string_list::const_iterator i = targets.begin(), i_end = targets.end(); i != i_end; ++i) { DEBUG_open << "Sending target " << *i << "... "; std::string s = 'T' + *i; ssize_t len = s.length() + 1; if (send(socket_fd, s.c_str(), len, MSG_NOSIGNAL) != len) goto error; } // Send variables. for (variable_map::const_iterator i = variables.begin(), i_end = variables.end(); i != i_end; ++i) { DEBUG_open << "Sending variable " << i->first << "... "; std::string s = 'V' + i->first; ssize_t len = s.length() + 1; if (send(socket_fd, s.c_str(), len, MSG_NOSIGNAL) != len) goto error; for (string_list::const_iterator j = i->second.begin(), j_end = i->second.end(); j != j_end; ++j) { std::string s = 'W' + *j; len = s.length() + 1; if (send(socket_fd, s.c_str(), len, MSG_NOSIGNAL) != len) goto error; } } // Send terminating nul and wait for reply. char result = 0; if (send(socket_fd, &result, 1, MSG_NOSIGNAL) != 1) goto error; if (recv(socket_fd, &result, 1, 0) != 1) exit(EXIT_FAILURE); exit(result ? EXIT_SUCCESS : EXIT_FAILURE); } /** @} */ /** * @defgroup ui User interface * * @{ */ /** * Display usage and exit with @a exit_status. */ static void usage(int exit_status) { std::cerr << "Usage: remake [options] [target] ...\n" "Options\n" " -B, --always-make Unconditionally make all targets.\n" " -d Echo script commands.\n" " -d -d Print lots of debugging information.\n" " -f FILE Read FILE as Remakefile.\n" " -h, --help Print this message and exit.\n" " -j[N], --jobs=[N] Allow N jobs at once; infinite jobs with no arg.\n" " -k, --keep-going Keep going when some targets cannot be made.\n" " -r Look up targets from the dependencies on stdin.\n" " -s, --silent, --quiet Do not echo targets.\n"; exit(exit_status); } /** * This program behaves in two different ways. * * - If the environment contains the REMAKE_SOCKET variable, the client * connects to this socket and sends to the server its build targets. * It exits once it receives the server reply. * * - Otherwise, it creates a server that waits for build requests. It * also creates a pseudo-client that requests the targets passed on the * command line. */ int main(int argc, char *argv[]) { std::string remakefile; string_list targets; bool literal_targets = false; bool indirect_targets = false; // Parse command-line arguments. for (int i = 1; i < argc; ++i) { std::string arg = argv[i]; if (arg.empty()) usage(EXIT_FAILURE); if (literal_targets) goto new_target; if (arg == "-h" || arg == "--help") usage(EXIT_SUCCESS); if (arg == "-d") if (echo_scripts) debug.active = true; else echo_scripts = true; else if (arg == "-k" || arg =="--keep-going") keep_going = true; else if (arg == "-s" || arg == "--silent" || arg == "--quiet") show_targets = false; else if (arg == "-r") indirect_targets = true; else if (arg == "-B" || arg == "--always-make") obsolete_targets = true; else if (arg == "-f") { if (++i == argc) usage(EXIT_FAILURE); remakefile = argv[i]; } else if (arg == "--") literal_targets = true; else if (arg.compare(0, 2, "-j") == 0) max_active_jobs = atoi(arg.c_str() + 2); else if (arg.compare(0, 7, "--jobs=") == 0) max_active_jobs = atoi(arg.c_str() + 7); else { if (arg[0] == '-') usage(EXIT_FAILURE); if (arg.find('=') != std::string::npos) { std::istringstream in(arg); std::string name = read_word(in); if (name.empty() || !expect_token(in, Equal)) usage(EXIT_FAILURE); read_words(in, variables[name]); continue; } new_target: targets.push_back(arg); DEBUG << "New target: " << arg << '\n'; } } init_working_dir(); normalize_list(targets, working_dir, working_dir); if (indirect_targets) { load_dependencies(std::cin); string_list l; targets.swap(l); if (l.empty() && !dependencies.empty()) { l.push_back(dependencies.begin()->second->targets.front()); } for (string_list::const_iterator i = l.begin(), i_end = l.end(); i != i_end; ++i) { dependency_map::const_iterator j = dependencies.find(*i); if (j == dependencies.end()) continue; dependency_t const &dep = *j->second; for (string_set::const_iterator k = dep.deps.begin(), k_end = dep.deps.end(); k != k_end; ++k) { targets.push_back(normalize(*k, working_dir, working_dir)); } } dependencies.clear(); } #ifdef WINDOWS WSADATA wsaData; if (WSAStartup(MAKEWORD(2,2), &wsaData)) { std::cerr << "Unexpected failure while initializing Windows Socket" << std::endl; return 1; } #endif // Run as client if REMAKE_SOCKET is present in the environment. if (char *sn = getenv("REMAKE_SOCKET")) client_mode(sn, targets); // Otherwise run as server. if (remakefile.empty()) { remakefile = "Remakefile"; init_prefix_dir(); } normalize_list(targets, working_dir, prefix_dir); server_mode(remakefile, targets); } /** @} */ interval-4.11.1/src/000077500000000000000000000000001470547631300142235ustar00rootroot00000000000000interval-4.11.1/src/Eval/000077500000000000000000000000001470547631300151125ustar00rootroot00000000000000interval-4.11.1/src/Eval/Eval.v000066400000000000000000001712621470547631300162010ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Bool Reals. From Flocq Require Import Zaux Raux. From Coq Require Import List. From Coquelicot Require Import Coquelicot. From mathcomp.ssreflect Require Import ssreflect. Require Import Stdlib. Require Import Xreal. Require Import Xreal_derive. Require Import Basic. Require Import Interval. Require Import Interval_compl. Require Import Taylor_model. Require Import Tree. Require Import Prog. Definition no_floor_op op := match op with | Nearbyint _ => false | RoundFlt _ _ _ | ErrorFlt _ _ _ => false | RoundFix _ _ | ErrorFix _ _ => false | _ => true end. Definition no_floor_term term := match term with Unary op _ => no_floor_op op | _ => true end. Definition no_floor_prog prog := fold_left (fun r t => r && no_floor_term t) prog true. Lemma no_floor_prog_cons t prog : no_floor_prog (t :: prog) = no_floor_term t && no_floor_prog prog. Proof. unfold no_floor_prog. generalize true. revert t; elim prog; simpl. now intros t b; case b; case no_floor_term. intros a l IH t b. now rewrite !IH; case no_floor_term; simpl; case no_floor_term; simpl. Qed. Lemma no_floor_prog_rcons t prog : no_floor_prog (prog ++ (t :: nil)) = no_floor_term t && no_floor_prog prog. Proof. unfold no_floor_prog. generalize true. revert t; elim prog; simpl. now intros t b; case b; case no_floor_term. intros a l IH t b. now rewrite !IH; case no_floor_term; simpl; case no_floor_term; simpl. Qed. Lemma no_floor_prog_rev prog : no_floor_prog (rev prog) = no_floor_prog prog. Proof. elim prog; simpl; try easy. intros a l IH. now rewrite no_floor_prog_rcons IH no_floor_prog_cons. Qed. Definition ext_operations := Build_operations (fun x => Xreal (IZR x)) Xnan (fun o => match o with | Neg => Xneg | Abs => Xabs | Inv => Xinv | Sqr => Xsqr | Sqrt => Xsqrt | Cos => Xcos | Sin => Xsin | Tan => Xtan | Atan => Xatan | Exp => Xexp | Ln => Xln | PowerInt n => fun x => Xpower_int x n | Nearbyint m => Xnearbyint m | RoundFlt m emin prec => Xround_flt m emin prec | ErrorFlt m emin prec => Xerror_flt m emin prec | RoundFix m emin => Xround_fix m emin | ErrorFix m emin => Xerror_fix m emin end) (fun o => match o with | Add => Xadd | Sub => Xsub | Mul => Xmul | Div => Xdiv end) (fun x => Xcmp x (Xreal 0)). Definition eval_ext := eval_generic ext_operations. Theorem eval_inductive_prop_fun : forall {T} A B P (opsA : operations A) (opsB : operations B), (forall a1 a2, (forall x : T, a1 x = a2 x) -> forall b, P a1 b -> P a2 b) -> (forall o a b, P a b -> P (fun x => unary opsA o (a x)) (unary opsB o b)) -> (forall o a1 a2 b1 b2, P a1 b1 -> P a2 b2 -> P (fun x => binary opsA o (a1 x) (a2 x)) (binary opsB o b1 b2)) -> forall inpA inpB, (forall n, P (fun x => nth n (inpA x) (unknown opsA)) (nth n inpB (unknown opsB))) -> forall prog, forall n, P (fun x => nth n (eval_generic opsA prog (inpA x)) (unknown opsA)) (nth n (eval_generic opsB prog inpB) (unknown opsB)). Proof. intros T A B P opsA opsB HP Hun Hbin inpA inpB Hinp prog n. apply HP with (fun x => nth n (fold_right (fun y x => eval_generic_body opsA x y) (inpA x) (rev prog)) (unknown opsA)). intros x. now rewrite rev_formula. rewrite rev_formula. generalize n. clear n. induction (rev prog). exact Hinp. intros [|n]. 2: apply IHl. destruct a as [n|o n|o n1 n2] ; [ idtac | apply Hun | apply Hbin ] ; apply IHl. Qed. Theorem eval_inductive_prop_floor_fun : forall {T} A B P (opsA : operations A) (opsB : operations B), (forall a1 a2, (forall x : T, a1 x = a2 x) -> forall b, P a1 b -> P a2 b) -> (forall o a b, no_floor_op o = true -> P a b -> P (fun x => unary opsA o (a x)) (unary opsB o b)) -> (forall o a1 a2 b1 b2, P a1 b1 -> P a2 b2 -> P (fun x => binary opsA o (a1 x) (a2 x)) (binary opsB o b1 b2)) -> forall inpA inpB, (forall n, P (fun x => nth n (inpA x) (unknown opsA)) (nth n inpB (unknown opsB))) -> forall prog, no_floor_prog prog = true -> forall n, P (fun x => nth n (eval_generic opsA prog (inpA x)) (unknown opsA)) (nth n (eval_generic opsB prog inpB) (unknown opsB)). Proof. intros T A B P opsA opsB HP Hun Hbin inpA inpB Hinp prog Hprog n. apply HP with (fun x => nth n (fold_right (fun y x => eval_generic_body opsA x y) (inpA x) (rev prog)) (unknown opsA)). intros x. now rewrite rev_formula. rewrite rev_formula. generalize n. clear n. revert Hprog; rewrite -no_floor_prog_rev. induction (rev prog). intros _. exact Hinp. rewrite no_floor_prog_cons. intros H1. assert (H2 : no_floor_term a = true). now revert H1; case no_floor_term. assert (H3 : no_floor_prog l = true). now revert H1; case no_floor_term; try discriminate. intros [|n]. 2: now apply IHl. now destruct a as [n|o n|o n1 n2] ; [ idtac | apply Hun | apply Hbin ] ; try apply IHl. Qed. Lemma rewrite_inv_diff : forall u u', Xmul u' (Xneg (Xsqr (Xinv u))) = Xneg (Xdiv u' (Xsqr u)). Proof. intros. rewrite Xmul_Xneg_distr_r. apply f_equal. rewrite Xdiv_split. apply f_equal. assert (forall x, Xsqr x = Xmul x x) by now intros [|x]. rewrite 2!H. apply sym_eq. apply Xinv_Xmul_distr. Qed. Lemma rewrite_div_diff : forall u v u' v', Xdiv (Xsub u' (Xmul v' (Xdiv u v))) v = Xdiv (Xsub (Xmul u' v) (Xmul v' u)) (Xmul v v). Proof. intros. repeat rewrite Xdiv_split. rewrite Xinv_Xmul_distr. repeat rewrite <- Xmul_assoc. apply (f_equal (fun x => Xmul x (Xinv v))). rewrite 2!Xsub_split. rewrite Xadd_comm. set (w := Xmul v' u). rewrite Xmul_Xadd_distr_r. rewrite Xmul_assoc Xmul_Xinv. destruct (Xinv v) as [|z]. by rewrite /= 2!Xlift2_nan_r. rewrite /= Xmul_1_r Xmul_Xneg_distr_l. apply Xadd_comm. Qed. Lemma nth_map : forall {T U} d' n (f : T -> U) l d, nth n (map f l) d = match le_lt_dec (length l) n with left _ => d | right _ => f (nth n l d') end. Proof. intros T U d' n f l d. destruct le_lt_dec as [H|H]. - apply nth_overflow. now rewrite map_length. - rewrite (nth_indep _ d (f d')). apply map_nth. now rewrite map_length. Qed. Lemma nth_map_lt : forall {T U} d' n (f : T -> U) l d, (n < length l)%nat -> nth n (map f l) d = f (nth n l d'). Proof. intros T U d' n f l d H. rewrite (nth_indep _ d (f d')). apply map_nth. now rewrite map_length. Qed. Lemma xreal_to_real : forall (P1 : ExtendedR -> Prop) (P2 : R -> Prop), (P1 Xnan -> forall r, P2 r) -> (forall r, P1 (Xreal r) -> P2 r) -> forall prog terms n, P1 (nth n (eval_ext prog (map Xreal terms)) Xnan) -> P2 (nth n (eval_real prog terms) 0%R). Proof. intros P1 P2 HP1 HP2 prog terms n. unfold eval_ext, eval_real. refine (_ (eval_inductive_prop _ _ (fun a b => match a with Xreal a => a = b | _ => True end) ext_operations real_operations _ _ (map Xreal terms) terms _ prog n)). simpl. case (nth n (eval_generic ext_operations prog (map Xreal terms)) Xnan). intros _ H. now apply HP1. intros y H. rewrite H. apply HP2. (* unary *) destruct a as [|a]. now destruct o. intros b H. rewrite H. destruct o ; try easy ; simpl ; unfold Xinv'. now case (is_zero b). unfold Xtan'. now case (is_zero (cos b)). unfold Xln'. now case (is_positive b). generalize (Xpower_int_correct n0 (Xreal b)). simpl. now case Xpower_int'. (* binary *) destruct a1 as [|a1]. now destruct o. destruct a2 as [|a2]. now destruct o. intros b1 b2 H1 H2. rewrite H1 H2. destruct o ; try easy ; simpl ; unfold Xdiv'. now destruct (is_zero b2). (* . *) intros k. rewrite (nth_map 0). now destruct le_lt_dec as [H|H]. Qed. Lemma continuous_unary : forall unop a b x, no_floor_op unop = true -> (notXnan b -> b = Xreal (a x) /\ continuous a x) -> notXnan (unary ext_operations unop b) -> unary ext_operations unop b = Xreal (unary real_operations unop (a x)) /\ continuous (fun x0 : R => unary real_operations unop (a x0)) x. Proof. move => unop a b x NF Hb HbnotXnan. case Hbnan: b Hb => [|b1] // Hb. rewrite Hbnan /= in HbnotXnan. by case unop in HbnotXnan. case: Hb => // Hb Hcontax. move: HbnotXnan. rewrite Hbnan Hb => {Hbnan Hb b1} HnotXnan. split. (case: unop NF HnotXnan; try discriminate) => //= [_|_|_|]. - rewrite /Xinv'. by case is_zero. - rewrite /Xtan'. by case is_zero. - rewrite /Xln'. by case is_positive. - case => [||p] //. rewrite /Xpower_int'. by case is_zero. (case: unop NF HnotXnan; try discriminate) => //= [_|_|_|_|_|_|_|_|_|_|_|]. - move => _. by apply: continuous_opp. - move => _. by apply: continuous_Rabs_comp. - move => HnotXnan. apply: continuous_Rinv_comp => // Ha. move: HnotXnan. by rewrite /Xinv' Ha is_zero_0. - move => _. by apply: continuous_mult. - move => HnotXnan. exact: continuous_sqrt_comp. - move => _. by apply: continuous_cos_comp. - move => _. by apply: continuous_sin_comp. - move => HnotXnan. apply: continuous_comp => //. apply: continuous_tan => Ha. move: HnotXnan. by rewrite /Xtan' Ha is_zero_0. - move => _. by apply: continuous_atan_comp. - move => _. by apply: continuous_exp_comp. - move => HnotXnan. apply: continuous_comp => //. apply: continuous_ln. rewrite /Xln' in HnotXnan. by case: is_positive_spec HnotXnan. - move => n. rewrite /powerRZ. case: n => [|n|n] _ HnotXnan. + exact: continuous_const. + apply: (continuous_comp a (fun x => pow x _)) => //. apply: ex_derive_continuous. apply: ex_derive_pow. exact: ex_derive_id. + rewrite /Xpower_int' in HnotXnan. case: is_zero_spec HnotXnan => // Ha _. apply: continuous_comp. apply: (continuous_comp a (fun x => pow x _)) => //. apply: ex_derive_continuous. apply: ex_derive_pow. exact: ex_derive_id. apply: continuous_Rinv. exact: pow_nonzero. Qed. Fixpoint change_nth {T} n (l : list T) f {struct l} := match l with | nil => nil | h :: t => match n with | O => f h :: t | S n => h :: change_nth n t f end end. Lemma change_nth_correct : forall {T} n m (l : list T) d f, ((n < length l)%nat /\ n = m /\ nth n (change_nth m l f) d = f (nth n l d)) \/ nth n (change_nth m l f) d = nth n l d. Proof. intros T n m l d f. revert n m. induction l as [|h l IH]. intros n m. now right. intros [|n] [|m] ; simpl. - left. repeat split. apply Nat.lt_0_succ. - now right. - now right. - destruct (IH n m) as [[H1 [H2 H3]]|H]. 2: now right. left. repeat split. now rewrite <-Nat.succ_lt_mono. now rewrite <- H2. exact H3. Qed. Lemma length_change_nth : forall {T} n (l : list T) f, length (change_nth n l f) = length l. Proof. intros T n l f. revert n. induction l as [|h l IH]. easy. intros [|n]. easy. simpl. apply f_equal, IH. Qed. Module IntervalAlgos (I : IntervalOps). Module J := IntervalExt I. Definition contains_all xi x := length xi = length x /\ forall n, contains (I.convert (nth n xi I.nai)) (Xreal (nth n x 0)). Definition bisect_step (bounds : list I.type) i (check : list I.type -> bool) cont := if check bounds then true else let bounds' := change_nth i bounds (fun xi => fst (I.bisect xi)) in match cont bounds' with | true => let bounds' := change_nth i bounds (fun xi => snd (I.bisect xi)) in cont bounds' | false => false end. Fixpoint bisect bounds idx check steps { struct steps } := match steps, idx with | O, _ => check bounds | S _, nil => check bounds | S steps, i :: idx => let idx := app idx (i :: nil) in bisect_step bounds i check (fun b => bisect b idx check steps) end. Lemma change_nth_bisect : forall bounds idx x, contains_all bounds x -> contains_all (change_nth idx bounds (fun xi : I.type => fst (I.bisect xi))) x \/ contains_all (change_nth idx bounds (fun xi : I.type => snd (I.bisect xi))) x. Proof. intros bounds i x H. destruct (I.bisect_correct (nth i bounds I.nai) (Xreal (nth i x 0))) as [Hi|Hi]. - apply H. - left. split. rewrite length_change_nth. apply H. intros n. generalize (change_nth_correct n i bounds I.nai (fun xi => fst (I.bisect xi))). intros [[_ [<- ->]] | ->]. exact Hi. apply H. - right. split. rewrite length_change_nth. apply H. intros n. generalize (change_nth_correct n i bounds I.nai (fun xi => snd (I.bisect xi))). intros [[_ [<- ->]] | ->]. exact Hi. apply H. Qed. Theorem bisect_correct : forall steps bounds idx check (P : _ -> Prop), ( forall xi x, contains_all xi x -> check xi = true -> P x ) -> bisect bounds idx check steps = true -> forall x, contains_all bounds x -> P x. Proof. intros steps bounds idx check P HP. revert idx bounds. induction steps as [|steps IH]. intros idx bounds Hc x H. apply HP with (1 := H) (2 := Hc). intros [|i idx] bounds Hc x H. apply HP with (1 := H) (2 := Hc). revert Hc. simpl. unfold bisect_step. case_eq (check bounds). intros Hc _ . apply HP with (1 := H) (2 := Hc). intros _. generalize (IH (app idx (i :: nil)) (change_nth i bounds (fun xi => fst (I.bisect xi)))). case bisect. 2: easy. intros H1 Hc. specialize (H1 eq_refl x). assert (H2 := IH _ _ Hc x). clear -H H1 H2. destruct (change_nth_bisect bounds i x H) as [H0|H0]. - now apply H1. - now apply H2. Qed. Definition lookup_step fi (bounds : list I.type) i output cont := if I.subset (fi bounds) output then output else let bounds' := change_nth i bounds (fun xi => fst (I.bisect xi)) in let output := cont bounds' output in if I.subset I.whole output then output else let bounds' := change_nth i bounds (fun xi => snd (I.bisect xi)) in cont bounds' output. Fixpoint lookup_main fi bounds idx output steps { struct steps } := match steps, idx with | O, _ => I.join (fi bounds) output | S _, nil => I.join (fi bounds) output | S steps, i :: idx => let idx := app idx (i :: nil) in lookup_step fi bounds i output (fun bounds output => lookup_main fi bounds idx output steps) end. Fixpoint lookup_piece bounds idx steps { struct steps } := match steps, idx with | O, _ => bounds | S _, nil => bounds | S steps, i :: idx => let idx := app idx (i :: nil) in let bounds := change_nth i bounds (fun xi => fst (I.bisect xi)) in lookup_piece bounds idx steps end. Definition lookup fi bounds idx extend steps := let bounds' := lookup_piece bounds idx steps in let output := extend (fi bounds') in if I.subset I.whole output then output else lookup_main fi bounds idx output steps. Theorem lookup_correct : forall steps bounds idx extend fi f, ( forall xi x, contains_all xi x -> contains (I.convert (fi xi)) (Xreal (f x)) ) -> let output := lookup fi bounds idx extend steps in forall x, contains_all bounds x -> contains (I.convert output) (Xreal (f x)). Proof. assert (Su: forall b1 b2, forall y, contains (I.convert b1) (Xreal y) -> contains (I.convert (if I.subset I.whole b2 then b2 else b1)) (Xreal y)). { intros b1 b2 y Hy. destruct I.subset eqn:H. apply I.subset_correct with (2 := H). apply I.whole_correct. easy. } intros depth bounds idx extend fi f Hf. unfold lookup. set (b := extend _). clearbody b. set (b0 := lookup_main _ _ _ _ _). intros x Hx. apply Su. revert x Hx. refine (@proj2 (forall y, contains (I.convert b) (Xreal y) -> contains (I.convert b0) (Xreal y)) _ _). unfold b0. clear -Hf Su. revert idx bounds b. induction depth as [|depth IH] ; simpl. { intros _ bounds b. split. intros y Hy. apply I.join_correct. now right. intros x Hx. apply I.join_correct. left. now apply Hf. } intros [|idx] bounds b. { split. intros y Hy. apply I.join_correct. now right. intros x Hx. apply I.join_correct. left. now apply Hf. } specialize (IH (app l (idx :: nil))). unfold bisect_step, lookup_step. set (b2 := lookup_main _ _ _ _ _). set (b3 := lookup_main _ _ _ _ _). destruct (I.subset (fi bounds) b) eqn:Hb. { split. easy. intros x Hx. apply I.subset_correct with (2 := Hb). now apply Hf. } clear Hb. split. { intros y Hy. apply Su. now apply IH, IH. } intros x Hx. apply Su. destruct (change_nth_bisect bounds idx x Hx) as [H0|H0]. - apply (proj1 (IH _ _)). now apply IH. - now apply IH. Qed. Lemma continuous_eval_ext : forall prog vars x m, no_floor_prog prog = true -> notXnan (nth m (eval_ext prog (Xreal x :: map Xreal vars)) Xnan) -> continuous (fun x => nth m (eval_real prog (x :: vars)) 0%R) x. Proof. intros prog vars x. rewrite /eval_ext /eval_real. intros m Hf H. eapply proj2. revert Hf m H. apply: (eval_inductive_prop_floor_fun _ _ (fun (f : R -> R) v => notXnan v -> v = Xreal (f x) /\ continuous f x)) => //. intros f1 f2 Heq b H Hb. case: (H Hb) => {} H H'. split. by rewrite -Heq. now eapply continuous_ext. move => unop a b Hb HnotXnan. exact: continuous_unary. (* case of binary operator *) case => a1 a2 b1 b2 Ha1 Ha2 HnotXnan /=. - move: HnotXnan Ha1 Ha2. case: b1 => [|b1] // ;case: b2 => [|b2] // . move => _ [] // -> Hconta1 [] // -> Hconta2. by split => //; apply: continuous_plus. - move: HnotXnan Ha1 Ha2. case: b1 => [|b1] // ;case: b2 => [|b2] // . move => _ [] // -> Hconta1 [] // -> Hconta2. by split => //; apply: continuous_minus. - move: HnotXnan Ha1 Ha2. case: b1 => [|b1] // ;case: b2 => [|b2] // . move => _ [] // -> Hconta1 [] // -> Hconta2. by split => //; apply: continuous_mult. - move: HnotXnan Ha1 Ha2. case: b1 => [|b1] // ;case: b2 => [|b2] // . move => HnotXnan [] // Heq1 Hconta1 [] // Heq2 Hconta2. split => // . + move: HnotXnan. rewrite /= /Xdiv'. case: (is_zero b2) => // . by inversion Heq1; inversion Heq2. + apply: continuous_mult => // . apply: continuous_Rinv_comp => // Habs . by move: Heq2 HnotXnan => ->; rewrite /= /Xdiv' Habs is_zero_0. intros [|n]. simpl. intros _. apply (conj eq_refl). apply continuous_id. simpl. rewrite (nth_map 0). destruct le_lt_dec. easy. intros _. apply (conj eq_refl). apply continuous_const. Qed. Lemma contains_map_Xreal : forall xi x, contains_all xi x -> forall n, contains (I.convert (nth n xi I.nai)) (nth n (map Xreal x) Xnan). Proof. intros xi x [H1 H2] n. rewrite (nth_map 0). destruct le_lt_dec as [H|H]. rewrite -> nth_overflow. now rewrite I.nai_correct. now rewrite H1. apply H2. Qed. Lemma contains_all_cons : forall li l xi x, contains_all li l -> contains (I.convert xi) (Xreal x) -> contains_all (xi :: li) (x :: l). Proof. intros li l xi x [H1 H2] Hx. split. simpl. apply f_equal, H1. intros [|n]. exact Hx. apply H2. Qed. Module BndValuator. Definition operations prec := Build_operations (I.fromZ prec) I.nai (fun o => match o with | Neg => I.neg | Abs => I.abs | Inv => I.inv prec | Sqr => I.sqr prec | Sqrt => I.sqrt prec | Cos => I.cos prec | Sin => I.sin prec | Tan => I.tan prec | Atan => I.atan prec | Exp => I.exp prec | Ln => I.ln prec | PowerInt n => fun x => I.power_int prec x n | Nearbyint m => I.nearbyint m | RoundFlt m emin p => J.round_flt prec m emin p | ErrorFlt m emin p => I.error_flt prec m emin p | RoundFix m emin => J.round_fix prec m emin | ErrorFix m emin => I.error_fix prec m emin end) (fun o => match o with | Add => I.add prec | Sub => I.sub prec | Mul => I.mul prec | Div => I.div prec end) I.sign_strict. Definition eval prec := eval_generic (operations prec). Lemma eval_correct_aux : forall prec prog bounds vars, (forall n, contains (I.convert (nth n bounds I.nai)) (nth n vars Xnan)) -> forall n, contains (I.convert (nth n (eval prec prog bounds) I.nai)) (nth n (eval_ext prog vars) Xnan). Proof. intros prec prog bounds vars Hinp. unfold eval, eval_ext. apply (eval_inductive_prop _ _ (fun a b => contains (I.convert a) b)). (* unary *) destruct o ; simpl ; [ apply I.neg_correct | apply I.abs_correct | apply I.inv_correct | apply I.sqr_correct | apply I.sqrt_correct | apply I.cos_correct | apply I.sin_correct | apply I.tan_correct | apply I.atan_correct | apply I.exp_correct | apply I.ln_correct | apply I.power_int_correct | apply I.nearbyint_correct | apply J.round_flt_correct' | apply I.error_flt_correct | apply J.round_fix_correct' | apply I.error_fix_correct ]. (* binary *) destruct o ; simpl ; [ apply I.add_correct | apply I.sub_correct | apply I.mul_correct | apply I.div_correct ]. (* . *) exact Hinp. Qed. Theorem eval_correct : forall prec prog bounds vars, contains_all bounds vars -> forall n, contains (I.convert (nth n (eval prec prog bounds) I.nai)) (nth n (eval_ext prog (map Xreal vars)) Xnan). Proof. intros prec prog bounds vars H. apply eval_correct_aux. now apply contains_map_Xreal. Qed. Theorem eval_correct' : forall prec prog bounds vars, contains_all bounds vars -> forall n, contains (I.convert (nth n (eval prec prog bounds) I.nai)) (Xreal (nth n (eval_real prog vars) 0%R)). Proof. intros prec prog bounds vars H n. set (yi := nth n _ _). apply (xreal_to_real (fun y => contains (I.convert yi) y) (fun y => contains (I.convert yi) (Xreal y))). now destruct (I.convert yi). easy. now apply eval_correct. Qed. Theorem eval_correct_ext : forall prec prog bounds vars, contains_all bounds vars -> forall n, I.extension (fun x => nth n (eval_ext prog (x :: map Xreal vars)) Xnan) (fun b => nth n (eval prec prog (b :: bounds)) I.nai). Proof. intros prec prog bounds vars H n xi x Hx. revert n. apply eval_correct_aux. intros [|n]. exact Hx. simpl. now apply contains_map_Xreal. Qed. Theorem eval_correct_ext' : forall prec prog bounds vars, contains_all bounds vars -> forall xi x, contains (I.convert xi) (Xreal x) -> forall n, contains (I.convert (nth n (eval prec prog (xi :: bounds)) I.nai)) (Xreal (nth n (eval_real prog (x :: vars)) 0%R)). Proof. intros prec prog bounds vars [H1 H2] xi x Hx. apply eval_correct'. now apply contains_all_cons. Qed. Lemma continuous_eval : forall prec prog bounds vars, contains_all bounds vars -> no_floor_prog prog = true -> forall xi x, contains (I.convert xi) (Xreal x) -> forall m, I.convert (nth m (eval prec prog (xi :: bounds)) I.nai) <> Inan -> continuous (fun x => nth m (eval_real prog (x :: vars)) 0%R) x. Proof. intros prec prog bounds vars H Hf xi x Hx m HnotInan. apply: continuous_eval_ext => //. generalize (eval_correct_ext prec prog bounds vars H m xi (Xreal x) Hx). revert HnotInan. case I.convert => //. by case: (nth _ _ _). Qed. Lemma ex_RInt_eval : forall prec prog bounds vars, contains_all bounds vars -> no_floor_prog prog = true -> forall a b xi, (forall x, Rmin a b <= x <= Rmax a b -> contains (I.convert xi) (Xreal x)) -> forall m, I.convert (nth m (eval prec prog (xi :: bounds)) I.nai) <> Inan -> ex_RInt (fun x => nth m (eval_real prog (x :: vars)) R0) a b. Proof. intros prec prog bounds vars H Hf a b xi Hx m HnotInan. apply: ex_RInt_continuous. intros z Hz. apply: continuous_eval HnotInan => //. exact: Hx. Qed. End BndValuator. Module DiffValuator. Definition diff_operations A (ops : @operations A) := Build_operations (fun x => (constant ops x, constant ops 0)) (unknown ops, unknown ops) (fun o x => match x with | (v, d) => match o with | Neg => let f := unary ops Neg in (f v, f d) | Abs => let w := unary ops Abs v in (w, match sign ops v with Xlt => unary ops Neg d | Xgt => d | _ => unknown ops end) | Inv => let w := unary ops Inv v in (w, binary ops Mul d (unary ops Neg (unary ops Sqr w))) | Sqr => let w := binary ops Mul d v in (unary ops Sqr v, binary ops Add w w) | Sqrt => let w := unary ops Sqrt v in (w, binary ops Div d (binary ops Add w w)) | Cos => (unary ops Cos v, binary ops Mul d (unary ops Neg (unary ops Sin v))) | Sin => (unary ops Sin v, binary ops Mul d (unary ops Cos v)) | Tan => let w := unary ops Tan v in (w, binary ops Mul d (binary ops Add (constant ops 1) (unary ops Sqr w))) | Atan => (unary ops Atan v, binary ops Div d (binary ops Add (constant ops 1) (unary ops Sqr v))) | Exp => let w := unary ops Exp v in (w, binary ops Mul d w) | Ln => (unary ops Ln v, match sign ops v with Xgt => binary ops Div d v | _ => unknown ops end) | PowerInt n => (unary ops o v, binary ops Mul d (binary ops Mul (constant ops n) (unary ops (PowerInt (n-1)) v))) | Nearbyint m => (unary ops (Nearbyint m) v, unknown ops) | RoundFlt m emin prec => (unary ops (RoundFlt m emin prec) v, unknown ops) | ErrorFlt m emin prec => (unary ops (ErrorFlt m emin prec) v, unknown ops) | RoundFix m emin => (unary ops (RoundFix m emin) v, unknown ops) | ErrorFix m emin => (unary ops (ErrorFix m emin) v, unknown ops) end end) (fun o x y => match x, y with | (vx, dx), (vy, dy) => match o with | Add => let f := binary ops Add in (f vx vy, f dx dy) | Sub => let f := binary ops Sub in (f vx vy, f dx dy) | Mul => let f := binary ops Mul in (f vx vy, binary ops Add (f dx vy) (f dy vx)) | Div => let f := binary ops Div in let w := f vx vy in (w, f (binary ops Sub dx (binary ops Mul dy w)) vy) end end) (fun x => match x with (vx, _) => sign ops vx end). Lemma unary_diff_correct : forall o f d x, Xderive_pt f x d -> let v := unary (diff_operations _ ext_operations) o (f x, d) in unary ext_operations o (f x) = fst v /\ Xderive_pt (fun x0 => unary ext_operations o (f x0)) x (snd v). Proof. intros o f d x Hd. destruct o ; simpl ; repeat split. now apply Xderive_pt_neg. now apply Xderive_pt_abs. rewrite rewrite_inv_diff. now apply Xderive_pt_inv. eapply Xderive_pt_eq_fun. 2: now apply Xderive_pt_mul. intros y. simpl. now case f. now apply Xderive_pt_sqrt. now apply Xderive_pt_cos. now apply Xderive_pt_sin. now apply Xderive_pt_tan. now apply Xderive_pt_atan. now apply Xderive_pt_exp. now apply Xderive_pt_ln. now apply Xderive_pt_power_int. now destruct x. now destruct x. now destruct x. now destruct x. now destruct x. Qed. Lemma binary_diff_correct : forall o f1 f2 d1 d2 x, Xderive_pt f1 x d1 -> Xderive_pt f2 x d2 -> let v := binary (diff_operations _ ext_operations) o (f1 x, d1) (f2 x, d2) in binary ext_operations o (f1 x) (f2 x) = fst v /\ Xderive_pt (fun x0 => binary ext_operations o (f1 x0) (f2 x0)) x (snd v). Proof. intros o f1 f2 d1 d2 x Hd1 Hd2. destruct o ; simpl ; repeat split. now apply Xderive_pt_add. now apply Xderive_pt_sub. now apply Xderive_pt_mul. rewrite rewrite_div_diff. now apply Xderive_pt_div. Qed. Lemma eval_diff_correct : forall prog terms n x, let v := nth n (eval_generic (diff_operations _ ext_operations) prog ((x, Xmask (Xreal 1) x) :: map (fun v => (Xreal v, Xmask (Xreal 0) x)) terms)) (Xnan, Xnan) in nth n (eval_ext prog (x :: map Xreal terms)) Xnan = fst v /\ Xderive_pt (fun x => nth n (eval_ext prog (x :: map Xreal terms)) Xnan) x (snd v). Proof. intros prog terms n x. (*set (inpA x := x :: map Xreal terms). set (inpB := (x, Xmask (Xreal 1) x) :: map (fun v : R => (Xreal v, Xmask (Xreal 0) x)) terms).*) refine (eval_inductive_prop_fun _ _ (fun a b => a x = fst b /\ Xderive_pt a x (snd b)) _ _ _ _ _ _ _ _ _ _). (* extensionality *) intros a1 a2 Heq (bl, br). simpl. intros (Hl, Hr). split. now rewrite <- Heq. apply Xderive_pt_eq_fun with (2 := Hr). intros. now apply sym_eq. (* unary *) intros o a (bl, br) (Hl, Hr). simpl in Hl. rewrite <- Hl. now apply unary_diff_correct. (* binary *) intros o a1 a2 (bl1, br1) (bl2, br2) (Hl1, Hr1) (Hl2, Hr2). simpl in Hl1, Hl2. rewrite <- Hl1, <- Hl2. now apply binary_diff_correct. (* inputs *) clear n. intros [|n]. simpl. repeat split. apply Xderive_pt_identity. simpl. split. rewrite <- (map_nth (@fst ExtendedR ExtendedR)). rewrite map_map. apply (f_equal (fun v => nth n v _)). now apply map_ext. rewrite <- map_nth. rewrite map_map. simpl. rewrite (nth_map 0). destruct le_lt_dec as [H|H]. rewrite nth_overflow. now case x. now rewrite map_length. rewrite -> (nth_map_lt 0) by easy. apply Xderive_pt_constant. Qed. Lemma unary_diff_bnd_correct : forall prec o f f', let u x := unary (diff_operations _ ext_operations) o (f x, f' x) in forall yi yi' xi, (forall x, contains xi x -> contains (I.convert yi) (f x)) -> (forall x, contains xi x -> contains (I.convert yi') (f' x)) -> let v := unary (diff_operations _ (BndValuator.operations prec)) o (yi, yi') in (forall x, contains xi x -> contains (I.convert (snd v)) (snd (u x))). Proof. intros prec o f f' u yi yi' xi Hf Hf' v x Hx. destruct o ; simpl ; repeat first [ now rewrite I.nai_correct | apply I.neg_correct | apply I.abs_correct | apply I.inv_correct | apply I.sqr_correct | apply I.sqrt_correct | apply I.cos_correct | apply I.sin_correct | apply I.tan_correct | apply I.atan_correct | apply I.exp_correct | apply I.ln_correct | apply I.power_int_correct | apply I.add_correct | apply I.mul_correct | apply I.div_correct | apply I.fromZ_correct | refine (I.add_correct _ _ _ (Xreal 1%R) _ _ _) | refine (I.mul_correct _ _ _ (Xreal (IZR _)) _ _ _) ] ; try now first [ apply Hf | apply Hf' ]. (* abs *) specialize (Hf _ Hx). generalize (I.sign_strict_correct yi). case I.sign_strict ; try rewrite I.nai_correct ; try easy. intros H. specialize (H _ Hf). rewrite (proj1 H). simpl. rewrite Rcompare_Lt. apply I.neg_correct. now apply Hf'. apply H. intros H. specialize (H _ Hf). rewrite (proj1 H). simpl. rewrite Rcompare_Gt. now apply Hf'. apply H. (* ln *) specialize (Hf _ Hx). generalize (I.sign_strict_correct yi). case I.sign_strict ; try rewrite I.nai_correct ; try easy. intros H. specialize (H _ Hf). rewrite {1}(proj1 H). simpl. rewrite Rcompare_Gt. apply I.div_correct. now apply Hf'. exact Hf. apply H. Qed. Lemma binary_diff_bnd_correct : forall prec o f1 f2 f1' f2', let u x := binary (diff_operations _ ext_operations) o (f1 x, f1' x) (f2 x, f2' x) in forall yi1 yi2 yi1' yi2' xi, (forall x, contains xi x -> contains (I.convert yi1) (f1 x)) -> (forall x, contains xi x -> contains (I.convert yi2) (f2 x)) -> (forall x, contains xi x -> contains (I.convert yi1') (f1' x)) -> (forall x, contains xi x -> contains (I.convert yi2') (f2' x)) -> let v := binary (diff_operations _ (BndValuator.operations prec)) o (yi1, yi1') (yi2, yi2') in (forall x, contains xi x -> contains (I.convert (snd v)) (snd (u x))). Proof. intros prec o f1 f2 f1' f2' u yi1 yi2 yi1' yi2' xi Hf1 Hf2 Hf1' Hf2' v x Hx. destruct o ; simpl ; repeat first [ apply I.add_correct | apply I.sub_correct | apply I.mul_correct | apply I.div_correct ] ; now first [ apply Hf1 | apply Hf2 | apply Hf1' | apply Hf2' ]. Qed. Lemma eval_diff_bnd_correct : forall prec prog bounds vars, contains_all bounds vars -> forall n, let ff' x := nth n (eval_generic (diff_operations _ ext_operations) prog ((x, Xmask (Xreal 1) x) :: map (fun v => (Xreal v, Xmask (Xreal 0) x)) vars)) (Xnan, Xnan) in let ffi' xi := nth n (eval_generic (diff_operations _ (BndValuator.operations prec)) prog ((xi, I.mask (I.fromZ_small 1) xi) :: map (fun b => (b, I.mask I.zero xi)) bounds)) (I.nai, I.nai) in forall xi, nth n (BndValuator.eval prec prog (xi :: bounds)) I.nai = fst (ffi' xi) /\ (forall x, contains (I.convert xi) x -> contains (I.convert (snd (ffi' xi))) (snd (ff' x))). Proof. intros prec prog bounds vars Hv n ff' ffi' xi. split. (* . *) unfold ffi', BndValuator.eval. apply (eval_inductive_prop _ (I.type * I.type) (fun a b => a = fst b)). intros o a (bl, br) H. rewrite H. now destruct o. intros o a1 a2 (bl1, br1) (bl2, br2) H1 H2. rewrite H1 H2. now destruct o. clear. intros [|n]. apply refl_equal. simpl. rewrite <- (map_nth (@fst I.type I.type)). rewrite map_map. simpl. apply sym_eq. exact (map_nth _ _ _ _). (* . *) refine (let toto := _ in fun x Hx => proj2 (toto x Hx : contains (I.convert (fst (ffi' xi))) (fst (ff' x)) /\ _)). apply (eval_inductive_prop_fun (ExtendedR * _) (I.type * _) (fun a b => forall x, contains (I.convert xi) x -> contains (I.convert (fst b)) (fst (a x)) /\ contains (I.convert (snd b)) (snd (a x)))). intros f1 f2 Heq (yi, yi') H x Hx. rewrite <- Heq. now apply H. intros o f (yi, yi') H x Hx. rewrite (surjective_pairing (f x)). split. assert (Hf := proj1 (H x Hx)). destruct o ; simpl ; [ apply I.neg_correct | apply I.abs_correct | apply I.inv_correct | apply I.sqr_correct | apply I.sqrt_correct | apply I.cos_correct | apply I.sin_correct | apply I.tan_correct | apply I.atan_correct | apply I.exp_correct | apply I.ln_correct | apply I.power_int_correct | apply I.nearbyint_correct | apply J.round_flt_correct' | apply I.error_flt_correct | apply J.round_fix_correct' | apply I.error_fix_correct ] ; exact Hf. apply (unary_diff_bnd_correct prec o (fun x => fst (f x)) (fun x => snd (f x))) with (3 := Hx). exact (fun x Hx => proj1 (H x Hx)). exact (fun x Hx => proj2 (H x Hx)). intros o f1 f2 (yi1, yi1') (yi2, yi2') H1 H2 x Hx. rewrite (surjective_pairing (f1 x)). rewrite (surjective_pairing (f2 x)). split. assert (Hf1 := proj1 (H1 x Hx)). assert (Hf2 := proj1 (H2 x Hx)). destruct o ; simpl ; [ apply I.add_correct | apply I.sub_correct | apply I.mul_correct | apply I.div_correct ] ; first [ exact Hf1 | exact Hf2 ]. apply (binary_diff_bnd_correct prec o (fun x => fst (f1 x)) (fun x => fst (f2 x)) (fun x => snd (f1 x)) (fun x => snd (f2 x))) with (5 := Hx). exact (fun x Hx => proj1 (H1 x Hx)). exact (fun x Hx => proj1 (H2 x Hx)). exact (fun x Hx => proj2 (H1 x Hx)). exact (fun x Hx => proj2 (H2 x Hx)). clear -Hv. intros [|n] x Hx ; simpl. split. exact Hx. apply I.mask_correct. now apply I.fromZ_small_correct. exact Hx. split. rewrite <- (map_nth (@fst I.type I.type)). rewrite <- (map_nth (@fst ExtendedR ExtendedR)). rewrite 2!map_map /= map_id. now apply contains_map_Xreal. rewrite <- (map_nth (@snd I.type I.type)). rewrite <- (map_nth (@snd ExtendedR ExtendedR)). rewrite 2!map_map /=. rewrite (nth_map I.nai). destruct le_lt_dec as [H|H]. rewrite nth_overflow. now rewrite I.nai_correct. rewrite map_length. now rewrite <- (proj1 Hv). rewrite (nth_map_lt 0). apply I.mask_correct. rewrite I.zero_correct. split ; apply Rle_refl. exact Hx. now rewrite <- (proj1 Hv). Qed. Definition diff_refining_points prec xi di yi yi' ym yl yu := match I.sign_large yi' with | Xund => if I.bounded yi' then I.meet yi (I.add prec ym (I.mul prec di yi')) else yi | Xeq => ym | Xlt => I.meet (if I.lower_bounded xi then I.lower_extent yl else I.whole) (if I.upper_bounded xi then I.upper_extent yu else I.whole) | Xgt => I.meet (if I.lower_bounded xi then I.upper_extent yl else I.whole) (if I.upper_bounded xi then I.lower_extent yu else I.whole) end. Definition diff_refining prec xi yi yi' fi := match I.sign_large yi' with | Xund => if I.bounded yi' then let mi := J.midpoint xi in I.meet yi (I.add prec (fi mi) (I.mul prec (I.sub prec xi mi) yi')) else yi | Xeq => fi (J.midpoint xi) | Xlt => I.meet (if I.lower_bounded xi then let l := I.lower xi in I.lower_extent (fi (I.bnd l l)) else I.whole) (if I.upper_bounded xi then let u := I.upper xi in I.upper_extent (fi (I.bnd u u)) else I.whole) | Xgt => I.meet (if I.lower_bounded xi then let l := I.lower xi in I.upper_extent (fi (I.bnd l l)) else I.whole) (if I.upper_bounded xi then let u := I.upper xi in I.lower_extent (fi (I.bnd u u)) else I.whole) end. Lemma diff_refining_aux_0 : forall f f' xi yi', Xderive f f' -> I.sign_large yi' <> Xund -> (forall x, contains xi x -> contains (I.convert yi') (f' x)) -> forall x, contains xi x -> x = Xreal (proj_val x) /\ forall v, f x = Xreal (proj_fun v f (proj_val x)) /\ f' x = Xreal (proj_fun v f' (proj_val x)). Proof. intros f f' xi yi' Hd Hs Hy' x Hx. case_eq (f' x). (* assuming f'(x) is NaN ... *) intros Hnf'. generalize (Hy' _ Hx). rewrite Hnf'. intros Hny'. apply False_ind. generalize (I.sign_large_correct yi'). destruct (I.sign_large yi') ; intros H. generalize (H _ Hny'). discriminate. destruct (H _ Hny') as (H0, _). discriminate H0. destruct (H _ Hny') as (H0, _). discriminate H0. now elim Hs. (* ... leads to a contradiction, so f'(x) is real ... *) intros ry' Hrf'. generalize (Hd x). destruct x as [|x]. rewrite Hrf'. now intro H. (* ... so x is real too *) rewrite Hrf'. unfold Xderive_pt. case_eq (f (Xreal x)). now intros _ H. intros ry Hrf _. repeat split. unfold proj_fun, proj_val. now rewrite Hrf. unfold proj_fun, proj_val. now rewrite Hrf'. Qed. Lemma diff_refining_aux_1 : forall prec f f' xi yi' m mi ymi, Xderive f f' -> contains (I.convert mi) (Xreal m) -> contains (I.convert xi) (Xreal m) -> contains (I.convert ymi) (f (Xreal m)) -> (forall x, contains (I.convert xi) x -> contains (I.convert yi') (f' x)) -> forall x, contains (I.convert xi) x -> contains (I.convert (I.add prec ymi (I.mul prec (I.sub prec xi mi) yi'))) (f x). Proof. intros prec f f' xi yi' m mi ymi Hd Hxm Hm Hym Hy' x Hx. case_eq (I.convert yi'). (* - yi' is NaI *) intro Hyn'. rewrite I.add_propagate_r. easy. now apply I.mul_propagate_r. (* - yi' is real ... *) intros yl' yu' Hyi'. destruct x as [|x]. case_eq (I.convert xi). intros Hxi. generalize (Hy' _ Hx). rewrite Hyi'. generalize (Hd Xnan). unfold Xderive_pt. case (f' Xnan). intros _ H. elim H. intros _ H _. elim H. intros xl xu Hxi. rewrite Hxi in Hx. elim Hx. (* ... so x is real ... *) set (Pxi := fun x => contains (I.convert xi) (Xreal x)). assert (H': forall c, Pxi c -> f' (Xreal c) <> Xnan). intros c Hc H. generalize (Hy' (Xreal c) Hc). rewrite H Hyi'. intro H0. elim H0. (* ... and we can apply the MVT *) destruct (Xderive_MVT _ _ Hd Pxi (contains_connected _) H' _ Hm _ Hx) as (c, (Hc1, Hc2)). rewrite Hc2. apply I.add_correct. exact Hym. rewrite Xmul_comm. apply I.mul_correct. now apply I.sub_correct. apply Hy'. exact Hc1. Qed. Lemma diff_refining_aux_2 : forall f f' xi m ymi, Xderive f f' -> contains xi (Xreal m) -> contains ymi (f (Xreal m)) -> (forall x, contains xi x -> contains (Ibnd (Xreal 0) (Xreal 0)) (f' x)) -> forall x, contains xi x -> contains ymi (f x). Proof. intros f f' xi m ymi Hd Hm Hym Hy'. (* the derivative is zero ... *) destruct xi as [|xl xu]. apply False_ind. generalize (Hy' Xnan I) (Hd Xnan). now case (f' (Xnan)). intros [|x] Hx. elim Hx. (* ... so x is real ... *) set (Pxi := fun x => contains (Ibnd xl xu) (Xreal x)). assert (H': forall c, Pxi c -> f' (Xreal c) <> Xnan). intros c Hc H. generalize (Hy' (Xreal c) Hc). now rewrite H. (* ... and we can apply the MVT *) destruct (Xderive_MVT _ _ Hd Pxi (contains_connected _) H' _ Hm _ Hx) as (c, (Hc1, Hc2)). rewrite Hc2. replace (f' (Xreal c)) with (Xreal 0). simpl. rewrite Rmult_0_l. rewrite Xadd_0_r. exact Hym. generalize (Hy' (Xreal c) Hc1). destruct (f' (Xreal c)) as [|y]. intro H. elim H. intros (H3,H4). apply f_equal. now apply Rle_antisym. Qed. Theorem diff_refining_points_correct : forall prec f f' xi yi yi' ym yl yu, Xderive f f' -> (forall x, contains (I.convert xi) x -> contains (I.convert yi) (f x)) -> (forall x, contains (I.convert xi) x -> contains (I.convert yi') (f' x)) -> contains (I.convert ym) (f (I.F.convert (I.midpoint xi))) -> (if I.lower_bounded xi then contains (I.convert yl) (f (I.F.convert (I.lower xi))) else True) -> (if I.upper_bounded xi then contains (I.convert yu) (f (I.F.convert (I.upper xi))) else True) -> forall x, contains (I.convert xi) x -> contains (I.convert (diff_refining_points prec xi (I.sub prec xi (J.midpoint xi)) yi yi' ym yl yu)) (f x). Proof. intros prec f f' xi yi yi' ym yl yu Hd Hyi Hyi' Hym Hyl Hyu x Hx. unfold diff_refining_points. generalize (I.sign_large_correct yi'). assert (Hnexi : not_empty (I.convert xi)). { apply not_empty_contains with (1 := Hx). } case_eq (I.sign_large yi') ; intros Hs1 Hs2. (* - sign is Xeq *) eapply diff_refining_aux_2 with (1 := Hd) (5 := Hx). apply J.subset_midpoint with (1 := Hnexi). now apply J.contains_midpoint. now destruct (I.midpoint_correct xi Hnexi) as [<- _]. intros. rewrite (Hs2 (f' x0)). split ; apply Rle_refl. now apply Hyi'. (* - sign is Xlt *) assert (I.sign_large yi' <> Xund). now rewrite Hs1. clear Hs1. rename H into Hs1. assert (forall x, contains (I.convert xi) x -> forall v, f x = Xreal (proj_fun v f (proj_val x)) /\ f' x = Xreal (proj_fun v f' (proj_val x)) /\ (proj_fun v f' (proj_val x) <= 0)%R). intros a Ha v. destruct (Hs2 _ (Hyi' _ Ha)) as (Ha1, Ha2). destruct (diff_refining_aux_0 _ _ _ _ Hd Hs1 Hyi' _ Ha) as (Ha3, Ha4). destruct (Ha4 v) as (Ha5, Ha6). split. exact Ha5. split. exact Ha6. rewrite Ha1 in Ha6. inversion Ha6. exact Ha2. clear Hs2. rename H into Hs2. apply I.meet_correct. (* lower part *) case_eq (I.lower_bounded xi). intros H. destruct (I.lower_bounded_correct xi H) as (Hxl, Hxi). rewrite H in Hyl. clear Hym Hyu H. assert (Hl: contains (I.convert xi) (I.F.convert (I.lower xi))). rewrite (Hxi Hnexi) Hxl. apply contains_lower with x. now rewrite <- Hxl, <- Hxi. rewrite (proj1 (Hs2 _ Hx R0)). apply I.lower_extent_correct with (proj_fun 0 f (proj_val (I.F.convert (I.lower xi)))). now rewrite <- (proj1 (Hs2 _ Hl 0)). destruct (diff_refining_aux_0 _ _ _ _ Hd Hs1 Hyi' _ Hx) as (Hx1, _). eapply (derivable_neg_imp_decreasing (proj_fun R0 f) (proj_fun R0 f')). apply (contains_connected (I.convert xi)). intros a Ha. simpl in Ha. destruct (Hs2 _ Ha R0) as (Ha1, (Ha2, Ha3)). split. generalize (Hd (Xreal a)). unfold Xderive_pt. rewrite Ha2 Ha1. intro H. exact (H R0). exact Ha3. simpl. now rewrite <- Hxl. simpl. now rewrite <- Hx1. rewrite -> Hxi, Hx1, Hxl in Hx. exact (proj1 Hx). exact Hnexi. intros _. rewrite (proj1 (Hs2 x Hx R0)). apply I.whole_correct. (* upper part *) case_eq (I.upper_bounded xi). intros H. destruct (I.upper_bounded_correct xi H) as (Hxu, Hxi). rewrite H in Hyu. clear H. assert (Hu: contains (I.convert xi) (I.F.convert (I.upper xi))). rewrite (Hxi Hnexi) Hxu. apply contains_upper with x. now rewrite <- Hxu, <- Hxi. rewrite (proj1 (Hs2 _ Hx R0)). apply I.upper_extent_correct with (proj_fun 0 f (proj_val (I.F.convert (I.upper xi)))). now rewrite <- (proj1 (Hs2 _ Hu 0)). destruct (diff_refining_aux_0 _ _ _ _ Hd Hs1 Hyi' _ Hx) as (Hx1, _). eapply (derivable_neg_imp_decreasing (proj_fun R0 f) (proj_fun R0 f')). apply (contains_connected (I.convert xi)). intros a Ha. simpl in Ha. destruct (Hs2 _ Ha R0) as (Ha1, (Ha2, Ha3)). split. generalize (Hd (Xreal a)). unfold Xderive_pt. rewrite Ha2 Ha1. intro H. exact (H R0). exact Ha3. simpl. now rewrite <- Hx1. simpl. now rewrite <- Hxu. rewrite -> Hxi, Hx1, Hxu in Hx. exact (proj2 Hx). exact Hnexi. intros _. rewrite (proj1 (Hs2 x Hx R0)). apply I.whole_correct. (* - sign is Xgt *) assert (I.sign_large yi' <> Xund). now rewrite Hs1. clear Hs1. rename H into Hs1. assert (forall x, contains (I.convert xi) x -> forall v, f x = Xreal (proj_fun v f (proj_val x)) /\ f' x = Xreal (proj_fun v f' (proj_val x)) /\ (0 <= proj_fun v f' (proj_val x))%R). intros a Ha v. destruct (Hs2 _ (Hyi' _ Ha)) as (Ha1, Ha2). destruct (diff_refining_aux_0 _ _ _ _ Hd Hs1 Hyi' _ Ha) as (Ha3, Ha4). destruct (Ha4 v) as (Ha5, Ha6). split. exact Ha5. split. exact Ha6. rewrite Ha1 in Ha6. inversion Ha6. exact Ha2. clear Hs2. rename H into Hs2. apply I.meet_correct. (* lower part *) case_eq (I.lower_bounded xi). intros H. destruct (I.lower_bounded_correct xi H) as (Hxl, Hxi). rewrite H in Hyl. clear H. assert (Hl: contains (I.convert xi) (I.F.convert (I.lower xi))). rewrite (Hxi Hnexi) Hxl. apply contains_lower with x. now rewrite <- Hxl, <- Hxi. rewrite (proj1 (Hs2 _ Hx R0)). apply I.upper_extent_correct with (proj_fun 0 f (proj_val (I.F.convert (I.lower xi)))). now rewrite <- (proj1 (Hs2 _ Hl 0)). destruct (diff_refining_aux_0 _ _ _ _ Hd Hs1 Hyi' _ Hx) as (Hx1, _). eapply (derivable_pos_imp_increasing (proj_fun 0 f) (proj_fun 0 f')). apply (contains_connected (I.convert xi)). intros a Ha. simpl in Ha. destruct (Hs2 _ Ha R0) as (Ha1, (Ha2, Ha3)). split. generalize (Hd (Xreal a)). unfold Xderive_pt. rewrite Ha2 Ha1. intro H. exact (H R0). exact Ha3. simpl. now rewrite <- Hxl. simpl. now rewrite <- Hx1. rewrite -> Hxi, Hx1, Hxl in Hx. exact (proj1 Hx). exact Hnexi. intros _. rewrite (proj1 (Hs2 x Hx R0)). apply I.whole_correct. (* upper part *) case_eq (I.upper_bounded xi). intros H. destruct (I.upper_bounded_correct xi H) as (Hxu, Hxi). rewrite H in Hyu. clear H. assert (Hu: contains (I.convert xi) (I.F.convert (I.upper xi))). rewrite (Hxi Hnexi) Hxu. apply contains_upper with x. now rewrite <- Hxu, <- Hxi. rewrite (proj1 (Hs2 _ Hx R0)). apply I.lower_extent_correct with (proj_fun 0 f (proj_val (I.F.convert (I.upper xi)))). now rewrite <- (proj1 (Hs2 _ Hu 0)). destruct (diff_refining_aux_0 _ _ _ _ Hd Hs1 Hyi' _ Hx) as (Hx1, _). eapply (derivable_pos_imp_increasing (proj_fun 0 f) (proj_fun 0 f')). apply (contains_connected (I.convert xi)). intros a Ha. simpl in Ha. destruct (Hs2 _ Ha R0) as (Ha1, (Ha2, Ha3)). split. generalize (Hd (Xreal a)). unfold Xderive_pt. rewrite Ha2 Ha1. intro H. exact (H R0). exact Ha3. simpl. now rewrite <- Hx1. simpl. now rewrite <- Hxu. rewrite -> Hxi, Hx1, Hxu in Hx. exact (proj2 Hx). exact Hnexi. intros _. rewrite (proj1 (Hs2 x Hx R0)). apply I.whole_correct. (* - sign is Xund *) clear Hs1 Hs2. case_eq (I.bounded yi') ; intro Hb. apply I.meet_correct. now apply Hyi. destruct (I.midpoint_correct xi Hnexi) as (Hm1, Hm2). eapply diff_refining_aux_1 with (1 := Hd). now apply J.contains_midpoint. now rewrite <- Hm1. now rewrite <- Hm1. exact Hyi'. exact Hx. now apply Hyi. Qed. Lemma convert_bnd : forall l u v, contains (Ibnd l u) (I.F.convert v) -> contains (I.convert (I.bnd v v)) (I.F.convert v). Proof. intros l u v H. rewrite I.bnd_correct. destruct (I.F.convert v). elim H. split ; apply Rle_refl. - apply I.valid_lb_real. now revert H; case I.F.convert. - apply I.valid_ub_real. now revert H; case I.F.convert. Qed. Theorem diff_refining_correct : forall prec f f' fi fi', I.extension f fi -> I.extension f' fi' -> Xderive f f' -> I.extension f (fun b => diff_refining prec b (fi b) (fi' b) fi). Proof. intros prec f f' fi fi' Hf Hf' Hd xi x Hx. unfold diff_refining. case_eq (I.convert xi) ; intros. (* - xi is Inan *) assert (contains (I.convert (fi' xi)) Xnan). replace Xnan with (f' Xnan). apply Hf'. now rewrite H. generalize (Hd Xnan). now case (f' Xnan) ; intros. generalize (I.sign_large_correct (fi' xi)). case (I.sign_large (fi' xi)) ; intro. now assert (H2 := H1 _ H0). now assert (H2 := proj1 (H1 _ H0)). now assert (H2 := proj1 (H1 _ H0)). clear H1. generalize (I.bounded_correct (fi' xi)). case (I.bounded (fi' xi)). intro H1. generalize (I.lower_bounded_correct _ (proj1 (H1 (refl_equal _)))). clear H1. intros (_, H1). unfold I.bounded_prop in H1. { destruct (I.convert (fi' xi)). have Hex : exists v : R, contains Inan (Xreal v) by exists R0. by move/(_ Hex) in H1. by case: H0. } intros _. now apply Hf. (* - xi is Ibnd *) apply diff_refining_points_correct with (1 := Hd) (7 := Hx). apply Hf. apply Hf'. apply Hf. apply (convert_bnd l u). rewrite <- H. apply I.midpoint_correct. apply not_empty_contains with (1 := Hx). (* lower bound *) generalize (I.lower_bounded_correct xi). case (I.lower_bounded xi). refine (fun H0 => _ (H0 (refl_equal true))). clear H0. intros (H0, H1). apply Hf. apply (convert_bnd l l). rewrite -> H1, H0 in H. rewrite H0. inversion_clear H. split; exact: Rle_refl. apply not_empty_contains with (1 := Hx). now intros _. (* upper bound *) generalize (I.upper_bounded_correct xi). case (I.upper_bounded xi). refine (fun H0 => _ (H0 (refl_equal true))). clear H0. intros (H0, H1). apply Hf. apply (convert_bnd u u). rewrite -> H1, H0 in H. rewrite H0. inversion H. split ; apply Rle_refl. apply not_empty_contains with (1 := Hx). now intros _. Qed. Definition eval prec formula bounds n xi := match nth n (eval_generic (diff_operations _ (BndValuator.operations prec)) formula ((xi, I.mask (I.fromZ_small 1) xi) :: map (fun b => (b, I.mask I.zero xi)) bounds)) (I.nai, I.nai) with | (yi, yi') => diff_refining prec xi yi yi' (fun b => nth n (BndValuator.eval prec formula (b :: bounds)) I.nai) end. Theorem eval_correct_ext : forall prec prog bounds vars, contains_all bounds vars -> forall n, I.extension (fun x => nth n (eval_ext prog (x :: map Xreal vars)) Xnan) (fun b => eval prec prog bounds n b). Proof. intros prec prog bounds vars Hv n xi x Hx. unfold eval. pose (f := fun x => nth n (eval_ext prog (x :: map Xreal vars)) Xnan). fold (f x). pose (ff' := fun x => nth n (eval_generic (diff_operations _ ext_operations) prog ((x, Xmask (Xreal 1) x) :: map (fun v => (Xreal v, Xmask (Xreal 0) x)) vars)) (Xnan, Xnan)). set (fi := fun xi => nth n (BndValuator.eval prec prog (xi :: bounds)) I.nai). pose (ffi' := fun xi => nth n (eval_generic (diff_operations _ (BndValuator.operations prec)) prog ((xi, I.mask (I.fromZ_small 1) xi) :: map (fun b => (b, I.mask I.zero xi)) bounds)) (I.nai, I.nai)). fold (ffi' xi). rewrite (surjective_pairing (ffi' xi)). assert (H := eval_diff_bnd_correct prec prog bounds vars Hv n). replace (fst (ffi' xi)) with (fi xi) by apply H. pose (fi' := fun xi => snd (ffi' xi)). fold (fi' xi). pose (f' x := snd (ff' x)). refine (diff_refining_correct prec f f' _ _ _ _ _ xi x Hx) ; clear Hx xi x. - now apply BndValuator.eval_correct_ext. - intros xi x Hx. now apply H. - intros x. apply eval_diff_correct. Qed. Theorem eval_correct : forall prec prog bounds vars, contains_all bounds vars -> forall n xi x, contains (I.convert xi) (Xreal x) -> contains (I.convert (eval prec prog bounds n xi)) (Xreal (nth n (eval_real prog (x :: vars)) 0%R)). Proof. intros prec prog bounds vars Hv n xi x Hx. set (yi := eval prec prog _ n xi). apply (xreal_to_real (fun y => contains (I.convert yi) y) (fun y => contains (I.convert yi) (Xreal y))). now destruct (I.convert yi). easy. simpl. apply eval_correct_ext with (1 := Hv) (2 := Hx). Qed. Definition root prec formula bounds xi := match nth 0 (eval_generic (diff_operations _ (BndValuator.operations prec)) formula ((xi, I.mask (I.fromZ_small 1) xi) :: map (fun b => (b, I.mask I.zero xi)) bounds)) (I.nai, I.nai) with | (yi, yi') => match I.sign_strict yi with | Xlt | Xgt => I.empty | _ => let mi := J.midpoint xi in let yi := nth 0 (BndValuator.eval prec formula (mi :: bounds)) I.nai in I.meet xi (I.sub prec mi (I.div prec yi yi')) end end. Theorem root_correct_ext : forall prec prog bounds vars, contains_all bounds vars -> forall xi x, contains (I.convert xi) x -> nth 0 (eval_ext prog (x :: map Xreal vars)) Xnan = Xreal 0 -> contains (I.convert (root prec prog bounds xi)) x. Proof. intros prec prog bounds vars Hv xi x Hx Zx. unfold root. pose (f := fun x => nth 0 (eval_ext prog (x :: map Xreal vars)) Xnan). fold (f x) in Zx. pose (ff' := fun x => nth 0 (eval_generic (diff_operations _ ext_operations) prog ((x, Xmask (Xreal 1) x) :: map (fun v => (Xreal v, Xmask (Xreal 0) x)) vars)) (Xnan, Xnan)). set (fi := fun xi => nth 0 (BndValuator.eval prec prog (xi :: bounds)) I.nai). pose (ffi' := fun xi => nth 0 (eval_generic (diff_operations _ (BndValuator.operations prec)) prog ((xi, I.mask (I.fromZ_small 1) xi) :: map (fun b => (b, I.mask I.zero xi)) bounds)) (I.nai, I.nai)). fold (ffi' xi). rewrite (surjective_pairing (ffi' xi)). assert (H0 := eval_diff_bnd_correct prec prog bounds vars Hv 0 xi). pose (fi' := fun xi => snd (ffi' xi)). pose (f' x := snd (ff' x)). fold (fi (J.midpoint xi)) (fi' xi). fold ff' ffi' (fi xi) (fi' xi) in H0. cut (contains (I.convert (I.meet xi (I.sub prec (J.midpoint xi) (I.div prec (fi (J.midpoint xi)) (fi' xi))))) x). { intros H. generalize (I.sign_strict_correct (fst (ffi' xi))). destruct I.sign_strict ; try easy. - intros H'. elim (Rlt_irrefl 0). specialize (H' (f x)). rewrite Zx in H'. apply H'. rewrite <- (proj1 H0), <- Zx. now apply BndValuator.eval_correct_ext. - intros H'. elim (Rlt_irrefl 0). specialize (H' (f x)). rewrite Zx in H'. apply H'. rewrite <- (proj1 H0), <- Zx. now apply BndValuator.eval_correct_ext. } apply I.meet_correct with (1 := Hx). destruct H0 as [_ H1]. assert (H2 := eval_diff_correct prog vars 0). fold (ff' x) f in H2. case_eq (I.convert (fi' xi)). { intros H. apply contains_Inan. apply I.sub_propagate_r. now apply I.div_propagate_r. } intros fi'l fi'u Hfi'. destruct x as [|x]. { generalize (H1 Xnan Hx) (proj2 (H2 Xnan)). fold (ff' Xnan) (f' Xnan). rewrite Hfi'. now destruct (f' Xnan). } assert (Nx := not_empty_contains _ _ Hx). destruct (I.midpoint_correct xi Nx) as [Hm1 Hm2]. set (m := proj_val (I.F.convert (I.midpoint xi))). fold m in Hm1. rewrite Hm1 in Hm2. assert (Hm3: contains (I.convert (J.midpoint xi)) (I.F.convert (I.midpoint xi))). { rewrite Hm1. now apply J.contains_midpoint. } replace x with (m - (m - x))%R by ring. change (Xreal (m - (m - x))) with (Xsub (Xreal m) (Xreal (m - x))). apply I.sub_correct. now rewrite <- Hm1. refine (_ (Xderive_MVT f f' _ _ (contains_connected (I.convert xi)) _ _ Hm2 x Hx)) ; cycle 1. { intros x'. apply H2. } { intros x' Hx'. generalize (H1 _ Hx'). fold (f' (Xreal x')). rewrite Hfi'. now destruct (f' (Xreal x')). } intros [c [Hc1 Hc2]]. generalize (H1 _ Hc1). fold (f' (Xreal c)). intros Hf'c. destruct (f' (Xreal c)) as [|f'c] eqn:Ef'c. now rewrite Hfi' in Hf'c. destruct (Req_dec f'c 0) as [Zf'c|Zf'c]. { apply contains_Inan. apply contains_Xnan. rewrite <- (Xdiv_0_r (f (I.F.convert (I.midpoint xi)))). apply I.div_correct. now apply BndValuator.eval_correct_ext with (2 := Hm3). now rewrite <- Zf'c. } replace (Xreal (m - x)) with (f (I.F.convert (I.midpoint xi)) / f' (Xreal c))%XR. { apply I.div_correct. now apply BndValuator.eval_correct_ext with (2 := Hm3). now apply H1. } rewrite Zx in Hc2. rewrite Hm1 Ef'c. rewrite Xdiv_split. unfold Xinv, Xinv'. rewrite -> is_zero_false by easy. clearbody f'. clear -Hc2 Zf'c. destruct f as [|y]. easy. apply (f_equal Xreal). injection Hc2 as H. apply eq_sym in H. rewrite <- (Ropp_involutive y), <- (Rplus_opp_r_uniq _ _ H). now field. Qed. Theorem root_correct : forall prec prog bounds vars, contains_all bounds vars -> forall xi x, contains (I.convert xi) (Xreal x) -> nth 0 (eval_real prog (x :: vars)) 0%R = 0%R -> contains (I.convert (root prec prog bounds xi)) (Xreal x). Proof. intros prec prog bounds vars Hv xi x Hx Zx. generalize (root_correct_ext prec prog bounds vars Hv _ _ Hx). destruct (nth 0 (eval_ext _ _) Xnan) as [|y] eqn:Hy. - intros _. unfold root. assert (H1 := eval_diff_bnd_correct prec prog bounds vars Hv 0 xi). simpl in H1. destruct (nth 0 (eval_generic _ _ _) _) as [yi zi]. generalize (BndValuator.eval_correct_ext prec prog bounds vars Hv 0 _ _ Hx). rewrite (proj1 H1) Hy. intros H2. generalize (I.sign_strict_correct yi). destruct I.sign_strict ; try now intros H3 ; specialize (H3 _ H2). intros _. apply I.meet_correct with (1 := Hx). apply contains_Inan. apply I.sub_propagate_r. apply I.div_propagate_r. destruct H1 as [_ H1]. specialize (H1 _ Hx). assert (H3 := eval_diff_correct prog vars 0 (Xreal x)). destruct (nth 0 (eval_generic _ _ _) _) as [y y']. apply contains_Xnan. destruct H3 as [_ H3]. unfold Xderive_pt in H3. destruct y' as [|y']. easy. now rewrite Hy in H3. - apply. apply f_equal, sym_eq. rewrite <- Zx. apply (xreal_to_real (fun z => z = Xreal y)). easy. intros r H. now injection H. easy. Qed. End DiffValuator. Module TaylorValuator. Module TM := TM I. Definition operations prec deg xi := Build_operations (fun _ => TM.dummy) (* fromZ *) TM.dummy (fun o => match o with | Neg => TM.opp (prec, deg) xi | Abs => TM.abs (prec, deg) xi | Inv => TM.inv (prec, deg) xi | Sqr => TM.sqr (prec, deg) xi | Sqrt => TM.sqrt (prec, deg) xi | Cos => TM.cos (prec, deg) xi | Sin => TM.sin (prec, deg) xi | Tan => TM.tan (prec, deg) xi | Atan => TM.atan (prec, deg) xi | Exp => TM.exp (prec, deg) xi | Ln => TM.ln (prec, deg) xi | PowerInt n => TM.power_int n (prec, deg) xi | Nearbyint m => TM.nearbyint m (prec, deg) xi | RoundFlt m emin p => TM.round_flt (prec, deg) m emin p xi | ErrorFlt m emin p => TM.error_flt (prec, deg) m emin p xi | RoundFix m emin => TM.round_fix (prec, deg) m emin xi | ErrorFix m emin => TM.error_fix (prec, deg) m emin xi end) (fun o => match o with | Add => TM.add (prec, deg) xi | Sub => TM.sub (prec, deg) xi | Mul => TM.mul (prec, deg) xi | Div => TM.div (prec, deg) xi end) (fun _ => Xund) (* sign_strict *). Definition eval prec deg xi := eval_generic (operations prec deg xi). Theorem eval_correct_aux : forall prec deg prog bounds vars, contains_all bounds vars -> forall n xi, TM.approximates xi (nth n (eval prec deg xi prog (TM.var :: map TM.const bounds)) TM.dummy) (fun x => nth n (eval_ext prog (Xreal x :: map Xreal vars)) Xnan). Proof. intros prec deg prog bounds vars Hv n xi. unfold eval, eval_ext. rewrite rev_formula. apply (@TM.approximates_ext (fun t => nth n (fold_right (fun y l => eval_generic_body ext_operations l y) (Xreal t :: map Xreal vars) (rev prog)) Xnan)). intros t. apply (f_equal (fun v => nth n v _)). apply sym_eq, rev_formula. revert n. induction (rev prog) as [|t l]. - intros [|n]. + now apply TM.var_correct. + simpl. rewrite (nth_map I.nai). destruct le_lt_dec as [H|H]. rewrite nth_overflow. eapply TM.approximates_ext. easy. now apply TM.dummy_correct. rewrite map_length. now rewrite <- (proj1 Hv). rewrite (nth_map_lt 0). eapply TM.approximates_ext. easy. apply TM.const_correct. apply Hv. now rewrite <- (proj1 Hv). - intros [|n]. 2: apply IHl. simpl. destruct t as [|uo n1|bo n1 n2]. + apply IHl. + generalize (IHl n1). destruct uo. apply TM.opp_correct. apply TM.abs_correct. apply TM.inv_correct. apply TM.sqr_correct. apply TM.sqrt_correct. apply TM.cos_correct. apply TM.sin_correct. apply TM.tan_correct. apply TM.atan_correct. apply TM.exp_correct. apply TM.ln_correct. apply TM.power_int_correct. apply TM.nearbyint_correct. apply TM.round_flt_correct. apply TM.error_flt_correct. apply TM.round_fix_correct. apply TM.error_fix_correct. + generalize (IHl n1) (IHl n2). destruct bo. apply TM.add_correct. apply TM.sub_correct. apply TM.mul_correct. apply TM.div_correct. Qed. Theorem eval_correct_aux' : forall prec deg prog bounds vars, contains_all bounds vars -> forall n xi, TM.approximates xi (nth n (eval prec deg xi prog (TM.var :: map TM.const bounds)) TM.dummy) (fun x => Xreal (nth n (eval_real prog (x :: vars)) 0)). Proof. intros prec deg prog bounds vars Hv n xi. generalize (eval_correct_aux prec deg prog bounds vars Hv n xi). intros H Ex. specialize (H Ex). destruct (nth n _ _) as [c| |]. - destruct H as [->|[[|y] H1 H2]]. now left. left. now destruct (I.convert c). right. exists (Xreal y). exact H1. intros x Hx. apply (xreal_to_real (fun x => x = Xreal y) (fun x => Xreal x = Xreal y)) ; try easy. now apply H2. - intros y Hy. apply (xreal_to_real (fun x => x = Xreal y) (fun x => Xreal x = Xreal y)) ; try easy. now apply H. - destruct H as [H1 H2 H3 H4 H5]. split ; try easy. destruct H5 as [Q H6 H7]. exists Q. exact H6. intros x Hx. simpl. set (x0 := proj_val (I.F.convert (I.midpoint xi))). apply (xreal_to_real (fun v => (v = Xnan -> I.convert (Taylor_model_sharp.error r) = Inan) /\ contains (I.convert (Taylor_model_sharp.error r)) (Xreal (proj_val v - Datatypes.PolR.horner tt Q (x - x0)))) (fun v => contains (I.convert (Taylor_model_sharp.error r)) (Xreal (v - Datatypes.PolR.horner tt Q (x - x0))))). + intros [Ha _]. now rewrite Ha. + intros a Ha. apply Ha. + simpl. split. now apply H1. now apply H7. Qed. Theorem eval_correct_ext : forall prec deg prog bounds vars, contains_all bounds vars -> forall n yi, I.extension (Xbind (fun x => nth n (eval_ext prog (Xreal x :: map Xreal vars)) Xnan)) (fun b => TM.eval (prec,deg) (nth n (eval prec deg yi prog (TM.var :: map TM.const bounds)) TM.dummy) yi b). Proof. intros prec deg prog bounds vars Hv n yi xi x Hx. apply (@TM.eval_correct (prec,deg) yi) with (2 := Hx). now apply eval_correct_aux. Qed. Theorem eval_correct : forall prec deg prog bounds vars, contains_all bounds vars -> forall n yi xi x, contains (I.convert xi) (Xreal x) -> contains (I.convert (TM.eval (prec,deg) (nth n (eval prec deg yi prog (TM.var :: map TM.const bounds)) TM.dummy) yi xi)) (Xreal (nth n (eval_real prog (x :: vars)) 0%R)). Proof. intros prec deg prog bounds vars Hv n zi xi x Hx. set (yi := TM.eval _ _ _ _). apply (xreal_to_real (fun y => contains (I.convert yi) y) (fun y => contains (I.convert yi) (Xreal y))). now destruct (I.convert yi). easy. apply (eval_correct_ext prec deg prog bounds vars Hv n zi xi _ Hx). Qed. End TaylorValuator. End IntervalAlgos. interval-4.11.1/src/Eval/Prog.v000066400000000000000000000400671470547631300162170ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2019, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals List Psatz. Require Import Xreal. Require Import Tree. Inductive term : Set := | Forward : nat -> term | Unary : unary_op -> nat -> term | Binary : binary_op -> nat -> nat -> term. Set Implicit Arguments. Record operations (A : Type) : Type := { constant : Z -> A ; unknown : A ; unary : unary_op -> A -> A ; binary : binary_op -> A -> A -> A ; sign : A -> Xcomparison }. Unset Implicit Arguments. Definition eval_generic_body {A} (ops : operations A) values op := let nth n := nth n values (unknown ops) in match op with | Forward u => nth u | Unary o u => unary ops o (nth u) | Binary o u v => binary ops o (nth u) (nth v) end :: values. Definition eval_generic {A} (ops : operations A) := fold_left (eval_generic_body ops). Lemma rev_formula : forall A formula terms (ops : operations A), eval_generic ops formula terms = fold_right (fun y x => eval_generic_body ops x y) terms (rev formula). Proof. intros. pattern formula at 1 ; rewrite <- rev_involutive. unfold eval_generic, eval_generic_body. rewrite <- fold_left_rev_right. rewrite rev_involutive. apply refl_equal. Qed. Theorem eval_inductive_prop : forall A B (P : A -> B -> Prop) (opsA : operations A) (opsB : operations B), (forall o a b, P a b -> P (unary opsA o a) (unary opsB o b)) -> (forall o a1 a2 b1 b2, P a1 b1 -> P a2 b2 -> P (binary opsA o a1 a2) (binary opsB o b1 b2)) -> forall inpA inpB, (forall n, P (nth n inpA (unknown opsA)) (nth n inpB (unknown opsB))) -> forall prog, forall n, P (nth n (eval_generic opsA prog inpA) (unknown opsA)) (nth n (eval_generic opsB prog inpB) (unknown opsB)). Proof. intros A B P opsA opsB Hun Hbin inpA inpB Hinp prog. do 2 rewrite rev_formula. induction (rev prog). exact Hinp. intros [|n]. 2: apply IHl. destruct a as [n|o n|o n1 n2] ; [ idtac | apply Hun | apply Hbin ] ; apply IHl. Qed. Definition real_operations := Build_operations IZR 0%R unary_real binary_real (fun x => Xcmp (Xreal x) (Xreal 0)). Definition eval_real := eval_generic real_operations. Scheme Equality for expr. Inductive splitted_expr : Set := | Sconst | Scomposed (lp lc : list expr). Fixpoint rcons_unique (e : expr) (l : list expr) := match l with | cons h t => if expr_beq e h then l else cons h (rcons_unique e t) | nil => cons e nil end. Lemma rcons_unique_correct : forall e l, exists l', rcons_unique e l = l ++ l'. Proof. induction l as [ | e' l [l' IHl]]. - now exists (e :: nil). - simpl. destruct expr_beq. + exists nil. apply app_nil_end. + exists l'. now rewrite IHl. Qed. Definition cons_unique (e : expr) (l : list expr) := let fix aux (l' : list expr) := match l' with | cons h t => if expr_beq e h then l else aux t | nil => cons e l end in aux l. Fixpoint split_expr (e : expr) (lp lc : list expr) := match e with | Evar n => Scomposed lp lc | Econst o => Sconst | Eunary o e1 => match split_expr e1 lp lc with | Sconst => Sconst | Scomposed lp lc => Scomposed (cons_unique e lp) lc end | Ebinary o e1 e2 => match split_expr e2 lp lc with | Sconst => match split_expr e1 lp lc with | Sconst => Sconst | Scomposed lp lc => Scomposed (cons_unique e lp) (rcons_unique e2 lc) end | Scomposed lp lc => match split_expr e1 lp lc with | Sconst => Scomposed (cons_unique e lp) (rcons_unique e1 lc) | Scomposed lp lc => Scomposed (cons_unique e lp) lc end end end. Lemma eval_nth_rcons_unique : forall d vars vars' e l, eval e vars = eval e vars' -> (forall n, eval (nth n l d) vars = eval (nth n l d) vars') -> forall n, eval (nth n (rcons_unique e l) d) vars = eval (nth n (rcons_unique e l) d) vars'. Proof. intros d vars vars' e l He Hl. induction l as [|h t IH] ; simpl. { simpl in Hl. now intros [|n]. } generalize (internal_expr_dec_bl e h). destruct expr_beq. { now intros _. } intros _ [|n]. { apply (Hl 0). } apply IH. intros n'. apply (Hl (S n')). Qed. Theorem split_expr_correct : forall d vars vars' e lp lc, (forall n, eval (nth n lc d) vars = eval (nth n lc d) vars') -> match split_expr e lp lc with | Sconst => eval e vars = eval e vars' | Scomposed lp' lc' => forall n, eval (nth n lc' d) vars = eval (nth n lc' d) vars' end. Proof. intros d vars vars'. induction e as [n|o|o e1 IHe1|o e1 IHe1 e2 IHe2] ; intros lp lc Hc ; simpl ; try easy. specialize (IHe1 lp lc Hc). destruct split_expr as [|lp' lc']. now apply f_equal. apply IHe1. specialize (IHe2 lp lc Hc). destruct split_expr as [|lp2 lc2]. specialize (IHe1 lp lc Hc). destruct split_expr as [|lp1 lc1]. now apply f_equal2. now apply eval_nth_rcons_unique. specialize (IHe1 lp2 lc2 IHe2). destruct split_expr as [|lp1 lc1]. now apply eval_nth_rcons_unique. apply IHe1. Qed. Fixpoint find_expr_aux (e : expr) (n : nat) (l : list expr) := match l with | cons h t => if expr_beq e h then Some n else find_expr_aux e (S n) t | nil => None end. Definition find_expr (e : expr) (vars : nat) (lp lc : list expr) := match e with | Evar n => if Nat.ltb n vars then Some (List.length lp + n)%nat else None | _ => match find_expr_aux e 0%nat lp with | Some n => Some n | None => find_expr_aux e (length lp + vars)%nat lc end end. Theorem find_expr_correct : forall e vars lp lc, match find_expr e vars lp lc with | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Econst (Int 0)) = e | None => True end. Proof. intros e vars lp lc. assert (H1: forall l n, match find_expr_aux e n l with | Some k => (n <= k < n + length l)%nat /\ nth (k - n) l (Econst (Int 0)) = e | None => True end). induction l as [|h t IH]. easy. intros n. simpl find_expr_aux. generalize (internal_expr_dec_bl e h). destruct expr_beq. intros H. split. simpl. lia. rewrite Nat.sub_diag. now rewrite H. intros _. specialize (IH (S n)). revert IH. destruct find_expr_aux as [k|] ; try easy. intros [H1 H2]. split. simpl. lia. replace (k - n)%nat with (S (k - S n))%nat by lia. easy. unfold find_expr. set (foo := match find_expr_aux e 0%nat lp with | Some n => Some n | None => find_expr_aux e (length lp + vars)%nat lc end). assert (H2: match foo with | Some n => nth n (lp ++ map Evar (seq 0 vars) ++ lc) (Econst (Int 0)) = e | None => True end). unfold foo. clear foo. generalize (H1 lp 0%nat). destruct find_expr_aux as [n1|]. rewrite Nat.add_0_l, Nat.sub_0_r. intros [H2 H3]. now rewrite app_nth1. intros _. specialize (H1 lc (length lp + vars)%nat). revert H1. destruct find_expr_aux as [n2|] ; try easy. intros [H1 H2]. rewrite -> app_nth2 by lia. rewrite app_nth2 ; rewrite map_length, seq_length. now rewrite <- Nat.sub_add_distr. lia. destruct e as [n|o|o n1|o n1 n2] ; simpl ; try easy. destruct (Nat.ltb_spec n vars) as [H|H] ; try easy. rewrite app_nth2 by apply Nat.le_add_r. rewrite Nat.add_comm, Nat.add_sub. rewrite app_nth1. rewrite nth_indep with (d' := Evar 0). now rewrite map_nth, seq_nth. now rewrite map_length, seq_length. now rewrite map_length, seq_length. Qed. Fixpoint decompose (vars : nat) (p : list term) (lp lc : list expr) := match lp with | nil => Some p | cons h t => match find_expr h vars t lc with | Some n => decompose vars (cons (Forward n) p) t lc | None => match h with | Evar n => decompose vars (cons (Forward (length t + n)) p) t lc | Econst _ => None | Eunary o e1 => match find_expr e1 vars t lc with | Some n => decompose vars (cons (Unary o n) p) t lc | None => None end | Ebinary o e1 e2 => match find_expr e1 vars t lc with | Some n1 => match find_expr e2 vars t lc with | Some n2 => decompose vars (cons (Binary o n1 n2) p) t lc | None => None end | None => None end end end end. Theorem decompose_correct : forall vars p lp lc, (forall vars n, eval (nth n lc (Econst (Int 0))) vars = eval (nth n lc (Econst (Int 0))) nil) -> let lc' := map (fun c => eval c nil) lc in match decompose (length vars) p lp lc with | None => True | Some lp' => eval_real lp' (vars ++ lc') = eval_real p ((map (fun c => eval c (vars ++ lc')) lp) ++ (vars ++ lc')) end. Proof. intros vars p lp lc Hc lc'. revert p. induction lp as [|h t IH]. easy. intros p. simpl. assert (H: forall n e, nth n (t ++ map Evar (seq 0 (length vars)) ++ lc) (Econst (Int 0)) = e -> nth n (map (fun c : expr => eval c (vars ++ lc')) t ++ vars ++ lc') 0%R = eval e (vars ++ lc')). intros n e. destruct (Nat.lt_ge_cases n (length t)) as [H1|H1]. rewrite app_nth1 by apply H1. intros H. rewrite app_nth1 by now rewrite map_length. change 0%R with ((fun c => eval c (vars ++ lc')) (Econst (Int 0))). rewrite map_nth. now rewrite H. rewrite app_nth2 by apply H1. rewrite (@app_nth2 _ _ _ _ n) ; rewrite map_length. 2: exact H1. destruct (Nat.lt_ge_cases (n - length t) (length vars)) as [H2|H2]. rewrite app_nth1 by now rewrite map_length, seq_length. rewrite app_nth1 by apply H2. rewrite nth_indep with (d' := Evar 0) by now rewrite map_length, seq_length. rewrite map_nth, seq_nth, Nat.add_0_l by apply H2. intros <-. simpl. now rewrite app_nth1 by apply H2. rewrite app_nth2 ; rewrite map_length, seq_length. 2: exact H2. rewrite app_nth2 by apply H2. intros H. unfold lc'. change 0%R with ((fun c => eval c nil) (Econst (Int 0))). rewrite map_nth, H. rewrite <- H at 2. now rewrite Hc, H. destruct find_expr eqn:H0. { generalize (find_expr_correct h (length vars) t lc). rewrite H0. specialize (IH (Forward n :: p)). destruct decompose; [| easy]. rewrite IH. intros H1. apply H in H1. rewrite <-H1. unfold eval_real. simpl. now unfold eval_generic_body. } clear H0. destruct h as [n|o|o e1|o e1 e2] ; try easy. - specialize (IH (Forward (length t + n) :: p)). destruct decompose ; try easy. rewrite IH. simpl. unfold eval_generic_body. rewrite app_nth2 ; rewrite map_length. apply (f_equal (fun v => eval_real p (nth v _ _ :: _))). lia. lia. - generalize (find_expr_correct e1 (length vars) t lc). destruct find_expr as [n1|] ; try easy. intros H1. specialize (IH (Unary o n1 :: p)). destruct decompose ; try easy. rewrite IH. simpl. unfold eval_generic_body. apply (f_equal (fun v => eval_real p (unary_real o v :: _))). now apply H. - generalize (find_expr_correct e1 (length vars) t lc). destruct find_expr as [n1|] ; try easy. intros H1. generalize (find_expr_correct e2 (length vars) t lc). destruct find_expr as [n2|] ; try easy. intros H2. specialize (IH (Binary o n1 n2 :: p)). destruct decompose ; try easy. rewrite IH. simpl. unfold eval_generic_body. apply (f_equal2 (fun v1 v2 => eval_real p (binary_real o v1 v2 :: _))). now apply H. now apply H. Qed. Fixpoint max_arity (e : expr) (n : nat) := match e with | Evar k => Nat.ltb k n | Econst _ => true | Eunary o e1 => max_arity e1 n | Ebinary o e1 e2 => if max_arity e1 n then max_arity e2 n else false end. Lemma max_arity_correct : forall e vars v, max_arity e (length vars) = true -> eval e (vars ++ v) = eval e vars. Proof. induction e as [n|o|o e IH|o e1 IH1 e2 IH2] ; simpl ; intros vars v H. - apply app_nth1. now apply Nat.ltb_lt. - easy. - now rewrite IH. - rewrite <- Bool.andb_lazy_alt in H. apply andb_prop in H. rewrite IH1 by easy. now rewrite IH2. Qed. Inductive extracted_expr : Set := | Eabort | Eprog (lp : list term) (lc : list expr). Fixpoint fold_split (le lp lc : list expr) := match le with | nil => (lp, lc) | e :: le => let (lp, lc) := fold_split le lp lc in match split_expr e lp lc with | Sconst => (lp, (rcons_unique e lc)) | Scomposed lp lc => (lp, lc) end end. Fixpoint max_arity_list (le : list expr) (vars : nat) := match le with | nil => true | e :: le => andb (max_arity e vars) (max_arity_list le vars) end. Lemma max_arity_nth : forall le vars k d, max_arity_list le vars = true -> k < length le -> max_arity (nth k le d) vars = true. Proof. induction le ; try easy. intros vars k d H Hk. simpl in H. apply andb_prop in H. destruct H as [Ha Hle]. destruct k as [|k] ; try easy. apply IHle with (1 := Hle). now simpl in Hk; rewrite <-Nat.succ_lt_mono in Hk. Qed. Definition extract_list (le : list expr) (vars : nat) := if max_arity_list le vars then let (lp, lc) := fold_split le nil nil in let lp' := le ++ lp in match decompose vars nil lp' lc with | Some p => Eprog p lc | None => Eabort end else Eabort. Definition eval_real_nth k prog vars consts := nth k (eval_real prog (vars ++ map (fun c => eval c nil) consts)) 0%R. Theorem extract_list_correct : forall le vars, match extract_list le (length vars) with | Eabort => True | Eprog lp lc => forall k, k < length le -> eval_real_nth k lp vars lc = eval (nth k le (Econst (Int 0))) vars end. Proof. intros le vars. unfold extract_list. destruct max_arity_list eqn:Ha ; [ |exact I]. destruct fold_split as (lp, lc) eqn:Hf. generalize (decompose_correct vars nil (le ++ lp) lc). destruct decompose as [lp'|] ; [ |easy]. assert ((forall (vars0 : list R) (n : nat), eval (nth n lc (Econst (Int 0))) vars0 = eval (nth n lc (Econst (Int 0))) nil) /\ forall k : nat, k < length le -> nth k (eval_real nil (map (fun c : expr => eval c (vars ++ map (fun c0 : expr => eval c0 nil) lc)) (le ++ lp) ++ vars ++ map (fun c : expr => eval c nil) lc)) 0%R = eval (nth k le (Econst (Int 0))) vars) as [H1 H2]. 2: { intros H. apply H in H1. unfold eval_real_nth. now rewrite H1. } revert lp lc Hf lp'. induction le ; intros lp lc. { intros [= <- <-]. split ; [ |easy]. now intros vars0 [|n]. } simpl fold_split. simpl in Ha. apply andb_prop in Ha. destruct Ha as [Ha1 Ha2]. destruct fold_split as (lp0, lc0) eqn:Hf'. intros Hf lp'. destruct (IHle Ha2 lp0 lc0 eq_refl lp') as [IH1 _]. clear IHle. generalize (fun v => split_expr_correct (Econst (Int 0)) v nil a lp0 lc0). intros Hs. destruct split_expr as [|lp1 lc1] ; injection Hf as <- <- ; split. - intros vars0 n. apply eval_nth_rcons_unique. now apply Hs. easy. - intros [|k] Hk ; simpl. { now apply max_arity_correct. } destruct (rcons_unique_correct a lc0) as [l' ->]. simpl in Hk. rewrite <-Nat.succ_lt_mono in Hk. rewrite app_nth1. 2: { rewrite map_length, app_length. lia. } rewrite map_nth with (d := Econst (Int 0)). rewrite app_nth1 by easy. apply max_arity_correct. now apply max_arity_nth. - intros vars0. now apply Hs. - intros [|k] Hk ; simpl. { now apply max_arity_correct. } simpl in Hk. rewrite <-Nat.succ_lt_mono in Hk. rewrite app_nth1. 2: { rewrite map_length, app_length. lia. } rewrite map_nth with (d := Econst (Int 0)). rewrite app_nth1 by easy. apply max_arity_correct. now apply max_arity_nth. Qed. Definition extract e vars := extract_list (e :: nil) vars. Definition eval_real' prog vars consts := nth O (eval_real prog (vars ++ map (fun c => eval c nil) consts)) 0%R. Theorem extract_correct : forall e vars, match extract e (length vars) with | Eabort => True | Eprog lp lc => eval_real' lp vars lc = eval e vars end. Proof. intros e vars. change (eval e vars) with (eval (nth O (e :: nil) (Econst (Int 0))) vars). unfold eval_real', extract. generalize (extract_list_correct (e :: nil) vars). destruct extract_list; [easy | ]. intros H. now specialize (H O (Nat.lt_0_succ _)). Qed. interval-4.11.1/src/Eval/Reify.v000066400000000000000000000353701470547631300163670ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2019, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Psatz. From Flocq Require Import Raux. From Coq Require Import List. Require Import Xreal. Require Import Interval. Require Import Tree. Require Import Prog. Inductive hyp : Set := | Hle (b l : bool) (v : expr) | Hge (b l : bool) (u : expr) | Hlele (l1 l2 : bool) (u v : expr) | Habsle (b l : bool) (v : expr). Definition eval_hyp (h : hyp) (var : R) := match h with | Hle true true v => (var <= eval v nil)%R | Hle true false v => (var < eval v nil)%R | Hle false true v => (eval v nil >= var)%R | Hle false false v => (eval v nil > var)%R | Hge true true u => (eval u nil <= var)%R | Hge true false u => (eval u nil < var)%R | Hge false true u => (var >= eval u nil)%R | Hge false false u => (var > eval u nil)%R | Hlele true true u v => (eval u nil <= var <= eval v nil)%R | Hlele true false u v => (eval u nil <= var < eval v nil)%R | Hlele false true u v => (eval u nil < var <= eval v nil)%R | Hlele false false u v => (eval u nil < var < eval v nil)%R | Habsle true true v => (Rabs var <= eval v nil)%R | Habsle true false v => (Rabs var < eval v nil)%R | Habsle false true v => (eval v nil >= Rabs var)%R | Habsle false false v => (eval v nil > Rabs var)%R end. Fixpoint eval_hyps_aux (hyps : list hyp) (var : R) (g : Prop) := match hyps with | hh :: th => eval_hyp hh var -> eval_hyps_aux th var g | nil => g end. Fixpoint eval_hyps (hyps : list (list hyp)) (vars : list R) (g : Prop) := match hyps, vars with | hh :: th, hv :: tv => eval_hyps_aux hh hv (eval_hyps th tv g) | nil, nil => g | _, _ => True end. Inductive gol : Set := | Gle (b : bool) (v : expr) | Gge (b : bool) (u : expr) | Glele (u v : expr) | Gltle (u v : expr) | Glelt (u v : expr) | Gltlt (u v : expr) | Gabsle (b : bool) (v : expr) | Glt (v : expr) | Ggt (u : expr) | Gne (b : bool) (u : expr). Definition eval_goal (g : gol) (x : R) := match g with | Gle true v => (x <= eval v nil)%R | Gle false v => (eval v nil >= x)%R | Gge true u => (eval u nil <= x)%R | Gge false u => (x >= eval u nil)%R | Glele u v => (eval u nil <= x <= eval v nil)%R | Gltle u v => (eval u nil < x <= eval v nil)%R | Glelt u v => (eval u nil <= x < eval v nil)%R | Gltlt u v => (eval u nil < x < eval v nil)%R | Gabsle true v => (Rabs x <= eval v nil)%R | Gabsle false v => (eval v nil >= Rabs x)%R | Glt v => (x < eval v nil)%R | Ggt u => (eval u nil < x)%R | Gne true u => (x <> eval u nil) | Gne false u => (eval u nil <> x) end. Ltac massage_goal := let aux a x t := let a := reify a (@nil R) in (change (eval_goal (t a) x)) in match goal with | |- (Rabs ?x <= ?v)%R => aux v x (Gabsle true) | |- (?u <= ?x)%R => aux u x (Gge true) | |- (?x <= ?v)%R => aux v x (Gle true) | |- (?x >= ?u)%R => aux u x (Gge false) | |- (?v >= ?x)%R => aux v x (Gle false) | |- (?u <= ?x <= ?v)%R => let u := reify u (@nil R) in aux v x (Glele u) | |- (?u < ?x <= ?v)%R => let u := reify u (@nil R) in aux v x (Gltle u) | |- (?u <= ?x < ?v)%R => let u := reify u (@nil R) in aux v x (Glelt u) | |- (?u < ?x < ?v)%R => let u := reify u (@nil R) in aux v x (Gltlt u) | |- (?u < ?x)%R => aux u x Ggt | |- (?x > ?u)%R => aux u x Ggt | |- (?x < ?v)%R => aux v x Glt | |- (?v > ?x)%R => aux v x Glt | |- (?x <> ?u :>R) => aux u x (Gne true) | |- (?u <> ?x :>R) => aux u x (Gne false) | _ => fail "Goal is not an inequality with constant bounds" end. Ltac find_hyps_aux x known cont := let aux H u t := let u := reify u (@nil R) in let k := constr:(cons (t u) known) in revert H ; find_hyps_aux x k cont in match goal with | H : (?u <= x <= ?v)%R |- _ => let u := reify u (@nil R) in aux H v (Hlele true true u) | H : (?u <= x < ?v)%R |- _ => let u := reify u (@nil R) in aux H v (Hlele true false u) | H : (?u < x <= ?v)%R |- _ => let u := reify u (@nil R) in aux H v (Hlele false true u) | H : (?u < x < ?v)%R |- _ => let u := reify u (@nil R) in aux H v (Hlele false false u) | H : (?u <= x)%R |- _ => aux H u (Hge true true) | H : (x >= ?u)%R |- _ => aux H u (Hge false true) | H : (x <= ?v)%R |- _ => aux H v (Hle true true) | H : (?v >= x)%R |- _ => aux H v (Hle false true) | H : (Rabs x <= ?v)%R |- _ => aux H v (Habsle true true) | H : (?v >= Rabs x)%R |- _ => aux H v (Habsle false true) | H : (?u < x)%R |- _ => aux H u (Hge true false) | H : (x > ?u)%R |- _ => aux H u (Hge false false) | H : (x < ?v)%R |- _ => aux H v (Hle true false) | H : (?v > x)%R |- _ => aux H v (Hle false false) | H : (Rabs x < ?v)%R |- _ => aux H v (Habsle true false) | H : (?v > Rabs x)%R |- _ => aux H v (Habsle false false) | _ => cont known end. Ltac find_hyps_aux2 vars cont := match vars with | ?h :: ?t => let cont' k := let cont'' k' := let k'' := constr:(cons k' k) in cont k'' in let k' := constr:(@nil hyp) in find_hyps_aux h k' cont'' in find_hyps_aux2 t cont' | nil => let k := constr:(@nil (list hyp)) in cont k end. Ltac find_hyps vars := match goal with | |- ?g => let cont k := change (eval_hyps k vars g) ; clear in find_hyps_aux2 vars cont end ; match goal with | |- eval_hyps ?hyps' _ _ => let hyps := fresh "__hyps" in set (hyps := hyps') end. Ltac reify_partial y vars := let expr' := reify y vars in let expr := fresh "__expr" in set (expr := expr') ; let decomp := eval lazy in (extract expr (length vars)) in match decomp with | Eprog ?prog' ?consts' => let prog := fresh "__prog" in set (prog := prog') ; let consts := fresh "__consts" in set (consts := consts') ; generalize (extract_correct expr vars) ; match goal with | |- _ -> ?G => change (eval_real' prog vars consts = y -> G) end end. Ltac reify_full vars0 := match goal with | |- eval_goal ?g' ?y => let vars := get_vars y vars0 in let g := fresh "__goal" in set (g := g') ; reify_partial y vars ; apply eq_ind ; find_hyps vars end. Module Bnd (I : IntervalOps). Module E := Tree.Bnd I. Module J := IntervalExt I. Definition eval_hyp_bnd (prec : I.precision) (h : hyp) := match h with | Hlele _ _ u v => I.join (E.eval_bnd prec u) (E.eval_bnd prec v) | Hle _ _ v => I.lower_extent (E.eval_bnd prec v) | Hge _ _ u => I.upper_extent (E.eval_bnd prec u) | Habsle _ _ v => let vi := I.lower_extent (E.eval_bnd prec v) in I.meet (I.neg vi) vi end. Theorem eval_hyp_bnd_correct : forall prec h var, eval_hyp h var -> contains (I.convert (eval_hyp_bnd prec h)) (Xreal var). Proof. intros prec h var. destruct h as [b l v|b l u|l1 l2 u v|b l v] ; intros H. - apply I.lower_extent_correct with (eval v nil). apply E.eval_bnd_correct. destruct l ; [|apply Rlt_le] ; destruct b ; [|apply Rge_le| |] ; apply H. - apply I.upper_extent_correct with (eval u nil). apply E.eval_bnd_correct. destruct l ; [|apply Rlt_le] ; destruct b ; [|apply Rge_le| |] ; apply H. - apply J.join_correct with (eval u nil) (eval v nil). apply E.eval_bnd_correct. apply E.eval_bnd_correct. destruct l1, l2 ; split ; try apply H ; apply Rlt_le, H. - assert (H': (- eval v nil <= var <= eval v nil)%R). apply Rabs_le_inv. destruct l ; [|apply Rlt_le] ; destruct b ; [|apply Rge_le| |] ; apply H. apply I.meet_correct. rewrite <- (Ropp_involutive var). apply J.neg_correct. apply I.lower_extent_correct with (eval v nil). apply E.eval_bnd_correct. lra. apply I.lower_extent_correct with (eval v nil). apply E.eval_bnd_correct. apply H'. Qed. Fixpoint merge_hyps_aux (prec : I.precision) (hyps : list hyp) (acc : I.type) := match hyps with | h :: t => merge_hyps_aux prec t (I.meet (eval_hyp_bnd prec h) acc) | nil => acc end. Fixpoint merge_hyps (prec : I.precision) (hyps : list (list hyp)) := match hyps with | h :: t => cons (merge_hyps_aux prec h I.whole) (merge_hyps prec t) | nil => nil end. Fixpoint eval_hyps_bnd (hyps : list I.type) (vars : list R) := match hyps, vars with | hh :: th, hv :: tv => contains (I.convert hh) (Xreal hv) /\ eval_hyps_bnd th tv | nil, nil => True | _, _ => False end. Theorem eval_hyps_bnd_correct : forall prec hyps vars (g : Prop), (eval_hyps_bnd (merge_hyps prec hyps) vars -> g) -> eval_hyps hyps vars g. Proof. intros prec. induction hyps as [|h1 t1 IH1]. intros [|x vars] g H. now apply H. exact I. intros [|x vars]. easy. simpl. generalize I.whole (I.whole_correct x). induction h1 as [|h2 t2 IH2] ; intros xi Ix g H. apply IH1. intros H'. now apply H. simpl. intros H'. simpl in H. apply (IH2 (I.meet (eval_hyp_bnd prec h2) xi)). apply I.meet_correct with (2 := Ix). now apply eval_hyp_bnd_correct. intros H''. now apply H. Qed. Definition eval_goal_bnd (prec : I.precision) (g : gol) : I.type -> bool := let check := match g with | Gle _ v => let j := I.lower_complement (E.eval_bnd prec v) in fun i => I.subset i j | Gge _ u => let j := I.upper_complement (E.eval_bnd prec u) in fun i => I.subset i j | Glele u v => let u := I.upper_complement (E.eval_bnd prec u) in let v := I.lower_complement (E.eval_bnd prec v) in let j := I.meet u v in fun i => I.subset i j | Gltle u v => let u := E.eval_bnd prec u in let v := I.lower_complement (E.eval_bnd prec v) in fun i => match I.sign_strict (I.sub prec i u) with Xgt => I.subset i v | _ => false end | Glelt u v => let u := I.upper_complement (E.eval_bnd prec u) in let v := E.eval_bnd prec v in fun i => match I.sign_strict (I.sub prec i v) with Xlt => I.subset i u | _ => false end | Gltlt u v => let u := E.eval_bnd prec u in let v := E.eval_bnd prec v in fun i => match I.sign_strict (I.sub prec i u) with Xgt => match I.sign_strict (I.sub prec i v) with Xlt => true | _ => false end | _ => false end | Gabsle _ v => let v := I.lower_complement (E.eval_bnd prec v) in let j := I.meet (I.neg v) v in fun i => I.subset i j | Glt v => let j := E.eval_bnd prec v in fun i => match I.sign_strict (I.sub prec i j) with Xlt => true | _ => false end | Ggt u => let j := E.eval_bnd prec u in fun i => match I.sign_strict (I.sub prec i j) with Xgt => true | _ => false end | Gne _ v => let j := E.eval_bnd prec v in fun i => match I.sign_strict (I.sub prec i j) with Xlt => true | Xgt => true | _ => false end end in fun xi => if I.is_empty xi then true else check xi. Theorem eval_goal_bnd_correct : forall prec g xi x, contains (I.convert xi) (Xreal x) -> eval_goal_bnd prec g xi = true -> eval_goal g x. Proof. intros prec g xi x Ix. unfold eval_goal_bnd. destruct (I.is_empty xi) eqn:Ex. { now elim I.is_empty_correct with (1 := Ix). } clear Ex. destruct g as [b v|b u|u v|u v|u v|u v|b v|v|u|b u] ; simpl ; intros H. - cut (x <= eval v nil)%R. now destruct b ; [|apply Rle_ge]. assert (H' := I.subset_correct _ _ _ Ix H). apply I.lower_complement_correct with (2 := H'). apply E.eval_bnd_correct. - cut (eval u nil <= x)%R. now destruct b ; [|apply Rle_ge]. assert (H' := I.subset_correct _ _ _ Ix H). apply I.upper_complement_correct with (2 := H'). apply E.eval_bnd_correct. - assert (H' := I.subset_correct _ _ _ Ix H). apply I.meet_correct' in H'. split. apply I.upper_complement_correct with (2 := proj1 H'). apply E.eval_bnd_correct. apply I.lower_complement_correct with (2 := proj2 H'). apply E.eval_bnd_correct. - generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec u))). destruct I.sign_strict ; try easy. intros Hd. split. apply Rminus_gt. apply (Hd (Xreal (x - eval u nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. assert (H' := I.subset_correct _ _ _ Ix H). apply I.lower_complement_correct with (2 := H'). apply E.eval_bnd_correct. - generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec v))). destruct I.sign_strict ; try easy. intros Hd. split. assert (H' := I.subset_correct _ _ _ Ix H). apply I.upper_complement_correct with (2 := H'). apply E.eval_bnd_correct. apply Rminus_lt. apply (Hd (Xreal (x - eval v nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. - generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec u))). destruct I.sign_strict ; try easy. intros Hd. generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec v))). destruct I.sign_strict ; try easy. intros He. split. apply Rminus_gt. apply (Hd (Xreal (x - eval u nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. apply Rminus_lt. apply (He (Xreal (x - eval v nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. - cut (Rabs x <= eval v nil)%R. now destruct b ; [|apply Rle_ge]. assert (H' := I.subset_correct _ _ _ Ix H). apply I.meet_correct' in H'. apply Rabs_le. destruct H' as [H1 H2]. split. rewrite <- (Ropp_involutive x) in H1 |- *. apply Ropp_le_contravar. apply (I.neg_correct' _ (Xreal (-x))) in H1. apply I.lower_complement_correct with (2 := H1). apply E.eval_bnd_correct. apply I.lower_complement_correct with (2 := H2). apply E.eval_bnd_correct. - apply Rminus_lt. generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec v))). destruct I.sign_strict ; try easy. intros Hd. apply (Hd (Xreal (x - eval v nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. - apply Rminus_gt. generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec u))). destruct I.sign_strict ; try easy. intros Hd. apply (Hd (Xreal (x - eval u nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. - cut (x - eval u nil <> 0)%R. destruct b ; lra. generalize (I.sign_strict_correct (I.sub prec xi (E.eval_bnd prec u))). destruct I.sign_strict ; try easy ; intros Hd. apply Rlt_not_eq. apply (Hd (Xreal (x - eval u nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. apply Rgt_not_eq. apply (Hd (Xreal (x - eval u nil))). apply J.sub_correct with (1 := Ix). apply E.eval_bnd_correct. Qed. End Bnd. interval-4.11.1/src/Eval/Tree.v000066400000000000000000000325551470547631300162120ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2019, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List. Require Import Xreal. Require Import Basic. Require Import Interval. Inductive nullary_op : Set := | Int (n : Z) | Bpow (r n : Z) | Pi. Inductive unary_op : Set := | Neg | Abs | Inv | Sqr | Sqrt | Cos | Sin | Tan | Atan | Exp | Ln | PowerInt (n : Z) | Nearbyint (m : rounding_mode) | RoundFlt (m : rounding_mode) (emin : Z) (prec : positive) | ErrorFlt (m : rounding_mode) (emin : Z) (prec : positive) | RoundFix (m : rounding_mode) (emin : Z) | ErrorFix (m : rounding_mode) (emin : Z). Inductive binary_op : Set := | Add | Sub | Mul | Div. Inductive expr : Set := | Evar : nat -> expr | Econst : nullary_op -> expr | Eunary : unary_op -> expr -> expr | Ebinary : binary_op -> expr -> expr -> expr. Definition bpow' (r e : Z) := match e with | 0%Z => 1%R | Z.pos p => IZR (Z.pow_pos r p) | Z.neg p => (/ IZR (Z.pow_pos r p))%R end. Definition nullary_real (o : nullary_op) : R := match o with | Int n => IZR n | Bpow r n => bpow' r n | Pi => PI end. Definition unary_real (o : unary_op) : R -> R := match o with | Neg => Ropp | Abs => Rabs | Inv => Rinv | Sqr => Rsqr | Sqrt => sqrt | Cos => cos | Sin => sin | Tan => tan | Atan => atan | Exp => exp | Ln => ln | PowerInt n => fun x => powerRZ x n | Nearbyint m => Rnearbyint m | RoundFlt m emin prec => round_flt m emin prec | ErrorFlt m emin prec => fun x => Rminus (round_flt m emin prec x) x | RoundFix m emin => round_fix m emin | ErrorFix m emin => fun x => Rminus (round_fix m emin x) x end. Strategy 1000 [Generic_fmt.round]. Definition binary_real (o : binary_op) : R -> R -> R := match o with | Add => Rplus | Sub => Rminus | Mul => Rmult | Div => Rdiv end. Fixpoint eval (e : expr) (l : list R) := match e with | Evar n => nth n l 0%R | Econst o => nullary_real o | Eunary o e1 => unary_real o (eval e1 l) | Ebinary o e1 e2 => binary_real o (eval e1 l) (eval e2 l) end. Ltac is_nat_const n := match n with | S ?n => is_nat_const n | O => true | _ => false end. Ltac is_positive_const x := match x with | xO ?p => is_positive_const p | xI ?p => is_positive_const p | xH => true | _ => false end. Ltac is_Z_const x := lazymatch x with | Zpos ?p => is_positive_const p | Zneg ?p => is_positive_const p | Z0 => true | _ => false end. Ltac list_add a l := let rec aux l := match l with | nil => constr:(cons a l) | cons a _ => l | cons ?x ?l => let l := aux l in constr:(cons x l) end in aux l. Ltac list_find a l := let rec aux l n := match l with | cons a _ => n | cons _ ?l => aux l (S n) end in aux l O. Ltac hyp_on_var x := lazymatch goal with | H : (?u <= x <= ?v)%R |- _ => true | H : (?u <= x < ?v)%R |- _ => true | H : (?u < x <= ?v)%R |- _ => true | H : (?u < x < ?v)%R |- _ => true | H : (?u <= x)%R |- _ => true | H : (x >= ?u)%R |- _ => true | H : (x <= ?v)%R |- _ => true | H : (?v >= x)%R |- _ => true | H : (Rabs x <= ?v)%R |- _ => true | H : (?v >= Rabs x)%R |- _ => true | H : (?u < x)%R |- _ => true | H : (x > ?u)%R |- _ => true | H : (x < ?v)%R |- _ => true | H : (?v > x)%R |- _ => true | H : (Rabs x < ?v)%R |- _ => true | H : (?v > Rabs x)%R |- _ => true end. Ltac reify_round m := lazymatch m with | Round_NE.ZnearestE => rnd_NE | Raux.Ztrunc => rnd_ZR | Raux.Zfloor => rnd_DN | Raux.Zceil => rnd_UP end. Ltac unfold_head t := let rec head t := lazymatch t with | Ropp _ => t | Rabs _ => t | Rinv _ => t | Rsqr _ => t | sqrt _ => t | cos _ => t | sin _ => t | tan _ => t | atan _ => t | exp _ => t | ln _ => t | powerRZ _ _ => t | pow _ _ => t | Rplus _ _ => t | Rminus _ _ => t | Rmult _ _ => t | Rdiv _ _ => t | Rpower _ _ => t | Rnearbyint _ _ => t | Generic_fmt.round _ _ _ _ => t | IZR _ => t | Raux.bpow _ _ => t | ?f _ => head f | _ => t end in let h := head t in eval unfold h in t. Ltac get_vars t l := let rec aux t l top := let aux_u a := aux a l top in let aux_b a b := let l := aux a l top in aux b l top in match True with | True => lazymatch t with | Ropp ?a => aux_u a | Rabs ?a => aux_u a | Rinv ?a => aux_u a | Rsqr ?a => aux_u a | Rmult ?a ?a => aux_u a | sqrt ?a => aux_u a | cos ?a => aux_u a | sin ?a => aux_u a | tan ?a => aux_u a | atan ?a => aux_u a | exp ?a => aux_u a | ln ?a => aux_u a | powerRZ ?a ?b => let b := eval lazy in b in lazymatch is_Z_const b with true => aux_u a end | pow ?a ?b => let b := eval lazy in b in lazymatch is_nat_const b with true => aux_u a end | Rplus ?a ?b => aux_b a b | Rminus ?a ?b => aux_b a b | Rmult ?a ?b => aux_b a b | Rdiv ?a ?b => aux_b a b | @Defs.F2R ?r ?f => let r := eval lazy in (Zaux.radix_val r) in let m := eval lazy in (@Defs.Fnum r f) in let e := eval lazy in (@Defs.Fexp r f) in lazymatch is_Z_const r with true => lazymatch is_Z_const m with true => lazymatch is_Z_const e with true => l end end end | Rpower ?a ?b => aux_b a b | Rnearbyint ?a ?b => aux_u b | Generic_fmt.round Zaux.radix2 (FLT.FLT_exp ?emin ?prec) ?mode ?a => let mode := reify_round mode in let prec := eval lazy in prec in let emin := eval lazy in emin in lazymatch is_Z_const prec with true => lazymatch is_Z_const emin with true => lazymatch prec with Z.pos ?p => aux_u a end end end | Generic_fmt.round Zaux.radix2 (FIX.FIX_exp ?emin) ?mode ?a => let mode := reify_round mode in let emin := eval lazy in emin in lazymatch is_Z_const emin with true => aux_u a end | IZR (Raux.Ztrunc ?a) => aux_u a | IZR (Raux.Zfloor ?a) => aux_u a | IZR (Raux.Zceil ?a) => aux_u a | IZR (Round_NE.ZnearestE ?a) => aux_u a | PI => l | Raux.bpow ?r ?n => let r := eval lazy in (Zaux.radix_val r) in let n := eval lazy in n in lazymatch is_Z_const r with true => lazymatch is_Z_const n with true => l end end | IZR ?n => let n := eval lazy in n in lazymatch is_Z_const n with true => l end end | _ => let v := hyp_on_var t in list_add t l | _ => let t' := unfold_head t in aux t' l false | _ => lazymatch t with | _ _ => lazymatch top with | true => list_add t l end | _ => list_add t l end end in aux t l true. Ltac reify t l := let rec aux t := let aux_u o a := let u := aux a in constr:(Eunary o u) in let aux_b o a b := let u := aux a in let v := aux b in constr:(Ebinary o u v) in match True with | True => let n := list_find t l in constr:(Evar n) | True => lazymatch t with | Ropp ?a => aux_u Neg a | Rabs ?a => aux_u Abs a | Rinv ?a => aux_u Inv a | Rsqr ?a => aux_u Sqr a | Rmult ?a ?a => aux_u Sqr a | sqrt ?a => aux_u Sqrt a | cos ?a => aux_u Cos a | sin ?a => aux_u Sin a | tan ?a => aux_u Tan a | atan ?a => aux_u Atan a | exp ?a => aux_u Exp a | ln ?a => aux_u Ln a | powerRZ ?a ?b => let b := eval lazy in b in lazymatch is_Z_const b with true => aux_u (PowerInt b) a end | pow ?a ?b => let b := eval lazy in (Z_of_nat b) in lazymatch is_Z_const b with true => aux_u (PowerInt b) a end | Rplus ?a (Ropp ?b) => aux (Rminus a b) | Rplus ?a ?b => aux_b Add a b | Rminus ?a ?b => let u := aux a in let v := aux b in match u with | Eunary (RoundFlt ?m ?e ?p) v => constr:(Eunary (ErrorFlt m e p) v) | Eunary (RoundFix ?m ?e) v => constr:(Eunary (ErrorFix m e) v) | _ => constr:(Ebinary Sub u v) end | Rmult ?a (Rinv ?b) => aux_b Div a b | @Defs.F2R ?r ?f => let r := eval lazy in (Zaux.radix_val r) in let m := eval lazy in (@Defs.Fnum r f) in let e := eval lazy in (@Defs.Fexp r f) in lazymatch is_Z_const r with true => lazymatch is_Z_const m with true => lazymatch is_Z_const e with true => constr:(Ebinary Mul (Econst (Int m)) (Econst (Bpow r e))) end end end | Q2R (QArith_base.Qmake ?a ?b) => aux_b Div constr:(IZR a) constr:(IZR (Zpos b)) | Rmult ?a ?b => aux_b Mul a b | Rdiv ?a ?b => aux_b Div a b | Rpower ?a ?b => aux (exp (b * ln a)) | Rnearbyint ?a ?b => aux_u (Nearbyint a) b | Generic_fmt.round Zaux.radix2 (FLT.FLT_exp ?emin ?prec) ?mode ?a => let mode := reify_round mode in let prec := eval lazy in prec in let emin := eval lazy in emin in lazymatch is_Z_const prec with true => lazymatch is_Z_const emin with true => lazymatch prec with Z.pos ?p => aux_u (RoundFlt mode emin p) a end end end | Generic_fmt.round Zaux.radix2 (FIX.FIX_exp ?emin) ?mode ?a => let mode := reify_round mode in let emin := eval lazy in emin in lazymatch is_Z_const emin with true => aux_u (RoundFix mode emin) a end | IZR (Raux.Ztrunc ?a) => aux_u (Nearbyint rnd_ZR) a | IZR (Raux.Zfloor ?a) => aux_u (Nearbyint rnd_DN) a | IZR (Raux.Zceil ?a) => aux_u (Nearbyint rnd_UP) a | IZR (Round_NE.ZnearestE ?a) => aux_u (Nearbyint rnd_NE) a | PI => constr:(Econst Pi) | Raux.bpow ?r ?n => let r := eval lazy in (Zaux.radix_val r) in let n := eval lazy in n in lazymatch is_Z_const r with true => lazymatch is_Z_const n with true => constr:(Econst (Bpow r n)) end end | IZR ?n => let n := eval lazy in n in match is_Z_const n with true => constr:(Econst (Int n)) end end | _ => let t' := unfold_head t in aux t' end in aux t. Module Bnd (I : IntervalOps). Module J := IntervalExt I. Definition nullary_bnd prec (o : nullary_op) : I.type := match o with | Int n => I.fromZ prec n | Bpow r n => I.power_int prec (I.fromZ prec r) n | Pi => I.pi prec end. Lemma nullary_bnd_correct : forall prec o, contains (I.convert (nullary_bnd prec o)) (Xreal (nullary_real o)). Proof. intros prec [n|r n|]. - apply I.fromZ_correct. - simpl. replace (bpow' r n) with (powerRZ (IZR r) n). apply J.power_int_correct. apply I.fromZ_correct. destruct n as [|n|n] ; simpl ; try rewrite Zpower_pos_powerRZ ; easy. - apply I.pi_correct. Qed. Definition unary_bnd prec (o : unary_op) : I.type -> I.type := match o with | Neg => I.neg | Abs => I.abs | Inv => I.inv prec | Sqr => I.sqr prec | Sqrt => I.sqrt prec | Cos => I.cos prec | Sin => I.sin prec | Tan => I.tan prec | Atan => I.atan prec | Exp => I.exp prec | Ln => I.ln prec | PowerInt n => fun x => I.power_int prec x n | Nearbyint m => I.nearbyint m | RoundFlt m emin p => J.round_flt prec m emin p | ErrorFlt m emin p => I.error_flt prec m emin p | RoundFix m emin => J.round_fix prec m emin | ErrorFix m emin => I.error_fix prec m emin end. Lemma unary_bnd_correct : forall prec o xi x, contains (I.convert xi) (Xreal x) -> contains (I.convert (unary_bnd prec o xi)) (Xreal (unary_real o x)). Proof. intros prec o xi x. destruct o. apply I.neg_correct. apply I.abs_correct. apply J.inv_correct. apply I.sqr_correct. apply J.sqrt_correct. apply I.cos_correct. apply I.sin_correct. apply J.tan_correct. apply I.atan_correct. apply I.exp_correct. apply J.ln_correct. apply J.power_int_correct. apply I.nearbyint_correct. apply J.round_flt_correct. apply I.error_flt_correct. apply J.round_fix_correct. apply I.error_fix_correct. Qed. Definition binary_bnd prec (o : binary_op) : I.type -> I.type -> I.type := match o with | Add => I.add prec | Sub => I.sub prec | Mul => I.mul prec | Div => I.div prec end. Lemma binary_bnd_correct : forall prec o xi yi x y, contains (I.convert xi) (Xreal x) -> contains (I.convert yi) (Xreal y) -> contains (I.convert (binary_bnd prec o xi yi)) (Xreal (binary_real o x y)). Proof. intros prec o xi yi x y. destruct o. apply I.add_correct. apply I.sub_correct. apply I.mul_correct. apply J.div_correct. Qed. Fixpoint eval_bnd (prec : I.precision) (e : expr) := match e with | Evar _ => I.nai | Econst o => nullary_bnd prec o | Eunary o e1 => unary_bnd prec o (eval_bnd prec e1) | Ebinary o e1 e2 => binary_bnd prec o (eval_bnd prec e1) (eval_bnd prec e2) end. Theorem eval_bnd_correct : forall prec e, contains (I.convert (eval_bnd prec e)) (Xreal (eval e nil)). Proof. intros prec. induction e as [n|o|o e1 IHe1|o e1 IHe1 e2 IHe2]. - apply contains_Inan, I.nai_correct. - apply nullary_bnd_correct. - now apply unary_bnd_correct. - now apply binary_bnd_correct. Qed. End Bnd. interval-4.11.1/src/Float/000077500000000000000000000000001470547631300152705ustar00rootroot00000000000000interval-4.11.1/src/Float/Basic.v000066400000000000000000000144561470547631300165120ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals ZArith Psatz. From Flocq Require Import Core. Require Import Xreal. Variant rounding_mode : Set := rnd_UP | rnd_DN | rnd_ZR | rnd_NE. Definition Rnearbyint mode r := match mode with | rnd_UP => IZR (Zceil r) | rnd_DN => IZR (Zfloor r) | rnd_ZR => IZR (Ztrunc r) | rnd_NE => IZR (ZnearestE r) end. Notation Xnearbyint := (fun mode => Xlift (Rnearbyint mode)). Lemma Rnearbyint_le : forall mode x y, (x <= y)%R -> (Rnearbyint mode x <= Rnearbyint mode y)%R. Proof. intros mode x y Hxy. destruct mode ; simpl. now apply IZR_le, Zceil_le. now apply IZR_le, Zfloor_le. now apply IZR_le, Ztrunc_le. now apply IZR_le; destruct (valid_rnd_N (fun x => negb (Z.even x))); auto. Qed. Lemma Rnearbyint_error_DN x : (-1 <= Rnearbyint rnd_DN x - x <= 0)%R. Proof. assert (H := (Zfloor_ub x, Zfloor_lb x)). case H; simpl; lra. Qed. Lemma Rnearbyint_error_UP x : (0 <= Rnearbyint rnd_UP x - x <= 1)%R. Proof. assert (H := (Zfloor_ub (- x), Zfloor_lb (- x))). simpl; unfold Zceil; rewrite opp_IZR. case H; simpl; lra. Qed. Lemma Rnearbyint_error_ZR_neg x : (x <= 0 -> 0 <= Rnearbyint rnd_ZR x - x <= 1)%R. Proof. simpl; unfold Ztrunc. case Rlt_bool_spec; try lra. intros; apply Rnearbyint_error_UP. intros H H0. assert (H1 : x = 0%R) by lra. assert (H2 := Zfloor_IZR 0); simpl in H2. rewrite H1, H2; simpl; lra. Qed. Lemma Rnearbyint_error_ZR_pos x : (0 <= x -> -1 <= Rnearbyint rnd_ZR x - x <= 0)%R. Proof. simpl; unfold Ztrunc. case Rlt_bool_spec; try lra. now intros; apply Rnearbyint_error_DN. Qed. Lemma Rnearbyint_error_ZR x : (-1 <= Rnearbyint rnd_ZR x - x <= 1)%R. Proof. assert (H := (Rnearbyint_error_ZR_neg x, Rnearbyint_error_ZR_pos x)). case H; simpl; lra. Qed. Lemma Rnearbyint_error_NE x : (- (1/2) <= Rnearbyint rnd_NE x - x <= 1/2)%R. Proof. simpl. assert (H := Znearest_half (fun x => negb (Z.even x)) x). split_Rabs; lra. Qed. Lemma Rnearbyint_error m x : (-1 <= Rnearbyint m x - x <= 1)%R. Proof. assert (H1 := Rnearbyint_error_DN x). assert (H2 := Rnearbyint_error_UP x). assert (H3 := Rnearbyint_error_ZR x). assert (H4 := Rnearbyint_error_NE x). case m; lra. Qed. Notation radix2 := Zaux.radix2 (only parsing). Section Definitions. Variable beta : radix. Fixpoint count_digits_aux nb pow (p q : positive) { struct q } : positive := if Zlt_bool (Zpos p) pow then nb else match q with | xH => nb | xI r => count_digits_aux (Pos.succ nb) (Zmult beta pow) p r | xO r => count_digits_aux (Pos.succ nb) (Zmult beta pow) p r end. Definition count_digits n := count_digits_aux 1 beta n n. Definition FtoR (s : bool) m e := let sm := if s then Zneg m else Zpos m in match e with | Zpos p => IZR (sm * Zpower_pos beta p) | Z0 => IZR sm | Zneg p => (IZR sm / IZR (Zpower_pos beta p))%R end. End Definitions. Definition rnd_of_mode mode := match mode with | rnd_UP => rndUP | rnd_DN => rndDN | rnd_ZR => rndZR | rnd_NE => rndNE end. Definition error_fix mode emin x := (round radix2 (FIX_exp emin) (rnd_of_mode mode) x - x)%R. Definition Xerror_fix mode emin := Xlift (error_fix mode emin). Definition round_fix mode emin := round radix2 (FIX_exp emin) (rnd_of_mode mode). Definition Xround_fix mode emin := Xlift (round_fix mode emin). Definition error_flt mode emin prec x := (round radix2 (FLT_exp emin (Zpos prec)) (rnd_of_mode mode) x - x)%R. Definition Xerror_flt mode emin prec := Xlift (error_flt mode emin prec). Definition round_flt mode emin prec := round radix2 (FLT_exp emin (Zpos prec)) (rnd_of_mode mode). Definition Xround_flt mode emin prec := Xlift (round_flt mode emin prec). Definition round beta mode prec := round beta (FLX_exp (Zpos prec)) (rnd_of_mode mode). Definition Xround beta mode prec := Xlift (round beta mode prec). Inductive float (beta : radix) : Set := | Fnan : float beta | Fzero : float beta | Float : bool -> positive -> Z -> float beta. Arguments Fnan {beta}. Arguments Fzero {beta}. Arguments Float {beta} _ _ _. Definition FtoX {beta} (f : float beta) := match f with | Fzero => Xreal 0 | Fnan => Xnan | Float s m e => Xreal (FtoR beta s m e) end. Lemma zpos_gt_0 : forall prec, Prec_gt_0 (Zpos prec). Proof. easy. Qed. Lemma valid_rnd_of_mode : forall mode, Valid_rnd (rnd_of_mode mode). Proof. destruct mode ; simpl ; auto with typeclass_instances. Qed. Lemma FtoR_split : forall beta s m e, FtoR beta s m e = F2R (Defs.Float beta (cond_Zopp s (Zpos m)) e). Proof. intros. unfold FtoR, F2R, cond_Zopp. simpl. case e. now rewrite Rmult_1_r. intros p. now rewrite mult_IZR. now intros p. Qed. Lemma is_zero_correct_float : forall beta s m e, is_zero (FtoR beta s m e) = false. Proof. intros beta s m e. rewrite FtoR_split. case is_zero_spec ; try easy. intros H. apply eq_0_F2R in H. now destruct s. Qed. Definition le_upper x y := match y with | Xnan => True | Xreal yr => match x with | Xnan => False | Xreal xr => Rle xr yr end end. Definition le_lower x y := le_upper (Xneg y) (Xneg x). Lemma le_upper_refl : forall x, le_upper x x. Proof. destruct x; [easy|apply Rle_refl]. Qed. Lemma le_lower_refl : forall x, le_upper x x. Proof. destruct x; [easy|apply Rle_refl]. Qed. Lemma le_upper_trans : forall x y z, le_upper x y -> le_upper y z -> le_upper x z. Proof. intros x y z. case z. split. intro zr. case y. intros _ H. elim H. intros yr. case x. intros H _. elim H. intros xr. simpl. apply Rle_trans. Qed. Lemma le_lower_trans : forall x y z, le_lower x y -> le_lower y z -> le_lower x z. Proof. unfold le_lower. intros. eapply le_upper_trans ; eassumption. Qed. interval-4.11.1/src/Float/Generic.v000066400000000000000000000422031470547631300170340ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Bool ZArith. From Flocq Require Import Zaux Raux Div Sqrt. Require Import Xreal. Require Import Basic. Inductive position : Set := pos_Eq | pos_Lo | pos_Mi | pos_Up. Inductive ufloat (beta : radix) : Set := | Unan : ufloat beta | Uzero : ufloat beta | Ufloat : bool -> positive -> Z -> position -> ufloat beta. Arguments Unan {beta}. Arguments Uzero {beta}. Arguments Ufloat {beta} _ _ _ _. (* * Fneg *) Definition Fneg {beta} (f : float beta) := match f with | Float s m e => Float (negb s) m e | _ => f end. (* * Fabs *) Definition Fabs {beta} (f : float beta) := match f with | Float s m e => Float false m e | _ => f end. (* * Fscale *) Definition Fscale {beta} (f : float beta) d := match f with | Float s m e => Float s m (e + d) | _ => f end. (* * Fscale2 *) Definition Fscale2 {beta} (f : float beta) d := match f with | Float s m e => match radix_val beta, d with | Zpos (xO xH), _ => Float s m (e + d) | _, Z0 => f | _, Zpos nb => Float s (iter_pos (fun x => xO x) nb m) e | Zpos (xO r), Zneg nb => Float s (iter_pos (fun x => Pmult r x) nb m) (e + d) | _, _ => Fnan end | _ => f end. (* * Fpow2 *) Definition Fpow2 {beta} d := Fscale2 (@Float beta false xH 0) d. (* * Fdiv2 *) Definition Fdiv2 {beta} (f : float beta) := Fscale2 f (-1). (* * Fcmp * * 1. Compare signs. * 2. Compare position of most significant digits. * 3. Compare shifted mantissas. *) Definition shift beta m nb := let r := match radix_val beta with Zpos r => r | _ => xH end in iter_pos (Pmult r) nb m. Definition Fcmp_aux1 m1 m2 := match Z.compare (Zpos m1) (Zpos m2) with | Eq => Xeq | Lt => Xlt | Gt => Xgt end. Definition Fcmp_aux2 beta m1 e1 m2 e2 := let d1 := count_digits beta m1 in let d2 := count_digits beta m2 in match Z.compare (e1 + Zpos d1)%Z (e2 + Zpos d2)%Z with | Lt => Xlt | Gt => Xgt | Eq => match Zminus e1 e2 with | Zpos nb => Fcmp_aux1 (shift beta m1 nb) m2 | Zneg nb => Fcmp_aux1 m1 (shift beta m2 nb) | Z0 => Fcmp_aux1 m1 m2 end end. Definition Fcmp {beta} (f1 f2 : float beta) := match f1, f2 with | Fnan, _ => Xund | _, Fnan => Xund | Fzero, Fzero => Xeq | Fzero, Float false _ _ => Xlt | Fzero, Float true _ _ => Xgt | Float false _ _, Fzero => Xgt | Float true _ _, Fzero => Xlt | Float false _ _, Float true _ _ => Xgt | Float true _ _, Float false _ _ => Xlt | Float false m1 e1, Float false m2 e2 => Fcmp_aux2 beta m1 e1 m2 e2 | Float true m1 e1, Float true m2 e2 => Fcmp_aux2 beta m2 e2 m1 e1 end. (* * Fmin *) Definition Fmin {beta} (f1 f2 : float beta) := match Fcmp f1 f2 with | Xlt => f1 | Xeq => f1 | Xgt => f2 | Xund => Fnan end. (* * Fmax *) Definition Fmax {beta} (f1 f2 : float beta) := match Fcmp f1 f2 with | Xlt => f2 | Xeq => f2 | Xgt => f1 | Xund => Fnan end. Definition UtoX {beta} (f : ufloat beta) := match f with | Uzero => Xreal R0 | Ufloat s m e pos_Eq => Xreal (FtoR beta s m e) | _ => Xnan end. Definition convert_location l := match l with | Bracket.loc_Exact => pos_Eq | Bracket.loc_Inexact l => match l with Lt => pos_Lo | Eq => pos_Mi | Gt => pos_Up end end. Definition float_to_ufloat {beta} (x : float beta) : ufloat beta := match x with | Fnan => Unan | Fzero => Uzero | Float s m e => Ufloat s m e pos_Eq end. Definition adjust_pos r d pos := match r with | Z0 => match pos with | pos_Eq => pos_Eq | _ => match d with xH => pos | _ => pos_Lo end end | Zneg _ => pos_Eq (* dummy *) | Zpos _ => let (hd, mid) := match d with | xO p => (p, match pos with pos_Eq => pos_Mi | _ => pos_Up end) | xI p => (p, match pos with pos_Eq => pos_Lo | _ => pos end) | xH => (xH, pos_Eq) (* dummy *) end in match Z.compare r (Zpos hd) with | Lt => pos_Lo | Eq => mid | Gt => pos_Up end end. (* * Fround_none *) Definition Fround_none {beta} (uf : ufloat beta) : float beta := match uf with | Uzero => Fzero | Ufloat s m e pos_Eq => Float s m e | _ => Fnan end. (* * Fround_at_prec * * Assume that the position is at exponent ex and that it is pos_Eq if mx is too short. *) Definition need_change mode even_m pos sign := match mode with | rnd_ZR => false | rnd_UP => match pos with pos_Eq => false | _ => negb sign end | rnd_DN => match pos with pos_Eq => false | _ => sign end | rnd_NE => match pos with | pos_Up => true | pos_Mi => negb even_m | _ => false end end. Definition need_change_radix even_r mode (even_m : bool) pos sign := match mode with | rnd_ZR => false | rnd_UP => match pos with pos_Eq => false | _ => negb sign end | rnd_DN => match pos with pos_Eq => false | _ => sign end | rnd_NE => match pos with | pos_Up => true | pos_Mi => if even_m then false else negb even_r | _ => false end end. Definition adjust_mantissa mode m pos sign := if need_change mode (match m with xO _ => true | _ => false end) pos sign then Pos.succ m else m. Definition Fround_at_prec {beta} mode prec (uf : ufloat beta) : float beta := match uf with | Unan => Fnan | Uzero => Fzero | Ufloat sign m1 e1 pos => match (Zpos (count_digits beta m1) - Zpos prec)%Z with | Zpos nb => let d := shift beta xH nb in match Z.div_eucl (Zpos m1) (Zpos d) with | (Zpos m2, r) => let pos2 := adjust_pos r d pos in let e2 := (e1 + Zpos nb)%Z in Float sign (adjust_mantissa mode m2 pos2 sign) e2 | _ => Fnan (* dummy *) end | Z0 => Float sign (adjust_mantissa mode m1 pos sign) e1 | _ => Float sign m1 e1 end end. (* * Fround_at_exp *) Definition need_change_zero mode pos sign := match mode with | rnd_ZR => false | rnd_UP => match pos with pos_Eq => false | _ => negb sign end | rnd_DN => match pos with pos_Eq => false | _ => sign end | rnd_NE => match pos with | pos_Up => true | _ => false end end. Definition Fround_at_exp {beta} mode e2 (uf : ufloat beta) : float beta := match uf with | Unan => Fnan | Uzero => Fzero | Ufloat sign m1 e1 pos => match (e2 - e1)%Z with | Zpos nb => match Z.compare (Zpos (count_digits beta m1)) (Zpos nb) with | Gt => let d := shift beta xH nb in match Z.div_eucl (Zpos m1) (Zpos d) with | (Zpos m2, r) => let pos2 := adjust_pos r d pos in Float sign (adjust_mantissa mode m2 pos2 sign) e2 | _ => Fnan (* dummy *) end | Eq => let d := shift beta xH nb in let pos2 := adjust_pos (Zpos m1) d pos in if need_change_zero mode pos2 sign then Float sign xH e2 else Fzero | Lt => if need_change_zero mode pos_Lo sign then Float sign xH e2 else Fzero end | Z0 => Float sign (adjust_mantissa mode m1 pos sign) e1 | _ => Float sign m1 e1 end end. (* * Fround *) Definition Fround {beta} mode prec (x : float beta) := Fround_at_prec mode prec (float_to_ufloat x). (* * Fnearbyint_exact *) Definition Fnearbyint_exact {beta} mode (x : float beta) := Fround_at_exp mode 0 (float_to_ufloat x). (* * Fnearbyint *) Definition Fnearbyint {beta} mode prec x := match x with | Float sx mx ex => match Z.compare (Zpos (count_digits beta mx) + ex) (Zpos prec) with | Gt => Fround_at_prec mode prec | _ => Fround_at_exp mode 0 end (@Ufloat beta sx mx ex pos_Eq) | _ => x end. (* * Fmul *) Definition Fmul_aux {beta} (x y : float beta) : ufloat beta := match x, y with | Fnan, _ => Unan | _, Fnan => Unan | Fzero, _ => Uzero | _, Fzero => Uzero | Float sx mx ex, Float sy my ey => Ufloat (xorb sx sy) (Pmult mx my) (ex + ey) pos_Eq end. Definition Fmul {beta} mode prec (x y : float beta) := Fround_at_prec mode prec (Fmul_aux x y). (* * Fadd_slow, Fadd_exact * * 1. Shift the mantissa with the highest exponent to match the other one. * 2. Perform the addition/subtraction. * 3. Round to p digits. * * Complexity is fine as long as px <= p and py <= p and exponents are close. *) Definition Fadd_slow_aux1 beta sx sy mx my e pos : ufloat beta := if eqb sx sy then Ufloat sx (Pplus mx my) e pos else match (Zpos mx + Zneg my)%Z with | Z0 => Uzero | Zpos p => Ufloat sx p e pos | Zneg p => Ufloat sy p e pos end. Definition Fadd_slow_aux2 beta sx sy mx my ex ey pos := match Zminus ex ey with | Zpos nb => Fadd_slow_aux1 beta sx sy (shift beta mx nb) my ey pos | Zneg nb => Fadd_slow_aux1 beta sx sy mx (shift beta my nb) ex pos | Z0 => Fadd_slow_aux1 beta sx sy mx my ex pos end. Definition Fadd_slow_aux {beta} (x y : float beta) := match x, y with | Fnan, _ => Unan | _, Fnan => Unan | Fzero, Fzero => Uzero | Fzero, Float sy my ey => Ufloat sy my ey pos_Eq | Float sx mx ex, Fzero => Ufloat sx mx ex pos_Eq | Float sx mx ex, Float sy my ey => Fadd_slow_aux2 beta sx sy mx my ex ey pos_Eq end. Definition Fadd_slow {beta} mode prec (x y : float beta) := Fround_at_prec mode prec (Fadd_slow_aux x y). Definition Fadd_exact {beta} (x y : float beta) := Fround_none (Fadd_slow_aux x y). (* * Fadd_fast * * 1. Guess a lower bound on the exponent of the result. * 2. Truncate the mantissa (at most one) that extends farther. * 3. Shift the (usually other) mantissa to match it. * 4. Perform the addition/subtraction. * 5. Round to p digits wrt the position given by the truncation. * * Complexity is fine as long as, either * . px <= p and py <= p, or * . pv <= p and v has same magnitude than the result. *) Definition Fadd_fast_aux1 beta s1 s2 m1 m2 e1 e2 e : ufloat beta := let m1' := match (e1 - e)%Z with | Zpos d => shift beta m1 d | _ => m1 end in match (e - e2)%Z with | Zpos nb => let d := shift beta xH nb in match Z.div_eucl (Zpos m2) (Zpos d) with | (Zpos m2', r) => let pos := adjust_pos r d pos_Eq in Fadd_slow_aux1 beta s1 s2 m1' m2' e pos | (Z0, r) => let pos := adjust_pos r d pos_Eq in Ufloat s1 m1' e pos | _ => Unan (* dummy *) end | Z0 => Fadd_slow_aux1 beta s1 s2 m1' m2 e pos_Eq | _ => Unan (* dummy *) end. Definition Fadd_fast_aux2 beta prec s1 s2 m1 m2 e1 e2 := let d1 := count_digits beta m1 in let d2 := count_digits beta m2 in let p1 := (Zpos d1 + e1)%Z in let p2 := (Zpos d2 + e2)%Z in if Zle_bool 2 (Z.abs (p1 - p2)) then let e := Z.min (Z.max e1 e2) (Z.max p1 p2 + Z.neg prec) in if Zlt_bool e1 e then Fadd_fast_aux1 beta s2 s1 m2 m1 e2 e1 e else Fadd_fast_aux1 beta s1 s2 m1 m2 e1 e2 e else (* massive cancellation possible *) Fadd_slow_aux2 beta s1 s2 m1 m2 e1 e2 pos_Eq. Definition Fadd_fast_aux {beta} prec (x y : float beta) := match x, y with | Fnan, _ => Unan | _, Fnan => Unan | Fzero, Fzero => Uzero | Fzero, Float sy my ey => Ufloat sy my ey pos_Eq | Float sx mx ex, Fzero => Ufloat sx mx ex pos_Eq | Float sx mx ex, Float sy my ey => Fadd_fast_aux2 beta prec sx sy mx my ex ey end. Definition Fadd_fast {beta} mode prec (x y : float beta) := Fround_at_prec mode prec (Fadd_fast_aux prec x y). Definition Fadd {beta} := @Fadd_slow beta. (* * Fsub *) Definition Fsub_slow_aux {beta} (x y : float beta) := match x, y with | Fnan, _ => Unan | _, Fnan => Unan | Fzero, Fzero => Uzero | Fzero, Float sy my ey => Ufloat (negb sy) my ey pos_Eq | Float sx mx ex, Fzero => Ufloat sx mx ex pos_Eq | Float sx mx ex, Float sy my ey => Fadd_slow_aux2 beta sx (negb sy) mx my ex ey pos_Eq end. Definition Fsub_slow {beta} mode prec (x y : float beta) := Fround_at_prec mode prec (Fsub_slow_aux x y). Definition Fsub_fast_aux {beta} prec (x y : float beta) := match x, y with | Fnan, _ => Unan | _, Fnan => Unan | Fzero, Fzero => Uzero | Fzero, Float sy my ey => Ufloat (negb sy) my ey pos_Eq | Float sx mx ex, Fzero => Ufloat sx mx ex pos_Eq | Float sx mx ex, Float sy my ey => Fadd_fast_aux2 beta prec sx (negb sy) mx my ex ey end. Definition Fsub_fast {beta} mode prec (x y : float beta) := Fround_at_prec mode prec (Fsub_fast_aux prec x y). Definition Fsub {beta} := @Fsub_slow beta. (* * Fdiv * * 1. Shift dividend mantissa so that it has at least py + p digits. * 2. Perform the euclidean division. * 3. Compute position with remainder. * 4. Round to p digits. * * Complexity is fine as long as px <= 2p and py <= p. *) Definition Fdiv_aux2 beta prec m1 e1 m2 e2 := let d1 := Digits.Zdigits beta m1 in let d2 := Digits.Zdigits beta m2 in let e := (e1 - e2)%Z in let (m, e') := match (d2 + prec - d1)%Z with | Zpos p => (m1 * Zpower_pos beta p, e + Zneg p)%Z | _ => (m1, e) end in let '(q, r) := Zfast_div_eucl m m2 in (q, e', Bracket.new_location m2 r Bracket.loc_Exact). Definition Fdiv_aux {beta} prec (x y : float beta) : ufloat beta := match x, y with | Fnan, _ => Unan | _, Fnan => Unan | _, Fzero => Unan | Fzero, _ => Uzero | Float sx mx ex, Float sy my ey => match Fdiv_aux2 beta (Zpos prec) (Zpos mx) ex (Zpos my) ey with | (Zpos m, e, l) => Ufloat (xorb sx sy) m e (convert_location l) | _ => Unan (* dummy *) end end. Definition Fdiv {beta} mode prec (x y : float beta) := Fround_at_prec mode prec (Fdiv_aux prec x y). (* * Frem * * 1. Shift mantissas so that dividend and divisor have the same exponents. * 2. Perform the euclidean division. * 3. Adjust quotient to closest integer (tie breaking to even). * 4. Scale remainder to common exponent. * 5. Round remainder to p digits. *) Definition Frem_aux1 beta mx my s e : float beta * ufloat beta := let (q1, r1) := Z.div_eucl (Zpos mx) (Zpos my) in let (q2, r2) := match match my with | xH => false | xO p => match Z.compare r1 (Zpos p) with | Lt => false | Eq => match q1 with | Z0 => false | Zpos (xO _) => false | _ => true end | Gt => true end | xI p => match Z.compare r1 (Zpos p) with | Lt => false | Eq => false | Gt => true end end with | false => (q1, r1) | true => (q1 + 1, r1 - Zpos my)%Z end in (match q2 with | Zpos p => Float s p 0 | Z0 => Fzero | _ => Fnan (* dummy *) end, match r2 with | Zpos p => Ufloat s p e pos_Eq | Z0 => Uzero | Zneg p => Ufloat (negb s) p e pos_Eq end). Definition Frem_aux {beta} (x y : float beta) := match x, y with | Fnan, _ => (Fnan, Unan) | _, Fnan => (Fnan, Unan) | _, Fzero => (Fnan, Unan) | Fzero, _ => (Fzero, Uzero) | Float sx mx ex, Float sy my ey => let s := xorb sx sy in match (ex - ey)%Z with | Zpos nb => Frem_aux1 beta (shift beta mx nb) my s ey | Z0 => Frem_aux1 beta mx my s ex | Zneg nb => Frem_aux1 beta mx (shift beta my nb) s ex end end. Definition Frem {beta} mode prec (x y : float beta) := let (q, r) := Frem_aux x y in (q, Fround_at_prec mode prec r). (* * Fsqrt * * 1. Shift the mantissa so that it has at least 2p-1 digits; * shift it one digit more if the new exponent is not even. * 2. Compute the square root s (at least p digits) of the new * mantissa, and its remainder r. * 3. Current position: r == 0 => Eq, * r <= s => Lo, * r >= s => Up. * 4. Round to p digits. * * Complexity is fine as long as p1 <= 2p-1. *) Definition Fsqrt_aux2 beta prec m e := let d := Digits.Zdigits beta m in let s := Z.max (2 * prec - d) 0 in let e' := (e - s)%Z in let (s', e'') := if Z.even e' then (s, e') else (s + 1, e' - 1)%Z in let m' := match s' with | Zpos p => (m * Zpower_pos beta p)%Z | _ => m end in let (q, r) := Z.sqrtrem m' in let l := if Zeq_bool r 0 then Bracket.loc_Exact else Bracket.loc_Inexact (if Zle_bool r q then Lt else Gt) in (q, Z.div2 e'', l). Definition Fsqrt_aux {beta} prec (f : float beta) : ufloat beta := match f with | Float false m e => match Fsqrt_aux2 beta (Zpos prec) (Zpos m) e with | (Zpos m, e, l) => Ufloat false m e (convert_location l) | _ => Unan (* dummy *) end | Float true _ _ => Unan | Fzero => Uzero | Fnan => Unan end. Definition Fsqrt {beta} mode prec (x : float beta) := Fround_at_prec mode prec (Fsqrt_aux prec x). (* * Fmag *) Definition Fmag {beta} (x : float beta) := match x with | Float _ m e => Zplus e (Zpos (count_digits beta m)) | _ => Z0 end. interval-4.11.1/src/Float/Generic_ops.v000066400000000000000000000372331470547631300177240ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals Psatz. From Flocq Require Import Zaux Raux. Require Import Xreal. Require Import Basic. Require Import Generic. Require Import Generic_proof. Require Import Sig. Module Type Radix. Parameter val : radix. End Radix. Module Radix2 <: Radix. Definition val := radix2. End Radix2. Module Radix10 <: Radix. Definition val := Build_radix 10 (refl_equal _). End Radix10. Module GenericFloat (Rad : Radix) <: FloatOps. Definition radix := Rad.val. Definition sensible_format := match radix_val radix with Zpos (xO _) => true | _ => false end. Definition type := float radix. Definition toF (x : type) := x. Definition toX (x : type) := FtoX x. Definition toR x := proj_val (toX x). Definition convert (x : type) := FtoX x. Definition fromF (x : type) := x. Definition precision := positive. Definition sfactor := Z. Definition prec := fun x : positive => x. Definition ZtoS := fun x : Z => x. Definition StoZ := fun x : Z => x. Definition PtoP := fun x : positive => x. Definition incr_prec := Pplus. Definition zero := @Fzero radix. Definition nan := @Basic.Fnan radix. Definition mag := @Fmag radix. Definition cmp := @Fcmp radix. Definition min := @Fmin radix. Definition max := @Fmax radix. Definition neg := @Fneg radix. Definition abs := @Fabs radix. Definition scale := @Fscale radix. Definition div2 := @Fdiv2 radix. Definition add_UP := @Fadd radix rnd_UP. Definition add_DN := @Fadd radix rnd_DN. Definition sub_UP := @Fsub radix rnd_UP. Definition sub_DN := @Fsub radix rnd_DN. Definition mul_UP := @Fmul radix rnd_UP. Definition mul_DN := @Fmul radix rnd_DN. Definition div_UP := @Fdiv radix rnd_UP. Definition div_DN := @Fdiv radix rnd_DN. Definition sqrt_UP := @Fsqrt radix rnd_UP. Definition sqrt_DN := @Fsqrt radix rnd_DN. Definition nearbyint_UP := @Fnearbyint_exact radix. Definition nearbyint_DN := @Fnearbyint_exact radix. Definition pow2_UP (_ : positive) := @Fpow2 radix. Definition zero_correct := refl_equal (Xreal R0). Definition nan_correct := refl_equal Fnan. Definition classify (f : float radix) := match f with Basic.Fnan => Fnan | _ => Freal end. Definition real (f : float radix) := match f with Basic.Fnan => false | _ => true end. Definition is_nan (f : float radix) := match f with Basic.Fnan => true | _ => false end. Lemma ZtoS_correct : forall prec z, (z <= StoZ (ZtoS z))%Z \/ toX (pow2_UP prec (ZtoS z)) = Xnan. Proof. now left. Qed. Lemma classify_correct : forall f, real f = match classify f with Freal => true | _ => false end. Proof. now intro f; case f. Qed. Lemma real_correct : forall f, real f = match toX f with Xnan => false | _ => true end. Proof. intros f. now case f. Qed. Lemma is_nan_correct : forall f, is_nan f = match classify f with Fnan => true | _ => false end. Proof. now intro f; case f. Qed. Definition valid_ub (_ : type) := true. Definition valid_lb (_ : type) := true. Lemma valid_lb_correct : forall f, valid_lb f = match classify f with Fpinfty => false | _ => true end. Proof. now intro f; case f. Qed. Lemma valid_ub_correct : forall f, valid_ub f = match classify f with Fminfty => false | _ => true end. Proof. now intro f; case f. Qed. Lemma min_correct : forall x y, match classify x, classify y with | Fnan, _ | _, Fnan => classify (min x y) = Fnan | Fminfty, _ | _, Fminfty => classify (min x y) = Fminfty | Fpinfty, _ => min x y = y | _, Fpinfty => min x y = x | Freal, Freal => toX (min x y) = Xmin (toX x) (toX y) end. Proof. intros x y. case_eq (classify x); [|now case x..]. case_eq (classify y); [|now case y; [case x; [..|intros b p z; case b]|..]|now case y..]. now rewrite (Fmin_correct radix). Qed. Lemma max_correct : forall x y, match classify x, classify y with | Fnan, _ | _, Fnan => classify (max x y) = Fnan | Fpinfty, _ | _, Fpinfty => classify (max x y) = Fpinfty | Fminfty, _ => max x y = y | _, Fminfty => max x y = x | Freal, Freal => toX (max x y) = Xmax (toX x) (toX y) end. Proof. intros x y. case_eq (classify x); [|now case x..]. case_eq (classify y); [|now case y; [case x; [..|intros b p z; case b]|..]|now case y..]. now rewrite (Fmax_correct radix). Qed. Lemma neg_correct : forall x, match classify x with | Freal => toX (neg x) = Xneg (toX x) | Fnan => classify (neg x) = Fnan | Fminfty => classify (neg x) = Fpinfty | Fpinfty => classify (neg x) = Fminfty end. Proof. intro x; case_eq (classify x); [|now case x..]. now rewrite (Fneg_correct radix). Qed. Lemma abs_correct : forall x, toX (abs x) = Xabs (toX x) /\ (valid_ub (abs x) = true). Proof. now intro x; rewrite (Fabs_correct radix). Qed. Lemma rnd_binop_UP_correct op Rop : (forall mode p x y, toX (op mode p x y) = Xround radix mode (prec p) (Xlift2 Rop (toX x) (toX y))) -> forall p x y, le_upper (Xlift2 Rop (toX x) (toX y)) (toX (op rnd_UP p x y)). Proof. intros H p x y; rewrite H; clear H. set (z := Xlift2 _ _ _). unfold Xround, Xlift. case z; [exact I|intro z'; simpl]. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Lemma rnd_binop_DN_correct op Rop : (forall mode p x y, toX (op mode p x y) = Xround radix mode (prec p) (Xlift2 Rop (toX x) (toX y))) -> forall p x y, le_lower (toX (op rnd_DN p x y)) (Xlift2 Rop (toX x) (toX y)). Proof. intros H p x y; rewrite H; clear H. set (z := Xlift2 _ _ _). unfold Xround, Xlift. case z; [exact I|intro z']. unfold le_lower, Xneg; simpl; apply Ropp_le_contravar. now apply Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. Definition fromZ n : float radix := match n with Zpos p => Float false p Z0 | Zneg p => Float true p Z0 | Z0 => Fzero end. Lemma fromZ_correct' : forall n, toX (fromZ n) = Xreal (IZR n). Proof. intros. case n ; split. Qed. Lemma fromZ_correct : forall n, (Z.abs n <= 256)%Z -> toX (fromZ n) = Xreal (IZR n). Proof. intros n _. apply fromZ_correct'. Qed. Definition fromZ_DN (p : precision) := fromZ. Lemma fromZ_DN_correct : forall p n, valid_lb (fromZ_DN p n) = true /\ le_lower (toX (fromZ_DN p n)) (Xreal (IZR n)). Proof. intros p n. split. easy. rewrite fromZ_correct'. apply Rle_refl. Qed. Definition fromZ_UP (p : precision) := fromZ. Lemma fromZ_UP_correct : forall p n, valid_ub (fromZ_UP p n) = true /\ le_upper (Xreal (IZR n)) (toX (fromZ_UP p n)). Proof. intros p n. split. easy. rewrite fromZ_correct'. apply Rle_refl. Qed. Lemma add_UP_correct : forall p x y, valid_ub x = true -> valid_ub y = true -> (valid_ub (add_UP p x y) = true /\ le_upper (Xadd (toX x) (toX y)) (toX (add_UP p x y))). Proof. intros p x y _ _; split; [easy|]. now apply (rnd_binop_UP_correct _ _ (@Fadd_correct _)). Qed. Lemma add_DN_correct : forall p x y, valid_lb x = true -> valid_lb y = true -> (valid_lb (add_DN p x y) = true /\ le_lower (toX (add_DN p x y)) (Xadd (toX x) (toX y))). Proof. intros p x y _ _; split; [easy|]. now apply (rnd_binop_DN_correct _ _ (@Fadd_correct _)). Qed. Lemma sub_UP_correct : forall p x y, valid_ub x = true -> valid_lb y = true -> (valid_ub (sub_UP p x y) = true /\ le_upper (Xsub (toX x) (toX y)) (toX (sub_UP p x y))). Proof. intros p x y _ _; split; [easy|]. now apply (rnd_binop_UP_correct _ _ (@Fsub_correct _)). Qed. Lemma sub_DN_correct : forall p x y, valid_lb x = true -> valid_ub y = true -> (valid_lb (sub_DN p x y) = true /\ le_lower (toX (sub_DN p x y)) (Xsub (toX x) (toX y))). Proof. intros p x y _ _; split; [easy|]. now apply (rnd_binop_DN_correct _ _ (@Fsub_correct _)). Qed. Definition is_non_neg x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 <= r)%R end. Definition is_non_neg' x := match toX x with Xnan => valid_ub x = true | Xreal r => (0 <= r)%R end. Definition is_pos x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 < r)%R end. Definition is_non_pos x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r <= 0)%R end. Definition is_non_pos' x := match toX x with Xnan => valid_lb x = true | Xreal r => (r <= 0)%R end. Definition is_neg x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r < 0)%R end. Definition is_non_neg_real x := match toX x with Xnan => False | Xreal r => (0 <= r)%R end. Definition is_pos_real x := match toX x with Xnan => False | Xreal r => (0 < r)%R end. Definition is_non_pos_real x := match toX x with Xnan => False | Xreal r => (r <= 0)%R end. Definition is_neg_real x := match toX x with Xnan => False | Xreal r => (r < 0)%R end. Lemma mul_UP_correct : forall p x y, ((is_non_neg' x /\ is_non_neg' y) \/ (is_non_pos' x /\ is_non_pos' y) \/ (is_non_pos_real x /\ is_non_neg_real y) \/ (is_non_neg_real x /\ is_non_pos_real y)) -> valid_ub (mul_UP p x y) = true /\ le_upper (Xmul (toX x) (toX y)) (toX (mul_UP p x y)). Proof. intros p x y _; split; [easy|]. now apply (rnd_binop_UP_correct _ _ (@Fmul_correct _)). Qed. Lemma mul_DN_correct : forall p x y, ((is_non_neg_real x /\ is_non_neg_real y) \/ (is_non_pos_real x /\ is_non_pos_real y) \/ (is_non_neg' x /\ is_non_pos' y) \/ (is_non_pos' x /\ is_non_neg' y)) -> (valid_lb (mul_DN p x y) = true /\ le_lower (toX (mul_DN p x y)) (Xmul (toX x) (toX y))). Proof. intros p x y _; split; [easy|]. now apply (rnd_binop_DN_correct _ _ (@Fmul_correct _)). Qed. Lemma pow2_UP_correct : forall p s, (valid_ub (pow2_UP p s) = true /\ le_upper (Xscale radix2 (Xreal 1) (StoZ s)) (toX (pow2_UP p s))). Proof. intros p s. split; [easy |]. simpl. rewrite Rmult_1_l. unfold pow2_UP, Fpow2, toX. generalize (radix_prop radix). destruct (radix_val radix) as [|[r|r|]|r] eqn:H ; try easy ; intros _. - unfold Fscale2; rewrite H. destruct s as [|s|s]; [apply Rle_refl| |easy]. rewrite iter_pos_nat. simpl. apply IZR_le. rewrite Zpower_pos_nat. apply Zeq_le. induction (Pos.to_nat s). easy. rewrite iter_nat_S. now rewrite Zpower_nat_S, IHn. - rewrite Fscale2_correct by now rewrite H. simpl. unfold StoZ. rewrite Rmult_1_l. apply Rle_refl. Qed. Definition is_real_ub x := match toX x with Xnan => valid_ub x = true | _ => True end. Definition is_real_lb x := match toX x with Xnan => valid_lb x = true | _ => True end. Lemma div_UP_correct : forall p x y, ((is_real_ub x /\ is_pos_real y) \/ (is_real_lb x /\ is_neg_real y)) -> valid_ub (div_UP p x y) = true /\ le_upper (Xdiv (toX x) (toX y)) (toX (div_UP p x y)). Proof. intros p x y _; split; [easy|]. unfold div_UP. rewrite (@Fdiv_correct radix). set (z := Xdiv _ _). unfold Xround, Xlift. case z; [exact I|intro z'; simpl]. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Lemma div_DN_correct : forall p x y, ((is_real_ub x /\ is_neg_real y) \/ (is_real_lb x /\ is_pos_real y)) -> valid_lb (div_DN p x y) = true /\ le_lower (toX (div_DN p x y)) (Xdiv (toX x) (toX y)). Proof. intros p x y _; split; [easy|]. unfold div_DN. rewrite (@Fdiv_correct radix). set (z := Xdiv _ _). unfold Xround, Xlift. case z; [exact I|intro z']. unfold le_lower, Xneg; simpl; apply Ropp_le_contravar. now apply Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. Lemma sqrt_UP_correct : forall p x, valid_ub (sqrt_UP p x) = true /\ le_upper (Xsqrt (toX x)) (toX (sqrt_UP p x)). Proof. intros p x; split; [easy|]. unfold sqrt_UP. rewrite (@Fsqrt_correct radix). unfold toX. case FtoX; [easy|intro rx]. unfold Xsqrt, Xsqrt_nan, Xsqrt', Xsqrt_nan'. case is_negative_spec; [easy|intros _]. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Lemma sqrt_DN_correct : forall p x, valid_lb x = true -> (valid_lb (sqrt_DN p x) = true /\ le_lower (toX (sqrt_DN p x)) (Xsqrt (toX x))). Proof. intros p x _; split; [easy|]. unfold sqrt_DN. rewrite (@Fsqrt_correct radix). unfold toX. case FtoX; [easy|intro rx]. unfold Xsqrt, Xsqrt_nan, Xsqrt', Xsqrt_nan'. case is_negative_spec; [easy|intros _]. unfold le_lower, Xneg; simpl; apply Ropp_le_contravar. now apply Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. Lemma nearbyint_UP_correct : forall mode x, valid_ub (nearbyint_UP mode x) = true /\ le_upper (Xnearbyint mode (toX x)) (toX (nearbyint_UP mode x)). Proof. intros mode x. split; [easy|]. rewrite (@Fnearbyint_exact_correct radix). unfold le_upper, toX. now case (Xlift _ _); [|intro r; right]. Qed. Lemma nearbyint_DN_correct : forall mode x, valid_lb (nearbyint_DN mode x) = true /\ le_lower (toX (nearbyint_DN mode x)) (Xnearbyint mode (toX x)). Proof. intros mode x. split; [easy|]. rewrite (@Fnearbyint_exact_correct radix). unfold le_upper, toX. now case (Xlift _ _); [|intro r; right]. Qed. Lemma cmp_correct : forall x y, cmp x y = match classify x, classify y with | Fnan, _ | _, Fnan => Xund | Fminfty, Fminfty => Xeq | Fminfty, _ => Xlt | _, Fminfty => Xgt | Fpinfty, Fpinfty => Xeq | _, Fpinfty => Xlt | Fpinfty, _ => Xgt | Freal, Freal => Xcmp (toX x) (toX y) end. Proof. intros x y. unfold cmp, classify. rewrite Fcmp_correct. now case x, y. Qed. Lemma mag_correct : forall f, (Rabs (toR f) < bpow radix (mag f))%R. Proof. intros f. unfold mag, Fmag. destruct f as [ | |s m e] ; try (change (Rabs _) with (Rabs 0) ; rewrite Rabs_R0 ; apply bpow_gt_0). unfold toR, toX. simpl. rewrite FtoR_split. rewrite <- digits_conversion, Zplus_comm. apply Rlt_le_trans with (1 := bpow_mag_gt radix _). apply bpow_le, Z.eq_le_incl. rewrite <- Raux.mag_abs, <- Float_prop.F2R_Zabs, abs_cond_Zopp. now apply Float_prop.mag_F2R_Zdigits. Qed. Lemma div2_correct : forall x, sensible_format = true -> (1 / 256 <= Rabs (toR x))%R -> toX (div2 x) = Xdiv (toX x) (Xreal 2). Proof. intros x Hf _. unfold div2, Fdiv2, toX. rewrite Fscale2_correct; [|easy]. simpl; unfold Z.pow_pos; simpl. rewrite Xdiv_split. unfold Xinv, Xinv'. now rewrite is_zero_false. Qed. Definition midpoint (x y : type) := Fscale2 (Fadd_exact x y) (ZtoS (-1)). Lemma midpoint_correct : forall x y, sensible_format = true -> real x = true -> real y = true -> (toR x <= toR y)%R -> real (midpoint x y) = true /\ (toR x <= toR (midpoint x y) <= toR y)%R. Proof. intros x y He. unfold toR, FtoX, midpoint. rewrite !real_correct. rewrite (Fscale2_correct _ _ _ He). rewrite Fadd_exact_correct. unfold toX. do 2 (case FtoX; [easy|]). change (bpow radix2 (ZtoS (-1))) with (/2)%R. clear x y; simpl; intros x y _ _ Hxy. now split; [|lra]. Qed. End GenericFloat. interval-4.11.1/src/Float/Generic_proof.v000066400000000000000000001073721470547631300202520ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Bool ZArith Psatz. From Flocq Require Import Core Digits Bracket Round Operations. From mathcomp.ssreflect Require Import ssrbool. Require Import Stdlib. Require Import Xreal. Require Import Basic. Require Import Generic. Local Existing Instance zpos_gt_0. Local Existing Instance valid_rnd_of_mode. Lemma FtoR_Rpos : forall beta m e, (0 < FtoR beta false m e)%R. Proof. intros beta m e. rewrite FtoR_split. now apply F2R_gt_0. Qed. Lemma FtoR_neg : forall beta s m e, (- FtoR beta s m e = FtoR beta (negb s) m e)%R. Proof. intros beta s m e. rewrite 2!FtoR_split. rewrite <- F2R_opp. now case s. Qed. Lemma FtoR_Rneg : forall beta m e, (FtoR beta true m e < 0)%R. Proof. intros beta m e. rewrite FtoR_split. now apply F2R_lt_0. Qed. Lemma FtoR_non_neg : forall beta s m e, (FtoR beta s m e <> 0)%R. Proof. intros beta [ | ] m e. { generalize (FtoR_Rneg beta m e); lra. } generalize (FtoR_Rpos beta m e); lra. Qed. Lemma FtoR_abs : forall beta s m e, (Rabs (FtoR beta s m e) = FtoR beta false m e)%R. Proof. intros beta s m e. rewrite 2!FtoR_split, <- F2R_abs. now case s. Qed. Lemma FtoR_add : forall beta s m1 m2 e, (FtoR beta s m1 e + FtoR beta s m2 e)%R = FtoR beta s (m1 + m2) e. Proof. intros beta s m1 m2 e. rewrite 3!FtoR_split. unfold F2R. simpl. rewrite <- Rmult_plus_distr_r. rewrite <- plus_IZR. now case s. Qed. Lemma FtoR_sub : forall beta s m1 m2 e, (Zpos m2 < Zpos m1)%Z -> (FtoR beta s m1 e + FtoR beta (negb s) m2 e)%R = FtoR beta s (m1 - m2) e. Proof. intros beta s m1 m2 e Hm. rewrite 3!FtoR_split. unfold F2R. simpl. rewrite <- Rmult_plus_distr_r. rewrite <- plus_IZR. case s ; simpl. rewrite (Z.pos_sub_spec m2 m1). unfold Z.lt in Hm ; simpl in Hm. now rewrite Hm. generalize (Z.lt_gt _ _ Hm). unfold Z.gt. simpl. intros H. now rewrite (Z.pos_sub_spec m1 m2), H. Qed. Lemma FtoR_mul : forall beta s1 s2 m1 m2 e1 e2, (FtoR beta s1 m1 e1 * FtoR beta s2 m2 e2)%R = FtoR beta (xorb s1 s2) (m1 * m2) (e1 + e2). Proof. intros beta s1 s2 m1 m2 e1 e2. rewrite 3!FtoR_split. unfold F2R. simpl. rewrite bpow_plus. case s1 ; case s2 ; simpl ; rewrite <- Rmult_assoc, (Rmult_comm (IZR _)), (Rmult_assoc _ _ (IZR _)), <- mult_IZR ; simpl ; ring. Qed. Lemma shift_correct : forall beta m e, Zpos (shift beta m e) = (Zpos m * Zpower_pos beta e)%Z. Proof. intros beta m e. rewrite Z.pow_pos_fold. unfold shift. set (r := match radix_val beta with Zpos r => r | _ => xH end). rewrite iter_pos_nat. rewrite Zpower_Zpower_nat by easy. simpl Z.abs_nat. induction (nat_of_P e). simpl. now rewrite Pmult_comm. rewrite iter_nat_S, Zpower_nat_S. rewrite Zpos_mult_morphism. rewrite IHn. replace (Zpos r) with (radix_val beta). ring. unfold r. generalize (radix_val beta) (radix_prop beta). clear. now intros [|p|p]. Qed. Lemma FtoR_shift : forall beta s m e p, FtoR beta s m (e + Zpos p) = FtoR beta s (shift beta m p) e. Proof. intros beta s m e p. rewrite 2!FtoR_split. rewrite shift_correct. rewrite F2R_change_exp with (e' := e). ring_simplify (e + Zpos p - e)%Z. case s ; unfold cond_Zopp. now rewrite Zopp_mult_distr_l_reverse. apply refl_equal. pattern e at 1 ; rewrite <- Zplus_0_r. now apply Zplus_le_compat_l. Qed. Lemma digits_conversion : forall beta p, Zdigits beta (Zpos p) = Zpos (count_digits beta p). Proof. intros beta p. unfold Zdigits, count_digits. generalize xH, (radix_val beta), p at 1 3. induction p ; simpl ; intros. case (Zlt_bool (Zpos p1) z). apply refl_equal. rewrite <- IHp. now rewrite Pplus_one_succ_r. case (Zlt_bool (Zpos p1) z). apply refl_equal. rewrite <- IHp. now rewrite Pplus_one_succ_r. now case (Zlt_bool (Zpos p0) z). Qed. (* * Fneg *) Theorem Fneg_correct : forall beta (f : float beta), FtoX (Fneg f) = Xneg (FtoX f). Proof. intros. case f ; intros. apply refl_equal. simpl. rewrite Ropp_0. apply refl_equal. simpl. rewrite FtoR_neg. apply refl_equal. Qed. (* * Fabs *) Theorem Fabs_correct : forall beta (f : float beta), FtoX (Fabs f) = Xabs (FtoX f). Proof. intros. case f ; intros. apply refl_equal. simpl. rewrite Rabs_R0. apply refl_equal. simpl. rewrite FtoR_abs. apply refl_equal. Qed. (* * Fscale2 *) Lemma cond_Zopp_mult : forall s u v, cond_Zopp s (u * v) = (cond_Zopp s u * v)%Z. Proof. intros s u v. case s. apply sym_eq. apply Zopp_mult_distr_l_reverse. apply refl_equal. Qed. Theorem Fscale2_correct : forall beta (f : float beta) d, match radix_val beta with Zpos (xO _) => true | _ => false end = true -> FtoX (Fscale2 f d) = Xmul (FtoX f) (Xreal (bpow radix2 d)). Proof. intros beta [| |s m e] d Hb ; simpl. apply refl_equal. now rewrite Rmult_0_l. revert Hb. destruct beta as (beta, Hb). simpl. destruct beta as [|[p|p|]|p] ; try easy. intros _. set (beta := Build_radix (Zpos p~0) Hb). cut (FtoX match d return (float beta) with | 0%Z => Float s m e | Zpos nb => Float s (iter_pos (fun x : positive => xO x) nb m) e | Zneg nb => Float s (iter_pos (fun x : positive => Pmult p x) nb m) (e + d) end = Xreal (FtoR beta s m e * bpow radix2 d)). (* *) intro H. destruct p as [p|p|] ; try exact H. unfold FtoX. rewrite 2!FtoR_split. unfold F2R. simpl. now rewrite bpow_plus, Rmult_assoc. (* *) destruct d as [|nb|nb]. now rewrite Rmult_1_r. (* . *) unfold FtoX. apply f_equal. rewrite 2!FtoR_split. simpl. replace (IZR (Zpower_pos 2 nb)) with (F2R (Defs.Float beta (Zpower_pos 2 nb) 0)). 2: apply Rmult_1_r. rewrite <- F2R_mult. simpl. rewrite Zplus_0_r. rewrite <- cond_Zopp_mult. apply (f_equal (fun v => F2R (Defs.Float beta (cond_Zopp s v) e))). apply (shift_correct radix2). (* . *) unfold FtoX. apply f_equal. rewrite 2!FtoR_split. apply Rmult_eq_reg_r with (bpow radix2 (Zpos nb)). 2: apply Rgt_not_eq ; apply bpow_gt_0. rewrite Rmult_assoc, <- bpow_plus. change (Zneg nb) with (Z.opp (Zpos nb)). rewrite Zplus_opp_l, Rmult_1_r. fold (e - Zpos nb)%Z. simpl. replace (IZR (Zpower_pos 2 nb)) with (F2R (Defs.Float beta (Zpower_pos 2 nb) 0)). 2: apply Rmult_1_r. rewrite <- F2R_mult. simpl. rewrite Zplus_0_r. rewrite (F2R_change_exp beta (e - Zpos nb) _ e). 2: generalize (Zgt_pos_0 nb) ; clearbody beta ; lia. ring_simplify (e - (e - Zpos nb))%Z. rewrite <- 2!cond_Zopp_mult. apply (f_equal (fun v => F2R (Defs.Float beta (cond_Zopp s v) _))). rewrite Z.pow_pos_fold. rewrite iter_pos_nat. rewrite 2!Zpower_Zpower_nat by easy. simpl Z.abs_nat. unfold beta. simpl radix_val. clear. revert m. induction (nat_of_P nb). easy. intros m. rewrite iter_nat_S, 2!Zpower_nat_S. rewrite Zpos_mult_morphism. replace (Zpos m * (Zpos (xO p) * Zpower_nat (Zpos (xO p)) n))%Z with (Zpos m * Zpower_nat (Zpos (xO p)) n * Zpos (xO p))%Z by ring. rewrite <- IHn. change (Zpos (xO p)) with (2 * Zpos p)%Z. ring. Qed. (* * Fcmp *) Lemma Fcmp_aux2_correct : forall beta m1 m2 e1 e2, Fcmp_aux2 beta m1 e1 m2 e2 = Xcmp (Xreal (FtoR beta false m1 e1)) (Xreal (FtoR beta false m2 e2)). Proof. intros beta m1 m2 e1 e2. rewrite 2!FtoR_split. simpl cond_Zopp. unfold Fcmp_aux2, Xcmp. rewrite <- 2!digits_conversion. rewrite (Zplus_comm e1), (Zplus_comm e2). rewrite <- 2!mag_F2R_Zdigits ; [|easy..]. destruct (mag beta (F2R (Defs.Float beta (Zpos m1) e1))) as (b1, B1). destruct (mag beta (F2R (Defs.Float beta (Zpos m2) e2))) as (b2, B2). simpl. assert (Z: forall m e, (0 < F2R (Defs.Float beta (Zpos m) e))%R). intros m e. now apply F2R_gt_0. specialize (B1 (Rgt_not_eq _ _ (Z _ _))). specialize (B2 (Rgt_not_eq _ _ (Z _ _))). rewrite Rabs_pos_eq with (1 := Rlt_le _ _ (Z _ _)) in B1. rewrite Rabs_pos_eq with (1 := Rlt_le _ _ (Z _ _)) in B2. clear Z. case Zcompare_spec ; intros Hed. (* *) rewrite Rcompare_Lt. apply refl_equal. apply Rlt_le_trans with (1 := proj2 B1). apply Rle_trans with (2 := proj1 B2). apply bpow_le. clear -Hed. lia. (* *) clear. unfold Fcmp_aux1. case_eq (e1 - e2)%Z. (* . *) intros He. rewrite Zminus_eq with (1 := He). now rewrite Rcompare_F2R. (* . *) intros d He. rewrite F2R_change_exp with (e' := e2). rewrite shift_correct, He. now rewrite Rcompare_F2R. generalize (Zgt_pos_0 d). lia. (* . *) intros d He. rewrite F2R_change_exp with (e := e2) (e' := e1). replace (e2 - e1)%Z with (Zpos d). rewrite shift_correct. now rewrite Rcompare_F2R. apply Z.opp_inj. simpl. rewrite <- He. ring. generalize (Zlt_neg_0 d). lia. (* *) rewrite Rcompare_Gt. apply refl_equal. apply Rlt_le_trans with (1 := proj2 B2). apply Rle_trans with (2 := proj1 B1). apply bpow_le. clear -Hed. lia. Qed. Theorem Fcmp_correct : forall beta (x y : float beta), Fcmp x y = Xcmp (FtoX x) (FtoX y). Proof. intros. case x ; intros ; simpl ; try apply refl_equal ; case y ; intros ; simpl ; try apply refl_equal ; clear. now rewrite Rcompare_Eq. case b. rewrite Rcompare_Gt. apply refl_equal. apply FtoR_Rneg. rewrite Rcompare_Lt. apply refl_equal. apply FtoR_Rpos. now case b ; apply refl_equal. case b. rewrite Rcompare_Lt. apply refl_equal. apply FtoR_Rneg. rewrite Rcompare_Gt. apply refl_equal. apply FtoR_Rpos. case b ; case b0. rewrite Fcmp_aux2_correct. simpl. change true with (negb false). repeat rewrite <- FtoR_neg. generalize (FtoR beta false p0 z0). generalize (FtoR beta false p z). intros. destruct (Rcompare_spec r0 r). rewrite Rcompare_Lt. apply refl_equal. now apply Ropp_lt_contravar. rewrite H. now rewrite Rcompare_Eq. rewrite Rcompare_Gt. apply refl_equal. apply Ropp_lt_contravar. exact H. rewrite Rcompare_Lt. apply refl_equal. apply Rlt_trans with R0. apply FtoR_Rneg. apply FtoR_Rpos. rewrite Rcompare_Gt. apply refl_equal. apply Rlt_trans with R0. apply FtoR_Rneg. apply FtoR_Rpos. rewrite Fcmp_aux2_correct. apply refl_equal. Qed. (* * Fmin *) Theorem Fmin_correct : forall beta (x y : float beta), FtoX (Fmin x y) = Xmin (FtoX x) (FtoX y). Proof. intros. unfold Fmin, Rmin. rewrite (Fcmp_correct beta x y). case_eq (FtoX x) ; [ split | intros xr Hx ]. case_eq (FtoX y) ; [ split | intros yr Hy ]. simpl. destruct (Rle_dec xr yr) as [[H|H]|H]. rewrite Rcompare_Lt. exact Hx. exact H. now rewrite Rcompare_Eq. rewrite Rcompare_Gt. exact Hy. apply Rnot_le_lt with (1 := H). Qed. (* * Fmax *) Theorem Fmax_correct : forall beta (x y : float beta), FtoX (Fmax x y) = Xmax (FtoX x) (FtoX y). Proof. intros. unfold Fmax, Rmax. rewrite (Fcmp_correct beta x y). case_eq (FtoX x) ; [ split | intros xr Hx ]. case_eq (FtoX y) ; [ split | intros yr Hy ]. simpl. destruct (Rle_dec xr yr) as [[H|H]|H]. rewrite Rcompare_Lt. exact Hy. exact H. now rewrite Rcompare_Eq. rewrite Rcompare_Gt. exact Hx. apply Rnot_le_lt with (1 := H). Qed. Ltac refl_exists := repeat match goal with | |- ex ?P => eapply ex_intro end ; repeat split. Definition convert_location_inv l := match l with | pos_Eq => loc_Exact | pos_Lo => loc_Inexact Lt | pos_Mi => loc_Inexact Eq | pos_Up => loc_Inexact Gt end. Lemma convert_location_bij : forall l, convert_location_inv (convert_location l) = l. Proof. now destruct l as [|[| |]]. Qed. Definition mode_choice mode s m l := match mode with | rnd_UP => cond_incr (round_sign_UP s l) m | rnd_DN => cond_incr (round_sign_DN s l) m | rnd_ZR => m | rnd_NE => cond_incr (round_N (negb (Z.even m)) l) m end. Lemma adjust_mantissa_correct : forall mode s m pos, Zpos (adjust_mantissa mode m pos s) = mode_choice mode s (Zpos m) (convert_location_inv pos). Proof. intros mode s m pos. unfold adjust_mantissa, need_change, mode_choice. case mode ; case s ; case pos ; simpl ; try apply Zpos_succ_morphism ; try apply refl_equal. destruct m ; try apply Zpos_succ_morphism ; try apply refl_equal. destruct m ; try apply Zpos_succ_morphism ; try apply refl_equal. Qed. Lemma adjust_pos_correct : forall q r pos, (1 < Zpos q)%Z -> (0 <= r < Zpos q)%Z -> convert_location_inv (adjust_pos r q pos) = new_location (Zpos q) r (convert_location_inv pos). Proof. unfold adjust_pos, new_location, new_location_even, new_location_odd. intros [q|q|] r pos Hq (Hr1, Hr2). destruct r as [|r|r] ; simpl. now case pos. change (r~1 ?= q~1)%positive with (r ?= q)%positive. now case ((r ?= q)%positive) ; case pos ; simpl. unfold Zeven. now elim Hr1. destruct r as [|r|r] ; simpl. now case pos. change (r~0 ?= q~0)%positive with (r ?= q)%positive. now case ((r ?= q)%positive) ; case pos. now elim Hr1. discriminate Hq. Qed. Lemma even_radix_correct : forall beta, match radix_val beta with Zpos (xO _) => true | _ => false end = Z.even beta. Proof. intros (beta, Hb). revert Hb. case beta ; try easy. Qed. Lemma Fround_at_prec_correct : forall beta mode prec s m1 e1 pos x, (0 < x)%R -> inbetween_float beta (Zpos m1) e1 x (convert_location_inv pos) -> ( (Zpos (count_digits beta m1) < Zpos prec)%Z -> pos = pos_Eq ) -> FtoX (Fround_at_prec mode prec (@Ufloat beta s m1 e1 pos)) = Xreal (round beta mode prec (if s then Ropp x else x)). Proof with auto with typeclass_instances. intros beta mode prec s m1 e1 pos x Hx Hl Hp. unfold round. rewrite round_trunc_sign_any_correct with (choice := mode_choice mode) (m := Zpos m1) (e := e1) (l := convert_location_inv pos)... (* *) unfold Round.truncate, Round.truncate_aux, FLX_exp. replace (Zdigits beta (Zpos m1) + e1 - Zpos prec - e1)%Z with (Zdigits beta (Zpos m1) - Zpos prec)%Z by ring. replace (Rlt_bool (if s then (-x)%R else x) 0) with s. unfold Fround_at_prec. case_eq (Zpos (count_digits beta m1) - Zpos prec)%Z. (* . *) intros Hd. apply (f_equal Xreal). rewrite FtoR_split. rewrite adjust_mantissa_correct. rewrite digits_conversion, Hd. easy. (* . *) intros d Hd. rewrite digits_conversion, Hd. rewrite shift_correct, Zmult_1_l. fold (Zpower beta (Zpos d)). unfold Z.div, Zmod. assert (Zpower beta (Zpos d) > 0)%Z. apply Z.lt_gt. now apply Zpower_gt_0. generalize (Z_div_mod (Zpos m1) (Zpower beta (Zpos d)) H). clear H. case Z.div_eucl. intros q r (Hq, Hr). cut (0 < q)%Z. (* .. *) clear -Hr. case q ; try easy. clear q. intros q _. apply (f_equal Xreal). rewrite FtoR_split. rewrite adjust_mantissa_correct. simpl. apply (f_equal (fun v => F2R (Defs.Float beta (cond_Zopp s (mode_choice mode s (Zpos q) v)) (e1 + Zpos d)))). rewrite <- (Zmult_1_l (Zpower_pos beta d)). rewrite <- shift_correct. apply adjust_pos_correct ; rewrite shift_correct, Zmult_1_l. now apply (Zpower_gt_1 beta (Zpos d)). exact Hr. (* .. *) clear -Hd Hq Hr. apply Zmult_lt_reg_r with (Zpower beta (Zpos d)). now apply Zpower_gt_0. apply Zplus_lt_reg_r with r. simpl (0 * Zpower beta (Zpos d) + r)%Z. rewrite Zmult_comm, <- Hq. apply Z.lt_le_trans with (1 := proj2 Hr). fold (Z.abs (Zpos m1)). apply Zpower_le_Zdigits. rewrite <- Hd. rewrite <- digits_conversion. now apply Zlt_minus_simpl_swap. (* . *) intros d Hd. rewrite digits_conversion, Hd. rewrite Hp. simpl. rewrite FtoR_split. now destruct mode. apply Z.lt_sub_0. now rewrite Hd. (* . *) clear -Hx. apply sym_eq. case s. apply Rlt_bool_true. rewrite <- Ropp_0. now apply Ropp_lt_contravar. apply Rlt_bool_false. now apply Rlt_le. (* *) clear. intros x m l Hx. case mode ; simpl. now apply inbetween_int_UP_sign. now apply inbetween_int_DN_sign. now apply inbetween_int_ZR_sign with (l := l). now apply inbetween_int_NE_sign with (x := x). (* *) case s. rewrite Rabs_Ropp, Rabs_pos_eq. exact Hl. now apply Rlt_le. rewrite Rabs_pos_eq. exact Hl. now apply Rlt_le. (* *) rewrite digits_conversion. unfold FLX_exp. destruct (Zle_or_lt (Zpos prec) (Zpos (count_digits beta m1))) as [H|H]. left. clear -H ; lia. right. now rewrite Hp. Qed. Definition ufloat_pos_Eq beta (x : ufloat beta) := match x with Ufloat _ _ _ pos_Eq => True | Ufloat _ _ _ _ => False | _ => True end. Lemma UtoX_pos_Eq : forall beta (x : ufloat beta), (UtoX x = Xnan -> x = Unan) -> ufloat_pos_Eq beta x. Proof. now intros beta [| |s m e [| | |]] H ; try exact I ; specialize (H (refl_equal _)). Qed. Lemma Fround_at_prec_pos_Eq : forall beta mode prec (x : ufloat beta), ufloat_pos_Eq beta x -> FtoX (Fround_at_prec mode prec x) = Xround beta mode prec (UtoX x). Proof with auto with typeclass_instances. intros beta mode prec [| |s m e [| | |]] H ; try elim H ; clear H. apply refl_equal. simpl. unfold round. rewrite round_0... unfold Xround, UtoX. rewrite FtoR_split. replace (F2R (Defs.Float beta (cond_Zopp s (Zpos m)) e)) with (if s then Ropp (F2R (Defs.Float beta (Zpos m) e)) else F2R (Defs.Float beta (Zpos m) e)). apply Fround_at_prec_correct. now apply F2R_gt_0. now constructor. easy. rewrite <- F2R_opp. now case s. Qed. (* * Fnearbyint_exact *) Lemma Rdiv_lt_mult_pos a b c : (0 < b -> a * b < c -> a < c / b)%R. Proof. intros Hb Hab. apply (Rmult_lt_reg_r b _ _ Hb). now unfold Rdiv; rewrite Rmult_assoc, Rinv_l, Rmult_1_r; lra. Qed. Lemma Rdiv_le_mult_pos a b c : (0 < b -> a * b <= c -> a <= c / b)%R. Proof. intros Hb Hab. apply (Rmult_le_reg_r b _ _ Hb). now unfold Rdiv; rewrite Rmult_assoc, Rinv_l, Rmult_1_r; lra. Qed. Lemma Rdiv_gt_mult_pos a b c : (0 < b -> a < b * c -> a / b < c)%R. Proof. intros Hb Hab. apply (Rmult_lt_reg_r b _ _ Hb). now unfold Rdiv; rewrite Rmult_assoc, Rinv_l, Rmult_1_r; lra. Qed. Lemma Rdiv_ge_mult_pos a b c : (0 < b -> a <= b * c -> a / b <= c)%R. Proof. intros Hb Hab. apply (Rmult_le_reg_r b _ _ Hb). now unfold Rdiv; rewrite Rmult_assoc, Rinv_l, Rmult_1_r; lra. Qed. Lemma Znearest_IZR c z : Znearest c (IZR z) = z. Proof. unfold Znearest; rewrite Zceil_IZR, Zfloor_IZR. now destruct Rcompare; try easy; destruct c. Qed. Lemma Rnearbyint_IZR mode z : Rnearbyint mode (IZR z) = IZR z. Proof. now destruct mode; simpl; rewrite ?Zceil_IZR, ?Zfloor_IZR, ?Ztrunc_IZR, ?Znearest_IZR. Qed. Lemma adjust_mantissa_Eq mode b p : adjust_mantissa mode p pos_Eq b = p. Proof. now destruct mode. Qed. Lemma radix_to_pos (r : radix) : Z.pos (Z.to_pos r) = r. Proof. now destruct r as [[]]. Qed. Lemma shift1_correct r e : shift r 1 e = (Z.to_pos r ^ e)%positive. Proof. generalize (shift_correct r 1 e). rewrite Zmult_1_l, <-(radix_to_pos r) at 1. rewrite <-Pos2Z.inj_pow_pos. now intro H; injection H. Qed. Lemma Rcompare_div_l x y z : (0 < y)%R -> Rcompare (x / y) z = Rcompare x (y * z). Proof. intro yP. replace x with (y * (x / y))%R at 2. now rewrite Rcompare_mult_l. field; lra. Qed. Lemma Rcompare_div_r x y z : (0 < z)%R -> Rcompare x (y / z) = Rcompare (z * x) y. Proof. intro yP. rewrite Rcompare_sym, Rcompare_div_l, Rcompare_sym; try easy. now destruct Rcompare. Qed. Lemma Rlt_bool_float beta b m e : Rlt_bool (FtoR beta b m e) 0 = b. Proof. destruct e as [|p | p]; destruct b; simpl; apply Rlt_bool_true || apply Rlt_bool_false; try lra. - now apply IZR_lt. - now apply IZR_le. - assert (H1 : (0 < Z.pow_pos beta p)%Z). apply Zpower_pos_gt_0; apply radix_gt_0. revert H1. destruct Z.pow_pos; simpl; try lia; intros _. now apply IZR_lt. - assert (H1 : (0 < Z.pow_pos beta p)%Z). apply Zpower_pos_gt_0; apply radix_gt_0. revert H1. destruct Z.pow_pos; simpl; try lia; intros _. now apply IZR_le. - apply Rdiv_gt_mult_pos. apply IZR_lt. apply Zpower_pos_gt_0; apply radix_gt_0. rewrite Rmult_0_r. now apply IZR_lt. - apply Rdiv_le_mult_pos. apply IZR_lt. apply Zpower_pos_gt_0; apply radix_gt_0. rewrite Rmult_0_l. now apply IZR_le. Qed. Lemma Fnearbyint_exact_correct : forall beta mode (x : float beta), FtoX (Fnearbyint_exact mode x) = Xnearbyint mode (FtoX x). Proof. intros beta mode x. assert (bP := Zle_bool_imp_le _ _ (radix_prop beta)). unfold Fnearbyint_exact, Fround_at_exp. destruct x as [| |b p z]; simpl float_to_ufloat; lazy iota beta; try easy. now generalize (Rnearbyint_IZR mode 0); simpl; intro H; rewrite H. destruct z as [| p1 | n1]; simpl Zminus; lazy iota beta. - now rewrite adjust_mantissa_Eq; simpl; rewrite Rnearbyint_IZR. - now simpl; rewrite Rnearbyint_IZR. rewrite <-digits_conversion, shift1_correct. case Z.compare_spec; intro H. (* *) set (x := Float b p _). set (p1 := adjust_pos _ _ _). pose (y := (FtoR beta b p (Z.neg n1))). apply trans_equal with (y := Xreal (IZR (cond_Zopp (Rlt_bool y 0) (mode_choice mode (Rlt_bool y 0) 0 (convert_location_inv p1))))). unfold y; rewrite Rlt_bool_float. now destruct b; destruct mode; simpl; destruct p1. apply (f_equal Xreal). apply sym_equal. assert (V : (1 < beta ^ Z.pos n1)%Z) by now apply Zpower_gt_1. assert (V0 : (1 < IZR (beta ^ Z.pos n1))%R) by now apply IZR_lt. assert (V1 : (Z.pos p < beta ^ Z.pos n1)%Z). generalize (Zdigits_correct beta (Z.pos p)). now rewrite H; intros [_ V3]. assert (V2 : inbetween_int 0 (Rabs y) (convert_location_inv p1)). unfold p1, inbetween_int. rewrite adjust_pos_correct; try lia; last 2 first. - now rewrite Pos2Z.inj_pow, radix_to_pos. - now rewrite Pos2Z.inj_pow, radix_to_pos; lia. simpl; unfold y, p1; rewrite FtoR_abs. rewrite Pos2Z.inj_pow, radix_to_pos. replace 1%R with (0 + IZR (beta ^ Z.pos n1)* (1 / IZR (beta ^ Z.pos n1)))%R; last first. field; last now apply Rlt_neq_sym; lra. apply new_location_correct; try lia. - apply Rdiv_lt_0_compat; try lra. apply inbetween_Exact. simpl. rewrite Z.pow_pos_fold. now field; lra. destruct mode; apply (f_equal IZR). - now eapply inbetween_int_UP_sign. - now eapply inbetween_int_DN_sign. - now eapply inbetween_int_ZR_sign with (l := (convert_location_inv p1)). - now eapply inbetween_int_NE_sign. (* *) set (x := Float b p _). set (p1 := pos_Lo). pose (y := (FtoR beta b p (Z.neg n1))). apply trans_equal with (y := Xreal (IZR (cond_Zopp (Rlt_bool y 0) (mode_choice mode (Rlt_bool y 0) 0 (convert_location_inv p1))))). unfold y; rewrite Rlt_bool_float. now destruct b; destruct mode; simpl; destruct p1. apply (f_equal Xreal). apply sym_equal. assert (0 < IZR (Zpos p))%R as V by now apply IZR_lt. assert (V0 : (1 < beta ^ Z.pos n1)%Z) by now apply Zpower_gt_1. assert (V1 : (1 < IZR (beta ^ Z.pos n1))%R) by now apply IZR_lt. assert (V2 : (Z.pos p < beta ^ Z.pos n1)%Z). generalize (Zdigits_correct beta (Z.pos p)). intros [_ V2]. apply Z.lt_trans with (1 := V2). apply Zpower_lt; lia. assert (V3 : inbetween_int 0 (Rabs y) (convert_location_inv p1)). unfold y, p1, inbetween_int. rewrite FtoR_abs. apply inbetween_Inexact; simpl; rewrite Z.pow_pos_fold. - split; try lra. - apply Rdiv_lt_0_compat; lra. - apply Rdiv_gt_mult_pos; try lra. rewrite Rmult_1_r; apply IZR_lt; lia. - rewrite Rcompare_div_l; try lra. replace (IZR (beta ^ Z.pos n1) * ((0 + 1) / 2))%R with (IZR (beta ^ Z.pos n1) / 2)%R; last first. now unfold Rdiv; ring. rewrite Rcompare_div_r; try lra. rewrite <- (mult_IZR 2). rewrite Rcompare_IZR. apply Zcompare_Lt; apply Z.gt_lt. apply Zgt_le_trans with (m := (beta * Zpos p)%Z); last first. now apply Zmult_le_compat_r; lia. apply Zle_gt_trans with (m := (beta ^ (1 + Zdigits beta (Z.pos p)))%Z). now apply Zpower_le; lia. rewrite Zpower_plus, Z.pow_1_r; try lia; last first. now apply Zdigits_ge_0. apply Zmult_gt_compat_l; try lia. generalize (Zdigits_correct beta (Z.pos p)); lia. destruct mode; apply (f_equal IZR). - now eapply inbetween_int_UP_sign. - now eapply inbetween_int_DN_sign. - now eapply inbetween_int_ZR_sign with (l := (convert_location_inv p1)). - now eapply inbetween_int_NE_sign. (* *) rewrite Zdiv_eucl_unique. set (q := (_ / _)%Z). set (r := (_ mod _)%Z). assert (Pq : (0 < q)%Z). apply Z.div_str_pos; split; try easy; try lia. generalize (Zdigits_correct beta (Zpos p)); intros [U1 U2]. apply Z.le_trans with (2 := U1). rewrite Pos2Z.inj_pow, radix_to_pos. now apply Zpower_le; lia. assert (Pr : (0 <= r < Z.pos (Z.to_pos beta ^ n1))%Z). now apply Z_mod_lt. revert Pq. case_eq q; try lia; intros q1 Hq1; try lia; intros _. unfold FtoX. rewrite FtoR_split. rewrite adjust_mantissa_correct, adjust_pos_correct; last 2 first. - rewrite Pos2Z.inj_pow, radix_to_pos. now apply Zpower_gt_1. - now apply Pr. unfold F2R; simpl bpow; rewrite Rmult_1_r. pose (ll := new_location (Z.pos (Z.to_pos beta ^ n1)) r loc_Exact). assert (V : inbetween_int q (IZR (Zpos p) / IZR (Z.pow_pos beta n1)) ll). unfold q, inbetween_int, ll. replace (IZR (Z.pos p / Z.pos (Z.to_pos beta ^ n1) + 1))%R with (IZR (Z.pos p / Z.pos (Z.to_pos beta ^ n1)) + IZR (Z.pos (Z.to_pos beta ^ n1)) * (1 / IZR (Z.pos (Z.to_pos beta ^ n1))))%R; last first. rewrite plus_IZR; simpl. field. apply Rlt_neq_sym. now apply IZR_lt. apply new_location_correct; try lia. - apply Rdiv_lt_0_compat; try lra. now apply IZR_lt. - rewrite Pos2Z.inj_pow, radix_to_pos. now apply Zpower_gt_1. apply inbetween_Exact. unfold r. rewrite Pos2Z.inj_pow, radix_to_pos, Z.pow_pos_fold. assert (0 < beta ^ Z.pos n1)%Z. apply Zpower_gt_0; lia. rewrite (Z_div_mod_eq (Z.pos p) (beta ^ Z.pos n1)) at 1; try lia. rewrite plus_IZR, mult_IZR. field. apply Rlt_neq_sym; apply IZR_lt; lia. unfold Fnum; apply sym_equal. rewrite <-(Rlt_bool_float beta b p (Z.neg n1)) at 2 3. destruct mode; unfold Xlift, Rnearbyint, F2R; do 2 eapply f_equal. - apply inbetween_int_UP_sign. now rewrite FtoR_abs, <- Hq1. - apply inbetween_int_DN_sign. now rewrite FtoR_abs, <- Hq1. - apply inbetween_int_ZR_sign with (l := ll). now rewrite FtoR_abs, <- Hq1. - apply inbetween_int_NE_sign with (l := ll). now rewrite FtoR_abs, <- Hq1. Qed. (* * Fadd *) Lemma Fadd_slow_aux1_correct : forall beta sx sy mx my e, UtoX (Fadd_slow_aux1 beta sx sy mx my e pos_Eq) = Xadd (FtoX (@Float beta sx mx e)) (FtoX (@Float beta sy my e)). Proof. intros. simpl Xbind2. unfold Fadd_slow_aux1. change (Zpos mx + Zneg my)%Z with (Zpos mx - Zpos my)%Z. case_eq (eqb sx sy) ; intro H. (* == *) rewrite (eqb_prop _ _ H). rewrite FtoR_add. apply refl_equal. (* != *) replace sy with (negb sx). clear H. case_eq (Zpos mx - Zpos my)%Z. intro H. rewrite <- (FtoR_neg beta sx). unfold FtoR. change (Zneg mx) with (- Zpos mx)%Z. rewrite (Zminus_eq _ _ H). rewrite Rplus_opp_r. apply refl_equal. intro p. unfold Zminus, Zplus. simpl. rewrite Z.pos_sub_spec. case_eq (mx ?= my)%positive ; intros ; try discriminate H0. rewrite (FtoR_sub beta sx). now inversion H0. apply Z.gt_lt. exact H. intro p. unfold Zminus, Zplus. simpl. rewrite Z.pos_sub_spec. case_eq (mx ?= my)%positive ; intros ; try discriminate H0. pattern sx at 2 ; rewrite <- (negb_involutive sx). rewrite Rplus_comm. rewrite (FtoR_sub beta (negb sx)). now inversion H0. exact H. generalize H. clear. now case sx ; case sy. Qed. Lemma Fadd_slow_aux2_correct : forall beta sx sy mx my ex ey, UtoX (Fadd_slow_aux2 beta sx sy mx my ex ey pos_Eq) = Xadd (FtoX (@Float beta sx mx ex)) (FtoX (@Float beta sy my ey)). Proof. intros. unfold Xbind2, FtoX. unfold Fadd_slow_aux2. case_eq (ex - ey)%Z ; intros ; rewrite Fadd_slow_aux1_correct ; unfold FtoX, Xbind2. (* . *) replace ey with ex. apply refl_equal. rewrite <- (Zplus_0_l ey). rewrite <- H. ring. (* . *) rewrite <- FtoR_shift. rewrite <- H. replace (ey + (ex - ey))%Z with ex. 2: ring. apply refl_equal. (* . *) rewrite <- FtoR_shift. replace (ex + Zpos p)%Z with ey. apply refl_equal. change (Zpos p) with (- Zneg p)%Z. rewrite <- H. ring. Qed. Theorem Fadd_slow_aux_correct : forall beta (x y : float beta), UtoX (Fadd_slow_aux x y) = Xadd (FtoX x) (FtoX y). Proof. intros. case x. (* . *) case y ; intros ; apply refl_equal. (* . *) simpl. case y. apply refl_equal. unfold FtoX. rewrite Rplus_0_l. apply refl_equal. intros sy my ey. unfold FtoX. rewrite Rplus_0_l. apply refl_equal. (* . *) intros sx mx ex. simpl. case y. apply refl_equal. unfold FtoX. rewrite Rplus_0_r. apply refl_equal. intros sy my ey. rewrite Fadd_slow_aux2_correct. apply refl_equal. Qed. Theorem Fadd_slow_correct : forall beta mode prec (x y : float beta), FtoX (Fadd_slow mode prec x y) = Xround beta mode prec (Xadd (FtoX x) (FtoX y)). Proof. intros beta mode prec x y. unfold Fadd_slow. rewrite Fround_at_prec_pos_Eq. now rewrite Fadd_slow_aux_correct. apply UtoX_pos_Eq. rewrite Fadd_slow_aux_correct. destruct x as [| |sx mx ex]. easy. now case y. now case y. Qed. Definition Fadd_correct := Fadd_slow_correct. (* * Fadd_exact *) Theorem Fadd_exact_correct : forall beta (x y : float beta), FtoX (Fadd_exact x y) = Xadd (FtoX x) (FtoX y). Proof. intros. unfold Fadd_exact. rewrite <- (Fadd_slow_aux_correct _ x y). case (Fadd_slow_aux x y) ; simpl ; try apply refl_equal. intros. case p0 ; apply refl_equal. Qed. (* * Fsub *) Lemma Fsub_split : forall beta mode prec (x y : float beta), FtoX (Fsub mode prec x y) = (FtoX (Fadd mode prec x (Fneg y))). Proof. intros. unfold Fneg, Fadd, Fsub, Fadd_slow, Fsub_slow. case y ; trivial. Qed. Theorem Fsub_correct : forall beta mode prec (x y : float beta), FtoX (Fsub mode prec x y) = Xround beta mode prec (Xsub (FtoX x) (FtoX y)). Proof. intros. rewrite Fsub_split. rewrite Xsub_split. rewrite <- Fneg_correct. apply Fadd_correct. Qed. (* * Fmul *) Theorem Fmul_aux_correct : forall beta (x y : float beta), UtoX (Fmul_aux x y) = Xmul (FtoX x) (FtoX y). Proof. intros beta [ | | sx mx ex ] [ | | sy my ey ] ; simpl ; try apply refl_equal. (* . *) rewrite Rmult_0_l. apply refl_equal. (* . *) rewrite Rmult_0_l. apply refl_equal. (* . *) rewrite Rmult_0_r. apply refl_equal. (* . *) rewrite FtoR_mul. apply refl_equal. Qed. Theorem Fmul_correct : forall beta mode prec (x y : float beta), FtoX (Fmul mode prec x y) = Xround beta mode prec (Xmul (FtoX x) (FtoX y)). Proof. intros beta mode prec x y. unfold Fmul. rewrite Fround_at_prec_pos_Eq. now rewrite Fmul_aux_correct. apply UtoX_pos_Eq. rewrite Fmul_aux_correct. destruct x as [| |sx mx ex]. easy. now case y. now case y. Qed. (* * Fdiv *) Theorem Fdiv_correct : forall beta mode prec (x y : float beta), FtoX (Fdiv mode prec x y) = Xround beta mode prec (Xdiv (FtoX x) (FtoX y)). Proof with auto with typeclass_instances. intros beta mode prec [ | | sx mx ex] [ | | sy my ey] ; simpl ; unfold Xdiv' ; try rewrite is_zero_0 ; try apply refl_equal ; rewrite is_zero_correct_float. unfold Rdiv. rewrite Rmult_0_l. apply sym_eq. apply (f_equal Xreal). apply round_0... unfold Xround, Fdiv, Fdiv_aux, Fdiv_aux2. set (e := Z.min ((Zdigits beta (Zpos mx) + ex) - (Zdigits beta (Zpos my) + ey) - Zpos prec) (ex - ey)). generalize (Div.Fdiv_core_correct beta (Zpos mx) ex (Zpos my) ey e eq_refl eq_refl). unfold Div.Fdiv_core. rewrite Zle_bool_true by apply Z.le_min_r. match goal with |- context [let (m,e') := ?v in let '(q,r) := Zfast_div_eucl _ _ in _] => set (me := v) end. assert (me = (Zpos mx * Zpower beta (ex - ey - e), e))%Z as ->. { unfold me, e ; clear. destruct (_ + Zpos prec - _)%Z as [|p|p] eqn:He. - rewrite Z.min_r by lia. now rewrite Z.sub_diag, Zmult_1_r. - rewrite Z.min_l by lia. change (Zneg p) with (Z.opp (Zpos p)). fold (Zpower beta (Zpos p)). rewrite <- He. apply (f_equal2 (fun v1 v2 => (_ * Zpower beta v1, v2)%Z)) ; ring. - rewrite Z.min_r by lia. now rewrite Z.sub_diag, Zmult_1_r. } rewrite Zfast_div_eucl_correct. destruct Z.div_eucl as [m r]. set (l := new_location _ _ _). intros H1. assert (Zpos prec <= Zdigits beta m)%Z as H2. { generalize (Div.mag_div_F2R beta (Zpos mx) ex (Zpos my) ey eq_refl eq_refl). cbv zeta. intros H2. refine (_ (cexp_inbetween_float _ (FLX_exp (Zpos prec)) _ _ _ _ _ H1 (or_introl _))). unfold cexp, FLX_exp, e. intros H3. lia. apply Rmult_lt_0_compat. now apply F2R_gt_0. apply Rinv_0_lt_compat. now apply F2R_gt_0. unfold cexp, FLX_exp, e. lia. } destruct m as [|p|p]. - now elim H2. - replace (FtoR beta sx mx ex / FtoR beta sy my ey)%R with (if xorb sx sy then - (FtoR beta false mx ex / FtoR beta false my ey) else (FtoR beta false mx ex / FtoR beta false my ey))%R. apply (Fround_at_prec_correct beta mode prec _ p e). apply Rmult_lt_0_compat. apply FtoR_Rpos. apply Rinv_0_lt_compat. apply FtoR_Rpos. rewrite convert_location_bij. now rewrite 2!FtoR_split. rewrite <- digits_conversion. intros H3. elim (Z.lt_irrefl _ (Z.le_lt_trans _ _ _ H2 H3)). rewrite 4!FtoR_split. assert (F2R (Defs.Float beta (Zpos my) ey) <> 0%R). apply Rgt_not_eq. now apply F2R_gt_0. unfold cond_Zopp. now case sx ; case sy ; repeat rewrite F2R_Zopp ; simpl ; field. destruct (Bracket.inbetween_float_bounds _ _ _ _ _ H1) as (_, H5). elim (Rlt_not_le _ _ H5). apply Rle_trans with 0%R. apply F2R_le_0. unfold Fnum. now apply (Zlt_le_succ (Zneg p)). - apply Rlt_le. apply Rmult_lt_0_compat. now apply F2R_gt_0. apply Rinv_0_lt_compat. now apply F2R_gt_0. Qed. (* * Fsqrt *) Lemma Fsqrt_correct : forall beta mode prec (x : float beta), FtoX (Fsqrt mode prec x) = Xround beta mode prec (Xsqrt_nan (FtoX x)). Proof with auto with typeclass_instances. intros beta mode prec [ | | sx mx ex] ; simpl ; unfold Xsqrt_nan' ; try easy. (* *) case is_negative_spec. intros H. elim (Rlt_irrefl _ H). intros _. apply sym_eq. apply (f_equal Xreal). rewrite sqrt_0. apply round_0... (* *) unfold Fsqrt, Fsqrt_aux, Fsqrt_aux2. case is_negative_spec. case sx ; simpl. easy. intros H. elim (Rlt_not_le _ _ H). apply Rlt_le. apply FtoR_Rpos. case sx. intros H. elim (Rle_not_lt _ _ H). apply FtoR_Rneg. intros _. unfold Xround. set (e1 := Z.max _ _). destruct (if Z.even _ then _ else _) as [s' e''] eqn:Hse. set (e' := Z.div2 e''). assert (e' = Z.div2 (ex - e1) /\ s' = ex - 2 * e')%Z as [He1 He2]. { generalize (Zdiv2_odd_eqn (ex - e1)). rewrite <- Z.negb_even. destruct Z.even eqn:H ; injection Hse ; intros <- <-. rewrite Zplus_0_r. intros H0. apply (conj eq_refl). fold e' in H0. rewrite <- H0. ring. change (if negb false then _ else _) with 1%Z. intros H'. unfold e'. rewrite H' at 1 3. rewrite Z.add_simpl_r. rewrite Zdiv2_div, (Zmult_comm 2), Z.div_mul by easy. apply (conj eq_refl). clear -H' ; lia. } assert (e' = Z.min (Z.div2 (Zdigits beta (Zpos mx) + ex) - Zpos prec) (Z.div2 ex)) as He1'. { rewrite He1. unfold e1. rewrite <- Z.sub_min_distr_l, Zminus_0_r. rewrite <- Z.min_mono. replace (ex - _)%Z with (Zdigits beta (Zpos mx) + ex + (-Zpos prec) * 2)%Z by ring. now rewrite Zdiv2_div, Z.div_add, <- Zdiv2_div. intros x y ; apply f_equal. intros x y. rewrite 2!Zdiv2_div. now apply Z.div_le_mono. } assert (2 * e' <= ex)%Z as He. { rewrite He1'. set (foo := (Z.div2 _ - _)%Z). clear. assert (Z.min foo (Z.div2 ex) <= Z.div2 ex)%Z as H by apply Z.le_min_r. generalize (Zdiv2_odd_eqn ex). destruct Z.odd ; intros ; lia. } generalize (Sqrt.Fsqrt_core_correct beta (Zpos mx) ex e' eq_refl He). unfold Sqrt.Fsqrt_core. set (m' := match s' with Z0 => _ | _ => _ end). assert (m' = Zpos mx * Zpower beta (ex - 2 * e'))%Z as ->. { rewrite <- He2. destruct s' as [|p|p]. now rewrite Zmult_1_r. easy. clear -He He2 ; lia. } destruct Z.sqrtrem as [m' r]. set (lz := if Zeq_bool _ _ then _ else _). intros H1. assert (Zpos prec <= Zdigits beta m')%Z as H2. { assert (e' <= Z.div2 (Zdigits beta (Zpos mx) + ex + 1) - Zpos prec)%Z as He'. { rewrite He1'. apply Z.le_trans with (1 := Z.le_min_l _ _). apply Zplus_le_compat_r. rewrite 2!Zdiv2_div. apply Z.div_le_mono. easy. apply Z.le_succ_diag_r. } refine (_ (cexp_inbetween_float _ (FLX_exp (Zpos prec)) _ _ _ _ _ H1 (or_introl _))). unfold cexp, FLX_exp. rewrite (Sqrt.mag_sqrt_F2R beta (Zpos mx) ex eq_refl). clear -He He' ; intros ; lia. apply sqrt_lt_R0. now apply F2R_gt_0. unfold cexp, FLX_exp. now rewrite (Sqrt.mag_sqrt_F2R beta (Zpos mx) ex eq_refl). } destruct m' as [|p|p]. now elim H1. apply (Fround_at_prec_correct beta mode prec false p e'). apply sqrt_lt_R0. apply FtoR_Rpos. rewrite convert_location_bij. now rewrite FtoR_split. rewrite <- digits_conversion. intros H3. elim (Z.lt_irrefl _ (Z.le_lt_trans _ _ _ H2 H3)). destruct (Bracket.inbetween_float_bounds _ _ _ _ _ H1) as (_, H5). elim (Rlt_not_le _ _ H5). apply Rle_trans with R0. apply F2R_le_0. unfold Fnum. now apply (Zlt_le_succ (Zneg p)). apply sqrt_ge_0. Qed. interval-4.11.1/src/Float/Primitive_ops.v000066400000000000000000003342611470547631300203210ustar00rootroot00000000000000From Coq Require Import ZArith Reals. Require Import Int63Compat. From Coq Require Import Floats Psatz. From Flocq Require Import Zaux Raux BinarySingleNaN PrimFloat Sterbenz Mult_error. (* Compatibility workaround, remove once requiring Coq >= 8.15 *) Module Import Compat. Definition ldexp f (_ : Z) : float := f. Definition frexp (f : float) := (f, Z0). End Compat. Import FloatOps. Module Import Z. Notation ldexp := ldexp. Notation frexp := frexp. End Z. Import Floats. Import Zaux BinarySingleNaN. Require Import Missing.Stdlib Missing.Flocq. Require Import Xreal. Require Import Basic. Require Import Sig. Require Generic_proof. Module PrimitiveFloat <: FloatOps. Definition radix := radix2. Definition sensible_format := true. Definition type := PrimFloat.float. Definition toF x : float radix2 := match Prim2SF x with | S754_zero _ => Fzero | S754_infinity _ | S754_nan => Basic.Fnan | S754_finite s m e => Basic.Float s m e end. Definition precision := Z. Definition sfactor := Z. (* TODO: change to Int63? *) Definition prec p := match p with Zpos q => q | _ => xH end. Definition PtoP p := Zpos p. Definition ZtoS (x : Z) := x. Definition StoZ (x : Z) := x. Definition incr_prec p i := Zplus p (Zpos i). Definition zero := zero. Definition nan := nan. Definition fromZ x := match x with | Z0 => zero | Zpos x => match (x ?= 9007199254740992)%positive (* 2^53 *) with | Lt => of_int63 (Int63.of_pos x) | _ => nan end | Zneg x => match (x ?= 9007199254740992)%positive (* 2^53 *) with | Lt => (-(of_int63 (Int63.of_pos x)))%float | _ => nan end end. Definition fromZ_UP (p : precision) x := match x with | Z0 => zero | Zpos x => match (x ?= 9007199254740992)%positive (* 2^53 *) with | Lt => of_int63 (Int63.of_pos x) | _ => let x := Zpos x in let d := Z.log2 x in let e := (d - 52)%Z in let m := Z.shiftr x e in Z.ldexp (of_int63 (of_Z m + 1)) e end | Zneg x => match (x ?= 9007199254740992)%positive (* 2^53 *) with | Lt => (-(of_int63 (Int63.of_pos x)))%float | _ => let x := Zpos x in let d := Z.log2 x in let e := (d - 52)%Z in let m := Z.shiftr x e in next_up (Z.ldexp (-(of_int63 (of_Z m))) e) end end. Definition fromZ_DN (p : precision) x := match x with | Z0 => zero | Zpos x => match (x ?= 9007199254740992)%positive (* 2^53 *) with | Lt => of_int63 (Int63.of_pos x) | _ => let x := Zpos x in let d := Z.log2 x in let e := (d - 52)%Z in let m := Z.shiftr x e in next_down (Z.ldexp (of_int63 (of_Z m)) e) end | Zneg x => match (x ?= 9007199254740992)%positive (* 2^53 *) with | Lt => (-(of_int63 (Int63.of_pos x)))%float | _ => let x := Zpos x in let d := Z.log2 x in let e := (d - 52)%Z in let m := Z.shiftr x e in Z.ldexp (-(of_int63 (Int63.of_Z m + 1))) e end end. Definition fromF (f : float radix) := match f with | Basic.Fnan => nan | Basic.Fzero => zero | Basic.Float s m e => if ((e <=? 971)%Z && (-1074 <=? e)%Z && (Pos.size m <=? 53)%positive)%bool then let m := of_int63 (Int63.of_pos m) in let e := Int63.of_Z (e + FloatOps.shift) in let f := ldshiftexp m e in if s then (- f)%float else f else nan end. Definition classify x := match classify x with | NaN => Sig.Fnan | PInf => Fpinfty | NInf => Fminfty | _ => Freal end. Definition real x := match PrimFloat.classify x with | PInf | NInf | NaN => false | _ => true end. Definition is_nan x := match PrimFloat.classify x with | NaN => true | _ => false end. Definition mag x := let (_, e) := PrimFloat.frshiftexp x in (Int63.to_Z e - FloatOps.shift)%Z. Definition valid_ub x := negb (PrimFloat.eqb x neg_infinity). Definition valid_lb x := negb (PrimFloat.eqb x infinity). Definition Xcomparison_of_float_comparison c := match c with | FEq => Xeq | FLt => Xlt | FGt => Xgt | FNotComparable => Xund end. Definition cmp x y := Xcomparison_of_float_comparison (compare x y). Definition min x y := match (x ?= y)%float with | FEq | FLt => x | FGt => y | FNotComparable => nan end. Definition max x y := match (x ?= y)%float with | FEq | FGt => x | FLt => y | FNotComparable => nan end. Definition neg x := (- x)%float. Definition abs x := abs x. Definition scale x e := ldshiftexp x (Int63.of_Z e + Int63.of_Z FloatOps.shift)%int63. Definition pow2_UP (_ : precision) e := if Zle_bool emax e then infinity else scale (fromZ 1) (Z.max e (-1074)). Definition div2 x := (x / 2)%float. Definition add_UP (_ : precision) x y := next_up (x + y). Definition add_DN (_ : precision) x y := next_down (x + y). Definition sub_UP (_ : precision) x y := next_up (x - y). Definition sub_DN (_ : precision) x y := next_down (x - y). Definition mul_UP (_ : precision) x y := next_up (x * y). Definition mul_DN (_ : precision) x y := next_down (x * y). Definition div_UP (_ : precision) x y := next_up (x / y). Definition div_DN (_ : precision) x y := next_down (x / y). Definition sqrt_UP (_ : precision) x := next_up (PrimFloat.sqrt x). Definition sqrt_DN (_ : precision) x := next_down (PrimFloat.sqrt x). Definition nearbyint default (mode : rounding_mode) (f : type) := if real f then let '(f', e) := frshiftexp f in if Int63.leb (of_Z (FloatOps.prec + FloatOps.shift))%int63 e then f else let m := normfr_mantissa f' in let d := (of_Z (FloatOps.prec + FloatOps.shift) - e)%int63 in let mh := (m >> d)%int63 in match mode with | rnd_ZR => if get_sign f then (- (of_int63 mh))%float else of_int63 mh | rnd_DN => if get_sign f then let f'' := (- (of_int63 mh))%float in if PrimFloat.ltb f f'' then (- (of_int63 (mh + 1)))%float else f'' else of_int63 mh | rnd_UP => if get_sign f then PrimFloat.opp (of_int63 mh) else let f'' := of_int63 mh in if PrimFloat.ltb f'' f then of_int63 (mh + 1) else f'' | rnd_NE => let fl := of_int63 mh in let f' := match (abs f - fl ?= 0.5)%float with | FLt => fl | FGt => of_int63 (mh + 1) | FEq | FNotComparable (* never happens *) => if Int63.eqb (mh land 1) 0 then fl else of_int63 (mh + 1) end in if get_sign f then (- f')%float else f' end else default. Definition nearbyint_UP := nearbyint infinity. Definition nearbyint_DN := nearbyint neg_infinity. Definition midpoint (x y : type) := let z := ((x + y) / 2)%float in if is_infinity z then (x / 2 + y / 2)%float else z. Definition toX x := FtoX (toF x). Definition toR x := proj_val (toX x). Definition convert x := FtoX (toF x). Lemma ZtoS_correct: forall prec z, (z <= StoZ (ZtoS z))%Z \/ toX (pow2_UP prec (ZtoS z)) = Xnan. Proof. now left. Qed. Lemma zero_correct : toX zero = Xreal 0. Proof. reflexivity. Qed. Lemma nan_correct : classify nan = Sig.Fnan. Proof. reflexivity. Qed. Definition BtoX (x : binary_float FloatOps.prec emax) := match x with | B754_zero _ => Xreal 0 | B754_finite s m e _ => Xreal (FtoR radix2 s m e) | _ => Xnan end. Lemma BtoX_B2R x r : BtoX x = Xreal r -> r = B2R x. Proof. case x as [s|s| |s m e B]; [ |now simpl..| ]. { now simpl; intro H; injection H. } now simpl; rewrite <-FtoR_split; intro H; injection H. Qed. Lemma B2R_BtoX : forall x, is_finite x = true -> BtoX x = Xreal (B2R x). Proof. intros [s|s| |s m e B] ; try easy. intros _. simpl. now rewrite FtoR_split. Qed. Lemma toX_Prim2B x : toX x = BtoX (Prim2B x). Proof. now unfold toX, toF; rewrite <-B2SF_Prim2B; case Prim2B. Qed. Lemma BtoX_Bopp x : BtoX (Bopp x) = (- (BtoX x))%XR. Proof. case x as [s|s| |s m e B]; [ |now simpl..| ]. { now simpl; rewrite Ropp_0. } now simpl; rewrite Generic_proof.FtoR_neg. Qed. Lemma valid_lb_correct : forall f, valid_lb f = match classify f with Fpinfty => false | _ => true end. Proof. intro f. unfold valid_lb. rewrite eqb_spec. unfold classify. rewrite classify_spec. unfold SF64classify, SFclassify. case Prim2SF; [now intros [ | ]..|now simpl| ]. now intros [ | ] m e; case Pos.eqb. Qed. Lemma valid_ub_correct : forall f, valid_ub f = match classify f with Fminfty => false | _ => true end. Proof. intro f. unfold valid_ub. rewrite eqb_spec. unfold classify. rewrite classify_spec. unfold SF64classify, SFclassify. case Prim2SF; [now intros [ | ]..|now simpl| ]. now intros [ | ] m e; case Pos.eqb. Qed. Lemma classify_correct : forall f, real f = match classify f with Freal => true | _ => false end. Proof. now intro f; unfold real, classify; case PrimFloat.classify. Qed. Lemma real_correct : forall f, real f = match toX f with Xnan => false | _ => true end. Proof. intro f. unfold real. rewrite classify_spec. unfold SF64classify, SFclassify. unfold toX, toF, FtoX. case Prim2SF; [now intros [ | ]..|reflexivity| ]. now intros [ | ] m e; case Pos.eqb. Qed. Lemma is_nan_correct : forall f, is_nan f = match classify f with Sig.Fnan => true | _ => false end. Proof. now intro f; unfold is_nan, classify; case PrimFloat.classify. Qed. Lemma real_is_finite x : real (B2Prim x) = is_finite x. Proof. case x as [s|s| |s m e B]; [now case s..|now simpl| ]. now rewrite real_correct, toX_Prim2B, Prim2B_B2Prim. Qed. Local Existing Instance Hprec. Local Existing Instance Hmax. Lemma of_int63_exact i : (Int63.to_Z i <= 2^53)%Z -> toX (of_int63 i) = Xreal (IZR (Int63.to_Z i)). Proof. rewrite toX_Prim2B, of_int63_equiv. rewrite Z.le_lteq; intros [Hi| ->]; [ |now compute]. generalize (binary_normalize_correct _ _ Hprec Hmax mode_NE (Int63.to_Z i) 0 false). simpl. rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ apply FLT.generic_format_FLT. set (f := Defs.Float _ _ _). apply (FLT.FLT_spec _ _ _ _ f); [reflexivity| |now simpl]. now rewrite Z.abs_eq; [ |apply to_Z_bounded]. } unfold Defs.F2R; simpl; rewrite Rmult_1_r. rewrite Rlt_bool_true. 2:{ rewrite Rabs_pos_eq; [ |now apply IZR_le, to_Z_bounded]. apply IZR_lt, (Z.lt_trans _ _ _ Hi). fold (2 ^ 1024)%Z; apply Zpow_facts.Zpower_lt_monotone; lia. } intros [H [H' _]]; revert H H'. case binary_normalize as [s|s| |s m e B]; [now intros <-|now simpl..| ]. now intros <- _; simpl; rewrite FtoR_split. Qed. Lemma of_int63_of_pos_exact p : (p < 2^53)%positive -> toX (of_int63 (Int63.of_pos p)) = Xreal (IZR (Zpos p)). Proof. intro H. assert (Hp : Int63.to_Z (of_pos p) = Zpos p). { replace (Int63.of_pos p) with (Int63.of_Z (Zpos p)); [ |now simpl]. rewrite of_Z_spec, Zmod_small; [now simpl|split; [now simpl| ]]. now apply (Z.lt_le_trans _ _ _ (Pos2Z.pos_lt_pos _ _ H)); compute. } rewrite of_int63_exact; rewrite Hp; [reflexivity| ]. apply (Z.le_trans _ _ _ (Z.lt_le_incl _ _ (Pos2Z.pos_lt_pos _ _ H))). now compute. Qed. Lemma toX_neg x : toX (- x) = (- (toX x))%XR. Proof. unfold toX. rewrite <-Generic_proof.Fneg_correct. f_equal. unfold toF. rewrite <-!B2SF_Prim2B, opp_equiv. now case Prim2B. Qed. Lemma fromZ_correct : forall n, (Z.abs n <= 256)%Z -> toX (fromZ n) = Xreal (IZR n). Proof. intros [ |p|p] Hp; unfold fromZ; [now simpl| | ]. { case Pos.compare_spec; intro Hp'. { now revert Hp; rewrite Hp'. } { now rewrite (of_int63_of_pos_exact _ Hp'). } lia. } case Pos.compare_spec; intro Hp'. { now revert Hp; rewrite Hp'. } { change (Xreal _) with (- (Xreal (IZR (Zpos p))))%XR. now rewrite <-(of_int63_of_pos_exact _ Hp'), toX_neg. } lia. Qed. Lemma mag_correct : forall f, (Rabs (toR f) < bpow radix2 (StoZ (mag f)))%R. Proof. intros f. unfold mag. generalize (frshiftexp_equiv f). destruct frshiftexp as [m' e']. generalize (Bfrexp_correct _ _ _ (Prim2B f)). unfold toR. rewrite toX_Prim2B. destruct (Prim2B f) as [ | | |s m e H] ; try (intros _ _ ; change (Rabs _) with (Rabs 0) ; rewrite Rabs_R0 ; apply bpow_gt_0). destruct Bfrexp as [m'' e'']. intros H1 H2. injection H2 as <- ->. simpl. specialize (H1 eq_refl). destruct H1 as [H1 H2]. specialize (H2 eq_refl). destruct H2 as [H2 H3]. simpl in H1, H3. rewrite FtoR_split, H3, H1. apply bpow_mag_gt. Qed. Lemma valid_ub_next_up x : valid_ub (next_up x) = true. Proof. rewrite valid_ub_correct. unfold classify. rewrite classify_spec. rewrite <-B2SF_Prim2B, next_up_equiv. case Prim2B as [s|s| |s m e B]; [now simpl|now case s|now simpl| ]. generalize (Bsucc_correct _ _ _ _ (B754_finite s m e B) (refl_equal _)). case Rlt_bool; [ |now intros ->]. intros [_ [H _]]; revert H. case Bsucc as [s'|s'| |s' m' e' B']; [now case s'|now simpl..| ]. intros _; simpl. now set (d := match digits2_pos m' with 53%positive => _ | _ => _ end); case s', d. Qed. Lemma valid_lb_next_down x : valid_lb (next_down x) = true. Proof. rewrite valid_lb_correct. unfold classify. rewrite classify_spec. rewrite <-B2SF_Prim2B, next_down_equiv. case Prim2B as [s|s| |s m e B]; [now simpl|now case s|now simpl| ]. generalize (Bpred_correct _ _ _ _ (B754_finite s m e B) (refl_equal _)). case Rlt_bool; [ |now intros ->]. intros [_ [H _]]; revert H. case Bpred as [s'|s'| |s' m' e' B']; [now case s'|now simpl..| ]. intros _; simpl. now set (d := match digits2_pos m' with 53%positive => _ | _ => _ end); case s', d. Qed. Lemma shiftr_pos p : let d := Z.log2 (Z.pos p) in let s := Z.shiftr (Z.pos p) (d - 52) in (0 <= d - 52 -> (s * 2 ^ (d - 52) <= Z.pos p < (s + 1) * 2 ^ (d - 52) /\ s < 2^53))%Z. Proof. intros d s. unfold s. unfold d. clear d s; intro He. rewrite (Z.shiftr_div_pow2 _ _ He). split; [split| ]. { now rewrite Zmult_comm; apply Z_mult_div_ge, pow2_pos. } { set (a := Z.pos p). set (b := (2^_)%Z). rewrite Z.mul_add_distr_r, Z.mul_1_l, Z.mul_comm. rewrite (Z_div_mod_eq a b) at 1; [ |now apply pow2_pos]. now apply Zplus_lt_compat_l, Z_mod_lt, pow2_pos. } apply (Zmult_gt_0_lt_reg_r _ _ _ (pow2_pos _ He)). rewrite Z.mul_comm. apply (Z.le_lt_trans _ _ _ (Z_mult_div_ge _ _ (pow2_pos _ He))). rewrite <-Z.pow_add_r; [ |lia|exact He]. replace (_ + _)%Z with (Z.log2 (Z.pos p) + 1)%Z by ring. now apply Z.log2_spec. Qed. Lemma Bsign_pos x r : BtoX x = Xreal r -> (0 < r)%R -> Bsign x = false. Proof. intros H H'; revert H. case x as [s|s| |s m e B]; [ |now simpl..| ]. { case s; simpl; [ |now simpl]. intro H; injection H; clear H; intro H. now exfalso; apply (Rlt_irrefl 0); rewrite H at 2. } case s; simpl; [ |now simpl]. intro H; exfalso. injection H; clear H; intro H. revert H'; rewrite <- H. apply Rle_not_lt, Rlt_le, Generic_proof.FtoR_Rneg. Qed. Lemma fromZ_UP_correct : forall p n, valid_ub (fromZ_UP p n) = true /\ le_upper (Xreal (IZR n)) (toX (fromZ_UP p n)). Proof. intros prec [ |p|p]; unfold fromZ_UP. { now compute; split; [ |right]. } { case Pos.compare_spec; intro Hp'. { now rewrite Hp'; compute; split; [ |left; lra]. } { generalize (classify_correct (of_int63 (of_pos p))). rewrite valid_ub_correct, real_correct. rewrite (of_int63_of_pos_exact _ Hp'). now intro H; split; [revert H; case classify|now right]. } set (e := (_ - _)%Z). set (s := Z.shiftr _ _). assert (Pe : (0 <= e)%Z). { unfold e. apply Zle_minus_le_0. refine (proj1 (Z.log2_le_pow2 _ _ _) _); [now simpl| ]. generalize (Pos2Z.pos_lt_pos _ _ Hp'); lia. } rewrite <-(B2Prim_Prim2B (Z.ldexp _ _)) at 1; rewrite toX_Prim2B. rewrite ldexp_equiv. generalize (shiftr_pos p Pe); intros [H1 H2]; revert H1 H2; fold e s. intros [_ H1] H2. assert (Hips1 : (Int63.to_Z (of_Z s + 1) = s + 1)%Z). { generalize H2. rewrite (is_int s) at -2. intros H3. rewrite Int63.add_spec, Zmod_small; rewrite to_Z_1. easy. generalize (proj1 (Int63.to_Z_bounded (of_Z s))); revert H3. change (2^53)%Z with 9007199254740992%Z. change wB with 9223372036854775808%Z. lia. split. now apply Z.shiftr_nonneg. now apply Z.lt_trans with (1 := H2). } assert (H2' : (Int63.to_Z (of_Z s + 1) <= 2 ^ 53)%Z). { rewrite Hips1; lia. } assert (Rips := of_int63_exact _ H2'). set (f := Prim2B _). generalize (Bldexp_correct _ _ _ _ mode_NE f e). assert (Hsf : Bsign f = false). { revert Rips; unfold f. rewrite toX_Prim2B. intro H; apply (Bsign_pos _ _ H). apply IZR_lt. rewrite Hips1. apply Zle_lt_succ. now apply Z.shiftr_nonneg. } case Rlt_bool. 2:{ rewrite Hsf. change (binary_overflow _ _ _ _) with (@B2SF FloatOps.prec emax (B754_infinity false)). intro H; rewrite (B2SF_inj _ _ _ _ H), valid_ub_correct. now unfold classify; rewrite classify_spec, Prim2SF_B2Prim; split. } intros [Hr [Hf _]]; split. { rewrite valid_ub_correct. generalize (classify_correct (B2Prim (Bldexp mode_NE f e))). rewrite real_is_finite, Hf. replace (is_finite f) with true; [now case classify|symmetry]. now unfold f; rewrite <-real_is_finite, B2Prim_Prim2B, real_correct, Rips. } case_eq (BtoX (Bldexp mode_NE f e)); [now simpl|intros rx Hrx]. rewrite (BtoX_B2R _ _ Hrx); clear rx Hrx; simpl; rewrite Hr. rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ now apply mult_bpow_pos_exact_FLT; [apply generic_format_B2R| ]. } revert Rips; rewrite toX_Prim2B; fold f. intro H; rewrite <-(BtoX_B2R _ _ H); clear H. apply (Rle_trans _ _ _ (Rlt_le _ _ (IZR_lt _ _ H1))); right. rewrite mult_IZR. now fold e; apply f_equal2; [rewrite Hips1|revert Pe; case e]. } case Pos.compare_spec; intro Hp'. { now rewrite Hp'; compute; split; [ |left; lra]. } { generalize (classify_correct (of_int63 (of_pos p))). rewrite valid_ub_correct, real_correct. rewrite toX_neg. rewrite (of_int63_of_pos_exact _ Hp'). intro H; split; [ |now right]. revert H; unfold classify; rewrite !classify_spec, opp_spec. now case Prim2SF as [[ | ]|[ | ]| |[ | ]]; simpl; try now simpl; set (s := match digits2_pos m with 53%positive => _ | _ => _ end); case s. } set (e := (_ - _)%Z). set (s := Z.shiftr _ _). split; [now rewrite valid_ub_next_up| ]. assert (Pe : (0 <= e)%Z). { unfold e. apply Zle_minus_le_0. refine (proj1 (Z.log2_le_pow2 _ _ _) _); [now simpl| ]. generalize (Pos2Z.pos_lt_pos _ _ Hp'); lia. } rewrite toX_Prim2B, next_up_equiv, ldexp_equiv, opp_equiv. generalize (shiftr_pos p Pe); intros [H1 H2]; revert H1 H2; fold e s. intros [H1 _] H2. assert (Rips : toX (of_int63 (of_Z s)) = Xreal (IZR s)). { generalize H2. rewrite is_int at -2. intros H3. apply of_int63_exact. now apply Z.lt_le_incl. split. now apply Z.shiftr_nonneg. now apply Z.lt_trans with (1 := H2). } set (f := Prim2B _). change (Z.neg p) with (- (Z.pos p))%Z; rewrite opp_IZR. generalize (Bldexp_correct _ _ _ _ mode_NE (Bopp f) e). rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ now apply mult_bpow_pos_exact_FLT; [apply generic_format_B2R| ]. } set (f' := Bldexp _ _ _). case Rlt_bool_spec; intro Hlt. { intros [Hr [Hf Hs]]. generalize (Bsucc_correct _ _ _ _ f'). rewrite Hf, is_finite_Bopp. unfold f; rewrite <-real_is_finite, B2Prim_Prim2B, real_correct, Rips. intro H; generalize (H (eq_refl _)); clear H. case Rlt_bool. 2:{ change (SpecFloat.S754_infinity false) with (@B2SF FloatOps.prec emax (B754_infinity false)). now intro H; rewrite (B2SF_inj _ _ _ _ H); clear H. } intros [Hr' [Hf' _]]. replace (BtoX _) with (Xreal (B2R (Bsucc f'))). 2:{ revert Hf'. rewrite <-real_is_finite, real_correct, toX_Prim2B, Prim2B_B2Prim. case_eq (BtoX (Bsucc f')); [now simpl|intros r'' Hr'']. now rewrite (BtoX_B2R _ _ Hr''). } simpl; rewrite Hr', Hr. refine (Rle_trans _ _ _ _ (Ulp.succ_ge_id _ _ _)). rewrite B2R_Bopp, <-Ropp_mult_distr_l. apply Ropp_le_contravar. revert Rips; rewrite toX_Prim2B; fold f; intro H. rewrite <-(BtoX_B2R _ _ H); clear H. refine (Rle_trans _ _ _ _ (IZR_le _ _ H1)); fold e; right. rewrite mult_IZR. now fold e; apply f_equal2; [ |revert Pe; case e]. } intro Hf'. apply (le_upper_trans _ (BtoX (Bopp Bmax_float))). 2:{ revert Hf'. now case f' as [sf'|sf'| |sf' mf' ef' Bf']; unfold B2SF; case Bsign; (try now intro H; discriminate H); [ | ]; intro H; injection H; clear H; intros ->; [right| ]. } rewrite BtoX_Bopp; apply Ropp_le_contravar. generalize (IZR_le _ _ H1); apply Rle_trans. revert Rips; rewrite toX_Prim2B; fold f e; intro Rips. revert Hlt. rewrite B2R_Bopp, <-Ropp_mult_distr_l, Rabs_Ropp. rewrite mult_IZR, <-(BtoX_B2R _ _ Rips). rewrite Rabs_mult. rewrite Rabs_pos_eq; [ |now apply IZR_le, Z.shiftr_nonneg]. rewrite Rabs_pos_eq; [ |now apply bpow_ge_0]. rewrite <-(IZR_Zpower _ _ Pe). apply Rle_trans; compute; lra. Qed. Lemma fromZ_DN_correct : forall p n, valid_lb (fromZ_DN p n) = true /\ le_lower (toX (fromZ_DN p n)) (Xreal (IZR n)). Proof. intros prec [ |p|p]; unfold fromZ_DN. { now compute; split; [ |right]. } { case Pos.compare_spec; intro Hp'. { now rewrite Hp'; compute; split; [ |left; lra]. } { generalize (classify_correct (of_int63 (of_pos p))). rewrite valid_lb_correct, real_correct. rewrite (of_int63_of_pos_exact _ Hp'). now intro H; split; [revert H; case classify|right]. } set (e := (_ - _)%Z). set (s := Z.shiftr _ _). split; [now rewrite valid_lb_next_down| ]. assert (Pe : (0 <= e)%Z). { unfold e. apply Zle_minus_le_0. refine (proj1 (Z.log2_le_pow2 _ _ _) _); [now simpl| ]. generalize (Pos2Z.pos_lt_pos _ _ Hp'); lia. } rewrite toX_Prim2B, next_down_equiv, ldexp_equiv. generalize (shiftr_pos p Pe); intros [H1 H2]; revert H1 H2; fold e s. intros [H1 _] H2. assert (Rips: toX (of_int63 (of_Z s)) = Xreal (IZR s)). { generalize H2. rewrite (is_int s) at -2. intros H3. apply of_int63_exact. generalize (proj1 (Int63.to_Z_bounded (of_Z s))); revert H3. change (2^53)%Z with 9007199254740992%Z. change wB with 9223372036854775808%Z. lia. split. now apply Z.shiftr_nonneg. now apply Z.lt_trans with (1 := H2). } set (f := Prim2B _). generalize (Bldexp_correct _ _ _ _ mode_NE f e). rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ now apply mult_bpow_pos_exact_FLT; [apply generic_format_B2R| ]. } set (f' := Bldexp _ _ _). case Rlt_bool_spec; intro Hlt. { intros [Hr [Hf Hs]]. generalize (Bpred_correct _ _ _ _ f'). rewrite Hf. unfold f; rewrite <-real_is_finite, B2Prim_Prim2B, real_correct. rewrite Rips. intro H; generalize (H (eq_refl _)); clear H. case Rlt_bool. 2:{ change (SpecFloat.S754_infinity true) with (@B2SF FloatOps.prec emax (B754_infinity true)). now intro H; rewrite (B2SF_inj _ _ _ _ H); clear H. } intros [Hr' [Hf' _]]. replace (BtoX _) with (Xreal (B2R (Bpred f'))). 2:{ revert Hf'. rewrite <-real_is_finite, real_correct, toX_Prim2B, Prim2B_B2Prim. case_eq (BtoX (Bpred f')); [now simpl|intros r'' Hr'']. now rewrite (BtoX_B2R _ _ Hr''). } simpl; rewrite Hr', Hr. apply Ropp_le_contravar, (Rle_trans _ _ _ (Ulp.pred_le_id _ _ _)). revert Rips; rewrite toX_Prim2B; fold f; intro H. rewrite <-(BtoX_B2R _ _ H); clear H. refine (Rle_trans _ _ _ _ (IZR_le _ _ H1)); fold e; right. rewrite mult_IZR. now fold e; apply f_equal2; [ |revert Pe; case e]. } intro Hf'. apply (le_lower_trans _ (BtoX (Bmax_float))). { revert Hf'. now case f' as [sf'|sf'| |sf' mf' ef' Bf']; unfold B2SF; case Bsign; (try now intro H; discriminate H); [ | ]; intro H; injection H; clear H; intros ->; [ |right]. } apply Ropp_le_contravar. generalize (IZR_le _ _ H1); apply Rle_trans. revert Rips; rewrite toX_Prim2B; fold f e; intro Rips. revert Hlt. rewrite mult_IZR, <-(BtoX_B2R _ _ Rips). rewrite Rabs_mult. rewrite Rabs_pos_eq; [ |now apply IZR_le, Z.shiftr_nonneg]. rewrite Rabs_pos_eq; [ |now apply bpow_ge_0]. rewrite <-(IZR_Zpower _ _ Pe). apply Rle_trans; compute; lra. } case Pos.compare_spec; intro Hp'. { now rewrite Hp'; compute; split; [ |left; lra]. } { generalize (classify_correct (- of_int63 (of_pos p))). rewrite valid_lb_correct, real_correct. generalize (of_int63_of_pos_exact _ Hp'). rewrite !toX_Prim2B, opp_equiv, BtoX_Bopp; intros ->. now intro H; split; [revert H; case classify|right]. } set (e := (_ - _)%Z). set (s := Z.shiftr _ _). assert (Pe : (0 <= e)%Z). { unfold e. apply Zle_minus_le_0. refine (proj1 (Z.log2_le_pow2 _ _ _) _); [now simpl| ]. generalize (Pos2Z.pos_lt_pos _ _ Hp'); lia. } rewrite <-(B2Prim_Prim2B (Z.ldexp _ _)) at 1; rewrite toX_Prim2B. rewrite ldexp_equiv, opp_equiv. rewrite Bldexp_Bopp_NE. rewrite BtoX_Bopp. change (Z.neg p) with (- (Z.pos p))%Z; rewrite opp_IZR. generalize (shiftr_pos p Pe); intros [H1 H2]; revert H1 H2; fold e s. intros [_ H1] H2. assert (Hips1 : (Int63.to_Z (of_Z s + 1) = s + 1)%Z). { generalize H2. rewrite (is_int s) at -2. intros H3. rewrite Int63.add_spec, Zmod_small; rewrite to_Z_1. easy. generalize (proj1 (Int63.to_Z_bounded (of_Z s))); revert H3. change (2^53)%Z with 9007199254740992%Z. change wB with 9223372036854775808%Z. lia. split. now apply Z.shiftr_nonneg. now apply Z.lt_trans with (1 := H2). } assert (H2' : (Int63.to_Z (of_Z s + 1) <= 2 ^ 53)%Z). { rewrite Hips1; lia. } assert (Rips := of_int63_exact _ H2'). set (f := Prim2B _). generalize (Bldexp_correct _ _ _ _ mode_NE f e). assert (Hsf : Bsign f = false). { revert Rips; unfold f. rewrite toX_Prim2B. intro H; apply (Bsign_pos _ _ H). apply IZR_lt. rewrite Hips1. apply Zle_lt_succ. now apply Z.shiftr_nonneg. } case Rlt_bool. 2:{ rewrite Hsf. change (binary_overflow _ _ _ _) with (@B2SF FloatOps.prec emax (B754_infinity false)). intro H; rewrite (B2SF_inj _ _ _ _ H), valid_lb_correct. now unfold classify; rewrite classify_spec, Prim2SF_B2Prim; split. } intros [Hr [Hf _]]; split. { rewrite valid_lb_correct. generalize (classify_correct (B2Prim (Bopp (Bldexp mode_NE f e)))). rewrite real_is_finite, is_finite_Bopp, Hf. replace (is_finite f) with true; [now case classify|symmetry]. now unfold f; rewrite <-real_is_finite, B2Prim_Prim2B, real_correct, Rips. } case_eq (BtoX (Bldexp mode_NE f e)); [now simpl|intros rx Hrx]. do 2 apply Ropp_le_contravar. rewrite (BtoX_B2R _ _ Hrx); clear rx Hrx; simpl; rewrite Hr. rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ now apply mult_bpow_pos_exact_FLT; [apply generic_format_B2R| ]. } revert Rips; rewrite toX_Prim2B; fold f. intro H; rewrite <-(BtoX_B2R _ _ H); clear H. apply (Rle_trans _ _ _ (Rlt_le _ _ (IZR_lt _ _ H1))); right. rewrite mult_IZR. now fold e; apply f_equal2; [rewrite Hips1|revert Pe; case e]. Qed. Lemma cmp_correct : forall x y, cmp x y = match classify x, classify y with | Sig.Fnan, _ | _, Sig.Fnan => Xund | Fminfty, Fminfty => Xeq | Fminfty, _ => Xlt | _, Fminfty => Xgt | Fpinfty, Fpinfty => Xeq | _, Fpinfty => Xlt | Fpinfty, _ => Xgt | Freal, Freal => Xcmp (toX x) (toX y) end. Proof. intros x y. unfold cmp, classify, toX, toF. rewrite compare_equiv. rewrite !classify_spec, <-!B2SF_Prim2B. set (fx := Prim2B x). set (fy := Prim2B y). generalize (Bcompare_correct _ _ fx fy). case fx; [intros [ | ]..| |intros [ | ] mx ex Hx]; (case fy; [intros [ | ]..| |intros [ | ] my ey Hy]); intro Hcmp; try rewrite (Hcmp eq_refl eq_refl); simpl; unfold Defs.F2R; simpl; try rewrite !FtoR_split; simpl; unfold Defs.F2R; simpl; repeat (replace match (if match _ with 53%positive => true | _ => _ end then _ else _) with PInf | NInf | NaN => _ | _ => Freal end with Freal; [ |now case match _ with 53%positive => true | _ => _ end]); try reflexivity; now case Rcompare. Qed. Definition float_comparison_of_Xcomparison c := match c with | Xeq => FEq | Xlt => FLt | Xgt => FGt | Xund => FNotComparable end. Lemma compare_cmp x y : compare x y = float_comparison_of_Xcomparison (cmp x y). Proof. now unfold cmp; case compare. Qed. Lemma min_correct : forall x y, match classify x, classify y with | Sig.Fnan, _ | _, Sig.Fnan => classify (min x y) = Sig.Fnan | Fminfty, _ | _, Fminfty => classify (min x y) = Fminfty | Fpinfty, _ => min x y = y | _, Fpinfty => min x y = x | Freal, Freal => toX (min x y) = Xmin (toX x) (toX y) end. Proof. intros x y. unfold min. rewrite compare_cmp, cmp_correct. unfold classify. rewrite !classify_spec. unfold toX, toF. set (fx := Prim2SF x). set (fy := Prim2SF y). rewrite <-(SF2Prim_Prim2SF x). rewrite <-(SF2Prim_Prim2SF y). generalize (Prim2SF_valid x). generalize (Prim2SF_valid y). fold fx; fold fy. case fx; [intros [ | ]..| |intros [ | ] mx ex]; (case fy; [intros [ | ]..| |intros [ | ] my ey]); intros vx vy; try (set (sf := SF2Prim _)); try (set (sf' := SF2Prim _)); simpl; try reflexivity; repeat (replace match (if match _ with 53%positive => true | _ => _ end then _ else _) with PInf | NInf | NaN => _ | _ => Freal end with Freal; [ |now case match _ with 53%positive => true | _ => _ end]); try reflexivity; rewrite Rmin_compare; case Rcompare; simpl; unfold sf; try unfold sf'; now repeat rewrite Prim2SF_SF2Prim. Qed. (* TODO: move in Flocq.Raux *) Lemma Rmax_compare x y : Rmax x y = match Rcompare x y with Lt => y | _ => x end. Proof. rewrite <-(Ropp_involutive (Rmax _ _)) at 1. rewrite Ropp_Rmax. rewrite Rmin_compare. case Rcompare_spec; case Rcompare_spec; lra. Qed. Lemma max_correct : forall x y, match classify x, classify y with | Sig.Fnan, _ | _, Sig.Fnan => classify (max x y) = Sig.Fnan | Fpinfty, _ | _, Fpinfty => classify (max x y) = Fpinfty | Fminfty, _ => max x y = y | _, Fminfty => max x y = x | Freal, Freal => toX (max x y) = Xmax (toX x) (toX y) end. Proof. intros x y. unfold max. rewrite compare_cmp, cmp_correct. unfold classify. rewrite !classify_spec. unfold toX, toF. set (fx := Prim2SF x). set (fy := Prim2SF y). rewrite <-(SF2Prim_Prim2SF x). rewrite <-(SF2Prim_Prim2SF y). generalize (Prim2SF_valid x). generalize (Prim2SF_valid y). fold fx; fold fy. case fx; [intros [ | ]..| |intros [ | ] mx ex]; (case fy; [intros [ | ]..| |intros [ | ] my ey]); intros vx vy; try (set (sf := SF2Prim _)); try (set (sf' := SF2Prim _)); simpl; try reflexivity; repeat (replace match (if match _ with 53%positive => true | _ => _ end then _ else _) with PInf | NInf | NaN => _ | _ => Freal end with Freal; [ |now case match _ with 53%positive => true | _ => _ end]); try reflexivity; rewrite Rmax_compare; case Rcompare; simpl; unfold sf; try unfold sf'; now repeat rewrite Prim2SF_SF2Prim. Qed. Lemma neg_correct : forall x, match classify x with | Freal => toX (neg x) = Xneg (toX x) | Sig.Fnan => classify (neg x) = Sig.Fnan | Fminfty => classify (neg x) = Fpinfty | Fpinfty => classify (neg x) = Fminfty end. Proof. intro x. unfold classify. rewrite !classify_spec. unfold toX, toF. unfold neg. rewrite opp_spec. case Prim2SF; [intros [ | ]..| |intros [ | ] mx ex]; try reflexivity; simpl; try (rewrite Ropp_0; reflexivity); unfold FtoR; repeat (replace match (if match _ with 53%positive => true | _ => _ end then _ else _) with PInf | NInf | NaN => _ | _ => Freal end with Freal; [ |now case match _ with 53%positive => true | _ => _ end]); case ex => [ |pex|pex]; unfold Rdiv; try rewrite Ropp_mult_distr_l; try rewrite <-opp_IZR; now try rewrite Zopp_mult_distr_l. Qed. Lemma abs_correct : forall x, toX (abs x) = Xabs (toX x) /\ (valid_ub (abs x) = true). Proof. intro x. unfold abs. unfold toX, toF. rewrite <-(SF2Prim_Prim2SF (PrimFloat.abs x)) at 2. generalize (Prim2SF_valid (PrimFloat.abs x)). rewrite abs_spec. rewrite valid_ub_correct. unfold classify. rewrite classify_spec. intro H. rewrite (Prim2SF_SF2Prim _ H). set (fx := Prim2SF x). case fx; [intros [ | ]..| |intros [ | ] mx ex]; simpl; try rewrite Rabs_R0; try (now split); repeat (replace match (if match _ with 53%positive => true | _ => _ end then _ else _) with PInf | NInf | NaN => _ | _ => Freal end with Freal; [ |now case match _ with 53%positive => true | _ => _ end]); now rewrite Generic_proof.FtoR_abs. Qed. Local Existing Instance PrimFloat.Hprec. Local Existing Instance PrimFloat.Hmax. Lemma Bdiv2_correct x : is_finite x = true -> let x2 := Bdiv mode_NE x (Prim2B 2) in B2R x2 = Generic_fmt.round radix2 (FLT.FLT_exp (3 - emax - FloatOps.prec) FloatOps.prec) (round_mode mode_NE) (B2R x / 2) /\ is_finite x2 = true /\ Bsign x2 = Bsign x /\ (Rabs (B2R x2) <= Rabs (B2R x))%R. Proof. set (b2 := Prim2B 2). assert (Hb2 : { H | b2 = B754_finite false 4503599627370496 (-51) H }). { now compute; eexists. } assert (Nz2 : B2R b2 <> 0%R). { compute; lra. } case x => [sx|sx| |sx mx ex Hmex]; [ |intro H; discriminate H..| ]; intros _ x2. { unfold x2. elim Hb2 => Hb2f ->. simpl; unfold Rdiv; rewrite Rabs_R0, Rmult_0_l. rewrite Generic_fmt.round_0; [ |now apply Generic_fmt.valid_rnd_N]. now split; [ |split; [ |split; [case sx|right]]]. } generalize (Bdiv_correct _ _ Hprec Hmax mode_NE (B754_finite sx mx ex Hmex) b2 Nz2). fold x2. set (fexp := FLT.FLT_exp _ _). set (m := round_mode _). set (rx := B2R (B754_finite sx mx ex _)). replace (B2R _) with 2%R; [ |compute; lra]. cut ((Rabs (Generic_fmt.round radix2 fexp m (rx / 2)) <= Rabs rx)%R). { intro Hrx2rx. rewrite Rlt_bool_true. 2:{ generalize (abs_B2R_lt_emax _ _ (B754_finite false mx ex Hmex)). apply Rle_lt_trans. revert Hrx2rx. unfold rx, B2R; rewrite <-!FtoR_split. now rewrite !Generic_proof.FtoR_abs. } simpl. intros [-> [Fx2 Sx2]]. split; [reflexivity|split; [exact Fx2|split; [ |exact Hrx2rx]]]. now rewrite Sx2; [case sx|revert Fx2; case x2]. } case (Rlt_or_le rx 0) => Hrx. { rewrite (Rabs_left1 rx); [ |now apply Rlt_le]. rewrite Rabs_left1. { apply Ropp_le_contravar. rewrite <-(Generic_fmt.round_generic radix2 fexp m rx) at 1. { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } lra. } apply generic_format_B2R. } rewrite <-(Generic_fmt.round_0 radix2 fexp m). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } lra. } rewrite (Rabs_pos_eq _ Hrx). rewrite Rabs_pos_eq. { rewrite <-(Generic_fmt.round_generic radix2 fexp m rx) at 2. { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } lra. } apply generic_format_B2R. } rewrite <-(Generic_fmt.round_0 radix2 fexp m). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } lra. Qed. Lemma div2_correct : forall x, sensible_format = true -> (1 / 256 <= Rabs (toR x))%R -> toX (div2 x) = Xdiv (toX x) (Xreal 2). Proof. intros x _. unfold toR, toX, toF. rewrite <-!B2SF_Prim2B. unfold div2. rewrite div_equiv. set (bx := Prim2B x). set (b2 := Prim2B 2). case bx => [sx|sx| |sx mx ex Hmex]; clear x bx; try (simpl; change R0 with 0%R; rewrite Rabs_R0; intro H; exfalso; lra); [ ]. pose (bx := B754_finite sx mx ex Hmex). intro Hx. unfold Xdiv, Xdiv'; rewrite is_zero_false; [ |lra]. elim (Bdiv2_correct bx eq_refl). fold b2. set (x2 := Bdiv _ _ _). intros Rx2 [Fx2 _]; revert Rx2 Fx2. rewrite Generic_fmt.round_generic. 2:{ now apply Generic_fmt.valid_rnd_N. } 2:{ unfold Rdiv; change (/ 2)%R with (bpow radix2 (-1)). apply mult_bpow_exact_FLT. { apply generic_format_B2R. } rewrite Z.le_sub_le_add_l, <-Z.le_sub_le_add_r; simpl. apply mag_ge_bpow. unfold B2R. revert Hx. rewrite <-FtoR_split. apply Rle_trans. compute; lra. } unfold B2SF at 2, FtoX. unfold B2R at 2, bx; rewrite <-FtoR_split => <-. case x2 => [sx2|sx2| |sx2 mx2 ex2 Hmex2]; [reflexivity|intro H; discriminate H..|intros _]. now unfold B2R; rewrite <-FtoR_split. Qed. Lemma le_upper_succ_finite s m e B : le_upper (@FtoX radix2 (Basic.Float s m e)) (@FtoX radix2 match B2SF (Bsucc (B754_finite s m e B)) with | S754_zero _ => Fzero | S754_finite s m e => Basic.Float s m e | _ => Basic.Fnan end). Proof. set (bx := B754_finite _ _ _ _). generalize (Bsucc_correct _ _ Hprec Hmax bx (eq_refl _)). case Rlt_bool; [ |now intros ->]. intros [HR [HF HS]]. revert HR. unfold B2R at 2, bx. rewrite <-FtoR_split. case Bsucc as [sx|sx| |sx mx ex Bx]; simpl; [ |now simpl..| ]. { set (x' := FtoR _ _ _ _). intro H. apply (Rle_trans _ _ _ (Ulp.succ_ge_id radix2 (SpecFloat.fexp FloatOps.prec emax) _)). now rewrite <-H; right. } rewrite <-FtoR_split => ->. apply Ulp.succ_ge_id. Qed. Lemma add_UP_correct : forall p x y, valid_ub x = true -> valid_ub y = true -> (valid_ub (add_UP p x y) = true /\ le_upper (Xadd (toX x) (toX y)) (toX (add_UP p x y))). Proof. intros p x y. unfold add_UP. intros Vx Vy; split; [now rewrite valid_ub_next_up| ]; revert Vx Vy. rewrite !valid_ub_correct. unfold classify. rewrite !classify_spec. unfold toX, toF. rewrite <-!B2SF_Prim2B. rewrite next_up_equiv, add_equiv. case_eq (Prim2B x); [intros sx|intros [ | ]| |intros sx mx ex Bx]; intro Hx; try (intros H; discriminate H); intros _. { rewrite Xadd_0_l. case_eq (Prim2B y); [intros [ | ]|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _; [ | |now simpl..| ]; [case sx; compute; lra..| ]. replace (Bplus _ _ _) with (Prim2B y); [ ]. rewrite Hy. apply le_upper_succ_finite. } { now intros _; case Prim2B; [intros [ | ]|intros [ | ]| | ]. } { now intros _; case Prim2B; [intros [ | ]|intros [ | ]| | ]. } case_eq (Prim2B y); [intros sy|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _. { rewrite Xadd_0_r. replace (Bplus _ _ _) with (Prim2B x). rewrite Hx. apply le_upper_succ_finite. } { now case sx. } { now simpl. } unfold B2SF at 1 2. rewrite <-Hx, <-Hy. set (b_x := Prim2B x). set (b_y := Prim2B y). set (b_xpy := Bplus _ _ _). generalize (Bsucc_correct _ _ Hprec Hmax b_xpy). assert (Fx : is_finite b_x = true). { now unfold b_x; revert Hx; case Prim2B. } assert (Fy : is_finite b_y = true). { now unfold b_y; revert Hy; case Prim2B. } generalize (Bplus_correct _ _ Hprec Hmax mode_NE b_x b_y Fx Fy). fold b_xpy. assert (Hrx : B2R b_x = FtoR radix2 sx mx ex). { now unfold b_x, B2R; rewrite Hx, <-FtoR_split. } assert (Hry : B2R b_y = FtoR radix2 sy my ey). { now unfold b_y, B2R; rewrite Hy, <-FtoR_split. } case Rlt_bool_spec => Hb. { intros [Rxpy [Fxpy Sxpy]]. intro H; generalize (H Fxpy); clear H. case Rlt_bool; [ |now intros ->]. set (b_s := Bsucc _). case_eq b_s; [intro ss..| |intros ss ms es Hes]; intro Hs. { intros [Rs _]; revert Rs; simpl => ->. rewrite Rxpy, Hrx, Hry. apply Ulp.succ_round_ge_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } { now case ss. } { now simpl. } intros [Rs _]; revert Rs; simpl. rewrite <-FtoR_split => ->. rewrite Rxpy, Hrx, Hry. apply Ulp.succ_round_ge_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } change (binary_overflow _ _ _ _) with (S754_infinity (Bsign b_x)). intros [Hxpy Sxy] _. revert Hxpy. case_eq b_xpy; [intro sxpy..| |intros sxpy mxpy expy Hexpy]; intro Hxpy; try (intro H; discriminate H); [simpl]. case sxpy; [ |now simpl]. unfold B2SF, FtoX, le_upper. intro H; inversion H as (Hsx); clear H. assert (Hsx' : Bsign b_x = sx). { now unfold b_x; rewrite Hx. } assert (Hsy' : Bsign b_y = sy). { now unfold b_y; rewrite Hy. } revert Hsx Sxy. rewrite !Hsx', Hsy'. intro Hsx''; rewrite <-Hsx''; intro Hsy''. revert Hb; rewrite Hrx, Hry, <-Hsx'', <-Hsy''. set (sum := (_ + _)%R). rewrite Rabs_left1. 2:{ set (fexp := SpecFloat.fexp _ _). set (rnd := round_mode _). rewrite <-(Generic_fmt.round_0 radix2 fexp rnd). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } unfold sum. generalize (Generic_proof.FtoR_Rneg radix2 mx ex). generalize (Generic_proof.FtoR_Rneg radix2 my ey). lra. } rewrite <-(Ropp_involutive (bpow _ _)). intro H; apply Ropp_le_cancel in H; revert H. unfold round_mode. set (c := fun _ => _). change (SpecFloat.fexp _ _) with (FLT.FLT_exp (3 - emax - FloatOps.prec) FloatOps.prec). elim (Relative.error_N_FLT radix2 (3 - emax - FloatOps.prec) _ Hprec c sum). intros eps [eta [Heps [Heta [Hepseta ->]]]]. intro Hb. case (Req_dec eta 0) => Heta0. { revert Hb. rewrite Heta0, Rplus_0_r. intro Hb. apply Rle_trans with (-bpow radix2 emax / (1 + eps))%R. { apply (Rmult_le_reg_r (1 + eps)). { revert Heps; compute; case Rcase_abs; lra. } unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r; [exact Hb| ]. revert Heps; compute; case Rcase_abs; lra. } apply (Rmult_le_reg_r (1 + eps)). { generalize (Rabs_le_inv _ _ Heps); compute; lra. } unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r. 2:{ generalize (Rabs_le_inv _ _ Heps); compute; lra. } apply Rle_trans with (FtoR radix2 true (9007199254740992 - 1) 971 * (1 + /2 * bpow radix2 (-FloatOps.prec + 1)))%R. { compute; lra. } apply Rmult_le_compat_neg_l; [compute; lra| ]. apply Rplus_le_compat_l. generalize (Rabs_le_inv _ _ Heps); intros [_ H]; exact H. } revert Hb. elim (Rmult_integral _ _ Hepseta); [ |lra]; intros ->. rewrite Rplus_0_r, Rmult_1_r. generalize (Rabs_le_inv _ _ Heta); compute; lra. Qed. Lemma le_lower_pred_finite s m e B : le_lower (@FtoX radix2 match B2SF (Bpred (B754_finite s m e B)) with | S754_zero _ => Fzero | S754_finite s m e => Basic.Float s m e | _ => Basic.Fnan end) (@FtoX radix2 (Basic.Float s m e)). Proof. set (bx := B754_finite _ _ _ _). generalize (Bpred_correct _ _ Hprec Hmax bx (eq_refl _)). case Rlt_bool; [ |now intros ->]. intros [HR [HF HS]]. revert HR. unfold B2R at 2, bx. rewrite <-FtoR_split. case Bpred as [sx|sx| |sx mx ex Bx]; simpl; [ |now simpl..| ]. { set (x' := FtoR _ _ _ _). intro H; apply Ropp_le_contravar. refine (Rle_trans _ _ _ _ (Ulp.pred_le_id radix2 (SpecFloat.fexp FloatOps.prec emax) _)). now rewrite <-H; right. } rewrite <-FtoR_split => ->. apply Ropp_le_contravar, Ulp.pred_le_id. Qed. Lemma add_DN_correct : forall p x y, valid_lb x = true -> valid_lb y = true -> (valid_lb (add_DN p x y) = true /\ le_lower (toX (add_DN p x y)) (Xadd (toX x) (toX y))). Proof. intros p x y. unfold add_DN. intros Vx Vy; split; [now rewrite valid_lb_next_down| ]; revert Vx Vy. rewrite !valid_lb_correct. unfold classify. rewrite !classify_spec. unfold toX, toF. rewrite <-!B2SF_Prim2B. rewrite next_down_equiv, add_equiv. case_eq (Prim2B x); [intros sx|intros [ | ]| |intros sx mx ex Bx]; intro Hx; try (intros H; discriminate H); intros _. { rewrite Xadd_0_l. case_eq (Prim2B y); [intros [ | ]|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _; [ | |now simpl..| ]; [case sx; compute; lra..| ]. replace (Bplus _ _ _) with (Prim2B y); [ ]. rewrite Hy. apply le_lower_pred_finite. } { now intros _; case Prim2B; [intros [ | ]|intros [ | ]| | ]. } { now simpl. } case_eq (Prim2B y); [intros sy|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _. { rewrite Xadd_0_r. replace (Bplus _ _ _) with (Prim2B x). rewrite Hx. apply le_lower_pred_finite. } { now case sx. } { now simpl. } rewrite <-Hx, <-Hy. set (b_x := Prim2B x). set (b_y := Prim2B y). set (b_xpy := Bplus _ _ _). generalize (Bpred_correct _ _ Hprec Hmax b_xpy). assert (Fx : is_finite b_x = true). { now unfold b_x; rewrite Hx. } assert (Fy : is_finite b_y = true). { now unfold b_y; rewrite Hy. } generalize (Bplus_correct _ _ Hprec Hmax mode_NE b_x b_y Fx Fy). fold b_xpy. assert (Hrx : B2R b_x = FtoR radix2 sx mx ex). { now unfold b_x, B2R; rewrite Hx, <-FtoR_split. } assert (Hry : B2R b_y = FtoR radix2 sy my ey). { now unfold b_y, B2R; rewrite Hy, <-FtoR_split. } case Rlt_bool_spec => Hb. { intros [Rxpy [Fxpy Sxpy]]. intro H; generalize (H Fxpy); clear H. case Rlt_bool; [ |now intros ->]. set (b_s := Bpred _). case_eq b_s; [intro ss..| |intros ss ms es Hes]; intro Hs. { intros [Rs _]; revert Rs; simpl => ->. rewrite Rxpy, Hrx, Hry. unfold b_x, b_y; rewrite Hx, Hy. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } { now case ss. } { now simpl. } intros [Rs _]; revert Rs; simpl. rewrite <-FtoR_split => ->. rewrite Rxpy, Hrx, Hry. unfold b_x, b_y; rewrite Hx, Hy. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } change (binary_overflow _ _ _ _) with (S754_infinity (Bsign b_x)). intros [Hxpy Sxy] _. revert Hxpy. case_eq b_xpy; [intro sxpy..| |intros sxpy mxpy expy Hexpy]; intro Hxpy; try (intro H; discriminate H); [simpl]. case sxpy; [now simpl| ]. unfold B2SF, FtoX, le_lower. intro H; inversion H as (Hsx); clear H. assert (Hsx' : Bsign b_x = sx). { now unfold b_x; rewrite Hx. } assert (Hsy' : Bsign b_y = sy). { now unfold b_y; rewrite Hy. } revert Hsx Sxy. rewrite !Hsx', Hsy'. intro Hsx''; rewrite <-Hsx''; intro Hsy''. revert Hb; rewrite Hrx, Hry, <-Hsx'', <-Hsy''. set (sum := (_ + _)%R). rewrite Rabs_pos_eq. 2:{ set (fexp := SpecFloat.fexp _ _). set (rnd := round_mode _). rewrite <-(Generic_fmt.round_0 radix2 fexp rnd). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } unfold sum. generalize (Generic_proof.FtoR_Rpos radix2 mx ex). generalize (Generic_proof.FtoR_Rpos radix2 my ey). lra. } unfold b_x, b_y; rewrite Hx, Hy. intro H; apply Ropp_le_contravar; revert H. unfold round_mode. set (c := fun _ => _). change (SpecFloat.fexp _ _) with (FLT.FLT_exp (3 - emax - FloatOps.prec) FloatOps.prec). elim (Relative.error_N_FLT radix2 (3 - emax - FloatOps.prec) _ Hprec c sum). intros eps [eta [Heps [Heta [Hepseta ->]]]]. intro Hb. case (Req_dec eta 0) => Heta0. { revert Hb. rewrite Heta0, Rplus_0_r. intro Hb. apply Rle_trans with (bpow radix2 emax / (1 + eps))%R. 2:{ apply (Rmult_le_reg_r (1 + eps)). { revert Heps; compute; case Rcase_abs; lra. } rewrite <-Hsx'', <-Hsy''; fold sum. unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r; [exact Hb| ]. revert Heps; compute; case Rcase_abs; lra. } apply (Rmult_le_reg_r (1 + eps)). { generalize (Rabs_le_inv _ _ Heps); compute; lra. } unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r. 2:{ generalize (Rabs_le_inv _ _ Heps); compute; lra. } apply Rle_trans with (FtoR radix2 false (9007199254740992 - 1) 971 * (1 + /2 * bpow radix2 (-FloatOps.prec + 1)))%R. 2:{ compute; lra. } apply Rmult_le_compat_l; [compute; lra| ]. apply Rplus_le_compat_l. generalize (Rabs_le_inv _ _ Heps); intros [_ H]; exact H. } revert Hb. elim (Rmult_integral _ _ Hepseta); [ |lra]; intros ->. rewrite Rplus_0_r, Rmult_1_r. generalize (Rabs_le_inv _ _ Heta). rewrite <-Hsx'', <-Hsy''; fold sum; compute; lra. Qed. Lemma sub_UP_correct : forall p x y, valid_ub x = true -> valid_lb y = true -> (valid_ub (sub_UP p x y) = true /\ le_upper (Xsub (toX x) (toX y)) (toX (sub_UP p x y))). Proof. intros p x y. unfold sub_UP. intros Vx Vy; split; [now rewrite valid_ub_next_up| ]; revert Vx Vy. rewrite valid_ub_correct, valid_lb_correct. unfold classify. rewrite !classify_spec. unfold toX, toF. rewrite <-!B2SF_Prim2B. rewrite next_up_equiv, sub_equiv. case_eq (Prim2B x); [intros sx|intros [ | ]| |intros sx mx ex Bx]; intro Hx; try (intros H; discriminate H); intros _. { rewrite Xsub_split. rewrite Xadd_0_l. case_eq (Prim2B y); [intros [ | ]|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _; try (replace (SF64add _ _) with (Prim2SF y); [rewrite Hy]); try (now simpl); [case sx; compute; lra..| ]. rewrite <-Generic_proof.Fneg_correct. apply le_upper_succ_finite. } { now intros _; case Prim2B; [intros [ | ]|intros [ | ]| | ]. } { now simpl. } case_eq (Prim2B y); [intros sy|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _. { rewrite Xsub_split. rewrite <-Generic_proof.Fneg_correct. rewrite Xadd_0_r. apply le_upper_succ_finite. } { now case sx. } { now simpl. } rewrite <-Hx, <-Hy. set (b_x := Prim2B x). set (b_y := Prim2B y). set (b_xpy := Bminus _ _ _). generalize (Bsucc_correct _ _ Hprec Hmax b_xpy). assert (Fx : is_finite b_x = true). { now unfold b_x; rewrite Hx. } assert (Fy : is_finite b_y = true). { now unfold b_y; rewrite Hy. } generalize (Bminus_correct _ _ Hprec Hmax mode_NE b_x b_y Fx Fy). fold b_xpy. assert (Hrx : B2R b_x = FtoR radix2 sx mx ex). { now unfold b_x, B2R; rewrite Hx, <-FtoR_split. } assert (Hry : B2R b_y = FtoR radix2 sy my ey). { now unfold b_y, B2R; rewrite Hy, <-FtoR_split. } case Rlt_bool_spec => Hb. { intros [Rxpy [Fxpy Sxpy]]. intro H; generalize (H Fxpy); clear H. case Rlt_bool; [ |now intros ->]. set (b_s := Bsucc _). case_eq b_s; [intro ss..| |intros ss ms es Hes]; intro Hs. { intros [Rs _]; revert Rs; simpl => ->. rewrite Rxpy, Hrx, Hry. unfold b_x, b_y; rewrite Hx, Hy. apply Ulp.succ_round_ge_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } { now case ss. } { now simpl. } intros [Rs _]; revert Rs; simpl. rewrite <-FtoR_split => ->. rewrite Rxpy, Hrx, Hry. unfold b_x, b_y; rewrite Hx, Hy. apply Ulp.succ_round_ge_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } change (binary_overflow _ _ _ _) with (S754_infinity (Bsign b_x)). intros [Hxpy Sxy] _. revert Hxpy. case_eq b_xpy; [intro sxpy..| |intros sxpy mxpy expy Hexpy]; intro Hxpy; try (intro H; discriminate H); [simpl]. case sxpy; [ |now simpl]. intro H; injection H; clear H. unfold b_x, b_y; rewrite Hx, Hy. unfold Bsign. intro Hsx. unfold FtoX, le_upper, B2SF, Xbind2. assert (Hsy' : Bsign b_y = sy). { now unfold b_y; rewrite Hy. } revert Sxy. rewrite Hsx, Hsy'. unfold b_x; rewrite Hx; simpl; rewrite <-Hsx. rewrite <-(Bool.negb_involutive true); intro Hsy''. apply ssrbool.negb_inj in Hsy''. revert Hb; rewrite Hrx, Hry, <-Hsx, <-Hsy''; unfold negb. set (sum := (_ - _)%R). rewrite Rabs_left1. 2:{ set (fexp := SpecFloat.fexp _ _). set (rnd := round_mode _). rewrite <-(Generic_fmt.round_0 radix2 fexp rnd). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } unfold sum. generalize (Generic_proof.FtoR_Rneg radix2 mx ex). generalize (Generic_proof.FtoR_Rpos radix2 my ey). simpl. lra. } rewrite <-(Ropp_involutive (bpow _ _)). intro H; apply Ropp_le_cancel in H; revert H. unfold round_mode. set (c := fun _ => _). change (SpecFloat.fexp _ _) with (FLT.FLT_exp (3 - emax - FloatOps.prec) FloatOps.prec). elim (Relative.error_N_FLT radix2 (3 - emax - FloatOps.prec) _ Hprec c sum). intros eps [eta [Heps [Heta [Hepseta ->]]]]. intro Hb. case (Req_dec eta 0) => Heta0. { revert Hb. rewrite Heta0, Rplus_0_r. intro Hb. apply Rle_trans with (-bpow radix2 emax / (1 + eps))%R. { apply (Rmult_le_reg_r (1 + eps)). { revert Heps; compute; case Rcase_abs; lra. } unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r; [exact Hb| ]. revert Heps; compute; case Rcase_abs; lra. } apply (Rmult_le_reg_r (1 + eps)). { generalize (Rabs_le_inv _ _ Heps); compute; lra. } unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r. 2:{ generalize (Rabs_le_inv _ _ Heps); compute; lra. } apply Rle_trans with (FtoR radix2 true (9007199254740992 - 1) 971 * (1 + /2 * bpow radix2 (-FloatOps.prec + 1)))%R. { compute; lra. } apply Rmult_le_compat_neg_l; [compute; lra| ]. apply Rplus_le_compat_l. generalize (Rabs_le_inv _ _ Heps); intros [_ H]; exact H. } revert Hb. elim (Rmult_integral _ _ Hepseta); [ |lra]; intros ->. rewrite Rplus_0_r, Rmult_1_r. generalize (Rabs_le_inv _ _ Heta); compute; lra. Qed. Lemma sub_DN_correct : forall p x y, valid_lb x = true -> valid_ub y = true -> (valid_lb (sub_DN p x y) = true /\ le_lower (toX (sub_DN p x y)) (Xsub (toX x) (toX y))). Proof. intros p x y. unfold sub_DN. intros Vx Vy; split; [now rewrite valid_lb_next_down| ]; revert Vx Vy. rewrite valid_ub_correct, valid_lb_correct. unfold classify. rewrite !classify_spec. unfold toX, toF. rewrite <-!B2SF_Prim2B. rewrite next_down_equiv, sub_equiv. case_eq (Prim2B x); [intros sx|intros [ | ]| |intros sx mx ex Be]; intro Hx; try (intros H; discriminate H); intros _. { rewrite Xsub_split. rewrite Xadd_0_l. case_eq (Prim2B y); [intros [ | ]|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _; try (replace (SF64add _ _) with (Prim2SF y); [rewrite Hy]); try (now simpl); [case sx; compute; lra..| ]. rewrite <-Generic_proof.Fneg_correct. apply le_lower_pred_finite. } { now intros _; case Prim2B; [intros [ | ]|intros [ | ]| | ]. } { now simpl. } case_eq (Prim2B y); [intros sy|intros [ | ]| |intros sy my ey By]; intro Hy; try (intros H; discriminate H); intros _. { rewrite Xsub_split. rewrite <-Generic_proof.Fneg_correct. rewrite Xadd_0_r. apply le_lower_pred_finite. } { now case sx. } { now simpl. } rewrite <-Hx, <-Hy. set (b_x := Prim2B x). set (b_y := Prim2B y). set (b_xmy := Bminus _ _ _). generalize (Bpred_correct _ _ Hprec Hmax b_xmy). assert (Fx : is_finite b_x = true). { now unfold b_x; rewrite Hx. } assert (Fy : is_finite b_y = true). { now unfold b_y; rewrite Hy. } generalize (Bminus_correct _ _ Hprec Hmax mode_NE b_x b_y Fx Fy). fold b_xmy. assert (Hrx : B2R b_x = FtoR radix2 sx mx ex). { now unfold b_x, B2R; rewrite Hx, <-FtoR_split. } assert (Hry : B2R b_y = FtoR radix2 sy my ey). { now unfold b_y, B2R; rewrite Hy, <-FtoR_split. } case Rlt_bool_spec => Hb. { intros [Rxmy [Fxmy Sxmy]]. intro H; generalize (H Fxmy); clear H. case Rlt_bool; [ |now intros ->]. set (b_s := Bpred _). case_eq b_s; [intro ss..| |intros ss ms es Hes]; intro Hs. { intros [Rs _]; revert Rs; simpl => ->. rewrite Rxmy, Hrx, Hry. unfold b_x, b_y; rewrite Hx, Hy. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } { now case ss. } { now simpl. } intros [Rs _]; revert Rs; simpl. rewrite <-FtoR_split => ->. rewrite Rxmy, Hrx, Hry. unfold b_x, b_y; rewrite Hx, Hy. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } change (binary_overflow _ _ _ _) with (S754_infinity (Bsign b_x)). intros [Hxmy Sxy] _. revert Hxmy. case_eq b_xmy; [intro sxmy..| |intros sxmy mxmy exmy Hexmy]; intro Hxmy; try (intro H; discriminate H); [simpl]. case sxmy; [now simpl| ]. unfold FtoX. unfold le_lower, le_upper. intro H; inversion H as (Hsx); clear H. assert (Hsx' : Bsign b_x = sx). { now unfold b_x; rewrite Hx. } assert (Hsy' : Bsign b_y = sy). { now unfold b_y; rewrite Hy. } revert Hsx Sxy. rewrite !Hsx', Hsy'. intro Hsx''; rewrite <-Hsx'', <-(Bool.negb_involutive false); intro Hsy''. apply ssrbool.negb_inj in Hsy''. revert Hb; rewrite Hrx, Hry, <-Hsx'', <-Hsy''. unfold negb. set (sum := (_ - _)%R). rewrite Rabs_pos_eq. 2:{ set (fexp := SpecFloat.fexp _ _). set (rnd := round_mode _). rewrite <-(Generic_fmt.round_0 radix2 fexp rnd). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } unfold sum. generalize (Generic_proof.FtoR_Rpos radix2 mx ex). generalize (Generic_proof.FtoR_Rneg radix2 my ey). lra. } unfold round_mode. set (c := fun _ => _). change (SpecFloat.fexp _ _) with (FLT.FLT_exp (3 - emax - FloatOps.prec) FloatOps.prec). elim (Relative.error_N_FLT radix2 (3 - emax - FloatOps.prec) _ Hprec c sum). intros eps [eta [Heps [Heta [Hepseta ->]]]]. intro Hb. case (Req_dec eta 0) => Heta0. { revert Hb. rewrite Heta0, Rplus_0_r. unfold b_x, b_y; rewrite Hx, Hy. intro Hb. apply Ropp_le_contravar. apply Rle_trans with (bpow radix2 emax / (1 + eps))%R. 2: { apply (Rmult_le_reg_r (1 + eps)). { revert Heps; compute; case Rcase_abs; lra. } rewrite <-Hsx'', <-Hsy''; unfold negb; fold sum. unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r; [exact Hb| ]. revert Heps; compute; case Rcase_abs; lra. } apply (Rmult_le_reg_r (1 + eps)). { generalize (Rabs_le_inv _ _ Heps); compute; lra. } unfold Rdiv; rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r. 2:{ generalize (Rabs_le_inv _ _ Heps); compute; lra. } apply Rle_trans with (FtoR radix2 false (9007199254740992 - 1) 971 * (1 + /2 * bpow radix2 (-FloatOps.prec + 1)))%R. 2:{ compute; lra. } apply Rmult_le_compat_l; [compute; lra| ]. apply Rplus_le_compat_l. generalize (Rabs_le_inv _ _ Heps); intros [_ H]; exact H. } revert Hb. elim (Rmult_integral _ _ Hepseta); [ |lra]; intros ->. rewrite Rplus_0_r, Rmult_1_r. unfold b_x, b_y; rewrite Hx, Hy, <-Hsx'', <-Hsy''. intro H. apply Ropp_le_contravar. unfold negb; fold sum. apply (Rplus_le_reg_r eta). revert H; apply Rle_trans. generalize (Rabs_le_inv _ _ Heta). compute; lra. Qed. Definition is_non_neg x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 <= r)%R end. Definition is_non_neg' x := match toX x with Xnan => valid_ub x = true | Xreal r => (0 <= r)%R end. Definition is_pos x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 < r)%R end. Definition is_non_pos x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r <= 0)%R end. Definition is_non_pos' x := match toX x with Xnan => valid_lb x = true | Xreal r => (r <= 0)%R end. Definition is_neg x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r < 0)%R end. Definition is_non_neg_real x := match toX x with Xnan => False | Xreal r => (0 <= r)%R end. Definition is_pos_real x := match toX x with Xnan => False | Xreal r => (0 < r)%R end. Definition is_non_pos_real x := match toX x with Xnan => False | Xreal r => (r <= 0)%R end. Definition is_neg_real x := match toX x with Xnan => False | Xreal r => (r < 0)%R end. Lemma mul_UP_correct : forall p x y, ((is_non_neg' x /\ is_non_neg' y) \/ (is_non_pos' x /\ is_non_pos' y) \/ (is_non_pos_real x /\ is_non_neg_real y) \/ (is_non_neg_real x /\ is_non_pos_real y)) -> valid_ub (mul_UP p x y) = true /\ le_upper (Xmul (toX x) (toX y)) (toX (mul_UP p x y)). Proof. intros p x y. unfold mul_UP, is_non_neg', is_non_pos', is_non_pos_real, is_non_neg_real. intros HH. split. now rewrite valid_ub_next_up. revert HH. rewrite 2!valid_ub_correct, 2!valid_lb_correct. unfold classify. rewrite 2!classify_spec. rewrite <- 2!B2SF_Prim2B. rewrite 3!toX_Prim2B. intros HH. rewrite next_up_equiv, mul_equiv. destruct (Prim2B x) as [sx|sx| |sx mx ex Bx] eqn:Hx ; try easy. { clear HH. destruct (Prim2B y) as [sy|sy| |sy my ey By] ; try easy ; simpl ; rewrite Rmult_0_l ; lra. } { destruct (Prim2B y) as [sy|sy| |sy my ey By] ; try easy ; simpl. now destruct sx, sy ; try easy ; simpl in HH |- * ; intuition. destruct sx, sy ; try easy ; simpl in HH |- * ; intuition. apply Rle_not_lt with (1 := H1). apply Generic_proof.FtoR_Rpos. apply Rle_not_lt with (1 := H1). apply Generic_proof.FtoR_Rneg. } destruct (Prim2B y) as [sy|sy| |sy my ey By] eqn:Hy ; try easy. simpl ; rewrite Rmult_0_r ; lra. simpl ; destruct xorb eqn:Hs ; simpl ; try easy. { destruct sx, sy ; try easy ; simpl in HH |- * ; intuition. apply Rle_not_lt with (1 := H0). apply Generic_proof.FtoR_Rneg. apply Rle_not_lt with (1 := H). apply Generic_proof.FtoR_Rpos. } clear HH. set (b_mxy := Bmult _ _ _). generalize (Bsucc_correct _ _ Hprec Hmax b_mxy). generalize (Bmult_correct _ _ Hprec Hmax mode_NE (B754_finite sx mx ex Bx) (B754_finite sy my ey By)). fold b_mxy. case Rlt_bool_spec. { intros _ [-> [-> H1]] H. specialize (H eq_refl). destruct Rlt_bool. 2: now destruct Bsucc. destruct H as [H2 [H3 H4]]. rewrite !B2R_BtoX, H2 by easy. apply Ulp.succ_round_ge_id. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. } intros Hb H1 _. simpl in H1. destruct xorb eqn:Hs. 2: now destruct b_mxy as [|[|]| |]. rewrite 2!B2R_BtoX by easy. revert Hb. simpl Xmul. simpl Rmult. rewrite <- Operations.F2R_mult. simpl Operations.Fmult. replace (cond_Zopp sx _ * _)%Z with (- (Z.pos mx * Z.pos my))%Z. 2: now destruct sx, sy. clear Hs. rewrite Rabs_left1. 2: { apply Generic_fmt.round_le_generic. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Generic_fmt.generic_format_0. now apply Float_prop.F2R_le_0. } set (v := Defs.F2R _). clearbody v. destruct b_mxy as [|[|]| |] ; try easy. clear. intros H. change (Bsucc _) with (Bopp Bmax_float). rewrite BtoX_Bopp. unfold Bmax_float. rewrite B2R_BtoX by easy. rewrite B2R_SF2B. simpl. apply Ropp_le_contravar in H. rewrite Ropp_involutive in H. eapply Rle_trans. apply (Ulp.succ_round_ge_id radix2 (fexp FloatOps.prec emax) (round_mode mode_NE)). replace (Ropp _) with (Ulp.succ radix2 (fexp FloatOps.prec emax) (-bpow radix2 emax)). { apply Ulp.succ_le with (4 := H). now apply FLT.FLT_exp_valid. apply Generic_fmt.generic_format_round. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Generic_fmt.generic_format_opp. now apply Generic_fmt.generic_format_bpow. } rewrite Ulp.succ_opp, Ulp.pred_bpow. apply f_equal. unfold Defs.F2R. simpl. rewrite <- mult_IZR, <- minus_IZR. now apply f_equal. Qed. Lemma mul_DN_correct : forall p x y, ((is_non_neg_real x /\ is_non_neg_real y) \/ (is_non_pos_real x /\ is_non_pos_real y) \/ (is_non_neg' x /\ is_non_pos' y) \/ (is_non_pos' x /\ is_non_neg' y)) -> (valid_lb (mul_DN p x y) = true /\ le_lower (toX (mul_DN p x y)) (Xmul (toX x) (toX y))). Proof. intros p x y. unfold mul_DN, is_non_neg', is_non_pos', is_non_pos_real, is_non_neg_real. intros HH. split. now rewrite valid_lb_next_down. revert HH. rewrite 2!valid_ub_correct, 2!valid_lb_correct. unfold classify. rewrite 2!classify_spec. rewrite <- 2!B2SF_Prim2B. rewrite 3!toX_Prim2B. intros HH. unfold le_lower. rewrite next_down_equiv, mul_equiv. destruct (Prim2B x) as [sx|sx| |sx mx ex Bx] eqn:Hx ; try easy. { clear HH. destruct (Prim2B y) as [sy|sy| |sy my ey By] ; try easy ; simpl ; rewrite Rmult_0_l ; lra. } { destruct (Prim2B y) as [sy|sy| |sy my ey By] ; try easy ; simpl. now destruct sx, sy ; try easy ; simpl in HH |- * ; intuition. destruct sx, sy ; try easy ; simpl in HH |- * ; intuition. apply Rle_not_lt with (1 := H1). apply Generic_proof.FtoR_Rneg. apply Rle_not_lt with (1 := H1). apply Generic_proof.FtoR_Rpos. } destruct (Prim2B y) as [sy|sy| |sy my ey By] eqn:Hy ; try easy. simpl ; rewrite Rmult_0_r ; lra. simpl ; destruct xorb eqn:Hs ; simpl ; try easy. { destruct sx, sy ; try easy ; simpl in HH |- * ; intuition. apply Rle_not_lt with (1 := H0). apply Generic_proof.FtoR_Rneg. apply Rle_not_lt with (1 := H0). apply Generic_proof.FtoR_Rpos. } clear HH. set (b_mxy := Bmult _ _ _). generalize (Bpred_correct _ _ Hprec Hmax b_mxy). generalize (Bmult_correct _ _ Hprec Hmax mode_NE (B754_finite sx mx ex Bx) (B754_finite sy my ey By)). fold b_mxy. case Rlt_bool_spec. { intros _ [-> [-> H1]] H. specialize (H eq_refl). destruct Rlt_bool. 2: now destruct Bpred. destruct H as [H2 [H3 H4]]. rewrite !B2R_BtoX, H2 by easy. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. } intros Hb H1 _. simpl in H1. destruct xorb eqn:Hs. now destruct b_mxy as [|[|]| |]. rewrite 2!B2R_BtoX by easy. revert Hb. simpl Xmul. simpl Rmult. rewrite <- Operations.F2R_mult. simpl Operations.Fmult. replace (cond_Zopp sx _ * _)%Z with (Z.pos mx * Z.pos my)%Z. 2: now destruct sx, sy. clear Hs. rewrite Rabs_pos_eq. 2: { apply Generic_fmt.round_ge_generic. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Generic_fmt.generic_format_0. now apply Float_prop.F2R_ge_0. } set (v := Defs.F2R _). clearbody v. destruct b_mxy as [|[|]| |] ; try easy. clear. intros H. change (Bpred _) with (Bmax_float). rewrite B2R_BtoX by easy. apply Ropp_le_contravar. eapply Rle_trans. 2: apply (Ulp.pred_round_le_id radix2 (fexp FloatOps.prec emax) (round_mode mode_NE)). unfold Bmax_float. rewrite B2R_SF2B. simpl. replace (Defs.F2R _) with (Ulp.pred radix2 (fexp FloatOps.prec emax) (bpow radix2 emax)). { apply Ulp.pred_le with (4 := H). now apply FLT.FLT_exp_valid. now apply Generic_fmt.generic_format_bpow. apply Generic_fmt.generic_format_round. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. } rewrite Ulp.pred_bpow. unfold Defs.F2R. simpl. rewrite <- mult_IZR, <- minus_IZR. now apply f_equal. Qed. Lemma pow2_UP_correct : forall p s, (valid_ub (pow2_UP p s) = true /\ le_upper (Xscale radix2 (Xreal 1) (StoZ s)) (toX (pow2_UP p s))). Proof. intros p s. unfold pow2_UP, emax. case Zle_bool_spec; [easy| ]; intro Hs1. destruct (Z.le_ge_cases s (- 1074)) as [Hs2 | Hs2]. { rewrite (Z.max_r _ _ Hs2). cbn -[FtoR]. split; [easy| ]. rewrite FtoR_split. simpl. rewrite Float_prop.F2R_bpow. rewrite Rmult_1_l. apply bpow_le. easy. } rewrite (Z.max_l _ _ Hs2). unfold scale, valid_ub, toX, toF. rewrite <- (B2Prim_Prim2B (ldshiftexp (fromZ 1) (of_Z s + of_Z FloatOps.shift))) at 1. rewrite <-B2SF_Prim2B. rewrite ldshiftexp_equiv. set (e := (to_Z (of_Z s + of_Z FloatOps.shift) - FloatOps.shift)%Z). generalize (Bldexp_correct _ _ _ _ mode_NE (Prim2B (fromZ 1)) e). unfold e. rewrite Int63.add_spec. rewrite 2!Int63.of_Z_spec. rewrite <-Z.add_mod by easy. rewrite Z.mod_small. 2: { change wB with 9223372036854775808%Z. unfold FloatOps.shift. lia. } ring_simplify (s + FloatOps.shift - FloatOps.shift)%Z. change (fromZ 1) with 1%float. replace (B2R (Prim2B 1)) with 1%R; [ |cbn; unfold Defs.F2R; cbn; unfold Prim2B; now apply Rinv_r_sym]. rewrite Rmult_1_l. rewrite Generic_fmt.round_generic. 2: apply valid_rnd_round_mode. 2: { apply Generic_fmt.generic_format_bpow. unfold fexp, FloatOps.prec, SpecFloat.emin, emax. lia. } rewrite Rlt_bool_true. 2: rewrite Rabs_pos_eq; [now apply bpow_lt | apply bpow_ge_0]. set (t := Bldexp mode_NE (Prim2B 1) s). intros [H1 [H2 H3]]. destruct t as [sg | | | sg mt ex] eqn:Ht ; try easy. { contradict H1. apply Rlt_not_eq. apply bpow_gt_0. } split. - rewrite neg_infinity_equiv. rewrite eqb_equiv. now rewrite 2Prim2B_B2Prim. - simpl. rewrite Rmult_1_l. unfold StoZ. rewrite <- H1. rewrite FtoR_split. apply Rle_refl. Qed. Definition is_real_ub x := match toX x with Xnan => valid_ub x = true | _ => True end. Definition is_real_lb x := match toX x with Xnan => valid_lb x = true | _ => True end. Lemma div_UP_correct : forall p x y, ((is_real_ub x /\ is_pos_real y) \/ (is_real_lb x /\ is_neg_real y)) -> valid_ub (div_UP p x y) = true /\ le_upper (Xdiv (toX x) (toX y)) (toX (div_UP p x y)). Proof. intros p x y. unfold div_UP, is_real_ub, is_real_lb, is_pos_real, is_neg_real. intros HH. split. now rewrite valid_ub_next_up. revert HH. rewrite valid_ub_correct, valid_lb_correct. unfold classify. rewrite classify_spec. rewrite <- B2SF_Prim2B. rewrite 3!toX_Prim2B. intros HH. rewrite next_up_equiv, div_equiv. destruct (Prim2B y) as [sy|sy| |sy my ey By] eqn:Hy. { destruct HH as [[_ HH]|[_ HH]] ; now elim (Rlt_irrefl 0). } { now destruct HH as [[_ HH]|[_ HH]]. } { now destruct HH as [[_ HH]|[_ HH]]. } unfold Xdiv', Xbind2. simpl. rewrite is_zero_correct_float. rewrite FtoR_split. destruct (Prim2B x) as [sx|sx| |sx mx ex Bx] eqn:Hx ; try easy. { simpl. unfold Rdiv at 1 ; rewrite Rmult_0_l. clear ; lra. } { destruct sx, sy ; try easy ; simpl in HH |- *. destruct HH as [[HH _]|[_ HH]] ; try easy. apply Rle_not_lt with (2 := HH). apply Rlt_le, Generic_proof.FtoR_Rpos. destruct HH as [[_ HH]|[HH _]] ; try easy. apply Rle_not_lt with (2 := HH). apply Rlt_le, Generic_proof.FtoR_Rneg. } clear HH. set (b_mxy := Bdiv _ _ _). generalize (Bsucc_correct _ _ Hprec Hmax b_mxy). assert (Hd: B2R (B754_finite sy my ey By) <> 0%R). { destruct sy. now apply Rlt_not_eq, Float_prop.F2R_lt_0. now apply Rgt_not_eq, Float_prop.F2R_gt_0. } generalize (Bdiv_correct _ _ Hprec Hmax mode_NE (B754_finite sx mx ex Bx) (B754_finite sy my ey By) Hd). fold b_mxy. case Rlt_bool_spec. { intros _ [-> [-> H1]] H. specialize (H eq_refl). destruct Rlt_bool. 2: now destruct Bsucc. destruct H as [H2 [H3 H4]]. rewrite !B2R_BtoX, H2 by easy. apply Ulp.succ_round_ge_id. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. } intros Hb H1 _. simpl in H1. destruct xorb eqn:Hs. 2: now destruct b_mxy as [|[|]| |]. rewrite B2R_BtoX by easy. revert Hb. simpl Rdiv. rewrite Rabs_left1. 2: { apply Generic_fmt.round_le_generic. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Generic_fmt.generic_format_0. destruct sx, sy ; try easy. apply Rdiv_neg_compat. now apply Float_prop.F2R_le_0. now apply Float_prop.F2R_gt_0. apply Rmult_le_pos_neg. now apply Float_prop.F2R_ge_0. apply Rlt_le, Rinv_lt_0_compat. now apply Float_prop.F2R_lt_0. } intros H. apply Ropp_le_contravar in H. rewrite Ropp_involutive in H. rewrite <- (SF2B'_B2SF b_mxy), H1. change (BtoX (Bsucc _)) with (Xreal (FtoR radix2 true (shift_pos (Z.to_pos FloatOps.prec) 1 - 1) (emax - FloatOps.prec))). apply Rnot_lt_le. intros H'. apply (Rle_not_lt _ _ H). clear -H'. rewrite FtoR_split in H'. eapply Rlt_le_trans. 2: { apply Generic_fmt.round_le. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Rlt_le. exact H'. } rewrite Generic_fmt.round_generic. 2: apply Generic_fmt.valid_rnd_N. apply Rcomplements.Rminus_lt_0. rewrite <- Float_prop.F2R_bpow. rewrite <- Operations.F2R_opp. rewrite <- Operations.F2R_minus. now apply Float_prop.F2R_gt_0. apply FLT.generic_format_FLT. now eexists. Qed. Lemma div_DN_correct : forall p x y, ((is_real_ub x /\ is_neg_real y) \/ (is_real_lb x /\ is_pos_real y)) -> valid_lb (div_DN p x y) = true /\ le_lower (toX (div_DN p x y)) (Xdiv (toX x) (toX y)). Proof. intros p x y. unfold div_DN, is_real_ub, is_real_lb, is_pos_real, is_neg_real. intros HH. split. now rewrite valid_lb_next_down. revert HH. rewrite valid_ub_correct, valid_lb_correct. unfold classify. rewrite classify_spec. rewrite <- B2SF_Prim2B. rewrite 3!toX_Prim2B. intros HH. rewrite next_down_equiv, div_equiv. destruct (Prim2B y) as [sy|sy| |sy my ey By] eqn:Hy. { destruct HH as [[_ HH]|[_ HH]] ; now elim (Rlt_irrefl 0). } { now destruct HH as [[_ HH]|[_ HH]]. } { now destruct HH as [[_ HH]|[_ HH]]. } unfold Xdiv', Xbind2. simpl. rewrite is_zero_correct_float. rewrite FtoR_split. destruct (Prim2B x) as [sx|sx| |sx mx ex Bx] eqn:Hx ; try easy. { simpl. apply Ropp_le_contravar. unfold Rdiv at 2 ; rewrite Rmult_0_l. clear ; lra. } { destruct sx, sy ; try easy ; cbn in HH |- *. destruct HH as [[HH _]|[_ HH]] ; try easy. apply Rle_not_lt with (2 := HH). apply Rlt_le, Generic_proof.FtoR_Rneg. destruct HH as [[_ HH]|[HH _]] ; try easy. apply Rle_not_lt with (2 := HH). apply Rlt_le, Generic_proof.FtoR_Rpos. } clear HH. set (b_mxy := Bdiv _ _ _). generalize (Bpred_correct _ _ Hprec Hmax b_mxy). assert (Hd: B2R (B754_finite sy my ey By) <> 0%R). { destruct sy. now apply Rlt_not_eq, Float_prop.F2R_lt_0. now apply Rgt_not_eq, Float_prop.F2R_gt_0. } generalize (Bdiv_correct _ _ Hprec Hmax mode_NE (B754_finite sx mx ex Bx) (B754_finite sy my ey By) Hd). fold b_mxy. case Rlt_bool_spec. { intros _ [-> [-> H1]] H. specialize (H eq_refl). destruct Rlt_bool. 2: now destruct Bpred. destruct H as [H2 [H3 H4]]. rewrite !B2R_BtoX, H2 by easy. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. } intros Hb H1 _. simpl in H1. destruct xorb eqn:Hs. now destruct b_mxy as [|[|]| |]. rewrite (B2R_BtoX (B754_finite _ _ _ _)) by easy. revert Hb. simpl Rdiv. rewrite Rabs_pos_eq. 2: { apply Generic_fmt.round_ge_generic. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Generic_fmt.generic_format_0. destruct sx, sy ; try easy. apply Rmult_le_neg_neg. now apply Float_prop.F2R_le_0. apply Rlt_le, Rinv_lt_0_compat. now apply Float_prop.F2R_lt_0. apply Rdiv_pos_compat. now apply Float_prop.F2R_ge_0. now apply Float_prop.F2R_gt_0. } intros H. rewrite <- (SF2B'_B2SF b_mxy), H1. change (BtoX (Bpred _)) with (Xreal (FtoR radix2 false (shift_pos (Z.to_pos FloatOps.prec) 1 - 1) (emax - FloatOps.prec))). apply Ropp_le_contravar. apply Rnot_lt_le. intros H'. apply (Rle_not_lt _ _ H). clear -H'. rewrite FtoR_split in H'. eapply Rle_lt_trans. { apply Generic_fmt.round_le. now apply FLT.FLT_exp_valid. apply Generic_fmt.valid_rnd_N. apply Rlt_le. exact H'. } rewrite Generic_fmt.round_generic. 2: apply Generic_fmt.valid_rnd_N. apply Rcomplements.Rminus_lt_0. rewrite <- Float_prop.F2R_bpow. rewrite <- Operations.F2R_minus. now apply Float_prop.F2R_gt_0. apply FLT.generic_format_FLT. now eexists. Qed. Lemma sqrt_UP_correct : forall p x, valid_ub (sqrt_UP p x) = true /\ le_upper (Xsqrt (toX x)) (toX (sqrt_UP p x)). Proof. intros p x. unfold sqrt_UP. split; [now rewrite valid_ub_next_up| ]. unfold toX, toF. rewrite <-!B2SF_Prim2B. rewrite next_up_equiv, sqrt_equiv. case_eq (Prim2B x); [intros sx|intros [ | ]| |intros [ | ] mx ex Bx]; intro Hx; try (now simpl; reflexivity); [ | ]. { simpl; rewrite sqrt_0; lra. } rewrite <-Hx. set (b_x := Prim2B x). set (b_sx := Bsqrt _ _). generalize (Bsucc_correct _ _ Hprec Hmax b_sx). generalize (Bsqrt_correct _ _ Hprec Hmax mode_NE b_x). fold b_sx. assert (Hrx : B2R b_x = FtoR radix2 false mx ex). { now unfold b_x, B2R; rewrite Hx, <-FtoR_split. } intros [Rsx [Fsx Ssx]]. revert Fsx. set (ma := match b_x with B754_zero _ => _ | _ => _ end). replace ma with true. 2:{ unfold ma. revert Hrx. case b_x; [intros [ | ]..| |intros [ | ] m e He]; simpl; try reflexivity; [now generalize (Generic_proof.FtoR_Rpos radix2 mx ex); lra..| ]. rewrite FtoR_split; simpl; unfold Defs.F2R; simpl. set (p1 := (_ * _)%R). set (p2 := (_ * _)%R). assert (Hp1 : (p1 < 0)%R). { unfold p1. rewrite Rmult_comm, <-(Rmult_0_r (bpow radix2 e)). apply Rmult_lt_compat_l; [apply bpow_gt_0|auto with real]. } assert (Hp2 : (0 < p2)%R). { unfold p2. apply Rmult_lt_0_compat; [auto with real|apply bpow_gt_0]. } lra. } intro Fsx. intro H; generalize (H Fsx); clear H. case Rlt_bool; [ |now intros ->]. set (b_s := Bsucc _). case_eq b_s; [intro ss..| |intros ss ms es Hes]; intro Hs. { intros [Rs _]; revert Rs; simpl => ->. rewrite Rsx, Hrx. unfold b_x; rewrite Hx. apply Ulp.succ_round_ge_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } { now case ss. } { now simpl. } intros [Rs _]; revert Rs; simpl. rewrite <-FtoR_split => ->. rewrite Rsx, Hrx. unfold b_x; rewrite Hx. apply Ulp.succ_round_ge_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. Qed. Lemma sqrt_DN_correct : forall p x, valid_lb x = true -> (valid_lb (sqrt_DN p x) = true /\ le_lower (toX (sqrt_DN p x)) (Xsqrt (toX x))). Proof. intros p x. unfold sqrt_DN. intros Vx; split; [now rewrite valid_lb_next_down| ]; revert Vx. rewrite valid_lb_correct. unfold classify. rewrite classify_spec. unfold toX, toF. rewrite <-!B2SF_Prim2B. rewrite next_down_equiv, sqrt_equiv. case_eq (Prim2B x); [intros sx|intros [ | ]| |intros [ | ] mx ex Bx]; intro Hx; try reflexivity; [ | | ]. { intros _; apply Ropp_le_contravar; simpl; rewrite sqrt_0; lra. } { intro H; discriminate H. } intros _. rewrite <-Hx. set (b_x := Prim2B x). set (b_sx := Bsqrt _ _). generalize (Bpred_correct _ _ Hprec Hmax b_sx). generalize (Bsqrt_correct _ _ Hprec Hmax mode_NE b_x). fold b_sx. assert (Hrx : B2R b_x = FtoR radix2 false mx ex). { now unfold b_x, B2R; rewrite Hx, <-FtoR_split. } intros [Rsx [Fsx Ssx]]. revert Fsx. set (ma := match b_x with B754_zero _ => _ | _ => _ end). replace ma with true. 2:{ unfold ma. revert Hrx. case b_x; [intros [ | ]..| |intros [ | ] m e He]; simpl; try reflexivity; [now generalize (Generic_proof.FtoR_Rpos radix2 mx ex); lra..| ]. rewrite FtoR_split; simpl; unfold Defs.F2R; simpl. set (p1 := (_ * _)%R). set (p2 := (_ * _)%R). assert (Hp1 : (p1 < 0)%R). { unfold p1. rewrite Rmult_comm, <-(Rmult_0_r (bpow radix2 e)). apply Rmult_lt_compat_l; [apply bpow_gt_0|auto with real]. } assert (Hp2 : (0 < p2)%R). { unfold p2. apply Rmult_lt_0_compat; [auto with real|apply bpow_gt_0]. } lra. } intro Fsx. intro H; generalize (H Fsx); clear H. case Rlt_bool; [ |now intros ->]. set (b_s := Bpred _). case_eq b_s; [intro ss..| |intros ss ms es Hes]; intro Hs. { intros [Rs _]; revert Rs; simpl => ->. rewrite Rsx, Hrx. unfold b_x; rewrite Hx. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. } { now case ss. } { now simpl. } intros [Rs _]; revert Rs; simpl. rewrite <-FtoR_split => ->. rewrite Rsx, Hrx. unfold b_x; rewrite Hx. apply Ropp_le_contravar. apply Ulp.pred_round_le_id. { now apply FLT.FLT_exp_valid. } now apply Generic_fmt.valid_rnd_N. Qed. (* TODO: use the one from Flocq when we'll require Flocq >= 3.3.2 (which will imply Coq >= 8.12) *) Lemma Bnormfr_mantissa_correct : forall f : binary_float FloatOps.prec emax, (/ 2 <= Rabs (B2R f) < 1)%R -> match f with | B754_finite _ m e _ => Bnormfr_mantissa f = N.pos m /\ Z.pos (digits2_pos m) = FloatOps.prec /\ (e = - FloatOps.prec)%Z | _ => False end. Proof. intro f. destruct f as [s|s| |s m e B]; [now simpl; rewrite Rabs_R0; lra..| ]. unfold Bnormfr_mantissa, SFnormfr_mantissa; simpl. intro Hf. cut (e = -53 /\ Z.pos (digits2_pos m) = FloatOps.prec)%Z. { now intros [-> ->]; rewrite Z.eqb_refl. } revert Hf. change (/ 2)%R with (bpow radix2 (0 - 1)); change 1%R with (bpow radix2 0). intro H; generalize (mag_unique _ _ _ H); clear H. rewrite Float_prop.mag_F2R_Zdigits; [ |now case s]. replace (Digits.Zdigits _ _) with (Digits.Zdigits radix2 (Z.pos m)); [ |now case s]. clear s. rewrite <-Digits.Zpos_digits2_pos. intro He; replace e with (e - 0)%Z by ring; rewrite <-He. cut (Z.pos (digits2_pos m) = 53)%Z. { intro H; split; [ |exact H]; ring_simplify. now rewrite <-Pos2Z.opp_pos; apply f_equal. } revert B; unfold SpecFloat.bounded, canonical_mantissa. intro H; generalize (andb_prop _ _ H); clear H; intros [H _]; revert H. intro H; generalize (Zeq_bool_eq _ _ H); clear H. unfold fexp, emin; fold FloatOps.prec. apply Z.max_case_strong; [ |unfold emax]; lia. Qed. Lemma nearbyint_correct : forall default mode x, real x = true -> Xnearbyint mode (toX x) = toX (nearbyint default mode x). Proof. intros default mode x Hx. unfold nearbyint. rewrite Hx; clear default. revert Hx. rewrite <-(B2Prim_Prim2B x). rewrite real_is_finite. case (Prim2B x) as [s|s| |s m e B]; clear x; [ |now simpl..| ]; intros _. { rewrite toX_Prim2B, Prim2B_B2Prim; simpl. rewrite Generic_proof.Rnearbyint_IZR. now case mode, s. } rewrite toX_Prim2B, Prim2B_B2Prim; unfold BtoX. set (f := B2Prim (B754_finite s m e B)). generalize (frexp_equiv f). unfold Z.frexp. case frshiftexp as [f' e']. generalize (Bfrexp_correct _ _ _ (Prim2B f)). unfold f; rewrite Prim2B_B2Prim; clear f. intro H; generalize (H (eq_refl _)); clear H. case (Bfrexp _) as [f'' e'']. intros [H1 H2]; revert H1; generalize (H2 (eq_refl _)); clear H2. intros [H1 H2] H3 [= H4 H5]; revert H1 H2 H3. rewrite <-H4, <-H5; clear f'' e'' H4 H5. intros Hf' He' Hf'e'. case lebP; (replace (to_Z _) with (FloatOps.prec + FloatOps.shift)%Z by now compute); intro H'e'. { rewrite toX_Prim2B, Prim2B_B2Prim; unfold BtoX. rewrite FtoR_split; unfold Defs.F2R; simpl. revert B He' Hf'e'. case e; [ |intro pe..]; intros B He' Hf'e'. { now simpl; rewrite Rmult_1_r, Generic_proof.Rnearbyint_IZR. } { now simpl; rewrite <-mult_IZR, Generic_proof.Rnearbyint_IZR. } exfalso; revert H'e'; apply Zlt_not_le. apply (Zplus_lt_reg_r _ _ (- FloatOps.shift)); ring_simplify. revert He'; unfold Z.sub; intros ->. simpl; rewrite Float_prop.mag_F2R_Zdigits; [ |now case s]. replace (Digits.Zdigits _ _) with (Digits.Zdigits radix2 (Z.pos m)); [ |now case s]. rewrite <-Digits.Zpos_digits2_pos. clear Hf'e'; revert B; unfold SpecFloat.bounded, canonical_mantissa; simpl. intro H; generalize (andb_prop _ _ H); clear H; intros [H _]; revert H. intro H; generalize (Zeq_bool_eq _ _ H); clear H. unfold fexp; lia. } assert (He'' : (to_Z e' - FloatOps.shift < FloatOps.prec)%Z) by lia. replace (of_Z _ - e')%int63 with (of_Z (FloatOps.prec - (to_Z e' - FloatOps.shift))). 2:{ apply Int63.to_Z_inj; rewrite Int63.sub_spec, Int63.of_Z_spec. apply f_equal2; [ |reflexivity]. change (to_Z (of_Z _)) with (FloatOps.prec + FloatOps.shift)%Z. ring. } revert He' Hf'e' He''; clear H'e'. set (e'' := (to_Z e' - FloatOps.shift)%Z); clearbody e''; clear e'. intros He'' Hf'e'' He''prec. replace (get_sign _) with s; [ |now rewrite get_sign_equiv, Prim2B_B2Prim]. rewrite <-(B2Prim_Prim2B (of_int63 _)). rewrite <-(B2Prim_Prim2B (of_int63 (_ + 1))). replace (Int63.eqb _ 0) with (Z.eqb (Int63.to_Z (normfr_mantissa f' >> of_Z (FloatOps.prec - e'') land 1)%int63) 0). 2:{ now case Int63.eqbP; intro H; [rewrite H|rewrite Z.eqb_neq]. } rewrite Int63.land_spec', Int63.to_Z_1. rewrite !of_int63_equiv, Int63.add_spec, !lsr_spec, normfr_mantissa_equiv. rewrite to_Z_1. assert (He''emin : (emin + 1 <= e'')%Z). { rewrite He''. apply mag_ge_bpow. replace (emin + 1 - 1)%Z with emin by ring. now apply abs_B2R_ge_emin. } rewrite of_Z_spec, Zmod_small. 2:{ split; [lia| ]. now apply (Z.le_lt_trans _ (FloatOps.prec - emin - 1)); [lia| ]. } set (fl := B2Prim (binary_normalize _ _ _ _ _ _ 0 false)). set (fu := B2Prim (binary_normalize _ _ _ _ _ _ 0 false)). rewrite <-(B2Prim_Prim2B (- fl)); rewrite opp_equiv. rewrite <-(B2Prim_Prim2B (- fu)); rewrite opp_equiv. rewrite !ltb_spec, <-!B2SF_Prim2B, !Prim2B_B2Prim. rewrite compare_equiv, sub_equiv, abs_equiv, Prim2B_B2Prim. unfold fl, fu; clear fl fu; rewrite !Prim2B_B2Prim. generalize (Bnormfr_mantissa_correct _ Hf'). revert Hf' Hf'e''. case (Prim2B f') as [ | | |sf' mf' ef' Bf']; [now intros _ _ H; case H..| ]. clear f'. change (Babs _) with (B754_finite false m e B). intros Hf' Hf'e'' [-> [Hmf' Hef']]. unfold B2R at 2 in Hf'e''. rewrite Hef' in Hf'e''. revert Bf' Hf'; rewrite Hef'; intros Bf' Hf'; clear Hef' ef'. rewrite <-FtoR_split in Hf'e''. change (Z.of_N (N.pos mf')) with (Z.pos mf'). set (mh := (_ / 2 ^ _)%Z). assert (Hmh : (0 <= mh < 2 ^ FloatOps.prec)%Z). { unfold mh; split. { now apply Z.div_pos; [ |apply Z.pow_pos_nonneg; lia]. } apply Z.div_lt_upper_bound. apply (Zpower_gt_0 radix2). lia. apply (Z.lt_le_trans _ (2 ^ FloatOps.prec)). { change (Z.pos mf') with (Z.abs (Z.pos mf')). rewrite <-Hmf', Digits.Zpos_digits2_pos. apply Digits.Zdigits_correct. } rewrite <- Zpower_plus. apply (Zpower_le radix2). lia. lia. easy. } assert (Hmagmh : (mh <> 0 -> 0 < Raux.mag radix2 (IZR mh) <= FloatOps.prec)%Z). { intro Nzmh; split. { now apply mag_gt_bpow; simpl; rewrite Rabs_pos_eq; apply IZR_le; lia. } apply mag_le_bpow; [now apply IZR_neq| ]. rewrite Rabs_pos_eq; [ |now apply IZR_le]. now apply IZR_lt. } assert (Hmagmh1 : (mh + 1 = 2 ^ FloatOps.prec \/ 0 < Raux.mag radix2 (IZR (mh + 1)) <= FloatOps.prec)%Z). { assert (H := Ztac.Zlt_le_add_1 _ _ (proj2 Hmh)). rewrite Z.le_lteq in H; destruct H as [H|H]; [right|now left]. split. { now apply mag_gt_bpow; simpl; rewrite Rabs_pos_eq; apply IZR_le; lia. } apply mag_le_bpow; [now apply IZR_neq; lia| ]. rewrite Rabs_pos_eq; [ |now apply IZR_le; lia]. now apply IZR_lt. } rewrite Zmod_small. 2:{ split; [lia| ]. now apply (Z.le_lt_trans _ (2 ^ FloatOps.prec)%Z); [lia| ]. } generalize (binary_normalize_correct _ _ _ _ mode_NE mh 0 false). generalize (binary_normalize_correct _ _ _ _ mode_NE (mh + 1) 0 false). unfold Defs.F2R; intros H H'; simpl in H, H'; revert H' H. rewrite !Rmult_1_r. rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ revert Hmh Hmagmh; case mh; [ |intro pmh..]. { intros _ _; apply Generic_fmt.generic_format_0. } { intros Hmh Hmagmh. unfold Generic_fmt.generic_format, Defs.F2R; simpl. unfold Generic_fmt.scaled_mantissa, Generic_fmt.cexp, fexp. rewrite Z.max_l. 2:{ apply (Zplus_le_reg_r _ _ FloatOps.prec); ring_simplify. apply Z.lt_le_incl, (Z.le_lt_trans _ 0); [compute; discriminate| ]. apply Hmagmh; discriminate. } case_eq (Raux.mag radix2 (IZR (Z.pos pmh)) - FloatOps.prec)%Z. { now intros _; rewrite !Rmult_1_r, Ztrunc_IZR. } { intros p; lia. } intros p Hp; simpl. rewrite <-mult_IZR, Ztrunc_IZR, mult_IZR. rewrite Rmult_assoc, Rinv_r; [now rewrite Rmult_1_r| ]. apply IZR_neq; generalize (Zpower_pos_gt_0 2 p); lia. } now simpl. } rewrite Rlt_bool_true. 2:{ apply Rabs_lt; rewrite <-opp_IZR; split; apply IZR_lt. { now apply (Z.lt_le_trans _ 0). } now apply (Z.lt_trans _ _ _ (proj2 Hmh)). } intros [Hrmh [Hfmh _]]. rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ destruct Hmagmh1 as [->|Hmagmh1]. { change (IZR _) with (bpow radix2 FloatOps.prec). now apply FLT.generic_format_FLT_bpow. } unfold Generic_fmt.generic_format, Defs.F2R; simpl. unfold Generic_fmt.scaled_mantissa, Generic_fmt.cexp, fexp. rewrite Z.max_l. 2:{ apply (Zplus_le_reg_r _ _ FloatOps.prec); ring_simplify. apply Z.lt_le_incl, (Z.le_lt_trans _ 0); [compute; discriminate| ]. apply Hmagmh1; discriminate. } case_eq (Raux.mag radix2 (IZR (mh + 1)) - FloatOps.prec)%Z. { now intros _; rewrite !Rmult_1_r, Ztrunc_IZR. } { intros p; lia. } intros p Hp; simpl. rewrite <-mult_IZR, Ztrunc_IZR, mult_IZR. rewrite Rmult_assoc, Rinv_r; [now rewrite Rmult_1_r| ]. apply IZR_neq; generalize (Zpower_pos_gt_0 2 p); lia. } rewrite Rlt_bool_true. 2:{ apply Rabs_lt; rewrite <-opp_IZR; split; apply IZR_lt. { now apply (Z.lt_le_trans _ 0); [compute|lia]. } now apply (Z.lt_trans _ (2 ^ FloatOps.prec + 1)); [lia|compute]. } intros [Hrmh1 [Hfmh1 _]]. assert (Hsf' : sf' = s). { revert Hf'e''; simpl; unfold Defs.F2R; simpl. unfold Rdiv; rewrite Rmult_assoc. change (/ _)%R with (bpow radix2 (- FloatOps.prec)). rewrite <-bpow_plus. case s, sf'; [now simpl| | |now simpl]. { intro H; exfalso; apply (Rlt_irrefl 0). apply (Rlt_le_trans _ (IZR (cond_Zopp true (Z.pos m)) * bpow radix2 e)%R). { now rewrite H; apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } now apply Stdlib.Rmult_le_neg_pos; [apply IZR_le|apply bpow_ge_0]. } intro H; exfalso; apply (Rlt_irrefl 0). apply (Rlt_le_trans _ (IZR (cond_Zopp false (Z.pos m)) * bpow radix2 e)%R). { now apply Rmult_lt_0_compat; [apply IZR_lt|apply bpow_gt_0]. } now rewrite H; apply Stdlib.Rmult_le_neg_pos; [apply IZR_le|apply bpow_ge_0]. } assert (HB2R_FtoR : forall s m e (B : SpecFloat.bounded FloatOps.prec emax m e = true), B2R (B754_finite s m e B) = FtoR radix2 s m e). { now intros s' m' e' B'; rewrite FtoR_split. } assert (H'f'e'' : (FtoR radix2 s m e = IZR (cond_Zopp s (Z.pos mf')) * bpow radix2 (- FloatOps.prec + e''))%R). { rewrite <-(HB2R_FtoR _ _ _ B), Hf'e'', Hsf', FtoR_split. unfold Defs.F2R, Defs.Fnum, Defs.Fexp. now rewrite bpow_plus, Rmult_assoc. } assert (Haf'e'' : (FtoR radix2 false m e = IZR (Z.pos mf') * bpow radix2 (- FloatOps.prec + e''))%R). { revert H'f'e''; rewrite !FtoR_split; unfold Defs.F2R, Defs.Fnum, Defs.Fexp. case s; [ |now intros ->]. unfold cond_Zopp; rewrite !opp_IZR, <-!Ropp_mult_distr_l. now intro H; generalize (f_equal Ropp H); rewrite !Ropp_involutive; intros ->. } assert (Hbpow : bpow radix2 (FloatOps.prec - e'') = IZR (2 ^ (FloatOps.prec - e''))). { now generalize (proj2 (Z.lt_0_sub _ _) He''prec); case (_ - _)%Z. } assert (Hbpow' : (bpow radix2 (- FloatOps.prec + e'') = / IZR (2 ^ (FloatOps.prec - e'')))%R). { replace (- _ + _)%Z with (- (FloatOps.prec - e''))%Z by ring. now case_eq (FloatOps.prec - e'')%Z; [ |intro p..]; [lia| |lia]. } case mode; clear mode. { case_eq s; intro Hs; simpl. { rewrite toX_Prim2B, Prim2B_B2Prim, BtoX_Bopp. rewrite (B2R_BtoX _ Hfmh), Hrmh. revert H'f'e''; rewrite Hs; intros->. unfold cond_Zopp, Zceil, Xlift. rewrite !opp_IZR, <-Ropp_mult_distr_l, Ropp_involutive. do 3 apply f_equal. rewrite Hbpow'; unfold mh. apply Zfloor_div, pow2_nz; lia. } unfold SFltb. generalize (Bcompare_correct _ _ _ (B754_finite false m e B) Hfmh (eq_refl _)). unfold Bcompare, B2SF at 2; intros ->. case Rcompare_spec. { rewrite Hrmh, HB2R_FtoR; simpl. rewrite toX_Prim2B, Prim2B_B2Prim, (B2R_BtoX _ Hfmh1), Hrmh1. rewrite <-Hs, H'f'e'', Hs; unfold cond_Zopp. intros H'mh. do 2 apply f_equal. apply Zceil_imp. split. { revert H'mh; apply Rle_lt_trans; right; apply IZR_eq; ring. } rewrite Hbpow'. change (_ * _)%R with (IZR (Z.pos mf') / IZR (2 ^ (FloatOps.prec - e'')))%R. rewrite Rcomplements.Rle_div_l; [ |now rewrite <-Hbpow; apply bpow_gt_0]. rewrite <-mult_IZR; apply IZR_le. rewrite Z.mul_comm, Z.mul_add_distr_l, Z.mul_1_r. rewrite (Z_div_mod_eq _ (2 ^ (FloatOps.prec - e''))) at 1. 2:{ apply Z.lt_gt, lt_IZR; rewrite <-Hbpow; apply bpow_gt_0. } apply Zplus_le_compat_l. apply Z.lt_le_incl, Z_mod_lt. apply Z.lt_gt, lt_IZR; rewrite <-Hbpow; apply bpow_gt_0. } { rewrite HB2R_FtoR; intros <-; rewrite Hrmh, Zceil_IZR, <-Hrmh; simpl. now rewrite toX_Prim2B, Prim2B_B2Prim, (B2R_BtoX _ Hfmh), Hrmh. } intro H; exfalso; revert H; apply Rle_not_lt. rewrite Hrmh; unfold mh. rewrite HB2R_FtoR, <-Hs, H'f'e'', Hs; unfold cond_Zopp. rewrite Hbpow', <-Zfloor_div; [ |apply pow2_nz; lia]. apply Zfloor_lb. } { generalize Hfmh; rewrite <-is_finite_Bopp; intro Hfomh. generalize (f_equal Ropp Hrmh); rewrite <-B2R_Bopp; intro Hromh. case_eq s; intro Hs; simpl. { unfold SFltb. generalize (Bcompare_correct _ _ (B754_finite true m e B) _ (eq_refl _) Hfomh). unfold Bcompare, B2SF at 1; intros ->. case Rcompare_spec. { rewrite Hromh, HB2R_FtoR; simpl. rewrite toX_Prim2B, Prim2B_B2Prim, BtoX_Bopp. rewrite (B2R_BtoX _ Hfmh1), Hrmh1. rewrite <-(Z.opp_involutive (Zfloor _)), <-(Ropp_involutive (FtoR _ _ _ _)). fold (Zceil (- (FtoR radix2 true m e))). rewrite <-Hs, H'f'e'', Hs; unfold cond_Zopp. rewrite opp_IZR, <-Ropp_mult_distr_l, !Ropp_involutive. unfold Xlift; rewrite opp_IZR. intro H; generalize (Ropp_lt_cancel _ _ H); clear H. intros H'mh. do 3 apply f_equal. apply Zceil_imp. split. { revert H'mh; apply Rle_lt_trans; right; apply IZR_eq; ring. } rewrite Hbpow'. change (_ * _)%R with (IZR (Z.pos mf') / IZR (2 ^ (FloatOps.prec - e'')))%R. rewrite Rcomplements.Rle_div_l; [ |now rewrite <-Hbpow; apply bpow_gt_0]. rewrite <-mult_IZR; apply IZR_le. rewrite Z.mul_comm, Z.mul_add_distr_l, Z.mul_1_r. rewrite (Z_div_mod_eq _ (2 ^ (FloatOps.prec - e''))) at 1. 2:{ apply Z.lt_gt, lt_IZR; rewrite <-Hbpow; apply bpow_gt_0. } apply Zplus_le_compat_l. apply Z.lt_le_incl, Z_mod_lt. apply Z.lt_gt, lt_IZR; rewrite <-Hbpow; apply bpow_gt_0. } { rewrite HB2R_FtoR; simpl. rewrite toX_Prim2B, Prim2B_B2Prim. rewrite Hromh, (B2R_BtoX _ Hfomh), Hromh ; intros ->. now rewrite <-opp_IZR, Zfloor_IZR. } rewrite B2R_Bopp. rewrite HB2R_FtoR, <-Hs, H'f'e'', Hs. unfold cond_Zopp. rewrite opp_IZR, <-Ropp_mult_distr_l. intro H; exfalso; revert H; apply Rle_not_lt, Ropp_le_contravar. rewrite Hrmh; unfold mh. rewrite Hbpow', <-Zfloor_div; [ |apply pow2_nz; lia]. apply Zfloor_lb. } rewrite toX_Prim2B, Prim2B_B2Prim. rewrite (B2R_BtoX _ Hfmh), Hrmh. revert H'f'e''; rewrite Hs; intros->. unfold cond_Zopp, Zceil, Xlift. do 2 apply f_equal. rewrite Hbpow'; unfold mh. apply Zfloor_div, pow2_nz; lia. } { simpl; unfold Ztrunc. case_eq s; intro Hs; simpl. { rewrite Rlt_bool_true. 2:{ apply Generic_proof.FtoR_Rneg. } rewrite toX_Prim2B, Prim2B_B2Prim, BtoX_Bopp. rewrite (B2R_BtoX _ Hfmh), Hrmh. rewrite <-Hs, H'f'e'', Hs. unfold cond_Zopp, Zceil, Xlift. rewrite !opp_IZR, <-Ropp_mult_distr_l, Ropp_involutive. do 3 apply f_equal. rewrite Hbpow'; unfold mh. apply Zfloor_div, pow2_nz; lia. } rewrite Rlt_bool_false. 2:{ apply Rlt_le, Generic_proof.FtoR_Rpos. } rewrite toX_Prim2B, Prim2B_B2Prim. rewrite (B2R_BtoX _ Hfmh), Hrmh. rewrite <-Hs, H'f'e'', Hs. do 2 apply f_equal. rewrite Hbpow'; unfold mh. apply Zfloor_div, pow2_nz; lia. } set (f' := B754_finite false m _ B). set (fl := binary_normalize _ _ _ _ _ mh _ _). set (fu := binary_normalize _ _ _ _ _ (mh + 1) _ _). generalize (Bminus_correct _ _ _ _ mode_NE f' fl (eq_refl _) Hfmh). assert (Hpos : (0 < 2 ^ (FloatOps.prec - e''))%Z). { now apply Z.pow_pos_nonneg; [ |lia]. } assert (Hpos' : (0 <= Z.pos mf' / 2 ^ (FloatOps.prec - e''))%Z). { apply Z.div_pos; lia. } assert (Pf' : (0 < B2R f')%R). { unfold f', B2R; rewrite <-FtoR_split. apply Generic_proof.FtoR_Rpos. } assert (Nzf' : (B2R f' <> 0)%R); [now apply Rgt_not_eq| ]. assert (Hflf' : (B2R fl <= B2R f')%R). { unfold fl, f'; rewrite Hrmh. unfold B2R; rewrite <-FtoR_split, Haf'e''. apply (Rmult_le_reg_r (bpow radix2 (FloatOps.prec - e''))). { apply bpow_gt_0. } rewrite Rmult_assoc, <-bpow_plus; replace (_ + _)%Z with 0%Z by ring. rewrite Rmult_1_r, Hbpow, <-mult_IZR; apply IZR_le. now rewrite Z.mul_comm; apply Z.mul_div_le. } assert (Hf'fu : (B2R f' <= B2R fu)%R). { unfold f', fu; rewrite Hrmh1. unfold B2R; rewrite <-FtoR_split, Haf'e''. apply (Rmult_le_reg_r (bpow radix2 (FloatOps.prec - e''))). { apply bpow_gt_0. } rewrite Rmult_assoc, <-bpow_plus; replace (_ + _)%Z with 0%Z by ring. rewrite Rmult_1_r, Hbpow, <-mult_IZR; apply IZR_le. rewrite Z.mul_comm, Z.mul_add_distr_l, Z.mul_1_r. rewrite (Z_div_mod_eq _ (2 ^ (FloatOps.prec - e''))) at 1; [ |lia]. apply Zplus_le_compat_l, Z.lt_le_incl, Z_mod_lt; lia. } assert (Pfl : (0 <= B2R fl)%R). { now unfold fl; rewrite Hrmh; unfold mh; apply IZR_le, Z.div_pos. } assert (Hflfu : (B2R fu = B2R fl + 1)%R). { now unfold fl, fu; rewrite Hrmh, Hrmh1, plus_IZR. } rewrite Generic_fmt.round_generic. 2:{ apply Generic_fmt.valid_rnd_N. } 2:{ case (Req_dec (B2R fl) 0). { intros ->; rewrite Rminus_0_r; apply generic_format_B2R. } intro Nzfl. apply sterbenz. { now apply FLT.FLT_exp_valid. } { apply FLT.FLT_exp_monotone. } { apply generic_format_B2R. } { apply generic_format_B2R. } split; [lra| ]. apply (Rle_trans _ _ _ Hf'fu); rewrite Hflfu. cut (1 <= B2R fl)%R; [lra| ]. revert Nzfl Pfl; unfold fl; rewrite Hrmh. intro H; generalize (neq_IZR _ _ H); clear H; intro Nzfl. intro H; generalize (le_IZR _ _ H); clear H; intro Pfl. apply IZR_le; lia. } rewrite Rlt_bool_true. 2:{ rewrite Rabs_pos_eq; [ |lra]. apply (Rle_lt_trans _ (B2R f')); [lra| ]. generalize (abs_B2R_lt_emax _ _ f'); apply Rle_lt_trans. rewrite Rabs_pos_eq; lra. } intros [Hrf'mfl [Hff'mfl _]]. rewrite (Bcompare_correct _ _ _ (Prim2B 0.5) Hff'mfl (eq_refl _)). rewrite Hrf'mfl. replace (B2R (Prim2B 0.5)) with (/ 2)%R; [ |now compute; lra]. case Rcompare_spec; intro Hf'flhalf; simpl. { cut (Xreal (Rnearbyint rnd_NE (FtoR radix2 false m e)) = toX (B2Prim fl)). { unfold Rnearbyint; case s; [ |now intros->]. intro H; rewrite toX_Prim2B, opp_equiv, BtoX_Bopp, <-toX_Prim2B, <-H. change false with (negb true); rewrite <-Generic_proof.FtoR_neg. rewrite Generic_fmt.Znearest_opp, opp_IZR. unfold Xlift; rewrite Ropp_involutive. do 2 f_equal. unfold Generic_fmt.Znearest. now rewrite Z.even_opp, Z.add_1_r, Z.even_succ, Z.negb_odd. } unfold fl; rewrite toX_Prim2B, Prim2B_B2Prim, (B2R_BtoX _ Hfmh), Hrmh. unfold Rnearbyint; do 2 apply f_equal. apply Generic_fmt.Znearest_imp. rewrite <-Hrmh; fold fl. replace (FtoR _ _ _ _) with (B2R f'); [ |now rewrite FtoR_split]. rewrite Rabs_pos_eq; lra. } 2:{ cut (Xreal (Rnearbyint rnd_NE (FtoR radix2 false m e)) = toX (B2Prim fu)). { unfold Rnearbyint; case s; [ |now intros->]. intro H; rewrite toX_Prim2B, opp_equiv, BtoX_Bopp, <-toX_Prim2B, <-H. change false with (negb true); rewrite <-Generic_proof.FtoR_neg. rewrite Generic_fmt.Znearest_opp, opp_IZR. unfold Xlift; rewrite Ropp_involutive. do 2 f_equal. unfold Generic_fmt.Znearest. now rewrite Z.even_opp, Z.add_1_r, Z.even_succ, Z.negb_odd. } unfold fu; rewrite toX_Prim2B, Prim2B_B2Prim, (B2R_BtoX _ Hfmh1), Hrmh1. unfold Rnearbyint; do 2 apply f_equal. apply Generic_fmt.Znearest_imp. rewrite <-Hrmh1; fold fu. replace (FtoR _ _ _ _) with (B2R f'); [ |now rewrite FtoR_split]. rewrite Rabs_minus_sym, Rabs_pos_eq; lra. } cut (Xreal (Rnearbyint rnd_NE (FtoR radix2 false m e)) = toX (if (Z.land mh 1 =? 0)%Z then B2Prim fl else B2Prim fu)). { unfold Rnearbyint; case s; [ |now intros->]. intro H; rewrite toX_Prim2B, opp_equiv, BtoX_Bopp, <-toX_Prim2B, <-H. change false with (negb true); rewrite <-Generic_proof.FtoR_neg. rewrite Generic_fmt.Znearest_opp, opp_IZR. unfold Xlift; rewrite Ropp_involutive. do 2 f_equal. unfold Generic_fmt.Znearest. now rewrite Z.even_opp, Z.add_1_r, Z.even_succ, Z.negb_odd. } unfold Rnearbyint, Generic_fmt.Znearest. replace (FtoR _ _ _ _) with (B2R f'); [ |now rewrite FtoR_split]. replace (Zfloor (B2R f')) with mh. 2:{ symmetry; apply Zfloor_imp. rewrite <-Hrmh, <-Hrmh1; fold fl fu; lra. } replace (Zceil (B2R f')) with (mh + 1)%Z. 2:{ symmetry; apply Zceil_imp. replace (_ - _)%Z with mh by ring. rewrite <-Hrmh, <-Hrmh1; fold fl fu; lra. } rewrite <-Hrmh; fold fl. case Rcompare_spec; [lra| |lra]; intros _. rewrite Bool.if_negb. cut (Z.even mh = (Z.land mh 1 =? 0)%Z). { intros <-. rewrite toX_Prim2B. case (Z.even mh) ; rewrite Prim2B_B2Prim, B2R_BtoX by easy ; now apply f_equal, eq_sym. } revert Hmh; case mh as [ |pmh|pmh]; [now simpl|intros _|lia]; simpl. now case pmh as [pmh|pmh| ]. Qed. Lemma nearbyint_UP_correct : forall mode x, valid_ub (nearbyint_UP mode x) = true /\ le_upper (Xnearbyint mode (toX x)) (toX (nearbyint_UP mode x)). Proof. intros mode x. unfold nearbyint_UP. case_eq (real x); intro Hx; [ |now unfold nearbyint; rewrite Hx]. split. { rewrite valid_ub_correct. generalize (classify_correct (nearbyint infinity mode x)). rewrite real_correct. rewrite <-(nearbyint_correct _ _ _ Hx). unfold Xlift; simpl. revert Hx; rewrite real_correct. now case toX; [ |case classify]. } rewrite <-(nearbyint_correct _ _ _ Hx). now case toX; [ |intro x'; right]. Qed. Lemma nearbyint_DN_correct : forall mode x, valid_lb (nearbyint_DN mode x) = true /\ le_lower (toX (nearbyint_DN mode x)) (Xnearbyint mode (toX x)). Proof. intros mode x. unfold nearbyint_DN. case_eq (real x); intro Hx; [ |now unfold nearbyint; rewrite Hx]. split. { rewrite valid_lb_correct. generalize (classify_correct (nearbyint neg_infinity mode x)). rewrite real_correct. rewrite <-(nearbyint_correct _ _ _ Hx). unfold Xlift; simpl. revert Hx; rewrite real_correct. now case toX; [ |case classify]. } rewrite <-(nearbyint_correct _ _ _ Hx). now case toX; [ |intro x'; right]. Qed. Lemma midpoint_correct : forall x y, sensible_format = true -> real x = true -> real y = true -> (toR x <= toR y)%R -> real (midpoint x y) = true /\ (toR x <= toR (midpoint x y) <= toR y)%R. Proof. intros x y _. rewrite !real_correct. unfold toR, toX, toF. rewrite <-!B2SF_Prim2B. set (b_x := Prim2B x). set (b_y := Prim2B y). intros Hx Hy Hxy. unfold midpoint. replace (Prim2B (if is_infinity _ then _ else _)) with (if is_infinity ((x + y) / 2) then Prim2B (x / 2 + y / 2) else Prim2B ((x + y) / 2)). 2:{ now case is_infinity. } rewrite is_infinity_equiv. rewrite add_equiv, !div_equiv, add_equiv. fold b_x; fold b_y. set (b2 := Prim2B 2). assert (Nz2 : B2R b2 <> 0%R). { compute; lra. } revert Hx Hxy. set (bplus := Bplus _). set (bdiv := Bdiv _). case b_x; [intros sx..| |intros sx mx ex Hmex]; [ |intro H; discriminate H..| ]; intros _. { revert Hy. case b_y; [intros sy..| |intros sy my ey Hmey]; [ |intro H; discriminate H..| ]; intros _. { now case sx, sy. } case sy; [intro Hy; simpl in Hy|intros _]. { generalize (Generic_proof.FtoR_Rneg radix2 my ey); lra. } change (bplus (B754_zero sx) _) with (B754_finite false my ey Hmey). set (by2 := bdiv (B754_finite false my ey Hmey) b2). elim (Bdiv2_correct (B754_finite false my ey Hmey) eq_refl). fold bdiv; fold b2; fold by2. intros _ [Fy2 [Sy2 Hy2']]; revert Fy2 Sy2 Hy2'. case by2 => [sy2|sy2| |sy2 my2 ey2 Hmey2]; [ |intro H; discriminate H..| ]; intros _; simpl. { intros _ _. split; [reflexivity|split; [now right| ]]. apply Rlt_le, Generic_proof.FtoR_Rpos. } intros ->. change (Z.pos my) with (cond_Zopp false (Z.pos my)). rewrite <-!FtoR_split, !Generic_proof.FtoR_abs. intro H; split; [reflexivity|split; [ |exact H]]. apply Rlt_le, Generic_proof.FtoR_Rpos. } revert Hy. case b_y; [intros sy..| |intros sy my ey Hmey]; [ |intro H; discriminate H..| ]; intros _. { case sx; [intros _|intros Hx; simpl in Hx]. 2:{ generalize (Generic_proof.FtoR_Rpos radix2 mx ex); lra. } change (bplus _ (B754_zero sy)) with (B754_finite true mx ex Hmex). set (bx2 := bdiv (B754_finite true mx ex Hmex) b2). elim (Bdiv2_correct (B754_finite true mx ex Hmex) eq_refl). fold bdiv; fold b2; fold bx2. intros _ [Fx2 [Sx2 Hx2]]; revert Fx2 Sx2 Hx2. case bx2 => [sx2|sx2| |sx2 mx2 ex2 Hmex2]; [ |intro H; discriminate H..| ]; intros _; simpl. { intros _ _. split; [reflexivity|split; [ |now right]]. apply Rlt_le, Generic_proof.FtoR_Rneg. } intros ->. change (Z.neg mx) with (cond_Zopp true (Z.pos mx)). rewrite <-!FtoR_split, !Generic_proof.FtoR_abs. intro H; split; [reflexivity|split]. 2:{ apply Rlt_le, Generic_proof.FtoR_Rneg. } change true with (negb false). rewrite <-!Generic_proof.FtoR_neg. now apply Ropp_le_contravar. } clear x y b_x b_y. set (b_x := B754_finite sx mx ex Hmex). set (b_y := B754_finite sy my ey Hmey). intros Hxy; simpl in Hxy. generalize (Bplus_correct _ _ Hprec Hmax mode_NE b_x b_y eq_refl eq_refl). fold bplus. case Rlt_bool_spec => Hb. { intros [Rxpy [Fxpy Sxpy]]. elim (Bdiv2_correct (bplus b_x b_y) Fxpy). fold bdiv; fold b2. intros _ [Fxpy2 _]. replace (match bdiv _ _ with B754_infinity _ => true | _ => _ end) with false; [ |now revert Fxpy2; case bdiv]. split; [now revert Fxpy2; case bdiv| ]. elim (Bdiv2_correct _ Fxpy); fold bdiv b2. intros Rxpy2 _. simpl. set (rx := FtoR radix2 sx mx ex). set (ry := FtoR radix2 sy my ey). revert Rxpy Rxpy2. set (fexp := FLT.FLT_exp _ _). set (m := round_mode _). intros Rxpy Rxpy2. rewrite <-(Generic_fmt.round_generic radix2 fexp m rx). 2:{ unfold rx; rewrite FtoR_split; change (Defs.F2R _) with (B2R b_x). apply generic_format_B2R. } rewrite <-(Generic_fmt.round_generic radix2 fexp m ry). 2:{ unfold ry; rewrite FtoR_split; change (Defs.F2R _) with (B2R b_y). apply generic_format_B2R. } replace rx with ((rx + rx) / 2)%R; [ |lra]. replace ry with ((ry + ry) / 2)%R; [ |lra]. replace (proj_val _) with (B2R (bdiv (bplus b_x b_y) b2)). 2:{ change (binary_normalize _ _ _ _ _ _ _ _) with (bplus b_x b_y). case bdiv => [s|s| |sb mb eb Hmeb]; [reflexivity..| ]. now unfold B2R; rewrite <-FtoR_split. } rewrite Rxpy2, Rxpy. split; (apply Generic_fmt.round_le; [now apply FLT.FLT_exp_valid|now apply Generic_fmt.valid_rnd_N| ]; unfold Rdiv; apply Rmult_le_compat_r; [lra| ]). { rewrite <-(Generic_fmt.round_generic radix2 fexp m (rx + rx)). { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } unfold B2R, b_x, b_y; rewrite <-!FtoR_split. now apply Rplus_le_compat_l. } replace (rx + rx)%R with (rx * bpow radix2 1)%R; [ |simpl; lra]. apply mult_bpow_pos_exact_FLT; [ |lia]. unfold rx; rewrite FtoR_split; change (Defs.F2R _) with (B2R b_x). apply generic_format_B2R. } rewrite <-(Generic_fmt.round_generic radix2 fexp m (ry + ry)). { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } unfold B2R, b_x, b_y; rewrite <-!FtoR_split. now apply Rplus_le_compat_r. } replace (ry + ry)%R with (ry * bpow radix2 1)%R; [ |simpl; lra]. apply mult_bpow_pos_exact_FLT; [ |lia]. unfold ry; rewrite FtoR_split; change (Defs.F2R _) with (B2R b_y). apply generic_format_B2R. } change (binary_overflow _ _ _ _) with (@B2SF FloatOps.prec emax (B754_infinity sx)). intros [H H']; revert H'; rewrite (B2SF_inj _ _ _ _ H); clear H. intro Hsxy; simpl in Hsxy. change (match bdiv _ _ with B754_infinity _ => true | _ => _ end) with true. revert Hb. change (SpecFloat.fexp _ _) with (FLT.FLT_exp (3 - emax - FloatOps.prec) FloatOps.prec). set (fexp := FLT.FLT_exp _ _). set (m := round_mode _). elim (Plus_error.FLT_plus_error_N_ex _ _ _ (fun x : Z => negb (Z.even x)) _ _ (generic_format_B2R _ _ b_x) (generic_format_B2R _ _ b_y)). change (Generic_fmt.Znearest _) with (round_mode mode_NE). unfold emin. fold fexp m. intros eps [Heps ->]. rewrite Rabs_mult. intro Hb. assert (R1peps : (0 < Rabs (1 + eps))%R). { apply Rabs_gt; right. generalize (Rle_trans _ _ _ Heps (Relative.u_rod1pu_ro_le_u_ro _ _)). intro H; generalize (Rabs_le_inv _ _ H); compute; lra. } generalize (Rmult_le_compat_r _ _ _ (Rlt_le _ _ (Rinv_0_lt_compat _ R1peps)) Hb). rewrite Rmult_assoc, Rinv_r, ?Rmult_1_r; [ |lra]. clear Hb; intro Hb. generalize (Rle_trans _ _ _ Hb (Rabs_triang _ _)). clear Hb; intro Hb. assert (Hb' : (1 / 256 <= bpow radix2 emax * / Rabs (1 + eps) - (bpow radix2 emax - bpow radix2 (emax - FloatOps.prec)))%R). { rewrite Rcomplements.Rle_minus_r. apply (Rmult_le_reg_r _ _ _ R1peps). rewrite Rmult_assoc, Rinv_l, ?Rmult_1_r; [ |lra]. refine (Rle_trans _ _ _ (Rmult_le_compat_l _ _ _ _ (Rle_trans _ _ _ (Rabs_triang _ _) (Rplus_le_compat_l _ _ _ Heps))) _). { apply Rplus_le_le_0_compat; [lra| ]. now apply Rle_0_minus, bpow_le; compute. } rewrite (Rabs_pos_eq _ Rle_0_1). compute; lra. } assert (Hx2h : (1 / 256 <= Rabs (toR (B2Prim b_x)))%R). { unfold toR, toX, toF; rewrite Prim2SF_B2Prim; unfold b_x; simpl. apply (Rle_trans _ _ _ Hb'). apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ Hb)). rewrite FtoR_split; change (Defs.F2R _) with (B2R b_x). apply (Rplus_le_reg_r (- Rabs (B2R b_y))). ring_simplify. unfold Rminus; rewrite Rplus_assoc. apply Rplus_le_compat_l. generalize (abs_B2R_le_emax_minus_prec _ emax Hprec b_y). lra. } assert (Hy2h : (1 / 256 <= Rabs (toR (B2Prim b_y)))%R). { unfold toR, toX, toF; rewrite Prim2SF_B2Prim; unfold b_y; simpl. apply (Rle_trans _ _ _ Hb'). apply (Rle_trans _ _ _ (Rplus_le_compat_r _ _ _ Hb)). rewrite FtoR_split; change (Defs.F2R _) with (B2R b_y). apply (Rplus_le_reg_r (- Rabs (B2R b_x))). ring_simplify. unfold Rminus; rewrite Rplus_assoc, Rplus_comm. apply Rplus_le_compat_r. generalize (abs_B2R_le_emax_minus_prec _ emax Hprec b_x). lra. } generalize (div2_correct _ (refl_equal _) Hy2h). generalize (div2_correct _ (refl_equal _) Hx2h). intros Hx2 Hy2. assert (Fx2 : is_finite (bdiv b_x b2) = true). { revert Hx2; unfold toX, toF, div2. rewrite <-B2SF_Prim2B, div_equiv, Prim2B_B2Prim; fold bdiv b2. rewrite Prim2SF_B2Prim. unfold Xdiv', Xbind2; rewrite is_zero_false; [ |lra]. now case bdiv => [s|s| |s m' e Hme]. } assert (Fy2 : is_finite (bdiv b_y b2) = true). { revert Hy2; unfold toX, toF, div2. rewrite <-B2SF_Prim2B, div_equiv, Prim2B_B2Prim; fold bdiv b2. rewrite Prim2SF_B2Prim. unfold Xdiv', Xbind2; rewrite is_zero_false; [ |lra]. now case bdiv => [s|s| |s m' e Hme]. } generalize (Bplus_correct _ _ Hprec Hmax mode_NE _ _ Fx2 Fy2). fold bplus fexp m. replace (B2R (bdiv b_x b2)) with (B2R b_x / 2)%R. 2:{ revert Hx2; unfold toX, toF, div2. rewrite <-B2SF_Prim2B, div_equiv, Prim2B_B2Prim; fold bdiv b2. rewrite Prim2SF_B2Prim. unfold Xdiv', Xbind2; rewrite is_zero_false; [ |lra]. case bdiv => [s|s| |s m' e Hme]; [ |intro H; discriminate H..| ]. { now intro H; inversion H as (H'); simpl; rewrite H', FtoR_split. } intro H; inversion H as (H'); revert H'; simpl. now rewrite !FtoR_split => ->. } replace (B2R (bdiv b_y b2)) with (B2R b_y / 2)%R. 2:{ revert Hy2; unfold toX, toF, div2. rewrite <-B2SF_Prim2B, div_equiv, Prim2B_B2Prim; fold bdiv b2. rewrite Prim2SF_B2Prim. unfold Xdiv', Xbind2; rewrite is_zero_false; [ |lra]. case bdiv => [s|s| |s m' e Hme]; [ |intro H; discriminate H..| ]. { now intro H; inversion H as (H'); simpl; rewrite H', FtoR_split. } intro H; inversion H as (H'); revert H'; simpl. now rewrite !FtoR_split => ->. } rewrite Rlt_bool_true. 2:{ unfold b_x, b_y; rewrite <-Hsxy. case_eq sx => Hsx. { apply (Rle_lt_trans _ (Rabs (B2R b_x))). 2:{ apply abs_B2R_lt_emax. } rewrite Rabs_left1. 2:{ rewrite <-(Generic_fmt.round_0 radix2 fexp m). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } simpl. change (Z.neg mx) with (cond_Zopp true (Z.pos mx)). change (Z.neg my) with (cond_Zopp true (Z.pos my)). rewrite <-!FtoR_split. generalize (Generic_proof.FtoR_Rneg radix2 mx ex). generalize (Generic_proof.FtoR_Rneg radix2 my ey). lra. } rewrite Rabs_left1. 2:{ simpl. rewrite <-FtoR_split, Hsx. generalize (Generic_proof.FtoR_Rneg radix2 mx ex). lra. } apply Ropp_le_contravar. rewrite <-(Generic_fmt.round_generic radix2 fexp m (B2R b_x)). { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } replace (B2R b_x) with (B2R b_x / 2 + B2R b_x / 2)%R by field. rewrite <-Hsx; apply Rplus_le_compat_l. apply Rmult_le_compat_r; [lra| ]. now revert Hxy; rewrite !FtoR_split, <-Hsxy. } apply generic_format_B2R. } apply (Rle_lt_trans _ (Rabs (B2R b_y))). 2:{ apply abs_B2R_lt_emax. } rewrite Rabs_pos_eq. 2:{ rewrite <-(Generic_fmt.round_0 radix2 fexp m). apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } simpl. change (Z.pos mx) with (cond_Zopp false (Z.pos mx)). change (Z.pos my) with (cond_Zopp false (Z.pos my)). rewrite <-!FtoR_split. generalize (Generic_proof.FtoR_Rpos radix2 mx ex). generalize (Generic_proof.FtoR_Rpos radix2 my ey). lra. } rewrite Rabs_pos_eq. 2:{ simpl. rewrite <-FtoR_split, <-Hsxy, Hsx. generalize (Generic_proof.FtoR_Rpos radix2 my ey). lra. } rewrite <-(Generic_fmt.round_generic radix2 fexp m (B2R b_y)). { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } replace (B2R b_y) with (B2R b_y / 2 + B2R b_y / 2)%R by field. rewrite <-Hsx, Hsxy; apply Rplus_le_compat_r. apply Rmult_le_compat_r; [lra| ]. now revert Hxy; rewrite !FtoR_split, Hsxy. } apply generic_format_B2R. } intros [Rx2py2 [Fx2py2 _]]. split. { revert Fx2py2; case bplus => [s|s| |s m' e Hme]; [ |intro H; discriminate H..| ]; reflexivity. } unfold proj_val at -2 3. replace (proj_val _) with (B2R (bplus (bdiv b_x b2) (bdiv b_y b2))). 2:{ now case bplus => [s|s| |s m' e Hme]; [..|simpl; rewrite <-FtoR_split]. } unfold B2SF, b_x, b_y, FtoX; fold b_x b_y. rewrite FtoR_split; change (Defs.F2R _) with (B2R b_x). rewrite FtoR_split; change (Defs.F2R _) with (B2R b_y). rewrite Rx2py2. rewrite <-(Generic_fmt.round_generic radix2 fexp m (B2R b_x)) at 1. 2:{ apply generic_format_B2R. } rewrite <-(Generic_fmt.round_generic radix2 fexp m (B2R b_y)) at 3. 2:{ apply generic_format_B2R. } split. { apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } replace (B2R b_x) with (B2R b_x / 2 + B2R b_x / 2)%R at 1 by field. apply Rplus_le_compat_l. apply Rmult_le_compat_r; [lra| ]. now revert Hxy; rewrite !FtoR_split. } apply Generic_fmt.round_le. { now apply FLT.FLT_exp_valid. } { now apply Generic_fmt.valid_rnd_N. } replace (B2R b_y) with (B2R b_y / 2 + B2R b_y / 2)%R at 2 by field. apply Rplus_le_compat_r. apply Rmult_le_compat_r; [lra| ]. now revert Hxy; rewrite !FtoR_split. Qed. End PrimitiveFloat. interval-4.11.1/src/Float/Sig.v000066400000000000000000000456271470547631300162170ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals. From Flocq Require Import Zaux Raux. Require Import Xreal. Require Import Basic. Variant fclass := Freal | Fnan | Fminfty | Fpinfty. (* TODO PR: move? *) Module Type FloatOps. Parameter sensible_format : bool. Parameter radix : radix. Parameter type : Type. Parameter toF : type -> float radix. Definition convert x := FtoX (toF x). Definition toX x := FtoX (toF x). Definition toR x := proj_val (toX x). Parameter precision : Type. Parameter sfactor : Type. Parameter prec : precision -> positive. Parameter PtoP : positive -> precision. Parameter ZtoS : Z -> sfactor. Parameter StoZ : sfactor -> Z. Parameter incr_prec : precision -> positive -> precision. Parameter zero : type. Parameter nan : type. Parameter fromZ : Z -> type. Parameter fromZ_DN : precision -> Z -> type. Parameter fromZ_UP : precision -> Z -> type. Parameter fromF : float radix -> type. Parameter classify : type -> fclass. Parameter real : type -> bool. Parameter is_nan : type -> bool. Parameter mag : type -> sfactor. Parameter valid_ub : type -> bool. (* valid upper bound (typically, not -oo) *) Parameter valid_lb : type -> bool. (* valid lower bound (typically, not +oo) *) Parameter cmp : type -> type -> Xcomparison. Parameter min : type -> type -> type. Parameter max : type -> type -> type. Parameter neg : type -> type. Parameter abs : type -> type. Parameter scale : type -> sfactor -> type. Parameter div2 : type -> type. Parameter add_UP : precision -> type -> type -> type. Parameter add_DN : precision -> type -> type -> type. Parameter sub_UP : precision -> type -> type -> type. Parameter sub_DN : precision -> type -> type -> type. Parameter mul_UP : precision -> type -> type -> type. Parameter mul_DN : precision -> type -> type -> type. Parameter pow2_UP : precision -> sfactor -> type. Parameter div_UP : precision -> type -> type -> type. Parameter div_DN : precision -> type -> type -> type. Parameter sqrt_UP : precision -> type -> type. Parameter sqrt_DN : precision -> type -> type. Parameter nearbyint_UP : rounding_mode -> type -> type. Parameter nearbyint_DN : rounding_mode -> type -> type. Parameter midpoint : type -> type -> type. Parameter zero_correct : toX zero = Xreal 0. Parameter nan_correct : classify nan = Fnan. Parameter ZtoS_correct: forall prec z, (z <= StoZ (ZtoS z))%Z \/ toX (pow2_UP prec (ZtoS z)) = Xnan. Parameter fromZ_correct : forall n, (Z.abs n <= 256)%Z -> toX (fromZ n) = Xreal (IZR n). Parameter fromZ_DN_correct : forall p n, valid_lb (fromZ_DN p n) = true /\ le_lower (toX (fromZ_DN p n)) (Xreal (IZR n)). Parameter fromZ_UP_correct : forall p n, valid_ub (fromZ_UP p n) = true /\ le_upper (Xreal (IZR n)) (toX (fromZ_UP p n)). Parameter classify_correct : forall f, real f = match classify f with Freal => true | _ => false end. Parameter real_correct : forall f, real f = match toX f with Xnan => false | _ => true end. Parameter is_nan_correct : forall f, is_nan f = match classify f with Fnan => true | _ => false end. Parameter mag_correct : forall f, (Rabs (toR f) < bpow radix (StoZ (mag f)))%R. Parameter valid_lb_correct : forall f, valid_lb f = match classify f with Fpinfty => false | _ => true end. Parameter valid_ub_correct : forall f, valid_ub f = match classify f with Fminfty => false | _ => true end. Parameter cmp_correct : forall x y, cmp x y = match classify x, classify y with | Fnan, _ | _, Fnan => Xund | Fminfty, Fminfty => Xeq | Fminfty, _ => Xlt | _, Fminfty => Xgt | Fpinfty, Fpinfty => Xeq | _, Fpinfty => Xlt | Fpinfty, _ => Xgt | Freal, Freal => Xcmp (toX x) (toX y) end. Parameter min_correct : forall x y, match classify x, classify y with | Fnan, _ | _, Fnan => classify (min x y) = Fnan | Fminfty, _ | _, Fminfty => classify (min x y) = Fminfty | Fpinfty, _ => min x y = y | _, Fpinfty => min x y = x | Freal, Freal => toX (min x y) = Xmin (toX x) (toX y) end. Parameter max_correct : forall x y, match classify x, classify y with | Fnan, _ | _, Fnan => classify (max x y) = Fnan | Fpinfty, _ | _, Fpinfty => classify (max x y) = Fpinfty | Fminfty, _ => max x y = y | _, Fminfty => max x y = x | Freal, Freal => toX (max x y) = Xmax (toX x) (toX y) end. Parameter neg_correct : forall x, match classify x with | Freal => toX (neg x) = Xneg (toX x) | Fnan => classify (neg x) = Fnan | Fminfty => classify (neg x) = Fpinfty | Fpinfty => classify (neg x) = Fminfty end. Parameter abs_correct : forall x, toX (abs x) = Xabs (toX x) /\ (valid_ub (abs x) = true). Parameter div2_correct : forall x, sensible_format = true -> (1 / 256 <= Rabs (toR x))%R -> toX (div2 x) = Xdiv (toX x) (Xreal 2). Parameter add_UP_correct : forall p x y, valid_ub x = true -> valid_ub y = true -> (valid_ub (add_UP p x y) = true /\ le_upper (Xadd (toX x) (toX y)) (toX (add_UP p x y))). Parameter add_DN_correct : forall p x y, valid_lb x = true -> valid_lb y = true -> (valid_lb (add_DN p x y) = true /\ le_lower (toX (add_DN p x y)) (Xadd (toX x) (toX y))). Parameter sub_UP_correct : forall p x y, valid_ub x = true -> valid_lb y = true -> (valid_ub (sub_UP p x y) = true /\ le_upper (Xsub (toX x) (toX y)) (toX (sub_UP p x y))). Parameter sub_DN_correct : forall p x y, valid_lb x = true -> valid_ub y = true -> (valid_lb (sub_DN p x y) = true /\ le_lower (toX (sub_DN p x y)) (Xsub (toX x) (toX y))). Definition is_non_neg x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 <= r)%R end. Definition is_non_neg' x := match toX x with Xnan => valid_ub x = true | Xreal r => (0 <= r)%R end. Definition is_pos x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 < r)%R end. Definition is_non_pos x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r <= 0)%R end. Definition is_non_pos' x := match toX x with Xnan => valid_lb x = true | Xreal r => (r <= 0)%R end. Definition is_neg x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r < 0)%R end. Definition is_non_neg_real x := match toX x with Xnan => False | Xreal r => (0 <= r)%R end. Definition is_pos_real x := match toX x with Xnan => False | Xreal r => (0 < r)%R end. Definition is_non_pos_real x := match toX x with Xnan => False | Xreal r => (r <= 0)%R end. Definition is_neg_real x := match toX x with Xnan => False | Xreal r => (r < 0)%R end. Parameter mul_UP_correct : forall p x y, ((is_non_neg' x /\ is_non_neg' y) \/ (is_non_pos' x /\ is_non_pos' y) \/ (is_non_pos_real x /\ is_non_neg_real y) \/ (is_non_neg_real x /\ is_non_pos_real y)) -> valid_ub (mul_UP p x y) = true /\ le_upper (Xmul (toX x) (toX y)) (toX (mul_UP p x y)). Parameter mul_DN_correct : forall p x y, ((is_non_neg_real x /\ is_non_neg_real y) \/ (is_non_pos_real x /\ is_non_pos_real y) \/ (is_non_neg' x /\ is_non_pos' y) \/ (is_non_pos' x /\ is_non_neg' y)) -> (valid_lb (mul_DN p x y) = true /\ le_lower (toX (mul_DN p x y)) (Xmul (toX x) (toX y))). Parameter pow2_UP_correct : forall p s, (valid_ub (pow2_UP p s) = true /\ le_upper (Xscale radix2 (Xreal 1) (StoZ s)) (toX (pow2_UP p s))). Definition is_real_ub x := match toX x with Xnan => valid_ub x = true | _ => True end. Definition is_real_lb x := match toX x with Xnan => valid_lb x = true | _ => True end. Parameter div_UP_correct : forall p x y, ((is_real_ub x /\ is_pos_real y) \/ (is_real_lb x /\ is_neg_real y)) -> valid_ub (div_UP p x y) = true /\ le_upper (Xdiv (toX x) (toX y)) (toX (div_UP p x y)). Parameter div_DN_correct : forall p x y, ((is_real_ub x /\ is_neg_real y) \/ (is_real_lb x /\ is_pos_real y)) -> valid_lb (div_DN p x y) = true /\ le_lower (toX (div_DN p x y)) (Xdiv (toX x) (toX y)). Parameter sqrt_UP_correct : forall p x, valid_ub (sqrt_UP p x) = true /\ le_upper (Xsqrt (toX x)) (toX (sqrt_UP p x)). Parameter sqrt_DN_correct : forall p x, valid_lb x = true -> (valid_lb (sqrt_DN p x) = true /\ le_lower (toX (sqrt_DN p x)) (Xsqrt (toX x))). Parameter nearbyint_UP_correct : forall mode x, valid_ub (nearbyint_UP mode x) = true /\ le_upper (Xnearbyint mode (toX x)) (toX (nearbyint_UP mode x)). Parameter nearbyint_DN_correct : forall mode x, valid_lb (nearbyint_DN mode x) = true /\ le_lower (toX (nearbyint_DN mode x)) (Xnearbyint mode (toX x)). Parameter midpoint_correct : forall x y, sensible_format = true -> real x = true -> real y = true -> (toR x <= toR y)%R -> real (midpoint x y) = true /\ (toR x <= toR (midpoint x y) <= toR y)%R. End FloatOps. Module FloatExt (F : FloatOps). Lemma valid_lb_real f : F.real f = true -> F.valid_lb f = true. Proof. generalize (F.valid_lb_correct f). generalize (F.classify_correct f). now case F.classify; try easy; intro H; rewrite H. Qed. Lemma valid_ub_real f : F.real f = true -> F.valid_ub f = true. Proof. generalize (F.valid_ub_correct f). generalize (F.classify_correct f). now case F.classify; try easy; intro H; rewrite H. Qed. Lemma valid_lb_nan : F.valid_lb F.nan = true. Proof. generalize F.nan_correct. generalize (F.valid_lb_correct F.nan). now case F.classify. Qed. Lemma valid_ub_nan : F.valid_ub F.nan = true. Proof. generalize F.nan_correct. generalize (F.valid_ub_correct F.nan). now case F.classify. Qed. Lemma valid_lb_zero : F.valid_lb F.zero = true. Proof. generalize (F.valid_lb_correct F.zero). generalize (F.classify_correct F.zero). rewrite F.real_correct, F.zero_correct. now case F.classify. Qed. Lemma valid_ub_zero : F.valid_ub F.zero = true. Proof. generalize (F.valid_ub_correct F.zero). generalize (F.classify_correct F.zero). rewrite F.real_correct, F.zero_correct. now case F.classify. Qed. Lemma nan_correct : F.toX F.nan = Xnan. Proof. generalize (F.classify_correct F.nan). generalize F.nan_correct. case F.classify; [easy|intros _|easy..]. generalize (F.real_correct F.nan). now case F.toX; [|intros r H; rewrite H]. Qed. Lemma is_nan_nan : F.is_nan F.nan = true. Proof. now rewrite F.is_nan_correct, F.nan_correct. Qed. Lemma neg_correct x : F.toX (F.neg x) = Xneg (F.toX x). Proof. generalize (F.real_correct x). generalize (F.real_correct (F.neg x)). generalize (F.neg_correct x). rewrite !F.classify_correct. case F.classify; intro Hx; rewrite Hx; [|now case F.toX, F.toX..]. now case F.toX; [easy|]; intros rx; simpl; case F.classify. Qed. Lemma valid_lb_neg x : F.valid_lb (F.neg x) = F.valid_ub x. Proof. generalize (F.real_correct x). generalize (F.real_correct (F.neg x)). generalize (F.neg_correct x). rewrite !F.classify_correct, !F.valid_lb_correct, !F.valid_ub_correct. case F.classify; intro Hx; rewrite Hx; [|now case F.toX, F.toX..]. now case F.toX; [easy|]; intros rx; simpl; case F.classify. Qed. Lemma valid_ub_neg x : F.valid_ub (F.neg x) = F.valid_lb x. Proof. generalize (F.real_correct x). generalize (F.real_correct (F.neg x)). generalize (F.neg_correct x). rewrite !F.classify_correct, !F.valid_lb_correct, !F.valid_ub_correct. case F.classify; intro Hx; rewrite Hx; [|now case F.toX, F.toX..]. now case F.toX; [easy|]; intros rx; simpl; case F.classify. Qed. Lemma real_neg x : F.real (F.neg x) = F.real x. Proof. now rewrite !F.real_correct, neg_correct; case F.toX. Qed. Lemma is_nan_neg x : F.is_nan (F.neg x) = F.is_nan x. Proof. rewrite !F.is_nan_correct. generalize (F.neg_correct x). case_eq (F.classify x); [|now intros _ H; rewrite H..]. intro Hx. generalize (F.classify_correct x); rewrite Hx, F.real_correct. case F.toX; [easy|]; intros rx _. generalize (F.classify_correct (F.neg x)). rewrite F.real_correct. case F.toX; [easy|]; intros rnx. now case F.classify. Qed. Definition cmp x y:= if F.real x then if F.real y then F.cmp x y else Xund else Xund. Lemma cmp_correct : forall x y, cmp x y = Xcmp (F.toX x) (F.toX y). Proof. intros x y. unfold cmp. rewrite !F.classify_correct, F.cmp_correct. generalize (F.classify_correct x). generalize (F.classify_correct y). rewrite !F.real_correct. now case (F.classify x), (F.classify y), (F.toX x), (F.toX y). Qed. Definition le' x y := match cmp x y with | Xlt | Xeq => true | Xgt | Xund => false end. Lemma le'_correct : forall x y, le' x y = true -> match F.toX x, F.toX y with | Xreal xr, Xreal yr => (xr <= yr)%R | _, _ => False end. Proof. intros x y. unfold le'. rewrite cmp_correct. destruct F.toX as [|xr]. easy. destruct F.toX as [|yr]. easy. simpl. now case Raux.Rcompare_spec ; auto with real. Qed. Definition lt' x y := match cmp x y with | Xlt => true | _ => false end. Lemma lt'_correct : forall x y, lt' x y = true -> match F.toX x, F.toX y with | Xreal xr, Xreal yr => (xr < yr)%R | _, _ => False end. Proof. intros x y. unfold lt'. rewrite cmp_correct. destruct F.toX as [|xr]. easy. destruct F.toX as [|yr]. easy. simpl. now case Raux.Rcompare_spec. Qed. Definition le x y := match F.cmp x y with | Xgt => false | _ => true end. Lemma le_correct : forall x y, F.toX x = Xreal (F.toR x) -> F.toX y = Xreal (F.toR y) -> le x y = Rle_bool (F.toR x) (F.toR y). Proof. intros x y Rx Ry. unfold le. rewrite F.cmp_correct. generalize (F.classify_correct x). generalize (F.classify_correct y). rewrite !F.real_correct, Rx, Ry. do 2 (case F.classify; [|easy..]; intros _). simpl. unfold Rle_bool. now case Rcompare. Qed. Definition lt x y := match F.cmp x y with | Xlt => true | _ => false end. Lemma lt_correct : forall x y, F.toX x = Xreal (F.toR x) -> F.toX y = Xreal (F.toR y) -> lt x y = Rlt_bool (F.toR x) (F.toR y). Proof. intros x y Rx Ry. unfold lt. rewrite F.cmp_correct. generalize (F.classify_correct x). generalize (F.classify_correct y). rewrite !F.real_correct, Rx, Ry. do 2 (case F.classify; [|easy..]; intros _). simpl. unfold Rlt_bool. now case Rcompare. Qed. Lemma real_correct : forall x, F.real x = true -> F.toX x = Xreal (F.toR x). Proof. intros x Rx. rewrite F.real_correct in Rx. unfold F.toR. now destruct F.toX as [|rx]. Qed. Lemma real_correct_false : forall x, F.real x = false -> F.toX x = Xnan. Proof. intros x Rx. rewrite F.real_correct in Rx. now destruct F.toX. Qed. Inductive toX_prop (x : F.type) : ExtendedR -> Prop := | toX_Xnan : toX_prop x Xnan | toX_Xreal : F.toX x = Xreal (F.toR x) -> toX_prop x (Xreal (F.toR x)). Lemma toX_spec : forall x, toX_prop x (F.toX x). Proof. intros x. case_eq (F.toX x). intros _. apply toX_Xnan. intros r H. change r with (proj_val (Xreal r)). rewrite <- H. apply toX_Xreal. unfold F.toR. now rewrite H at 2. Qed. Lemma classify_real : forall x, F.real x = true -> F.classify x = Freal. Proof. intros x. rewrite F.classify_correct. now case F.classify. Qed. Lemma classify_zero : F.classify F.zero = Freal. Proof. apply classify_real. now rewrite F.real_correct, F.zero_correct. Qed. Lemma min_valid_lb x y : F.valid_lb x = true -> F.valid_lb y = true -> (F.valid_lb (F.min x y) = true /\ F.toX (F.min x y) = Xmin (F.toX x) (F.toX y)). Proof. rewrite !F.valid_lb_correct. generalize (F.min_correct x y). generalize (F.classify_correct x) ; rewrite F.real_correct ; case_eq (F.classify x); intro Cx ; [..|easy] ; [case_eq (F.toX x); [easy|] ; intros rx Hx _ |case_eq (F.toX x); [|easy] ; intros Hx _..] ; ( generalize (F.classify_correct y) ; rewrite F.real_correct ; case_eq (F.classify y); intro Cy ; [..|easy] ; [case_eq (F.toX y); [easy|] ; intros ry Hy _ |case_eq (F.toX y); [|easy] ; intros Hy _..] ) ; intros Hmin _ _ ; generalize (F.classify_correct (F.min x y)) ; rewrite F.real_correct ; rewrite Hmin ; simpl ; rewrite ?Cx, ?Cy ; rewrite ?Hx, ?Hy ; [case F.classify ; easy|..] ; now case F.toX. Qed. Lemma max_valid_ub x y : F.valid_ub x = true -> F.valid_ub y = true -> (F.valid_ub (F.max x y) = true /\ F.toX (F.max x y) = Xmax (F.toX x) (F.toX y)). Proof. rewrite !F.valid_ub_correct. generalize (F.max_correct x y). generalize (F.classify_correct x) ; rewrite F.real_correct ; case_eq (F.classify x); intro Cx ; [..|easy|] ; [case_eq (F.toX x); [easy|] ; intros rx Hx _ |case_eq (F.toX x); [|easy] ; intros Hx _..] ; ( generalize (F.classify_correct y) ; rewrite F.real_correct ; case_eq (F.classify y); intro Cy ; [..|easy|] ; [case_eq (F.toX y); [easy|] ; intros ry Hy _ |case_eq (F.toX y); [|easy] ; intros Hy _..] ) ; intros Hmax _ _ ; generalize (F.classify_correct (F.max x y)) ; rewrite F.real_correct ; rewrite Hmax ; simpl ; rewrite ?Cx, ?Cy ; rewrite ?Hx, ?Hy ; [case F.classify ; easy|..] ; now case F.toX. Qed. Lemma mul_UP_correct : forall p x y, ((F.is_non_neg x /\ F.is_non_neg y) \/ (F.is_non_pos x /\ F.is_non_pos y) \/ (F.is_non_pos_real x /\ F.is_non_neg_real y) \/ (F.is_non_neg_real x /\ F.is_non_pos_real y)) -> (F.valid_ub (F.mul_UP p x y) = true /\ le_upper (Xmul (F.toX x) (F.toX y)) (F.toX (F.mul_UP p x y))). Proof. intros prec x y H. apply F.mul_UP_correct. destruct H as [[[H1 H2] [H3 H4]]|[[[H1 H2] [H3 H4]]|[[H1 H2]|[H1 H2]]]]. - left ; unfold F.is_non_neg' ; split. now destruct (F.toX x). now destruct (F.toX y). - right ; left ; unfold F.is_non_pos' ; split. now destruct (F.toX x). now destruct (F.toX y). - intuition. - intuition. Qed. Lemma mul_DN_correct : forall p x y, ((F.is_non_neg_real x /\ F.is_non_neg_real y) \/ (F.is_non_pos_real x /\ F.is_non_pos_real y) \/ (F.is_non_neg x /\ F.is_non_pos y) \/ (F.is_non_pos x /\ F.is_non_neg y)) -> (F.valid_lb (F.mul_DN p x y) = true /\ le_lower (F.toX (F.mul_DN p x y)) (Xmul (F.toX x) (F.toX y))). Proof. intros prec x y H. apply F.mul_DN_correct. destruct H as [[H1 H2]|[[H1 H2]|[[[H1 H2] [H3 H4]]|[[H1 H2] [H3 H4]]]]]. - intuition. - intuition. - right ; right ; left ; unfold F.is_non_neg', F.is_non_pos' ; split. now destruct (F.toX x). now destruct (F.toX y). - right ; right ; right ; unfold F.is_non_pos', F.is_non_neg' ; split. now destruct (F.toX x). now destruct (F.toX y). Qed. Lemma sqr_UP_correct : forall prec x, F.valid_lb x = true \/ F.valid_ub x = true -> F.valid_ub (F.mul_UP prec x x) = true /\ le_upper (F.toX x * F.toX x)%XR (F.toX (F.mul_UP prec x x)). Proof. intros prec x Vx. apply F.mul_UP_correct. unfold F.is_non_neg', F.is_non_pos', F.is_non_pos_real, F.is_non_neg_real. destruct F.toX as [|xr]. intuition. destruct (Rlt_or_le 0 xr) as [H|H]. apply Rlt_le in H. now left. now right ; left. Qed. End FloatExt. interval-4.11.1/src/Float/Specific_bigint.v000066400000000000000000000570621470547631300205520ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Bool ZArith Reals Psatz. From Bignums Require Import BigN BigZ. From Flocq Require Import Zaux Raux Digits. Require Import Basic. Require Import Generic. Require Import Generic_proof. Require Import Specific_sig. Module BigIntRadix2 <: FloatCarrier. Definition radix := radix2. Definition radix_correct := refl_equal Lt. Definition smantissa_type := BigZ.t. Definition mantissa_type := BigN.t. Definition exponent_type := BigZ.t. Definition MtoZ := BigZ.to_Z. Definition ZtoM := BigZ.of_Z. Definition MtoP v := match BigN.to_Z v with Zpos w => w | _ => xH end. Definition PtoM := BigN.of_pos. Definition EtoZ := BigZ.to_Z. Definition ZtoE := BigZ.of_Z. Definition valid_mantissa v := exists p, BigN.to_Z v = Zpos p. Definition exponent_zero := 0%bigZ. Definition exponent_one := 1%bigZ. Definition exponent_neg := BigZ.opp. Definition exponent_add := BigZ.add. Definition exponent_sub := BigZ.sub. Definition exponent_cmp := BigZ.compare. Definition mantissa_zero := 0%bigZ. Definition mantissa_one := 1%bigN. Definition mantissa_add := BigN.add. Definition mantissa_sub := BigN.sub. Definition mantissa_mul := BigN.mul. Definition mantissa_cmp := BigN.compare. Definition mantissa_pos := BigZ.Pos. Definition mantissa_neg := BigZ.Neg. Definition mantissa_sign m := if BigZ.eqb m 0%bigZ then Mzero else match m with | BigZ.Pos p => Mnumber false p | BigZ.Neg p => Mnumber true p end. Definition mantissa_shl m d := BigN.shiftl m (BigZ.to_N d). Definition mantissa_scale2 (m : mantissa_type) (d : exponent_type) := (m, d). Definition mantissa_digits m := BigZ.Pos (BigN.Ndigits m - BigN.head0 m)%bigN. Definition mantissa_even m := BigN.even m. Definition mantissa_split_div m d pos := let (q, r) := BigN.div_eucl m d in (q, if BigN.eqb r 0%bigN then match pos with pos_Eq => pos_Eq | _ => pos_Lo end else match BigN.compare (BigN.shiftl r 1%bigN) d with | Lt => pos_Lo | Eq => match pos with pos_Eq => pos_Mi | _ => pos_Up end | Gt => pos_Up end). Definition mantissa_div := fun m d => mantissa_split_div m d pos_Eq. (* Definition mantissa_shr m d pos := mantissa_split_div m (mantissa_shl 1%bigN d) pos. *) Definition mantissa_shr m d pos := let dd := BigZ.to_N d in (BigN.shiftr m dd, let d1 := BigN.pred dd in match BigN.compare (BigN.tail0 m) d1 with | Gt => match pos with pos_Eq => pos_Eq | _ => pos_Lo end | Eq => match pos with pos_Eq => pos_Mi | _ => pos_Up end | Lt => if BigN.even (BigN.shiftr m d1) then pos_Lo else pos_Up end). (* Definition mantissa_shr m d pos := let dd := BigZ.to_N d in let d1 := BigN.pred dd in (BigN.shiftr dd m, let p1 := BigN.is_even (BigN.shiftr d1 m) in let p2 := BigN.is_even (BigN.shiftr d1 (BigN.pred m)) in if p1 then if p2 then (* 00 *) pos_Lo else (* 01 *) match pos with pos_Eq => pos_Eq | _ => pos_Lo end else if p2 then (* 10 *) match pos with pos_Eq => pos_Mi | _ => pos_Up end else (* 11 *) pos_Up). *) Definition mantissa_shrp m d pos := match pos with | pos_Eq => let dd := BigZ.to_N d in match BigN.compare (BigN.shiftl m 1) (BigN.shiftl 1 dd) with | Eq => pos_Mi | _ => pos_Up end | _ => pos_Up end. Definition exponent_div2_floor e := match e with | BigZ.Pos p => (BigZ.Pos (BigN.shiftr p 1%bigN), negb (BigN.even p)) | BigZ.Neg p => let q := BigN.shiftr p 1%bigN in if BigN.even p then (BigZ.Neg q, false) else (BigZ.Neg (BigN.succ q), true) end. Definition mantissa_sqrt m := let s := BigN.sqrt m in let r := BigN.sub m (BigN.square s) in (s, if BigN.eqb r 0%bigN then pos_Eq else match BigN.compare r s with Gt => pos_Up | _ => pos_Lo end). Definition exponent_zero_correct := refl_equal Z0. Definition exponent_one_correct := refl_equal 1%Z. Definition mantissa_zero_correct := refl_equal Z0. Definition ZtoM_correct := BigZ.spec_of_Z. Definition ZtoE_correct := BigZ.spec_of_Z. Definition exponent_neg_correct := BigZ.spec_opp. Definition exponent_add_correct := BigZ.spec_add. Definition exponent_sub_correct := BigZ.spec_sub. Lemma exponent_div2_floor_correct : forall e, let (e',b) := exponent_div2_floor e in EtoZ e = (2 * EtoZ e' + if b then 1 else 0)%Z. Proof. unfold exponent_div2_floor. intros [e|e]. unfold EtoZ. simpl BigZ.to_Z. rewrite BigN.spec_shiftr. rewrite <- Z.div2_spec. rewrite BigN.spec_even. rewrite <- Zodd_even_bool. apply Zdiv2_odd_eqn. rewrite BigN.spec_even. case_eq (Z.even (BigN.to_Z e)). unfold EtoZ. simpl BigZ.to_Z. rewrite BigN.spec_shiftr. rewrite <- Z.div2_spec. rewrite (Zdiv2_odd_eqn (BigN.to_Z e)) at 2. rewrite Zodd_even_bool. intros ->. simpl negb ; cbv iota. ring. unfold EtoZ. simpl BigZ.to_Z. rewrite BigN.spec_succ. rewrite BigN.spec_shiftr. rewrite <- Z.div2_spec. rewrite (Zdiv2_odd_eqn (BigN.to_Z e)) at 2. rewrite Zodd_even_bool. intros ->. simpl negb ; cbv iota. ring. Qed. Lemma PtoM_correct : forall n, MtoP (PtoM n) = n. Proof. intros. unfold MtoP, PtoM. rewrite BigN.spec_of_pos. apply refl_equal. Qed. Lemma mantissa_pos_correct : forall x, valid_mantissa x -> MtoZ (mantissa_pos x) = Zpos (MtoP x). Proof. intros x (p, H). unfold MtoZ, MtoP. simpl. rewrite H. apply refl_equal. Qed. Lemma mantissa_neg_correct : forall x, valid_mantissa x -> MtoZ (mantissa_neg x) = Zneg (MtoP x). Proof. intros x (p, H). unfold MtoZ, MtoP. simpl. rewrite H. apply refl_equal. Qed. Lemma mantissa_even_correct : forall x, valid_mantissa x -> mantissa_even x = Z.even (Zpos (MtoP x)). Proof. intros x (px, Hx). unfold mantissa_even, Zeven, MtoP. generalize (BigN.spec_even x). rewrite Hx. case (BigN.even x) ; destruct px as [px|px|] ; try easy. Qed. Lemma mantissa_one_correct : MtoP mantissa_one = xH /\ valid_mantissa mantissa_one. Proof. repeat split. now exists xH. Qed. Lemma mantissa_add_correct : forall x y, valid_mantissa x -> valid_mantissa y -> MtoP (mantissa_add x y) = (MtoP x + MtoP y)%positive /\ valid_mantissa (mantissa_add x y). Proof. intros x y (px, Hx) (py, Hy). unfold mantissa_add, valid_mantissa, MtoP. rewrite BigN.spec_add. rewrite Hx, Hy. repeat split. now exists (px + py)%positive. Qed. Lemma mantissa_sub_correct : forall x y, valid_mantissa x -> valid_mantissa y -> (MtoP y < MtoP x)%positive -> MtoP (mantissa_sub x y) = (MtoP x - MtoP y)%positive /\ valid_mantissa (mantissa_sub x y). Proof. intros x y (px, Hx) (py, Hy). unfold mantissa_sub, valid_mantissa, MtoP. rewrite BigN.spec_sub. rewrite Hx, Hy. simpl. rewrite Z.pos_sub_spec. case Pos.compare_spec. intros H1 H2. elim (Pos.lt_irrefl py). now rewrite H1 in H2. intros H1 H2. elim (Pos.lt_irrefl py). now apply Pos.lt_trans with px. intros H _. repeat split. now exists (px - py)%positive. Qed. Lemma mantissa_mul_correct : forall x y, valid_mantissa x -> valid_mantissa y -> MtoP (mantissa_mul x y) = (MtoP x * MtoP y)%positive /\ valid_mantissa (mantissa_mul x y). intros x y (px, Hx) (py, Hy). unfold mantissa_mul, valid_mantissa, MtoP. rewrite BigN.spec_mul. rewrite Hx, Hy. simpl. split. apply refl_equal. exists (px * py)%positive. apply refl_equal. Qed. Lemma mantissa_cmp_correct : forall x y, valid_mantissa x -> valid_mantissa y -> mantissa_cmp x y = Z.compare (Zpos (MtoP x)) (Zpos (MtoP y)). intros x y (px, Hx) (py, Hy). unfold mantissa_cmp, MtoP. rewrite Hx, Hy, <- Hx, <- Hy. apply BigN.spec_compare. Qed. Lemma exponent_cmp_correct : forall x y, exponent_cmp x y = Z.compare (MtoZ x) (MtoZ y). intros. unfold exponent_cmp, MtoZ. apply sym_eq. generalize (BigZ.spec_compare x y). unfold Z.lt, Z.gt. case (x ?= y)%bigZ ; intro H ; rewrite H ; first [ apply Z.compare_refl | apply refl_equal ]. Qed. Lemma mantissa_digits_correct : forall x, valid_mantissa x -> EtoZ (mantissa_digits x) = Zpos (count_digits radix (MtoP x)). Proof. intros x (px, Vx). unfold mantissa_digits, EtoZ. simpl. rewrite BigN.spec_sub_pos. rewrite BigN.spec_Ndigits. rewrite <- digits_conversion. rewrite <- Zplus_0_r. rewrite <- (Zplus_opp_r (BigN.to_Z (BigN.head0 x)))%Z. rewrite Zplus_assoc. apply (f_equal (fun v => v + _)%Z). rewrite <- Zdigits_mult_Zpower. 2: now apply Zgt_not_eq. 2: apply BigN.spec_pos. refine (_ (BigN.spec_head0 x _)). 2: now rewrite Vx. intros (H1,H2). unfold MtoP. rewrite Vx. set (d := Zdigits radix (Zpos px * radix ^ (BigN.to_Z (BigN.head0 x)))). cut (d <= Zpos (BigN.digits x) /\ Zpos (BigN.digits x) - 1 < d)%Z. lia. unfold d ; clear d. split. apply Zdigits_le_Zpower. rewrite Zabs_Zmult, Zmult_comm. rewrite Z.abs_eq. simpl Z.abs. now rewrite <- Vx. apply Zpower_ge_0. apply Zdigits_gt_Zpower. rewrite Zabs_Zmult, Zmult_comm. rewrite Z.abs_eq. simpl Z.abs. now rewrite <- Vx. apply Zpower_ge_0. rewrite BigN.spec_Ndigits. assert (Zpower 2 (BigN.to_Z (BigN.head0 x)) * 1 < Zpower 2 (Zpos (BigN.digits x)))%Z. apply Z.le_lt_trans with (Zpower 2 (BigN.to_Z (BigN.head0 x)) * Zpos px)%Z. apply Zmult_le_compat_l. now case px. apply (Zpower_ge_0 radix2). rewrite <- Vx. apply BigN.spec_head0. now rewrite Vx. change (~ ((BigN.to_Z (BigN.head0 x)) > Zpos (BigN.digits x))%Z). intros H'. apply (Zlt_not_le _ _ H). rewrite Zmult_1_r. apply (Zpower_le radix2). apply Zlt_le_weak. now apply Z.gt_lt. Qed. Lemma mantissa_scale2_correct : forall x d, valid_mantissa x -> let (x',d') := mantissa_scale2 x d in (IZR (Zpos (MtoP x')) * bpow radix (EtoZ d') = IZR (Zpos (MtoP x)) * bpow radix2 (EtoZ d))%R /\ valid_mantissa x'. Proof. intros x d Vx. repeat split. exact Vx. Qed. Lemma mantissa_shl_correct : forall x y z, valid_mantissa y -> EtoZ z = Zpos x -> MtoP (mantissa_shl y z) = shift radix (MtoP y) x /\ valid_mantissa (mantissa_shl y z). Proof. intros x y z (py, Vy) Hz. unfold mantissa_shl, MtoP, valid_mantissa. rewrite BigN.spec_shiftl, Vy. enough (Z.shiftl (Zpos py) (BigN.to_Z (BigZ.to_N z)) = Zpos (shift radix py x))%Z as ->. repeat split. refl_exists. unfold EtoZ in Hz. rewrite spec_to_Z, Hz. rewrite Z.shiftl_mul_pow2 by easy. rewrite shift_correct. now rewrite Z.pow_pos_fold. Qed. Lemma mantissa_sign_correct : forall x, match mantissa_sign x with | Mzero => MtoZ x = Z0 | Mnumber s p => MtoZ x = (if s then Zneg else Zpos) (MtoP p) /\ valid_mantissa p end. intros. unfold mantissa_sign. rewrite BigZ.spec_eqb. case Z.eqb_spec. easy. change (BigZ.to_Z 0%bigZ) with Z0. case x ; unfold valid_mantissa ; simpl ; intros ; rename n into H. (* + *) assert (BigN.to_Z t = Zpos (MtoP t)). generalize H. clear. unfold MtoP. generalize (BigN.spec_pos t). case (BigN.to_Z t) ; intros. elim H0. apply refl_equal. apply refl_equal. elim H. apply refl_equal. split. exact H0. exists (MtoP t). exact H0. (* - *) assert (- BigN.to_Z t = Zneg (MtoP t))%Z. generalize H. clear. unfold MtoP. generalize (BigN.spec_pos t). case (BigN.to_Z t) ; intros. elim H0. apply refl_equal. apply refl_equal. elim H. apply refl_equal. split. exact H0. exists (MtoP t). exact (BinInt.Z.opp_inj _ (Zpos _) H0). Qed. Lemma mantissa_shr_correct : forall x y z k, valid_mantissa y -> EtoZ z = Zpos x -> (Zpos (shift radix 1 x) <= Zpos (MtoP y))%Z -> let (sq,l) := mantissa_shr y z k in let (q,r) := Z.div_eucl (Zpos (MtoP y)) (Zpos (shift radix 1 x)) in Zpos (MtoP sq) = q /\ l = adjust_pos r (shift radix 1 x) k /\ valid_mantissa sq. Proof. intros x y z k [y' Vy] Ezx. unfold mantissa_shr, MtoP. unfold EtoZ in Ezx. rewrite Vy. intros Hy. unfold valid_mantissa. rewrite BigN.spec_shiftr_pow2. rewrite spec_to_Z_pos by now rewrite Ezx. rewrite Vy, Ezx. generalize (Z.div_str_pos _ _ (conj (refl_equal Lt : (0 < Zpos _)%Z) Hy)). generalize (Z_div_mod (Z.pos y') (Z.pos (shift radix 1 x)) (eq_refl Gt)). rewrite shift_correct, Zmult_1_l. change (Zpower 2 (Zpos x)) with (Z.pow_pos radix x). unfold Z.div. case Z.div_eucl. intros q r. revert Hy. change (adjust_pos r (shift radix 1 x) k) with (match Z.pos (shift radix 1 x) with Zpos v => adjust_pos r v k | _ => pos_Eq end). rewrite shift_correct, Zmult_1_l. intros Hy [H2 H3]. destruct q as [|q|q] ; try easy. intros _. refine (conj (eq_refl _) (conj _ (ex_intro _ q (eq_refl _)))). generalize (BigN.spec_tail0 y). rewrite Vy. intros H. specialize (H (eq_refl Lt)). destruct H as [yn [Hy1 Hy2]]. rewrite BigN.spec_compare. rewrite BigN.spec_even. rewrite BigN.spec_shiftr_pow2. rewrite Vy. rewrite BigN.spec_pred_pos ; rewrite BigZ.spec_to_Z_pos ; rewrite Ezx ; try easy. unfold adjust_pos. change (Z.pow_pos radix x) with (Z.pow_pos (Zpos 2) x). rewrite <- Pos2Z.inj_pow_pos. assert (Hp : (0 <= Zpos x - 1)%Z). now apply (Zlt_0_le_0_pred (Zpos x)). assert (H2x : (2^x)%positive = xO (Z.to_pos (2 ^ (Zpos x - 1)))). clear -Hp. rewrite <- (Z2Pos.inj_pow_pos 2) by easy. change (Z.pow_pos 2 x) with (Zpower 2 (Zpos x)). pattern (Zpos x) at 1 ; replace (Zpos x) with (1 + (Zpos x - 1))%Z by ring. rewrite Zpower_plus by easy. rewrite Z2Pos.inj_mul ; try easy. now apply (Zpower_gt_0 radix2). rewrite H2x. case Zcompare_spec ; intros Hc. - rewrite Zeven_mod. assert (Hy': (Zpos y' / Zpower 2 (Zpos x - 1) = Zpos q * 2 + r / Zpower 2 (Zpos x - 1))%Z). rewrite H2. rewrite Zplus_comm, Zmult_comm. change (Z.pow_pos radix x) with (Zpower 2 (Zpos x)). pattern (Zpos x) at 1 ; replace (Zpos x) with (1 + (Zpos x - 1))%Z by ring. rewrite Zpower_plus by easy. rewrite Zmult_assoc. rewrite (Zplus_comm (Zpos q * 2)). apply Z_div_plus_full. now apply Zgt_not_eq, (Zpower_gt_0 radix2). rewrite Hy'. rewrite Zplus_comm, Z_mod_plus_full. case Zcompare_spec ; intros Hr. + rewrite Zeq_bool_true. destruct r as [|r|r] ; [|easy|]. 2: now elim (proj1 H3). destruct k ; try easy. contradict H2. rewrite Hy2, Zplus_0_r. change (Z.pow_pos radix x) with (Zpower 2 (Zpos x)). replace (Zpos x) with (Zpos x - 1 - (BigN.to_Z (BigN.tail0 y)) + 1 + (BigN.to_Z (BigN.tail0 y)))%Z by ring. rewrite <- (Zmult_comm (Zpos q)). rewrite Zpower_plus. 2: clear -Hc ; lia. 2: apply BigN.spec_pos. rewrite Zmult_assoc. intros H. apply Z.mul_reg_r in H. 2: apply Zgt_not_eq, (Zpower_gt_0 radix2), BigN.spec_pos. revert H. rewrite Zpower_plus ; try easy. 2: clear -Hc ; lia. change (2 ^ 1)%Z with 2%Z. clear ; intros. apply (f_equal Z.even) in H. revert H. rewrite Zplus_comm, Z.even_add_mul_2. rewrite Zmult_assoc, Z.even_mul. now rewrite orb_comm. rewrite Zdiv_small. easy. split. apply H3. rewrite Z2Pos.id in Hr. exact Hr. now apply (Zpower_gt_0 radix2). + contradict H2. rewrite Hy2, Hr. rewrite Z2Pos.id. 2: apply (Zpower_gt_0 radix2) ; clear ; lia. change (Z.pow_pos radix x) with (Zpower 2 (Zpos x)). pattern (Zpos x) at 1 ; replace (Zpos x) with (1 + (Zpos x - 1))%Z by ring. rewrite Zpower_plus by easy. change (2 ^ 1)%Z with 2%Z. replace (2 * 2 ^ (Zpos x - 1) * Zpos q + 2 ^ (Zpos x - 1))%Z with ((1 + Zpos q * 2) * 2 ^ (Zpos x - 1))%Z by ring. replace (Zpos x - 1)%Z with (Zpos x - 2 - (BigN.to_Z (BigN.tail0 y)) + ((BigN.to_Z (BigN.tail0 y)) + 1))%Z by ring. rewrite Zpower_plus. 2: clear -Hc ; lia. 2: apply Z.le_le_succ_r, BigN.spec_pos. intros H2. apply (f_equal (fun v => Zmod v (2 ^ ((BigN.to_Z (BigN.tail0 y)) + 1)))) in H2. revert H2. rewrite Zmult_assoc, Z_mod_mult. rewrite Zmult_plus_distr_l. rewrite (Zmult_comm 2), <- Zmult_assoc, Zmult_1_l. rewrite Zplus_comm, (Zmult_comm 2). rewrite <- (Zpower_plus 2 _ 1). 2: apply BigN.spec_pos. 2: easy. rewrite Z_mod_plus_full. rewrite Zmod_small. apply Zgt_not_eq. apply (Zpower_gt_0 radix2). apply BigN.spec_pos. split. apply (Zpower_ge_0 radix2). apply (Zpower_lt radix2). apply Z.le_le_succ_r, BigN.spec_pos. apply Z.lt_succ_diag_r. + rewrite Zeq_bool_false. clear -Hr. now destruct r as [|r|r]. rewrite Zmod_small. apply Zgt_not_eq. apply Z.gt_lt, Zle_succ_gt. apply Z.div_le_lower_bound. now apply (Zpower_gt_0 radix2). rewrite Zmult_1_r. rewrite Z2Pos.id in Hr. now apply Zlt_le_weak. now apply (Zpower_gt_0 radix2). split. now apply BigNumPrelude.div_le_0. apply Z.div_lt_upper_bound. now apply (Zpower_gt_0 radix2). rewrite <- (Zpower_plus 2 _ 1) by easy. now ring_simplify (Zpos x - 1 + 1)%Z. - replace r with (Zpos (Z.to_pos (2^(Zpos x - 1)))). now rewrite Z.compare_refl. rewrite Z2Pos.id. 2: apply (Zpower_gt_0 radix2) ; clear ; lia. replace (Zpower 2 (Zpos x - 1)) with (Zmod (Zpos y') (Zpower 2 (Zpos x))). apply sym_eq. apply Z.mod_unique_pos with (1 := H3) (2 := H2). rewrite Hy2, Hc. rewrite Zmult_plus_distr_l, (Zmult_comm 2), Zmult_1_l. rewrite <- Zmult_assoc. rewrite <- (Zpower_plus 2 1). ring_simplify (1 + (Zpos x - 1))%Z. rewrite Zplus_comm, Z_mod_plus_full. apply Zmod_small. split. apply (Zpower_ge_0 radix2). apply (Zpower_lt radix2). easy. apply (Z.lt_pred_l (Zpos x)). easy. now case x. - replace r with Z0. reflexivity. apply sym_eq. replace Z0 with (Zmod (Zpos y') (Zpower 2 (Zpos x))). apply Z.mod_unique_pos with (1 := H3) (2 := H2). rewrite Hy2. replace (BigN.to_Z (BigN.tail0 y)) with ((BigN.to_Z (BigN.tail0 y)) - Zpos x + Zpos x)%Z by ring. rewrite Zpower_plus. rewrite Zmult_assoc. apply Z_mod_mult. clear -Hc ; lia. easy. Qed. Lemma mantissa_shrp_correct : forall x y z k, valid_mantissa y -> EtoZ z = Zpos x -> (Zpower radix (Zpos x - 1) <= Zpos (MtoP y) < Zpos (shift radix 1 x))%Z -> let l := mantissa_shrp y z k in l = adjust_pos (Zpos (MtoP y)) (shift radix 1 x) k. Proof. intros x y z k [v Hv] Ezx. unfold mantissa_shrp. case (Pos.succ_pred_or x); intro Hx. rewrite Hx. intros Hl; simpl in Hl. assert (MtoP y = 1%positive) by lia. rewrite H. unfold MtoP in H; rewrite Hv in H. destruct k; simpl; try easy. unfold EtoZ in Ezx. case BigN.compare_spec; try easy; intro H1; red in H1; rewrite !BigN.spec_shiftl, spec_to_Z, Ezx in H1; simpl Z.sgn in H1; rewrite Hx, Hv,H in H1; cbv in H1; inversion H1. rewrite <- Hx at 1. rewrite Pos2Z.inj_succ. replace (Z.succ (Z.pos (Pos.pred x)) - 1)%Z with (Z.pos (Pos.pred x)) by lia. intros [Hl _]. unfold mantissa_shrp. replace (shift radix 1 x) with (xO ((Z.to_pos radix) ^ (Pos.pred x))); last first. apply Pos2Z.inj. rewrite <- (Pos.mul_1_r (_ ^ _)), <- (Pos.mul_xO_r _ xH). rewrite Pos.mul_comm, <- Pos.pow_succ_r, Hx, shift_correct. rewrite !Z.pow_pos_fold, Pos2Z.inj_pow, radix_to_pos; lia. simpl. replace (BigN.shiftl y 1 ?= BigN.shiftl 1 (BigZ.to_N z))%bigN with (MtoP y ?= 2 ^ Pos.pred x)%positive. revert Hl. rewrite <-Z.pow_pos_fold, <- radix_to_pos, <- Pos2Z.inj_pow_pos. simpl. case Pos.compare_spec; try easy. intro H; lia. now destruct k. rewrite BigN.spec_compare, !BigN.spec_shiftl. rewrite Z.shiftl_1_l. unfold EtoZ in Ezx. rewrite spec_to_Z, Ezx. unfold MtoP; rewrite Hv. rewrite Z.mul_1_l. rewrite <- Hx at 2. rewrite Pos2Z.inj_succ. rewrite Z.pow_succ_r, Z.mul_comm; try lia. replace (Z.shiftl (Z.pos v) (BigN.to_Z 1)) with (Zpos v * 2)%Z by (cbn; lia). rewrite <- Pos2Z.inj_pow; try easy. now rewrite <- Zmult_compare_compat_r. Qed. Lemma mantissa_div_correct : forall x y, valid_mantissa x -> valid_mantissa y -> (Zpos (MtoP y) <= Zpos (MtoP x))%Z -> let (q,l) := mantissa_div x y in Zpos (MtoP q) = (Zpos (MtoP x) / Zpos (MtoP y))%Z /\ Bracket.inbetween_int (Zpos (MtoP q)) (IZR (Zpos (MtoP x)) / IZR (Zpos (MtoP y)))%R (convert_location_inv l) /\ valid_mantissa q. Proof. intros x y [x' Vx] [y' Vy]. unfold MtoP. rewrite Vx, Vy. unfold mantissa_div, mantissa_split_div. generalize (BigN.spec_div_eucl x y). generalize (Z_div_mod (Z.pos (MtoP x)) (Z.pos (MtoP y)) (eq_refl Gt)). unfold MtoP. rewrite Vx, Vy. destruct BigN.div_eucl as [q r]. destruct Z.div_eucl as [q' r']. intros [H1 H2] H. injection H. clear H. intros Hr' Vq Hxy. assert (H: (0 < q')%Z). apply Zmult_lt_reg_r with (Zpos y'). easy. rewrite Zmult_0_l, Zmult_comm. apply Zplus_lt_reg_r with r'. rewrite Zplus_0_l. rewrite <- H1. now apply Z.lt_le_trans with (2 := Hxy). destruct q' as [|q'|q'] ; try easy. rewrite Vq. clear H Hxy. assert (Hq := Zdiv_unique _ _ _ _ H2 H1). refine (conj Hq (conj _ (ex_intro _ _ Vq))). unfold Bracket.inbetween_int. rewrite BigN.spec_eqb. rewrite BigN.spec_compare. rewrite BigN.spec_shiftl_pow2. rewrite Hr', Vy. change (BigN.to_Z 0) with Z0. change (2 ^ (BigN.to_Z 1))%Z with 2%Z. destruct (Z.eqb_spec r' 0) as [Hr|Hr]. - apply Bracket.inbetween_Exact. rewrite H1, Hq, Hr, Zplus_0_r. rewrite mult_IZR. field. now apply IZR_neq. - replace (convert_location_inv _) with (Bracket.loc_Inexact (Z.compare (r' * 2) (Zpos y'))). 2: now case Z.compare. apply Bracket.inbetween_Inexact. unfold Rdiv. rewrite H1, Zmult_comm. split ; apply Rmult_lt_reg_r with (IZR (Zpos y')) ; (try now apply IZR_lt) ; rewrite Rmult_assoc, Rinv_l, Rmult_1_r, <- mult_IZR ; (try now apply IZR_neq) ; apply IZR_lt. clear -H2 Hr ; lia. rewrite Zmult_plus_distr_l. clear -H2 ; lia. rewrite H1, 2!plus_IZR, mult_IZR. destruct (Z.compare_spec (r' * 2) (Zpos y')) as [H|H|H]. + apply Rcompare_Eq. rewrite <- H. rewrite mult_IZR. field. now apply IZR_neq. + apply Rcompare_Lt. apply Rminus_gt. match goal with |- (?a > 0)%R => replace a with ((IZR (Zpos y') - IZR r' * 2) / (2 * IZR (Zpos y')))%R end. apply Fourier_util.Rlt_mult_inv_pos. apply Rgt_minus. rewrite <- mult_IZR. now apply IZR_lt. apply Rmult_lt_0_compat. apply Rlt_0_2. now apply IZR_lt. field. now apply IZR_neq. + apply Rcompare_Gt. apply Rminus_lt. match goal with |- (?a < 0)%R => replace a with (- ((IZR r' * 2 - IZR (Zpos y')) / (2 * IZR (Zpos y'))))%R end. apply Ropp_lt_gt_0_contravar. apply Fourier_util.Rlt_mult_inv_pos. apply Rgt_minus. rewrite <- mult_IZR. now apply IZR_lt. apply Rmult_lt_0_compat. apply Rlt_0_2. now apply IZR_lt. field. now apply IZR_neq. Qed. Lemma mantissa_sqrt_correct : forall x, valid_mantissa x -> let (q,l) := mantissa_sqrt x in let (s,r) := Z.sqrtrem (Zpos (MtoP x)) in Zpos (MtoP q) = s /\ match l with pos_Eq => r = Z0 | pos_Lo => (0 < r <= s)%Z | pos_Mi => False | pos_Up => (s < r)%Z end /\ valid_mantissa q. Proof. intros x [x' Vx]. unfold mantissa_sqrt, MtoP. rewrite BigN.spec_eqb. rewrite BigN.spec_compare. rewrite BigN.spec_sub. rewrite BigN.spec_square. rewrite BigN.spec_sqrt. rewrite <- Z.sqrtrem_sqrt. refine (_ (Z.sqrtrem_spec (Zpos x') _)). 2: easy. rewrite Vx. case_eq (Z.sqrtrem (Zpos x')). intros s r Hsr. simpl fst. intros [H1 H2]. refine ((fun H => conj (proj1 H) (conj _ (proj2 H))) _). clear H. rewrite H1. replace (s * s + r - s * s)%Z with r by ring. rewrite Zmax_right by easy. change (BigN.to_Z 0) with Z0. case Z.eqb_spec. easy. intros H. assert (H3: (0 < r)%Z) by lia. case Zcompare_spec ; intros H4. apply (conj H3). now apply Zlt_le_weak. apply (conj H3). now apply Zeq_le. exact H4. destruct s as [|s|s]. simpl in H1. rewrite <- H1 in H2. now elim (proj2 H2). split. apply eq_refl. exists s. rewrite BigN.spec_sqrt. rewrite <- Z.sqrtrem_sqrt. now rewrite Vx, Hsr. now elim (Z.le_trans _ _ _ (proj1 H2) (proj2 H2)). Qed. End BigIntRadix2. interval-4.11.1/src/Float/Specific_ops.v000066400000000000000000001451561470547631300201010ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals Lia Bool Psatz. From Flocq Require Import Zaux Raux Digits Bracket. From mathcomp.ssreflect Require Import ssrbool. Require Import Xreal. Require Import Basic. Require Import Generic. Require Import Generic_proof. Require Import Sig. Require Import Specific_sig. Inductive s_float (smantissa_type exponent_type : Type) : Type := | Fnan : s_float smantissa_type exponent_type | Float : smantissa_type -> exponent_type -> s_float smantissa_type exponent_type. Arguments Fnan {smantissa_type exponent_type}. Arguments Float {smantissa_type exponent_type} _ _. Module SpecificFloat (Carrier : FloatCarrier) <: FloatOps. Import Carrier. Definition sensible_format := match radix_val radix with Zpos (xO _) => true | _ => false end. Definition radix := radix. Definition type := s_float smantissa_type exponent_type. Definition toF (x : type) : float radix := match x with | Fnan => Basic.Fnan | Float m e => match mantissa_sign m with | Mzero => Basic.Fzero | Mnumber s p => Basic.Float s (MtoP p) (EtoZ e) end end. Definition toX (x : type) := FtoX (toF x). Definition toR (x : type) := proj_val (toX x). Definition convert (x : type) := FtoX (toF x). Definition fromF (f : Basic.float radix) := match f with | Basic.Fnan => Fnan | Basic.Fzero => Float mantissa_zero exponent_zero | Basic.Float false m e => Float (ZtoM (Zpos m)) (ZtoE e) | Basic.Float true m e => Float (ZtoM (Zneg m)) (ZtoE e) end. Definition precision := exponent_type. Definition sfactor := exponent_type. Definition prec p := match EtoZ p with Zpos q => q | _ => xH end. Definition ZtoS := ZtoE. Definition StoZ := EtoZ. Definition PtoP n := ZtoE (Zpos n). Definition incr_prec x y := exponent_add x (ZtoE (Zpos y)). Definition sm1 := ZtoE (-1). Definition zero := Float mantissa_zero exponent_zero. Definition nan := @Fnan smantissa_type exponent_type. Lemma zero_correct : toX zero = Xreal 0. Proof. generalize (mantissa_sign_correct mantissa_zero). unfold toX. simpl. case (mantissa_sign mantissa_zero). trivial. rewrite mantissa_zero_correct. intros s p. case s ; intros (H, _) ; discriminate H. Qed. Definition mag (x : type) := match x with | Fnan => exponent_zero | Float m e => match mantissa_sign m with | Mzero => e | Mnumber _ m => exponent_add e (mantissa_digits m) end end. Definition classify (f : type) := match f with Fnan => Sig.Fnan | _ => Sig.Freal end. Definition nan_correct := refl_equal Sig.Fnan. Definition real (f : type) := match f with Fnan => false | _ => true end. Definition is_nan (f : type) := match f with Fnan => true | _ => false end. Lemma classify_correct : forall f, real f = match classify f with Freal => true | _ => false end. Proof. now intro f; case f. Qed. Lemma real_correct : forall f, real f = match toX f with Xnan => false | _ => true end. Proof. intros. case f ; simpl. apply refl_equal. intros m e. unfold toX. simpl. now case (mantissa_sign m). Qed. Lemma is_nan_correct : forall f, is_nan f = match classify f with Sig.Fnan => true | _ => false end. Proof. now intro f; case f. Qed. Definition valid_ub (_ : type) := true. Definition valid_lb (_ : type) := true. Lemma valid_lb_correct : forall f, valid_lb f = match classify f with Fpinfty => false | _ => true end. Proof. now intro f; case f. Qed. Lemma valid_ub_correct : forall f, valid_ub f = match classify f with Fminfty => false | _ => true end. Proof. now intro f; case f. Qed. Definition fromZ n := Float (ZtoM n) exponent_zero. Lemma fromZ_correct' : forall n, toX (fromZ n) = Xreal (IZR n). Proof. intros. unfold toX. simpl. generalize (mantissa_sign_correct (ZtoM n)). case_eq (mantissa_sign (ZtoM n)) ; intros ; rewrite ZtoM_correct in *. rewrite H0. apply refl_equal. rewrite exponent_zero_correct. rewrite (proj1 H0). now case s. Qed. Lemma fromZ_correct : forall n, (Z.abs n <= 256)%Z -> toX (fromZ n) = Xreal (IZR n). Proof. intros n _. apply fromZ_correct'. Qed. Definition fromZ_DN (p : precision) := fromZ. Lemma fromZ_DN_correct : forall p n, valid_lb (fromZ_DN p n) = true /\ le_lower (toX (fromZ_DN p n)) (Xreal (IZR n)). Proof. intros p n. split. easy. rewrite fromZ_correct'. apply Rle_refl. Qed. Definition fromZ_UP (p : precision) := fromZ. Lemma fromZ_UP_correct : forall p n, valid_ub (fromZ_UP p n) = true /\ le_upper (Xreal (IZR n)) (toX (fromZ_UP p n)). Proof. intros p n. split. easy. rewrite fromZ_correct'. apply Rle_refl. Qed. Lemma match_helper_1 : forall A B y2, forall f : A -> B, forall x y1, f (match mantissa_sign x with Mzero => y1 | Mnumber s p => y2 s p end) = match mantissa_sign x with Mzero => f y1 | Mnumber s p => f (y2 s p) end. Proof. intros. now case (mantissa_sign x). Qed. Definition float_aux s m e : type := Float ((if s : bool then mantissa_neg else mantissa_pos) m) e. Lemma toF_float : forall s p e, valid_mantissa p -> toF (float_aux s p e) = Basic.Float s (MtoP p) (EtoZ e). Proof. intros. simpl. generalize (mantissa_sign_correct ((if s then mantissa_neg else mantissa_pos) p)). case (mantissa_sign ((if s then mantissa_neg else mantissa_pos) p)). case s. rewrite mantissa_neg_correct. intro H0 ; discriminate H0. exact H. rewrite mantissa_pos_correct. intro H0 ; discriminate H0. exact H. intros t q. case s. rewrite mantissa_neg_correct. case t ; intros (H1, H2). now inversion H1. discriminate H1. exact H. rewrite mantissa_pos_correct. case t ; intros (H1, H2). discriminate H1. now inversion H1. exact H. Qed. Lemma toX_Float : forall m e, toX (Float m e) = Xreal (toR (Float m e)). Proof. intros m e. unfold toR, toX, toF. now destruct mantissa_sign. Qed. (* * neg *) Definition neg (f : type) := match f with | Float m e => match mantissa_sign m with | Mzero => f | Mnumber s p => Float ((if s then mantissa_pos else mantissa_neg) p) e end | _ => f end. Lemma neg_correct : forall x, match classify x with | Freal => toX (neg x) = Xneg (toX x) | Sig.Fnan => classify (neg x) = Sig.Fnan | Fminfty => classify (neg x) = Fpinfty | Fpinfty => classify (neg x) = Fminfty end. Proof. intro x. case_eq (classify x); [|now case x..]. intro Cx. destruct x as [| m e]. apply refl_equal. unfold toX. simpl. generalize (mantissa_sign_correct m). case_eq (mantissa_sign m). simpl. intros -> _. now rewrite Ropp_0. intros s p H0 [H1 H2]. generalize (toF_float (negb s) p e H2). destruct s ; simpl ; intros -> ; now rewrite FtoR_neg. Qed. (* * abs *) Definition abs (f : type) := match f with | Float m e => match mantissa_sign m with | Mzero => f | Mnumber _ p => Float (mantissa_pos p) e end | _ => f end. Lemma abs_correct : forall x, toX (abs x) = Xabs (toX x) /\ (valid_ub (abs x) = true). Proof. intros. split; [|easy]. destruct x as [| m e]. apply refl_equal. unfold toX. simpl. generalize (mantissa_sign_correct m). case_eq (mantissa_sign m). simpl. intros -> _. now rewrite Rabs_R0. intros s p H0 [H1 H2]. generalize (toF_float false p e H2). simpl ; intros ->. now rewrite FtoR_abs. Qed. (* * scale *) Definition scale (f : type) d := match f with | Float m e => Float m (exponent_add e d) | _ => f end. (* * scale2 *) Definition scale2 (f : type) d := match f with | Float m e => match mantissa_sign m with | Mzero => f | Mnumber s p => match mantissa_scale2 p d with | (p2, d2) => float_aux s p2 (exponent_add e d2) end end | _ => f end. Lemma scale2_correct : forall x d, sensible_format = true -> toX (scale2 x d) = Xmul (toX x) (Xreal (bpow radix2 (StoZ d))). Proof. intros [|m e] d H. easy. unfold toX. simpl. generalize (mantissa_sign_correct m). case_eq (mantissa_sign m). intros Hs _. simpl. rewrite Hs. now rewrite Rmult_0_l. intros s m' _ (Em,Vm). simpl. generalize (mantissa_scale2_correct m' d Vm). case mantissa_scale2. intros p e' (Ep, Vp). rewrite toF_float with (1 := Vp). rewrite exponent_add_correct. simpl. rewrite 2!FtoR_split. unfold Defs.F2R. simpl. rewrite Rmult_assoc, (Rmult_comm (bpow radix (EtoZ e))). rewrite 2!IZR_cond_Zopp, <- 2!cond_Ropp_mult_l. apply (f_equal (fun v => Xreal (cond_Ropp s v))). rewrite Zplus_comm, bpow_plus, <- 2!Rmult_assoc. unfold radix. now rewrite Ep. Qed. (* * pow2 *) Definition pow2_UP (p : precision) e := if sensible_format then scale2 (Float (mantissa_pos mantissa_one) exponent_zero) e else Fnan. Lemma pow2_UP_correct : forall p s, (valid_ub (pow2_UP p s) = true /\ le_upper (Xscale radix2 (Xreal 1) (StoZ s)) (toX (pow2_UP p s))). Proof. intros. split. - easy. - unfold pow2_UP. unfold Xscale. destruct sensible_format eqn:H1. + rewrite scale2_correct by easy. unfold toX, toF, FtoX. generalize (mantissa_sign_correct (mantissa_pos mantissa_one)). rewrite mantissa_pos_correct by apply mantissa_one_correct. rewrite (proj1 mantissa_one_correct). destruct mantissa_sign. * easy. * destruct s0; [easy |]. unfold FtoR. rewrite exponent_zero_correct. intros [<- _]. apply le_upper_refl. + easy. Qed. Lemma ZtoS_correct: forall p z, (z <= StoZ (ZtoS z))%Z \/ toX (pow2_UP p (ZtoS z)) = Xnan. Proof. left. now rewrite ZtoE_correct. Qed. (* * mag *) Lemma mag_correct : forall f, (Rabs (toR f) < bpow radix (StoZ (mag f)))%R. Proof. intros f. unfold StoZ, mag. destruct f as [ |sm e]. { change (toR Fnan) with 0%R. rewrite Rabs_R0. apply bpow_gt_0. } unfold toR, toX. simpl. generalize (mantissa_sign_correct sm). destruct mantissa_sign as [ |s m]. { intros _. change (proj_val (FtoX Fzero)) with 0%R. rewrite Rabs_R0. apply bpow_gt_0. } simpl. intros H. rewrite FtoR_split. rewrite exponent_add_correct. rewrite mantissa_digits_correct by apply H. rewrite <- digits_conversion, Zplus_comm. apply Rlt_le_trans with (1 := bpow_mag_gt radix _). apply bpow_le, Z.eq_le_incl. rewrite <- Raux.mag_abs, <- Float_prop.F2R_Zabs, abs_cond_Zopp. now apply Float_prop.mag_F2R_Zdigits. Qed. (* * div2 *) Definition div2 (f : type) := scale2 f sm1. Lemma div2_correct : forall x, sensible_format = true -> (1 / 256 <= Rabs (toR x))%R -> toX (div2 x) = Xdiv (toX x) (Xreal 2). Proof. intros x Hf _. unfold div2, sm1. rewrite scale2_correct; [|easy]. simpl; unfold Z.pow_pos; simpl. rewrite Xdiv_split. unfold Xinv, Xinv'. unfold StoZ. rewrite ZtoE_correct. now rewrite is_zero_false. Qed. (* * cmp *) Definition cmp_aux1 m1 m2 := match mantissa_cmp m1 m2 with | Eq => Xeq | Lt => Xlt | Gt => Xgt end. Definition cmp_aux2 m1 e1 m2 e2 := let d1 := mantissa_digits m1 in let d2 := mantissa_digits m2 in match exponent_cmp (exponent_add e1 d1) (exponent_add e2 d2) with | Lt => Xlt | Gt => Xgt | Eq => let nb := exponent_sub e1 e2 in match exponent_cmp nb exponent_zero with | Gt => cmp_aux1 (mantissa_shl m1 nb) m2 | Lt => cmp_aux1 m1 (mantissa_shl m2 (exponent_neg nb)) | Eq => cmp_aux1 m1 m2 end end. Lemma cmp_aux2_correct : forall m1 e1 m2 e2, valid_mantissa m1 -> valid_mantissa m2 -> cmp_aux2 m1 e1 m2 e2 = Fcmp_aux2 radix (MtoP m1) (EtoZ e1) (MtoP m2) (EtoZ e2). Proof. intros m1 e1 m2 e2 H1 H2. unfold cmp_aux2, Fcmp_aux2. rewrite exponent_cmp_correct. do 2 rewrite exponent_add_correct. do 2 (rewrite mantissa_digits_correct ; [idtac | assumption]). unfold radix. case (EtoZ e1 + Zpos (count_digits Carrier.radix (MtoP m1)) ?= EtoZ e2 + Zpos (count_digits Carrier.radix (MtoP m2)))%Z ; try apply refl_equal. rewrite exponent_cmp_correct. rewrite exponent_zero_correct. rewrite exponent_sub_correct. case_eq (EtoZ e1 - EtoZ e2)%Z ; intros ; simpl ; unfold cmp_aux1, Fcmp_aux1. now rewrite mantissa_cmp_correct. generalize (mantissa_shl_correct p m1 (exponent_sub e1 e2) H1). rewrite exponent_sub_correct. refine (fun H0 => _ (proj1 (H0 H)) (proj2 (H0 H))). clear H0. intros H3 H4. rewrite mantissa_cmp_correct. rewrite H3. apply refl_equal. exact H4. exact H2. generalize (mantissa_shl_correct p m2 (exponent_neg (exponent_sub e1 e2)) H2). rewrite exponent_neg_correct. rewrite exponent_sub_correct. rewrite H. refine (fun H0 => _ (proj1 (H0 (refl_equal _))) (proj2 (H0 (refl_equal _)))). clear H0. intros H3 H4. rewrite mantissa_cmp_correct. rewrite H3. apply refl_equal. exact H1. exact H4. Qed. Definition cmp (f1 f2 : type) := match f1, f2 with | Fnan, _ => Xund | _, Fnan => Xund | Float m1 e1, Float m2 e2 => match mantissa_sign m1, mantissa_sign m2 with | Mzero, Mzero => Xeq | Mzero, Mnumber true _ => Xgt | Mzero, Mnumber false _ => Xlt | Mnumber true _, Mzero => Xlt | Mnumber false _, Mzero => Xgt | Mnumber true _, Mnumber false _ => Xlt | Mnumber false _, Mnumber true _ => Xgt | Mnumber true p1, Mnumber true p2 => cmp_aux2 p2 e2 p1 e1 | Mnumber false p1, Mnumber false p2 => cmp_aux2 p1 e1 p2 e2 end end. Lemma cmp_correct : forall x y, cmp x y = match classify x, classify y with | Sig.Fnan, _ | _, Sig.Fnan => Xund | Fminfty, Fminfty => Xeq | Fminfty, _ => Xlt | _, Fminfty => Xgt | Fpinfty, Fpinfty => Xeq | _, Fpinfty => Xlt | Fpinfty, _ => Xgt | Freal, Freal => Xcmp (toX x) (toX y) end. Proof. intros x y. unfold classify. destruct x as [|mx ex]. easy. destruct y as [|my ey]. easy. simpl. unfold toR, toX, toF. generalize (mantissa_sign_correct mx) (mantissa_sign_correct my). destruct (mantissa_sign mx) as [|[|] mx'] ; destruct (mantissa_sign my) as [|[|] my'] ; intros Hx Hy. - now simpl; rewrite Rcompare_Eq. - simpl; rewrite Rcompare_Gt. easy. apply FtoR_Rneg. - simpl; rewrite Rcompare_Lt. easy. apply FtoR_Rpos. - simpl; rewrite Rcompare_Lt. easy. apply FtoR_Rneg. - rewrite cmp_aux2_correct by easy. rewrite Fcmp_aux2_correct. simpl. change true with (negb false). rewrite <- 2!FtoR_neg. now rewrite Rcompare_opp. - simpl; rewrite Rcompare_Lt. easy. apply Rlt_trans with 0%R. apply FtoR_Rneg. apply FtoR_Rpos. - simpl; rewrite Rcompare_Gt. easy. apply FtoR_Rpos. - simpl; rewrite Rcompare_Gt. easy. apply Rlt_trans with 0%R. apply FtoR_Rneg. apply FtoR_Rpos. - rewrite cmp_aux2_correct by easy. now rewrite Fcmp_aux2_correct. Qed. (* * min *) Definition min x y := match cmp x y with | Xlt => x | Xeq => x | Xgt => y | Xund => nan end. Lemma min_correct : forall x y, match classify x, classify y with | Sig.Fnan, _ | _, Sig.Fnan => classify (min x y) = Sig.Fnan | Fminfty, _ | _, Fminfty => classify (min x y) = Fminfty | Fpinfty, _ => min x y = y | _, Fpinfty => min x y = x | Freal, Freal => toX (min x y) = Xmin (toX x) (toX y) end. Proof. intros [|mx ex] [|my ey]; [simpl; easy..|]. unfold classify. rewrite 2!toX_Float. unfold min, Xmin. rewrite cmp_correct by apply toX_Float. simpl. unfold Xcmp, toR. generalize (classify_correct (Float mx ex)). generalize (classify_correct (Float my ey)). rewrite !real_correct. simpl. case_eq (toX (Float my ey)); [easy|]; intros ry Hry _. case_eq (toX (Float mx ex)); [easy|]; intros rx Hrx _. simpl. case Rcompare_spec; intros H; rewrite toX_Float; unfold valid_lb, valid_ub; simpl. { unfold toR; rewrite Hrx; simpl. now apply f_equal; rewrite Rmin_left; [|apply Rlt_le]. } { unfold toR; rewrite Hrx; simpl. now apply f_equal; rewrite Rmin_left; [|apply Req_le]. } unfold toR; rewrite Hry; simpl. now apply f_equal; rewrite Rmin_right; [|apply Rlt_le]. Qed. (* * max *) Definition max x y := match cmp x y with | Xlt => y | Xeq => y | Xgt => x | Xund => nan end. Lemma max_correct : forall x y, match classify x, classify y with | Sig.Fnan, _ | _, Sig.Fnan => classify (max x y) = Sig.Fnan | Fpinfty, _ | _, Fpinfty => classify (max x y) = Fpinfty | Fminfty, _ => max x y = y | _, Fminfty => max x y = x | Freal, Freal => toX (max x y) = Xmax (toX x) (toX y) end. Proof. intros [|mx ex] [|my ey]; [simpl; easy..|]. unfold classify. rewrite 2!toX_Float. unfold max, Xmax. rewrite cmp_correct by apply toX_Float. simpl. unfold Xcmp, toR. generalize (classify_correct (Float mx ex)). generalize (classify_correct (Float my ey)). rewrite !real_correct. simpl. case_eq (toX (Float my ey)); [easy|]; intros ry Hry _. case_eq (toX (Float mx ex)); [easy|]; intros rx Hrx _. simpl. case Rcompare_spec; intros H; rewrite toX_Float; unfold valid_lb, valid_ub; simpl. { unfold toR; rewrite Hry; simpl. now apply f_equal; rewrite Rmax_right; [|apply Rlt_le]. } { unfold toR; rewrite Hry; simpl. now apply f_equal; rewrite Rmax_right; [|apply Req_le]. } unfold toR; rewrite Hrx; simpl. now apply f_equal; rewrite Rmax_left; [|apply Rlt_le]. Qed. (* * round *) Definition adjust_mantissa mode m pos sign := if need_change mode (mantissa_even m) pos sign then mantissa_add m mantissa_one else m. Lemma adjust_mantissa_correct : forall mode m pos sign, valid_mantissa m -> MtoP (adjust_mantissa mode m pos sign) = Generic.adjust_mantissa mode (MtoP m) pos sign /\ valid_mantissa (adjust_mantissa mode m pos sign). Proof. intros mode m pos sign Hm. unfold adjust_mantissa, Generic.adjust_mantissa. rewrite mantissa_even_correct with (1 := Hm). unfold Z.even. case need_change. 2: now split. destruct mantissa_one_correct as (Oe, Ov). rewrite Pplus_one_succ_r. rewrite <- Oe. now apply mantissa_add_correct. Qed. Definition round_aux mode prec sign m1 e1 pos := let prec := match exponent_cmp prec exponent_zero with Gt => prec | _ => exponent_one end in let nb := exponent_sub (mantissa_digits m1) prec in let e2 := exponent_add e1 nb in match exponent_cmp nb exponent_zero with | Gt => let (m2, pos2) := mantissa_shr m1 nb pos in float_aux sign (adjust_mantissa mode m2 pos2 sign) e2 | Eq => float_aux sign (adjust_mantissa mode m1 pos sign) e1 | Lt => float_aux sign m1 e1 end. Lemma round_aux_correct : forall mode p sign m1 e1 pos, valid_mantissa m1 -> FtoX (toF (round_aux mode p sign m1 e1 pos)) = FtoX (Fround_at_prec mode (prec p) (@Generic.Ufloat radix sign (MtoP m1) (EtoZ e1) pos)). Proof. intros mode p' sign m1 e1 pos Hm1. apply f_equal. unfold round_aux. set (p := match exponent_cmp p' exponent_zero with Gt => p' | _ => exponent_one end). assert (Hp: Zpos (prec p') = EtoZ p). unfold p. rewrite exponent_cmp_correct, exponent_zero_correct. unfold prec. case_eq (EtoZ p') ; try easy ; intros ; apply sym_eq ; apply exponent_one_correct. clearbody p. rewrite exponent_cmp_correct. rewrite exponent_sub_correct. rewrite exponent_zero_correct. rewrite mantissa_digits_correct with (1 := Hm1). unfold Fround_at_prec. rewrite Hp. unfold radix. case_eq (Zpos (count_digits Carrier.radix (MtoP m1)) - EtoZ p)%Z ; unfold Z.compare. (* *) intros Hd. destruct (adjust_mantissa_correct mode m1 pos sign Hm1) as (H1,H2). rewrite toF_float with (1 := H2). now rewrite H1. (* *) intros dp Hd. refine (_ (mantissa_shr_correct dp m1 (exponent_sub (mantissa_digits m1) p) pos Hm1 _ _)). case mantissa_shr. intros sq sl. case Z.div_eucl. intros q r (Hq, (Hl, Vq)). rewrite <- Hq. destruct (adjust_mantissa_correct mode sq sl sign Vq) as (Ha, Va). rewrite toF_float with (1 := Va). rewrite Ha. rewrite exponent_add_correct, exponent_sub_correct, mantissa_digits_correct with (1 := Hm1). now rewrite Hd, Hl. now rewrite exponent_sub_correct, mantissa_digits_correct. rewrite shift_correct, Zmult_1_l. change (Zpower Carrier.radix (Zpos dp) <= Z.abs (Zpos (MtoP m1)))%Z. apply Zpower_le_Zdigits. rewrite <- Hd, <- Hp. rewrite <- digits_conversion. clear ; lia. (* *) intros dp Hd. now rewrite toF_float. Qed. Definition round_at_exp_aux mode e2 sign m1 e1 pos := let nb := exponent_sub e2 e1 in match exponent_cmp nb exponent_zero with | Gt => match exponent_cmp (mantissa_digits m1) nb with | Gt => let (m2, pos2) := mantissa_shr m1 nb pos in float_aux sign (adjust_mantissa mode m2 pos2 sign) e2 | Eq => let pos2 := mantissa_shrp m1 nb pos in if need_change_zero mode pos2 sign then float_aux sign mantissa_one e2 else zero | Lt => let pos2 := match pos with pos_Eq => pos_Eq | _ => pos_Lo end in if need_change_zero mode pos_Lo sign then float_aux sign mantissa_one e2 else zero end | Eq => float_aux sign (adjust_mantissa mode m1 pos sign) e1 | Lt => float_aux sign m1 e1 end. Lemma toF_zero : toF zero = Fzero. Proof. unfold toF; simpl. generalize (mantissa_sign_correct mantissa_zero). rewrite mantissa_zero_correct. now destruct mantissa_sign; try easy; destruct s; intros []; discriminate. Qed. Lemma round_at_exp_aux_correct : forall mode e2 sign m1 e1 pos, valid_mantissa m1 -> FtoX (toF (round_at_exp_aux mode e2 sign m1 e1 pos)) = FtoX (Fround_at_exp mode (EtoZ e2) (@Generic.Ufloat radix sign (MtoP m1) (EtoZ e1) pos)). Proof. intros mode p' sign m1 e1 pos Hm1. apply f_equal. unfold round_at_exp_aux. rewrite exponent_cmp_correct. rewrite exponent_sub_correct. rewrite exponent_zero_correct. unfold Fround_at_exp. unfold radix. case_eq (EtoZ p' - EtoZ e1)%Z ; unfold Z.compare. (* *) intros Hd. destruct (adjust_mantissa_correct mode m1 pos sign Hm1) as (H1,H2). now rewrite toF_float, H1. (* *) intros dp Hd. rewrite exponent_cmp_correct, mantissa_digits_correct, exponent_sub_correct; try easy. rewrite Hd; simpl Z.compare. case Pos.compare_spec. - intros Hc. rewrite <- mantissa_shrp_correct with (z := (exponent_sub p' e1)); try easy; last 2 first. - now rewrite exponent_sub_correct. - rewrite shift_correct, Z.pow_pos_fold. rewrite <- Hc, <- digits_conversion. destruct (Zdigits_correct Carrier.radix (Z.pos (MtoP m1))). now lia. - destruct need_change_zero; try easy. - destruct mantissa_one_correct as [Ho1 Ho2]. now rewrite toF_float, Ho1. - now apply toF_zero. - intros Hc. rewrite fun_if with (f := toF). destruct mantissa_one_correct as [Ho1 Ho2]. now rewrite toF_zero, toF_float, Ho1. - intros Hc. refine ( _ (mantissa_shr_correct dp m1 (exponent_sub p' e1) pos Hm1 _ _)); last 2 first. - now rewrite exponent_sub_correct. - rewrite shift_correct, Z.pow_pos_fold. - assert (He: (Zpos dp <= Zpos ( count_digits Carrier.radix (MtoP m1)) -1)%Z) by lia. generalize (Zpower_le Carrier.radix _ _ He). rewrite <- digits_conversion. destruct (Zdigits_correct Carrier.radix (Z.pos (MtoP m1))). now lia. case mantissa_shr. intros sq sl. case Z.div_eucl. intros q r (Hq, (Hl, Vq)). rewrite <- Hq. destruct (adjust_mantissa_correct mode sq sl sign Vq) as (Ha, Va). rewrite toF_float with (1 := Va). now rewrite Ha, <- Hl. (* *) intros dp Hd. now rewrite toF_float. Qed. (* * mul *) Definition mul mode prec (x y : type) := match x, y with | Fnan, _ => x | _, Fnan => y | Float mx ex, Float my ey => match mantissa_sign mx, mantissa_sign my with | Mzero, _ => x | _, Mzero => y | Mnumber sx mx, Mnumber sy my => round_aux mode prec (xorb sx sy) (mantissa_mul mx my) (exponent_add ex ey) pos_Eq end end. Lemma mul_correct : forall mode p x y, toX (mul mode p x y) = Xround radix mode (prec p) (Xmul (toX x) (toX y)). Proof. intros mode p x y. unfold toX. rewrite <- Fmul_correct. destruct x as [|mx ex] ; destruct y as [|my ey] ; try easy. simpl. now case (mantissa_sign mx). simpl. generalize (mantissa_sign_correct mx). case_eq (mantissa_sign mx). simpl. intros. rewrite H. now case (mantissa_sign my). intros sx px Hx (Hx1, Hx2). rewrite (match_helper_1 _ _ (fun s py => round_aux mode p (Datatypes.xorb sx s) (mantissa_mul px py) (exponent_add ex ey) pos_Eq) (fun a => FtoX (toF a))). rewrite (match_helper_1 _ _ (fun s p => Basic.Float s (MtoP p) (EtoZ ey)) (fun a => FtoX (Fmul mode (prec p) (Basic.Float sx (MtoP px) (EtoZ ex)) a))). simpl. generalize (mantissa_sign_correct my). case (mantissa_sign my). trivial. intros sy py (_, Hy2). destruct (mantissa_mul_correct px py) as (H1, H2) ; try assumption. rewrite round_aux_correct. rewrite H1. clear H1. rewrite exponent_add_correct. apply refl_equal. exact H2. Qed. Definition mul_UP := mul rnd_UP. Definition is_non_neg x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 <= r)%R end. Definition is_non_neg' x := match toX x with Xnan => valid_ub x = true | Xreal r => (0 <= r)%R end. Definition is_pos x := valid_ub x = true /\ match toX x with Xnan => True | Xreal r => (0 < r)%R end. Definition is_non_pos x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r <= 0)%R end. Definition is_non_pos' x := match toX x with Xnan => valid_lb x = true | Xreal r => (r <= 0)%R end. Definition is_neg x := valid_lb x = true /\ match toX x with Xnan => True | Xreal r => (r < 0)%R end. Definition is_non_neg_real x := match toX x with Xnan => False | Xreal r => (0 <= r)%R end. Definition is_pos_real x := match toX x with Xnan => False | Xreal r => (0 < r)%R end. Definition is_non_pos_real x := match toX x with Xnan => False | Xreal r => (r <= 0)%R end. Definition is_neg_real x := match toX x with Xnan => False | Xreal r => (r < 0)%R end. Lemma mul_UP_correct : forall p x y, ((is_non_neg' x /\ is_non_neg' y) \/ (is_non_pos' x /\ is_non_pos' y) \/ (is_non_pos_real x /\ is_non_neg_real y) \/ (is_non_neg_real x /\ is_non_pos_real y)) -> valid_ub (mul_UP p x y) = true /\ le_upper (Xmul (toX x) (toX y)) (toX (mul_UP p x y)). Proof. intros p x y _; split; [reflexivity|]. unfold mul_UP. rewrite mul_correct. unfold Xround, Xlift. set (z := Xmul _ _); case z; [exact I|]; intro zr. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Definition mul_DN := mul rnd_DN. Lemma mul_DN_correct : forall p x y, ((is_non_neg_real x /\ is_non_neg_real y) \/ (is_non_pos_real x /\ is_non_pos_real y) \/ (is_non_neg' x /\ is_non_pos' y) \/ (is_non_pos' x /\ is_non_neg' y)) -> (valid_lb (mul_DN p x y) = true /\ le_lower (toX (mul_DN p x y)) (Xmul (toX x) (toX y))). Proof. intros p x y _; split; [reflexivity|]. unfold mul_DN. rewrite mul_correct. unfold Xround, Xlift. set (z := Xmul _ _); case z; [exact I|]; intro zr. now apply Ropp_le_contravar, Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. (* * add_exact *) Definition add_exact_aux1 sx sy mx my e := if eqb sx sy then float_aux sx (mantissa_add mx my) e else match mantissa_cmp mx my with | Eq => zero | Gt => float_aux sx (mantissa_sub mx my) e | Lt => float_aux sy (mantissa_sub my mx) e end. Definition add_exact_aux2 sx sy mx my ex ey := let nb := exponent_sub ex ey in match exponent_cmp nb exponent_zero with | Gt => add_exact_aux1 sx sy (mantissa_shl mx nb) my ey | Lt => add_exact_aux1 sx sy mx (mantissa_shl my (exponent_neg nb)) ex | Eq => add_exact_aux1 sx sy mx my ex end. Definition add_exact (x y : type) := match x, y with | Fnan, _ => x | _, Fnan => y | Float mx ex, Float my ey => match mantissa_sign mx, mantissa_sign my with | Mzero, _ => y | _, Mzero => x | Mnumber sx mx, Mnumber sy my => add_exact_aux2 sx sy mx my ex ey end end. Lemma add_exact_aux_correct : forall sx mx ex sy my ey, valid_mantissa mx -> valid_mantissa my -> FtoX (toF (add_exact_aux2 sx sy mx my ex ey)) = FtoX (Fround_none (Fadd_slow_aux2 radix sx sy (MtoP mx) (MtoP my) (EtoZ ex) (EtoZ ey) pos_Eq)). Proof. assert (Aux: forall sx mx sy my e, valid_mantissa mx -> valid_mantissa my -> FtoX (toF (add_exact_aux1 sx sy mx my e)) = FtoX (Fround_none (Fadd_slow_aux1 radix sx sy (MtoP mx) (MtoP my) (EtoZ e) pos_Eq))). intros sx mx sy my e Mx My. unfold add_exact_aux1, Fadd_slow_aux1. case eqb. destruct (mantissa_add_correct _ _ Mx My) as (Ep,Mp). rewrite toF_float with (1 := Mp). now rewrite Ep. rewrite (mantissa_cmp_correct _ _ Mx My). simpl. rewrite Z.pos_sub_spec. case Pos.compare_spec. intros _. apply zero_correct. intros H. destruct (mantissa_sub_correct _ _ My Mx H) as (Ep,Mp). rewrite toF_float with (1 := Mp). now rewrite Ep. intros H. destruct (mantissa_sub_correct _ _ Mx My H) as (Ep,Mp). rewrite toF_float with (1 := Mp). now rewrite Ep. intros sx mx ex sy my ey Mx My. unfold add_exact_aux2, Fadd_slow_aux2. rewrite exponent_cmp_correct. rewrite exponent_zero_correct. rewrite <- exponent_sub_correct. case_eq (EtoZ (exponent_sub ex ey)). simpl. intros H. now apply Aux. simpl. intros p Hp. destruct (mantissa_shl_correct _ _ _ Mx Hp) as (Ep,Mp). rewrite Aux ; try easy. now rewrite Ep. simpl. intros p Hp. assert (Hn: EtoZ (exponent_neg (exponent_sub ex ey)) = Zpos p). rewrite exponent_neg_correct. now rewrite Hp. destruct (mantissa_shl_correct _ _ _ My Hn) as (Ep,Mp). rewrite Aux ; try easy. now rewrite Ep. Qed. Lemma add_exact_correct : forall x y, toX (add_exact x y) = Xadd (toX x) (toX y). Proof. intros x y. unfold toX. rewrite <- Fadd_exact_correct. destruct x as [|mx ex]. apply refl_equal. destruct y as [|my ey]. simpl. now case (mantissa_sign mx). simpl. generalize (mantissa_sign_correct mx). case_eq (mantissa_sign mx). simpl. now case (mantissa_sign my). intros sx px Hx (Hx1, Hx2). generalize (mantissa_sign_correct my). case (mantissa_sign my). simpl. now rewrite Hx. intros sy py (Hy1, Hy2). unfold Fadd_exact, Fadd_slow_aux. now apply add_exact_aux_correct. Qed. (* * add *) Definition add_slow_aux1 mode prec sx sy mx my e := if eqb sx sy then round_aux mode prec sx (mantissa_add mx my) e pos_Eq else match mantissa_cmp mx my with | Eq => zero | Gt => round_aux mode prec sx (mantissa_sub mx my) e pos_Eq | Lt => round_aux mode prec sy (mantissa_sub my mx) e pos_Eq end. Lemma add_slow_aux1_correct : forall mode p sx sy mx my e, valid_mantissa mx -> valid_mantissa my -> FtoX (toF (add_slow_aux1 mode p sx sy mx my e)) = FtoX (Fround_at_prec mode (prec p) (Fadd_slow_aux1 radix sx sy (MtoP mx) (MtoP my) (EtoZ e) pos_Eq)). Proof. intros mode p sx sy mx my e Vx Vy. unfold add_slow_aux1, Fadd_slow_aux1. case eqb. - destruct (mantissa_add_correct mx my Vx Vy) as [H1 H2]. rewrite <- H1. now apply round_aux_correct. - change (Zpos (MtoP mx) + Zneg (MtoP my))%Z with (Zpos (MtoP mx) - Zpos (MtoP my))%Z. rewrite (mantissa_cmp_correct mx my Vx Vy). rewrite Z.compare_sub. case_eq (Zpos (MtoP mx) - Zpos (MtoP my))%Z ; unfold Z.compare. + intros H. simpl. generalize (mantissa_sign_correct mantissa_zero). case mantissa_sign. easy. rewrite mantissa_zero_correct. now intros [|]. + intros m H. assert (H': (Zpos (MtoP my) < Zpos (MtoP mx))%Z). clear -H ; lia. destruct (mantissa_sub_correct mx my Vx Vy H') as [H1 H2]. rewrite round_aux_correct by exact H2. rewrite H1. simpl in H. rewrite Z.pos_sub_gt in H by exact H'. injection H. now intros ->. + intros m H. assert (H': (Zpos (MtoP mx) < Zpos (MtoP my))%Z). clear -H ; lia. destruct (mantissa_sub_correct my mx Vy Vx H') as [H1 H2]. rewrite round_aux_correct by exact H2. rewrite H1. simpl in H. rewrite Z.pos_sub_lt in H by exact H'. injection H. now intros ->. Qed. Definition add_slow_aux2 mode prec sx sy mx my ex ey := let nb := exponent_sub ex ey in match exponent_cmp nb exponent_zero with | Gt => add_slow_aux1 mode prec sx sy (mantissa_shl mx nb) my ey | Lt => add_slow_aux1 mode prec sx sy mx (mantissa_shl my (exponent_neg nb)) ex | Eq => add_slow_aux1 mode prec sx sy mx my ex end. Lemma add_slow_aux2_correct : forall mode p sx sy mx my ex ey, valid_mantissa mx -> valid_mantissa my -> FtoX (toF (add_slow_aux2 mode p sx sy mx my ex ey)) = FtoX (Fround_at_prec mode (prec p) (Fadd_slow_aux2 radix sx sy (MtoP mx) (MtoP my) (EtoZ ex) (EtoZ ey) pos_Eq)). Proof. intros mode p sx sy mx my ex ey Vx Vy. unfold add_slow_aux2, Fadd_slow_aux2. rewrite exponent_cmp_correct, exponent_sub_correct, exponent_zero_correct. case_eq (EtoZ ex - EtoZ ey)%Z ; unfold Z.compare. - intros _. now apply add_slow_aux1_correct. - intros d Hd. generalize (mantissa_shl_correct d mx (exponent_sub ex ey) Vx). intros H'. destruct H' as [H1 H2]. rewrite <- Hd. apply exponent_sub_correct. rewrite add_slow_aux1_correct by assumption. now rewrite H1. - intros d Hd. generalize (mantissa_shl_correct d my (exponent_neg (exponent_sub ex ey)) Vy). intros H'. destruct H' as [H1 H2]. change (Zpos d) with (Z.opp (Zneg d)). rewrite <- Hd. rewrite exponent_neg_correct. apply f_equal, exponent_sub_correct. rewrite add_slow_aux1_correct by assumption. now rewrite H1. Qed. Definition add_slow mode prec (x y : type) := match x, y with | Fnan, _ => x | _, Fnan => y | Float mx ex, Float my ey => match mantissa_sign mx, mantissa_sign my with | Mzero, Mzero => x | Mzero, Mnumber sy py => round_aux mode prec sy py ey pos_Eq | Mnumber sx px, Mzero => round_aux mode prec sx px ex pos_Eq | Mnumber sx px, Mnumber sy py => add_slow_aux2 mode prec sx sy px py ex ey end end. Lemma add_slow_correct : forall mode p x y, toX (add_slow mode p x y) = Xround radix mode (prec p) (Xadd (toX x) (toX y)). Proof. intros mode p x y. unfold toX. rewrite <- Fadd_correct. unfold add_slow, Fadd_slow, Fadd_slow_aux. destruct x as [|mx ex] ; try easy. destruct y as [|my ey]. simpl. now destruct (mantissa_sign mx). unfold toF. generalize (mantissa_sign_correct mx). case_eq (mantissa_sign mx). - intros Hx _. generalize (mantissa_sign_correct my). destruct (mantissa_sign my) as [|sy ny]. now rewrite Hx. intros [My Vy]. rewrite <- round_aux_correct by exact Vy. case round_aux. reflexivity. intros m e. generalize (mantissa_sign_correct m). case_eq (mantissa_sign m). simpl. now intros ->. intros s n. simpl. now intros ->. - intros sx nx Hx [Hmx Vx]. generalize (mantissa_sign_correct my). destruct (mantissa_sign my) as [|sy ny]. + intros Hy. rewrite <- round_aux_correct by exact Vx. case round_aux. reflexivity. intros m e. generalize (mantissa_sign_correct m). case_eq (mantissa_sign m). simpl. now intros ->. intros s n. simpl. now intros ->. + intros [Hmy Vy]. rewrite <- (add_slow_aux2_correct mode p sx sy nx ny ex ey Vx Vy). case add_slow_aux2. reflexivity. intros m e. generalize (mantissa_sign_correct m). case_eq (mantissa_sign m). simpl. now intros ->. simpl. now intros s n ->. Qed. Definition add_UP := add_slow rnd_UP. Lemma add_UP_correct : forall p x y, valid_ub x = true -> valid_ub y = true -> (valid_ub (add_UP p x y) = true /\ le_upper (Xadd (toX x) (toX y)) (toX (add_UP p x y))). Proof. intros p x y _ _; split; [reflexivity|]. unfold add_UP. rewrite add_slow_correct. unfold Xround, Xlift. set (z := Xadd _ _); case z; [exact I|]; intro zr. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Definition add_DN := add_slow rnd_DN. Lemma add_DN_correct : forall p x y, valid_lb x = true -> valid_lb y = true -> (valid_lb (add_DN p x y) = true /\ le_lower (toX (add_DN p x y)) (Xadd (toX x) (toX y))). Proof. intros p x y _ _; split; [reflexivity|]. unfold add_DN. rewrite add_slow_correct. unfold Xround, Xlift. set (z := Xadd _ _); case z; [exact I|]; intro zr. now apply Ropp_le_contravar, Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. (* * sub *) Definition sub_UP prec (x y : type) := add_UP prec x (neg y). Lemma sub_UP_correct : forall p x y, valid_ub x = true -> valid_lb y = true -> (valid_ub (sub_UP p x y) = true /\ le_upper (Xsub (toX x) (toX y)) (toX (sub_UP p x y))). Proof. intros p x y _ _; split; [reflexivity|]. unfold sub_UP. rewrite Xsub_split. assert (H : toX (neg y) = Xneg (toX y)); [|rewrite <-H; clear H]. { now generalize (neg_correct y); case y. } now apply add_UP_correct. Qed. Definition sub_DN prec (x y : type) := add_DN prec x (neg y). Lemma sub_DN_correct : forall p x y, valid_lb x = true -> valid_ub y = true -> (valid_lb (sub_DN p x y) = true /\ le_lower (toX (sub_DN p x y)) (Xsub (toX x) (toX y))). Proof. intros p x y _ _; split; [reflexivity|]. unfold sub_DN. rewrite Xsub_split. assert (H : toX (neg y) = Xneg (toX y)); [|rewrite <-H; clear H]. { now generalize (neg_correct y); case y. } now apply add_DN_correct. Qed. (* * div *) Definition div_aux mode prec s mx my e := let (q, pos) := mantissa_div mx my in round_aux mode prec s q e pos. Definition div mode prec (x y : type) := match x, y with | Fnan, _ => x | _, Fnan => y | Float mx ex, Float my ey => let prec := match exponent_cmp prec exponent_zero with Gt => prec | _ => exponent_one end in match mantissa_sign mx, mantissa_sign my with | _, Mzero => Fnan | Mzero, _ => x | Mnumber sx px, Mnumber sy py => let dx := mantissa_digits px in let dy := mantissa_digits py in let e := exponent_sub ex ey in let nb := exponent_sub (exponent_add dy prec) dx in match exponent_cmp nb exponent_zero with | Gt => div_aux mode prec (xorb sx sy) (mantissa_shl px nb) py (exponent_sub e nb) | _ => div_aux mode prec (xorb sx sy) px py e end end end. Theorem div_correct : forall mode p x y, toX (div mode p x y) = Xround radix mode (prec p) (Xdiv (toX x) (toX y)). Proof. intros mode p x y. unfold toX. rewrite <- Fdiv_correct. destruct x as [|mx ex] ; destruct y as [|my ey] ; try easy. simpl. now case (mantissa_sign mx). simpl. generalize (mantissa_sign_correct mx). case_eq (mantissa_sign mx) ; [ intros Hx Mx | intros sx nx Hx (Mx, Vmx) ]. destruct (mantissa_sign my) as [|sy ny]. apply refl_equal. simpl. now rewrite Hx. generalize (mantissa_sign_correct my). case_eq (mantissa_sign my) ; [ intros Hy My | intros sy ny Hy (My, Vmy) ]. apply refl_equal. rewrite exponent_cmp_correct. rewrite exponent_sub_correct, exponent_add_correct, exponent_zero_correct. rewrite 2!mantissa_digits_correct ; try easy. rewrite <- 2!digits_conversion. unfold Fdiv, Fdiv_aux, Fdiv_aux2. set (p' := match exponent_cmp p exponent_zero with Gt => p | _ => exponent_one end). assert (Hp: EtoZ p' = Zpos (prec p)). unfold p', prec. rewrite exponent_cmp_correct, exponent_zero_correct. case_eq (EtoZ p) ; try (intros ; apply exponent_one_correct). easy. rewrite Hp. unfold radix. set (d := (Zdigits Carrier.radix (Zpos (MtoP ny)) + Zpos (prec p) - Zdigits Carrier.radix (Zpos (MtoP nx)))%Z). set (nd := exponent_sub (exponent_add (mantissa_digits ny) p') (mantissa_digits nx)). assert (Hs := fun d' (H : EtoZ nd = Zpos d') => mantissa_shl_correct d' nx nd Vmx H). assert (Hs': forall d', d = Zpos d' -> MtoP (mantissa_shl nx nd) = shift Carrier.radix (MtoP nx) d' /\ valid_mantissa (mantissa_shl nx nd)). intros d' H. apply Hs. unfold nd. rewrite exponent_sub_correct, exponent_add_correct, 2!mantissa_digits_correct, <- 2!digits_conversion ; trivial. now rewrite Hp. replace (match (d ?= 0)%Z with | Gt => div_aux mode p' (xorb sx sy) (mantissa_shl nx nd) ny (exponent_sub (exponent_sub ex ey) nd) | _ => div_aux mode p' (xorb sx sy) nx ny (exponent_sub ex ey) end) with (div_aux mode p' (xorb sx sy) (match d with Zpos _ => mantissa_shl nx nd | _ => nx end) ny (match d with Zpos _ => exponent_sub (exponent_sub ex ey) nd | _ => exponent_sub ex ey end)) by now case d. unfold div_aux. (* *) assert (Vmx': valid_mantissa (match d with Zpos _ => mantissa_shl nx nd | _ => nx end)). destruct d as [|pd|pd] ; trivial. now apply (Hs' pd). assert (Hxy: (Zpos (MtoP ny) <= Zpos (MtoP (match d with Zpos _ => mantissa_shl nx nd | _ => nx end)))%Z). apply Zlt_le_weak. apply (lt_Zdigits Carrier.radix). easy. case_eq d. unfold d. clear ; lia. intros p0 Hp0. specialize (Hs' p0 Hp0). rewrite (proj1 Hs'). rewrite shift_correct. fold (Zpower Carrier.radix (Zpos p0)). rewrite Zdigits_mult_Zpower ; try easy. rewrite <- Hp0. unfold d. clear ; lia. intros p0. unfold d. clear ; lia. (* *) clear Hs. generalize (mantissa_div_correct _ ny Vmx' Vmy Hxy). destruct (mantissa_div (match d with Zpos _ => mantissa_shl nx nd | _ => nx end) ny) as (nq, nl). assert (H: Zpos (MtoP (match d with Zpos _ => mantissa_shl nx nd | _ => nx end)) = match d with Zpos p0 => (Zpos (MtoP nx) * Zpower_pos Carrier.radix p0)%Z | _ => Zpos (MtoP nx) end). destruct d as [|pd|pd] ; trivial. rewrite <- shift_correct. apply f_equal. now apply Hs'. rewrite H. clear H. intros (H1, (H2, H3)). rewrite round_aux_correct with (1 := H3). apply (f_equal2 (fun v w => FtoX (Fround_at_prec mode v w))). unfold prec. now rewrite Hp. replace (match d with Zpos p0 => ((Zpos (MtoP nx) * Zpower_pos Carrier.radix p0), (EtoZ ex - EtoZ ey + Zneg p0))%Z | _ => (Zpos (MtoP nx), (EtoZ ex - EtoZ ey)%Z) end) with (match d with Zpos p0 => (Zpos (MtoP nx) * Zpower_pos Carrier.radix p0)%Z | _ => Zpos (MtoP nx) end, match d with Zpos p0 => (EtoZ ex - EtoZ ey + Zneg p0)%Z | _ => (EtoZ ex - EtoZ ey)%Z end) by now case d. revert H1. unfold Z.div. generalize (Z_div_mod (match d with Zpos p0 => (Zpos (MtoP nx) * Zpower_pos Carrier.radix p0)%Z | _ => Zpos (MtoP nx) end) (Zpos (MtoP ny)) (refl_equal _)). rewrite Zfast_div_eucl_correct. case Z.div_eucl. intros q r (Hq,Hr) H1. rewrite <- H1. apply f_equal2. case_eq d ; try (intros ; apply exponent_sub_correct). intros p0 Hp0. rewrite 2!exponent_sub_correct. unfold Zminus. apply f_equal. change (Zneg p0) with (-Zpos p0)%Z. rewrite <- Hp0. unfold nd. rewrite exponent_sub_correct, exponent_add_correct, 2!mantissa_digits_correct, <- 2!digits_conversion ; trivial. now rewrite Hp. replace nl with (convert_location (convert_location_inv nl)) by now case nl. apply f_equal. destruct (Zle_or_lt (Zpos (MtoP ny)) 1) as [Ky|Ky]. (* . *) assert (Zpos (MtoP ny) = 1%Z /\ r = Z0). clear -Hr Ky ; lia. rewrite (proj1 H), (proj2 H). inversion_clear H2. easy. apply False_ind. revert H0. rewrite (proj1 H). unfold Rdiv. rewrite Rinv_1, Rmult_1_r. intros (H0, H2). generalize (lt_IZR _ _ H0) (lt_IZR _ _ H2). clear ; lia. (* . *) apply Bracket.inbetween_unique with (1 := H2). rewrite plus_IZR. replace 1%R with (IZR (Zpos (MtoP ny)) * /IZR (Zpos (MtoP ny)))%R. apply Bracket.new_location_correct ; trivial. apply Rinv_0_lt_compat. now apply IZR_lt. constructor. rewrite Hq, H1. rewrite plus_IZR. unfold Rdiv. rewrite Rmult_plus_distr_r. rewrite mult_IZR, <- (Rmult_comm (IZR q)), Rmult_assoc. rewrite Rinv_r. now rewrite Rmult_1_r. now apply IZR_neq. apply Rinv_r. now apply IZR_neq. Qed. Definition div_UP := div rnd_UP. Definition is_real_ub x := match toX x with Xnan => valid_ub x = true | _ => True end. Definition is_real_lb x := match toX x with Xnan => valid_lb x = true | _ => True end. Lemma div_UP_correct : forall p x y, ((is_real_ub x /\ is_pos_real y) \/ (is_real_lb x /\ is_neg_real y)) -> valid_ub (div_UP p x y) = true /\ le_upper (Xdiv (toX x) (toX y)) (toX (div_UP p x y)). Proof. intros p x y _; split; [reflexivity|]. unfold div_UP. rewrite div_correct. unfold Xround, Xlift. set (z := Xdiv _ _); case z; [exact I|]; intro zr. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Definition div_DN := div rnd_DN. Lemma div_DN_correct : forall p x y, ((is_real_ub x /\ is_neg_real y) \/ (is_real_lb x /\ is_pos_real y)) -> valid_lb (div_DN p x y) = true /\ le_lower (toX (div_DN p x y)) (Xdiv (toX x) (toX y)). Proof. intros p x y _; split; [reflexivity|]. unfold div_DN. rewrite div_correct. unfold Xround, Xlift. set (z := Xdiv _ _); case z; [exact I|]; intro zr. now apply Ropp_le_contravar, Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. (* * sqrt *) Definition sqrt mode prec (f : type) := match f with | Fnan => f | Float m e => match mantissa_sign m with | Mzero => f | Mnumber true _ => Fnan | Mnumber false p => let d := mantissa_digits p in let prec := match exponent_cmp prec exponent_zero with Gt => prec | _ => exponent_one end in let s := exponent_sub (exponent_add prec prec) d in let s := match exponent_cmp s exponent_zero with Gt => s | _ => exponent_zero end in let (e', r) := exponent_div2_floor (exponent_sub e s) in let s := if r then exponent_add s exponent_one else s in let m := match exponent_cmp s exponent_zero with Gt => mantissa_shl p s | _ => p end in let (m', pos) := mantissa_sqrt m in round_aux mode prec false m' e' pos end end. Lemma sqrt_correct : forall mode p x, toX (sqrt mode p x) = Xround radix mode (prec p) (Xsqrt_nan (toX x)). Proof. intros mode p x. unfold toX. rewrite <- Fsqrt_correct. destruct x as [|mx ex] ; try easy. simpl. generalize (mantissa_sign_correct mx). case_eq (mantissa_sign mx) ; [ intros Hx Mx | intros sx nx Hx (Mx, Vx) ]. simpl. now rewrite Hx. destruct sx ; try easy. set (p' := match exponent_cmp p exponent_zero with Gt => p | _ => exponent_one end). assert (Hp: EtoZ p' = Zpos (prec p)). unfold p', prec. rewrite exponent_cmp_correct, exponent_zero_correct. case_eq (EtoZ p) ; try (intros ; apply exponent_one_correct). easy. clearbody p'. rewrite exponent_cmp_correct. rewrite exponent_sub_correct. rewrite exponent_add_correct. rewrite exponent_zero_correct. unfold Fsqrt, Fsqrt_aux, Fsqrt_aux2. set (s1 := match Z.compare (EtoZ p' + EtoZ p' - EtoZ (mantissa_digits nx)) 0 with Gt => exponent_sub (exponent_add p' p') (mantissa_digits nx) | _ => exponent_zero end). set (s2 := Z.max (2 * Zpos (prec p) - Zdigits radix (Zpos (MtoP nx))) 0). assert (Hs: EtoZ s1 = s2). revert s1 s2 ; cbv zeta. replace (2 * Zpos (prec p))%Z with (Zpos (prec p) + Zpos (prec p))%Z by ring. rewrite digits_conversion. change radix with Carrier.radix. rewrite <- mantissa_digits_correct with (1 := Vx). case Zcompare_spec ; rewrite Hp ; try rewrite exponent_zero_correct ; intros H ; apply eq_sym ; try apply Zmax_right. now apply Zlt_le_weak. now apply Zeq_le. rewrite exponent_sub_correct. rewrite exponent_add_correct. rewrite Hp. apply Zmax_left. now apply Z.le_ge, Zlt_le_weak. clearbody s1 s2. generalize (exponent_div2_floor_correct (exponent_sub ex s1)). case exponent_div2_floor ; intros e1 r He. rewrite exponent_cmp_correct. rewrite exponent_zero_correct. set (s3 := if r then exponent_add s1 exponent_one else s1). set (s4e2 := if Z.even (EtoZ ex - s2) then (s2, EtoZ ex - s2)%Z else (s2 + 1, EtoZ ex - s2 - 1)%Z). assert (Hes: EtoZ e1 = Z.div2 (snd s4e2) /\ EtoZ s3 = fst s4e2). clear -He Hs. generalize (Zdiv2_odd_eqn (EtoZ ex - s2)). rewrite Zodd_even_bool. rewrite exponent_sub_correct, Hs in He. assert (Z.even (EtoZ ex - s2) = negb r). rewrite He. rewrite (Zplus_comm (2 * EtoZ e1)). rewrite Z.even_add_mul_2. now case r. rewrite H. rewrite negb_involutive. change Zeven with Z.even in s4e2. intros H'. revert s4e2 s3 ; cbv zeta. rewrite H. destruct r ; simpl. split. rewrite H'. replace (2 * Z.div2 (EtoZ ex - s2) + 1 - 1)%Z with (2 * Z.div2 (EtoZ ex - s2))%Z by ring. rewrite Z.div2_div. rewrite Zmult_comm, Z_div_mult by easy. lia. rewrite exponent_add_correct. rewrite exponent_one_correct. now rewrite Hs. split. lia. exact Hs. clearbody s4e2 s3. destruct s4e2 as [s4 e2]. simpl in Hes. rewrite <- (proj2 Hes). rewrite <- (proj1 Hes). clear He Hes. set (m1 := match Z.compare (EtoZ s3) 0 with Gt => mantissa_shl nx s3 | _ => nx end). set (m2 := match EtoZ s3 with Zpos p => (Zpos (MtoP nx) * Z.pow_pos radix p)%Z | _ => Zpos (MtoP nx) end). assert (Hm: valid_mantissa m1 /\ Zpos (MtoP m1) = m2). revert m1 m2 ; cbv zeta. case_eq (EtoZ s3) ; simpl Z.compare ; cbv iota. intros _. now split. intros q Hq. generalize (mantissa_shl_correct q nx s3 Vx Hq). intros [-> H]. apply (conj H). apply shift_correct. intros q Hq. now split. generalize (mantissa_sqrt_correct m1 (proj1 Hm)). rewrite <- (proj2 Hm). clearbody m1 m2. clear Hm. destruct (mantissa_sqrt m1) as [q l]. destruct (Z.sqrtrem (Z.pos (MtoP m1))) as [s r']. intros [<- [H1 H2]]. rewrite round_aux_correct with (1 := H2). unfold prec at 1. rewrite Hp. clear -H1. apply (f_equal (fun l => FtoX (Fround_at_prec mode (prec p) (Ufloat _ _ _ l)))). destruct l. now rewrite Zeq_bool_true. rewrite Zeq_bool_false. now rewrite Zle_bool_true. now apply Zgt_not_eq. easy. rewrite Zeq_bool_false. now rewrite Zle_bool_false. apply Zgt_not_eq. now apply Z.lt_trans with (2 := H1). Qed. Definition sqrt_UP := sqrt rnd_UP. Lemma sqrt_UP_correct : forall p x, valid_ub (sqrt_UP p x) = true /\ le_upper (Xsqrt (toX x)) (toX (sqrt_UP p x)). Proof. intros p x; split; [reflexivity|]. unfold sqrt_UP. rewrite sqrt_correct. unfold Xround, Xlift. case toX; [easy|intro rx]. unfold Xsqrt', Xsqrt_nan'. case is_negative_spec; [easy|intros _]. now apply Generic_fmt.round_UP_pt, FLX.FLX_exp_valid. Qed. Definition sqrt_DN := sqrt rnd_DN. Lemma sqrt_DN_correct : forall p x, valid_lb x = true -> (valid_lb (sqrt_DN p x) = true /\ le_lower (toX (sqrt_DN p x)) (Xsqrt (toX x))). Proof. intros p x _; split; [reflexivity|]. unfold sqrt_DN. rewrite sqrt_correct. unfold Xround, Xlift. case toX; [easy|intro rx]. unfold Xsqrt', Xsqrt_nan'. case is_negative_spec; [easy|intros _]. now apply Ropp_le_contravar, Generic_fmt.round_DN_pt, FLX.FLX_exp_valid. Qed. (* * nearbyint *) Definition nearbyint mode (f : type) := match f with | Fnan => f | Float m e => match mantissa_sign m with | Mnumber s m => round_at_exp_aux mode exponent_zero s m e pos_Eq | Mzero => zero end end. Definition nearbyint_UP := nearbyint. Definition nearbyint_DN := nearbyint. Lemma nearbyint_correct : forall mode x, toX (nearbyint mode x) = Xnearbyint mode (toX x). Proof. intros mode x. unfold toX. destruct x as [|mx ex] ; try easy. simpl. generalize (mantissa_sign_correct mx). case (mantissa_sign mx). - rewrite toF_zero. simpl. now rewrite (Rnearbyint_IZR mode 0). intros s m [_ H]. rewrite <- Fnearbyint_exact_correct. rewrite round_at_exp_aux_correct; try easy. unfold Fnearbyint_exact. eapply f_equal. eapply f_equal2; try easy. now rewrite exponent_zero_correct. Qed. Lemma nearbyint_UP_correct : forall mode x, valid_ub (nearbyint_UP mode x) = true /\ le_upper (Xnearbyint mode (toX x)) (toX (nearbyint_UP mode x)). Proof. intros mode x. split; [easy|]. rewrite nearbyint_correct. unfold le_upper, toX. now case (Xlift _ _); [|intro r; right]. Qed. Lemma nearbyint_DN_correct : forall mode x, valid_lb (nearbyint_DN mode x) = true /\ le_lower (toX (nearbyint_DN mode x)) (Xnearbyint mode (toX x)). Proof. intros mode x. split; [easy|]. rewrite nearbyint_correct. unfold le_upper, toX. now case (Xlift _ _); [|intro r; right]. Qed. (* * midpoint *) Definition midpoint (x y : type) := scale2 (add_exact x y) sm1. Lemma midpoint_correct : forall x y, sensible_format = true -> real x = true -> real y = true -> (toR x <= toR y)%R -> real (midpoint x y) = true /\ (toR x <= toR (midpoint x y) <= toR y)%R. Proof. intros x y He. unfold toR, midpoint, sm1. rewrite !real_correct. rewrite (scale2_correct _ _ He). rewrite add_exact_correct. do 2 (case toX; [easy|]). unfold StoZ. rewrite ZtoE_correct. change (bpow radix2 (-1)) with (/2)%R. clear x y; simpl; intros x y _ _ Hxy. now split; [|lra]. Qed. End SpecificFloat. interval-4.11.1/src/Float/Specific_sig.v000066400000000000000000000157741470547631300200640ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals. From Flocq Require Import Zaux Raux. Require Import Basic. Require Import Generic. Require Import Generic_proof. Inductive signed_number (A : Type) := | Mzero : signed_number A | Mnumber (s : bool) (m : A) : signed_number A. Arguments Mzero {A}. Arguments Mnumber {A} s m. Module Type FloatCarrier. Parameter radix : radix. Parameter smantissa_type : Type. Parameter mantissa_type : Type. Parameter exponent_type : Type. Parameter MtoP : mantissa_type -> positive. Parameter PtoM : positive -> mantissa_type. Parameter MtoZ : smantissa_type -> Z. Parameter ZtoM : Z -> smantissa_type. Parameter EtoZ : exponent_type -> Z. Parameter ZtoE : Z -> exponent_type. Parameter valid_mantissa : mantissa_type -> Prop. Parameter exponent_zero : exponent_type. Parameter exponent_one : exponent_type. Parameter mantissa_zero : smantissa_type. Parameter mantissa_one : mantissa_type. Parameter mantissa_pos : mantissa_type -> smantissa_type. Parameter mantissa_neg : mantissa_type -> smantissa_type. Parameter exponent_neg : exponent_type -> exponent_type. Parameter exponent_add : exponent_type -> exponent_type -> exponent_type. Parameter exponent_sub : exponent_type -> exponent_type -> exponent_type. Parameter exponent_cmp : exponent_type -> exponent_type -> comparison. Parameter exponent_div2_floor : exponent_type -> exponent_type * bool. Parameter mantissa_sign : smantissa_type -> signed_number mantissa_type. Parameter mantissa_add : mantissa_type -> mantissa_type -> mantissa_type. Parameter mantissa_sub : mantissa_type -> mantissa_type -> mantissa_type. Parameter mantissa_mul : mantissa_type -> mantissa_type -> mantissa_type. Parameter mantissa_cmp : mantissa_type -> mantissa_type -> comparison. Parameter mantissa_digits : mantissa_type -> exponent_type. Parameter mantissa_even : mantissa_type -> bool. Parameter mantissa_scale2 : mantissa_type -> exponent_type -> mantissa_type * exponent_type. Parameter mantissa_shl : mantissa_type -> exponent_type -> mantissa_type. Parameter mantissa_shr : mantissa_type -> exponent_type -> position -> mantissa_type * position. Parameter mantissa_shrp : mantissa_type -> exponent_type -> position -> position. Parameter mantissa_div : mantissa_type -> mantissa_type -> mantissa_type * position. Parameter mantissa_sqrt : mantissa_type -> mantissa_type * position. Parameter PtoM_correct : forall n, MtoP (PtoM n) = n. Parameter ZtoM_correct : forall n, MtoZ (ZtoM n) = n. Parameter ZtoE_correct : forall n, EtoZ (ZtoE n) = n. Parameter exponent_zero_correct : EtoZ exponent_zero = Z0. Parameter exponent_one_correct : EtoZ exponent_one = 1%Z. Parameter exponent_neg_correct : forall x, EtoZ (exponent_neg x) = (- EtoZ x)%Z. Parameter exponent_add_correct : forall x y, EtoZ (exponent_add x y) = (EtoZ x + EtoZ y)%Z. Parameter exponent_sub_correct : forall x y, EtoZ (exponent_sub x y) = (EtoZ x - EtoZ y)%Z. Parameter exponent_cmp_correct : forall x y, exponent_cmp x y = Z.compare (EtoZ x) (EtoZ y). Parameter exponent_div2_floor_correct : forall e, let (e',b) := exponent_div2_floor e in EtoZ e = (2 * EtoZ e' + if b then 1 else 0)%Z. Parameter mantissa_zero_correct : MtoZ mantissa_zero = Z0. Parameter mantissa_pos_correct : forall x, valid_mantissa x -> MtoZ (mantissa_pos x) = Zpos (MtoP x). Parameter mantissa_neg_correct : forall x, valid_mantissa x -> MtoZ (mantissa_neg x) = Zneg (MtoP x). Parameter mantissa_sign_correct : forall x, match mantissa_sign x with | Mzero => MtoZ x = Z0 | Mnumber s p => MtoZ x = (if s then Zneg else Zpos) (MtoP p) /\ valid_mantissa p end. Parameter mantissa_even_correct : forall x, valid_mantissa x -> mantissa_even x = Z.even (Zpos (MtoP x)). Parameter mantissa_one_correct : MtoP mantissa_one = xH /\ valid_mantissa mantissa_one. Parameter mantissa_add_correct : forall x y, valid_mantissa x -> valid_mantissa y -> MtoP (mantissa_add x y) = (MtoP x + MtoP y)%positive /\ valid_mantissa (mantissa_add x y). Parameter mantissa_sub_correct : forall x y, valid_mantissa x -> valid_mantissa y -> (MtoP y < MtoP x)%positive -> MtoP (mantissa_sub x y) = (MtoP x - MtoP y)%positive /\ valid_mantissa (mantissa_sub x y). Parameter mantissa_mul_correct : forall x y, valid_mantissa x -> valid_mantissa y -> MtoP (mantissa_mul x y) = (MtoP x * MtoP y)%positive /\ valid_mantissa (mantissa_mul x y). Parameter mantissa_cmp_correct : forall x y, valid_mantissa x -> valid_mantissa y -> mantissa_cmp x y = Z.compare (Zpos (MtoP x)) (Zpos (MtoP y)). Parameter mantissa_digits_correct : forall x, valid_mantissa x -> EtoZ (mantissa_digits x) = Zpos (count_digits radix (MtoP x)). Parameter mantissa_scale2_correct : forall x d, valid_mantissa x -> let (x',d') := mantissa_scale2 x d in (IZR (Zpos (MtoP x')) * bpow radix (EtoZ d') = IZR (Zpos (MtoP x)) * bpow radix2 (EtoZ d))%R /\ valid_mantissa x'. Parameter mantissa_shl_correct : forall x y z, valid_mantissa y -> EtoZ z = Zpos x -> MtoP (mantissa_shl y z) = shift radix (MtoP y) x /\ valid_mantissa (mantissa_shl y z). Parameter mantissa_shr_correct : forall x y z k, valid_mantissa y -> EtoZ z = Zpos x -> (Zpos (shift radix 1 x) <= Zpos (MtoP y))%Z -> let (sq,l) := mantissa_shr y z k in let (q,r) := Z.div_eucl (Zpos (MtoP y)) (Zpos (shift radix 1 x)) in Zpos (MtoP sq) = q /\ l = adjust_pos r (shift radix 1 x) k /\ valid_mantissa sq. Parameter mantissa_shrp_correct : forall x y z k, valid_mantissa y -> EtoZ z = Zpos x -> (Zpower radix (Zpos x - 1) <= Zpos (MtoP y) < Zpos (shift radix 1 x))%Z -> let l := mantissa_shrp y z k in l = adjust_pos (Zpos (MtoP y)) (shift radix 1 x) k. Parameter mantissa_div_correct : forall x y, valid_mantissa x -> valid_mantissa y -> (Zpos (MtoP y) <= Zpos (MtoP x))%Z -> let (q,l) := mantissa_div x y in Zpos (MtoP q) = (Zpos (MtoP x) / Zpos (MtoP y))%Z /\ Bracket.inbetween_int (Zpos (MtoP q)) (IZR (Zpos (MtoP x)) / IZR (Zpos (MtoP y)))%R (convert_location_inv l) /\ valid_mantissa q. Parameter mantissa_sqrt_correct : forall x, valid_mantissa x -> let (q,l) := mantissa_sqrt x in let (s,r) := Z.sqrtrem (Zpos (MtoP x)) in Zpos (MtoP q) = s /\ match l with pos_Eq => r = Z0 | pos_Lo => (0 < r <= s)%Z | pos_Mi => False | pos_Up => (s < r)%Z end /\ valid_mantissa q. End FloatCarrier. interval-4.11.1/src/Float/Specific_stdz.v000066400000000000000000000376521470547631300202650ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals Psatz Bool. From Flocq Require Import Zaux Raux. Require Import Basic. Require Import Generic. Require Import Generic_proof. Require Import Specific_sig. Module StdZRadix2 <: FloatCarrier. Definition radix := radix2. Definition radix_correct := refl_equal Lt. Definition smantissa_type := Z. Definition mantissa_type := positive. Definition exponent_type := Z. Definition MtoP := fun (m : positive) => m. Definition PtoM := fun (m : positive) => m. Definition MtoZ := fun (m : Z) => m. Definition ZtoM := fun (m : Z) => m. Definition EtoZ := fun (e : Z) => e. Definition ZtoE := fun (e : Z) => e. Definition exponent_zero := Z0. Definition exponent_one := Zpos xH. Definition exponent_neg := Z.opp. Definition exponent_add := Zplus. Definition exponent_sub := Zminus. Definition exponent_cmp := Z.compare. Definition mantissa_zero := Z0. Definition mantissa_one := xH. Definition mantissa_add := Pplus. Definition mantissa_sub := Pminus. Definition mantissa_mul := Pmult. Definition mantissa_cmp x y := Pcompare x y Eq. Definition mantissa_pos := Zpos. Definition mantissa_neg := Zneg. Definition valid_mantissa := fun (m : positive) => True. Definition mantissa_sign m := match m with | Zneg p => Mnumber true p | Z0 => Mzero | Zpos p => Mnumber false p end. Definition mantissa_even m := match m with | xO _ => true | _ => false end. Definition mantissa_shl m d := match d with Zpos nb => iter_pos (fun x => xO x) nb m | _ => xH end. Definition mantissa_scale2 (m : mantissa_type) (d : exponent_type) := (m, d). Fixpoint digits_aux m nb { struct m } := match m with | xH => nb | xO p => digits_aux p (Pos.succ nb) | xI p => digits_aux p (Pos.succ nb) end. Definition mantissa_digits m := Zpos (digits_aux m xH). Definition mantissa_split_div m d pos := match Zfast_div_eucl (Zpos m) (Zpos d) with | (Zpos q, r) => (q, adjust_pos r d pos) | _ => (xH, pos_Eq) (* dummy *) end. Definition mantissa_shr_aux v := match v with | (xO p, pos_Eq) => (p, pos_Eq) | (xO p, _) => (p, pos_Lo) | (xI p, pos_Eq) => (p, pos_Mi) | (xI p, _) => (p, pos_Up) | _ => (xH, pos_Eq) (* dummy *) end. Definition mantissa_shr m d pos := match d with | Zpos nb => iter_pos mantissa_shr_aux nb (m, pos) | _ => (xH, pos_Eq) (* dummy *) end. Fixpoint mantissa_shrp_aux m d := match m with | xO m1 => if (d =? 1)%positive then pos_Up else mantissa_shrp_aux m1 (Pos.pred d) | xI m1 => pos_Up | xH => if (d =? 1)%positive then pos_Mi else pos_Up end. Lemma mantissa_shrp_aux_correct m d : mantissa_shrp_aux m (Pos.succ d) = match (m ?= shift radix 1 d)%positive with | Eq => pos_Mi | _ => pos_Up end. Proof. apply eq_trans with (if (m =? shift radix 1 d)%positive then pos_Mi else pos_Up); last first. now rewrite Pos.eqb_compare; destruct Pos.compare. rewrite Pos2Z.inj_eqb, shift_correct, Z.pow_pos_fold, Zmult_1_l. rewrite <- radix_to_pos, <- Pos2Z.inj_pow. revert d; induction m as [m|m|]; intros d. - case (Pos.succ_pred_or d); intro Hd. now rewrite Hd; simpl; destruct m. rewrite <- Hd, Pos.pow_succ_r. now unfold mantissa_shrp_aux; case Pos.eqb. - case (Pos.succ_pred_or d); intro Hd. now rewrite Hd; destruct m. rewrite <- Hd at 2. rewrite Pos.pow_succ_r. rewrite <- Pos2Z.inj_eqb, Pos.eqb_compare, Pos.compare_xO_xO. rewrite <- Pos.eqb_compare, Pos2Z.inj_eqb, <- IHm; simpl. now rewrite Hd, Pos.pred_succ; destruct d. case (Pos.succ_pred_or d); intro Hd. now rewrite Hd. rewrite <- Hd at 2. rewrite Pos.pow_succ_r. now destruct d. Qed. Definition mantissa_shrp m d pos := match pos with | pos_Eq => mantissa_shrp_aux m (Z.to_pos d) | _ => pos_Up end. Definition mantissa_div := fun m d => mantissa_split_div m d pos_Eq. Definition exponent_div2_floor n := match n with | Z0 => (Z0, false) | Zpos xH => (Z0, true) | Zneg xH => (Zneg xH, true) | Zpos (xO p) => (Zpos p, false) | Zneg (xO p) => (Zneg p, false) | Zpos (xI p) => (Zpos p, true) | Zneg (xI p) => (Zneg (Pos.succ p), true) end. Definition mantissa_sqrt m := match Z.sqrtrem (Zpos m) with | (Zpos s, r) => let pos := match r with | Z0 => pos_Eq | Zpos r => match Pos.compare r s with | Gt => pos_Up | _ => pos_Lo end | Zneg _ => pos_Eq (* dummy *) end in (s, pos) | _ => (xH, pos_Eq) (* dummy *) end. Definition PtoM_correct := fun x : positive => refl_equal x. Definition ZtoM_correct := fun x : Z => refl_equal x. Definition ZtoE_correct := fun x : Z => refl_equal x. Definition exponent_zero_correct := refl_equal Z0. Definition exponent_one_correct := refl_equal 1%Z. Definition exponent_neg_correct := fun x => refl_equal (- EtoZ x)%Z. Definition exponent_add_correct := fun x y => refl_equal (EtoZ x + EtoZ y)%Z. Definition exponent_sub_correct := fun x y => refl_equal (EtoZ x - EtoZ y)%Z. Definition exponent_cmp_correct := fun x y => refl_equal (EtoZ x ?= EtoZ y)%Z. Lemma exponent_div2_floor_correct : forall e, let (e',b) := exponent_div2_floor e in EtoZ e = (2 * EtoZ e' + if b then 1 else 0)%Z. Proof. unfold EtoZ, exponent_div2_floor. intros [|[e|e|]|[e|e|]] ; try easy. rewrite <- Pos.add_1_r. change (- (2 * Zpos e + 1) = 2 * - (Zpos e + 1) + 1)%Z. ring. Qed. Definition mantissa_zero_correct := refl_equal Z0. Definition mantissa_pos_correct := fun (x : positive) (_ : True) => refl_equal (Zpos x). Definition mantissa_neg_correct := fun (x : positive) (_ : True) => refl_equal (Zneg x). Definition mantissa_one_correct := conj (refl_equal xH) I. Definition mantissa_add_correct := fun x y (_ _ : True) => conj (refl_equal (MtoP x + MtoP y)%positive) I. Definition mantissa_sub_correct := fun x y (_ _ : True) (_ : (MtoP y < MtoP x)%positive) => conj (refl_equal (MtoP x - MtoP y)%positive) I. Definition mantissa_mul_correct := fun x y (Hx Hy : True) => conj (refl_equal (MtoP x * MtoP y)%positive) I. Definition mantissa_cmp_correct := fun x y (Hx Hy : True) => refl_equal (Zpos (MtoP x) ?= Zpos (MtoP y))%Z. Definition mantissa_even_correct := fun x (_ : True) => refl_equal (Z.even (Zpos x)). Lemma mantissa_sign_correct : forall x, match mantissa_sign x with | Mzero => MtoZ x = Z0 | Mnumber s p => MtoZ x = (if s then Zneg else Zpos) (MtoP p) /\ valid_mantissa p end. intros. case x ; repeat split. Qed. Lemma mantissa_digits_correct : forall x, valid_mantissa x -> EtoZ (mantissa_digits x) = Zpos (count_digits radix (MtoP x)). Proof. intros x _. rewrite <- digits_conversion. rewrite <- Digits.Zdigits2_Zdigits. unfold EtoZ, mantissa_digits, MtoP, Digits.Zdigits2. replace (Zpos (Digits.digits2_pos x)) with (Zpos (Digits.digits2_pos x) + 1 - 1)%Z by ring. generalize xH at 1 2. induction x ; intros p ; simpl digits_aux ; simpl Digits.digits2_pos. rewrite IHx, 2!Pos2Z.inj_succ. ring. rewrite IHx, 2!Pos2Z.inj_succ. ring. ring. Qed. Lemma mantissa_scale2_correct : forall x d, valid_mantissa x -> let (x',d') := mantissa_scale2 x d in (IZR (Zpos (MtoP x')) * bpow radix (EtoZ d') = IZR (Zpos (MtoP x)) * bpow radix2 (EtoZ d))%R /\ valid_mantissa x'. Proof. now intros x d Vx. Qed. Lemma mantissa_shl_correct : forall x y z, valid_mantissa y -> z = Zpos x -> MtoP (mantissa_shl y z) = shift radix (MtoP y) x /\ valid_mantissa (mantissa_shl y z). Proof. repeat split. unfold EtoZ in H0. rewrite H0. apply refl_equal. Qed. Lemma mantissa_shr_correct : forall x y z k, valid_mantissa y -> EtoZ z = Zpos x -> (Zpos (shift radix 1 x) <= Zpos (MtoP y))%Z -> let (sq,l) := mantissa_shr y z k in let (q,r) := Z.div_eucl (Zpos (MtoP y)) (Zpos (shift radix 1 x)) in Zpos (MtoP sq) = q /\ l = adjust_pos r (shift radix 1 x) k /\ valid_mantissa sq. Proof. intros x y z k _ Ezx. destruct z as [|z|z] ; try easy. injection Ezx. clear Ezx. unfold MtoP. intros -> Hy. unfold mantissa_shr. rewrite iter_pos_nat. case_eq (iter_nat mantissa_shr_aux (Pos.to_nat x) (y, k)). intros sq l H1. generalize (Z.div_str_pos _ _ (conj (refl_equal Lt : (0 < Zpos _)%Z) Hy)). generalize (Z_div_mod (Z.pos y) (Z.pos (shift radix 1 x)) (eq_refl Gt)). unfold Z.div. case Z.div_eucl. intros q r [H2 H3] H4. refine ((fun H => conj (proj1 H) (conj (proj2 H) I)) _). revert H2 H3 Hy. change (adjust_pos r (shift radix 1 x) k) with (match Z.pos (shift radix 1 x) with Zpos v => adjust_pos r v k | _ => l end). rewrite shift_correct. rewrite Zpower_pos_nat. rewrite Zmult_1_l. revert sq l q r H1 H4. induction (Pos.to_nat x) as [|p IHp]. - change (Zpower_nat radix 0) with 1%Z. intros sq l q r. rewrite Zmult_1_l. simpl. intros H1. injection H1. intros <- <-. clear H1. intros _ H1 H2. revert H1. assert (H: r = 0%Z) by lia. rewrite H, Zplus_0_r. split. exact H1. now destruct k. - intros sq' l' q' r'. rewrite iter_nat_S. destruct (iter_nat mantissa_shr_aux p (y, k)) as [sq l]. specialize (IHp sq l). intros H1 H0 H2 H3 Hy. revert H2. generalize (Z.le_lt_trans _ _ _ (proj1 H3) (proj2 H3)). case_eq (Zpower_nat radix (S p)) ; try easy. intros m'. revert H3. rewrite Zpower_nat_S. revert IHp. destruct (Zpower_nat radix p) as [|m|m] ; try easy. intros IHp H3 H4 _ H2. injection H4. intros <-. clear H4. change (radix_val radix) with 2%Z in H3. change (Zpos (xO m)) with (2 * Zpos m)%Z in H2. destruct (Zle_or_lt (Zpos m) r') as [Hr|Hr]. + destruct (IHp (2 * q' + 1)%Z (r' - Zpos m)%Z) as [H4 H5]. reflexivity. clear -H0 ; lia. rewrite H2. ring. clear -Hr H3 ; lia. rewrite H2. rewrite <- (Zplus_0_l (Zpos m)) at 1. apply Zplus_le_compat with (2 := Hr). apply Zmult_le_0_compat. clear -H3 ; lia. now apply Zlt_le_weak. clear IHp. destruct q' as [|q'|q'] ; try easy. clear H0. destruct sq as [sq|sq|] ; try easy. simpl in H1. simpl in H4. split. injection H4. intros <-. apply f_equal, sym_eq. now destruct l ; injection H1. clear H4. unfold adjust_pos. destruct r' as [|r'|r'] ; try now elim Hr. apply sym_eq. replace l' with (match l with pos_Eq => pos_Mi | _ => pos_Up end). 2: clear -H1 ; destruct l ; injection H1 ; easy. rewrite H5. clear H1 H5. destruct (Zcompare_spec (Zpos r') (Zpos m)) as [H|H|H]. * elim Hr. now apply Zcompare_Gt. * rewrite (Zeq_minus _ _ H). simpl. case k ; try easy ; case m ; easy. * assert (H': (Zpos r' - Zpos m)%Z = Zpos (r' - m)) by now apply Z.pos_sub_gt. rewrite H'. unfold adjust_pos. clear -H H3. destruct m as [m|m|] ; case Z.compare ; try easy ; try (case k ; easy). clear -H3 H ; lia. + destruct (IHp (2 * q')%Z r') as [H4 H5]. reflexivity. clear -H0 ; lia. rewrite H2. ring. clear -Hr H3 ; lia. rewrite H2. rewrite <- (Zplus_0_r (Zpos m)) at 1. apply Zplus_le_compat with (2 := proj1 H3). apply Zle_0_minus_le. replace (2 * Zpos m * q' - Zpos m)%Z with (Zpos m * (2 * q' - 1))%Z by ring. apply Zmult_le_0_compat. easy. clear -H0 ; lia. clear IHp. destruct q' as [|q'|q'] ; try easy. clear H0. destruct sq as [sq|sq|] ; try easy. simpl in H1. simpl in H4. split. injection H4. intros <-. apply f_equal, sym_eq. now destruct l ; injection H1. clear H4. unfold adjust_pos. apply sym_eq. replace l' with (match l with pos_Eq => pos_Eq | _ => pos_Lo end). 2: clear -H1 ; destruct l ; injection H1 ; easy. rewrite H5. clear H1 H5. destruct r' as [|r'|r'] ; try now elim (proj1 H3). case k ; try easy ; case m ; easy. rewrite Zcompare_Lt with (1 := Hr). unfold adjust_pos. destruct m. case Z.compare ; try easy ; case k ; easy. case Z.compare ; try easy ; case k ; easy. now rewrite Hr. Qed. Lemma mantissa_shrp_correct : forall x y z k, valid_mantissa y -> EtoZ z = Zpos x -> (Zpower radix (Zpos x - 1) <= Zpos (MtoP y) < Zpos (shift radix 1 x))%Z -> let l := mantissa_shrp y z k in l = adjust_pos (Zpos (MtoP y)) (shift radix 1 x) k. Proof. intros x y [|z|z] k _ Ezx; try discriminate. unfold MtoP. unfold EtoZ in Ezx; rewrite Ezx; simpl Z.to_pos; clear z Ezx. case (Pos.succ_pred_or x); intro Hx. rewrite Hx. now destruct y; destruct k. rewrite <- Hx at 1. rewrite Pos2Z.inj_succ. replace (Z.succ (Z.pos (Pos.pred x)) - 1)%Z with (Z.pos (Pos.pred x)) by lia. intros [Hl _]. unfold mantissa_shrp; simpl Z.to_pos. replace (mantissa_shrp_aux y x) with (mantissa_shrp_aux (xO y) (Pos.succ x)); last first. simpl. now rewrite Pos.pred_succ; destruct x. rewrite mantissa_shrp_aux_correct. replace (shift radix 1 x) with (xO ((Z.to_pos radix) ^ (Pos.pred x))); last first. apply Pos2Z.inj. rewrite <- (Pos.mul_1_r (_ ^ _)), <- (Pos.mul_xO_r _ xH). rewrite Pos.mul_comm, <- Pos.pow_succ_r, Hx, shift_correct. rewrite !Z.pow_pos_fold, Pos2Z.inj_pow, radix_to_pos; lia. simpl. rewrite Pos.compare_xO_xO; try easy. revert Hl. rewrite <-Z.pow_pos_fold, <- radix_to_pos, <- Pos2Z.inj_pow_pos. simpl. case Pos.compare_spec; try easy. intro H; lia. now destruct k. Qed. Lemma mantissa_div_correct : forall x y, valid_mantissa x -> valid_mantissa y -> (Zpos (MtoP y) <= Zpos (MtoP x))%Z -> let (q,l) := mantissa_div x y in Zpos (MtoP q) = (Zpos (MtoP x) / Zpos (MtoP y))%Z /\ Bracket.inbetween_int (Zpos (MtoP q)) (IZR (Zpos (MtoP x)) / IZR (Zpos (MtoP y)))%R (convert_location_inv l) /\ valid_mantissa q. Proof. intros x y _ _. unfold MtoP. intros Hxy. unfold mantissa_div, mantissa_split_div. generalize (Z_div_mod (Z.pos x) (Z.pos y) (eq_refl Gt)). rewrite Zfast_div_eucl_correct. destruct Z.div_eucl as [q r]. intros [H1 H2]. assert (H: (0 < q)%Z). apply Zmult_lt_reg_r with (Zpos y). easy. rewrite Zmult_0_l, Zmult_comm. apply Zplus_lt_reg_r with r. rewrite Zplus_0_l. rewrite <- H1. now apply Z.lt_le_trans with (2 := Hxy). destruct q as [|q|q] ; try easy. clear H Hxy. assert (Hq := Zdiv_unique _ _ _ _ H2 H1). refine (conj Hq (conj _ I)). unfold Bracket.inbetween_int. destruct (Zle_or_lt 2 (Zpos y)) as [Hy|Hy]. - assert (H: (1 < Zpos y)%Z) by now apply Z.gt_lt, Zle_succ_gt. rewrite adjust_pos_correct by assumption. rewrite plus_IZR. rewrite <- (Rinv_r (IZR (Zpos y))) by now apply IZR_neq. apply Bracket.new_location_correct ; try assumption. now apply Rinv_0_lt_compat, IZR_lt. apply Bracket.inbetween_Exact. rewrite H1, plus_IZR, mult_IZR. field. now apply IZR_neq. - rewrite Hq, H1. clear H1 Hq. cut (Zpos y = 1 /\ r = 0)%Z. 2: lia. clear. intros [-> ->]. simpl. apply Bracket.inbetween_Exact. unfold Rdiv. now rewrite Zdiv_1_r, Rinv_1, Rmult_1_r. Qed. Lemma mantissa_sqrt_correct : forall x, valid_mantissa x -> let (q,l) := mantissa_sqrt x in let (s,r) := Z.sqrtrem (Zpos (MtoP x)) in Zpos (MtoP q) = s /\ match l with pos_Eq => r = Z0 | pos_Lo => (0 < r <= s)%Z | pos_Mi => False | pos_Up => (s < r)%Z end /\ valid_mantissa q. Proof. intros x _. unfold mantissa_sqrt, MtoP. refine (_ (Z.sqrtrem_spec (Zpos x) _)). 2: easy. case Z.sqrtrem. intros s r [H1 H2]. destruct s as [|s|s]. simpl in H1. rewrite <- H1 in H2. now elim (proj2 H2). repeat split. destruct r as [|r|r]. apply eq_refl. case Pos.compare_spec. intros ->. split. easy. apply Z.le_refl. intros H. split. easy. now apply Zlt_le_weak. easy. now elim (proj1 H2). now elim (Z.le_trans _ _ _ (proj1 H2) (proj2 H2)). Qed. End StdZRadix2. interval-4.11.1/src/Integral/000077500000000000000000000000001470547631300157705ustar00rootroot00000000000000interval-4.11.1/src/Integral/Bertrand.v000066400000000000000000001157371470547631300177360ustar00rootroot00000000000000From Coq Require Import Reals ZArith Psatz Fourier_util. From Flocq Require Import Raux. From Coquelicot Require Import Coquelicot AutoDerive. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool ssrnat bigop. Require Import Stdlib. Require Import Coquelicot. Require Import Xreal. Require Import Interval. Section powerRZMissing. Lemma powerRZ_ind (P : Z -> (R -> R) -> Prop) : P 0%Z (fun x => 1) -> (forall n, P (Z.of_nat n) (fun x => x ^ n)) -> (forall n, P ((-(Z.of_nat n))%Z) (fun x => / x ^ n)) -> (forall f g, f =1 g -> forall n, P n f -> P n g) -> forall (m : Z), P m (fun x => powerRZ x m). Proof. move => H0 Hpos Hneg Hext m. case: m => [|p|p]. - by rewrite /=. - rewrite -positive_nat_Z. apply: Hext. move => x. by rewrite -pow_powerRZ. exact: Hpos. - rewrite /powerRZ. apply: Hext. move => x. by []. rewrite -Pos2Z.opp_pos. rewrite -positive_nat_Z. exact: Hneg. Qed. Lemma is_derive_powerRZ (n : Z) (x : R): ((0 <= n)%Z \/ x <> 0) -> is_derive (fun x : R => powerRZ x n) x (IZR n * (powerRZ x (n - 1))). Proof. move => Hnx. move: (is_derive_n_powerRZ n 1 x Hnx). case Hn : n => [|p|p] /= . - by rewrite !Rmult_0_l; move => _; apply: is_derive_const. - rewrite big_ord_recl /= big_ord0 /= subn0 Rmult_1_r. rewrite INR_IZR_INZ positive_nat_Z. rewrite pow_powerRZ. congr (is_derive _ _ (_ * powerRZ _ _)). rewrite -> Nat2Z.inj_sub by now rewrite Nat.le_succ_l; apply Pos2Nat.is_pos. now rewrite positive_nat_Z. - rewrite big_ord_recl /= big_ord0 /= addn0 Rmult_1_r. rewrite INR_IZR_INZ positive_nat_Z. by rewrite Pos2Nat.inj_add. Qed. Lemma is_derive_powerRZS (n : Z) (x : R): ((1 <= n)%Z \/ x <> 0) -> is_derive (fun x : R => powerRZ x (n+1)) x (IZR (n+1) * (powerRZ x n)). Proof. move => Hnx. move: (is_derive_powerRZ (n+1) x). rewrite Z.add_simpl_r // ; apply. case: Hnx => [Hn | Hx]. left; lia. by right. Qed. Lemma ex_derive_powerRZ (n : Z) (x : R): ((0 <= n)%Z \/ x <> 0) -> ex_derive (fun x : R => powerRZ x n) x. Proof. move => H. apply: (ex_derive_is_derive ((fun x : R => powerRZ x (n)))). exact: is_derive_powerRZ. Qed. Lemma ex_derive_powerRZS (n : Z) (x : R): ((1 <= n)%Z \/ x <> 0) -> ex_derive (fun x : R => powerRZ x (n+1)) x. Proof. move => H. apply: ex_derive_powerRZ. case: H => [Hn | Hx]. left; lia. by right. Qed. Lemma is_RInt_powerRZ (alpha : Z) (a b : R) (HneqN1 : alpha <> (-1)%Z) (H : 0 < a <= b) : is_RInt (powerRZ^~ alpha) a b ((powerRZ b (alpha + 1) - powerRZ a (alpha + 1)) / IZR (alpha + 1)). Proof. have neq0 : IZR (alpha + 1) <> 0. apply: not_0_IZR. by rewrite Z.add_move_0_r; exact: HneqN1. pose F := fun x => powerRZ x (alpha+1) / IZR (alpha + 1). have -> : ((powerRZ b (alpha + 1) - powerRZ a (alpha + 1)) / IZR (alpha + 1)) = F b - F a. rewrite /F. field => // . have xneq0 : forall x, Rmin a b <= x <= Rmax a b -> x <> 0. move => x [Hax Hxb]. apply: Rgt_not_eq. apply: (Rlt_le_trans 0 (Rmin a b) x) => // . by case: H => [H0a Hab]; rewrite Rmin_left. apply: is_RInt_derive => x Hx. rewrite /F. have -> : (powerRZ x alpha) = ((IZR (alpha+1)) * ((powerRZ x alpha)) / (IZR (alpha+1))). by field. rewrite !/Rdiv. apply: is_derive_scal_l. apply: is_derive_powerRZS. by right; apply xneq0. apply: ex_derive_continuous. apply: (ex_derive_n_powerRZ alpha 1). by right; apply xneq0. Qed. Lemma int_x_alpha alpha A B (H : 0 < A <= B) (Halpha: alpha <> (-1)%Z) : is_RInt (powerRZ^~ alpha) A B ((powerRZ B (alpha + 1) - powerRZ A (alpha + 1)) / IZR (alpha + 1)). Proof. apply: is_RInt_powerRZ => // . Qed. End powerRZMissing. Section CoquelicotMissing. (* this one should be in Coquelicot to relieve users *) Lemma continuous_Rdiv_1_x x (H : x <> 0) : continuous (Rdiv 1) x. Proof. apply: (continuous_ext (fun (x : R) => (/ x))). by move => x0; rewrite /Rdiv Rmult_1_l. exact: continuous_Rinv. Qed. End CoquelicotMissing. (* Bertrand Integral: *) (* RInt (fun x=> x^alpha (ln x)^beta A B for *) (* alpha in Z, beta in N, A, B (finite) reals *) Definition Bertrand alpha beta A B (I : R) := is_RInt (fun x => powerRZ x alpha * (pow (ln x) beta)) A B I. (* Function computing the Bertrand integral: *) Fixpoint f (alpha : Z) (beta : nat) (A B : R) {struct beta} := match beta with | 0 => (powerRZ B (alpha+1)- powerRZ A (alpha+1)) / (IZR (alpha + 1)) | S m => (powerRZ B (alpha+1) * (pow (ln B) (beta)) - powerRZ A (alpha+1) * (pow (ln A) beta)) / (IZR (alpha + 1)) - (INR beta) / (IZR (alpha+1)) * f alpha m A B end. (* limit of the Bertrand integral *) Definition Bertrand_lim alpha beta (A : R) (I : R) := is_RInt_gen (fun x => powerRZ x alpha * (pow (ln x) beta)) (at_point A) (Rbar_locally p_infty) I. (* Function computing the limit of the Bertrand integral *) Fixpoint f_lim (alpha : Z) (beta : nat) (A : R) {struct beta} := match beta with | 0 => (- powerRZ A (alpha+1)) / (IZR (alpha + 1)) | S m => - ( powerRZ A (alpha+1) * (pow (ln A) beta)) / (IZR (alpha + 1)) - (INR beta) / (IZR (alpha+1)) * f_lim alpha m A end. (* Variables (A B : R). *) (* Eval cbn in f 1 3 A B. *) Lemma one_step_by_parts alpha beta (A : R) (B : R) (H : 0 < A <= B) (Halpha: alpha <> (-1)%Z) : forall I, Bertrand alpha beta A B I -> Bertrand alpha (S beta) A B ((powerRZ B (alpha+1) * (pow (ln B) (S beta)) - powerRZ A (alpha+1) * (pow (ln A) (S beta))) / (IZR (alpha + 1)) - (INR (S beta)) / (IZR (alpha+1)) * I). Proof. have Salpha_neq_0 : IZR (alpha + 1) <> 0. by apply: not_0_IZR; lia. move => I HABI. rewrite/Bertrand. pose f := (fun x => Rdiv (powerRZ x (alpha+1)) (IZR(alpha+1))). pose f' := (fun x => powerRZ x alpha). pose g := (fun x => pow (ln x) (beta.+1)). pose g' := (fun x => (1 / x) * (INR (beta.+1) * pow (ln x) beta)). set f'g := (fun x : R => scal (f' x) (g x)). pose fg' := (fun t => scal (f t) (g' t)). pose f'gplusfg' := (fun t : R => plus (f'g t) (fg' t)). apply (is_RInt_ext (fun x => minus (f'gplusfg' x) (fg' x))) => [x HX|]. rewrite /f'gplusfg' /fg' /f /g /f'g. by rewrite /minus -plus_assoc plus_opp_r plus_zero_r /scal. apply: is_RInt_minus. - apply: (is_RInt_ext (fun t : R => plus (scal (f' t) (g t)) (scal (f t) (g' t)))) =>[x Hx|]. by []. have -> : ((powerRZ B (alpha + 1) * ln B ^ beta.+1 - powerRZ A (alpha + 1) * ln A ^ beta.+1) / IZR (alpha + 1)) = (minus (scal (f B) (g B)) (scal (f A) (g A))). rewrite /f /g /minus /opp /plus /scal /mult /= /mult /= . by field. apply: (is_RInt_scal_derive f g f' g' A B) => x Hx. have xgt0 : x > 0 by case: Hx; rewrite Rmin_left; lra. + rewrite /f /f'. apply: (is_derive_ext (fun x0 => scal (powerRZ x0 (alpha + 1)) (1 / IZR (alpha + 1)))) => [t|]. by rewrite /scal /= /mult /=;field. have -> : powerRZ x alpha = scal (IZR (alpha+1) * (powerRZ x alpha)) (1 / IZR (alpha + 1)). by rewrite /scal /mult /= /mult /=; field. apply: is_derive_scal_l. apply: (is_derive_powerRZS alpha x). by lra. + rewrite /g /g'. have -> : (1 / x * (INR beta.+1 * ln x ^ beta)) = (INR beta.+1 * ( / x) * ln x ^ beta.+1.-1). rewrite -pred_Sn; field. by case: Hx; rewrite Rmin_left; lra. apply: (is_derive_pow). apply: is_derive_ln. by case: Hx; rewrite Rmin_left; lra. + have Hxneq0 : x <> 0 by rewrite Rmin_left in Hx; lra. apply: ex_derive_continuous. apply: ex_derive_powerRZ; right => // . + have Hxgt0 : x > 0 by rewrite Rmin_left in Hx; lra. have Hxneq0 : x <> 0 by lra. apply: continuous_mult. apply: continuous_Rdiv_1_x => // . apply: continuous_mult; first exact: continuous_const. (* intermediary lemmas needed here *) apply: ex_derive_continuous. apply: ex_derive_is_derive. apply: is_derive_pow. by apply: is_derive_ln. move: HABI; rewrite /Bertrand. suff Hx : forall x, Rmin A B < x < Rmax A B -> (fun x => scal (INR beta.+1 / IZR (alpha + 1)) (powerRZ x alpha * ln x ^ beta)) x = fg' x => [HABI|t HAtB]. apply: is_RInt_ext. exact: Hx. apply: is_RInt_scal => // . have Hxgt0 : t > 0 by rewrite Rmin_left in HAtB; lra. have Hxneq0 : t <> 0 by lra. rewrite /fg' /f /g'. rewrite powerRZ_add // . rewrite /scal /= /mult /=. field; lra. Qed. Lemma f_correct alpha beta A B (H : 0 < A <= B) (Halpha: alpha <> (-1)%Z) : Bertrand alpha beta A B (f alpha beta A B). Proof. elim: beta => [|m HIm] // . rewrite /f /Bertrand. apply: (is_RInt_ext (fun x => powerRZ x alpha)). + by move => x Hx; rewrite pow_O Rmult_1_r. exact: int_x_alpha. by move: (one_step_by_parts alpha m A B H Halpha _ HIm). Qed. Lemma f_correct_RInt alpha beta A B (H : 0 < A <= B) (Halpha: alpha <> (-1)%Z) : f alpha beta A B = RInt (fun x => powerRZ x alpha * (pow (ln x) beta)) A B. Proof. symmetry. apply: is_RInt_unique. exact: f_correct. Qed. Lemma is_lim_RInv_p_infty: is_lim [eta Rinv] p_infty 0. Proof. suff -> : 0 = Rbar_inv p_infty => // . apply: (is_lim_inv (fun x => x) p_infty p_infty) => // . Qed. Lemma is_lim_RInv_m_infty: is_lim [eta Rinv] m_infty 0. Proof. suff -> : 0 = Rbar_inv m_infty => // . apply: (is_lim_inv (fun x => x) m_infty m_infty) => // . Qed. Lemma is_lim_powerRZ_0 alpha (Halpha : (alpha < 0)%Z) : is_lim (powerRZ^~ (alpha)%Z) p_infty (0%R). Proof. apply: (powerRZ_ind (fun n f => (n < 0)%Z -> is_lim f p_infty (0%R))) => // [n Hn|n Hn|]. - move: Hn. have -> : 0%Z = (Z.of_nat 0%N)%Z by []. rewrite -Nat2Z.inj_lt; lia. - elim: n Hn => [|m Hm Hn] // . rewrite /= . apply: (is_lim_ext_loc (fun x => / x * / x^m)). exists 0 => x Hx. field. split. by apply: pow_nonzero; lra. by lra. case: m Hm Hn => [|m Hm] Hn. + move => _ /=. have -> : 0 = Rbar_mult (Finite 0) (Finite 1) by rewrite /= Rmult_0_l. apply: (is_lim_mult (fun x => / x) (fun x => / 1) p_infty 0 1) => // . exact: is_lim_RInv_p_infty. by rewrite Rinv_1; exact: is_lim_const. have -> : 0 = Rbar_mult (Finite 0) (Finite 0) by rewrite /= Rmult_0_l. (* why so much detail needed ? *) apply: (is_lim_mult (fun x => / x) (fun x => / x^m.+1) p_infty 0 0) => // . exact: is_lim_RInv_p_infty. apply: Hm. rewrite Z.opp_neg_pos. have -> : 0%Z = (Z.of_nat 0%N)%Z by []. by rewrite -Nat2Z.inj_lt; lia. move => f g Hfg n H1 H2. apply: (is_lim_ext f g _ _ Hfg). by apply: H1. Qed. Lemma is_lim_pow_infty n : is_lim (fun x => x^n.+1) p_infty p_infty. Proof. elim: n => [|n Hn]. - apply: (is_lim_ext id) => // . by move => y; rewrite pow_1. - apply: (is_lim_ext (fun x => x * x^n.+1)). by move => y. have {2}-> : p_infty = Rbar_mult p_infty p_infty => // . apply: is_lim_mult => // . Qed. Lemma is_lim_pow_0 (f : R -> R) n : is_lim f p_infty 0 -> is_lim (fun x => (f x)^n.+1) p_infty 0. Proof. elim: n => [|n Hn]. - apply: (is_lim_ext f) => // . by move => y; rewrite pow_1. - move => Hf0. apply: (is_lim_ext (fun x => (f x) * (f x)^n.+1)). by move => y. have {1}-> : 0 = Rbar_mult 0 0 by rewrite /= Rmult_0_l. apply: (is_lim_mult f (fun x => (f x)^n.+1) p_infty 0 0) => // . exact: Hn. Qed. Lemma Rbar_mult_p_l y (Hy : 0 < y) : Rbar_mult y p_infty = p_infty. Proof. rewrite /Rbar_mult /Rbar_mult'. case: (Rle_dec 0 y) => Hy1; last by lra. by case: (Rle_lt_or_eq_dec 0 y Hy1) => // ; lra. Qed. Lemma Rbar_mult_p_r y (Hy : 0 < y) : Rbar_mult p_infty y = p_infty. Proof. by rewrite Rbar_mult_comm; exact: Rbar_mult_p_l. Qed. Lemma Rbar_mult_m_l y (Hy : 0 < y) : Rbar_mult y m_infty = m_infty. Proof. rewrite /Rbar_mult /Rbar_mult'. case: (Rle_dec 0 y) => Hy1; last by lra. by case: (Rle_lt_or_eq_dec 0 y Hy1) => // ; lra. Qed. Lemma Rbar_mult_m_r y (Hy : 0 < y) : Rbar_mult m_infty y = m_infty. Proof. by rewrite Rbar_mult_comm; exact: Rbar_mult_m_l. Qed. (* TODO: variant with a composition *) Lemma is_lim_Rpower y (Hy : 0 < y) : is_lim (fun x => Rpower x y) p_infty p_infty. Proof. rewrite /Rpower. apply: is_lim_comp => // . exact: is_lim_exp_p. apply: (is_lim_ext (fun x => scal y (ln x))). by move => x0. have {2}-> : p_infty = Rbar_mult y p_infty. by rewrite Rbar_mult_p_l. apply (is_lim_scal_l ln y p_infty p_infty). exact: is_lim_ln_p. exists 0 => x0 Hx0 //. Qed. Lemma x_alpha_0 alpha (Halpha : (alpha < -1)%Z) : is_lim (powerRZ^~ (alpha + 1)%Z) p_infty (0%R). Proof. apply: is_lim_powerRZ_0. by lia. Qed. Lemma Rpower_pos {x y} (Hx : 0 < x) (Hy : 0 <= y) : Rpower x y > 0. Proof. rewrite /Rpower. by apply: exp_pos. Qed. Lemma is_derive_Rpower {x y} (Hx : 0 < x) (Hy : 0 <= y) : is_derive (fun t => Rpower t y) x (y * Rpower x (y - 1)). Proof. move: (is_derive_n_Rpower 1 y x Hx) => /=. by rewrite big_ord_recl big_ord0 /= Rminus_0_r Rmult_1_r. Qed. Lemma ln_Rpower x y (Hx : 0 < x) (Hy : 0 <= y) : ln (Rpower x y) = y * ln x. Proof. rewrite /Rpower // . by rewrite ln_exp. Qed. Lemma x_alpha_beta alpha beta (Halpha : (alpha < -1)%Z) : is_lim (fun x => powerRZ x (alpha + 1)%Z * (pow (ln x) beta.+1)) p_infty (0%R). Proof. have Halpah1 : IZR (alpha + 1) < 0. by apply: (IZR_lt _ 0); lia. have Hbeta1 : INR beta.+1 > 0. apply: lt_0_INR. exact: Nat.lt_0_succ. have foo : 0 < IZR (- (alpha + 1)) / INR beta.+1. rewrite opp_IZR. by apply: RIneq.Rdiv_lt_0_compat => // ; lra. set X := fun x => Rpower x ((IZR (Z.opp (alpha + 1))) / INR beta.+1). (* First we rewrite our function *) have Htransform: forall x, x > 0 -> powerRZ x (alpha + 1) * ln x ^ beta.+1 = pow (-((INR beta.+1) / IZR (alpha + 1)) * (ln (X x) * / (X x))) beta.+1. move => x Hx. have HXgt0 : X x > 0. by apply: Rpower_pos => // ; lra. have -> : -((INR beta.+1) / IZR (alpha + 1)) * (ln (X x) / (X x)) = (-((INR beta.+1) / IZR (alpha + 1)) * ln (X x)) / (X x). field. by split; lra. rewrite -ln_Rpower ?Rpow_mult_distr => // . + have -> : Rpower (X x) (-(INR beta.+1 / IZR (alpha + 1))) = x. rewrite Rpower_mult. rewrite opp_IZR. have -> : (- IZR ((alpha + 1)) / INR beta.+1 * -(INR beta.+1 / IZR (alpha + 1))) = 1 by field; lra. exact: Rpower_1. + rewrite Rmult_comm. congr (_ * _). have Hpow_pos : Rpower x (IZR (- (alpha + 1)) / INR beta.+1) > 0. by apply: Rpower_pos => // ; lra. rewrite -Rinv_pow /X; try lra. rewrite -Rpower_pow ?Rpower_mult -?Rpower_Ropp // . have -> : (- (IZR (- (alpha + 1)) / INR beta.+1 * INR beta.+1)) = IZR (alpha + 1)%Z. by rewrite opp_IZR; field; lra. by rewrite powerRZ_Rpower. apply: Ropp_0_ge_le_contravar. apply: Rle_ge. rewrite /Rdiv. apply: Rmult_le_pos_neg => // ; try lra. by apply: Rlt_le; apply: Rinv_lt_0_compat. (* now we can show its limit *) apply: (is_lim_ext_loc (fun x => (- (INR beta.+1 / IZR (alpha + 1)) * (ln (X x) * / X x)) ^ beta.+1) ). by exists 0; move => x Hx ; rewrite Htransform // . apply: is_lim_pow_0. have -> : 0 = Rbar_mult (- (INR beta.+1 / IZR (alpha + 1))) 0. by rewrite /Rbar_mult /Rbar_mult' Rmult_0_r. apply (is_lim_scal_l (fun (x : R) => (ln (X x) * / X x)) (- (INR beta.+1 / IZR (alpha + 1))) p_infty 0). apply: (is_lim_comp (fun x => ln x / x) X p_infty 0 p_infty). + exact: is_lim_div_ln_p. + apply: is_lim_Rpower => // . + exists 0 => x Hx // . Qed. Lemma f_lim_is_lim alpha beta A (H : 0 < A) (Halpha : (alpha < -1)%Z): filterlim (f alpha beta A) (Rbar_locally p_infty) (locally (f_lim alpha beta A)). elim: beta => [ | beta Hbeta]. - rewrite /f /f_lim /Rdiv /Rminus. rewrite -[locally _]/(Rbar_locally (Rbar_mult (Finite _) (Finite _))). rewrite -[filterlim _ _ _]/(is_lim _ p_infty _). apply: is_lim_mult => // . + apply: is_lim_plus. * exact: x_alpha_0. * exact: is_lim_const. * rewrite /is_Rbar_plus /= . by apply f_equal, f_equal, Rplus_0_l. + apply is_lim_const. - rewrite /f /f_lim -/f -/f_lim /Rdiv /Rminus. rewrite -[locally _]/(Rbar_locally (Finite _)). rewrite -[filterlim _ _ _]/(is_lim _ p_infty _). apply: is_lim_plus. + apply: is_lim_mult. * apply: is_lim_plus. - exact: x_alpha_beta. - exact: is_lim_const. - done. * exact: is_lim_const. * done. + apply: is_lim_opp. apply: is_lim_mult. * exact: is_lim_const. * rewrite -[locally _]/(Rbar_locally (Finite _)) in Hbeta. exact Hbeta. * done. + by rewrite Rplus_0_l. Qed. Lemma f_lim_correct alpha beta A (H : 0 < A) (Halpha : (alpha < -1)%Z) : Bertrand_lim alpha beta A (f_lim alpha beta A). Proof. rewrite /Bertrand_lim. apply prodi_to_single_l. apply: (filterlimi_lim_ext_loc (f alpha beta A)). exists A => x Hx. apply f_correct. apply (conj H). exact: Rlt_le. exact: Zlt_not_eq. exact: f_lim_is_lim. Qed. Section BertrandLogNeg. (* in this section we focus on integrals of the shape *) (* int(1 / (x * ln^beta), x=a..infinity), a>1, beta>1 *) Definition f_neg (a : R) (beta : nat) := - / ((INR beta) * (ln a)^beta). Lemma continuous_f_neg x beta (H0x : 0 < x) (Hx1 : x <> 1): continuous (fun x0 : R => / (x0 * ln x0 ^ beta)) x. Proof. have Hlnn0 x1 beta1 : 0 < x1 -> 1 <> x1 -> ln x1 ^ beta1 <> 0. by move => H0x1 Hx10; apply: pow_nonzero; case: (Rlt_dec 1 x1) => H; move: (ln_increasing 1 x1); move: (ln_increasing x1 1); rewrite ln_1; lra. apply: continuous_comp. apply: continuous_mult; first exact: continuous_id. apply: (continuous_comp ln (fun x => pow x beta)). by apply: continuous_ln; lra. by apply: ex_derive_continuous; apply: ex_derive_pow; exact: ex_derive_id. apply: continuous_Rinv. apply: Rmult_integral_contrapositive; split; try lra. apply: Hlnn0; lra. Qed. Lemma is_derive_f_neg : forall beta x, beta <> 0%N -> 0 < x -> x <> 1 -> is_derive (fun x : R => f_neg x beta) x (/ (x * (ln x)^beta.+1)). Proof. intros beta x Hbeta Hx1 Hx2. rewrite /f_neg -[/(_ * _)]Ropp_involutive. apply: is_derive_opp. assert (H: (ln x <> 0)%R). rewrite <- ln_1. contradict Hx2. exact (ln_inv x 1 Hx1 Rlt_0_1 Hx2). auto_derive. - refine (conj Hx1 (conj _ I)). apply Rmult_integral_contrapositive. split. now apply not_0_INR. now apply pow_nonzero. - destruct beta as [|beta]. easy. simpl Nat.pred. simpl pow. field. repeat split. now apply pow_nonzero. exact H. now apply Rgt_not_eq. now apply not_0_INR. Qed. Lemma f_neg_correct_RInt_0_1 a b beta (Hab1 : 0 < a <= b) (Hb1 : b < 1) (Hbeta : beta <> 0%N) : is_RInt (fun x => / (x * (ln x)^beta.+1)) a b (f_neg b beta - f_neg a beta). Proof. have Hbetn0 : INR beta <> 0 by apply: not_0_INR; case: beta Hbeta. have Hlnn0 x beta1 : 0 < x < 1 -> ln x ^ beta1 <> 0. by move => Hx0; apply: pow_nonzero; move: (ln_increasing x 1); rewrite ln_1;lra. have Hder : forall x, 0 < x < 1 -> is_derive (fun x => f_neg x beta) x (/ (x * (ln x)^beta.+1)). move => x Hax. apply is_derive_f_neg. now destruct beta. apply Hax. now apply Rlt_not_eq. apply: (is_RInt_derive (fun x => f_neg x beta) _). by move => x Hx; apply: Hder; rewrite Rmin_left ?Rmax_right in Hx; try lra. move => x. (rewrite Rmin_left ?Rmax_right; try (by lra)). move => Hx. apply: continuous_comp. apply: continuous_mult; first exact: continuous_id. apply: (continuous_comp ln (fun x => pow x beta.+1)). by apply: continuous_ln; lra. by apply: ex_derive_continuous; apply: ex_derive_pow; exact: ex_derive_id. apply: continuous_Rinv. apply: Rmult_integral_contrapositive; split; try lra. by apply: Hlnn0; lra. Qed. Lemma f_neg_correct_RInt_a_infty a b beta (Ha : 1 < a <= b) (Hbeta : beta <> 0%N) : is_RInt (fun x => / (x * (ln x)^beta.+1)) a b (f_neg b beta - f_neg a beta). Proof. have Hbetn0 : INR beta <> 0 by apply: not_0_INR; case: beta Hbeta. have Hlnn0 x beta1 : a <= x -> ln x ^ beta1 <> 0. by move => Hx0; apply: pow_nonzero; move: (ln_increasing 1 x); rewrite ln_1; lra. have Hder : forall x, a <= x -> is_derive (fun x => f_neg x beta) x (/ (x * (ln x)^beta.+1)). move => x Hax. apply is_derive_f_neg. now destruct beta. apply Rlt_trans with (1 := Rlt_0_1). now apply Rlt_le_trans with a. apply Rgt_not_eq. now apply Rlt_le_trans with a. apply: (is_RInt_derive (fun x => f_neg x beta) _). by move => x Hx; apply: Hder; rewrite Rmin_left in Hx; try lra. move => x. (rewrite Rmin_left; last by lra); move => Hx. apply: continuous_comp. apply: continuous_mult; first exact: continuous_id. apply: (continuous_comp ln (fun x => pow x beta.+1)). by apply: continuous_ln; lra. by apply: ex_derive_continuous; apply: ex_derive_pow; exact: ex_derive_id. apply: continuous_Rinv. apply: Rmult_integral_contrapositive; split; try lra. by apply: Hlnn0; lra. Qed. Lemma filterlim_sqr_m_infty: filterlim (pow^~ 2%N) (Rbar_locally m_infty) (Rbar_locally p_infty). Proof. apply: (filterlim_ext (fun x => x * x)); first by move => y; rewrite /= ?Rmult_1_r. suff -> : p_infty = Rbar_mult m_infty m_infty => // . apply: filterlim_comp_2; try exact: filterlim_id. exact: filterlim_Rbar_mult. Qed. Lemma is_lim_sqr_infty: is_lim (pow^~ 2%N) m_infty p_infty. Proof. apply: (is_lim_ext (fun x => x * x)); first by move => y; rewrite /= ?Rmult_1_r. suff -> : p_infty = Rbar_mult m_infty m_infty => // . by apply: is_lim_mult => // . Qed. Lemma filterlim_pow_infty n : filterlim (pow^~ n.+1) (Rbar_locally p_infty) (Rbar_locally p_infty). Proof. elim: n => [|n Hn]. apply: (filterlim_ext (fun x => x)). by move => x; rewrite pow_1. exact: filterlim_id. apply: (filterlim_ext (fun x => x * (pow x n.+1))). by move => x. apply: filterlim_comp_2; first exact: filterlim_id. exact: Hn. exact: filterlim_Rbar_mult. Qed. Lemma filterlim_pow_m_even n : ~~ odd n.+1 -> filterlim (fun x => pow x n.+1) (Rbar_locally m_infty) (Rbar_locally p_infty). Proof. move => Hodd. rewrite -(odd_double_half n.+1). rewrite -[odd n.+1]Bool.negb_involutive Hodd /= add0n. (*ugly *) rewrite -mul2n. apply: filterlim_ext. move => y; by rewrite pow_mult. apply: (filterlim_comp _ _ _ (fun x => x ^ 2) (fun x => x ^ (uphalf n))). apply: filterlim_sqr_m_infty. case: n Hodd => [|n] // Hodd. exact: filterlim_pow_infty. Qed. Lemma filterlim_pow_m_odd n : odd n.+1 -> filterlim (fun x => pow x n.+1) (Rbar_locally m_infty) (Rbar_locally m_infty). Proof. move => Hodd. case: n Hodd => [|n] Hodd. - apply: (filterlim_ext id). by move => x /=; rewrite Rmult_1_r. exact: filterlim_id. apply: (filterlim_ext (fun x => x * pow x n.+1)). by move => x. apply: filterlim_comp_2. exact: filterlim_id. by apply: filterlim_pow_m_even. by apply: filterlim_Rbar_mult. Qed. (* Lemma is_lim_pow_m_infty n : is_lim (fun x => pow x n.+1) m_infty (if odd n.+1 then m_infty else p_infty). Proof. rewrite -{1}(odd_double_half n.+1). case : ifP => Hodd. suff {2}-> : m_infty = Rbar_mult m_infty (if (uphalf n) is m.+1 then p_infty else 1). apply: is_lim_mult => // . rewrite -mul2n. apply: is_lim_ext. move => y. by rewrite pow_mult. apply: (is_lim_comp (fun x => x ^(uphalf n)) (fun x => x ^ 2)). case Hhalf: (uphalf n) => [|m]. apply: (is_lim_ext (fun x => 1)). by move => y; rewrite pow_O. exact: is_lim_const. exact: is_lim_pow_infty. exact: is_lim_sqr_infty. by exists 0 . case: (uphalf n) => // ; rewrite /ex_Rbar_mult; lra. case: (uphalf n) => // ; rewrite Rbar_mult_m_r // ; lra. rewrite add0n -mul2n. apply: is_lim_ext. move => y; by rewrite pow_mult. case: n Hodd => // n Hodd. apply: (is_lim_comp (fun x => x ^ (n.+2)./2) (fun x => x ^2) _ _ p_infty). apply: is_lim_pow_infty. exact: is_lim_sqr_infty. by exists 1. Qed. Lemma is_lim_pow_m_odd n : odd n.+1 -> is_lim (fun x => pow x n.+1) m_infty m_infty. Proof. move => Hodd. by move: (is_lim_pow_m_infty n); rewrite Hodd. Qed. Lemma is_lim_pow_m_even n : ~~ odd n.+1 -> is_lim (fun x => pow x n.+1) m_infty p_infty. Proof. move => Hodd. move: (is_lim_pow_m_infty n); case: ifPn => // Heven. by rewrite Heven in Hodd. Qed. *) Lemma f_neg_correct_RInt_gen_0_a a beta (Ha : 0 < a < 1) (Hbeta : beta <> 0%N) : is_RInt_gen (fun x => / (x * (ln x)^beta.+1)) (at_right 0) (at_point a) (f_neg a beta). Proof. apply prodi_to_single_r. have apos : 0 < a by lra. set ap := mkposreal a apos. apply: (filterlimi_lim_ext_loc). exists ap => x Hx1 Hx2. apply f_neg_correct_RInt_0_1 => // ;move/ball_to_lra: Hx1 => /=; lra. rewrite -{2}[f_neg _ _ ]Rminus_0_r. apply: (filterlim_comp _ _ _ (fun x => f_neg x beta) (fun x => f_neg a beta - x) (at_right 0) _ (* (Rbar_locally 0) *) _) ;last first. rewrite /Rminus. apply: continuous_plus. exact: filterlim_const. exact: filterlim_opp. rewrite /f_neg. apply: filterlim_comp; last first. rewrite -[0]Ropp_0. exact: (filterlim_opp 0). case HEvenOdd: (odd beta); last first. - rewrite -[locally 0]/(Rbar_locally (Rbar_inv p_infty)). apply (filterlim_comp _ _ _ (fun x => INR beta*ln x ^ beta) Rinv _ (Rbar_locally p_infty)). have -> : p_infty = Rbar_mult (INR beta) p_infty. by rewrite Rbar_mult_p_l // ; apply: lt_0_INR; apply/ltP; case: beta Hbeta HEvenOdd. suff: filterlim (fun x => (ln x)^beta) (at_right 0) (Rbar_locally p_infty). move => Hln. apply: filterlim_comp; last first. exact: filterlim_Rbar_mult_l. exact: Hln. apply: (filterlim_comp _ _ _ _ (fun x => x ^beta)) => //; try apply: is_lim_ln_0. case: beta Hbeta HEvenOdd => [|beta] Hbeta HevenOdd // . by apply: filterlim_pow_m_even; by rewrite HevenOdd. exact: is_lim_RInv_p_infty. - rewrite -[locally 0]/(Rbar_locally (Rbar_inv m_infty)). apply (filterlim_comp _ _ _ (fun x => INR beta*ln x ^ beta) Rinv _ (Rbar_locally m_infty)). have -> : m_infty = Rbar_mult (INR beta) m_infty. by rewrite Rbar_mult_m_l // ; apply: lt_0_INR; apply/ltP; case: beta Hbeta HEvenOdd. suff: filterlim (fun x => (ln x)^beta) (at_right 0) (Rbar_locally m_infty). move => Hln. apply: filterlim_comp; first exact: Hln. exact: filterlim_Rbar_mult_l. apply: (filterlim_comp _ _ _ _ (fun x => x ^ beta)); try apply: is_lim_ln_0. case: beta Hbeta HEvenOdd => [|beta] Hbeta HevenOdd // . by apply: filterlim_pow_m_odd; by rewrite HevenOdd. by apply: is_lim_RInv_m_infty. Qed. Lemma f_neg_correct_RInt_gen_a_infty a beta (Ha : 1 < a) (Hbeta : beta <> 0%N) : is_RInt_gen (fun x => / (x * (ln x)^beta.+1)) (at_point a) (Rbar_locally p_infty) (- f_neg a beta). Proof. apply prodi_to_single_l. apply: (filterlimi_lim_ext_loc). exists a => x Hx. by apply f_neg_correct_RInt_a_infty => // ; lra. rewrite -Rminus_0_l. apply: (filterlim_comp _ _ _ (fun x => f_neg x beta) (fun x => x - f_neg a beta) (* (Rbar_locally' p_infty) *) _ (* (Rbar_locally 0) *) _);last first. rewrite /Rminus. apply: continuous_plus 0%R _ _. exact: filterlim_id. exact: filterlim_const. rewrite /f_neg. apply: filterlim_comp. apply: (is_lim_inv (fun x => INR beta*ln x ^ beta) (p_infty) (p_infty)) => // . have {2} -> : p_infty = Rbar_mult (INR beta) p_infty. by rewrite Rbar_mult_p_l // ; apply: lt_0_INR; apply/ltP; case: beta Hbeta. apply: is_lim_mult; first exact: is_lim_const. apply: (filterlim_comp _ _ _ _ (fun x => x ^beta)) => // ; try apply: is_lim_ln_p. by case :beta Hbeta => [| beta] // Hbeta; apply: is_lim_pow_infty. by apply: not_0_INR; case: beta Hbeta. rewrite -[0]Ropp_0. exact: (filterlim_opp 0). Qed. End BertrandLogNeg. Section ExponentInQ. End ExponentInQ. Section ZeroToEpsilon. (* The following definition stems from the fact that 'RInt (x^alpha * (ln x)^beta) 0 eps' = RInt_gen (u^(2 - alpha) * (ln u) ^ beta) (1/eps) p_infty *) Definition f0eps (alpha : Z) (beta : nat) (epsilon : R) (B : R) := (-1) ^ beta * f (- 2 - alpha) beta (/ epsilon) B. Definition f0eps_lim (alpha : Z) (beta : nat) (epsilon : R) := (-1) ^ beta * f_lim (- 2 - alpha) beta (/ epsilon). Lemma pow_negx x n : pow (- x) n = (pow (-1) n) * pow x n. have -> : - x = -1 * x by ring. by rewrite Rpow_mult_distr. Qed. Lemma subst_lemma alpha beta epsilon (eta : R) (Heps : 0 < epsilon) (Heta : 0 < eta <= epsilon) (Halpha : -1 < IZR alpha) : RInt_gen (fun x => powerRZ x alpha * pow (ln x) beta) (at_point eta) (at_point epsilon) = - RInt (fun x => - (pow (-1) beta) * powerRZ x (- 2 - alpha) * (pow (ln x) beta)) (1 / epsilon) (1 / eta). Proof. have Hint : ex_RInt (fun x : R => powerRZ x alpha * ln x ^ beta) eta epsilon. eexists. apply: f_correct => // . suff: (-1 < alpha)%Z by lia. apply: lt_IZR => // . (* should be a lemma *) have -> : RInt_gen (fun x : R => powerRZ x alpha * ln x ^ beta) (at_point eta) (at_point epsilon) = RInt (fun x : R => powerRZ x alpha * ln x ^ beta) eta epsilon. apply is_RInt_gen_unique; rewrite is_RInt_gen_at_point. exact: RInt_correct => // . pose g := fun x => Rinv x. pose dg := fun x => - 1 / x^2. have {1}-> : 1 / eta = (g eta). by rewrite /g; field; lra. have {1}-> : 1 / epsilon = (g epsilon). by rewrite /g; field; lra. rewrite -(RInt_comp _ _ dg). rewrite -opp_RInt_swap ; first congr (opp _) ; last by apply: ex_RInt_swap. symmetry; apply: RInt_ext. move => x Hx. rewrite Rmin_right in Hx; try lra. rewrite Rmax_left in Hx; try lra. have Hxneg0 : x <> 0 by lra. have Hinv : / x <> 0. by apply: Rinv_neq_0_compat. have -> : scal (dg x)(- (-1) ^ beta * powerRZ (g x) (-2 - alpha) * ln (g x) ^ beta) = (dg x) * (- (-1) ^ beta * powerRZ (g x) (-2 - alpha) * ln (g x) ^ beta) by []. rewrite /dg /g. rewrite powerRZ_add ?ln_Rinv; try lra. rewrite -> (powerRZ_neg _ 2), powerRZ_neg, Rinv_involutive by easy. rewrite [(- ln x) ^beta] pow_negx. replace (powerRZ x alpha * ln x ^ beta) with ((-1)^beta * (-1)^beta * (powerRZ x alpha * ln x ^ beta)). rewrite /(powerRZ x 2) /=. now field. rewrite -Rpow_mult_distr. have -> : -1 * -1 = 1 by ring. by rewrite pow1 Rmult_1_l. move => x Hx. rewrite Rmin_right in Hx; try lra. rewrite Rmax_left in Hx; try lra. apply: continuous_mult. apply: continuous_mult. exact: continuous_const. apply: ex_derive_continuous. apply: ex_derive_powerRZ. by rewrite /g; right; apply: Rinv_neq_0_compat; lra. rewrite /g. apply: continuous_ext. move => x0. by rewrite pow_powerRZ. apply: (continuous_comp ln (fun x => powerRZ x (Z.of_nat beta))). by apply: continuous_ln; apply: Rinv_0_lt_compat; lra. apply: ex_derive_continuous. by apply: ex_derive_powerRZ; left; apply: Zle_0_nat. move => x Hx. rewrite Rmin_right in Hx; try lra. rewrite Rmax_left in Hx; try lra. split. rewrite /g /dg. apply: (is_derive_inv (fun x => x) x 1); last by lra. exact: is_derive_id. rewrite /dg. apply: continuous_mult; first exact: continuous_const. apply: continuous_Rinv_comp. apply: (continuous_ext (fun t => t * t)) => [t|]. by rewrite pow_powerRZ /=; ring. by apply: continuous_mult; exact: continuous_id. by apply: pow_nonzero; lra. Qed. Lemma f0eps_correct alpha beta epsilon (B : R) (Heps : 0 < / B <= epsilon) (HB : 0 < B) (Halpha : (-1 < alpha)%Z) : is_RInt_gen ((fun x => powerRZ x alpha * (pow (ln x) beta))) (at_point (/ B)) (at_point epsilon) (f0eps alpha beta epsilon B). Proof. have Hint : ex_RInt (fun x : R => powerRZ x alpha * ln x ^ beta) (/ B) epsilon. eexists. apply: f_correct => // . by lia. have HinvepsinvB : 0 < / epsilon <= B. split. by apply: Rinv_0_lt_compat; by lra. by rewrite -[B]Rinv_involutive; try lra; apply: Rinv_le; lra. rewrite is_RInt_gen_at_point. suff: f0eps alpha beta epsilon B = RInt (fun x : R => powerRZ x alpha * ln x ^ beta) (/B) epsilon. by move ->; apply: RInt_correct. rewrite -RInt_gen_at_point; last first. + eexists. apply: f_correct; try lra; try lia. + rewrite subst_lemma ; try lra. 2: now apply IZR_lt. symmetry. rewrite /f0eps. rewrite f_correct_RInt; try lra; try lia. rewrite (RInt_ext _ (fun x : R => scal (- (-1) ^ beta) (powerRZ x (-2 - alpha) * ln x ^ beta))); last first. by move => x Hx; rewrite /scal [in RHS]/= /mult /=; rewrite Rmult_assoc. set e1 := (-2 - alpha)%Z; rewrite RInt_scal /scal /= /mult /= . ring_simplify; congr(_ * RInt _ _ _) => // ; field; lra. rewrite /e1. by eexists; apply: f_correct; first (split; field_simplify; lra); lia. Qed. Lemma f0eps_correct_sing alpha beta epsilon sing (B : R) (Heps : 0 < / B <= epsilon) (HB : 0 < B) (Halpha : (-1 < alpha)%Z) : is_RInt_gen ((fun x => powerRZ (x - sing) alpha * (pow (ln (x - sing)) beta))) (at_point (sing + / B)) (at_point (sing + epsilon)) (f0eps alpha beta epsilon B). Proof. apply is_RInt_gen_at_point. apply: (is_RInt_translation_sub _ (fun x => powerRZ x alpha * ln x ^ beta)). apply is_RInt_gen_at_point. have H : forall x y, x + y - x = y by move => x y; ring. rewrite !H; apply f0eps_correct => // . Qed. Lemma f0eps_lim_is_lim alpha beta epsilon (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon) : filterlim (fun x : R => f0eps alpha beta epsilon (/ x)) (at_right 0) (locally (f0eps_lim alpha beta epsilon)). Proof. apply: filterlim_comp. exact: filterlim_Rinv_0_right. rewrite /f0eps /f0eps_lim. have H x : ((-1) ^ beta * x) = mult ((-1) ^ beta) x by []. rewrite H. apply: filterlim_ext. by move => x; first rewrite H. rewrite -[locally _]/(Rbar_locally (Rbar_mult (Finite _) (Finite _))). rewrite -[filterlim _ _ _]/(is_lim _ p_infty _). apply: is_lim_mult => // . + exact: is_lim_const. + apply: f_lim_is_lim; first exact: Rinv_0_lt_compat. by lia. Qed. Lemma f0eps_lim_is_lim_sing alpha beta epsilon sing (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon) : filterlim (fun x : R => f0eps alpha beta epsilon (/ (x - sing))) (at_right sing) (locally (f0eps_lim alpha beta epsilon)). Proof. apply: (filterlim_comp _ _ _ (fun x => x - sing) (fun x => f0eps alpha beta epsilon (Rinv x)) _ (at_right 0)). move => P [eps HepsP]. rewrite /filtermap /at_right /within /locally. exists eps => y Hy Hsing. apply: HepsP. have Hepspos : 0 < eps by exact: (cond_pos eps). by apply/ball_to_lra; split; move/ball_to_lra: Hy; lra. lra. exact: f0eps_lim_is_lim. Qed. Lemma f0eps_lim_correct alpha beta epsilon (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon) : is_RInt_gen ((fun x => powerRZ x alpha * (pow (ln x) beta))) (at_right 0) (at_point epsilon) (f0eps_lim alpha beta epsilon). Proof. set eps := mkposreal epsilon Heps. apply prodi_to_single_r. apply: (filterlimi_lim_ext_loc (fun x => f0eps alpha beta epsilon (/ x))). exists (pos_div_2 eps) => y /= Hy1 Hy2. move/ball_to_lra in Hy1. have {1}-> : y = / / y by rewrite Rinv_involutive; lra. rewrite -is_RInt_gen_at_point. apply (f0eps_correct); rewrite ?Rinv_involutive; try lra. exact: Rinv_0_lt_compat. exact Halpha. exact: f0eps_lim_is_lim. Qed. Lemma f0eps_lim_correct_sing alpha beta epsilon sing (Halpha : (-1 < alpha)%Z) (Heps : 0 < epsilon) : is_RInt_gen ((fun x => powerRZ (x - sing) alpha * (pow (ln (x - sing)) beta))) (at_right sing) (at_point (sing + epsilon)) (f0eps_lim alpha beta epsilon). Proof. set eps := mkposreal epsilon Heps. apply prodi_to_single_r. apply: (filterlimi_lim_ext_loc (fun x => f0eps alpha beta epsilon (/ (x - sing)))). exists (pos_div_2 eps) => y /= Hy1 Hy2. move/ball_to_lra in Hy1. have {1}-> : y = sing + / / (y - sing) by rewrite Rinv_involutive; lra. rewrite -is_RInt_gen_at_point. apply f0eps_correct_sing; rewrite ?Rinv_involutive; try lra. apply: Rinv_0_lt_compat; lra. exact Halpha. exact: f0eps_lim_is_lim_sing. Qed. End ZeroToEpsilon. Module BertrandInterval (I : IntervalOps). Module J := IntervalExt I. Section EffectiveBertrand. (* TODO: factor out the A^alpha+1 and compute ln A only once for efficiency *) Variable prec : I.precision. Section Infinity. Variable a : R. Variable A : I.type. Let iA := I.convert A. Hypothesis Hcontainsa : contains iA (Xreal a). Section BertrandLogNegInt. Definition f_neg_int beta := I.inv prec (I.mul prec (I.fromZ prec (Z.of_nat beta)) (I.power_int prec (I.ln prec A) (Z.of_nat beta))). Lemma f_neg_int_correct beta : contains (I.convert (f_neg_int beta)) (Xreal (- f_neg a beta)). Proof. rewrite /f_neg Ropp_involutive. apply: J.inv_correct. apply: J.mul_correct. rewrite INR_IZR_INZ. exact: I.fromZ_correct. rewrite pow_powerRZ. apply: J.power_int_correct. exact: J.ln_correct. Qed. End BertrandLogNegInt. Fixpoint f_int_aux (alpha : Z) (beta : nat) (A_pow_Salpha : I.type) (ln_A : I.type) {struct beta} : I.type := let alphap1 := I.fromZ prec (alpha + 1) in match beta with | 0 => I.div prec (I.neg A_pow_Salpha) alphap1 | S m => let beta := Z.of_nat beta in I.sub prec (I.div prec (I.neg (I.mul prec A_pow_Salpha (I.power_int prec ln_A beta))) alphap1) (I.mul prec (I.div prec (I.fromZ prec beta) alphap1) (f_int_aux alpha m A_pow_Salpha ln_A)) end. Definition f_int_fast (alpha : Z) (beta : nat) := let A_pow_Salpha := I.power_int prec A (alpha+1) in let ln_A := I.ln prec A in f_int_aux alpha beta A_pow_Salpha ln_A. Fixpoint f_int (alpha : Z) (beta : nat) {struct beta} : I.type := let alphap1' := (alpha + 1)%Z in let alphap1 := I.fromZ prec alphap1' in match beta with | 0 => I.div prec (I.neg (I.power_int prec A alphap1')) alphap1 | S m => let beta := Z.of_nat beta in I.sub prec (I.div prec (I.neg (I.mul prec (I.power_int prec A alphap1') (I.power_int prec (I.ln prec A) beta))) alphap1) (I.mul prec (I.div prec (I.fromZ prec beta) alphap1) (f_int alpha m)) end. Lemma f_int_correct alpha beta (H : 0 < a) (Halpha: alpha <> (-1)%Z) : contains (I.convert (f_int alpha beta)) (Xreal (f_lim alpha beta a)). Proof. have Salphaneq0 : IZR (alpha + 1) <> 0. apply: not_0_IZR. by rewrite Z.add_move_0_r. have an0 : not (is_zero a). by move: is_zero_spec; case => // ; lra. have Salphaneq01: not (is_zero (IZR (alpha + 1))). move: (is_zero_spec (IZR (alpha + 1))). case => // . elim: beta => [|m HIm]. - rewrite /= . apply: J.div_correct. apply: J.neg_correct. apply: J.power_int_correct => // ; apply: Hcontainsa. exact: I.fromZ_correct. - rewrite /f_int -/f_int /f_lim -/f_lim. apply: J.sub_correct. apply: J.div_correct. apply: J.neg_correct. apply: J.mul_correct. apply: J.power_int_correct; apply: Hcontainsa. rewrite pow_powerRZ. apply: J.power_int_correct. apply: J.ln_correct; apply: Hcontainsa. exact: I.fromZ_correct. apply: J.mul_correct => // . apply: J.div_correct. by rewrite INR_IZR_INZ; apply: I.fromZ_correct. exact: I.fromZ_correct. Qed. Lemma f_int_fast_f_int alpha beta : f_int_fast alpha beta = f_int alpha beta. Proof. elim: beta => [| beta Hbeta] //= . rewrite /f_int_fast //= . by rewrite -!Hbeta. Qed. Lemma f_int_fast_correct alpha beta (H : 0 < a) (Halpha: alpha <> (-1)%Z) : contains (I.convert (f_int_fast alpha beta)) (Xreal (f_lim alpha beta a)). Proof. by rewrite f_int_fast_f_int; exact: f_int_correct. Qed. End Infinity. Section Sing. Variable epsilon : R. Variable Epsilon : I.type. Let iEps := I.convert Epsilon. Hypothesis HEps : contains iEps (Xreal epsilon). Hypothesis eps_gt0 : 0 < epsilon. Definition f0eps_int (alpha : Z) (beta : nat) := let yi := f_int_fast (I.inv prec Epsilon) (- 2 - alpha) beta in if Nat.even beta then yi else I.neg yi. Lemma f0eps_correct (alpha : Z) (beta : nat) (Halpha : (alpha <> -1)%Z) : contains (I.convert (f0eps_int alpha beta)) (Xreal (f0eps_lim alpha beta epsilon)). Proof. rewrite /f0eps_int /f0eps_lim. assert (H: contains (I.convert (f_int_fast (I.inv prec Epsilon) (-2 - alpha) beta)) (Xreal (f_lim (-2 - alpha) beta (/ epsilon)))). { rewrite f_int_fast_f_int. apply: f_int_correct. exact: J.inv_correct. exact: Rinv_0_lt_compat. by lia. } replace ((-1) ^ beta) with (if Nat.even beta then 1 else -1). { case Nat.even. now rewrite Rmult_1_l. replace (-1 * _) with (-f_lim (-2 - alpha) beta (/ epsilon)) by ring. exact: J.neg_correct. } clear ; induction beta. easy. rewrite Nat.even_succ -Nat.negb_even. rewrite /= -IHbeta. case Nat.even => /= ; ring. Qed. End Sing. End EffectiveBertrand. End BertrandInterval. interval-4.11.1/src/Integral/Integral.v000066400000000000000000000712311470547631300177300ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2015-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List Psatz. From Coquelicot Require Import Coquelicot. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool. Require Import Stdlib. Require Import Coquelicot. Require Import Xreal. Require Import Interval. Require Import Taylor_model. Require Import Interval_compl. Section Missing. Lemma filter_prod_at_point_infty : forall a (P : R -> R -> Prop), (forall x y, a <= x <= y -> P x y) -> filter_prod (at_point a) (Rbar_locally p_infty) (fun ab : R * R => P ab.1 ab.2). Proof. intros a P HP. apply (Filter_prod _ _ _ (fun x => x = a) (fun x => a < x)). - easy. - now exists a. - move => x y -> /= H. apply HP. split. apply Rle_refl. now apply Rlt_le. Qed. Lemma filter_prod_at_point : forall {T F} { FF : Filter F} a (P : R -> T -> Prop) Q, F Q -> (forall y, Q y -> P a y) -> filter_prod (at_point a) F (fun ab : R * T => P ab.1 ab.2). Proof. intros T F FF a P Q FQ HQ. apply: (Filter_prod _ _ _ (fun x => x = a) Q) => // . - move => x y -> /= H. exact: HQ. Qed. Lemma filter_prod_at_point_l : forall {T F} { FF : Filter F} a (P : T -> R -> Prop) Q, F Q -> (forall y, Q y -> P y a) -> filter_prod F (at_point a) (fun ab : T * R => P ab.1 ab.2). Proof. intros T F FF a P Q FQ HQ. apply: (Filter_prod _ _ _ Q (fun x => x = a)) => // . - move => x y /= H ->. exact: HQ. Qed. Lemma at_point_filter_prod : forall {T F} { FF : Filter F} a (P : R -> T -> Prop), filter_prod (at_point a) F (fun ab : R * T => P ab.1 ab.2) -> F (P a). Proof. move => T F FF a P [Q R inQ inR H]. apply: filter_imp inR. move => x; exact: H. Qed. Lemma at_point_filter_prod_l : forall {T F} { FF : Filter F} a (P : T -> R -> Prop), filter_prod F (at_point a) (fun ab : T * R => P ab.1 ab.2) -> F (fun y => P y a). Proof. move => T F FF a P [Q R inQ inR H]. apply: filter_imp inQ. move => x /= HQ; apply: H => // . Qed. Lemma filterlimi_const_loc {T} {U : UniformSpace} {F : (T -> Prop) -> Prop} {FF : Filter F} : forall (f : T -> U -> Prop) (a : U), F (fun x => f x a) -> filterlimi f F (locally a). Proof. intros f a Hf P HP. rewrite /filtermapi /=. apply: filter_imp Hf => x H. exists a. apply (conj H). exact: locally_singleton. Qed. Lemma filterlimi_const {T} {U : UniformSpace} {F : (T -> Prop) -> Prop} {FF : Filter F} : forall (f : T -> U -> Prop) (a : U), (forall x, f x a) -> filterlimi f F (locally a). Proof. intros f a Hf. apply filterlimi_const_loc. exact: filter_forall. Qed. Lemma is_RInt_gen_0 {Fa Fb : (R -> Prop) -> Prop} {FFa : Filter Fa} {FFb : Filter Fb} : is_RInt_gen (fun y => 0) Fa Fb zero. Proof. apply: filterlimi_const. intros [a b]. rewrite -(scal_zero_r (b - a)). exact: is_RInt_const. Qed. (* TODO: find better name *) Lemma is_RInt_gen_filterlim {V : CompleteNormedModule R_AbsRing} {Fa Fb : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f : R -> V) (lf : V) : is_RInt_gen f Fa Fb lf -> filterlim (fun x => RInt f x.1 x.2) (filter_prod Fa Fb) (locally lf). Proof. move => Hlf P HlfP. have := (Hlf P HlfP). case => Q R HFa HFb. econstructor. exact: HFa. exact: HFb. move => x y HQx HRy. case : (p x y HQx HRy) => x0 [HRInt HP]. by move: (is_RInt_unique f x y _ HRInt ) => ->. Qed. (* very inelegant *) Lemma ex_RInt_ex_RInt_gen {V : CompleteNormedModule R_AbsRing} {Fa Fb : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f : R -> V) : ex_RInt_gen f Fa Fb -> (filter_prod Fa Fb (fun ab => ex_RInt f ab.1 ab.2)). Proof. intros [lf Hlf]. have := (Hlf (fun _ => True)). case. now exists (mkposreal _ Rlt_0_1). move => Q R HFaQ HFbR His_RInt. apply: Filter_prod HFaQ HFbR _. move => x y HQx HRy. case: (His_RInt x y HQx HRy) => I [H _]. now exists I. Qed. (* very inelegant again *) (* we probably want a more general lemma linking filterlim and filterlimi *) Lemma RInt_gen_le {Fa Fb : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f : R -> R) (g : R -> R) (lf : R) (lg : R) : filter_prod Fa Fb (fun ab => fst ab <= snd ab) -> filter_prod Fa Fb (fun ab => forall x, fst ab <= x <= snd ab -> f x <= g x) -> is_RInt_gen f Fa Fb lf -> is_RInt_gen g Fa Fb lg -> lf <= lg. Proof. move => Hab Hle. move => Hlf Hlg. apply (filterlim_le (F := filter_prod Fa Fb) (fun x => RInt f x.1 x.2) (fun x => RInt g x.1 x.2) lf lg). apply: (filter_imp (fun x => ex_RInt f x.1 x.2 /\ ex_RInt g x.1 x.2 /\ (forall y, x.1 <= y <= x.2 -> f y <= g y) /\ x.1 <= x.2)). move => x [H1 [H2 [H3 H4]]]. apply: RInt_le => // . move => x0 Hx0. have:= H3 x0. apply. by split; now apply Rlt_le. apply: filter_and. apply: ex_RInt_ex_RInt_gen. now exists lf. apply: filter_and. apply: ex_RInt_ex_RInt_gen. now exists lg. apply: filter_and => // . exact: is_RInt_gen_filterlim. exact: is_RInt_gen_filterlim. Qed. Lemma ex_RInt_gen_cauchy {V : CompleteNormedModule R_AbsRing} {Fb : (R -> Prop) -> Prop} {FFb : ProperFilter Fb} (a : R) (f : R -> V) : ex_RInt_gen f (at_point a) Fb <-> (filter_prod (at_point a) Fb (fun ab => ex_RInt f ab.1 ab.2) /\ forall eps : posreal, exists P, Fb P /\ (forall u v, P u -> P v -> forall I, is_RInt f u v I -> norm I <= eps)). Proof. split. - intros [If HIf]. split. apply ex_RInt_ex_RInt_gen. now exists If. move => eps. exists (fun x => ex_RInt f a x /\ forall I, is_RInt f a x I -> ball_norm If (pos_div_2 eps) I). split. - assert (Hb: locally If (ball_norm If (pos_div_2 eps))). exact: locally_ball_norm. have toto := (HIf _ Hb). rewrite /filtermapi in toto. pose K x1 x2 := exists y : V, is_RInt f x1 x2 y /\ ball_norm If (pos_div_2 eps) y. assert (titi := at_point_filter_prod a K toto). + apply: filter_and. apply: filter_imp titi => x. rewrite /K; case => y [Hy _]. by eexists; exact Hy. apply: filter_imp titi => x [y [Hy1 Hy2]] I HI. rewrite -(is_RInt_unique _ _ _ _ HI). by rewrite (is_RInt_unique _ _ _ _ Hy1). - move => u v [Hau Hu] [Hvu Hv] I HI. suff Hfau : is_RInt f a u (RInt f a u). suff Hfav : is_RInt f a v (RInt f a v). suff -> : (I = plus (minus If (RInt f a u)) (minus (RInt f a v) If))%R. rewrite /ball_norm. rewrite /minus. suff -> : (pos eps%R = (pos (pos_div_2 eps)) + (pos (pos_div_2 eps)))%R. apply :Rle_trans. apply: (norm_triangle). apply: Rle_trans. apply: Rplus_le_compat_l. move: (Hv _ Hfav). rewrite /ball_norm /minus. exact: Rlt_le. apply: Rplus_le_compat_r. move: (Hu _ Hfau). rewrite /ball_norm /minus. rewrite -{2}[If]opp_opp -opp_plus norm_opp plus_comm. exact: Rlt_le. rewrite /pos_div_2 /=; lra. rewrite -opp_minus -[minus (RInt f a v) If]opp_minus. rewrite -opp_plus. rewrite -minus_trans /minus -opp_RInt_swap. rewrite opp_plus !opp_opp. rewrite RInt_Chasles. symmetry; apply: is_RInt_unique => // . apply: ex_RInt_swap; eexists; exact: Hfau. eexists; exact: Hfav. apply: ex_RInt_swap; eexists; exact: Hfau. apply: RInt_correct => // . apply: RInt_correct => // . - intros [Hab Hb]. refine (proj1 (filterlimi_locally_cauchy _ _) _). apply: filter_imp Hab. move => /= [a' b'] /= HIf. apply (conj HIf). intros y1 y2 H1 H2. rewrite -(is_RInt_unique _ _ _ _ H1). exact: is_RInt_unique. intros eps. destruct (Hb (pos_div_2 eps)) as [Qb [FbQb H]]. exists (fun ab => ab.1 = a /\ Qb ab.2). split. eexists (fun x => x = a) _. easy. exact: FbQb. easy. intros [u1 u2] [v1 v2] [-> Qbu2] [-> Qbv2] I1 I2 HI1 HI2. apply: norm_compat1. unfold minus. apply is_RInt_swap in HI1. have HC := (is_RInt_Chasles _ _ _ _ _ _ HI1 HI2). rewrite plus_comm. move: (H _ _ Qbu2 Qbv2) => /= . move => /(_ _ HC) Hle. apply: Rle_lt_trans Hle _. move: (cond_pos eps); lra. Qed. (* this proof should be much shorter *) Lemma ex_RInt_gen_cauchy_left {V : CompleteNormedModule R_AbsRing} {Fb : (R -> Prop) -> Prop} {FFb : ProperFilter Fb} (a : R) (f : R -> V) : ex_RInt_gen f Fb (at_point a) <-> (filter_prod Fb (at_point a) (fun ab => ex_RInt f ab.1 ab.2) /\ forall eps : posreal, exists P, Fb P /\ (forall u v, P u -> P v -> forall I, is_RInt f u v I -> norm I <= eps)). Proof. split. - move => [I HI]. have Hswap : ex_RInt_gen (fun x => opp (f x)) (at_point a) Fb. apply is_RInt_gen_swap,is_RInt_gen_opp in HI. by eexists; exact: HI. case ((proj1 (ex_RInt_gen_cauchy a (fun x => opp (f x)))) Hswap) => Hprod Hint. split. + case: Hprod => Q R HQ HR H. econstructor. * exact: HR. * exact: HQ. * move => x y Hx Hy /= . case: (H y x Hy Hx) => /= I1 HI1. eexists; apply: is_RInt_swap. apply: is_RInt_ext => [x1 Hx1|]; first by rewrite -[f x1]opp_opp. by apply: is_RInt_opp; exact: HI1. + move => eps; case: (Hint eps) => Peps [HFeps HRInt]. exists Peps; split => // . move => u v Hu Hv I0 HI0. case: (HRInt u v Hu Hv (opp I0)). exact: is_RInt_opp. by rewrite norm_opp; lra. by rewrite norm_opp; lra. - move => [Hfilter HInt]. eexists. apply: is_RInt_gen_swap. case: (proj2 (ex_RInt_gen_cauchy a f)). split. + case: Hfilter => Q R HQ HR Hex. apply: (Filter_prod). * exact: HR. * exact: HQ. * move => x y Rx Qy; apply: ex_RInt_swap; exact: Hex. + move => eps; case: (HInt eps) => Peps [HFPeps His_RInt]. exists Peps ;split => // . + move => x Hx. apply RInt_gen_correct. eexists. exact: Hx. Qed. Lemma at_right_le_at_point a b (Hab : a < b) : (filter_prod (at_right a) (at_point b) (fun x => x.1 <= x.2)). Proof. pose Q x := a < x < b. pose R x := x = b. apply: (Filter_prod _ _ _ Q R) => // . rewrite /at_right /within /locally. pose epsilon := (b - a). have Hepspos : 0 < epsilon by rewrite /epsilon; lra. pose eps := mkposreal epsilon Hepspos. exists (pos_div_2 eps) => y. by move/ball_to_lra; rewrite /Q; rewrite /= /epsilon; lra. move => x y . rewrite /Q /R /=. lra. Qed. Lemma RInt_gen_pos (* {V : CompleteNormedModule R_AbsRing} *) {Fa : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {Fb : (R -> Prop) -> Prop} {FFb : ProperFilter Fb} (P Q : R -> Prop) (f : R -> R) (If : R) : (Fa P) -> (Fb Q) -> (forall x y z, P x -> Q y -> x <= z <= y -> 0 <= f z) -> filter_prod Fa Fb (fun ab : R * R => ab.1 <= ab.2) -> is_RInt_gen f Fa Fb If -> 0 <= If. Proof. move => HFa HFb Hfx Hle Hint. have -> : 0 = norm 0 by rewrite norm_zero. apply: (RInt_gen_norm (fun _ => 0) f 0 If _ _ _ Hint) => // . apply: (Filter_prod _ _ _ P Q HFa HFb) => x y HPx HQy x0 /= Hx0. rewrite norm_zero; apply: (Hfx _ _ _ HPx HQy) => // . exact: is_RInt_gen_0. Qed. Lemma RInt_gen_neg (* {V : CompleteNormedModule R_AbsRing} *) {Fa : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {Fb : (R -> Prop) -> Prop} {FFb : ProperFilter Fb} (P Q : R -> Prop) (f : R -> R) (If : R) : (Fa P) -> (Fb Q) -> (forall x y z, P x -> Q y -> x <= z <= y -> f z <= 0) -> filter_prod Fa Fb (fun ab : R * R => ab.1 <= ab.2) -> is_RInt_gen f Fa Fb If -> If <= 0. Proof. move => HFa HFb Hfx Hle Hint. (* have -> : 0 = norm 0 by rewrite norm_zero. *) apply is_RInt_gen_opp in Hint. suff: 0 <= opp If. by rewrite /opp /=; lra. apply: (@RInt_gen_pos Fa FFa Fb FFb P Q (fun x => opp (f x)) (opp If)) => // . move => x y z HPx HQy Hxzy; move: (Hfx x y z HPx HQy Hxzy). by rewrite /opp /=; lra. Qed. End Missing. Module IntegralTactic (I : IntervalOps). Module J := IntervalExt I. (* this can probably be significantly shortened *) Lemma bounded_ex {xi} (Hne : not_empty (I.convert xi)) (Hbnded : I.bounded xi) : (exists l u : R, I.convert xi = Ibnd (Xreal l) (Xreal u)). Proof. exists (proj_val (I.F.convert (I.lower xi))). exists (proj_val (I.F.convert (I.upper xi))). have := (I.bounded_correct xi). rewrite Hbnded; case => // . move => Hlb Hub. case: (I.lower_bounded_correct xi Hlb) => <- => /= HbndedProp. case: (I.upper_bounded_correct xi Hub) => <-. by rewrite /I.bounded_prop; apply. Qed. Lemma at_right_open_interval a lb : (lb < a) -> at_right lb (fun x : R => lb < x < a). Proof. move => Hlba. rewrite /at_right /within /locally. pose epsilon := (a - lb). have Hepspos : 0 < epsilon by rewrite /epsilon; lra. pose eps := mkposreal epsilon Hepspos. exists (pos_div_2 eps) => y. by move/ball_to_lra; rewrite /= /epsilon; lra. Qed. Lemma at_right_semi_open_interval a lb : (lb < a) -> at_right lb (fun x : R => lb < x <= a). Proof. move => Hlba. rewrite /at_right /within /locally. pose epsilon := (a - lb). have Hepspos : 0 < epsilon by rewrite /epsilon; lra. pose eps := mkposreal epsilon Hepspos. exists (pos_div_2 eps) => y. by move/ball_to_lra; rewrite /= /epsilon; lra. Qed. Definition constant_sign (S : R -> Prop) (f : R -> R) := (forall x, S x -> 0 <= f x) \/ (forall x, S x -> f x <= 0). Lemma is_RInt_le_0 : forall (f : R -> R) (a b If : R), a <= b -> is_RInt f a b If -> (forall x : R, a < x < b -> f x <= 0) -> If <= 0. Proof. move => f a b If leab fint fneg. suff: (0 <= -If) by lra. apply: (is_RInt_ge_0 (fun x => - (f x)) a b _ leab). exact: is_RInt_opp. by move => x Hx; move: (fneg x Hx); lra. Qed. Lemma is_RInt_const_sign (f : R -> R) (If : R) a b (le_ab : a <= b) : constant_sign (fun x => Rmin a b <= x <= Rmax a b) f -> is_RInt f a b If -> is_RInt (fun x => Rabs (f x)) a b (Rabs If). Proof. move => cst_sgn fint. case: cst_sgn => [f_pos|f_neg]. - have Habs : forall x , Rmin a b < x < Rmax a b -> f x = Rabs (f x). by move => x Hx; rewrite Rabs_pos_eq //; apply: f_pos; lra. apply: (is_RInt_ext f _ _ _ _ Habs). rewrite Rabs_pos_eq // . apply: (is_RInt_ge_0 f a b If le_ab fint). by move => x Hx; apply: f_pos; rewrite Rmin_left ?Rmax_right; lra. - have Habs : forall x , Rmin a b < x < Rmax a b -> - (f x) = Rabs (f x). by move => x Hx; rewrite Rabs_left1 //; apply: f_neg; lra. apply: (is_RInt_ext _ _ _ _ _ Habs). rewrite Rabs_left1. apply: is_RInt_opp => // . apply: (is_RInt_le_0 _ a b _ le_ab) => // . exact: fint. move => x Hx. apply: f_neg. rewrite Rmin_left ?Rmax_right; lra. Qed. Lemma integral_interval_mul_sing : forall prec sing a ia f fi g Ig Igi, (sing < a) -> contains (I.convert ia) (Xreal a) -> (forall x, sing <= x <= a -> contains (I.convert fi) (Xreal (f x))) -> I.bounded fi -> (forall x, sing <= x <= a -> continuous f x) -> (forall x, sing < x <= a -> continuous g x) -> constant_sign (fun x => sing < x <= a) g -> is_RInt_gen g (at_right sing) (at_point a) Ig -> contains (I.convert Igi) (Xreal Ig) -> exists Ifg, is_RInt_gen (fun t => f t * g t) (at_right sing) (at_point a) Ifg /\ contains (I.convert (I.mul prec fi Igi)) (Xreal Ifg). Proof. move => prec sing a ia f fi g Ig Igi H0a Hia Hf Hfi Cf Cg Hg HIg HIg'. have Hnefi : not_empty (I.convert fi). { now exists (f sing); apply Hf; split; [right|left]. } move: (bounded_ex Hnefi Hfi) => [] l [] u HiFia. have Hgoodorder_bis : forall x, sing <= x <= a -> l <= f x <= u. move => x0 Hax0. move: (Hf _ Hax0). by rewrite HiFia. suff [Ifg HIfg]: ex_RInt_gen (fun t => f t * g t) (at_right sing) (at_point a). exists Ifg. have HIntl : is_RInt_gen (fun x => scal l (g x)) (at_right sing) (at_point a) (scal l Ig). exact: is_RInt_gen_scal. have HIntu : is_RInt_gen (fun x => scal u (g x)) (at_right sing) (at_point a) (scal u Ig). exact: is_RInt_gen_scal. have Hgoodorder : l <= u. by case: (Hgoodorder_bis a); try lra. apply: (conj HIfg). case: Hg => [Hg|Hg]; last first. apply: (contains_connected _ (scal u Ig) (scal l Ig)). + apply: J.mul_correct => // . rewrite HiFia. exact: (conj _ (Rle_refl _)). + apply: J.mul_correct => // . rewrite HiFia. exact: (conj (Rle_refl _)). split. apply: (@RInt_gen_le (at_right sing) (at_point a) _ _ (fun x => scal u (g x)) (fun x => scal (f x) (g x)) _ _) => // . exact: at_right_le_at_point. apply: (filter_prod_at_point_l a (fun x y => forall z, x <= z <= y -> _ <= _) (fun z => sing < z < a)). exact: at_right_open_interval. by move => y Hy z Hz; apply: Rmult_le_compat_neg_r; case: (Hg z) (Hgoodorder_bis z); lra. apply: (@RInt_gen_le (at_right sing) (at_point a) _ _ (fun x => scal (f x) (g x)) (fun x => scal l (g x)) _ _) => // . exact: at_right_le_at_point. apply: (filter_prod_at_point_l a (fun x y => forall z, x <= z <= y -> _ <= _) (fun z => sing < z < a)). exact: at_right_open_interval. by move => y Hy z Hz; apply: Rmult_le_compat_neg_r; case: (Hg z) (Hgoodorder_bis z); lra. (* second case: 0 <= g x *) apply: (contains_connected _ (scal l Ig) (scal u Ig)). + apply: J.mul_correct => // . rewrite HiFia. exact: (conj (Rle_refl _)). + apply: J.mul_correct => // . rewrite HiFia. exact: (conj _ (Rle_refl _)). split. apply: (@RInt_gen_le (at_right sing) (at_point a) _ _ (fun x => scal l (g x)) (fun x => scal (f x) (g x)) _ _) => // . exact: at_right_le_at_point. apply: (filter_prod_at_point_l a (fun x y => forall z, x <= z <= y -> _ <= _) (fun z => sing < z < a)). exact: at_right_open_interval. by move => y Hy z Hz; apply: Rmult_le_compat_r; case: (Hg z) (Hgoodorder_bis z); lra. apply: (@RInt_gen_le (at_right sing) (at_point a) _ _ (fun x => scal (f x) (g x)) (fun x => scal u (g x)) _ _) => // . exact: at_right_le_at_point. apply: (filter_prod_at_point_l a (fun x y => forall z, x <= z <= y -> _ <= _) (fun z => sing < z < a)). exact: at_right_open_interval. by move => y Hy z Hz; apply: Rmult_le_compat_r; case: (Hg z) (Hgoodorder_bis z); lra. refine (proj2 (ex_RInt_gen_cauchy_left _ _) _). split. - apply: filter_prod_at_point_l; first exact: (at_right_open_interval a). move => y Hxay; apply: ex_RInt_continuous => z Hz. rewrite Rmin_left in Hz; last by lra. rewrite Rmax_right in Hz; last by lra. apply: continuous_mult. by apply: Cf; lra. by apply: Cg; lra. - move => eps. set eps1 := eps / (1 + Rmax (Rabs l) (Rabs u)). have Hmaxpos : 1 + Rmax (Rabs l) (Rabs u) > 0. by rewrite /Rmax; case: Rle_dec; move: (Rabs_pos u) (Rabs_pos l); lra. have eps1_pos : 0 < eps1. by apply: RIneq.Rdiv_lt_0_compat => // ; first apply: cond_pos eps. set pos_eps1 := mkposreal eps1 eps1_pos. case: (proj1 (ex_RInt_gen_cauchy_left _ _) (ex_intro _ _ HIg)) => Hexg Heps. case: (Heps (pos_eps1)) => Peps1 [HPinf HPint]. have HPge : at_right sing (fun x => sing < x < a). exact: at_right_open_interval. assert(Hand := filter_and _ _ (at_point_filter_prod_l _ _ Hexg) HPinf). assert(Hand1 := filter_and _ _ Hand HPge). eexists; split. exact: Hand1. move => u0 v0 [[Hu1 Hu2] Hule] [[Hv1 Hv2] Hvle] I HisInt. wlog : I u0 v0 Hv1 Hv2 Hvle HisInt Hu1 Hu2 Hule / (u0 <= v0). move => Hwlog. case: (Rle_dec v0 u0) => Huv; last first. by apply: (Hwlog _ u0 v0 Hv1) => // ; lra. rewrite -norm_opp. apply: (Hwlog (opp I) v0 u0) => // . exact: is_RInt_swap. move => Hu0v0. have [Ig' HIg'']: ex_RInt g u0 v0. apply: ex_RInt_Chasles. exact: Hu1. exact: ex_RInt_swap. move: (HPint u0 v0 Hu2 Hv2 Ig' HIg'') => {} HPint. suff Hineq: norm I <= (1 + Rmax (Rabs l) (Rabs u)) * norm Ig'. apply: Rle_trans Hineq _. rewrite /pos_eps1 /eps1 /= in HPint. have ->: eps = (1 + Rmax (Rabs l) (Rabs u)) * (eps / (1 + Rmax (Rabs l) (Rabs u))) :> R . by field; lra. by apply: Rmult_le_compat_l HPint; lra. apply: norm_RInt_le HisInt _; first lra. move => x Hx. 2: { apply: is_RInt_scal. apply: (is_RInt_const_sign g) => // . case: Hg => [gpos | gneg]; [left|right] => x Hx. by apply: gpos; move: Hx; rewrite Rmin_left ?Rmax_right; lra. by apply: gneg; move: Hx; rewrite Rmin_left ?Rmax_right; lra. } rewrite /=. eapply Rle_trans. exact: norm_scal. rewrite /norm /= /abs /= . apply: Rmult_le_compat_r; first exact: Rabs_pos. have Hax : sing <= x <= a by lra. suff: Rabs (f x) <= Rmax (Rabs l) (Rabs u) by lra. by apply: RmaxAbs; move: (Hgoodorder_bis x Hax) ;lra. Qed. Lemma integral_interval_mul_zero : forall prec a ia f fi g Ig Igi, (0 < a) -> contains (I.convert ia) (Xreal a) -> (forall x, 0 <= x <= a -> contains (I.convert fi) (Xreal (f x))) -> I.bounded fi -> (forall x, 0 <= x <= a -> continuous f x) -> (forall x, 0 < x <= a -> continuous g x) -> constant_sign (fun x => 0 < x <= a) g -> is_RInt_gen g (at_right 0) (at_point a) Ig -> contains (I.convert Igi) (Xreal Ig) -> exists Ifg, is_RInt_gen (fun t => f t * g t) (at_right 0) (at_point a) Ifg /\ contains (I.convert (I.mul prec fi Igi)) (Xreal Ifg). Proof. move => prec a ia f fi g Ig Igi H0a Hia Hf Hfi Cf Cg Hg HIg HIg'. apply: (integral_interval_mul_sing) => // ; last exact: HIg'; last exact: HIg. exact: Hia. Qed. Lemma integral_interval_mul_infty : forall prec a ia f fi g Ig Igi, contains (I.convert ia) (Xreal a) -> (forall x, a <= x -> contains (I.convert fi) (Xreal (f x))) -> I.bounded fi -> (forall x, a <= x -> continuous f x) -> (forall x, a <= x -> continuous g x) -> (forall x, a <= x -> 0 <= g x) -> is_RInt_gen g (at_point a) (Rbar_locally p_infty) Ig -> contains (I.convert Igi) (Xreal Ig) -> exists Ifg, is_RInt_gen (fun t => f t * g t) (at_point a) (Rbar_locally p_infty) Ifg /\ contains (I.convert (I.mul prec fi Igi)) (Xreal Ifg). Proof. move => prec a ia f fi g Ig Igi Hia Hf Hfi Cf Cg Hg HIg HIg'. have Hnefi : not_empty (I.convert fi). { now exists (f a); apply Hf; right. } move: (bounded_ex Hnefi Hfi) => [] l [] u HiFia. have Hgoodorder_bis : forall x, a <= x -> l <= f x <= u. move => x0 Hax0. move: (Hf _ Hax0). by rewrite HiFia. suff [Ifg HIfg]: ex_RInt_gen (fun t => f t * g t) (at_point a) (Rbar_locally p_infty). exists Ifg. have HIntl : is_RInt_gen (fun x => scal l (g x)) (at_point a) (Rbar_locally p_infty) (scal l Ig). by apply: is_RInt_gen_scal. have HIntu : is_RInt_gen (fun x => scal u (g x)) (at_point a) (Rbar_locally p_infty) (scal u Ig). by apply: is_RInt_gen_scal. have Hgoodorder : l <= u. move: (Hgoodorder_bis a (Rle_refl a)). move => [H1 H2]. exact: Rle_trans H1 H2. have intgpos : 0 <= Ig. apply: (@RInt_gen_pos (at_point a) _ (Rbar_locally p_infty) _ (fun x => x = a) (fun y => y > a) g) => // . by rewrite /= ; exists a => x; lra. by move => x y z Hxa Hya Hxz; apply: Hg; lra. now apply filter_prod_at_point_infty. apply: (conj HIfg). apply: (contains_connected _ (scal l Ig) (scal u Ig)). + apply: J.mul_correct => // . rewrite HiFia. exact: (conj (Rle_refl _)). + apply: J.mul_correct => // . rewrite HiFia. exact: conj (Rle_refl _). split. apply: (@RInt_gen_le (at_point a) (Rbar_locally p_infty) _ _ (fun x => scal l (g x)) (fun x => scal (f x) (g x)) _ _) => // . now apply filter_prod_at_point_infty. (* now and by behave differently here *) apply (filter_prod_at_point_infty a (fun x y => forall z, x <= z <= y -> _ <= _)). move => m n [Hm _] o [Ho _]. rewrite /scal /= /mult /= . apply: Rmult_le_compat_r => // . apply Hg. now apply Rle_trans with m. apply Hgoodorder_bis. now apply Rle_trans with m. apply: (@RInt_gen_le (at_point a) (Rbar_locally p_infty) _ _ (fun x => scal (f x) (g x)) (fun x => scal u (g x)) _ _) => // . now apply filter_prod_at_point_infty. apply (filter_prod_at_point_infty a (fun x y => forall z, x <= z <= y -> _ <= _)). move => m n [Hm _] o [Ho _]. rewrite /scal /= /mult /= . apply: Rmult_le_compat_r => // . apply Hg. now apply Rle_trans with m. apply Hgoodorder_bis. now apply Rle_trans with m. refine (proj2 (ex_RInt_gen_cauchy _ _) _). split. - apply: filter_prod_at_point_infty. move => x y Hxay; apply: ex_RInt_continuous => z Hz. rewrite Rmin_left in Hz; last by lra. rewrite Rmax_right in Hz; last by lra. apply: continuous_mult. by apply: Cf; lra. by apply: Cg; lra. - move => eps. set eps1 := eps / (1 + Rmax (Rabs l) (Rabs u)). have Hmaxpos : 1 + Rmax (Rabs l) (Rabs u) > 0. by rewrite /Rmax; case: Rle_dec; move: (Rabs_pos u) (Rabs_pos l); lra. have eps1_pos : 0 < eps1. by apply: RIneq.Rdiv_lt_0_compat => // ; first apply: cond_pos eps. set pos_eps1 := mkposreal eps1 eps1_pos. case: (proj1 (ex_RInt_gen_cauchy _ _) (ex_intro _ _ HIg)) => Hexg Heps. case: (Heps (pos_eps1)) => Peps1 [HPinf HPint]. have HPge : Rbar_locally p_infty (fun x => a <= x). by exists a => x; lra. assert(Hand := filter_and _ _ (at_point_filter_prod _ _ Hexg) HPinf). assert(Hand1 := filter_and _ _ Hand HPge). eexists; split. exact: Hand1. move => u0 v0 [[Hu1 Hu2] Hule] [[Hv1 Hv2] Hvle] I HisInt. wlog : I u0 v0 Hv1 Hv2 Hvle HisInt Hu1 Hu2 Hule / (u0 <= v0). move => Hwlog. case: (Rle_dec v0 u0) => Huv; last first. by apply: (Hwlog _ u0 v0 Hv1) => // ; lra. rewrite -norm_opp. apply: (Hwlog (opp I) v0 u0) => // . exact: is_RInt_swap. move => Hu0v0. have [Ig' HIg'']: ex_RInt g u0 v0. apply: ex_RInt_Chasles Hv1. exact: ex_RInt_swap. have Ig'pos : 0 <= Ig'. apply: (is_RInt_le (fun _ => zero) g) Hu0v0 _ HIg'' _. have -> : 0 = scal (v0 - u0) zero by rewrite scal_zero_r. by apply: is_RInt_const. by move => x Hx; apply: Hg; lra. move: (HPint u0 v0 Hu2 Hv2 Ig' HIg'') => {} HPint. suff Hineq: norm I <= (1 + Rmax (Rabs l) (Rabs u)) * norm Ig'. apply: Rle_trans Hineq _. rewrite /pos_eps1 /eps1 /= in HPint. have ->: eps = (1 + Rmax (Rabs l) (Rabs u)) * (eps / (1 + Rmax (Rabs l) (Rabs u))) :> R . by field; lra. by apply: Rmult_le_compat_l HPint; lra. apply: norm_RInt_le HisInt _; first lra. move => x Hx. 2: { apply: is_RInt_scal. suff -> : norm Ig' = Ig'. exact: HIg''. by rewrite /norm /= /abs /=; rewrite Rabs_right //; lra. } rewrite /=. eapply Rle_trans. exact: norm_scal. rewrite /norm /= /abs /= . rewrite (Rabs_pos_eq (g x)). apply: Rmult_le_compat_r; first by (apply: Hg; lra). have Hax : a <= x by lra. suff: Rabs (f x) <= Rmax (Rabs l) (Rabs u) by lra. by apply: RmaxAbs; move: (Hgoodorder_bis x Hax) ;lra. by apply: Hg; lra. Qed. End IntegralTactic. Module IntegralTaylor (I : IntervalOps). Module J := IntervalExt I. Module TM := TM I. Section DepthZeroPol. (* A fixed precision *) Variable prec : I.precision. Variables (f : R -> R) (iF : I.type -> I.type). Hypothesis HiFIntExt : forall xi x, contains (I.convert xi) (Xreal x) -> contains (I.convert (iF xi)) (Xreal (f x)). Variable Mf : TM.TMI.rpa. Variables X : I.type. Let x0 := proj_val (I.F.convert (I.midpoint X)). Let X0 := J.midpoint X. Let iX := I.convert X. Let iX0 := I.convert X0. Hypothesis validMf : TM.TMI.i_validTM x0 iX Mf (fun x => Xreal (f x)). Variables (a b : R). (* f is integrable on [a, b]*) Hypothesis Hintegrable : ex_RInt f a b. Variables ia ib : I.type. Hypothesis Hconta : contains (I.convert ia) (Xreal a). Hypothesis Hcontb : contains (I.convert ib) (Xreal b). Hypothesis Hcontxa : contains iX (Xreal a). Hypothesis Hcontxb : contains iX (Xreal b). Definition taylor_integral := TM.TMI.integralEnclosure prec X0 Mf ia ib. (* now we take the intersection of a naive and intelligent way of computing the integral *) Definition taylor_integral_naive_intersection := let temp := I.mul prec (I.sub prec ib ia) (iF (I.join ia ib)) in if I.real temp then I.meet temp taylor_integral else temp. Lemma taylor_integral_correct : contains (I.convert taylor_integral) (Xreal (RInt f a b)). Proof. rewrite /taylor_integral. apply: (@TM.TMI.integralEnclosure_correct prec X0 X (fun x => Xreal (f x)) Mf (proj_val (I.F.convert (I.midpoint X)))) => //. apply J.contains_midpoint. now exists a. Qed. Lemma taylor_integral_naive_intersection_correct : contains (I.convert taylor_integral_naive_intersection) (Xreal (RInt f a b)). Proof. rewrite /taylor_integral_naive_intersection. set tmp := I.mul prec (I.sub prec ib ia) (iF (I.join ia ib)). generalize (I.real_correct tmp). case I.real ; intros Hr. 2: now destruct (I.convert tmp). apply I.meet_correct. apply J.contains_RInt => //. intros x Hx. apply HiFIntExt. assert (H := I.join_correct ia ib). apply: contains_connected Hx. apply H. now apply Rmin_case ; [left|right]. apply H. now apply Rmax_case ; [left|right]. exact: taylor_integral_correct. Qed. End DepthZeroPol. End IntegralTaylor. interval-4.11.1/src/Integral/Priority.v000066400000000000000000000365571470547631300200200ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2019, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import List Arith ZArith Psatz. From mathcomp.ssreflect Require Import ssrfun ssrbool fintype. Section Permut. Context {T : Type}. Fixpoint onth n (l : list T) := match l, n with | nil, _ => None | v :: _, O => Some v | _ :: l, S n => onth n l end. Lemma onth_nth : forall n p d, n < length p -> onth n p = Some (nth n p d). Proof. induction n as [|n IH] ; intros [|h p] d Hl ; try easy. simpl. apply IH. now rewrite Nat.succ_lt_mono. Qed. Lemma onth_rev : forall n p, n < length p -> onth n (rev p) = onth (length p - S n) p. Proof. intros n [|h p]. easy. intros H. rewrite 2!onth_nth with (d := h). now rewrite rev_nth with (1 := H). lia. now rewrite rev_length. Qed. Lemma onth_app_l : forall n p q, n < length p -> onth n (p ++ q) = onth n p. Proof. intros n p q. revert n. induction p as [|v p IH]. easy. intros [|n] ; simpl. easy. intros H. rewrite <-Nat.succ_lt_mono in H. now apply IH. Qed. Lemma onth_app_r : forall n p q, length p <= n -> onth n (p ++ q) = onth (n - length p) q. Proof. intros n p q. revert n. induction p as [|v p IH]. intros n _. now rewrite Nat.sub_0_r. intros [|n] ; simpl. easy. intros H. apply le_S_n in H. now apply IH. Qed. Lemma onth_insert : forall n v p, onth n p = Some v -> exists q r, p = q ++ v :: r. Proof. intros n v p Hp. set (f := fix aux n (q : list T) := match n, q with | O, _ => nil | S n, nil => nil | S n, h :: t => h :: aux n t end). set (g := fix aux n (q : list T) := match q, n with | nil, _ => nil | h :: t, O => t | h :: t, S n => aux n t end). exists (f n p), (g n p). revert p Hp. induction n as [|n IH] ; simpl ; intros [|h p] Hp ; try easy ; clearbody f g. now injection Hp as ->. simpl. apply f_equal. now apply IH. Qed. Fixpoint all P (l : list T) := match l with | nil => True | h :: t => P h /\ all P t end. Inductive permut (p q : list T) : Prop := | Permut (Hl : length p = length q) (f : ordinal (length p) -> ordinal (length p)) (Hf : injective f) (Hpq : forall n : ordinal _, onth n p = onth (f n) q). Lemma permut_refl : forall p, permut p p. Proof. intros p. now apply Permut with (f := fun n => n). Qed. Lemma permut_sym : forall p q, permut p q -> permut q p. Proof. intros p q [Hl f Hf Hpq]. revert f Hf Hpq. rewrite Hl. intros f Hf Hpq. apply Permut with (f := invF Hf). now apply eq_sym. apply can_inj with (g := f). apply f_invF. intros n. rewrite <- (f_invF Hf n) at 1. apply eq_sym, Hpq. Qed. Lemma permut_trans : forall q p r, permut p q -> permut q r -> permut p r. Proof. intros q p r [Hl1 f1 Hf1 Hpq] [Hl2 f2 Hf2 Hqr]. revert f1 Hf1 Hpq f2 Hf2 Hqr. rewrite <- Hl1. intros f1 Hf1 Hpq f2 Hf2 Hqr. apply Permut with (f := fun k => f2 (f1 k)). now apply eq_trans with (length q). now apply inj_comp. intros n. now rewrite <- Hqr. Qed. Lemma permut_rev : forall p, permut (rev p) p. Proof. intros p. apply Permut with (f := fun x => rev_ord x). apply rev_length. apply rev_ord_inj. intros n. simpl. rewrite <- ssrnat.minusE. rewrite rev_length at 2. apply onth_rev. eapply elimT. now apply ssrnat.ltP. now rewrite <- (rev_length p). Qed. Lemma injective_split : forall n n1 n2 n3 n4 (H1 : n = n1 + n2) (H2 : n3 + n4 = n) f, injective f -> injective (fun k : ordinal n => cast_ord H2 (unsplit (f (split (cast_ord H1 k))))). Proof. intros n n1 n2 n3 n4 H1 H2 f Hf. apply inj_comp with (f := cast_ord H2). apply cast_ord_inj. apply inj_comp with (f := @unsplit _ _). eapply can_inj. apply unsplitK. apply inj_comp with (1 := Hf). apply inj_comp with (f := @split _ _). eapply can_inj. apply splitK. apply cast_ord_inj. Qed. Lemma permut_app_l : forall p q r, permut q r -> permut (p ++ q) (p ++ r). Proof. intros p q r [Hl f Hf H1]. assert (H2: length (p ++ q) = length p + length q). apply app_length. simple refine (Permut _ _ _ _ _ _). - rewrite 2!app_length. now apply f_equal. - intros k. apply (cast_ord (esym H2)). apply unsplit. destruct (split (cast_ord H2 k)) as [k'|k']. now left. right. now apply f. - apply injective_split with (f := fun k => match k with inl k' => inl k' | inr k' => inr (f k') end). clear -Hf. intros [k1|k1] [k2|k2] ; try easy. intros H. apply f_equal. injection H. apply Hf. - simpl. intros n. case splitP ; simpl ; change ssrnat.addn with plus ; intros k ->. assert (Hk: k < length p). eapply elimT. now apply ssrnat.ltP. easy. now rewrite 2!onth_app_l. rewrite 2!onth_app_r by lia. rewrite !(Nat.add_comm (length p)), !Nat.add_sub. apply H1. Qed. Lemma permut_app : forall p q, permut (p ++ q) (q ++ p). Proof. intros l1 l2. assert (H1: length l2 + length l1 = length (l1 ++ l2)). rewrite app_length. apply Nat.add_comm. assert (H2: length (l1 ++ l2) = length l1 + length l2). apply app_length. simple refine (Permut _ _ _ _ _ _). - rewrite 2!app_length. apply Nat.add_comm. - intros k. apply (cast_ord H1). apply unsplit. destruct (split (cast_ord H2 k)) as [k'|k']. now right. now left. - apply injective_split with (f := fun k => match k with inl k' => inr k' | inr k' => inl k' end). clear. intros [k1|k1] [k2|k2] ; try easy ; intros H ; injection H ; apply f_equal. - simpl. intros n. case splitP ; simpl ; change ssrnat.addn with plus ; intros k Hk. rewrite onth_app_l. rewrite onth_app_r by lia. rewrite Nat.add_comm, Nat.add_sub. now rewrite <- Hk. eapply elimT. now apply ssrnat.ltP. now rewrite Hk. rewrite onth_app_r by lia. rewrite onth_app_l. now rewrite Hk, Nat.add_comm, Nat.add_sub. cut (n < length l1 + length l2). lia. eapply elimT. apply ssrnat.ltP. now rewrite <- app_length. Qed. Lemma permut_app_r : forall p q r, permut p r -> permut (p ++ q) (r ++ q). Proof. intros p q r H. apply permut_trans with (q ++ r). apply permut_trans with (q ++ p). apply permut_app. now apply permut_app_l. apply permut_app. Qed. Lemma permut_cons : forall h p q, permut p q -> permut (h :: p) (h :: q). Proof. intros h p q. apply (permut_app_l (h :: nil)). Qed. Lemma permut_cons_rev : forall h p q, permut (h :: p) (h :: q) -> permut p q. Proof. intros h p q [Hl f Hf Hpq]. assert (H2: length (h :: p) = 1 + length p). easy. simple refine (Permut _ _ _ _ _ _). - now injection Hl. - intros k. destruct (split (cast_ord H2 (f (rshift 1 k)))) as [_|k']. destruct (split (cast_ord H2 (f (@ord0 (length p))))) as [_|k']. apply k. apply k'. apply k'. - set (g := fun (k : ordinal (length p)) => match split (cast_ord H2 (invF Hf (rshift 1 k))) with | inl _ => match split (cast_ord H2 (invF Hf (@ord0 (length p)))) with | inl _ => k | inr k' => k' end | inr k' => k' end). apply (@can_inj _ _ _ g). intros k. unfold g. clear g. destruct (splitP (cast_ord H2 (f (rshift 1 k)))) as [k1 Hk1|k1 Hk1]. + replace (nat_of_ord k1) with O in Hk1 by now destruct k1 as [[|k1] H]. destruct (splitP (cast_ord H2 (f (@ord0 (length p))))) as [k2 Hk2|k2 Hk2]. replace (nat_of_ord k2) with O in Hk2 by now destruct k2 as [[|k2] H]. exfalso. rewrite <- Hk2 in Hk1. apply ord_inj in Hk1. apply cast_ord_inj in Hk1. now apply Hf in Hk1. replace (invF Hf (rshift 1 k2)) with (@ord0 (length p)). destruct (splitP (cast_ord H2 (@ord0 (length p)))) as [k3 Hk3|k3 Hk3]. 2: easy. replace (invF Hf (@ord0 (length p))) with (rshift 1 k). destruct (splitP (cast_ord H2 (rshift 1 k))) as [k4 Hk4|k4 Hk4]. now destruct k4 as [[|k4] H]. apply ord_inj. now injection Hk4. apply Hf. rewrite f_invF. now apply ord_inj. apply Hf. rewrite f_invF. now apply ord_inj. + replace (invF Hf (rshift 1 k1)) with (rshift 1 k). destruct (splitP (cast_ord H2 (rshift 1 k))) as [k2 Hk2|k2 Hk2]. now destruct k2 as [[|k2] H]. apply ord_inj. now injection Hk2. apply Hf. rewrite f_invF. now apply ord_inj. - intros k. destruct (splitP (cast_ord H2 (f (rshift 1 k)))) as [k1 Hk1|k1 Hk1]. + replace (nat_of_ord k1) with O in Hk1 by now destruct k1 as [[|k1] H]. destruct (splitP (cast_ord H2 (f (@ord0 (length p))))) as [k2 Hk2|k2 Hk2]. replace (nat_of_ord k2) with O in Hk2 by now destruct k2 as [[|k2] H]. exfalso. rewrite <- Hk2 in Hk1. apply ord_inj in Hk1. apply cast_ord_inj in Hk1. now apply Hf in Hk1. destruct (splitP (cast_ord H2 (f (rshift 1 k)))) as [k3 Hk3|k3 Hk3]. 2: now rewrite Hk1 in Hk3. change (onth (rshift 1 k) (h :: p) = onth (ssrnat.addn 1 k2) (h :: q)). rewrite Hpq. simpl in Hk1, Hk2. simpl (length (h :: p)). rewrite Hk1, <- Hk2. now rewrite <- Hpq. + destruct (splitP (cast_ord H2 (f (rshift 1 k)))) as [k2 Hk2|k2 Hk2]. rewrite Hk1 in Hk2. now destruct k2 as [[|k2] H]. simpl. change (onth (rshift 1 k) (h :: p) = onth (ssrnat.addn 1 k2) (h :: q)). rewrite <- Hk2. apply Hpq. Qed. Lemma permut_insert : forall v p q, permut (v :: p ++ q) (p ++ v :: q). Proof. intros v p q. change (permut (((v :: nil) ++ p) ++ q) (p ++ (v :: nil) ++ q)). rewrite app_assoc. apply permut_app_r. apply permut_app. Qed. Lemma permut_remove : forall v p q, permut (v :: p) q -> exists s, exists t, q = s ++ v :: t /\ permut p (s ++ t). Proof. intros v p q H. destruct (H) as [Hl f Hf H']. specialize (H' (@ord0 (length p))). revert H'. generalize (nat_of_ord (f (@ord0 (length p)))). simpl. intros n. intros H'. clear -H H'. apply eq_sym in H'. destruct onth_insert with (1 := H') as [r [s Hq]]. exists r, s. apply (conj Hq). rewrite Hq in H. clear -H. apply permut_cons_rev with v. apply permut_trans with (1 := H). apply permut_sym, permut_insert. Qed. Lemma all_permut : forall P p q, all P p -> permut p q -> all P q. Proof. intros P p q. revert p. induction q as [|v q IH] ; intros p Hp Hpq. easy. assert (Hpv := Hpq). apply permut_sym, permut_remove in Hpv. destruct Hpv as [s [t [Hpv Hq]]]. apply permut_sym in Hq. cut (P v /\ all P (s ++ t)). intros [H1 H2]. apply (conj H1). now apply IH with (2 := Hq). rewrite Hpv in Hp. clear -Hp. induction s as [|h p IH]. exact Hp. destruct Hp as [H1 H2]. destruct (IH H2) as [H3 H4]. apply (conj H3). easy. Qed. Lemma fold_right_permut : forall {A} f (acc : A) p q, (forall u v w, f u (f v w) = f v (f u w)) -> permut p q -> fold_right f acc p = fold_right f acc q. Proof. intros A f acc p q Hf. revert acc q. induction p as [|h p IH] ; intros acc. intros [|q]. easy. intros [Hl _ _ _]. easy. intros q Hq. apply permut_remove in Hq. destruct Hq as [s [t [H1 H2]]]. simpl. rewrite IH with (1 := H2). rewrite H1. clear -Hf. induction s as [|k s IH]. easy. simpl. now rewrite <- IH. Qed. Lemma fold_left_permut : forall {A} f (acc : A) p q, (forall u v w, f (f u v) w = f (f u w) v) -> permut p q -> fold_left f p acc = fold_left f q acc. Proof. intros A f acc p q Hf Hpq. rewrite <- 2!fold_left_rev_right. apply fold_right_permut. now intros u v w. apply permut_trans with p. apply permut_rev. apply permut_trans with (1 := Hpq). apply permut_sym, permut_rev. Qed. End Permut. Section Pairing. Context {T : Type}. Inductive ptree := PTsome (v : T) (l : list ptree). Inductive pheap := PHnone | PHsome (t : ptree). Theorem ptree_ind' : forall P : ptree -> Prop, (forall v l, Forall P l -> P (PTsome v l)) -> forall t, P t. Proof. intros P H. fix IH 1. intros [v l]. apply H. induction l ; constructor. apply IH. apply IHl. Qed. Fixpoint ptree_to_list (p : ptree) : list T := match p with | PTsome v l => v :: flat_map ptree_to_list l end. Fixpoint pheap_to_list (p : pheap) : list T := match p with | PHnone => nil | PHsome p => ptree_to_list p end. Variable le : T -> T -> bool. Definition ptree_meld (p1 p2 : ptree) : ptree := match p1, p2 with | PTsome v1 l1, PTsome v2 l2 => if le v1 v2 then PTsome v1 (p2 :: l1) else PTsome v2 (p1 :: l2) end. Theorem ptree_meld_correct : forall p1 p2, permut (ptree_to_list (ptree_meld p1 p2)) (ptree_to_list p1 ++ ptree_to_list p2). Proof. intros [v1 l1] [v2 l2]. unfold ptree_meld. case le ; simpl. - apply permut_cons. apply (permut_app (v2 :: flat_map _ _)). - apply permut_insert with (p := v1 :: flat_map _ _). Qed. Definition ptree_insert (p : ptree) (v : T) := ptree_meld p (PTsome v nil). Theorem ptree_insert_correct : forall p v, permut (ptree_to_list (ptree_insert p v)) (v :: ptree_to_list p). Proof. intros [v1 l1] v. unfold ptree_insert. eapply permut_trans. apply ptree_meld_correct. apply (permut_app _ (v :: nil)). Qed. Definition pheap_insert (p : pheap) (v : T) : ptree := match p with | PHnone => PTsome v nil | PHsome p => ptree_insert p v end. Theorem pheap_insert_correct : forall p v, permut (ptree_to_list (pheap_insert p v)) (v :: pheap_to_list p). Proof. intros [|p] v. apply permut_refl. apply ptree_insert_correct. Qed. Fixpoint ptree_merge_pairs (p1 : ptree) (l : list ptree) : ptree := match l with | nil => p1 | p2 :: nil => ptree_meld p1 p2 | p2 :: p3 :: l' => ptree_meld (ptree_meld p1 p2) (ptree_merge_pairs p3 l') end. Lemma list_ind2 : forall A (P : list A -> Prop), P nil -> (forall v, P (v :: nil)) -> (forall v w l, P l -> P (v :: w :: l)) -> forall l, P l. Proof. intros A P H0 H1 H12. fix aux 1. intros [|v [|w l]]. easy. easy. apply H12. apply aux. Qed. Theorem ptree_merge_pairs_correct : forall p l, permut (ptree_to_list (ptree_merge_pairs p l)) (ptree_to_list p ++ flat_map ptree_to_list l). Proof. intros p l. revert p. induction l as [|v|v w l IH] using list_ind2 ; simpl ; intros p. rewrite app_nil_r. apply permut_refl. rewrite app_nil_r. apply ptree_meld_correct. eapply permut_trans. apply ptree_meld_correct. rewrite app_assoc. eapply permut_trans. apply permut_app_r. apply ptree_meld_correct. now apply permut_app_l. Qed. Definition ptree_pop (p : ptree) : T * pheap := match p with | PTsome v l => (v, match l with | nil => PHnone | lh :: lt => PHsome (ptree_merge_pairs lh lt) end) end. Theorem ptree_pop_correct : forall p, match ptree_pop p with | (v, q) => permut (v :: pheap_to_list q) (ptree_to_list p) end. Proof. intros [v [|l]]. apply permut_refl. simpl. apply permut_cons. apply ptree_merge_pairs_correct. Qed. Fixpoint ptree_fold {A} (f : A -> T -> A) (p : ptree) (acc : A) : A := match p with | PTsome v l => fold_left (fun acc q => ptree_fold f q acc) l (f acc v) end. Theorem ptree_fold_correct : forall A (f : A -> T -> A) acc p, ptree_fold f p acc = fold_left f (ptree_to_list p) acc. Proof. intros A f acc p. revert acc. induction p as [v l IH] using ptree_ind'. simpl. intros acc. generalize (f acc v). clear acc. induction IH as [|q l H1 _ H2] ; simpl ; intros acc. easy. rewrite fold_left_app. rewrite H2. now apply f_equal. Qed. End Pairing. Arguments ptree : clear implicits. Arguments pheap : clear implicits. interval-4.11.1/src/Integral/Refine.v000066400000000000000000000376641470547631300174070ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2019, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import BinPos Reals List. From Coquelicot Require Import Coquelicot. Require Import Xreal. Require Import Interval. Require Import Priority. Section IterUntil. (* iteratively call [step] on [v] until [done] is true or [n] calls have been made; [cache_step] is called every 2^k approximately to precompute some data for [done] *) Fixpoint iter_until {T} n (step : T -> T) (cache_step : T -> T) (done : T -> bool) v := match n with | xH => step v | xO n => let v := iter_until n step cache_step done v in if done v then v else let v := cache_step v in iter_until n step (fun x => x) done v | xI n => let v := step v in if done v then v else let v := iter_until n step cache_step done v in if done v then v else let v := cache_step v in iter_until n step (fun x => x) done v end. Theorem iter_until_correct : forall {T} (P : T -> Prop) n step slow_step done, (forall v : T, P v -> P (step v)) -> (forall v : T, P v -> P (slow_step v)) -> forall v : T, P v -> P (iter_until n step slow_step done v). Proof. intros T P n step slow_step done H Hs. revert slow_step Hs. induction n as [n IH|n IH|] ; intros slow_step Hs v Hv ; simpl. - case done. now apply H. apply H in Hv. apply IH with (1 := Hs) in Hv. case done. exact Hv. apply IH. easy. now apply Hs. - apply IH with (1 := Hs) in Hv. case done. exact Hv. apply IH. easy. now apply Hs. - now apply H. Qed. End IterUntil. Definition valid (f : R -> R) (uf vf : (R -> Prop) -> Prop) yi := (yi <> Inan -> ex_RInt_gen f uf vf) /\ contains yi (Xreal (RInt_gen f uf vf)). Lemma valid_Inan : forall f uf vf, valid f uf vf Inan. Proof. intros f uf vf. now split. Qed. Module IntegralRefiner (I : IntervalOps). Module J := IntervalExt I. Inductive integral_bound := IBu | IBv | IBp (x : I.F.type). Section Bounds. Variable uf vf : (R -> Prop) -> Prop. Context (Fuf : ProperFilter' uf) (Fvf : ProperFilter' vf). Definition convert b := match b with | IBu => uf | IBv => vf | IBp x => at_point (proj_val (I.F.convert x)) end. Local Instance filter_convert : forall b, ProperFilter' (convert b). Proof. intros [| |p] ; simpl ; try easy. apply Proper_StrongProper. apply at_point_filter. Qed. Definition valid f u v i := valid f (convert u) (convert v) (I.convert i). Inductive piece := Piece (u v : integral_bound) (i : I.type). Fixpoint invariant_aux h l (u : integral_bound) := match h with | Piece u' v i => u = u' /\ match l with | nil => v = IBv | h :: t => match v with IBp _ => invariant_aux h t v | _ => False end end end. Let exact_sum (f : R -> R) l := fold_right (fun r s => Rplus s match r with | Piece ur vr _ => RInt_gen f (convert ur) (convert vr) end) 0%R l. Definition invariant (f : R -> R) (p : ptree piece) := all (fun r => match r with Piece uf vf i => valid f uf vf i end) (ptree_to_list p) /\ exists qh, exists qt, permut (ptree_to_list p) (qh :: qt) /\ invariant_aux qh qt IBu. Definition sum prec (p : ptree piece) := ptree_fold (fun acc v => I.add prec acc match v with Piece _ _ i => i end) p I.zero. Theorem sum_invariant : forall prec p f, invariant f p -> valid f IBu IBv (sum prec p). Proof. intros prec p f. unfold sum, invariant, valid. rewrite ptree_fold_correct. generalize (ptree_to_list p). clear p. intros p. assert (H: (I.convert I.zero <> Inan -> all (fun r => match r with | Piece ur vr _ => ex_RInt_gen f (convert ur) (convert vr) end) nil) /\ contains (I.convert I.zero) (Xreal (exact_sum f nil))). simpl. apply (conj (fun _ => I)). rewrite I.zero_correct. split ; apply Rle_refl. change p with (nil ++ p) at 1 2. intros [Hp [qh [qt [Hq Iq]]]]. revert Hq Hp H. generalize (@nil piece) I.zero. induction p as [|h t IH] ; simpl ; intros l s Hq Hl [H1 H2]. - clear Hl. rewrite app_nil_r in Hq. unfold exact_sum in H2. rewrite fold_right_permut with (2 := Hq) in H2 by (intros ; ring). case_eq (I.convert s) ; [intros Hs | intros sl su Hs]. easy. cut (ex_RInt_gen f uf vf /\ RInt_gen f uf vf = exact_sum f (qh :: qt)). intros [H3 H4]. split. intros _. apply H3. rewrite H4. now rewrite <- Hs. assert (H1': all (fun r => match r with | Piece ur vr _ => ex_RInt_gen f (convert ur) (convert vr) end) (qh :: qt)). apply all_permut with (2 := Hq). apply H1. now rewrite Hs. clear -Iq H1' Fuf Fvf. revert qh Iq H1'. change uf with (convert IBu). generalize IBu. induction qt as [|qh qt IH] ; simpl. intros x [u v _] [-> ->] [H _]. apply (conj H). apply eq_sym, Rplus_0_l. intros x [u v _] [-> H6] [H1 H2]. destruct v as [| |x] ; try easy. destruct (IH _ _ H6 H2) as [H7 H8]. assert (H9 := ex_RInt_gen_Chasles _ _ H1 H7). assert (H5 := RInt_gen_Chasles _ _ H1 H7). clear IH H1 H2 H6 H7. apply (conj H9). simpl in H8. rewrite <- H5, <- H8. apply Rplus_comm. - eapply permut_trans in Hq. 2: apply permut_insert. destruct h as [ur' vr' i]. eapply all_permut in Hl. 2: apply permut_sym, permut_insert. apply (IH (_ :: l) (I.add prec s i) Hq Hl). destruct Hl as [H3 _]. clear -H1 H2 H3. split. intros H'. split. apply H3. contradict H'. now apply I.add_propagate_r. apply H1. contradict H'. now apply I.add_propagate_l. simpl. apply J.add_correct. apply H2. apply H3. Qed. Definition le_piece prec (p q : piece) := match p, q with | Piece _ _ pi, Piece _ _ qi => I.wider prec pi qi end. Definition split_piece prec midp fi sp := let le_piece := le_piece prec in match sp with | (s, p) => match ptree_pop le_piece p with | (Piece u v i, h) => let m := IBp (midp u v) in let i1 := fi u m in let i2 := fi m v in let p1 := Piece u m i1 in let p2 := Piece m v i2 in let s := I.add prec (I.cancel_add prec s i) (I.add prec i1 i2) in let p := ptree_insert le_piece (pheap_insert le_piece h p1) p2 in (s, p) end end. Theorem split_piece_correct : forall prec midp f fi p, (forall u v, valid f u v (fi u v)) -> invariant f (snd p) -> invariant f (snd (split_piece prec midp fi p)). Proof. intros prec midp f fi [sp p] Hfi [H1 [qh [qt [H2 H3]]]]. unfold split_piece. set (le_piece := le_piece prec). generalize (ptree_pop_correct le_piece p). destruct ptree_pop as [[u' v' i] p1]. intros H4. set (m := IBp (midp u' v')). generalize (pheap_insert_correct le_piece p1 (Piece u' m (fi u' m))). generalize (pheap_insert le_piece p1 (Piece u' m (fi u' m))). intros p2 H5. generalize (ptree_insert_correct le_piece p2 (Piece m v' (fi m v'))). generalize (ptree_insert le_piece p2 (Piece m v' (fi m v'))). intros p3 H6. unfold invariant. split. - apply permut_sym in H6. apply all_permut with (2 := H6). split. apply Hfi. apply permut_sym in H5. apply all_permut with (2 := H5). split. apply Hfi. clear -H1 H4. apply permut_sym in H4. eapply all_permut in H4. 2: apply H1. apply H4. - assert (H7 := permut_trans _ _ _ H4 H2). destruct (permut_remove _ _ _ H7) as [s [t [H8 H9]]]. assert (exists sh st, sh :: st = s ++ Piece u' m (fi u' m) :: nil) as [sh [st Ha]]. clear. destruct s as [|sh st]. now exists (Piece u' m (fi u' m)), nil. now exists sh, (st ++ Piece u' m (fi u' m) :: nil). exists sh, (st ++ Piece m v' (fi m v') :: t). split. change (sh :: st ++ _) with ((sh :: st) ++ Piece m v' (fi m v') :: t). rewrite Ha. apply permut_trans with (1 := H6). eapply permut_trans. 2: apply permut_insert. apply permut_cons. rewrite <- app_assoc. simpl. apply permut_trans with (1 := H5). eapply permut_trans. 2: apply permut_insert. now apply permut_cons. revert H3 H8 Ha. clear. generalize IBu. revert qh qt sh st. induction s as [|[u v i'] s IH] ; simpl ; intros qh qt sh st x H1 [= -> ->] [= -> ->]. simpl. destruct t as [|th tt]. now destruct H1. now destruct H1. destruct s as [|sh st]. destruct H1 as [H1 H2]. simpl. apply (conj H1). destruct v as [| |x'] ; try easy. destruct t as [|th tt]. now destruct H2. now destruct H2. destruct H1 as [H1 H2]. simpl. apply (conj H1). destruct v as [| |x'] ; try easy. now apply IH with (1 := H2). Qed. (* Definition bisect prec n midp fi (check : I.type -> bool) := let i := fi IBu IBv in if check i then (i, i, 0%Z, 0%Z) else let '(s, p, n1, n2) := iter_until n (fun '(p, n1, n2) => (split_piece prec midp fi p, Z.succ n1, n2)) (fun '(_, p, n1, n2) => (sum prec p, p, n1, Z.succ n2)) (fun '(p, _, _, _) => check p) (i, PTsome (Piece IBu IBv i) nil, 0%Z, 0%Z) in (s, sum prec p, n1, n2). *) Definition bisect prec n midp fi (check : I.type -> bool) := let i := fi IBu IBv in if check i then i else let p := iter_until n (split_piece prec midp fi) (fun '(_, p) => (sum prec p, p)) (fun '(p, _) => check p) (i, PTsome (Piece IBu IBv i) nil) in sum prec (snd p). Theorem bisect_correct : forall prec n midp f fi check, (forall u v, valid f u v (fi u v)) -> valid f IBu IBv (bisect prec n midp fi check). Proof. intros prec n midp f fi check Hfi. unfold bisect. destruct check. apply Hfi. apply sum_invariant. apply iter_until_correct. intros [v p]. now apply split_piece_correct. now intros [v p]. split ; simpl. now split. exists (Piece IBu IBv (fi IBu IBv)), nil. split. apply permut_refl. easy. Qed. End Bounds. Theorem contains_RInt_valid : forall f u v i, valid (at_point u) (at_point v) f IBu IBv i -> contains (I.convert i) (Xreal (RInt f u v)). Proof. intros f u v i [H1 H2]. destruct (I.convert i) as [|il iu]. easy. rewrite <- RInt_gen_at_point. exact H2. apply ex_RInt_gen_at_point. now apply H1. Qed. Theorem valid_at_point : forall f u v fi ui vi, contains (I.convert ui) (Xreal u) -> contains (I.convert vi) (Xreal v) -> (forall ui' vi' u' v', contains (I.convert ui') (Xreal u') -> contains (I.convert vi') (Xreal v') -> (I.convert (fi ui' vi') <> Inan -> ex_RInt f u' v') /\ contains (I.convert (fi ui' vi')) (Xreal (RInt f u' v'))) -> forall u' v', let cb := fun x => match x with IBu => ui | IBv => vi | IBp x => I.singleton x end in valid (at_point u) (at_point v) f u' v' (fi (cb u') (cb v')). Proof. intros f u v fi ui vi Hu Hv Hf u' v' cb. unfold valid. set (cb' p := match p with IBu => u | IBv => v | IBp x => proj_val (I.F.convert x) end). assert (H1: forall p, at_point (cb' p) = convert (at_point u) (at_point v) p). now intros [| |p]. assert (H2: forall p, contains (I.convert (cb p)) (Xreal (cb' p))). intros [| |p]. exact Hu. exact Hv. apply I.singleton_correct. rewrite <- 2!H1. destruct (Hf (cb u') (cb v') (cb' u') (cb' v') (H2 u') (H2 v')) as [H3 H4]. destruct (I.convert (fi (cb u') (cb v'))) as [|il iu] eqn:E. easy. split. intros _. apply <- (ex_RInt_gen_at_point f). now apply H3. rewrite RInt_gen_at_point. exact H4. now apply H3. Qed. Theorem valid_at_mixed : forall f u v (Fv: ProperFilter v) fi1 fi2 ui, contains (I.convert ui) (Xreal u) -> (forall ui' vi' u' v', contains (I.convert ui') (Xreal u') -> contains (I.convert vi') (Xreal v') -> (I.convert (fi1 ui' vi') <> Inan -> ex_RInt f u' v') /\ contains (I.convert (fi1 ui' vi')) (Xreal (RInt f u' v'))) -> (forall ui' u', contains (I.convert ui') (Xreal u') -> (I.convert (fi2 ui') <> Inan -> ex_RInt_gen f (at_point u') v) /\ contains (I.convert (fi2 ui')) (Xreal (RInt_gen f (at_point u') v))) -> forall u' v', valid (at_point u) v f u' v' (match u', v' with | IBu, IBp xu => fi1 ui (I.singleton xu) | IBp xl, IBp xu => fi1 (I.singleton xl) (I.singleton xu) | IBu, IBv => fi2 ui | IBp xl, IBv => fi2 (I.singleton xl) | _, _ => I.nai end). Proof. intros f u v Fv fi1 fi2 ui Hu Hf1 Hf2 u' v'. unfold valid. destruct u' as [| |ur] ; destruct v' as [| |vr] ; try (rewrite I.nai_correct ; apply valid_Inan). - now apply Hf2. - destruct (Hf1 ui _ u _ Hu (I.singleton_correct vr)) as [H2 H3]. destruct (I.convert (fi1 ui (I.singleton vr))) as [|il iu] eqn:E. easy. split. intros _. apply <- (ex_RInt_gen_at_point f). now apply H2. simpl convert. rewrite RInt_gen_at_point. apply H3. now apply H2. - destruct (Hf2 _ _ (I.singleton_correct ur)) as [H2 H3]. destruct (I.convert (fi2 (I.singleton ur))) as [|il iu] eqn:E. easy. split. intros _. now apply H2. apply H3. - destruct (Hf1 _ _ _ _ (I.singleton_correct ur) (I.singleton_correct vr)) as [H2 H3]. destruct (I.convert (fi1 (I.singleton ur) (I.singleton vr))) as [|il iu] eqn:E. easy. split. intros _. apply <- (ex_RInt_gen_at_point f). now apply H2. simpl convert. rewrite RInt_gen_at_point. apply H3. now apply H2. Qed. Theorem valid_at_mixed' : forall f u v (Fu: ProperFilter u) fi1 fi2 vi, contains (I.convert vi) (Xreal v) -> (forall ui' vi' u' v', contains (I.convert ui') (Xreal u') -> contains (I.convert vi') (Xreal v') -> (I.convert (fi1 ui' vi') <> Inan -> ex_RInt f u' v') /\ contains (I.convert (fi1 ui' vi')) (Xreal (RInt f u' v'))) -> (forall vi' v', contains (I.convert vi') (Xreal v') -> (I.convert (fi2 vi') <> Inan -> ex_RInt_gen f u (at_point v')) /\ contains (I.convert (fi2 vi')) (Xreal (RInt_gen f u (at_point v')))) -> forall u' v', valid u (at_point v) f u' v' (match u', v' with | IBu, IBp xu => fi2 (I.singleton xu) | IBp xl, IBp xu => fi1 (I.singleton xl) (I.singleton xu) | IBu, IBv => fi2 vi | IBp xl, IBv => fi1 (I.singleton xl) vi | _, _ => I.nai end). Proof. intros f u v Fu fi1 fi2 vi Hv Hf1 Hf2 u' v'. unfold valid. destruct u' as [| |ur] ; destruct v' as [| |vr] ; try (rewrite I.nai_correct ; apply valid_Inan). - now apply Hf2. - destruct (Hf2 _ _ (I.singleton_correct vr)) as [H2 H3]. destruct (I.convert (fi2 (I.singleton vr))) as [|il iu] eqn:E. easy. split. intros _. now apply H2. apply H3. - destruct (Hf1 _ vi _ v (I.singleton_correct ur)) as [H2 H3]. apply Hv. destruct (I.convert (fi1 (I.singleton ur) vi)) as [|il iu] eqn:E. easy. split. intros _. apply <- (ex_RInt_gen_at_point f). now apply H2. simpl convert. rewrite RInt_gen_at_point. apply H3. now apply H2. - destruct (Hf1 _ _ _ _ (I.singleton_correct ur) (I.singleton_correct vr)) as [H2 H3]. destruct (I.convert (fi1 (I.singleton ur) (I.singleton vr))) as [|il iu] eqn:E. easy. split. intros _. apply <- (ex_RInt_gen_at_point f). now apply H2. simpl convert. rewrite RInt_gen_at_point. apply H3. now apply H2. Qed. End IntegralRefiner. Lemma RInt_helper : forall f u v i, (i <> Inan -> exists I : R, is_RInt f u v I /\ contains i (Xreal I)) -> (i <> Inan -> ex_RInt f u v) /\ contains i (Xreal (RInt f u v)). Proof. intros f u v [|il iu]. easy. intros [I [H1 H2]]. easy. split. intros _. now exists I. apply eq_ind with (1 := H2). apply f_equal, eq_sym. now apply is_RInt_unique. Qed. Lemma RInt_gen_helper : forall f u v {Fu : ProperFilter' u} {Fv : ProperFilter' v} i, (i <> Inan -> exists I : R, is_RInt_gen f u v I /\ contains i (Xreal I)) -> (i <> Inan -> ex_RInt_gen f u v) /\ contains i (Xreal (RInt_gen f u v)). Proof. intros f u v Fu Fv [|il iu]. easy. intros [I [H1 H2]]. easy. split. intros _. now exists I. apply eq_ind with (1 := H2). apply f_equal, eq_sym. now apply is_RInt_gen_unique. Qed. interval-4.11.1/src/Interval/000077500000000000000000000000001470547631300160075ustar00rootroot00000000000000interval-4.11.1/src/Interval/Float.v000066400000000000000000003424741470547631300172610ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Bool Reals Psatz. From Flocq Require Import Raux. Require Import Stdlib. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Definition output_bnd (fmt upp : bool) radix (s : bool) m e := let m := if s then Zneg m else Zpos m in match e with | 0%Z => BInteger m | Zpos p => BInteger (m * Zaux.Zfast_pow_pos (Zaux.radix_val radix) p) | Zneg p => if andb fmt (Zeq_bool (Zaux.radix_val radix) 2) then let e' := Z.to_pos (Zpos p * 3 / 10) in let m' := Z.mul m (Zaux.Zfast_pow_pos 5 e') in let m'' := Z.div_eucl m' (Z.pow 2 (Zpos p - Zpos e')) in let u := if upp then if Zeq_bool (snd m'') 0 then 0%Z else 1%Z else 0%Z in let d := Z.to_pos (Zaux.Zfast_pow_pos 10 e') in BDecimal (QArith_base.Qmake (fst m'' + u) d) else BFraction m (Zaux.Zfast_pow_pos (Zaux.radix_val radix) p) end. Theorem output_bnd_correct : forall fmt radix s m e, (Interval.convert_bound (output_bnd fmt false radix s m e) <= FtoR radix s m e)%R /\ (FtoR radix s m e <= Interval.convert_bound (output_bnd fmt true radix s m e))%R. Proof. intros fmt radix s m e. assert (Hd: forall a b c d, (0 < b)%Z -> (0 < d)%Z -> (a * d <= b * c)%Z -> (IZR a / IZR b <= IZR c/ IZR d)%R). { intros a b c d Hb Hd H. apply Rcomplements.Rle_div_l. now apply IZR_lt. unfold Rdiv. rewrite Rmult_assoc, <- (Rmult_comm (IZR b)), <- Rmult_assoc. apply Rcomplements.Rle_div_r. now apply IZR_lt. rewrite <- 2!mult_IZR. apply IZR_le. now rewrite <- (Zmult_comm b). } unfold output_bnd. destruct (andb fmt (Zeq_bool (Zaux.radix_val radix) 2)) eqn:Hr. 2: destruct e ; (try rewrite Zaux.Zfast_pow_pos_correct) ; split ; apply Rle_refl. destruct fmt. 2: easy. destruct e as [|e|e]. split ; apply Rle_refl. rewrite Zaux.Zfast_pow_pos_correct ; split ; apply Rle_refl. unfold FtoR. set (sm := if s then Z.neg m else Z.pos m). set (e'' := (Zpos e * 3 / 10)%Z). set (e' := Z.to_pos e''). apply Zeq_is_eq_bool in Hr. assert (He1: (0 <= Zpos e - Zpos e')%Z). { apply Zle_minus_le_0. destruct e'' as [|p|p] eqn:He ; try now apply (Zlt_le_succ 0). unfold e'. simpl. rewrite <- He. apply Z.div_le_upper_bound. easy. rewrite Zmult_comm. now apply Zmult_le_compat_r. } assert (He2: (2 ^ (Z.pos e - Zpos e') > 0)%Z). { apply Z.lt_gt. now apply (Zaux.Zpower_gt_0 Zaux.radix2). } assert (He3: (0 <= Zpos e')%Z) by easy. rewrite Zaux.Zfast_pow_pos_correct. generalize (Zdiv.Z_div_mod (sm * Z.pow_pos 5 e') (2 ^ (Zpos e - Zpos e')) He2). set (qr := Z.div_eucl (sm * Z.pow_pos 5 e') (2 ^ (Zpos e - Zpos e'))). rewrite Hr. destruct qr as [q r]. intros [H1 H2]. rewrite Zaux.Zfast_pow_pos_correct. rewrite Z2Pos.inj_pow_pos by easy. simpl. assert (H3: (sm * 10 ^ Zpos e' = 2 ^ (Zpos e) * q + r * 2 ^ Zpos e')%Z). { change 10%Z with (2 * 5)%Z. rewrite Z.pow_mul_l. rewrite <- (Zmult_comm (5 ^ Zpos e')), Zmult_assoc. unfold Z.pow at 1. rewrite H1. pattern (Zpos e) at 2 ; replace (Zpos e) with (Zpos e - Zpos e' + Zpos e')%Z by ring. rewrite Z.pow_add_r ; try easy. ring. } split. - apply Hd. easy. now apply (Zaux.Zpower_gt_0 radix2 (Zpos e)). unfold QArith_base.Qnum, QArith_base.Qden. rewrite Pos2Z.inj_pow. rewrite <- (Zmult_comm sm), H3. rewrite Zplus_0_r, Zmult_comm. rewrite <- (Zplus_0_r (Z.pow_pos 2 e * q)). apply Zplus_le_compat_l. apply Z.mul_nonneg_nonneg. easy. apply (Zaux.Zpower_ge_0 radix2). - apply Hd. now apply (Zaux.Zpower_gt_0 radix2 (Zpos e)). easy. unfold QArith_base.Qnum, QArith_base.Qden. rewrite Pos2Z.inj_pow. rewrite H3. rewrite Z.mul_add_distr_l. apply Zplus_le_compat_l. generalize (Zeq_bool_if r 0). destruct Zeq_bool. intros ->. now rewrite Zmult_0_l, Zmult_0_r. intros _. rewrite Zmult_1_r. change (Z.pow_pos 2 e) with (Z.pow 2 (Zpos e)). replace (Zpos e) with (Zpos e - Zpos e' + Zpos e')%Z by ring. rewrite Z.pow_add_r by easy. apply Zmult_le_compat_r. now apply Zlt_le_weak. apply (Zaux.Zpower_ge_0 radix2). Qed. Inductive f_interval (A : Type) : Type := | Inan : f_interval A | Ibnd (l u : A) : f_interval A. Arguments Inan {A}. Arguments Ibnd {A} _ _. Definition le_lower' x y := match x with | Xnan => True | Xreal xr => match y with | Xnan => False | Xreal yr => Rle xr yr end end. Module FloatInterval (F'' : FloatOps with Definition sensible_format := true) <: IntervalBasicOps with Module F := F''. Module F := F''. Module F' := FloatExt F. Definition c1 := F.fromZ 1. Definition cm1 := F.fromZ (-1). Definition c2 := F.fromZ 2. Definition p52 := F.PtoP 52. Definition type := f_interval F.type. Definition bound_type := F.type. Definition precision := F.precision. Definition valid_lb x := F.valid_lb x = true. Definition valid_ub x := F.valid_ub x = true. Definition nan := F.nan. Definition convert_bound := F.toX. Definition convert (xi : type) := match xi with | Inan => Interval.Inan | Ibnd l u => if (F.valid_lb l && F.valid_ub u)%bool then Interval.Ibnd (F.toX l) (F.toX u) else Interval.Ibnd (Xreal 1) (Xreal 0) end. Definition nai : type := @Inan F.type. Definition bnd l u : type := Ibnd l u. Definition zero : type := Ibnd F.zero F.zero. Definition empty : type := Ibnd c1 F.zero. Definition real (xi : type) := match xi with | Inan => false | Ibnd _ _ => true end. Definition singleton b := if andb (F.valid_lb b) (F.valid_ub b) then @Ibnd F.type b b else @Inan F.type. Lemma valid_lb_real : forall b, F.toX b = Xreal (proj_val (F.toX b)) -> F.valid_lb b = true. Proof. now intros b Hb; rewrite F'.valid_lb_real; [|rewrite F.real_correct, Hb]. Qed. Lemma valid_ub_real : forall b, F.toX b = Xreal (proj_val (F.toX b)) -> F.valid_ub b = true. Proof. now intros b Hb; rewrite F'.valid_ub_real; [|rewrite F.real_correct, Hb]. Qed. Lemma bnd_correct : forall l u, valid_lb l -> valid_ub u -> convert (bnd l u) = Interval.Ibnd (F.toX l) (F.toX u). Proof. now intros l u Vl Vu; unfold convert; simpl; rewrite Vl, Vu. Qed. Lemma singleton_correct : forall b, contains (convert (singleton b)) (Xreal (proj_val (convert_bound b))). Proof. intros b. unfold singleton, convert, convert_bound. destruct F.valid_lb eqn:Hl. 2: easy. destruct F.valid_ub eqn:Hu. 2: easy. simpl. rewrite Hl, Hu. simpl. destruct F.toX. repeat split. split ; apply Rle_refl. Qed. Lemma nai_correct : convert nai = Interval.Inan. Proof. split. Qed. Lemma zero_correct : convert zero = Interval.Ibnd (Xreal 0) (Xreal 0). Proof. simpl. rewrite F'.valid_lb_zero, F'.valid_ub_zero. now rewrite F.zero_correct. Qed. Lemma empty_correct : forall x, contains (convert empty) x -> False. Proof. intros [|x]. { now simpl; case (_ && _). } simpl. unfold c1. rewrite F.fromZ_correct, F.zero_correct by easy. case (_ && _); simpl; lra. Qed. Lemma real_correct : forall xi, real xi = match convert xi with Interval.Inan => false | _ => true end. Proof. now intros [|xl xu]; [|simpl; case (_ && _)]. Qed. Definition is_empty xi := match xi with | Ibnd xl xu => match F.cmp xl xu with | Xgt => true | _ => false end | _ => false end. Definition bounded xi := match xi with | Ibnd xl xu => F.real xl && F.real xu | _ => false end. Definition lower_bounded xi := match xi with | Ibnd xl _ => F.real xl | _ => false end. Definition upper_bounded xi := match xi with | Ibnd _ xu => F.real xu | _ => false end. Definition output (fmt : bool) xi := match xi with | Ibnd xl xu => match F.toF xl, F.toF xu with | Float sl ml el, Float su mu eu => (Some (output_bnd fmt false F.radix sl ml el), Some (output_bnd fmt true F.radix su mu eu)) | Fzero, Float su mu eu => (Some (BInteger 0), Some (output_bnd fmt true F.radix su mu eu)) | Float sl ml el, Fzero => (Some (output_bnd fmt false F.radix sl ml el), Some (BInteger 0)) | Fzero, Fzero => (Some (BInteger 0), Some (BInteger 0)) | Fzero, Basic.Fnan => (Some (BInteger 0), None) | Basic.Fnan, Fzero => (None, Some (BInteger 0)) | Basic.Fnan, Float su mu eu => (None, Some (output_bnd fmt true F.radix su mu eu)) | Float sl ml el, Basic.Fnan => (Some (output_bnd fmt false F.radix sl ml el), None) | Basic.Fnan, Basic.Fnan => (None, None) end | Inan => (None, None) end. Definition subset xi yi := if is_empty xi then true else match xi, yi with | Ibnd xl xu, Ibnd yl yu => match F.cmp xl yl with | Xund => match F.classify yl with | Fnan | Fminfty => true | Freal | Fpinfty => false end | Xlt => false | _ => true end && match F.cmp xu yu with | Xund => match F.classify yu with | Fnan | Fpinfty => true | Freal | Fminfty => false end | Xgt => false | _ => true end | _, Inan => true | Inan, Ibnd _ _ => false end. Definition wider prec xi yi := match yi, xi with | Inan, _ => false | Ibnd yl yu, Inan => true | Ibnd yl yu, Ibnd xl xu => let yw := F.sub_UP prec yu yl in if F.real yw then match F'.cmp (F.sub_UP prec xu xl) yw with | Xlt | Xeq => false | _ => true end else false end. Definition join xi yi := if is_empty xi then yi else if is_empty yi then xi else match xi, yi with | Ibnd xl xu, Ibnd yl yu => Ibnd (F.min xl yl) (F.max xu yu) | _, _ => Inan end. Definition meet xi yi := if is_empty xi then xi else if is_empty yi then yi else match xi, yi with | Ibnd xl xu, Ibnd yl yu => let l := match F.is_nan xl, F.is_nan yl with | true, _ => yl | false, true => xl | false, false => F.max xl yl end in let u := match F.is_nan xu, F.is_nan yu with | true, _ => yu | false, true => xu | false, false => F.min xu yu end in Ibnd l u | Inan, _ => yi | _, Inan => xi end. Definition mask xi yi : type := match yi with | Inan => yi | _ => xi end. Definition lower_extent xi := match xi with | Ibnd _ xu => Ibnd F.nan xu | _ => Inan end. Definition upper_extent xi := match xi with | Ibnd xl _ => Ibnd xl F.nan | _ => Inan end. Definition lower_complement xi := match xi with | Ibnd xl _ => if F.real xl then Ibnd F.nan xl else empty | Inan => empty end. Definition upper_complement xi := match xi with | Ibnd _ xu => if F.real xu then Ibnd xu F.nan else empty | Inan => empty end. Definition whole := Ibnd F.nan F.nan. Definition lower xi := match xi with | Ibnd xl _ => xl | _ => F.nan end. Definition upper xi := match xi with | Ibnd _ xu => xu | _ => F.nan end. Definition fromZ_small n := let f := F.fromZ n in Ibnd f f. Definition fromZ prec n := Ibnd (F.fromZ_DN prec n) (F.fromZ_UP prec n). Definition midpoint xi := match xi with | Inan => F.zero | Ibnd xl xu => match F.real xl, F.real xu with | false, false => F.zero | true, false => match F.cmp xl F.zero with | Xund | Xlt => F.zero | Xeq => c1 | Xgt => let m := F.mul_UP p52 xl c2 in if F.real m then m else xl end | false, true => match F.cmp xu F.zero with | Xund | Xgt => F.zero | Xeq => cm1 | Xlt => let m := F.mul_DN p52 xu c2 in if F.real m then m else xu end | true, true => F.midpoint xl xu end end. Definition bisect xi := match xi with | Inan => (Inan, Inan) | Ibnd xl xu => let m := midpoint xi in (Ibnd xl m, Ibnd m xu) end. Definition extension f fi := forall b x, contains (convert b) x -> contains (convert (fi b)) (f x). Definition extension_2 f fi := forall ix iy x y, contains (convert ix) x -> contains (convert iy) y -> contains (convert (fi ix iy)) (f x y). Definition sign_large_ xl xu := match F.cmp xl F.zero, F.cmp xu F.zero with | Xeq, Xeq => Xeq | _, Xlt => Xlt | _, Xeq => Xlt | Xgt, _ => Xgt | Xeq, _ => Xgt | _, _ => Xund end. Definition sign_large xi := match xi with | Ibnd xl xu => sign_large_ xl xu | Inan => Xund end. Definition sign_strict_ xl xu := match F.cmp xl F.zero, F.cmp xu F.zero with | Xeq, Xeq => Xeq | _, Xlt => Xlt | Xgt, _ => Xgt | _, _ => Xund end. Definition sign_strict xi := match xi with | Ibnd xl xu => sign_strict_ xl xu | Inan => Xund end. Definition neg xi := match xi with | Ibnd xl xu => Ibnd (F.neg xu) (F.neg xl) | Inan => Inan end. Definition abs xi := match xi with | Ibnd xl xu => match sign_large_ xl xu with | Xgt => xi | Xeq => Ibnd F.zero F.zero | Xlt => Ibnd (F.neg xu) (F.neg xl) | Xund => Ibnd F.zero (F.max (F.neg xl) xu) end | Inan => Inan end. Definition mul2 prec xi := match xi with | Ibnd xl xu => Ibnd (F.mul_DN prec xl c2) (F.mul_UP prec xu c2) | Inan => Inan end. Definition sqrt prec xi := match xi with | Ibnd xl xu => match F.cmp xl F.zero with | Xgt => Ibnd (F.sqrt_DN prec xl) (F.sqrt_UP prec xu) | _ => Ibnd F.zero (F.sqrt_UP prec xu) end | Inan => Inan end. Definition add prec xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => Ibnd (F.add_DN prec xl yl) (F.add_UP prec xu yu) | _, _ => Inan end. Definition sub prec xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => Ibnd (F.sub_DN prec xl yu) (F.sub_UP prec xu yl) | _, _ => Inan end. Definition cancel_add prec xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => Ibnd (F.sub_DN prec xl yl) (F.sub_UP prec xu yu) | _, _ => Inan end. Definition cancel_sub prec xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => Ibnd (F.add_DN prec xl yu) (F.add_UP prec xu yl) | _, _ => Inan end. Definition mul_mixed prec xi y := match xi with | Ibnd xl xu => if F.real y then match F.cmp y F.zero with | Xlt => Ibnd (F.mul_DN prec xu y) (F.mul_UP prec xl y) | Xeq => Ibnd F.zero F.zero | Xgt => Ibnd (F.mul_DN prec xl y) (F.mul_UP prec xu y) | Xund => Inan end else Inan | Inan => Inan end. Definition div_mixed_r prec xi y := match xi with | Ibnd xl xu => if F.real y then match F.cmp y F.zero with | Xlt => Ibnd (F.div_DN prec xu y) (F.div_UP prec xl y) | Xgt => Ibnd (F.div_DN prec xl y) (F.div_UP prec xu y) | _ => Inan end else Inan | Inan => Inan end. Definition sqr prec xi := match xi with | Ibnd xl xu => match sign_large_ xl xu with | Xund => let xm := F.max (F.abs xl) xu in Ibnd F.zero (F.mul_UP prec xm xm) | Xeq => Ibnd F.zero F.zero | Xlt => let lb := F.mul_DN prec xu xu in match F.cmp lb F.zero with | Xgt => Ibnd lb (F.mul_UP prec xl xl) | _ => Ibnd F.zero (F.mul_UP prec xl xl) end | Xgt => let lb := F.mul_DN prec xl xl in match F.cmp lb F.zero with | Xgt => Ibnd lb (F.mul_UP prec xu xu) | _ => Ibnd F.zero (F.mul_UP prec xu xu) end end | _ => Inan end. Definition mul prec xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => match sign_large_ xl xu, sign_large_ yl yu with | Xeq, _ => Ibnd F.zero F.zero | _, Xeq => Ibnd F.zero F.zero | Xgt, Xgt => Ibnd (F.mul_DN prec xl yl) (F.mul_UP prec xu yu) | Xlt, Xlt => Ibnd (F.mul_DN prec xu yu) (F.mul_UP prec xl yl) | Xgt, Xlt => Ibnd (F.mul_DN prec xu yl) (F.mul_UP prec xl yu) | Xlt, Xgt => Ibnd (F.mul_DN prec xl yu) (F.mul_UP prec xu yl) | Xgt, Xund => Ibnd (F.mul_DN prec xu yl) (F.mul_UP prec xu yu) | Xlt, Xund => Ibnd (F.mul_DN prec xl yu) (F.mul_UP prec xl yl) | Xund, Xgt => Ibnd (F.mul_DN prec xl yu) (F.mul_UP prec xu yu) | Xund, Xlt => Ibnd (F.mul_DN prec xu yl) (F.mul_UP prec xl yl) | Xund, Xund => Ibnd (F.min (F.mul_DN prec xl yu) (F.mul_DN prec xu yl)) (F.max (F.mul_UP prec xl yl) (F.mul_UP prec xu yu)) end | _, _ => Inan end. Definition Fdivz_UP prec x y := if F.real y then F.div_UP prec x y else F.zero. Definition Fdivz_DN prec x y := if F.real y then F.div_DN prec x y else F.zero. Definition inv prec xi := match xi with | Ibnd xl xu => match sign_strict_ xl xu with | Xund => Inan | Xeq => Inan | _ => Ibnd (Fdivz_DN prec c1 xu) (Fdivz_UP prec c1 xl) end | _ => Inan end. Definition invnz prec xi := match xi with | Ibnd xl xu => match sign_strict_ xl xu with | Xund => match sign_large_ xl xu with | Xund => Inan | Xeq => Inan | Xlt => Ibnd F.nan (Fdivz_UP prec c1 xl) | Xgt => Ibnd (Fdivz_DN prec c1 xu) F.nan end | Xeq => Inan | _ => Ibnd (Fdivz_DN prec c1 xu) (Fdivz_UP prec c1 xl) end | _ => Inan end. Definition div prec xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => match sign_strict_ xl xu, sign_strict_ yl yu with | _, Xund => Inan | _, Xeq => Inan | Xeq, _ => Ibnd F.zero F.zero | Xgt, Xgt => Ibnd (Fdivz_DN prec xl yu) (F.div_UP prec xu yl) | Xlt, Xlt => Ibnd (Fdivz_DN prec xu yl) (F.div_UP prec xl yu) | Xgt, Xlt => Ibnd (F.div_DN prec xu yu) (Fdivz_UP prec xl yl) | Xlt, Xgt => Ibnd (F.div_DN prec xl yl) (Fdivz_UP prec xu yu) | Xund, Xgt => Ibnd (F.div_DN prec xl yl) (F.div_UP prec xu yl) | Xund, Xlt => Ibnd (F.div_DN prec xu yu) (F.div_UP prec xl yu) end | _, _ => Inan end. Fixpoint Fpower_pos_UP prec x n := match n with | xH => x | xO p => Fpower_pos_UP prec (F.mul_UP prec x x) p | xI p => F.mul_UP prec x (Fpower_pos_UP prec (F.mul_UP prec x x) p) end. Fixpoint Fpower_pos_DN prec x n := match n with | xH => x | xO p => let xx := F.mul_DN prec x x in match F.cmp xx F.zero with | Xgt => Fpower_pos_DN prec xx p | Xeq | Xlt => F.zero | Xund => F.nan end | xI p => let xx := F.mul_DN prec x x in match F.cmp xx F.zero with | Xgt => F.mul_DN prec x (Fpower_pos_DN prec xx p) | Xeq | Xlt => F.zero | Xund => F.nan end end. Definition power_pos prec xi n := match xi with | Ibnd xl xu => match sign_large_ xl xu with | Xund => match n with | xH => xi | xO _ => let xm := F.max (F.abs xl) xu in Ibnd F.zero (Fpower_pos_UP prec xm n) | xI _ => Ibnd (F.neg (Fpower_pos_UP prec (F.abs xl) n)) (Fpower_pos_UP prec xu n) end | Xeq => Ibnd F.zero F.zero | Xlt => match n with | xH => xi | xO _ => Ibnd (Fpower_pos_DN prec (F.abs xu) n) (Fpower_pos_UP prec (F.abs xl) n) | xI _ => Ibnd (F.neg (Fpower_pos_UP prec (F.abs xl) n)) (F.neg (Fpower_pos_DN prec (F.abs xu) n)) end | Xgt => Ibnd (Fpower_pos_DN prec xl n) (Fpower_pos_UP prec xu n) end | _ => Inan end. Definition power_int prec xi n := match n with | Zpos p => power_pos prec xi p | Z0 => match xi with Inan => Inan | _ => Ibnd c1 c1 end | Zneg p => inv prec (power_pos prec xi p) end. Definition nearbyint mode xi := match xi with | Inan => Inan | Ibnd xl xu => Ibnd (F.nearbyint_DN mode xl) (F.nearbyint_UP mode xu) end. Definition error_aux prec mode e := let e := match mode with | rnd_NE => Z.pred e | _ => e end in let err := F.pow2_UP prec (F.ZtoS e) in match mode with | rnd_NE => Ibnd (F.neg err) err | rnd_UP => Ibnd F.zero err | rnd_DN => Ibnd (F.neg err) F.zero | rnd_ZR => Ibnd (F.neg err) err end. Definition error_fix prec mode emin (xi : type) := match xi with | Inan => Inan | Ibnd xl xu => error_aux prec mode emin end. Definition error_flt prec mode emin p xi := match xi with | Inan => Inan | Ibnd xl xu => let xu' := F.max (F.neg xl) xu in if andb (F.real xu') (Z.eqb (Zaux.radix_val F.radix) 2) then let e := FLT.FLT_exp emin (Z.pos p) (F.StoZ (F.mag xu')) in error_aux prec mode e else Inan end. Ltac xreal_tac v := let X := fresh "X" in case_eq (F.toX v) ; [ intros X ; try exact I | let r := fresh "r" in intros r X ; try rewrite X in * ]. Ltac xreal_tac2 := match goal with | H: F.toX ?v = Xreal _ |- context [F.toX ?v] => rewrite H | |- context [F.toX ?v] => xreal_tac v end. Ltac xreal_tac3 v := match goal with | H: F.toX v = Xreal _ |- _ => rewrite H | H: F.toX v = Xnan |- _ => rewrite H | _ => xreal_tac v end. Ltac bound_tac := unfold Xround, Xbind ; match goal with | |- (round ?r rnd_DN ?p ?v <= ?w)%R => apply Rle_trans with (1 := proj1 (proj2 (Generic_fmt.round_DN_pt F.radix (FLX.FLX_exp (Zpos p)) v))) | |- (?w <= round ?r_UP ?p ?v)%R => apply Rle_trans with (2 := proj1 (proj2 (Generic_fmt.round_UP_pt F.radix (FLX.FLX_exp (Zpos p)) v))) end. Lemma is_empty_correct : forall xi x, contains (convert xi) x -> is_empty xi = true -> False. Proof. intros [|xl xu]. easy. intros x. simpl. rewrite F.cmp_correct. rewrite F.valid_lb_correct, F.valid_ub_correct. destruct x as [|x]. { now destruct F.classify ; destruct F.classify. } assert (H: (1 <= x <= 0)%R -> true = true -> False). { intros H _. apply (Rlt_not_le 1 0 Rlt_0_1). now apply Rle_trans with x. } destruct F.classify ; destruct F.classify ; try easy. destruct F.toX as [|xlr]. easy. destruct F.toX as [|xur]. easy. simpl. intros H'. case Rcompare_spec ; try easy. intros K _. apply Rlt_not_le with (1 := K). now apply Rle_trans with x. Qed. Lemma lower_correct : forall xi : type, not_empty (convert xi) -> F.toX (lower xi) = Xlower (convert xi). Proof. intros [|xl xu]. simpl. now rewrite F'.nan_correct. simpl; unfold convert; case (_ && _); [easy|]. intros [x Hx]; revert Hx; simpl; lra. Qed. Lemma valid_lb_lower : forall xi : type, not_empty (convert xi) -> valid_lb (lower xi). Proof. intros [|l u] [x Hx]; unfold valid_lb; simpl; [now rewrite F'.valid_lb_nan|]. now revert Hx; unfold convert; case F.valid_lb; [|simpl; lra]. Qed. Lemma upper_correct : forall xi : type, not_empty (convert xi) -> F.toX (upper xi) = Xupper (convert xi). Proof. intros [|xl xu]. simpl. now rewrite F'.nan_correct. simpl; unfold convert; case (_ && _); [easy|]. intros [x Hx]; revert Hx; simpl; lra. Qed. Lemma valid_ub_upper : forall xi : type, not_empty (convert xi) -> valid_ub (upper xi). Proof. intros [|l u] [x Hx]; unfold valid_ub; simpl; [now rewrite F'.valid_ub_nan|]. revert Hx; unfold convert. now case F.valid_ub; rewrite andb_comm; [|simpl; lra]. Qed. Theorem output_correct : forall fmt xi x, contains (convert xi) (Xreal x) -> contains_output (output fmt xi) x. Proof. intros fmt xi x. unfold output, convert. destruct xi as [|xl xu] ; try easy. assert (H: forall P : Prop, (1 <= x <= 0)%R -> P). { intros P [H1 H2]. elim (Rlt_irrefl 0). apply Rlt_le_trans with (1 := Rlt_0_1). apply Rle_trans with (1 := H1) (2 := H2). } destruct (F.valid_lb xl). 2: apply H. destruct (F.valid_ub xu). 2: apply H. clear H. simpl. unfold F.toX. intros [H1 H2]. destruct (F.toF xl) as [| |sl ml el] ; destruct (F.toF xu) as [| |su mu eu] ; try split ; first [ easy | apply Rle_trans with (1 := proj1 (output_bnd_correct fmt F.radix sl ml el)) | apply Rle_trans with (2 := proj2 (output_bnd_correct fmt F.radix su mu eu)) ]; easy. Qed. Theorem subset_correct : forall xi yi v, contains (convert xi) v -> subset xi yi = true -> contains (convert yi) v. Proof. intros xi yi. case xi ; case yi ; try (simpl ; intros ; try exact I ; discriminate). unfold subset. intros yl yu xl xu v Hv. generalize (is_empty_correct (Ibnd xl xu) v Hv). destruct is_empty. { intros H H'. now elim H. } intros _. revert Hv. simpl. rewrite !F.cmp_correct, !F.valid_lb_correct, !F.valid_ub_correct. generalize (F.classify_correct xl); rewrite F.real_correct. generalize (F.classify_correct xu); rewrite F.real_correct. generalize (F.classify_correct yl); rewrite F.real_correct. generalize (F.classify_correct yu); rewrite F.real_correct. intros Hyu Hyl Hxu Hxl Hv. assert (Hc : match F.classify xl with Fpinfty => false | _ => true end && match F.classify xu with Fminfty => false | _ => true end = true). { clear -Hv. destruct andb. easy. destruct v as [|v]. easy. elim (Rlt_irrefl v). apply Rle_lt_trans with (1 := proj2 Hv). apply Rlt_le_trans with (2 := proj1 Hv). exact Rlt_0_1. } rewrite Hc in Hv. destruct v as [|v]. easy. revert Hxl Hyl Hxu Hyu Hc. case (F.classify xl) ; destruct (F.toX xl) as [|xlr] ; try easy ; intros _ ; case (F.classify yl) ; destruct (F.toX yl) as [|ylr] ; try easy ; intros _ ; case (F.classify xu) ; destruct (F.toX xu) as [|xur] ; try easy ; intros _ ; case (F.classify yu) ; destruct (F.toX yu) as [|yur] ; try easy ; intros _ ; intros _ ; simpl ; (try now rewrite andb_false_r) ; simpl in Hv ; case Rcompare_spec ; try easy ; try lra ; case Rcompare_spec ; try easy ; try lra. Qed. Lemma join_correct : forall xi yi v, contains (convert xi) v \/ contains (convert yi) v -> contains (convert (join xi yi)) v. Proof. intros xi yi v H. unfold join. generalize (is_empty_correct xi v). intros Ex. destruct is_empty. { destruct H as [H|H]. now elim Ex. exact H. } clear Ex. generalize (is_empty_correct yi v). intros Ey. destruct is_empty. { destruct H as [H|H]. exact H. now elim Ey. } clear Ey. revert H. assert (H1v0 : forall v, ~(1 <= v <= 0)%R). { intros v' Hf. apply (Rlt_irrefl 0), (Rlt_le_trans _ 1); [apply Rlt_0_1|]. elim Hf; apply Rle_trans. } revert xi yi v. simpl. intros [|xl xu] [|yl yu] [|v]; simpl; try rewrite Hxl, Hxu; try rewrite Hyl, Hyu; simpl; try tauto; [|]. { now case (_ && _); case (_ && _); intros [H|H]. } generalize (F.max_correct xu yu). generalize (F.min_correct xl yl). generalize (F.real_correct yu) ; generalize (F.classify_correct yu) ; generalize (F.valid_ub_correct yu) ; case (F.classify yu) => -> -> ; [xreal_tac yu; [easy|intros _]|xreal_tac yu; [intros _|easy]..] ; ( generalize (F.real_correct xu) ; generalize (F.classify_correct xu) ; generalize (F.valid_ub_correct xu) ; case (F.classify xu) => -> -> ; [xreal_tac xu; [easy|intros _]|xreal_tac xu; [intros _|easy]..] ) ; ( generalize (F.real_correct yl) ; generalize (F.classify_correct yl) ; generalize (F.valid_lb_correct yl) ; case (F.classify yl) => -> -> ; [xreal_tac yl; [easy|intros _]|xreal_tac yl; [intros _|easy]..] ) ; ( generalize (F.real_correct xl) ; generalize (F.classify_correct xl) ; generalize (F.valid_lb_correct xl) ; case (F.classify xl) => -> -> ; [xreal_tac xl; [easy|intros _]|xreal_tac xl; [intros _|easy]..] ) ; simpl ; intros Hmin Hmax ; rewrite ?Hmin, ?Hmax ; try ( intro H; exfalso; lra ) ; try match type of Hmin with | F.classify _ = _ => generalize (F.valid_lb_correct (F.min xl yl)) ; rewrite Hmin => -> | F.toX _ = Xreal _ => rewrite F'.valid_lb_real; [|now rewrite F.real_correct, Hmin] end ; try match type of Hmax with | F.classify _ = _ => generalize (F.valid_ub_correct (F.max xu yu)) ; rewrite Hmax => -> | F.toX _ = Xreal _ => rewrite F'.valid_ub_real; [|now rewrite F.real_correct, Hmax] end ; simpl ; try match goal with | |- context [ F.valid_lb ?x ] => match goal with | H : F.toX x = Xreal _ |- _ => rewrite F'.valid_lb_real; [|now rewrite F.real_correct, H] end end ; try match goal with | |- context [ F.valid_ub ?x ] => match goal with | H : F.toX x = Xreal _ |- _ => rewrite F'.valid_ub_real; [|now rewrite F.real_correct, H] end end ; simpl ; (* no more if valid... at this point *) try match goal with | |- context [ F.toX (F.min _ _) ] => match type of Hmin with | F.classify _ = _ => generalize (F.classify_correct (F.min xl yl)) ; rewrite Hmin, F.real_correct ; case (F.toX (F.min xl yl)); try easy; intros _ end end ; try match goal with | |- context [ F.toX (F.max _ _) ] => match type of Hmax with | F.classify _ = _ => generalize (F.classify_correct (F.max xu yu)) ; rewrite Hmax, F.real_correct ; case (F.toX (F.max xu yu)); try easy; intros _ end end ; do 2 try match goal with | |- context [ F.toX ?x ] => match goal with | H : F.toX x = _ |- _ => rewrite H end end ; (* no more match *) intro H ; split ; try exact I ; destruct H ; try ( exfalso ; lra ) ; try match goal with | |- context [ Rmin ?x ?y ] => generalize (Rmin_l x y) ; generalize (Rmin_r x y) ; lra end ; try match goal with | |- context [ Rmax ?x ?y ] => generalize (Rmax_l x y) ; generalize (Rmax_r x y) ; lra end ; easy. Qed. Theorem meet_correct : forall xi yi v, contains (convert xi) v -> contains (convert yi) v -> contains (convert (meet xi yi)) v. Proof. intros xi yi v Hx Hy. unfold meet. destruct is_empty. easy. destruct is_empty. easy. revert xi yi v Hx Hy. intros [|xl xu] [|yl yu] [|v] ; simpl ; trivial; [now case (_ && _)|]. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. case_eq (F.valid_lb yl); [|intros _ _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub yu); [|intros _ _ _ [H0 H1]; exfalso; lra]. intros Vyu Vyl. intros (Hxl, Hxu) (Hyl, Hyu). simpl. generalize (F.max_correct xl yl). generalize (F.min_correct xu yu). generalize (F.real_correct yu) ; generalize (F.is_nan_correct yu) ; generalize (F.classify_correct yu) ; generalize Vyu; rewrite F.valid_ub_correct ; case (F.classify yu); try easy; intros _ H H'; rewrite H, H'; clear H H' ; [xreal_tac yu; [easy|intros _]|xreal_tac yu; [intros _|easy]..] ; ( generalize (F.real_correct xu) ; generalize (F.is_nan_correct xu) ; generalize (F.classify_correct xu) ; generalize Vxu; rewrite F.valid_ub_correct ; case (F.classify xu); try easy; intros _ H H'; rewrite H, H'; clear H H' ; [xreal_tac xu; [easy|intros _]|xreal_tac xu; [intros _|easy]..] ) ; ( generalize (F.real_correct yl) ; generalize (F.is_nan_correct yl) ; generalize (F.classify_correct yl) ; generalize Vyl; rewrite F.valid_lb_correct ; case (F.classify yl); try easy; intros _ H H'; rewrite H, H'; clear H H' ; [xreal_tac yl; [easy|intros _]|xreal_tac yl; [intros _|easy]..] ) ; ( generalize (F.real_correct xl) ; generalize (F.is_nan_correct xl) ; generalize (F.classify_correct xl) ; generalize Vxl; rewrite F.valid_lb_correct ; case (F.classify xl); try easy; intros _ H H'; rewrite H, H'; clear H H' ; [xreal_tac xl; [easy|intros _]|xreal_tac xl; [intros _|easy]..] ) ; simpl ; intros Hmin Hmax ; rewrite ?Hmin, ?Hmax, ?Vxu, ?Vxl, ?Vyu, ?Vyl ; try match type of Hmin with | F.toX _ = Xreal _ => rewrite F'.valid_ub_real; [|now rewrite F.real_correct, Hmin] end ; try match type of Hmax with | F.toX _ = Xreal _ => rewrite F'.valid_lb_real; [|now rewrite F.real_correct, Hmax] end ; simpl ; (* no more if valid... at this point *) do 2 try match goal with | |- context [ F.toX ?x ] => match goal with | H : F.toX x = _ |- _ => rewrite H end end ; (* no more match *) split ; try exact I ; try match goal with | |- (?z <= Rmin ?x ?y)%R => generalize (Rmin_glb x y z) ; lra end ; try match goal with | |- (Rmax ?x ?y <= ?z)%R => generalize (Rmax_lub x y z) ; lra end ; easy. Qed. Theorem meet_correct' : forall xi yi v, contains (convert (meet xi yi)) v -> contains (convert xi) v /\ contains (convert yi) v. Proof. intros xi yi v. unfold meet. generalize (is_empty_correct xi v). destruct is_empty. { intros H Hv. now elim H. } intros _. generalize (is_empty_correct yi v). destruct is_empty. { intros H Hv. now elim H. } intros _. revert xi yi v. intros [|xl xu] [|yl yu] v H ; try easy. destruct v as [|v]; revert H; simpl; [now case (_ && _)|]. assert (HRmin: forall p q, (v <= Rmin p q)%R -> (v <= p /\ v <= q)%R). intros p q H. unfold Rmin in H. destruct Rle_dec as [H'|H'] ; lra. assert (HRmax: forall p q, (Rmax p q <= v)%R -> (p <= v /\ q <= v)%R). intros p q H. unfold Rmax in H. destruct Rle_dec as [H'|H'] ; lra. generalize (F.max_correct xl yl). generalize (F.min_correct xu yu). generalize (F.real_correct yu) ; generalize (F.is_nan_correct yu) ; generalize (F.classify_correct yu) ; generalize (F.valid_ub_correct yu) ; ( case (F.classify yu) ; intros Vyu H H'; rewrite H, H'; clear H H' ) ; [xreal_tac yu; [easy|intros _]|xreal_tac yu; [intros _|easy]..] ; ( generalize (F.real_correct xu) ; generalize (F.is_nan_correct xu) ; generalize (F.classify_correct xu) ; generalize (F.valid_ub_correct xu) ; ( case (F.classify xu) ; intros Vxu H H'; rewrite H, H'; clear H H' ) ; [xreal_tac xu; [easy|intros _]|xreal_tac xu; [intros _|easy]..] ) ; ( generalize (F.real_correct yl) ; generalize (F.is_nan_correct yl) ; generalize (F.classify_correct yl) ; generalize (F.valid_lb_correct yl) ; ( case (F.classify yl) ; intros Vyl H H'; rewrite H, H'; clear H H' ) ; [xreal_tac yl; [easy|intros _]|xreal_tac yl; [intros _|easy]..] ) ; ( generalize (F.real_correct xl) ; generalize (F.is_nan_correct xl) ; generalize (F.classify_correct xl) ; generalize (F.valid_lb_correct xl) ; ( case (F.classify xl) ; intros Vxl H H'; rewrite H, H'; clear H H' ) ; [xreal_tac xl; [easy|intros _]|xreal_tac xl; [intros _|easy]..] ) ; simpl ; intros Hmin Hmax ; rewrite ?Hmin, ?Hmax, ?Vxu, ?Vxl, ?Vyu, ?Vyl ; try match type of Hmin with | F.toX _ = Xreal _ => rewrite F'.valid_ub_real; [|now rewrite F.real_correct, Hmin] | F.classify ?m = _ => generalize (F.valid_ub_correct m) ; rewrite Hmin => -> end ; try match type of Hmax with | F.toX _ = Xreal _ => rewrite F'.valid_lb_real; [|now rewrite F.real_correct, Hmax] | F.classify ?m = _ => generalize (F.valid_lb_correct m) ; rewrite Hmax => -> end ; simpl ; (* no more if valid... at this point *) do 2 try match goal with | |- context [ F.toX ?x ] => match goal with | H : F.toX x = _ |- _ => rewrite H end end ; (* no more match *) intros [Hl Hu] ; try match type of Hl with | (Rmax ?x ?y <= _)%R => apply (HRmax x y) in Hl end ; try match type of Hu with | (_ <= Rmin ?x ?y)%R => apply (HRmin x y) in Hu end ; lra. Qed. Definition bounded_prop xi := not_empty (convert xi) -> convert xi = Interval.Ibnd (F.toX (lower xi)) (F.toX (upper xi)). Theorem lower_bounded_correct : forall xi, lower_bounded xi = true -> F.toX (lower xi) = Xreal (proj_val (F.toX (lower xi))) /\ bounded_prop xi. Proof. unfold lower_bounded. intros [|xl xu] H. discriminate H. generalize (F.real_correct xl). rewrite H. clear H. simpl. unfold F.toX. case (F.toF xl). intro H. discriminate H. repeat split. { unfold bounded_prop, convert; simpl; case (_ && _); [easy|]. intros [x Hx]; revert Hx; simpl; lra. } intros s m e; case (FtoX _); [now simpl|]; intros r _; split; [now simpl|]. unfold bounded_prop, convert; simpl; case (_ && _); [easy|]. intros [x Hx]; revert Hx; simpl; lra. Qed. Theorem upper_bounded_correct : forall xi, upper_bounded xi = true -> F.toX (upper xi) = Xreal (proj_val (F.toX (upper xi))) /\ bounded_prop xi. Proof. unfold upper_bounded. intros [|xl xu] H. discriminate H. generalize (F.real_correct xu). rewrite H. clear H. simpl. unfold F.toX. case (F.toF xu). intro H. discriminate H. repeat split. { unfold bounded_prop, convert; simpl; case (_ && _); [easy|]. intros [x Hx]; revert Hx; simpl; lra. } intros s m e; case (FtoX _); [now simpl|]; intros r _; split; [now simpl|]. unfold bounded_prop, convert; simpl; case (_ && _); [easy|]. intros [x Hx]; revert Hx; simpl; lra. Qed. Theorem bounded_correct : forall xi, bounded xi = true -> lower_bounded xi = true /\ upper_bounded xi = true. Proof. unfold bounded. intros [|xl xu] H. discriminate H. now apply andb_prop. Qed. Theorem lower_extent_correct : forall xi x y, contains (convert xi) (Xreal y) -> (x <= y)%R -> contains (convert (lower_extent xi)) (Xreal x). Proof. assert (H1v0 : forall v, ~(1 <= v <= 0)%R). { intros v Hf. apply (Rlt_irrefl 0), (Rlt_le_trans _ 1); [apply Rlt_0_1|]. elim Hf; apply Rle_trans. } intros [|xl xu] x y; simpl; [now simpl|]. case_eq (F.valid_lb xl); intro Vxl; [|now intro H; destruct (H1v0 y)]. case_eq (F.valid_ub xu); intro Vxu; [|now intro H; destruct (H1v0 y)]. intros (Hyl, Hyu) Hx; rewrite F'.valid_lb_nan; split. { now rewrite F'.nan_correct. } now revert Hyu; xreal_tac xu; [now simpl|]; apply Rle_trans. Qed. Theorem upper_extent_correct : forall xi x y, contains (convert xi) (Xreal y) -> (y <= x)%R -> contains (convert (upper_extent xi)) (Xreal x). Proof. assert (H1v0 : forall v, ~(1 <= v <= 0)%R). { intros v Hf. apply (Rlt_irrefl 0), (Rlt_le_trans _ 1); [apply Rlt_0_1|]. elim Hf; apply Rle_trans. } intros [|xl xu] x y; simpl; [now simpl|]. case_eq (F.valid_lb xl); intro Vxl; [|now intro H; destruct (H1v0 y)]. case_eq (F.valid_ub xu); intro Vxu; [|now intro H; destruct (H1v0 y)]. intros (Hxl, Hxu) Hx; rewrite F'.valid_ub_nan; split. { now revert Hxl; xreal_tac xl; [now simpl|]; intro Hxl; apply (Rle_trans _ y). } now rewrite F'.nan_correct. Qed. Theorem lower_complement_correct : forall xi x y, contains (convert xi) (Xreal x) -> contains (convert (lower_complement xi)) (Xreal y) -> (y <= x)%R. Proof. intros [|xl xu] x y. intros _ H. now apply empty_correct in H. unfold convert at 1. case F.valid_lb; simpl; [|lra]. case F.valid_ub; simpl; [|lra]. intros [H _]. simpl. rewrite F.real_correct. case_eq (F.toX xl). intros _ H'. now apply empty_correct in H'. intros l Hl. unfold convert. rewrite F'.valid_lb_nan; simpl. case F.valid_ub; [|simpl; lra]. intros [_ H']. rewrite Hl in H, H'. now apply Rle_trans with l. Qed. Theorem upper_complement_correct : forall xi x y, contains (convert xi) (Xreal x) -> contains (convert (upper_complement xi)) (Xreal y) -> (x <= y)%R. Proof. intros [|xl xu] x y. intros _ H. now apply empty_correct in H. unfold convert at 1. case F.valid_lb; simpl; [|lra]. case F.valid_ub; simpl; [|lra]. intros [_ H]. simpl. rewrite F.real_correct. case_eq (F.toX xu). intros _ H'. now apply empty_correct in H'. intros u Hu. unfold convert. rewrite F'.valid_ub_nan; simpl. case F.valid_lb; [|simpl; lra]. intros [H' _]. rewrite Hu in H, H'. now apply Rle_trans with u. Qed. Theorem whole_correct : forall x, contains (convert whole) (Xreal x). Proof. intros x. simpl. rewrite F'.nan_correct. now rewrite F'.valid_lb_nan, F'.valid_ub_nan. Qed. Lemma sign_large_correct_ : forall xl xu x, contains (convert (Ibnd xl xu)) (Xreal x) -> match sign_large_ xl xu with | Xeq => x = 0%R /\ F.toX xl = Xreal 0 /\ F.toX xu = Xreal 0 | Xlt => (x <= 0)%R /\ (match F.toX xl with Xreal rl => (rl <= 0)%R | _=> True end) /\ (exists ru, F.toX xu = Xreal ru /\ (ru <= 0)%R) | Xgt => (0 <= x)%R /\ (match F.toX xu with Xreal ru => (0 <= ru)%R | _=> True end) /\ (exists rl, F.toX xl = Xreal rl /\ (0 <= rl)%R) | Xund => match F.toX xl with Xreal rl => (rl <= 0)%R | _=> True end /\ match F.toX xu with Xreal ru => (0 <= ru)%R | _=> True end end. Proof. assert (H1v0 : forall v, ~(1 <= v <= 0)%R). { intros v Hf. apply (Rlt_irrefl 0), (Rlt_le_trans _ 1); [apply Rlt_0_1|]. elim Hf; apply Rle_trans. } intros xl xu x; simpl. case_eq (F.valid_lb xl); intro Vxl; [|now intro H; destruct (H1v0 x)]. case_eq (F.valid_ub xu); intro Vxu; [|now intro H; destruct (H1v0 x)]. simpl. unfold sign_large_. rewrite 2!F.cmp_correct. rewrite F.zero_correct, F'.classify_zero. generalize Vxl ; rewrite F.valid_lb_correct ; generalize (F.classify_correct xl) ; rewrite F.real_correct ; case_eq (F.classify xl); intro Cxl ; [..|easy] ; [case_eq (F.toX xl); [easy|] ; intros rxl Hrxl _ |case_eq (F.toX xl); [|easy] ; intros Hrxl _..] ; ( generalize Vxu ; rewrite F.valid_ub_correct ; generalize (F.classify_correct xu) ; rewrite F.real_correct ; case_eq (F.classify xu); intro Cxu ; [..|easy|] ; [case_eq (F.toX xu); [easy|] ; intros rxu Hrxu _ |case_eq (F.toX xu); [|easy] ; intros Hrxu _..] ) ; intros _ _ [Hxl Hxu] ; unfold Xcmp ; try ( case (Rcompare_spec rxl 0) ; intros Hrxl0 ) ; try ( case (Rcompare_spec rxu 0) ; intros Hrxu0 ) ; rewrite ?Hrxl0, ?Hrxu0 ; ( split; [lra|] ) ; try ( easy || lra ) ; ( split ; [try ( exact I || lra )|] ) ; try ( now exists 0%R; split; [|lra] ) ; try ( now exists rxu; split; [|lra] ) ; try ( now exists rxl; split; [|lra] ). Qed. Theorem sign_large_correct : forall xi, match sign_large xi with | Xeq => forall x, contains (convert xi) x -> x = Xreal 0 | Xlt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rle (proj_val x) 0 | Xgt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rle 0 (proj_val x) | Xund => True end. Proof. intros [|xl xu]. exact I. generalize (sign_large_correct_ xl xu). unfold sign_large. case (sign_large_ xl xu); intro H; try exact I; (intros [|x]; [try easy; try now simpl; case (_ && _)|]); intro H'; [| |]. { now rewrite (proj1 (H _ H')). } { now split; simpl; [|elim (H _ H')]. } now split; simpl; [|elim (H _ H')]. Qed. Lemma sign_strict_correct_ : forall xl xu x, contains (convert (Ibnd xl xu)) (Xreal x) -> match sign_strict_ xl xu with | Xeq => x = 0%R /\ F.toX xl = Xreal 0 /\ F.toX xu = Xreal 0 | Xlt => (x < 0)%R /\ (match F.toX xl with Xreal rl => (rl < 0)%R | _=> True end) /\ (exists ru, F.toX xu = Xreal ru /\ (ru < 0)%R) | Xgt => (0 < x)%R /\ (match F.toX xu with Xreal ru => (0 < ru)%R | _=> True end) /\ (exists rl, F.toX xl = Xreal rl /\ (0 < rl)%R) | Xund => match F.toX xl with Xreal rl => (rl <= 0)%R | _=> True end /\ match F.toX xu with Xreal ru => (0 <= ru)%R | _=> True end end. Proof. assert (H1v0 : forall v, ~(1 <= v <= 0)%R). { intros v Hf. apply (Rlt_irrefl 0), (Rlt_le_trans _ 1); [apply Rlt_0_1|]. elim Hf; apply Rle_trans. } intros xl xu x; simpl. case_eq (F.valid_lb xl); intro Vxl; [|now intro H; destruct (H1v0 x)]. case_eq (F.valid_ub xu); intro Vxu; [|now intro H; destruct (H1v0 x)]. unfold sign_strict_. rewrite 2!F.cmp_correct, F.zero_correct, F'.classify_zero. generalize Vxl ; rewrite F.valid_lb_correct ; generalize (F.classify_correct xl) ; rewrite F.real_correct ; case_eq (F.classify xl); [..|easy]; intro Cxl ; [case_eq (F.toX xl); [easy|]; intros rxl|case_eq (F.toX xl); [|easy]..] ; intros Hrxl _ _ ; ( generalize Vxu ; rewrite F.valid_ub_correct ; generalize (F.classify_correct xu) ; rewrite F.real_correct ; case_eq (F.classify xu); [..|easy|]; intro Cxu ; [case_eq (F.toX xu); [easy|]; intros rxu|case_eq (F.toX xu); [|easy]..] ; intros Hrxu _ _ ) ; intros [Hxl Hxu] ; unfold Xcmp ; try ( case Rcompare_spec; intros H1 ; try easy ) ; try ( case Rcompare_spec; intros H2 ; try easy ) ; try lra ; ( split ; [try lra|] ) ; ( split ; [try lra|] ) ; rewrite ?H1, ?H2 ; try easy ; try ( now exists rxu ) ; try ( now exists rxl ). Qed. Theorem sign_strict_correct : forall xi, match sign_strict xi with | Xeq => forall x, contains (convert xi) x -> x = Xreal 0 | Xlt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rlt (proj_val x) 0 | Xgt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rlt 0 (proj_val x) | Xund => True end. Proof. intros [|xl xu]. exact I. generalize (sign_strict_correct_ xl xu). unfold sign_strict. case (sign_strict_ xl xu); intro H; try exact I; (intros [|x]; [try easy; try now simpl; case (_ && _)|]); intro H'; [| |]. { now rewrite (proj1 (H _ H')). } { now split; simpl; [|elim (H _ H')]. } now split; simpl; [|elim (H _ H')]. Qed. Theorem fromZ_small_correct : forall v, (Z.abs v <= 256)%Z -> contains (convert (fromZ_small v)) (Xreal (IZR v)). Proof. intros. simpl. rewrite F'.valid_lb_real, F'.valid_ub_real by now rewrite F.real_correct, F.fromZ_correct. rewrite F.fromZ_correct by easy. split ; apply Rle_refl. Qed. Theorem fromZ_correct : forall prec v, contains (convert (fromZ prec v)) (Xreal (IZR v)). Proof. intros. simpl. destruct (F.fromZ_DN_correct prec v) as [Hlv Lv]. destruct (F.fromZ_UP_correct prec v) as [Huv Uv]. rewrite Hlv, Huv. now apply le_contains. Qed. Theorem midpoint_correct : forall xi, not_empty (convert xi) -> F.toX (midpoint xi) = Xreal (proj_val (F.toX (midpoint xi))) /\ contains (convert xi) (F.toX (midpoint xi)). Proof. intros [|xl xu]. { intros _. refine (conj _ I). simpl. now rewrite F.zero_correct. } intros (x, Hx). unfold midpoint, c1, cm1, c2. destruct (F.real xl) eqn:Rl. - destruct (F.real xu) eqn:Ru. + revert Hx. simpl. rewrite F'.valid_lb_real, F'.valid_ub_real by easy. rewrite 2!F'.real_correct by easy. intros [Hxl Hxu]. destruct (F.midpoint_correct _ _ eq_refl Rl Ru (Rle_trans _ _ _ Hxl Hxu)) as [Hm1 Hm2]. simpl. now rewrite F'.real_correct. + assert (Hx': (proj_val (F.toX xl) <= x)%R). { revert Hx. simpl. case andb ; simpl. now rewrite F'.real_correct. lra. } assert (Hz: forall z, (F.toR xl <= z)%R -> contains (convert (Ibnd xl xu)) (Xreal z)). { intros z Hz. revert Hx. simpl. case andb ; simpl. intros _. split. now rewrite F'.real_correct. now rewrite F'.real_correct_false. lra. } rewrite F.cmp_correct. rewrite F'.classify_real by easy. rewrite F'.classify_real by now rewrite F.real_correct, F.zero_correct. rewrite (F'.real_correct xl) by easy. rewrite F.zero_correct. simpl Xcmp. case Rcompare_spec ; intros Hl. * rewrite F.zero_correct. apply (conj eq_refl). apply Hz. now apply Rlt_le. * rewrite F.fromZ_correct by easy. apply (conj eq_refl). apply Hz. rewrite Hl. apply Rle_0_1. * destruct (F.mul_UP_correct p52 xl (F.fromZ 2)) as [Hm1 Hm2]. { left. unfold F.is_non_neg'. split. rewrite F'.real_correct by easy. now apply Rlt_le. rewrite F.fromZ_correct by easy. now apply IZR_le. } destruct (F.real (F.mul_UP p52 xl (F.fromZ 2))) eqn:Rp. split. now apply F'.real_correct. rewrite F'.real_correct by easy. apply Hz. revert Hm2. unfold le_upper, F.toR. rewrite F'.real_correct by easy. rewrite F'.real_correct by easy. rewrite F.fromZ_correct by easy. simpl. lra. split. now apply F'.real_correct. rewrite F'.real_correct by easy. apply Hz. apply Rle_refl. - destruct (F.real xu) eqn:Ru. + assert (Hx': (x <= proj_val (F.toX xu))%R). { revert Hx. simpl. case andb ; simpl. now rewrite (F'.real_correct xu). lra. } assert (Hz: forall z, (z <= F.toR xu)%R -> contains (convert (Ibnd xl xu)) (Xreal z)). { intros z Hz. revert Hx. simpl. case andb ; simpl. intros _. split. now rewrite F'.real_correct_false. now rewrite F'.real_correct. lra. } rewrite F.cmp_correct. rewrite F'.classify_real by easy. rewrite F'.classify_real by now rewrite F.real_correct, F.zero_correct. rewrite (F'.real_correct xu) by easy. rewrite F.zero_correct. simpl Xcmp. case Rcompare_spec ; intros Hu. * destruct (F.mul_DN_correct p52 xu (F.fromZ 2)) as [Hm1 Hm2]. { right. right. right. unfold F.is_non_pos', F.is_non_neg'. split. rewrite F'.real_correct by easy. now apply Rlt_le. rewrite F.fromZ_correct by easy. now apply IZR_le. } destruct (F.real (F.mul_DN p52 xu (F.fromZ 2))) eqn:Rp. split. now apply F'.real_correct. rewrite F'.real_correct by easy. apply Hz. revert Hm2. unfold le_lower, le_upper, F.toR. unfold Xneg. rewrite F'.real_correct by easy. rewrite F'.real_correct by easy. rewrite F.fromZ_correct by easy. simpl. lra. split. now apply F'.real_correct. rewrite F'.real_correct by easy. apply Hz. apply Rle_refl. * rewrite F.fromZ_correct by easy. apply (conj eq_refl). apply Hz. rewrite Hu. now apply IZR_le. * rewrite F.zero_correct. apply (conj eq_refl). apply Hz. now apply Rlt_le. + rewrite F.zero_correct. apply (conj eq_refl). revert Hx. simpl. case andb ; simpl. intros _. now rewrite 2!F'.real_correct_false. lra. Qed. Theorem bisect_correct : forall xi x, contains (convert xi) x -> contains (convert (fst (bisect xi))) x \/ contains (convert (snd (bisect xi))) x. Proof. intros xi x Hx. destruct (midpoint_correct xi) as [H1 H2]. { apply not_empty_contains with (1 := Hx). } unfold bisect. set (m := midpoint xi). fold m in H1, H2. clearbody m. destruct xi as [|xl xu]. now left. revert Hx. simpl. destruct x as [|x]. now case (_ && _). destruct (F.valid_lb xl). 2: simpl ; lra. destruct (F.valid_ub xu). 2: simpl ; lra. intros [H3 H4]. rewrite valid_lb_real by easy. rewrite valid_ub_real by easy. simpl. rewrite H1. destruct (Rle_or_lt x (proj_val (F.toX m))) as [H5|H5]. now left. right. split. now apply Rlt_le. exact H4. Qed. Theorem mask_correct : extension_2 Xmask mask. Proof. intros xi [|yl yu] x [|y] Hx Hy; try easy. now revert Hy; simpl; case (_ && _). Qed. Theorem mask_correct' : forall xi yi x, contains (convert xi) x -> contains (convert (mask xi yi)) x. Proof. now intros xi [|yl yu] x Hx. Qed. Definition propagate_l fi := forall xi yi : type, convert xi = Interval.Inan -> convert (fi xi yi) = Interval.Inan. Definition propagate_r fi := forall xi yi : type, convert yi = Interval.Inan -> convert (fi xi yi) = Interval.Inan. Theorem neg_correct : extension Xneg neg. Proof. intros [ | xl xu] [ | x] ; simpl ; trivial; [now case (_ && _)|]. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vu Vl (Hxl, Hxu). rewrite F'.valid_lb_neg, F'.valid_ub_neg, Vu, Vl. rewrite !F'.neg_correct. now split ; [ xreal_tac xu | xreal_tac xl ] ; apply Ropp_le_contravar. Qed. Theorem neg_correct' : forall xi x, contains (convert (neg xi)) (Xneg x) -> contains (convert xi) x. Proof. intros [|xl xu] [|x] ; try easy ; unfold convert ; simpl ; rewrite F'.valid_lb_neg, F'.valid_ub_neg, !F'.neg_correct ; [now case (_ && _)|]. rewrite andb_comm; case (_ && _); [|simpl; lra]. destruct (F.toX xl) as [|xl'] ; destruct (F.toX xu) as [|xu'] ; simpl. easy. intros [H _]. apply (conj I). now apply Ropp_le_cancel. intros [_ H]. refine (conj _ I). now apply Ropp_le_cancel. intros [H1 H2]. now split ; apply Ropp_le_cancel. Qed. Theorem abs_correct : extension Xabs abs. Proof. intros [ | xl xu] [ | x] Hx ; trivial; [ | ]. { now revert Hx; unfold convert; case (_ && _). } simpl. generalize (sign_large_correct_ _ _ _ Hx). case (sign_large_ xl xu) ; intros. { (* zero *) rewrite (proj1 H). rewrite Rabs_R0. simpl. rewrite F'.valid_lb_zero, F'.valid_ub_zero. rewrite F.zero_correct. split ; exact (Rle_refl R0). } { (* negative *) rewrite (Rabs_left1 _ (proj1 H)). exact (neg_correct _ _ Hx). } { (* positive *) rewrite (Rabs_right _ (Rle_ge _ _ (proj1 H))). exact Hx. } (* both *) clear H. simpl. rewrite F.zero_correct. rewrite F'.valid_lb_zero. assert (Vxu : F.valid_ub xu = true). { revert Hx; unfold convert; case (F.valid_ub xu); [easy|]. rewrite andb_comm; intros (H0, H1); lra. } revert Hx; unfold convert; rewrite Vxu. case_eq (F.valid_lb xl); [|now intros _ [H0 H1]; exfalso; lra]. intros Vxl [Hxl Hxu]. generalize (F.max_correct (F.neg xl) xu). generalize (F.real_correct xu) ; generalize (F.classify_correct xu) ; generalize Vxu; rewrite F.valid_ub_correct ; case (F.classify xu); try easy; intros _ H; rewrite H; clear H ; [xreal_tac xu; [easy|intros _]|xreal_tac xu; [intros _|easy]..] ; ( generalize (F.real_correct (F.neg xl)) ; generalize (F.classify_correct (F.neg xl)) ; generalize Vxl ; rewrite F'.neg_correct, <-F'.valid_ub_neg, F.valid_ub_correct ; ( case (F.classify (F.neg xl)); try easy; intros _ H; rewrite H; clear H ) ; [xreal_tac xl; [easy|intros _]|xreal_tac xl; [intros _|easy]..] ) ; simpl ; intro Hmax ; rewrite ?Hmax ; try match type of Hmax with | F.toX _ = Xreal _ => rewrite F'.valid_ub_real; [|now rewrite F.real_correct, Hmax] | F.classify ?m = _ => generalize (F.valid_ub_correct m) ; rewrite Hmax => -> end ; (* no more if valid... at this point *) ( split; [now apply Rabs_pos|] ) ; [|now generalize (F.classify_correct (F.max (F.neg xl) xu)) ; rewrite Hmax ; rewrite F.real_correct ; xreal_tac2..]. (* - upper *) apply <- Rmax_Rle. unfold Rabs. destruct (Rcase_abs x) as [H|H]. { left. apply Ropp_le_contravar. exact Hxl. } right. exact Hxu. Qed. Theorem abs_ge_0 : forall xi, not_empty (convert xi) -> convert xi <> Interval.Inan -> le_lower' (Xreal 0) (F.toX (lower (abs xi))). Proof. intros [|xl xu]. { now intros H; elim H. } intros [x Hx] _; revert Hx. unfold convert. case_eq (F.valid_lb xl); intro Vxl; [|intros [H0 H1]; lra]. case_eq (F.valid_ub xu); intro Vxu; [|intros [H0 H1]; lra]. intros [Hxl Hxu]. simpl. unfold sign_large_. rewrite 2!F.cmp_correct, F.zero_correct, F'.classify_zero. generalize Vxl Vxu. rewrite F.valid_lb_correct, F.valid_ub_correct. generalize (F.classify_correct xl) ; rewrite F.real_correct ; case_eq (F.classify xl) ; intros Cxl ; [..|easy] ; [case_eq (F.toX xl); [easy|]; intros rxl Hrxl _ _ |case_eq (F.toX xl); [|easy]; intros Hrxl _ _..] ; ( generalize (F.classify_correct xu) ; rewrite F.real_correct ; case_eq (F.classify xu) ; intros Cxu ; [..|easy|] ; [case_eq (F.toX xu); [easy|]; intros rxu Hrxu _ _ |case_eq (F.toX xu); [|easy]; intros Hrxu _ _..] ) ; unfold Xcmp ; try ( case (Rcompare_spec rxl 0) ; intros Hrxl0 ) ; try ( case (Rcompare_spec rxu 0) ; intros Hrxu0 ) ; simpl ; rewrite ?F'.neg_correct, ?F.zero_correct, ?Hrxl, ?Hrxu ; simpl ; lra. Qed. Theorem abs_ge_0' : forall xi, not_empty (convert xi) -> (0 <= proj_val (F.toX (lower (abs xi))))%R. Proof. intros [|xl xu] Hne. simpl. rewrite F'.nan_correct. apply Rle_refl. refine (_ (abs_ge_0 (Ibnd xl xu) Hne _)). 2: now unfold convert; case (_ && _). simpl. now case F.toX. Qed. Lemma abs_correct_aux : forall xl xu x, contains (convert (Ibnd xl xu)) (Xreal x) -> let xm := F.max (F.neg xl) xu in le_upper (Xreal (Rabs x)) (F.toX xm). Proof. intros xl xu x Hx xm. generalize (F.neg_correct xl). intros Hxl. generalize (F.max_correct (F.neg xl) xu). intros Hxm. destruct (F.classify xl) eqn:Hxl_eq. - generalize (F.classify_correct (F.neg xl)). rewrite F'.real_neg. rewrite (F.classify_correct xl). rewrite Hxl_eq. destruct (F.classify (F.neg xl)); [| easy..]. intros _. destruct (F.classify xu) eqn:Hxu_eq. + unfold xm. rewrite Hxm, Hxl. simpl in Hx. rewrite F.valid_lb_correct, F.valid_ub_correct in Hx. rewrite Hxl_eq, Hxu_eq in Hx. simpl in Hx. generalize (F.classify_correct xu). rewrite (F.real_correct xu). rewrite Hxu_eq. generalize (F.classify_correct xl). rewrite (F.real_correct xl). rewrite Hxl_eq. intros Hxl' Hxu'. destruct (F.toX xl), (F.toX xu); try easy. simpl. apply Rmax_Rle. destruct (Rle_or_lt 0 x). * apply Rabs_pos_eq in H. rewrite H. now right. * apply Rabs_left in H. rewrite H. lra. + unfold xm. rewrite F'.real_correct_false; [easy |]. rewrite F.classify_correct. now rewrite Hxm. + specialize (F.real_correct xm) as Hxm'. unfold xm in *. rewrite Hxm in *. rewrite F'.real_neg, F.classify_correct, Hxl_eq in Hxm'. destruct (F.toX (F.neg xl)); [easy | clear Hxm']. rewrite Hxl. simpl in Hx. rewrite F.valid_lb_correct, F.valid_ub_correct in Hx. rewrite Hxl_eq, Hxu_eq in Hx. simpl in Hx. lra. + unfold xm. rewrite F'.real_correct_false; [easy |]. rewrite F.classify_correct. now rewrite Hxm. - rewrite Hxl in Hxm. rewrite F'.real_correct_false; [easy |]. rewrite F.classify_correct. unfold xm. now rewrite Hxm. - rewrite Hxl in Hxm. now destruct (F.classify xu); rewrite F'.real_correct_false; try (rewrite F.classify_correct; unfold xm; rewrite Hxm). - rewrite Hxl in Hxm. destruct (F.classify xu) eqn:Hxu_eq. + unfold xm. rewrite Hxm. simpl in Hx. rewrite F.valid_lb_correct, F.valid_ub_correct in Hx. rewrite Hxl_eq, Hxu_eq in Hx. simpl in Hx. lra. + rewrite F'.real_correct_false; [easy |]. rewrite F.classify_correct. unfold xm. now rewrite Hxm. + unfold xm. rewrite Hxm. simpl in Hx. rewrite F.valid_lb_correct, F.valid_ub_correct in Hx. rewrite Hxl_eq, Hxu_eq in Hx. simpl in Hx. lra. + rewrite F'.real_correct_false; [easy |]. rewrite F.classify_correct. unfold xm. now rewrite Hxm. Qed. Theorem mul2_correct : forall prec xi x, contains (convert xi) x -> contains (convert (mul2 prec xi)) (Xmul x (Xreal 2)). Proof. intros prec [ | xl xu]. easy. intros [|x]; unfold convert; [now case (_ && _)|]. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl [Hxl Hxu]. simpl. unfold c2. elim (F.mul_DN_correct prec xl (F.fromZ 2)); [intros Vl Hl; rewrite Vl|]. { elim (F.mul_UP_correct prec xu (F.fromZ 2)); [intros Vu Hu; rewrite Vu|]. { split. { xreal_tac2. revert Hl; rewrite F.fromZ_correct by easy. unfold le_lower, le_upper; simpl. now xreal_tac2; simpl; [|lra]. } xreal_tac2. revert Hu; rewrite F.fromZ_correct by easy. unfold le_upper. now xreal_tac2; simpl; [|lra]. } unfold F.is_non_neg', F.is_non_pos', F.is_non_neg_real, F.is_non_pos_real. rewrite Vxu. rewrite F.fromZ_correct by easy. xreal_tac2; [now left; repeat split; lra|]. case (Rlt_or_le 0 r); intro Hr. { left; repeat split; lra. } do 2 right; left; lra. } unfold F.is_non_neg', F.is_non_pos', F.is_non_neg_real, F.is_non_pos_real. rewrite Vxl. rewrite F.fromZ_correct by easy. xreal_tac2; [now do 3 right; repeat split; lra|]. case (Rlt_or_le 0 r); intro Hr. { left; repeat split; lra. } do 3 right; repeat split; lra. Qed. Theorem add_correct : forall prec, extension_2 Xadd (add prec). Proof. intros prec [ | xl xu] [ | yl yu] [ | x] [ | y] ; trivial; [| |intros _|]; [now unfold convert; case (_ && _)..|]. unfold convert. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. case_eq (F.valid_lb yl); [|intros _ _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub yu); [|intros _ _ _ [H0 H1]; exfalso; lra]. intros Vyu Vyl. intros (Hxl, Hxu) (Hyl, Hyu). simpl. elim (F.add_DN_correct prec xl yl); [|easy..]; intros H _; rewrite H; clear H. elim (F.add_UP_correct prec xu yu); [|easy..]; intros H _; rewrite H; clear H. apply le_contains. { apply (le_lower_trans _ (Xadd (F.toX xl) (F.toX yl))); [now apply F.add_DN_correct|]. revert Hxl Hyl. xreal_tac2; [now simpl|intro Hx]. xreal_tac2; [now simpl|intro Hy]. now apply Ropp_le_contravar, Rplus_le_compat. } apply (le_upper_trans _ (Xadd (F.toX xu) (F.toX yu))); [|now apply F.add_UP_correct]. revert Hxu Hyu. xreal_tac2; [now simpl|intro Hx]. xreal_tac2; [now simpl|intro Hy]. now apply Rplus_le_compat. Qed. Theorem sub_correct : forall prec, extension_2 Xsub (sub prec). Proof. intros prec [ | xl xu] [ | yl yu] [ | x] [ | y] ; trivial; [| |intros _|]; [now unfold convert; case (_ && _)..|]. unfold convert. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. case_eq (F.valid_lb yl); [|intros _ _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub yu); [|intros _ _ _ [H0 H1]; exfalso; lra]. intros Vyu Vyl. intros (Hxl, Hxu) (Hyl, Hyu). simpl. elim (F.sub_DN_correct prec xl yu); [|easy..]; intros H _; rewrite H; clear H. elim (F.sub_UP_correct prec xu yl); [|easy..]; intros H _; rewrite H; clear H. apply le_contains. { apply (le_lower_trans _ (Xsub (F.toX xl) (F.toX yu))); [now apply F.sub_DN_correct|]. revert Hxl Hyu. xreal_tac2; [now simpl|intro Hx]. xreal_tac2; [now simpl|intro Hy]. now apply Ropp_le_contravar, Rplus_le_compat; [|apply Ropp_le_contravar]. } apply (le_upper_trans _ (Xsub (F.toX xu) (F.toX yl))); [|now apply F.sub_UP_correct]. revert Hxu Hyl. xreal_tac2; [now simpl|intro Hx]. xreal_tac2; [now simpl|intro Hy]. now apply Rplus_le_compat; [|apply Ropp_le_contravar]. Qed. Theorem sqrt_correct : forall prec, extension Xsqrt (sqrt prec). Proof. intros prec [ | xl xu] [ | x]; trivial; [now unfold convert; case (_ && _)|]. unfold convert. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. intros [Hxl Hxu]. elim (F.sqrt_UP_correct prec xu); intros Vsuxu Hsuxu. unfold sqrt; rewrite F.cmp_correct, F.zero_correct, F'.classify_zero. generalize Vxl; rewrite F.valid_lb_correct. generalize (F.classify_correct xl); rewrite F.real_correct. case_eq (F.toX xl); [|intro rl]; intro Hrl. { now case F.classify; [easy|..|easy]; intros _ _; (rewrite F'.valid_lb_zero, Vsuxu; split; [rewrite F.zero_correct; apply sqrt_pos| revert Hxu Hsuxu; case (F.toX (F.sqrt_UP _ _)); [easy|intro rsxu]; case F.toX; [easy|intro rxu]; intro Hx; apply Rle_trans, sqrt_le_1_alt]). } (* xl real *) revert Hxl. rewrite Hrl. intros Hxl. case F.classify; [|easy..]; intros _ _. unfold Xsqrt'. unfold Xcmp; case Rcompare_spec; intro Hrl0; rewrite Vsuxu; [rewrite F'.valid_lb_zero..|rewrite Bool.andb_comm]; simpl; [now split; [rewrite F.zero_correct; apply sqrt_pos|]; revert Hxu Hsuxu; case (F.toX (F.sqrt_UP _ _)); [easy|intro rsuxu]; case F.toX; [easy|intros rxu Hrxu]; apply Rle_trans, sqrt_le_1_alt..|]. (* xl positive *) elim (F.sqrt_DN_correct prec _ Vxl). intros Vslxl Hslxl. rewrite Vslxl. apply le_contains. { apply (le_lower_trans _ _ _ Hslxl). rewrite Hrl. simpl; unfold Xsqrt'. now apply Ropp_le_contravar, sqrt_le_1_alt. } revert Hsuxu. apply le_upper_trans. revert Hxu; xreal_tac2; intro Hxu; [exact I|]. simpl; unfold Xsqrt'. now apply sqrt_le_1_alt. Qed. Ltac clear_complex_aux := match goal with | H: Rle _ _ |- _ => generalize H ; clear H ; try clear_complex_aux | H: (Rle _ _) /\ _ |- _ => generalize (proj1 H) ; destruct H as (_, H) ; try clear_complex_aux | H: Rlt _ _ |- _ => generalize H ; clear H ; try clear_complex_aux | H: (Rlt _ _) /\ _ |- _ => generalize (proj1 H) ; destruct H as (_, H) ; try clear_complex_aux | H: ex (fun r : R => _ /\ _) |- _ => let a := fresh "a" in let K := fresh in destruct H as (a, (K, H)) ; injection K ; clear K ; intro K ; rewrite <- K in H ; clear K a ; try clear_complex_aux | H: _ /\ _ |- _ => destruct H as (_, H) ; try clear_complex_aux | H: _ |- _ => clear H ; try clear_complex_aux end. Ltac clear_complex := clear_complex_aux ; clear ; intros. Local Hint Resolve Rlt_le : mulauto. Local Hint Resolve Rle_trans : mulauto. Local Hint Resolve Rmult_le_compat_l : mulauto. Local Hint Resolve Rmult_le_compat_r : mulauto. Local Hint Resolve Rmult_le_compat_neg_l : mulauto. Local Hint Resolve Rmult_le_compat_neg_r : mulauto. Theorem mul_mixed_correct : forall prec yf, extension (fun x => Xmul x (F.toX yf)) (fun xi => mul_mixed prec xi yf). Proof. intros prec yf [|xl xu] [|x]; trivial; [now unfold convert; case (_ && _)|]. unfold convert. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. intros (Hxl, Hxu). simpl. generalize (F.classify_correct yf). rewrite F.cmp_correct, F.zero_correct, F.real_correct, F'.classify_zero. case_eq (F.classify yf); intro Cyf; [xreal_tac2; [easy|]|xreal_tac2; [|easy]..]; intros _; [|easy..]. unfold Xcmp. case Rcompare_spec; intro Hr. { elim (F.mul_DN_correct prec xu yf). { intros Vl Hl; rewrite Vl. elim (F.mul_UP_correct prec xl yf). { intros Vu Hu; rewrite Vu. apply le_contains. { apply (le_lower_trans _ _ _ Hl). rewrite X. revert Hxu; xreal_tac2; [now simpl|]; intro Hx. now apply Ropp_le_contravar, Rmult_le_compat_neg_r; [apply Rlt_le|]. } revert Hu; apply le_upper_trans. rewrite X. revert Hxl; xreal_tac2; [now simpl|]; intro Hx. now apply Rmult_le_compat_neg_r; [apply Rlt_le|]. } unfold F.is_non_neg', F.is_non_pos', F.is_non_pos_real, F.is_non_neg_real. rewrite X. case (F.toX xl). { right; left. split. easy. now apply Rlt_le. } intro r'; case (Rlt_or_le 0 r'); intro Hr'. { now do 3 right; split; apply Rlt_le. } right; left. split. easy. now apply Rlt_le. } unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_pos', F.is_non_neg'. rewrite X. case (F.toX xu). { right; right; left. split. easy. now apply Rlt_le. } intro r'; case (Rlt_or_le 0 r'); intro Hr'. { now do 2 right; left; split; apply Rlt_le. } right; left. split. easy. now apply Rlt_le. } { rewrite Hr, Rmult_0_r. rewrite F'.valid_lb_real, ?F'.valid_ub_real; [|now rewrite F.real_correct, F.zero_correct..]. now apply le_contains; rewrite F.zero_correct; right. } elim (F.mul_DN_correct prec xl yf). { intros Vl Hl; rewrite Vl. elim (F.mul_UP_correct prec xu yf). { intros Vu Hu; rewrite Vu. apply le_contains. { apply (le_lower_trans _ _ _ Hl). rewrite X. revert Hxl; xreal_tac2; [now simpl|]; intro Hx. now apply Ropp_le_contravar, Rmult_le_compat_r; [apply Rlt_le|]. } revert Hu; apply le_upper_trans. rewrite X. revert Hxu; xreal_tac2; [now simpl|]; intro Hx. now apply Rmult_le_compat_r; [apply Rlt_le|]. } unfold F.is_non_neg', F.is_non_pos', F.is_non_pos_real, F.is_non_neg_real. rewrite X. case (F.toX xu). { left. split. easy. now apply Rlt_le. } intro r'; case (Rlt_or_le 0 r'); intro Hr'. { left. now split; apply Rlt_le. } do 2 right; left. split. easy. now apply Rlt_le. } unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_pos', F.is_non_neg'. rewrite X. case (F.toX xl). { do 3 right. split. easy. now apply Rlt_le. } intro r'; case (Rlt_or_le 0 r'); intro Hr'. { now left; split; apply Rlt_le. } do 3 right. split. easy. now apply Rlt_le. Qed. Theorem mul_correct : forall prec, extension_2 Xmul (mul prec). Proof. intros prec [ | xl xu] [ | yl yu] [ | x] [ | y] ; trivial; [| |intros _|]; [now unfold convert; case (_ && _)..|]. intros Hxlu Hylu. generalize Hxlu Hylu. unfold convert. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. case_eq (F.valid_lb yl); [|intros _ _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub yu); [|intros _ _ _ [H0 H1]; exfalso; lra]. intros Vyu Vyl. intros (Hxl, Hxu) (Hyl, Hyu). simpl. unfold bnd, contains, convert. (* case study on sign of xi *) generalize (sign_large_correct_ xl xu x Hxlu). case (sign_large_ xl xu) ; intros (Hx0, Hx0') ; (* case study on sign of yi *) try ( generalize (sign_large_correct_ yl yu y Hylu) ; case (sign_large_ yl yu) ; intros (Hy0, Hy0') ) ; (* remove trivial comparisons with zero *) try ( rewrite F'.valid_lb_real, ?F'.valid_ub_real; [|now rewrite F.real_correct, F.zero_correct..] ; simpl ; try ( rewrite Hx0 ; rewrite Rmult_0_l ) ; try ( rewrite Hy0 ; rewrite Rmult_0_r ) ; split ; rewrite F.zero_correct ; apply Rle_refl ) ; (* most cases *) try ( match goal with | |- context [F.valid_lb (F.mul_DN ?prec ?x ?y)] => elim (F'.mul_DN_correct prec x y); [intros Vl Hl; rewrite Vl| unfold F.is_non_neg_real, F.is_non_pos_real; unfold F.is_non_neg, F.is_non_pos] end ; [ match goal with | |- context [F.valid_ub (F.mul_UP ?prec ?x ?y)] => elim (F'.mul_UP_correct prec x y); [intros Vu Hu; rewrite Vu| unfold F.is_non_neg_real, F.is_non_pos_real; unfold F.is_non_neg, F.is_non_pos] end|] ; [split; match goal with | |- context [F.toX (F.mul_DN ?prec ?x ?y)] => xreal_tac2; revert Hl; (xreal_tac x; [now simpl|]); (xreal_tac y; [now simpl|]); (let H := fresh "H" in intro H; apply Ropp_le_cancel in H; apply (Rle_trans _ _ _ H); clear H) | |- context [F.toX (F.mul_UP ?prec ?x ?y)] => xreal_tac2; revert Hu; (xreal_tac x; [now simpl|]); (xreal_tac y; [now simpl|]); apply Rle_trans end ; clear_complex; (* solve by transivity *) try ( eauto with mulauto ; fail ) | |] ; try (destruct Hx0' as (Hx0', (rHx0, (Hx0'', Hx0'''))); rewrite Hx0'') ; try (destruct Hy0' as (Hy0', (rHy0, (Hy0'', Hy0'''))); rewrite Hy0'') ; try (now left); try (now (right; left)); try (now (right; right; left)); try (now (right; right; right)) ). (* multiplication around zero *) elim (F'.mul_DN_correct prec xl yu); [intros Vxlyu Hxlyu |now (try (now left); try (now (right; left)); try (now (right; right; left)); try (now (right; right; right)))]. elim (F'.mul_DN_correct prec xu yl); [intros Vxuyl Hxuyl |now (try (now left); try (now (right; left)); try (now (right; right; left)); try (now (right; right; right)))]. elim (F'.mul_UP_correct prec xl yl); [intros Vxlyl Hxlyl |now (try (now left); try (now (right; left)); try (now (right; right; left)); try (now (right; right; right)))]. elim (F'.mul_UP_correct prec xu yu); [intros Vxuyu Hxuyu |now (try (now left); try (now (right; left)); try (now (right; right; left)); try (now (right; right; right)))]. elim (F'.min_valid_lb _ _ Vxlyu Vxuyl). intros Vmin Hmin. elim (F'.max_valid_ub _ _ Vxlyl Vxuyu). intros Vmax Hmax. rewrite Vmin, Vmax, Hmin, Hmax. split. { do 2 xreal_tac2. simpl; apply <-Rmin_Rle. destruct (Rle_or_lt x 0) as [Hx|Hx]; [left|right; generalize (Rlt_le _ _ Hx); clear Hx; intro Hx]; [revert Hxlyu; xreal_tac xl; [now simpl|]; xreal_tac yu; [now simpl|] |revert Hxuyl; xreal_tac xu; [now simpl|]; xreal_tac yl; [now simpl|]]; (let H := fresh "H" in intro H; apply Ropp_le_cancel in H; apply (Rle_trans _ _ _ H); clear H); clear_complex ; eauto with mulauto. } do 2 xreal_tac2. simpl; apply <-Rmax_Rle. destruct (Rle_or_lt x 0) as [Hx|Hx]; [left|right; generalize (Rlt_le _ _ Hx); clear Hx; intro Hx]; [revert Hxlyl; xreal_tac xl; [now simpl|]; xreal_tac yl; [now simpl|] |revert Hxuyu; xreal_tac xu; [now simpl|]; xreal_tac yu; [now simpl|]]; apply Rle_trans; clear_complex ; eauto with mulauto. Qed. Ltac simpl_is_zero := let X := fresh "X" in match goal with | H: Rlt ?v 0 |- context [is_zero ?v] => destruct (is_zero_spec v) as [X|X] ; [ rewrite X in H ; elim (Rlt_irrefl _ H) | idtac ] | H: Rlt 0 ?v |- context [is_zero ?v] => destruct (is_zero_spec v) as [X|X] ; [ rewrite X in H ; elim (Rlt_irrefl _ H) | idtac ] | H: Rlt ?v 0 /\ _ |- context [is_zero ?v] => destruct (is_zero_spec v) as [X|X] ; [ rewrite X in H ; elim (Rlt_irrefl _ (proj1 H)) | idtac ] (*rewrite (Rcompare_correct_lt _ _ (proj1 H))*) | H: _ /\ (Rlt ?v 0 /\ _) |- context [is_zero ?v] => destruct (is_zero_spec v) as [X|X] ; [ rewrite X in H ; elim (Rlt_irrefl _ (proj1 (proj2 H))) | idtac ] (*rewrite (Rcompare_correct_lt _ _ (proj1 (proj2 H)))*) | H: Rlt 0 ?v /\ _ |- context [is_zero ?v] => destruct (is_zero_spec v) as [X|X] ; [ rewrite X in H ; elim (Rlt_irrefl _ (proj1 H)) | idtac ] (*rewrite (Rcompare_correct_gt _ _ (proj1 H))*) | H: _ /\ (Rlt 0 ?v /\ _) |- context [is_zero ?v] => destruct (is_zero_spec v) as [X|X] ; [ rewrite X in H ; elim (Rlt_irrefl _ (proj1 (proj2 H))) | idtac ] (*rewrite (Rcompare_correct_gt _ _ (proj1 (proj2 H)))*) end. Local Hint Resolve Rinv_lt_0_compat : mulauto. Local Hint Resolve Rinv_0_lt_compat : mulauto. Local Hint Resolve Rle_Rinv_pos : mulauto. Local Hint Resolve Rle_Rinv_neg : mulauto. Local Hint Resolve Rlt_le : mulauto2. Local Hint Resolve Rinv_lt_0_compat : mulauto2. Local Hint Resolve Rinv_0_lt_compat : mulauto2. Local Hint Resolve Rmult_le_pos_pos : mulauto2. Local Hint Resolve Rmult_le_neg_pos : mulauto2. Local Hint Resolve Rmult_le_pos_neg : mulauto2. Local Hint Resolve Rmult_le_neg_neg : mulauto2. Theorem div_mixed_r_correct : forall prec yf, extension (fun x => Xdiv x (F.toX yf)) (fun xi => div_mixed_r prec xi yf). Proof. intros prec yf [| xl xu] [| x]; trivial; [now unfold convert; case (_ && _)|]. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl. intros [Hxl Hxu]. simpl. generalize (F.classify_correct yf). rewrite F.cmp_correct, F.zero_correct, F.real_correct, F'.classify_zero. case_eq (F.classify yf); intro Cyf; [xreal_tac2; [easy|]|xreal_tac2; [|easy]..]; intros _; [|easy..]. unfold Xcmp. unfold Xdiv'. simpl. case Rcompare_spec ; intros Hy ; try exact I ; simpl; simpl_is_zero. { elim (F.div_DN_correct prec xu yf); [intros Vl Hl|]; last first. { unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real. left. split. now destruct (F.toX xu). now rewrite X. } elim (F.div_UP_correct prec xl yf); [intros Vu Hu|]; last first. { unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real. right. split. now destruct F.toX. now rewrite X. } rewrite Vl, Vu. split. { revert Hl; rewrite X. xreal_tac (F.div_DN prec xu yf); [now simpl|]. revert Hxu; xreal_tac xu; [now simpl|]; intro Hxu. unfold Xdiv, Xdiv'; simpl_is_zero. intro H; apply Ropp_le_cancel in H; revert H. unfold Rdiv ; eauto with mulauto. } revert Hu; rewrite X. xreal_tac (F.div_UP prec xl yf); [now simpl|]. revert Hxl; xreal_tac xl; [now simpl|]; intro Hxl. unfold Xdiv, Xdiv'; simpl_is_zero. unfold Rdiv ; eauto with mulauto. } elim (F.div_DN_correct prec xl yf); [intros Vl Hl|]; last first. { unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real. right. split. now destruct (F.toX xl). now rewrite X. } elim (F.div_UP_correct prec xu yf); [intros Vu Hu|]; last first. { unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real. left. split. now destruct (F.toX xu). now rewrite X. } rewrite Vl, Vu. split. { revert Hl; rewrite X. xreal_tac (F.div_DN prec xl yf); [now simpl|]. revert Hxl; xreal_tac xl; [now simpl|]; intro Hxl. unfold Xdiv, Xdiv'; simpl_is_zero. intro H; apply Ropp_le_cancel in H; revert H. unfold Rdiv ; eauto with mulauto. } revert Hu; rewrite X. xreal_tac (F.div_UP prec xu yf); [now simpl|]. revert Hxu; xreal_tac xu; [now simpl|]; intro Hxu. unfold Xdiv, Xdiv'; simpl_is_zero. unfold Rdiv ; eauto with mulauto. Qed. Theorem div_correct : forall prec, extension_2 Xdiv (div prec). Proof. intros prec [ | xl xu] [ | yl yu] [ | x] [ | y] ; try ( intros ; exact I ) ; [now unfold convert; case (_ && _).. |now unfold convert at 2; case (_ && _)|]. intros Hxlu Hylu. generalize Hxlu Hylu. unfold convert at -3. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl [Hxl Hxu]. case_eq (F.valid_lb yl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub yu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vyu Vyl [Hyl Hyu]. simpl. unfold bnd, contains, convert, Xdiv'. (* case study on sign of xi *) generalize (sign_strict_correct_ xl xu x Hxlu) ; case (sign_strict_ xl xu) ; intros (Hx0, Hx0') ; (* case study on sign of yi *) try ( generalize (sign_strict_correct_ yl yu y Hylu) ; case (sign_strict_ yl yu) ; intros (Hy0, Hy0') ) ; try exact I ; try simpl_is_zero ; unfold Rdiv ; (* remove trivial comparisons with zero *) try ( rewrite F'.valid_lb_real, ?F'.valid_ub_real; [|now rewrite F.real_correct, F.zero_correct..] ; simpl ; try ( rewrite Hx0 ; rewrite Rmult_0_l ) ; split ; rewrite F.zero_correct ; apply Rle_refl ) ; (* simplify Fdivz *) try ( (unfold Fdivz_DN || unfold Fdivz_UP) ; rewrite F.real_correct ; xreal_tac3 yl ; xreal_tac3 yu ; try rewrite F.zero_correct ) ; try ( rewrite (F'.valid_lb_real F.zero) ; [|now rewrite F.real_correct, F.zero_correct] ) ; try ( rewrite (F'.valid_ub_real F.zero) ; [|now rewrite F.real_correct, F.zero_correct] ) ; try ( destruct Hy0' as (_, (rHy0', (Hy0', _))) ; match type of Hy0' with | F.toX ?x = Xreal _ => match goal with | H : F.toX x = Xnan |- _ => rewrite H in Hy0' end end ; discriminate ) ; try match goal with | |- context [F.valid_lb (F.div_DN ?prec ?x ?y)] => elim (F.div_DN_correct prec x y); [intros Vl Hl; rewrite Vl| unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real ] ; rewrite ?F.real_correct end ; try match goal with | |- context [F.valid_ub (F.div_UP ?prec ?x ?y)] => elim (F.div_UP_correct prec x y); [intros Vu Hu; rewrite Vu| unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real ] ; rewrite ?F.real_correct end ; try split ; (* solve by comparing to zero *) try ( clear_complex ; simpl ; eauto with mulauto2 ; fail ) ; try match goal with | |- context [F.toX (F.div_UP ?prec ?x ?y)] => xreal_tac2; revert Hu ; xreal_tac3 x; (try now simpl) ; xreal_tac3 y; (try now simpl) ; unfold Xdiv, Xdiv', Rdiv ; match goal with |- context [is_zero ?v] => case (is_zero v) ; [now simpl|] end ; apply Rle_trans ; clear_complex ; (* solve by transivity *) eauto 8 with mulauto | |- context [F.toX (F.div_DN ?prec ?x ?y)] => xreal_tac2; revert Hl ; xreal_tac3 x; (try now simpl) ; xreal_tac3 y; (try now simpl) ; unfold Xdiv, Xdiv', Rdiv ; match goal with |- context [is_zero ?v] => case (is_zero v) ; [now simpl|] end ; (let H := fresh "H" in intro H; apply Ropp_le_cancel in H; apply (Rle_trans _ _ _ H); clear H) ; clear_complex ; (* solve by transivity *) eauto 8 with mulauto end ; repeat match goal with | H:F.toX _ = _ |- _ => (try rewrite H) ; clear H end ; try destruct Hx0' as (Hx0', (rHx0, (Hx0'', Hx0'''))) ; try rewrite Hx0'' ; try apply Rlt_le in Hx0''' ; try destruct Hy0' as (Hy0', (rHy0, (Hy0'', Hy0'''))) ; try rewrite Hy0'' ; try ( match type of Hx0' with | context [F.toX ?x] => revert Hx0'; xreal_tac x; intro Hx0' end ) ; try apply Rlt_le in Hx0' ; try rewrite X0 ; try rewrite X1 ; try inversion Hy0'' ; try (now left) ; try (now right ; destruct (F.toX xl)) ; try (now (right; left)) ; try (now (right; right; left)) ; try (now (right; right; right)). Qed. Theorem inv_correct : forall prec, extension Xinv (inv prec). Proof. intros prec [ | xl xu] [ | x] ; try ( intros ; exact I ) ; [now unfold convert; case (_ && _)|]. intros Hxlu. generalize Hxlu. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl [Hxl Hxu]. simpl. unfold bnd, contains, convert, Xinv'. (* case study on sign of xi *) generalize (sign_strict_correct_ xl xu x Hxlu). unfold c1. case (sign_strict_ xl xu) ; (intros (Hx0, (Hx0', (rHx0, (Hx0'', Hx0''')))) || intros (Hx0, Hx0')) ; try exact I ; try simpl_is_zero ; unfold Rdiv ; (* simplify Fdivz *) try ( (unfold Fdivz_DN, Fdivz_UP) ; rewrite 2!F.real_correct ; xreal_tac3 xl ; xreal_tac3 xu ; try rewrite F.zero_correct ) ; try ( rewrite (F'.valid_lb_real F.zero) ; [|now rewrite F.real_correct, F.zero_correct] ) ; try ( rewrite (F'.valid_ub_real F.zero) ; [|now rewrite F.real_correct, F.zero_correct] ) ; try match goal with | |- context [F.valid_lb (F.div_DN ?prec ?x ?y)] => elim (F.div_DN_correct prec x y); [intros Vl Hl; rewrite Vl| unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real ] ; rewrite ?F.real_correct end ; try match goal with | |- context [F.valid_ub (F.div_UP ?prec ?x ?y)] => elim (F.div_UP_correct prec x y); [intros Vu Hu; rewrite Vu| unfold F.is_real_ub, F.is_real_lb, F.is_neg_real, F.is_pos_real ] ; rewrite ?F.real_correct end ; try split ; (* solve by comparing to zero *) try ( clear_complex ; simpl ; eauto with mulauto2 ; fail ) ; try match goal with | |- context [F.toX (F.div_UP ?prec ?x ?y)] => xreal_tac2; revert Hu ; rewrite F.fromZ_correct by easy ; xreal_tac3 y; (try now simpl) ; unfold Xdiv, Xdiv', Rdiv ; rewrite Rmult_1_l ; match goal with |- context [is_zero ?v] => case (is_zero v) ; [now simpl|] end ; apply Rle_trans ; try (revert Hxl; rewrite Hx0'') ; auto with mulauto | |- context [F.toX (F.div_DN ?prec ?x ?y)] => xreal_tac2; revert Hl ; rewrite F.fromZ_correct by easy ; xreal_tac3 y; (try now simpl) ; unfold Xdiv, Xdiv', Rdiv ; rewrite Rmult_1_l ; match goal with |- context [is_zero ?v] => case (is_zero v) ; [now simpl|] end ; (let H := fresh "H" in intro H; apply Ropp_le_cancel in H; apply (Rle_trans _ _ _ H); clear H) ; try (revert Hxu; rewrite Hx0'') ; auto with mulauto end ; repeat match goal with | H:F.toX _ = _ |- _ => (try rewrite H) ; clear H end ; try rewrite F.fromZ_correct by easy ; try ( rewrite (F'.valid_lb_real (F.fromZ 1)) ; [|now rewrite F.real_correct, F.fromZ_correct] ) ; try ( rewrite (F'.valid_ub_real (F.fromZ 1)) ; [|now rewrite F.real_correct, F.fromZ_correct] ) ; set (H01 := Rlt_le _ _ Rlt_0_1) ; try (now left) ; try (now right) ; try (now (right; left)) ; try (now (right; right; left)) ; try (now (right; right; right)). Qed. Theorem invnz_correct : forall prec xi x, x <> Xreal 0 -> contains (convert xi) x -> contains (convert (invnz prec xi)) (Xinv x). Proof. intros prec xi x Zx Bx. generalize (inv_correct prec xi x Bx). unfold inv, invnz. destruct xi as [| xl xu] ; try easy. destruct (sign_strict_ xl xu) ; try easy. intros _. destruct x as [|x]. { revert Bx. simpl. now case (_ && _). } unfold Xinv, Xinv'. rewrite is_zero_false. 2: contradict Zx ; now rewrite Zx. generalize (sign_large_correct_ xl xu x Bx). case sign_large_ ; try easy. - intros [H1 [H2 H3]]. simpl. rewrite F'.valid_lb_nan. unfold Fdivz_UP. rewrite F.real_correct. destruct F.toX as [|xlr] eqn:Hxl. + rewrite F'.valid_ub_zero. split. now rewrite F'.nan_correct. rewrite F.zero_correct. apply Rlt_le, Rinv_lt_0_compat. now destruct H1 as [H1 | ->]. + assert (Hx: (xlr <= x)%R). { revert Bx. simpl. rewrite valid_lb_real by now rewrite Hxl. destruct H3 as [xur [Hxu _]]. rewrite valid_ub_real by now rewrite Hxu. rewrite Hxl. now intros [H _]. } assert (Hxlr: (xlr < 0)%R). { apply Rle_lt_trans with (1 := Hx). now destruct H1 as [H1 | ->]. } destruct (F.div_UP_correct prec c1 xl) as [-> H]. * unfold F.is_real_lb, F.is_neg_real, c1. right. split. now rewrite F.fromZ_correct. now rewrite Hxl. * split. now rewrite F'.nan_correct. destruct (F.toX (F.div_UP prec c1 xl)) as [|yur]. easy. revert H. unfold c1. rewrite F.fromZ_correct by easy. rewrite Hxl. simpl. unfold Xdiv'. rewrite is_zero_false. apply Rle_trans. unfold Rdiv. rewrite Rmult_1_l. apply Rle_Rinv_neg with (2 := Hx). now destruct H1 as [H1 | ->]. now apply Rlt_not_eq. - intros [H1 [H2 H3]]. simpl. rewrite F'.valid_ub_nan. unfold Fdivz_DN. rewrite F.real_correct. destruct F.toX as [|xur] eqn:Hxu. + rewrite F'.valid_lb_zero. split. 2: now rewrite F'.nan_correct. rewrite F.zero_correct. apply Rlt_le, Rinv_0_lt_compat. now destruct H1 as [H1 | <-]. + assert (Hx: (x <= xur)%R). { revert Bx. simpl. rewrite valid_ub_real by now rewrite Hxu. destruct H3 as [xlr [Hxl _]]. rewrite valid_lb_real by now rewrite Hxl. rewrite Hxu. now intros [_ H]. } assert (Hxur: (0 < xur)%R). { apply Rlt_le_trans with (2 := Hx). now destruct H1 as [H1 | <-]. } destruct (F.div_DN_correct prec c1 xu) as [-> H]. * unfold F.is_real_lb, F.is_pos_real, c1. right. split. now rewrite F.fromZ_correct. now rewrite Hxu. * split. 2: now rewrite F'.nan_correct. destruct (F.toX (F.div_DN prec c1 xu)) as [|ylr]. easy. revert H. unfold c1. rewrite F.fromZ_correct by easy. rewrite Hxu. simpl. unfold Xdiv'. rewrite is_zero_false. intros H. apply Rle_trans with (1 := Ropp_le_cancel _ _ H). unfold Rdiv. rewrite Rmult_1_l. apply Rle_Rinv_pos with (2 := Hx). now destruct H1 as [H1 | <-]. now apply Rgt_not_eq. Qed. Theorem sqr_correct : forall prec, extension Xsqr (sqr prec). Proof. intros prec [ | xl xu] [ | x] ; try ( intros ; exact I ) ; [now unfold convert; case (_ && _)|]. intros Hxlu. generalize Hxlu. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vxu Vxl [Hxl Hxu]. simpl. unfold bnd, contains, convert. (* case study on sign of xi *) generalize (sign_large_correct_ xl xu x Hxlu). unfold Rsqr. case (sign_large_ xl xu) ; intros [Hx0 Hx0'] ; [|revert Hx0'; intros [Hxl0 [rxu [Hrxu Hrxu0]]]..|] ; (* remove trivial comparisons with zero *) try ( rewrite F'.valid_lb_real, ?F'.valid_ub_real; [|now rewrite F.real_correct, F.zero_correct..] ; simpl ; try ( rewrite Hx0 ; rewrite Rmult_0_l ) ; split ; rewrite F.zero_correct ; apply Rle_refl ) ; rewrite ?F.cmp_correct, ?F.zero_correct ; rewrite ?F'.classify_zero, ?F'.valid_lb_zero ; try match goal with | |- context [F.mul_DN ?prec ?x ?y] => elim (F.mul_DN_correct prec x x); [intros Vmdn Hmdn| unfold F.is_non_neg_real, F.is_non_neg, F.is_non_pos_real, F.is_non_pos ; rewrite Hrxu ; try ( now left ) ; now right ; left] ; generalize Vmdn ; rewrite ?F.valid_lb_correct, ?F.valid_ub_correct ; case_eq (F.classify (F.mul_DN prec x x)) ; intros Cmdn; try easy; intros _ ; generalize (F.classify_correct (F.mul_DN prec x x)) ; rewrite F.real_correct, Cmdn ; [xreal_tac2; [easy|]; intros _|xreal_tac2; [|easy]; intros _..] ; unfold Xcmp ; try ( case Rcompare_spec ; intros Hr ) ; rewrite ?F'.valid_lb_zero, ?F.valid_lb_correct, ?Cmdn ; rewrite ?F.zero_correct end ; try match goal with | |- context [ F.mul_UP prec ?x ?y ] => elim (F'.mul_UP_correct prec x x) ; [intros Vmdu Hmdu| now rewrite ?Vxl, ?Vxu ; try ( now left ) ; now right ; left] ; rewrite Vmdu ; split end ; try apply Rle_0_sqr ; try ( generalize Hmdu ; unfold le_upper ; xreal_tac2; [easy|] ; xreal_tac2; [easy|] ; simpl ; clear_complex ; (* solve by transivity *) eauto with mulauto ; fail ) ; try ( generalize Hmdn ; unfold le_lower, le_upper ; simpl ; xreal_tac2 ; simpl; xreal_tac2 ; intro H; apply Ropp_le_cancel in H; revert H ; try ( revert Hxu; rewrite Hrxu ) ; try ( revert Hxl; rewrite Hrxu ) ; clear_complex ; (* solve by transivity *) eauto with mulauto ; fail ). (* multiplication around zero *) simpl. destruct (F.abs_correct xl) as [Haxl Vaxl]. destruct (F'.max_valid_ub _ _ Vaxl Vxu) as [Vmax Hmax]. elim (F'.mul_UP_correct prec (F.max (F.abs xl) xu) (F.max (F.abs xl) xu)). 2:{ unfold F.is_non_neg, F.is_non_pos, F.is_non_neg_real, F.is_non_pos_real. rewrite Vmax, Hmax, Haxl. left. split; (split; [exact eq_refl|]); revert Hx0'; (xreal_tac xu; case (Xabs (F.toX xl)); [now simpl..|]); intros r' Hr; apply (Rle_trans _ _ _ Hr), Rmax_r. } intros Vu Hu. rewrite Vu. split; [apply Rle_0_sqr|]. revert Hu. unfold le_upper. xreal_tac2; [easy|]. rewrite Hmax, Haxl. do 2 ( xreal_tac2; [easy|] ) ; simpl. apply Rle_trans. rewrite (Rabs_left1 _ Hx0). case (Rle_lt_dec 0 x); intro Hx. { now apply (Rmult_le_compat _ _ _ _ Hx Hx); rewrite Rmax_Rle; right. } rewrite <-(Ropp_involutive (x * x)). rewrite Ropp_mult_distr_l, Ropp_mult_distr_r. now apply Rmult_le_compat; try (now rewrite <-Ropp_0; apply Ropp_le_contravar, Rlt_le); rewrite Rmax_Rle; left; apply Ropp_le_contravar. Qed. Lemma Fpower_pos_up_correct : forall prec x n, F.valid_ub x = true -> le_upper (Xreal 0) (F.toX x) -> F.valid_ub (Fpower_pos_UP prec x n) = true /\ le_upper (Xpower_int (F.toX x) (Zpos n)) (F.toX (Fpower_pos_UP prec x n)). Proof. intros prec x n Vx Hx. set (p := Fpower_pos_UP prec x n). cut (F.valid_ub p = true /\ le_upper (Xreal 0) (F.toX p) /\ le_upper (Xpower_int (F.toX x) (Z.pos n)) (F.toX p)). { now simpl. } unfold p; clear p. revert x Vx Hx; induction n; intros x Vx Hx; last first. { do 2 (split; [now simpl|]). simpl. xreal_tac x. now simpl; rewrite Rmult_1_r; right. } { assert (Vxx : F.valid_ub (F.mul_UP prec x x) = true). { now apply F'.mul_UP_correct; left. } assert (Hxx : le_upper (Xreal 0) (F.toX (F.mul_UP prec x x))). { apply (le_upper_trans _ (Xmul (F.toX x) (F.toX x))). { now xreal_tac2; apply Rmult_le_pos. } now apply F'.mul_UP_correct; left. } do 2 (split; [now apply (IHn _ Vxx Hxx)|]). generalize (proj2 (proj2 (IHn _ Vxx Hxx))). apply le_upper_trans. generalize (Xpower_int_correct (Z.pos n) (F.toX (F.mul_UP prec x x))). xreal_tac2; (case (Xpower_int _ _); [intros _; exact I|]); intros r1' Hr1'; [now simpl|]. rewrite <-Hr1'. xreal_tac2. { cut (le_upper (Xnan * Xnan)%XR (Xreal r)); [now simpl|]. rewrite <-X0, <-X. now apply F'.mul_UP_correct; left. } simpl. rewrite Pos2Nat.inj_xO. rewrite pow_sqr. apply pow_incr; split; [now apply Rmult_le_pos|]. change (_ <= _)%R with (le_upper (Xmul (Xreal r0) (Xreal r0)) (Xreal r)). rewrite <-X0, <-X. now apply F'.mul_UP_correct; left; rewrite <-X0 in Hx. } assert (Vxx : F.valid_ub (F.mul_UP prec x x) = true). { now apply F'.mul_UP_correct; left. } assert (Hxx : le_upper (Xreal 0) (F.toX (F.mul_UP prec x x))). { apply (le_upper_trans _ (Xmul (F.toX x) (F.toX x))). { now xreal_tac2; apply Rmult_le_pos. } now apply F'.mul_UP_correct; left. } elim (F'.mul_UP_correct prec x (Fpower_pos_UP prec (F.mul_UP prec x x) n)). { intros Vu Hu. split; [now simpl; rewrite Vu|]. split. { revert Hu; apply le_upper_trans. do 2 xreal_tac2. apply Rmult_le_pos; [now simpl|]. change (_ <= _)%R with (le_upper (Xreal 0) (Xreal r0)). rewrite <-X0. now apply IHn. } revert Hu. apply le_upper_trans. revert Hx; xreal_tac2; [now simpl|]; intro Hr. xreal_tac2. simpl. rewrite Pmult_nat_mult, Nat.mul_comm. apply (Rmult_le_compat_l _ _ _ Hr). rewrite pow_sqr. change (_ <= _)%R with (le_upper (Xreal ((r * r) ^ Pos.to_nat n)) (Xreal r0)). rewrite <-X0. apply (le_upper_trans _ (Xpower_int (F.toX (F.mul_UP prec x x)) (Z.pos n))). { generalize (Xpower_int_correct (Z.pos n) (F.toX (F.mul_UP prec x x))). xreal_tac2; (case (Xpower_int _ _); [intros _; exact I|]); intros r1' Hr1'; [now simpl|]. rewrite <-Hr1'. apply pow_incr; split; [now apply Rmult_le_pos|]. change (_ <= _)%R with (le_upper (Xmul (Xreal r) (Xreal r)) (Xreal r1)). rewrite <-X, <-X1; apply F'.mul_UP_correct. left. unfold F.is_non_neg. now rewrite F'.valid_ub_real, X; [|rewrite F.real_correct, X]. } now apply IHn. } left. split; [now simpl|]. now split; now apply IHn. Qed. Lemma Fpower_pos_dn_correct : forall prec x n, le_lower' (Xreal 0) (F.toX x) -> F.valid_lb (Fpower_pos_DN prec x n) = true /\ le_lower' (F.toX (Fpower_pos_DN prec x n)) (Xpower_int (F.toX x) (Zpos n)). Proof. intros prec x n. xreal_tac2; [now simpl|]. simpl. intro Hx. set (p := Fpower_pos_DN prec x n). cut (F.valid_lb p = true /\ le_lower' (F.toX p) (Xreal (r ^ Pos.to_nat n))). { now simpl. } unfold p; clear p. revert x r X Hx. unfold le_lower'. induction n ; intros x rx Hrx Hx ; simpl; last first. { split. { now rewrite F'.valid_lb_real; [|rewrite F.real_correct, Hrx]. } now rewrite Hrx, Rmult_1_r; right. } { rewrite F.cmp_correct, F.zero_correct, F'.classify_zero. elim (F.mul_DN_correct prec x x); [|now left; unfold F.is_non_neg_real; rewrite Hrx]. intros Vmdn Hmdn. generalize Vmdn; rewrite F.valid_lb_correct. case F.classify; [..|easy]; intros _. 2: now rewrite F'.valid_lb_nan, F'.nan_correct. 2: { rewrite F'.valid_lb_zero, F.zero_correct; split; [easy|]. rewrite Pos2Nat.inj_xO, pow_sqr. apply pow_le, Rle_0_sqr. } unfold Xcmp. xreal_tac2; [now rewrite F'.valid_lb_nan, F'.nan_correct|]. case Rcompare_spec; intro Hr0; [rewrite F'.valid_lb_zero, F.zero_correct; split; [easy|] ; rewrite Pos2Nat.inj_xO, pow_sqr ; apply pow_le, Rle_0_sqr..|]. rewrite Pos2Nat.inj_xO, pow_sqr. generalize (IHn _ _ X (Rlt_le _ _ Hr0)). intros [Vp Hp]; split; [exact Vp|]. revert Hp; xreal_tac2; [easy|]; intro Hp. apply (Rle_trans _ _ _ Hp). apply pow_incr. split; [now left|]. apply Ropp_le_cancel. change (_ <= _)%R with (le_lower (Xreal r) (Xmul (Xreal rx) (Xreal rx))). now rewrite <-Hrx. } rewrite F.cmp_correct, F.zero_correct, F'.classify_zero. elim (F.mul_DN_correct prec x x); [|now left; unfold F.is_non_neg_real; rewrite Hrx]. intros Vmdn Hmdn. generalize Vmdn; rewrite F.valid_lb_correct. case F.classify; [..|easy]; intros _. 2: now rewrite F'.valid_lb_nan, F'.nan_correct. 2: { rewrite F'.valid_lb_zero, F.zero_correct; split; [easy|]. apply (Rmult_le_pos _ _ Hx). rewrite Pmult_nat_mult, Nat.mul_comm, pow_sqr. apply pow_le, Rle_0_sqr. } unfold Xcmp. xreal_tac2; [now rewrite F'.valid_lb_nan, F'.nan_correct|]. case Rcompare_spec; intro Hr0; [rewrite F'.valid_lb_zero, F.zero_correct; split; [easy|]; apply (Rmult_le_pos _ _ Hx); rewrite Pmult_nat_mult, Nat.mul_comm, pow_sqr; apply pow_le, Rle_0_sqr..|]. elim (IHn _ _ X (Rlt_le _ _ Hr0)). intros Vp Hp. elim (F'.mul_DN_correct prec x (Fpower_pos_DN prec (F.mul_DN prec x x) n)). 2:{ unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg, F.is_non_pos. rewrite Hrx, F'.valid_ub_real, Vp; [|now rewrite F.real_correct, Hrx]. xreal_tac2; [now right; right; left|]. now case (Rle_or_lt 0 r0); intro H0r0; [left|right; right; left; repeat split; lra]. } intros Vxp Hxp; split; [easy|]. revert Hxp; rewrite Hrx. do 2 (xreal_tac2; [easy|]). unfold le_lower; intro H; apply Ropp_le_cancel in H. apply (Rle_trans _ _ _ H); clear H. apply (Rmult_le_compat_l _ _ _ Hx). apply (Rle_trans _ _ _ Hp). rewrite Pmult_nat_mult, Nat.mul_comm, pow_sqr. apply pow_incr; split; [now apply Rlt_le|]. rewrite Hrx in Hmdn. now apply Ropp_le_cancel in Hmdn. Qed. Theorem power_pos_correct : forall prec n, extension (fun x => Xpower_int x (Zpos n)) (fun x => power_pos prec x n). Proof. intros prec n [ | xl xu] [ | x] ; try ( intros ; exact I ) ; [now unfold convert; case (_ && _)|]. intros Hxlu. generalize Hxlu. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. unfold contains, convert, power_pos, Xpower_int. intros Vxu Vxl [Hxl Hxu]. generalize (sign_large_correct_ xl xu x Hxlu). case (sign_large_ xl xu) ; intros Hx0 ; simpl in Hx0. { rewrite F.zero_correct. simpl. rewrite (proj1 Hx0), pow_i. rewrite F'.valid_lb_real, ?F'.valid_ub_real; [|now rewrite F.real_correct, F.zero_correct..]. split ; apply Rle_refl. apply lt_O_nat_of_P. } { assert (Hxl_pos : le_upper (Xreal 0) (F.toX (F.abs xl))). { rewrite (proj1 (F.abs_correct _)). now xreal_tac2; apply Rabs_pos. } assert (Hxu_pos : le_lower' (Xreal 0) (F.toX (F.abs xu))). { destruct Hx0 as (_, (_, (rHx0, (Hx0, _)))). rewrite (proj1 (F.abs_correct _)), Hx0. apply Rabs_pos. } generalize (Fpower_pos_up_correct prec _ n (proj2 (F.abs_correct xl)) Hxl_pos). generalize (Fpower_pos_dn_correct prec _ n Hxu_pos). destruct n as [n|n|]. { rewrite !F'.neg_correct, F'.valid_lb_neg, F'.valid_ub_neg. intros (Vpow_DN, Hpow_DN) (Vpow_UP, Hpow_UP). rewrite Vpow_UP, Vpow_DN. split. { revert Hpow_UP. unfold le_upper. rewrite (proj1 (F.abs_correct _)). xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. intros H. apply Ropp_le_contravar in H. apply Rle_trans with (1 := H). rewrite Rabs_left1; [|now apply Hx0]. rewrite Ropp_mult_distr_l_reverse, Ropp_involutive. change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO at 2. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. apply Rle_trans with (r0 * (-x) ^ nat_of_P (xO n))%R. { apply Rmult_le_compat_neg_l; [now apply Hx0|]. apply pow_incr. now split; [rewrite <- Ropp_0|]; apply Ropp_le_contravar. } apply Rmult_le_compat_r; [|exact Hxl]. apply pow_le. rewrite <- Ropp_0. now apply Ropp_le_contravar. } revert Hpow_DN. unfold le_lower'. rewrite (proj1 (F.abs_correct _)). xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. intros H'. apply Ropp_le_contravar in H'. apply Rle_trans with (2 := H'). assert (Hr0 : (r0 <= 0)%R). { destruct Hx0 as (_,(_,(ru,(H1,H2)))). now inversion H1. } rewrite Rabs_left1 with (1 := Hr0). rewrite Ropp_mult_distr_l_reverse, Ropp_involutive. change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO at 1. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. apply Rle_trans with (x * (-r0) ^ nat_of_P (xO n))%R. { apply Rmult_le_compat_neg_l. apply Hx0. apply pow_incr. now split; [rewrite <- Ropp_0|]; apply Ropp_le_contravar. } apply Rmult_le_compat_r; [|exact Hxu]. apply pow_le. rewrite <- Ropp_0. now apply Ropp_le_contravar. } { intros (Vpow_DN, Hpow_DN) (Vpow_UP, Hpow_UP). rewrite Vpow_UP, Vpow_DN. split. { revert Hpow_DN. unfold le_lower'. rewrite (proj1 (F.abs_correct _)). xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. intros H. apply Rle_trans with (1 := H). assert (Hr0 : (r0 <= 0)%R). { destruct Hx0 as (_,(_,(ru,(H1,H2)))). now inversion H1. } rewrite Rabs_left1 with (1 := Hr0). change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO at 2. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. apply pow_incr. now split; [rewrite <- Ropp_0|]; apply Ropp_le_contravar. } revert Hpow_UP. unfold le_upper. rewrite (proj1 (F.abs_correct _)). xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. intros H. apply Rle_trans with (2 := H). rewrite Rabs_left1; [|now apply Hx0]. change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO at 1. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. apply pow_incr. now split; [rewrite <- Ropp_0|]; apply Ropp_le_contravar. } intros _ _. rewrite Vxl, Vxu. now simpl; split; xreal_tac2; rewrite Rmult_1_r. } { assert (Hxl_pos : le_lower' (Xreal 0) (F.toX xl)). { destruct Hx0 as (_, (_, (rHx0, (Hx0, Hx0')))). now rewrite Hx0. } assert (Hxu_pos : le_upper (Xreal 0) (F.toX xu)). { apply Hx0. } generalize (Fpower_pos_up_correct prec _ n Vxu Hxu_pos). generalize (Fpower_pos_dn_correct prec _ n Hxl_pos). intros (Vpow_DN, Hpow_DN) (Vpow_UP, Hpow_UP). rewrite Vpow_UP, Vpow_DN. split. { revert Hpow_DN. unfold le_lower'. xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. intros H. assert (Hr0: (0 <= r0)%R). { destruct Hx0 as (_,(_,(rl,(H1,H2)))). now inversion H1. } apply Rle_trans with (1 := H). apply pow_incr. now split. } revert Hpow_UP. unfold le_upper. xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. intros H. refine (Rle_trans _ _ _ _ H). apply pow_incr. now split. } destruct n as [n|n|]. { assert (Hxl_pos : le_upper (Xreal 0) (F.toX (F.abs xl))). { rewrite (proj1 (F.abs_correct _)). now xreal_tac2; apply Rabs_pos. } assert (Hxu_pos : le_upper (Xreal 0) (F.toX xu)). { apply Hx0. } generalize (Fpower_pos_up_correct prec _ n~1 (proj2 (F.abs_correct xl)) Hxl_pos). generalize (Fpower_pos_up_correct prec _ n~1 Vxu Hxu_pos). rewrite F'.neg_correct, F'.valid_lb_neg. intros (Vpow_DN, Hpow_DN) (Vpow_UP, Hpow_UP). rewrite Vpow_UP, Vpow_DN. split. { revert Hpow_UP. unfold le_upper. rewrite (proj1 (F.abs_correct _)). xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. rewrite Rabs_left1; [|now apply Hx0]. intros H. apply Ropp_le_contravar in H. apply Rle_trans with (1 := H). rewrite Ropp_mult_distr_l_reverse, Ropp_involutive. destruct (Rle_or_lt x 0) as [Hx|Hx]. { change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO at 2. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. apply Rle_trans with (r0 * (-x) ^ nat_of_P (xO n))%R. { apply Rmult_le_compat_neg_l. { apply Hx0. } apply pow_incr. now split; [rewrite <- Ropp_0|]; apply Ropp_le_contravar. } apply Rmult_le_compat_r; [|exact Hxl]. apply pow_le. rewrite <- Ropp_0. now apply Ropp_le_contravar. } apply Rlt_le in Hx. apply Rle_trans with 0%R. { apply Ropp_le_cancel. rewrite Ropp_0, <- Ropp_mult_distr_l_reverse. now apply Rmult_le_pos; [|apply pow_le]; rewrite <- Ropp_0; apply Ropp_le_contravar. } apply Rmult_le_pos with (1 := Hx). now apply pow_le. } revert Hpow_DN. unfold le_upper. xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. intros H. refine (Rle_trans _ _ _ _ H). destruct (Rle_or_lt x 0) as [Hx|Hx]. { apply Rle_trans with 0%R. { apply Ropp_le_cancel. rewrite Ropp_0, <- Ropp_mult_distr_l_reverse. change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. now apply Rmult_le_pos; [|apply pow_le]; rewrite <- Ropp_0; apply Ropp_le_contravar. } apply Rmult_le_pos; [now apply Hx0|]. now apply pow_le. } apply Rlt_le in Hx. apply Rmult_le_compat with (1 := Hx). { now apply pow_le. } { exact Hxu. } apply pow_incr. now split. } { elim (F'.max_valid_ub _ _ (proj2 (F.abs_correct xl)) Vxu). intros Vmax Hmax. assert (Hxu_pos : le_upper (Xreal 0) (F.toX (F.max (F.abs xl) xu))). { rewrite Hmax. rewrite (proj1 (F.abs_correct _)). xreal_tac xl; xreal_tac xu. apply (Rle_trans _ _ _ (proj2 Hx0)), Rmax_r. } generalize (Fpower_pos_up_correct prec _ n~0 Vmax Hxu_pos). intros (Vpow_UP, Hpow_UP). rewrite Vpow_UP. rewrite F'.valid_lb_real; [|now rewrite F.real_correct, F.zero_correct]. split. { rewrite F.zero_correct. rewrite nat_of_P_xO. rewrite pow_sqr. change (x * x)%R with (Rsqr x). simpl. apply pow_le. apply Rle_0_sqr. } revert Hpow_UP. unfold le_upper. rewrite Hmax. rewrite (proj1 (F.abs_correct _)). xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. xreal_tac2; [now simpl|]. simpl. intros H. assert (Hr: (0 <= Rmax (Rabs r0) r1)%R). { apply Rmax_case. { apply Rabs_pos. } apply Hx0. } apply Rle_trans with (2 := H). destruct (Rle_or_lt x 0) as [Hx|Hx]. { change (Pmult_nat n 2) with (nat_of_P (xO n)). rewrite nat_of_P_xO at 1. rewrite pow_sqr. rewrite <- (Rmult_opp_opp x x). rewrite <- pow_sqr, <- nat_of_P_xO. apply pow_incr. split. { rewrite <- Ropp_0. now apply Ropp_le_contravar. } apply Rle_trans with (2 := Rmax_l _ _). rewrite Rabs_left1. { now apply Ropp_le_contravar. } apply Hx0. } apply pow_incr. split. { now apply Rlt_le. } now apply Rle_trans with (2 := Rmax_r _ _). } rewrite Vxl, Vxu. now split; xreal_tac2; simpl; rewrite Rmult_1_r. Qed. Theorem power_int_correct : forall prec n, extension (fun x => Xpower_int x n) (fun x => power_int prec x n). Proof. intros prec [|n|n]. { unfold power_int, Xpower_int. intros [ | xl xu] [ | x] ; try ( intros ; exact I ) ; [now unfold convert; case (_ && _)|]. intros _. simpl. unfold c1. rewrite F.fromZ_correct by easy. rewrite F'.valid_lb_real, ?F'.valid_ub_real; [|now rewrite F.real_correct, F.fromZ_correct..]. split ; apply Rle_refl. } { apply power_pos_correct. } intros xi x Hx. generalize (power_pos_correct prec n _ _ Hx). intros Hp. generalize (inv_correct prec _ _ Hp). unfold Xpower_int, Xpower_int', Xinv', Xbind, power_int. destruct x as [ | x]; [easy|]. replace (is_zero x) with (is_zero (x ^ nat_of_P n)); [easy|]. case (is_zero_spec x) ; intros Zx. { rewrite Zx, pow_i. { apply is_zero_0. } apply lt_O_nat_of_P. } case is_zero_spec ; try easy. intros H. elim (pow_nonzero _ _ Zx H). Qed. Lemma mask_propagate_l : propagate_l mask. Proof. intros xi yi; destruct xi; destruct yi; easy. Qed. Lemma mask_propagate_r : propagate_r mask. Proof. intros xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma add_propagate_l : forall prec, propagate_l (add prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma sub_propagate_l : forall prec, propagate_l (sub prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma mul_propagate_l : forall prec, propagate_l (mul prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma div_propagate_l : forall prec, propagate_l (div prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma add_propagate_r : forall prec, propagate_r (add prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma sub_propagate_r : forall prec, propagate_r (sub prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma mul_propagate_r : forall prec, propagate_r (mul prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma div_propagate_r : forall prec, propagate_r (div prec). Proof. intros prec xi yi; destruct xi; destruct yi; [easy..|]. now unfold convert; case (_ && _). Qed. Lemma nearbyint_correct : forall mode, extension (Xnearbyint mode) (nearbyint mode). Proof. intros mode [|xl xu] [|xr] ; try ( intros ; exact I ) ; [now unfold convert; case (_ && _)|]. simpl. intros Hlu. generalize Hlu. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; exfalso; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; exfalso; lra]. intros Vu Vl [Hl Hu]. unfold convert. rewrite (proj1 (F.nearbyint_DN_correct _ _)). rewrite (proj1 (F.nearbyint_UP_correct _ _)). split. { xreal_tac2. generalize (F.nearbyint_DN_correct mode xl). rewrite X. unfold le_lower, le_upper; simpl. xreal_tac2; [easy|]; simpl. intros [_ H]. now apply (Rle_trans _ _ _ (Ropp_le_cancel _ _ H)), Rnearbyint_le. } xreal_tac2. generalize (F.nearbyint_UP_correct mode xu). rewrite X. unfold le_upper; simpl. xreal_tac2; [easy|]; simpl. intros [_ H]. now revert H; apply Rle_trans, Rnearbyint_le. Qed. Lemma error_aux_correct_aux : forall prec mode fexp e x, Generic_fmt.Valid_exp fexp -> (Ulp.ulp radix2 fexp x <= bpow radix2 e)%R -> contains (convert (error_aux prec mode e)) (Xreal (Generic_fmt.round radix2 fexp (rnd_of_mode mode) x - x)) /\ contains (convert (error_aux prec mode e)) (Xreal 0). Proof. intros prec mode fexp e x Ve Hx. unfold error_aux. set (e' := match mode with rnd_NE => Z.pred e | _ => e end). set (err := F.pow2_UP prec (F.ZtoS e')). assert (mode = rnd_NE \/ e' = e) as [-> | ->] by now (destruct mode ; left + right). - destruct (F.pow2_UP_correct prec (F.ZtoS e')) as [Hp1 Hp2]. generalize (F.ZtoS_correct prec e'). fold err in Hp1, Hp2 |- *. simpl. rewrite F'.valid_lb_neg, Hp1, F'.neg_correct. destruct (F.toX err) as [ |er]. easy. intros [Hs|Hs] ; [|easy]. simpl. simple refine (let H := _ in conj H _). 2: { apply Rabs_le in H. apply Rabs_le_inv. apply Rle_trans with (2 := H). rewrite Rabs_R0. apply Rabs_pos. } apply Rabs_le_inv. apply Rle_trans with (2 := Hp2). eapply Rle_trans. now apply Ulp.error_le_half_ulp. rewrite Rmult_1_l. apply Rle_trans with (bpow radix2 (e - 1)). 2: now apply bpow_le. unfold Z.sub. rewrite Zplus_comm, bpow_plus. apply Rmult_le_compat_l with (2 := Hx). apply bpow_ge_0. - destruct (F.pow2_UP_correct prec (F.ZtoS e)) as [Hp1 Hp2]. generalize (F.ZtoS_correct prec e). fold err in Hp1, Hp2 |- *. assert (Hp3 := F'.valid_lb_neg err). rewrite Hp1 in Hp3. destruct (F.toX err) as [ |er] eqn:He. { intros _. destruct mode ; simpl ; rewrite ?Hp1, ?Hp3, ?F'.valid_lb_zero, ?F'.valid_ub_zero ; simpl ; rewrite ?F'.neg_correct, ?F.zero_correct, He ; simpl ; try easy ; repeat split ; try apply Rle_refl. apply Rle_0_minus. now apply Generic_fmt.round_UP_pt. apply Rle_minus. now apply Generic_fmt.round_DN_pt. } intros [Hs|Hs] ; [|easy]. assert (- er <= Generic_fmt.round radix2 fexp (rnd_of_mode mode) x - x <= er)%R. { apply Rabs_le_inv. eapply Rle_trans. apply Ulp.error_le_ulp. exact Ve. apply valid_rnd_of_mode. apply Rle_trans with (2 := Hp2). rewrite Rmult_1_l. apply Rle_trans with (1 := Hx). now apply bpow_le. } assert (H1 := Rabs_le _ _ H). assert (H2 := Rle_trans _ _ _ (Rabs_pos _) H1). destruct mode ; simpl ; rewrite ?Hp1, ?Hp3, ?F'.valid_lb_zero, ?F'.valid_ub_zero ; simpl ; rewrite ?F'.neg_correct, ?F.zero_correct, He ; simpl ; split ; try apply Rabs_le_inv ; try split ; try rewrite Rabs_R0 ; try easy ; try apply Rle_refl ; try apply H. apply Rle_0_minus. now apply Generic_fmt.round_UP_pt. apply Rle_minus. now apply Generic_fmt.round_DN_pt. rewrite <- Ropp_0. now apply Ropp_le_contravar. Qed. Lemma error_fix_correct_aux : forall prec mode emin xi x, contains (convert xi) x -> contains (convert (error_fix prec mode emin xi)) (Xerror_fix mode emin x) /\ contains (convert (error_fix prec mode emin xi)) (Xreal 0). Proof. intros prec mode emin [|xl xu] [|xr]; try easy; [now unfold convert; case (_ && _)|]. intros _. cbn -[error_aux]. refine (_ (error_aux_correct_aux prec mode (FIX.FIX_exp emin) emin xr _ _)). now destruct error_aux. rewrite FIX.ulp_FIX. apply Rle_refl. Qed. Lemma error_fix_correct : forall prec mode emin, extension (Xerror_fix mode emin) (error_fix prec mode emin). Proof. unfold extension. intros. now apply error_fix_correct_aux. Qed. Lemma error_fix_contains_0 : forall prec mode emin x, not_empty (convert x) -> contains (convert (error_fix prec mode emin x)) (Xreal 0). Proof. intros prec mode emin x [v Hv]. unfold error_fix. assert (H := fun emin => proj2 (error_fix_correct_aux prec mode emin _ _ Hv)). destruct mode ; apply H. Qed. Lemma error_flt_correct_aux : forall prec mode emin p xi x, contains (convert xi) x -> contains (convert (error_flt prec mode emin p xi)) (Xerror_flt mode emin p x) /\ contains (convert (error_flt prec mode emin p xi)) (Xreal 0). Proof. intros prec mode emin p [|xl xu] [|xr]; try easy; [now unfold convert; case (_ && _)|]. cbn -[error_aux]. case_eq (F.valid_lb xl); [| simpl; lra]. case_eq (F.valid_ub xu); [| simpl; lra]. simpl. intros Vu Vl [Hl Hu]. generalize (abs_correct_aux xl xu xr). unfold convert. rewrite Vu, Vl. set (xu' := F.max (F.neg xl) xu). intros Hr. assert (Vu' : F.valid_ub xu' = true). { apply F'.max_valid_ub; [| easy]. now rewrite F'.valid_ub_neg. } simple refine (let Hx := Hr _ in _). now split. clearbody xu' Hx. clear -Hx Vu'. destruct F.real eqn:Ru'. 2: easy. case Z.eqb_spec. 2: easy. intros R2. cbv [andb]. apply F'.real_correct in Ru'. rewrite Ru' in Hx. simpl in Hx. set (e := FLT.FLT_exp emin (Z.pos p) (F.StoZ (F.mag xu'))). refine (_ (error_aux_correct_aux prec mode (FLT.FLT_exp emin (Z.pos p)) e xr _ _)). now destruct error_aux. now apply FLT.FLT_exp_valid. unfold Ulp.ulp. case Req_bool_spec ; intros Hxr. { destruct (@FLT.negligible_exp_FLT emin (Z.pos p) eq_refl) as [n [-> H]]. unfold e, FLT.FLT_exp. rewrite Z.max_r by lia. apply bpow_le, Z.le_max_r. } apply bpow_le, Generic_fmt.cexp_le_bpow ; try easy. apply FLT.FLT_exp_monotone. apply Rle_lt_trans with (1 := Hx). rewrite <- (Rabs_pos_eq (F.toR xu')). 2: apply Rle_trans with (2 := Hx), Rabs_pos. generalize (F.mag_correct xu'). unfold bpow. now rewrite R2. Qed. Lemma error_flt_correct : forall prec mode emin p, extension (Xerror_flt mode emin p) (error_flt prec mode emin p). Proof. unfold extension. intros. now apply error_flt_correct_aux. Qed. Lemma error_flt_contains_0 : forall prec mode emin p x, not_empty (convert x) -> contains (convert (error_flt prec mode emin p x)) (Xreal 0). Proof. intros prec mode emin p x [v Hv]. unfold error_flt. assert (H := fun emin p => proj2 (error_flt_correct_aux prec mode emin p _ _ Hv)). destruct mode ; apply H. Qed. Definition valid_lb_nan := F'.valid_lb_nan. Definition valid_ub_nan := F'.valid_ub_nan. End FloatInterval. interval-4.11.1/src/Interval/Float_full.v000066400000000000000000001023711470547631300202710ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Psatz. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Require Import Float. Require Import Transcend. Module FloatIntervalFull (F'' : FloatOps with Definition sensible_format := true) <: IntervalOps. Module T := TranscendentalFloatFast F''. Include T.I. Definition c3 := F.fromZ 3. Definition c4 := F.fromZ 4. Definition c8 := F.fromZ 8. Definition pi prec := mul2 prec (mul2 prec (T.pi4 prec)). Lemma pi_correct : forall prec, contains (convert (pi prec)) (Xreal PI). Proof. intros prec. unfold pi. replace (Xreal PI) with (Xmul (Xreal (PI/4)) (Xreal (Raux.bpow radix2 2))). change (Xreal (Raux.bpow _ _)) with (Xreal 2 * Xreal 2)%XR. rewrite <-Xmul_assoc. do 2 apply mul2_correct. apply T.pi4_correct. change (Raux.bpow _ _) with 4%R. simpl. apply f_equal. field. Qed. (* accurate only for |xi| <= 2 * pi *) Definition cos prec xi := match abs xi with | Ibnd xl xu => if F'.le' xu xl then T.cos_fast prec xl else let pi4 := T.pi4 prec in if F'.le' xu (F.mul_DN prec (lower pi4) c4) then bnd (lower (T.cos_fast prec xu)) (upper (T.cos_fast prec xl)) else if F'.le' xu (F.mul_DN prec (lower pi4) c8) then if F'.le' (F.mul_UP prec (upper pi4) c4) xl then bnd (lower (T.cos_fast prec xl)) (upper (T.cos_fast prec xu)) else bnd cm1 (F.max (upper (T.cos_fast prec xl)) (upper (T.cos_fast prec xu))) else let d := F.sub_UP prec xu xl in if F'.le' d c3 then let m := F.midpoint xl xu in let d := F.max (F.sub_UP prec xu m) (F.sub_UP prec m xl) in let c := T.cos_fast prec m in meet (bnd cm1 c1) (add prec c (bnd (F.neg d) d)) else bnd cm1 c1 | Inan => Inan end. Lemma cos_correct : forall prec, extension Xcos (cos prec). Proof. intros prec xi x Hx. unfold cos. generalize (abs_correct xi x Hx) (abs_ge_0' xi). destruct (abs xi) as [|xl xu]; [easy|]. destruct x as [|x]. { now simpl; case (_ && _)%bool. } unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hxl Hxu]. intros Hal. simpl in Hal. assert (H : not_empty (convert xi)). { now exists x. } specialize (Hal H); clear H. unfold Xbind. replace (Rtrigo_def.cos x) with (Rtrigo_def.cos (Rabs x)). 2: now unfold Rabs ; case Rcase_abs ; intros _ ; try easy ; apply cos_neg. clear Hx. assert (Hcxl := T.cos_fast_correct prec xl). assert (Hcxu := T.cos_fast_correct prec xu). case_eq (F'.le' xu xl). { intros Hl. apply F'.le'_correct in Hl. destruct (F.toX xu) as [|xur] ; [easy|]. destruct (F.toX xl) as [|xlr] ; [easy|]. replace (Rabs x) with xlr. { exact Hcxl. } apply Rle_antisym. { easy. } now apply Rle_trans with (2 := Hl). } intros _. unfold cm1, c1, c3, c4, c8. assert (Hlb'_cos : F.valid_lb (lower (T.cos_fast prec xl)) = true). { generalize Hcxl. unfold T.I.convert. case (T.cos_fast prec xl). { now simpl; rewrite F'.valid_lb_nan. } simpl. intros l u. case (F.valid_lb l); [easy|]. now simpl; case F.toX; [|intros r [H0 H1]; lra]. } assert (Hub'_cos : F.valid_ub (upper (T.cos_fast prec xu)) = true). { generalize Hcxu. unfold T.I.convert. case (T.cos_fast prec xu). { now simpl; rewrite F'.valid_ub_nan. } simpl. intros l u. rewrite Bool.andb_comm. case (F.valid_ub u); [easy|]. now simpl; case F.toX; [|intros r [H0 H1]; lra]. } assert (Hub_cos : F.valid_ub (upper (T.cos_fast prec xl)) = true). { generalize Hcxl. unfold T.I.convert. case (T.cos_fast prec xl). { now simpl; rewrite F'.valid_ub_nan. } simpl. intros l u; rewrite Bool.andb_comm. case (F.valid_ub u); [easy|]. now simpl; case F.toX; [|intros r [H0 H1]; lra]. } assert (Hlb_cos : F.valid_lb (lower (T.cos_fast prec xu)) = true). { generalize Hcxu. unfold T.I.convert. case (T.cos_fast prec xu). { now simpl; rewrite F'.valid_lb_nan. } simpl. intros l u. now case (F.valid_lb l); [|simpl; case Xcos; [|intros r [H0 H1]; lra]]. } case_eq (F'.le' xu (F.mul_DN prec (lower (T.pi4 prec)) (F.fromZ 4))). { intros Hu. apply F'.le'_correct in Hu. destruct (F.toX xu) as [|xur] ; try easy. assert (Hxur: (xur <= PI)%R). { revert Hu. elim (F.mul_DN_correct prec (lower (T.pi4 prec)) (F.fromZ 4)). 2:{ unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg', F.is_non_pos'. rewrite F.fromZ_correct by easy. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4. { simpl; intros _; do 3 right; rewrite F'.valid_lb_nan, F'.nan_correct. repeat split; lra. } intros l u; simpl. rewrite F.valid_lb_correct. case F.classify; [..|intros [H0 H1]; lra]; intros _; (case F.toX; [now do 3 right; repeat split; lra|]; intro rl); (case (Rle_or_lt 0 rl); intro Hrl; [now left; repeat split; lra|do 3 right; repeat split; lra]). } intros Vmdn. unfold le_lower, le_upper. case F.toX; [easy|]; intro Rmdn; simpl. rewrite F.fromZ_correct by easy. generalize (T.pi4_correct prec). destruct (T.pi4 prec) as [|pi4l pi4u] ; simpl. { now rewrite F'.nan_correct. } case (_ && _)%bool; [|intros [H0 H1]; lra]. case F.toX; [easy|]; intro pi4r. simpl. intros [H _] Hu. apply Ropp_le_cancel in Hu. intro H'; apply (Rle_trans _ _ _ H'); clear H'. apply Rle_trans with (1 := Hu). lra. } clear Hu. unfold convert; simpl. rewrite Hlb_cos; simpl. rewrite Hub_cos; simpl. split. { destruct (T.cos_fast prec xu) as [|cu cu'] ; simpl. { now rewrite F'.nan_correct. } generalize Hcxu; unfold T.I.convert; case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [Hcu _]. destruct (F.toX cu) as [|cur] ; [easy|]. apply Rle_trans with (1 := Hcu). apply cos_decr_1 with (4 := Hxur). { apply Rabs_pos. } { now apply Rle_trans with xur. } { revert Hxu; apply Rle_trans, Rabs_pos. } exact Hxu. } generalize (T.cos_fast_correct prec xl). unfold T.I.convert. case_eq (T.cos_fast prec xl); [now simpl; rewrite F'.nan_correct|]. intros cl' cl Hcl. generalize Hub_cos; rewrite Hcl; simpl=> ->. generalize Hlb'_cos; rewrite Hcl; simpl=> ->; simpl. destruct (F.toX xl) as [|xlr] ; [easy|]. intros [_ Hl]. destruct (F.toX cl) as [|clr] ; [easy|]. apply Rle_trans with (2 := Hl). apply cos_decr_1 with (1 := Hal). { apply Rle_trans with (2 := Hxur). now apply Rle_trans with (Rabs x). } { apply Rabs_pos. } { now apply Rle_trans with xur. } apply Hxl. } intros _. case_eq (F'.le' xu (F.mul_DN prec (lower (T.pi4 prec)) (F.fromZ 8))). { intros Hu. apply F'.le'_correct in Hu. destruct (F.toX xu) as [|xur] ; [easy|]. assert (Hxur: (xur <= 2 * PI)%R). { revert Hu. elim (F.mul_DN_correct prec (lower (T.pi4 prec)) (F.fromZ 8)). 2:{ unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg', F.is_non_pos'. rewrite F.fromZ_correct by easy. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4. { simpl; intros _; do 3 right; rewrite F'.valid_lb_nan, F'.nan_correct. repeat split; lra. } intros l u; simpl. rewrite F.valid_lb_correct. case F.classify; [..|intros [H0 H1]; lra]; intros _; (case F.toX; [now do 3 right; repeat split; lra|]; intro rl); (case (Rle_or_lt 0 rl); intro Hrl; [now left; repeat split; lra|do 3 right; repeat split; lra]). } intros Vmdn. unfold le_lower, le_upper. case F.toX; [easy|]; intro rmdn; simpl. rewrite F.fromZ_correct by easy. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4; [now simpl; rewrite F'.nan_correct|]; intros l u. case (_ && _)%bool; [|intros [H0 H1]; lra]. simpl. case F.toX; simpl; [easy|]. intros rlpi4 [Hrlpi4 _]. lra. } clear Hu. case_eq (F'.le' (F.mul_UP prec (upper (T.pi4 prec)) (F.fromZ 4)) xl). { intros Hl. apply F'.le'_correct in Hl. destruct (F.toX xl) as [|xlr]. { now destruct (F.toX (F.mul_UP prec (upper (T.pi4 prec)) (F.fromZ 4))). } assert (Hxlr: (PI <= xlr)%R). { revert Hl. elim (F.mul_UP_correct prec (upper (T.pi4 prec)) (F.fromZ 4)). 2:{ left ; unfold F.is_non_neg' ; split. clear. assert (H := T.pi4_correct prec). rewrite T.I.valid_ub_upper, T.I.upper_correct by (eexists ; exact H). destruct T.I.convert as [|l [|u]] ; try easy. apply Rle_trans with (2 := proj2 H). apply Rlt_le, PI4_RGT_0. rewrite F.fromZ_correct by easy. now apply IZR_le. } intros Vmup. rewrite F.fromZ_correct by easy. unfold le_upper. case F.toX; [easy|]; intro rmup. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4; [now simpl; rewrite F'.nan_correct|]; intros l u. case (_ && _)%bool; [|intros [H0 H1]; lra]. simpl. case (F.toX u); simpl; [easy|]. intros rupi4 [_ Hrupi4]. lra. } clear Hl. simpl. rewrite Hlb'_cos, Hub'_cos. split. { destruct (T.cos_fast prec xl) as [|cl cl'] ; simpl. { now rewrite F'.nan_correct. } revert Hcxl. unfold T.I.convert. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [Hcl _]. destruct (F.toX cl) as [|clr] ; [easy|]. apply Rle_trans with (1 := Hcl). apply cos_incr_1 with (1 := Hxlr) (5 := Hxl). { apply Rle_trans with (2 := Hxur). apply Rle_trans with (1 := Hxl) (2 := Hxu). } { apply Rle_trans with (1 := Hxlr) (2 := Hxl). } apply Rle_trans with (1 := Hxu) (2 := Hxur). } destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl. { now rewrite F'.nan_correct. } revert Hcxu. unfold T.I.convert. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [_ Hcu]. destruct (F.toX cu) as [|cur] ; [easy|]. apply Rle_trans with (2 := Hcu). apply cos_incr_1 with (4 := Hxur) (5 := Hxu). { apply Rle_trans with (1 := Hxlr) (2 := Hxl). } { apply Rle_trans with (1 := Hxu) (2 := Hxur). } apply Rle_trans with (1 := Hxlr). apply Rle_trans with (1 := Hxl) (2 := Hxu). } intros _. unfold convert. simpl; rewrite F'.valid_lb_real. 2: now rewrite F.real_correct, F.fromZ_correct; [..|lia]. generalize (F'.max_valid_ub _ _ Hub_cos Hub'_cos). intros [Vmax Hmax]. rewrite Vmax, Hmax. split. { rewrite F.fromZ_correct by easy. apply COS_bound. } destruct (T.cos_fast prec xl) as [|cl' cl] ; simpl. { now rewrite F'.nan_correct. } revert Hcxl. unfold T.I.convert; simpl. simpl in Hlb'_cos. rewrite Hlb'_cos. simpl in Hub_cos. rewrite Hub_cos. simpl. destruct (F.toX xl) as [|xlr] ; [easy|]. intros [_ Hcl]. destruct (F.toX cl) as [|clr] ; [easy|]. destruct (T.cos_fast prec xu) as [|cu' cu] ; simpl. { now rewrite F'.nan_correct. } revert Hcxu. unfold T.I.convert. simpl in Hub'_cos. rewrite Hub'_cos. simpl in Hlb_cos. rewrite Hlb_cos. simpl. intros [_ Hcu]. destruct (F.toX cu) as [|cur] ; [easy|]. destruct (Rle_dec (Rabs x) PI) as [Hx|Hx]. { apply Rle_trans with (2 := Rmax_l _ _). apply Rle_trans with (2 := Hcl). apply cos_decr_1 with (1 := Hal) (3 := Rabs_pos _) (4 := Hx) (5 := Hxl). apply Rle_trans with (1 := Hxl) (2 := Hx). } apply Rle_trans with (2 := Rmax_r _ _). apply Rle_trans with (2 := Hcu). apply Rnot_le_lt, Rlt_le in Hx. apply cos_incr_1 with (1 := Hx) (4 := Hxur) (5 := Hxu). { apply Rle_trans with (1 := Hxu) (2 := Hxur). } apply Rle_trans with (1 := Hx) (2 := Hxu). } intros _. case_eq (F'.le' (F.sub_UP prec xu xl) (F.fromZ 3)). { intros Hd. apply F'.le'_correct in Hd. revert Hd. elim (F.sub_UP_correct prec xu xl); [|easy..]. intros Vsup. unfold le_upper. case F.toX; [easy|]; intro rsup. rewrite F.fromZ_correct by easy. case_eq (F.toX xu) ; [easy|] ; intros xur Hur. case_eq (F.toX xl) ; [easy|] ; intros xlr Hlr. rewrite Hur in Hxu. rewrite Hlr in Hxl. intros Hsup Hrsup3. simpl in Hsup. apply meet_correct. { unfold convert, bnd. rewrite F'.valid_ub_real, F'.valid_lb_real by now rewrite F.real_correct, F.fromZ_correct. rewrite 2!F.fromZ_correct by easy. apply COS_bound. } elim (F.midpoint_correct xl xu); [|easy|now rewrite F.real_correct, ?Hlr, ?Hur.. |now unfold F.toR; rewrite Hlr, Hur; apply (Rle_trans _ _ _ Hxl)]. set (m := F.midpoint xl xu). intros Rm [Hlm Hum]. replace (Xreal (Rtrigo_def.cos (Rabs x))) with (Xadd (Xcos (Xreal (F.toR m))) (Xreal (Rtrigo_def.cos (Rabs x) - Rtrigo_def.cos (F.toR m)))) by (apply (f_equal Xreal) ; ring). apply add_correct. { generalize (T.cos_fast_correct prec m). now rewrite (F'.real_correct _ Rm). } simpl. rewrite F'.valid_lb_neg. rewrite F'.neg_correct. elim (F.sub_UP_correct prec xu m); [|easy|now generalize (F.classify_correct m); rewrite Rm, F.valid_lb_correct; case F.classify]. intros Vsxum Hsxum. elim (F.sub_UP_correct prec m xl); [|now generalize (F.classify_correct m); rewrite Rm, F.valid_ub_correct; case F.classify|easy]. intros Vsmxl Hsmxl. elim (F'.max_valid_ub _ _ Vsxum Vsmxl). intros Vm Hm. rewrite Vm, Hm. revert Hsxum Hsmxl. rewrite Hlr, Hur, (F'.real_correct _ Rm). unfold le_upper. case F.toX; [easy|]; simpl. intros rsxum Hrsxum. case F.toX; [easy|]; simpl. intros rsmxl Hrsmxl. apply Raux.Rabs_le_inv. destruct (MVT_abs Rtrigo_def.cos (fun t => Ropp (sin t)) (F.toR m) (Rabs x)) as [v [-> _]]. { intros c _. apply derivable_pt_lim_cos. } apply Rle_trans with (1 * Rabs (Rabs x - (F.toR m)))%R. { apply Rmult_le_compat_r. apply Rabs_pos. rewrite Rabs_Ropp. apply Rabs_le, SIN_bound. } rewrite Rmult_1_l. case (Rle_lt_dec (Rabs x) (F.toR m)); intro Hxm. { refine (Rle_trans _ _ _ _ (Rmax_r _ _)). rewrite Rabs_minus_sym, Rabs_pos_eq; [|lra]. apply (Rle_trans _ ((F.toR m) - xlr)); lra. } refine (Rle_trans _ _ _ _ (Rmax_l _ _)). rewrite Rabs_pos_eq; [|lra]. apply (Rle_trans _ (xur - (F.toR m))); lra. } intros _. unfold convert, bnd. rewrite F'.valid_ub_real, F'.valid_lb_real by now rewrite F.real_correct, F.fromZ_correct. rewrite 2!F.fromZ_correct by easy. apply COS_bound. Qed. (* accurate only for |xi| <= 5/2*pi *) Definition sin prec xi := match xi with | Ibnd xl xu => if F'.le' xu xl then T.sin_fast prec xl else let pi4 := T.pi4 prec in let pi2 := F.mul_DN prec (lower pi4) c2 in match F'.le' (F.neg pi2) xl, F'.le' xu pi2 with | true, true => bnd (lower (T.sin_fast prec xl)) (upper (T.sin_fast prec xu)) | true, false => cos prec (sub prec (mul2 prec pi4) xi) | _, _ => neg (cos prec (add prec xi (mul2 prec pi4))) end | Inan => Inan end. Theorem sin_correct : forall prec, extension Xsin (sin prec). Proof. intros prec [|xl xu]; [easy|]. intros [|x]. { now simpl; case (_ && _)%bool. } intro Hx; generalize Hx. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hxl Hxu]. unfold sin, c2. case_eq (F'.le' xu xl). intros Hl. apply F'.le'_correct in Hl. assert (Hsxl := T.sin_fast_correct prec xl). destruct (F.toX xu) as [|xur] ; try easy. destruct (F.toX xl) as [|xlr] ; try easy. replace x with xlr. exact Hsxl. apply Rle_antisym with (1 := Hxl). now apply Rle_trans with (2 := Hl). intros _. set (pi2 := F.mul_DN prec (lower (T.pi4 prec)) (F.fromZ 2)). case_eq (F'.le' (F.neg pi2) xl). intros Hpl. generalize (F'.le'_correct _ _ Hpl). xreal_tac xl. now case (F.toX (F.neg pi2)). clear Hpl. intros Hpl. case_eq (F'.le' xu pi2). intros Hpu. generalize (F'.le'_correct _ _ Hpu). xreal_tac xu. easy. xreal_tac pi2. easy. clear Hpu. intros Hpu. revert Hpl. rewrite F'.neg_correct, X1. simpl. intros Hpl. elim (F.mul_DN_correct prec (lower (T.pi4 prec)) (F.fromZ 2)). 2: { unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg', F.is_non_pos'. rewrite F.fromZ_correct by easy. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4. { intros _; do 3 right; simpl. rewrite F'.valid_lb_nan, F'.nan_correct; repeat split; lra. } intros pl pu; simpl. case (F.valid_lb pl); [|intros [H0 H1]; lra]; intros _. case F.toX; [do 3 right; repeat split; lra|]. intro r'. case (Rle_or_lt 0 r'); intro Hr'; [left; split; lra|]. do 3 right; repeat split; lra. } fold pi2. intros Vpi2. unfold le_lower, le_upper. rewrite X1, F.fromZ_correct by easy. simpl. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4; [now simpl; rewrite F'.nan_correct|]. intros pl pu. case (_ && _)%bool; [|intros [H0 H1]; lra]. simpl. case F.toX; [easy|]. intros rpl [Hrpl _]. simpl. intro Hrpl'. assert (Hpl' : (-(PI/2) <= r)%R) by lra. assert (Hpu' : (r0 <= PI/2)%R) by lra. cut (match F.toX (upper (T.sin_fast prec xu)) with | Xnan => True | Xreal r3 => (Rtrigo_def.sin x <= r3)%R end). { cut (match F.toX (lower (T.sin_fast prec xl)) with | Xnan => True | Xreal r3 => (r3 <= Rtrigo_def.sin x)%R end). { generalize (T.sin_fast_correct prec xu). generalize (T.sin_fast_correct prec xl). destruct (T.sin_fast prec xl) as [|yl yu]; simpl; [rewrite F'.valid_lb_nan|]; (destruct (T.sin_fast prec xu) as [|zl zu]; simpl; [rewrite F'.valid_ub_nan|]); rewrite ?F'.nan_correct; [easy|..]; try (case (F.valid_lb yl); [|now simpl; case Xsin; [|intros rs [H0 H1]; lra]]); try (case (F.valid_ub zu); [|now intros _; rewrite Bool.andb_comm; case Xsin; [|intros rs [H0 H1]; lra]]); try (case (F.valid_ub yu); [|now simpl; case Xsin; [|intros rs [H0 H1]; lra]]); try (case (F.valid_lb zl); [|now intros _; rewrite Bool.andb_comm; case Xsin; [|intros rs [H0 H1]; lra]]); now case Xsin. } generalize (T.sin_fast_correct prec xl). destruct (T.sin_fast prec xl) as [|yl yu]. simpl. now rewrite F'.nan_correct. rewrite X. simpl. xreal_tac yl. easy. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [Hy _]. apply Rle_trans with (1 := Hy). assert (H' := Rle_trans _ _ _ Hxu Hpu'). apply sin_incr_1; try easy. now apply Rle_trans with x. now apply Rle_trans with r. } generalize (T.sin_fast_correct prec xu). destruct (T.sin_fast prec xu) as [|yl yu]. simpl. now rewrite F'.nan_correct. rewrite X0. simpl. xreal_tac yu. easy. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [_ Hy]. apply Rle_trans with (2 := Hy). assert (H' := Rle_trans _ _ _ Hpl' Hxl). apply sin_incr_1 ; try easy. now apply Rle_trans with r0. now apply Rle_trans with x. intros _. unfold Xsin. rewrite <- cos_shift. change (Xreal (Rtrigo_def.cos (PI / 2 - x))) with (Xcos (Xsub (Xreal (PI / 2)) (Xreal x))). apply cos_correct. apply sub_correct with (2 := Hx). replace (PI / 2)%R with (PI / 4 * 2)%R by field. change (Xreal (PI / 4 * 2)) with (Xreal (PI / 4) * Xreal 2)%XR. apply mul2_correct. apply T.pi4_correct. intros _. rewrite <- (Ropp_involutive x). unfold Xsin. rewrite sin_neg. apply (neg_correct _ (Xreal _)). rewrite <- cos_shift. replace (PI / 2 - - x)%R with (x + PI / 2)%R by ring. change (Xreal (Rtrigo_def.cos (x + PI / 2))) with (Xcos (Xadd (Xreal x) (Xreal (PI / 2)))). apply cos_correct. apply (add_correct _ _ _ _ _ Hx). replace (PI / 2)%R with (PI / 4 * 2)%R by field. change (Xreal (PI / 4 * 2)) with (Xreal (PI / 4) * Xreal 2)%XR. apply mul2_correct. apply T.pi4_correct. Qed. (* meaningful only for |xi| <= pi/2 *) Definition tan prec xi := match xi with | Ibnd xl xu => if F'.le' xu xl then T.tan_fast prec xl else let pi2 := F.mul_DN prec (lower (T.pi4 prec)) c2 in match F'.lt' (F.neg pi2) xl, F'.lt' xu pi2 with | true, true => bnd (lower (T.tan_fast prec xl)) (upper (T.tan_fast prec xu)) | _, _ => Inan end | Inan => Inan end. Lemma tan_correct : forall prec, extension Xtan (tan prec). Proof. intros prec [|xl xu]; [easy|]. intros [|x]. { now simpl; case (_ && _)%bool. } intro Hx; generalize Hx. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hxl Hxu]. unfold tan, c2. case_eq (F'.le' xu xl). intros Hl. apply F'.le'_correct in Hl. assert (Htxl := T.tan_fast_correct prec xl). unfold convert in Hx; rewrite Vxl, Vxu in Hx; simpl in Hx. destruct (F.toX xu) as [|xur] ; try easy. destruct (F.toX xl) as [|xlr] ; try easy. replace x with xlr. exact Htxl. apply Rle_antisym with (1 := proj1 Hx). apply Rle_trans with (2 := Hl). apply Hx. intros _. case_eq (F'.lt' (F.neg (F.mul_DN prec (lower (T.pi4 prec)) (F.fromZ 2))) xl) ; try easy. intros Hlt1. apply F'.lt'_correct in Hlt1. case_eq (F'.lt' xu (F.mul_DN prec (lower (T.pi4 prec)) (F.fromZ 2))) ; try easy. intros Hlt2. apply F'.lt'_correct in Hlt2. generalize (T.tan_correct prec xl) (T.tan_correct prec xu). unfold convert in Hx; rewrite Vxl, Vxu in Hx; simpl in Hx. destruct (F.toX xl) as [|rl]. { now destruct (F.toX (F.neg (F.mul_DN prec (lower (T.pi4 prec)) (F.fromZ 2)))). } destruct (F.toX xu) as [|ru] ; try easy. intros Hl Hu. rewrite bnd_correct. 2: { generalize (T.tan_fast_correct prec xl). unfold T.I.convert. case T.tan_fast; [now simpl; unfold valid_lb; rewrite F'.valid_lb_nan|]. intros l u; simpl; unfold valid_lb; case F.valid_lb; [easy|]. now case Xtan; [|intros r [H0 H1]; lra]. } 2: { generalize (T.tan_fast_correct prec xu). unfold T.I.convert. case T.tan_fast; [now simpl; unfold valid_ub; rewrite F'.valid_ub_nan|]. intros l u; rewrite Bool.andb_comm. simpl; unfold valid_ub; case F.valid_ub; [easy|]. now case Xtan; [|intros r [H0 H1]; lra]. } rewrite F'.neg_correct in Hlt1. elim (F.mul_DN_correct prec (lower (T.pi4 prec)) (F.fromZ 2)). 2: { unfold F.is_non_neg_real, F.is_non_pos_real, F.is_non_neg', F.is_non_pos'. rewrite F.fromZ_correct by easy. generalize (T.pi4_correct prec). unfold T.I.convert. case T.pi4. { intros _; do 3 right; simpl. rewrite F'.valid_lb_nan, F'.nan_correct; repeat split; lra. } intros pl pu; simpl. case (F.valid_lb pl); [|intros [H0 H1]; lra]; intros _. case F.toX; [do 3 right; repeat split; lra|]. intro r'. case (Rle_or_lt 0 r'); intro Hr'; [left; split; lra|]. do 3 right; repeat split; lra. } intro Vmpi2. unfold le_lower, le_upper. rewrite F.fromZ_correct by easy. revert Hlt1 Hlt2. case F.toX; [easy|]; intro rpi2. simpl. intros Hlt1 Hlt2. generalize (T.pi4_correct prec). destruct (T.pi4 prec) as [|pi4l pi4u]. { now simpl; rewrite F'.nan_correct. } unfold T.I.convert. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [Hpil _]. simpl. destruct (F.toX pi4l) as [|pi4r] ; [easy|]. simpl. intro Hmpi2. apply (Rmult_le_compat_r 2) in Hpil; [|now apply IZR_le]. unfold Rdiv in Hpil. replace (PI * /4 * 2)%R with (PI / 2)%R in Hpil by field. assert (H1: (- PI / 2 < rl)%R) by lra. assert (H2: (ru < PI / 2)%R) by lra. unfold Xtan'. simpl. case is_zero_spec. simpl in Hx. apply Rgt_not_eq, cos_gt_0. apply Rlt_le_trans with (2 := proj1 Hx). unfold Rdiv. now rewrite <- Ropp_mult_distr_l_reverse. now apply Rle_lt_trans with ru. unfold Xtan' in Hl, Hu. intros _. split. - destruct (T.tan_fast prec xl) as [|tl tu]. simpl. now rewrite F'.nan_correct. revert Hl. simpl. case (_ && _)%bool; [|now case is_zero; [|intros [H0' H1']; lra]]. simpl. case is_zero_spec ; try easy. intros _ [H _]. destruct (F.toX tl) as [|rtl] ; try easy. apply Rle_trans with (1 := H). destruct (proj1 Hx) as [Hx'|Hx']. apply Rlt_le. apply tan_increasing ; try easy. now apply Rle_lt_trans with ru. rewrite Hx'. apply Rle_refl. - destruct (T.tan_fast prec xu) as [|tl tu]. simpl. now rewrite F'.nan_correct. revert Hu. simpl. case (_ && _)%bool; [|now case is_zero; [|intros [H0' H1']; lra]]. simpl. case is_zero_spec ; [easy|]. intros _ [_ H]. destruct (F.toX tu) as [|rtu] ; try easy. apply Rle_trans with (2 := H). destruct (proj2 Hx) as [Hx'|Hx']. apply Rlt_le. apply tan_increasing ; try easy. now apply Rlt_le_trans with rl. rewrite Hx'. apply Rle_refl. Qed. Definition atan prec xi := match xi with | Ibnd xl xu => Ibnd (if F.real xl then lower (T.atan_fast prec xl) else F.neg (F.mul_UP prec (upper (T.pi4 prec)) c2)) (if F.real xu then upper (T.atan_fast prec xu) else F.mul_UP prec (upper (T.pi4 prec)) c2) | Inan => Inan end. Lemma pi4_mul2 : forall prec, F.valid_ub (F.mul_UP prec (upper (T.pi4 prec)) (F.fromZ 2)) = true /\ le_upper (Xreal (PI/2))%XR (F.toX (F.mul_UP prec (upper (T.pi4 prec)) (F.fromZ 2))). Proof. intros prec. unfold F.is_non_neg, F.is_non_pos, F.is_non_pos_real, F.is_non_neg_real. assert (H1 := T.pi4_correct prec). assert (H2 := proj2 (T.J.contains_le _ _ H1)). elim (F.mul_UP_correct prec (upper (T.pi4 prec)) (F.fromZ 2)). - intros H3 H4. split. exact H3. apply le_upper_trans with (2 := H4). clear -H2. destruct F.toX as [|pu]. easy. rewrite F.fromZ_correct by easy. simpl in *. lra. - unfold F.is_non_neg'. left ; split. revert H2. change T.I.F.convert with F.toX. rewrite valid_ub_upper, T.I.upper_correct by (eexists ; exact H1). destruct T.I.convert as [|l [|u]] ; try easy. apply Rle_trans, Rlt_le, PI4_RGT_0. rewrite F.fromZ_correct by easy. now apply IZR_le. Qed. Lemma atan_correct : forall prec, extension Xatan (atan prec). Proof. intros prec [|xl xu]; [easy|]. intros [|x]. { now simpl; case (_ && _)%bool. } intro Hx; generalize Hx. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hxl Hxu]. assert (Hpi := T.pi4_correct prec). simpl. unfold c2. unfold convert in Hx; rewrite Vxl, Vxu in Hx; simpl in Hx. destruct (pi4_mul2 prec) as [Vmpi2 Hmpi2]. set (l := if F.real xl then _ else _). set (u := if F.real xu then _ else _). assert (Vl : F.valid_lb l = true). { unfold l; rewrite F.real_correct. generalize (T.atan_fast_correct prec xl). case F.toX. { now intros _; rewrite F'.valid_lb_neg. } intro r. unfold T.I.convert. case T.atan_fast; [now simpl; rewrite F'.valid_lb_nan|]. intros l' u'. simpl. now case F.valid_lb; [|intros [H0 H1]; lra]. } assert (Vu : F.valid_ub u = true). { unfold u; rewrite F.real_correct. generalize (T.atan_fast_correct prec xu). case F.toX; [easy|]. intro r. unfold T.I.convert. case T.atan_fast; [now simpl; rewrite F'.valid_ub_nan|]. intros l' u'. simpl. now rewrite Bool.andb_comm; case F.valid_ub; [|intros [H0 H1]; lra]. } rewrite Vl, Vu; simpl. unfold l, u. rewrite 2!F.real_correct. split. - generalize (proj1 Hx). clear Hx. case_eq (F.toX xl). intros _ _. rewrite F'.neg_correct. revert Hmpi2; unfold le_upper. case F.toX; [easy|]; intro rmpi2. intro H. apply (Rle_trans _ _ _ (Ropp_le_contravar _ _ H)). apply Rlt_le. apply Rle_lt_trans with (2 := proj1 (atan_bound x)). lra. intros rl Hl Hx. generalize (T.atan_correct prec xl). destruct (T.atan_fast prec xl) as [|al au]. intros _. simpl. now rewrite F'.nan_correct. simpl. rewrite Hl. case (_ && _)%bool; [|intros [H0 H1]; lra]. destruct (F.toX al) as [|ral] ; try easy. intros [H _]. apply Rle_trans with (1 := H). destruct Hx as [Hx|Hx]. now apply Rlt_le, atan_increasing. rewrite Hx. apply Rle_refl. - generalize (proj2 Hx). clear Hx. case_eq (F.toX xu). intros _ _. revert Hmpi2. unfold le_upper. case F.toX; [easy|]; intro rmpi2. apply Rle_trans. apply Rlt_le, atan_bound. intros rl Hl Hx. generalize (T.atan_correct prec xu). destruct (T.atan_fast prec xu) as [|al au]. intros _. simpl. now rewrite F'.nan_correct. simpl. rewrite Hl. case (_ && _)%bool; [|intros [H0 H1]; lra]. destruct (F.toX au) as [|rau] ; try easy. intros [_ H]. apply Rle_trans with (2 := H). destruct Hx as [Hx|Hx]. now apply Rlt_le, atan_increasing. rewrite Hx. apply Rle_refl. Qed. Definition exp prec xi := match xi with | Ibnd xl xu => Ibnd (if F.real xl then lower (T.exp_fast prec xl) else F.zero) (if F.real xu then upper (T.exp_fast prec xu) else F.nan) | Inan => Inan end. Theorem exp_correct : forall prec, extension Xexp (exp prec). Proof. intros prec [|xl xu]. easy. intros [|x]. now simpl; case (_ && _)%bool. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hxl Hxu]. simpl. set (l := if F.real xl then _ else _). set (u := if F.real xu then _ else _). assert (Vl : F.valid_lb l = true). { unfold l. rewrite F.real_correct. generalize (T.exp_fast_correct prec xl). case F.toX. { now simpl; rewrite F'.valid_lb_zero. } intro rxl. unfold T.I.convert. simpl. case T.exp_fast. { now simpl; rewrite F'.valid_lb_nan. } intros rl ru. simpl. now case F.valid_lb; [|intros [H0 H1]; lra]. } assert (Vu : F.valid_ub u = true). { unfold u. rewrite F.real_correct. generalize (T.exp_fast_correct prec xu). case F.toX. { now rewrite F'.valid_ub_nan. } intro rxu. unfold T.I.convert. simpl. case T.exp_fast. { now simpl; rewrite F'.valid_ub_nan. } intros rl ru. simpl; rewrite Bool.andb_comm. now case F.valid_ub; [|intros [H0 H1]; lra]. } rewrite Vl, Vu; unfold l, u. split. (* lower *) clear Hxu. rewrite F.real_correct. xreal_tac xl. rewrite F.zero_correct. simpl. apply Rlt_le. apply exp_pos. generalize (T.exp_fast_correct prec xl). destruct (T.exp_fast prec xl) as [|yl yu]. unfold lower. now rewrite F'.nan_correct. rewrite X. unfold T.I.convert. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros (H, _). simpl. xreal_tac2. apply Rle_trans with (1 := H). now apply Raux.exp_le. (* upper *) clear Hxl. rewrite F.real_correct. xreal_tac xu. now rewrite F'.nan_correct. generalize (T.exp_fast_correct prec xu). destruct (T.exp_fast prec xu) as [|yl yu]. unfold upper. now rewrite F'.nan_correct. rewrite X. unfold T.I.convert. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros (_, H). simpl. xreal_tac2. apply Rle_trans with (2 := H). now apply Raux.exp_le. Qed. Definition ln prec xi := match xi with | Ibnd xl xu => if F'.lt' F.zero xl then Ibnd (lower (T.ln_fast prec xl)) (if F.real xu then upper (T.ln_fast prec xu) else F.nan) else Inan | Inan => Inan end. Theorem ln_correct : forall prec, extension Xln (ln prec). Proof. intros prec [|xl xu]. easy. unfold Xln'. intros [|x]; [now unfold convert; case (_ && _)%bool|]. simpl. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hl Hu]. case_eq (F'.lt' F.zero xl) ; intros Hlt ; [|easy]. apply F'.lt'_correct in Hlt. rewrite F.zero_correct in Hlt. simpl. set (l := lower _). set (u := if F.real xu then _ else _). assert (Vl : F.valid_lb l = true). { generalize (T.ln_fast_correct prec xl). unfold l, T.I.convert. case T.ln_fast; [now simpl; rewrite F'.valid_lb_nan|]. intros rl ru. simpl. now case F.valid_lb; [|case Xln; [|intros r [H0 H1]; lra]]. } assert (Vu : F.valid_ub u = true). { generalize (T.ln_fast_correct prec xu). unfold u, T.I.convert; simpl. rewrite F.real_correct. case F.toX; [now rewrite F'.valid_ub_nan|]. intro r. case T.ln_fast; [now simpl; rewrite F'.valid_ub_nan|]. intros rl ru. rewrite Bool.andb_comm; simpl. now case F.valid_ub; [|case Xln'; [|intros r' [H0 H1]; lra]]. } rewrite Vl, Vu; unfold l, u; clear Vl l Vu u; simpl. case is_positive_spec. intros Hx. simpl. split. generalize (T.ln_fast_correct prec xl). case T.ln_fast. intros _. simpl. now rewrite F'.nan_correct. intros l u. simpl. case_eq (Xln (F.toX xl)); [now intros _; case (_ && _)%bool|]. intros lnx Hlnx. case (_ && _)%bool; [|intros [H0 H1]; lra]. intros [H _]. destruct (F.toX l) as [|lr]. easy. apply Rle_trans with (1 := H). destruct (F.toX xl) as [|xlr]. easy. revert Hlnx. unfold Xln'. simpl. case is_positive_spec. intros _ H'. injection H'. intros <-. destruct Hl as [Hl|Hl]. now apply Rlt_le, ln_increasing. rewrite Hl. apply Rle_refl. easy. rewrite F.real_correct. case_eq (F.toX xu). now rewrite F'.nan_correct. intros xur Hxu. rewrite Hxu in Hu. generalize (T.ln_fast_correct prec xu). case T.ln_fast. intros _. simpl. now rewrite F'.nan_correct. intros l u. simpl. rewrite Hxu. unfold Xln'. simpl. case (_ && _)%bool; [|now case is_positive; [intros [H0 H1]; lra|]]. case is_positive_spec. intros _. intros [_ H]. destruct (F.toX u) as [|ur]. easy. apply Rle_trans with (2 := H). destruct Hu as [Hu|Hu]. now apply Rlt_le, ln_increasing. rewrite Hu. apply Rle_refl. easy. intros Hx. destruct (F.toX xl) as [|xlr]. easy. elim Rle_not_lt with (1 := Hx). now apply Rlt_le_trans with xlr. Qed. End FloatIntervalFull. interval-4.11.1/src/Interval/Float_full_primfloat.v000066400000000000000000001262401470547631300223470ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2023-2023, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Psatz PrimInt63 Uint63 Sint63 PArray Floats. From Flocq Require Import Core PrimFloat BinarySingleNaN. Require Import Missing.Flocq. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Require Import Float. Require Import Float_full. Require Import Specific_bigint Specific_ops. Require Import Primitive_ops. Require Import Lang_expr Lang_tac. Require Import Interval_helper. Local Open Scope R_scope. Lemma sub_sub_assoc : forall x y z, (x - (y - z) = x - y + z)%uint63. Proof. intros x y z. rewrite 3Sint63.sub_of_Z, Sint63.add_of_Z. apply Sint63.to_Z_inj. rewrite 4Sint63.of_Z_spec. rewrite <-4cmod_cmod by easy. unfold Zcmod at 1 3. unfold Z.sub. rewrite (Z.add_comm (Sint63.to_Z x)). rewrite Z.opp_eq_mul_m1. rewrite <-2Z.add_assoc, cmod_mul_add_mod; [| easy | now exists 1%Z]. rewrite cmod_add_mod; [| easy | now exists 1%Z]. apply f_equal with (f := fun n => (n mod wB + (- Z.quot wB 2))%Z). lia. Qed. Lemma asr_land : forall x y, (Uint63.to_Z y <= 62)%Z -> to_Z x = (to_Z (asr x y) * (2 ^ Uint63.to_Z y) + Uint63.to_Z (x land (lsl 1 y - 1)))%Z. Proof. intros x y Hy. rewrite asr_spec, land_spec', Uint63.sub_spec, lsl_spec. change (Uint63.to_Z 1) with 1%Z. rewrite Z.mul_1_l. rewrite (Z.mod_small (2 ^ _)). 2: { change wB with (2 ^ 63)%Z. split. apply (Zpower_ge_0 radix2). apply (Zpower_lt radix2); lia. } rewrite Z.mod_small. 2: { change wB with (2 ^ 63)%Z. split. apply Z.lt_le_pred. apply (Zpower_gt_0 radix2). apply Uint63.to_Z_bounded. apply Z.lt_pred_le. apply (Zpower_le radix2). lia. } change (2 ^ _ - 1)%Z with (Z.pred (2 ^ Uint63.to_Z y)). rewrite <-Z.ones_equiv. rewrite Z.land_ones by apply Uint63.to_Z_bounded. unfold to_Z at 3. rewrite (proj2 (Uint63.ltb_spec _ _)) by now apply Z.le_lt_trans with (1 := Hy). rewrite <-(to_Z_mod_Uint63to_Z x). rewrite <-Znumtheory.Zmod_div_mod. - rewrite Z.mul_comm. apply Zdiv.Z_div_mod_eq_full. - apply (Zpower_gt_0 radix2). apply Uint63.to_Z_bounded. - easy. - change wB with (2 ^ 63)%Z. replace 63%Z with (63 - Uint63.to_Z y + Uint63.to_Z y)%Z by ring. rewrite Z.pow_add_r. apply Z.divide_factor_r. lia. apply Uint63.to_Z_bounded. Qed. Lemma ulp_FLX_le_FLT : forall (beta : radix) (emin prec : Z), Prec_gt_0 prec -> forall x : R, ulp beta (FLX_exp prec) x <= ulp beta (FLT_exp emin prec) x. Proof. intros beta emin prec Iprec_gt_0 x. unfold ulp. destruct (Req_bool_spec x 0) as [-> | Hx]; [rewrite negligible_exp_FLX by easy |]. - destruct (negligible_exp_FLT emin prec) as [n [-> _]]. apply bpow_ge_0. - apply bpow_le. unfold cexp, FLX_exp, FLT_exp. lia. Qed. Lemma ulp_FLX_eq_FLT_large : forall (beta : radix) (emin prec : Z), Prec_gt_0 prec -> forall x : R, bpow beta (emin + prec - 1) <= Rabs x -> ulp beta (FLX_exp prec) x = ulp beta (FLT_exp emin prec) x. Proof. intros beta emin prec Iprec_gt_0 x Hx. rewrite <-(ulp_abs _ (FLX_exp _)), <-(ulp_abs _ (FLT_exp _ _)). unfold ulp. destruct (Req_bool_spec (Rabs x) 0) as [H | _]; [generalize (bpow_gt_0 beta (emin + prec - 1)); lra |]. f_equal. unfold cexp. rewrite <-Rabs_Rabsolu in Hx. apply mag_gt_bpow in Hx. unfold FLX_exp, FLT_exp. lia. Qed. Lemma succ_FLX_le_FLT : forall beta emin prec, Prec_gt_0 prec -> forall x, succ beta (FLX_exp prec) x <= succ beta (FLT_exp emin prec) x. Proof. intros beta emin prec Iprec_gt_0 x. unfold succ. case (Rle_bool 0 x); [now apply Rplus_le_compat_l, ulp_FLX_le_FLT |]. unfold pred_pos. case (Req_bool (- x) (bpow beta (mag beta (- x) - 1))); rewrite 2Ropp_minus_distr; apply Rplus_le_compat_r; [apply bpow_le; unfold FLT_exp, FLX_exp; lia | now apply ulp_FLX_le_FLT]. Qed. Lemma pred_FLT_le_FLX : forall beta emin prec, Prec_gt_0 prec -> forall x, pred beta (FLT_exp emin prec) x <= pred beta (FLX_exp prec) x. Proof. intros beta emin prec Iprec_gt_0 x. unfold pred. apply Ropp_le_contravar. now apply succ_FLX_le_FLT. Qed. Lemma succ_FLX_eq_FLT_large : forall beta emin prec, Prec_gt_0 prec -> forall x, bpow beta (emin + prec - 1) <= x -> succ beta (FLX_exp prec) x = succ beta (FLT_exp emin prec) x. Proof. intros beta emin prec Iprec_gt_0 x Hx. unfold succ, pred_pos. destruct (Rle_bool_spec 0 x) as [_ | H]. 2: generalize (bpow_gt_0 beta (emin + prec - 1)); lra. rewrite <-ulp_FLX_eq_FLT_large; [easy.. |]. apply Rle_trans with (1 := Hx), Rle_abs. Qed. Lemma FLX_FLT_aux : forall (emin prec e : Z), (emin + prec - 1 < e)%Z -> FLX_exp prec e = FLT_exp emin prec e. Proof. unfold FLX_exp, FLT_exp. lia. Qed. Lemma pred_FLT_eq_FLX_large : forall beta emin prec, Prec_gt_0 prec -> forall x, bpow beta (emin + prec - 1) < x -> pred beta (FLT_exp emin prec) x = pred beta (FLX_exp prec) x. Proof. intros beta emin prec Iprec_gt_0 x Hx. unfold pred, succ, pred_pos. destruct (Rle_bool_spec 0 (- x)) as [H | _]. { generalize (bpow_gt_0 beta (emin + prec - 1)). lra. } rewrite 3Ropp_involutive. revert Hx. destruct (Req_bool_spec x (bpow beta (mag beta x - 1))) as [-> | _]; intros Hx. { apply lt_bpow in Hx. rewrite mag_bpow. now rewrite <- FLX_FLT_aux by lia. } rewrite <-ulp_FLX_eq_FLT_large; [easy.. |]. left. apply Rlt_le_trans with (1 := Hx), Rle_abs. Qed. Lemma succ_round_gt_id : forall (beta : radix) (fexp : Z -> Z), Valid_exp fexp -> forall rnd : R -> Z, Valid_rnd rnd -> forall x : R, ulp beta fexp x <> 0 -> x < succ beta fexp (Generic_fmt.round beta fexp rnd x). Proof. intros beta fexp Ivalid_exp rnd Ivalid_rnd x Hulp. destruct (generic_format_EM beta fexp x) as [Hx | Hx]. - rewrite round_generic by easy. unfold succ. destruct (Rle_bool_spec 0 x) as [H | H]. + generalize (ulp_ge_0 beta fexp x). lra. + generalize (pred_pos_lt_id beta fexp (- x)). lra. - revert Hx. destruct (succ_round_ge_id beta fexp rnd x) as [H | ->]; [easy |]. intros Hx. now generalize (generic_format_succ beta fexp (Generic_fmt.round beta fexp rnd x) (generic_format_round _ _ _ _)). Qed. Lemma succ_round_FLX_le_FLT : forall beta emin prec, Prec_gt_0 prec -> forall rnd, Valid_rnd rnd -> forall x, generic_format beta (FLX_exp prec) x -> succ beta (FLX_exp prec) x <= succ beta (FLT_exp emin prec) (Generic_fmt.round beta (FLT_exp emin prec) rnd x). Proof. intros beta emin prec Iprec_gt_0 rnd Ivalid_rnd x Hx. generalize (FLX_exp_valid prec). intros Ivalid_exp_FLX. apply succ_le_lt; [easy.. | |]. - apply generic_format_FLX_FLT with emin. generalize (FLT_exp_valid emin prec). intros Ivalid_exp_FLT. apply generic_format_succ; [easy |]. now apply generic_format_round. - apply succ_round_gt_id; [now apply FLT_exp_valid | easy |]. unfold ulp. destruct (Req_bool_spec x 0) as [-> | Hxneq0]. + destruct (negligible_exp_FLT emin prec) as [n [-> _]]. generalize (bpow_gt_0 beta (FLT_exp emin prec n)). lra. + generalize (bpow_gt_0 beta (cexp beta (FLT_exp emin prec) x)). lra. Qed. Lemma pred_round_FLT_le_FLX : forall beta emin prec, Prec_gt_0 prec -> forall rnd, Valid_rnd rnd -> forall x, generic_format beta (FLX_exp prec) x -> pred beta (FLT_exp emin prec) (Generic_fmt.round beta (FLT_exp emin prec) rnd x) <= pred beta (FLX_exp prec) x. Proof. intros beta emin prec Iprec_gt_0 rnd Ivalid_rnd x Hx. unfold pred. apply Ropp_le_contravar. set (rnd' := fun x => Z.opp (rnd (- x))). replace (- Generic_fmt.round _ _ _ _) with (Generic_fmt.round beta (FLT_exp emin prec) rnd' (- x)). 2: { unfold Generic_fmt.round, scaled_mantissa, F2R. simpl. unfold rnd'. now rewrite cexp_opp, <-Ropp_mult_distr_l, Ropp_involutive, Ropp_mult_distr_l, <-opp_IZR. } apply succ_round_FLX_le_FLT; [easy | | now apply generic_format_opp]. apply Build_Valid_rnd; unfold rnd'. - intros x' y' Hx'y'. rewrite <-Z.opp_le_mono. apply Ivalid_rnd. lra. - intros n. rewrite <-opp_IZR. apply Z.opp_inj. rewrite Z.opp_involutive. apply Ivalid_rnd. Qed. Lemma pred_FLX_exact_shift : forall beta prec, Prec_gt_0 prec -> forall x e, pred beta (FLX_exp prec) (x * bpow beta e) = pred beta (FLX_exp prec) x * bpow beta e. Proof. intros beta prec Iprec_gt_0 x e. unfold pred. rewrite <-Ropp_mult_distr_l. f_equal. rewrite Ropp_mult_distr_l. now apply succ_FLX_exact_shift. Qed. Lemma succ_FLT_shift_ge : forall beta emin prec, Prec_gt_0 prec -> forall rnd, Valid_rnd rnd -> forall x, generic_format beta (FLT_exp emin prec) x -> bpow beta (emin + prec - 1) <= x -> forall e, succ beta (FLT_exp emin prec) x * bpow beta e <= succ beta (FLT_exp emin prec) (Generic_fmt.round beta (FLT_exp emin prec) rnd (x * bpow beta e)). Proof. intros beta emin prec Iprec_gt_0 rnd Ivalid_rnd x Hformat_x Hmin_x e. rewrite <-(succ_FLX_eq_FLT_large _ _ _ _ x) by easy. rewrite <-succ_FLX_exact_shift by easy. apply succ_round_FLX_le_FLT; [easy.. |]. now apply Mult_error.mult_bpow_exact_FLX, generic_format_FLX_FLT with emin. Qed. Lemma pred_FLT_shift_le : forall beta emin prec, Prec_gt_0 prec -> forall rnd, Valid_rnd rnd -> forall x, generic_format beta (FLT_exp emin prec) x -> bpow beta (emin + prec - 1) < x -> forall e, pred beta (FLT_exp emin prec) (Generic_fmt.round beta (FLT_exp emin prec) rnd (x * bpow beta e)) <= pred beta (FLT_exp emin prec) x * bpow beta e. Proof. intros beta emin prec Iprec_gt_0 rnd Ivalid_rnd x Hformat_x Hinf_x e. rewrite (pred_FLT_eq_FLX_large _ _ _ _ x) by easy. rewrite <-pred_FLX_exact_shift by easy. apply pred_round_FLT_le_FLX; [easy.. |]. now apply Mult_error.mult_bpow_exact_FLX, generic_format_FLX_FLT with emin. Qed. Lemma pred_round_N_le : forall beta fexp choice, Valid_exp fexp -> forall x y e, bpow beta (e - 1) < Rabs (Generic_fmt.round beta fexp (Znearest choice) x) < bpow beta e -> (x - y <= /2 * bpow beta (fexp e))%R -> (pred beta fexp (Generic_fmt.round beta fexp (Znearest choice) x) <= y)%R. Proof. intros beta fexp choice Vexp x y e [He1 He2] Hxy. apply Rle_trans with (x - /2 * bpow beta (fexp e))%R. 2: lra. clear Hxy. unfold pred, succ, pred_pos, ulp, cexp. rewrite Ropp_involutive. assert (Ha: (Rabs (Generic_fmt.round beta fexp (Znearest choice) x) <> 0)%R). { intros H. apply Rlt_not_le with (1 := He1). rewrite H. apply bpow_ge_0. } rewrite 2!(Req_bool_false _ 0). 2: { contradict Ha. rewrite Ha. apply Rabs_R0. } 2: { contradict Ha. rewrite <- Rabs_Ropp, Ha. apply Rabs_R0. } assert (Hm: mag beta (Generic_fmt.round beta fexp (Znearest choice) x) = e :> Z). { apply mag_unique. refine (conj _ He2). now apply Rlt_le. } rewrite mag_opp, Hm. generalize (error_le_half_ulp beta fexp choice x). unfold ulp, cexp. rewrite Req_bool_false. 2: { intros H. apply Rlt_not_le with (1 := He1). rewrite H, round_0 by apply valid_rnd_N. rewrite Rabs_R0. apply bpow_ge_0. } replace (mag beta x : Z) with e. 2: { destruct (mag_round beta fexp (Znearest choice) x). { contradict Ha. rewrite Ha. apply Rabs_R0. } now rewrite <- H. rewrite H in He1, He2. apply lt_bpow in He1, He2. lia. } intros H. apply Rabs_le_inv in H. case Rle_bool_spec ; intros H'. - lra. - rewrite Req_bool_false. lra. intros H''. apply Rlt_not_le with (1 := He1). rewrite H'', Rabs_pos_eq. apply Rle_refl. apply bpow_ge_0. Qed. Lemma succ_round_N_ge : forall beta fexp choice, Valid_exp fexp -> forall x y e, bpow beta (e - 1) < Rabs (Generic_fmt.round beta fexp (Znearest choice) x) < bpow beta e -> (y - x <= /2 * bpow beta (fexp e))%R -> (y <= succ beta fexp (Generic_fmt.round beta fexp (Znearest choice) x))%R. Proof. intros beta fexp choice Vexp x y e [He1 He2] Hxy. apply Rle_trans with (x + /2 * bpow beta (fexp e))%R. lra. clear Hxy. unfold succ, pred_pos, ulp, cexp. assert (Ha: (Rabs (Generic_fmt.round beta fexp (Znearest choice) x) <> 0)%R). { intros H. apply Rlt_not_le with (1 := He1). rewrite H. apply bpow_ge_0. } rewrite 2!(Req_bool_false _ 0). 2: { contradict Ha. rewrite <- Rabs_Ropp, Ha. apply Rabs_R0. } 2: { contradict Ha. rewrite Ha. apply Rabs_R0. } assert (Hm: mag beta (Generic_fmt.round beta fexp (Znearest choice) x) = e :> Z). { apply mag_unique. refine (conj _ He2). now apply Rlt_le. } rewrite mag_opp, Hm. generalize (error_le_half_ulp beta fexp choice x). unfold ulp, cexp. rewrite Req_bool_false. 2: { intros H. apply Rlt_not_le with (1 := He1). rewrite H, round_0 by apply valid_rnd_N. rewrite Rabs_R0. apply bpow_ge_0. } replace (mag beta x : Z) with e. 2: { destruct (mag_round beta fexp (Znearest choice) x). { contradict Ha. rewrite Ha. apply Rabs_R0. } now rewrite <- H. rewrite H in He1, He2. apply lt_bpow in He1, He2. lia. } intros H. apply Rabs_le_inv in H. case Rle_bool_spec ; intros H'. - lra. - rewrite Req_bool_false. lra. intros H''. apply Rlt_not_le with (1 := He1). rewrite <- Rabs_Ropp, H'', Rabs_pos_eq. apply Rle_refl. apply bpow_ge_0. Qed. Lemma pred_succ_round_N_le : forall beta fexp choice, Valid_exp fexp -> forall x y e, bpow beta (e - 1) < Rabs (Generic_fmt.round beta fexp (Znearest choice) x) < bpow beta e -> (Rabs (x - y) <= /2 * bpow beta (fexp e))%R -> (pred beta fexp (Generic_fmt.round beta fexp (Znearest choice) x) <= y <= succ beta fexp (Generic_fmt.round beta fexp (Znearest choice) x))%R. Proof. intros beta fexp choice Vexp x y e He Hxy. apply Rabs_le_inv in Hxy. split. now apply pred_round_N_le with (1 := Vexp) (2 := He). apply succ_round_N_ge with (1 := Vexp) (2 := He). lra. Qed. Module PrimFloatIntervalFull <: IntervalOps. Module Faux := SpecificFloat BigIntRadix2. Module Iaux := FloatIntervalFull Faux. Module IT := IntervalTacticAux Iaux. Import IT.SimpleTactic. Module I := FloatIntervalFull PrimitiveFloat. Import I. Definition pi (prec : F.precision) : type := (Ibnd 0x1.921fb54442d18p+1 0x1.921fb54442d19p+1)%float. Theorem pi_correct : forall prec, contains (convert (pi prec)) (Xreal PI). Proof. intros prec. cbv -[IZR PI Rle Rdiv]. interval with (i_prec 60). Qed. Include FloatInterval PrimitiveFloat. Definition cos := cos. Definition sin := sin. Definition tan := tan. Definition atan := atan. Definition ln := ln. Definition cos_correct := cos_correct. Definition sin_correct := sin_correct. Definition tan_correct := tan_correct. Definition atan_correct := atan_correct. Definition ln_correct := ln_correct. Module ExpImpl. Definition consts := [| 0x1.0000000000000p0%float; 0x1.02c9a3e778061p0%float; 0x1.059b0d3158574p0%float; 0x1.0874518759bc8p0%float; 0x1.0b5586cf9890fp0%float; 0x1.0e3ec32d3d1a2p0%float; 0x1.11301d0125b51p0%float; 0x1.1429aaea92de0p0%float; 0x1.172b83c7d517bp0%float; 0x1.1a35beb6fcb75p0%float; 0x1.1d4873168b9aap0%float; 0x1.2063b88628cd6p0%float; 0x1.2387a6e756238p0%float; 0x1.26b4565e27cddp0%float; 0x1.29e9df51fdee1p0%float; 0x1.2d285a6e4030bp0%float; 0x1.306fe0a31b715p0%float; 0x1.33c08b26416ffp0%float; 0x1.371a7373aa9cbp0%float; 0x1.3a7db34e59ff7p0%float; 0x1.3dea64c123422p0%float; 0x1.4160a21f72e2ap0%float; 0x1.44e086061892dp0%float; 0x1.486a2b5c13cd0p0%float; 0x1.4bfdad5362a27p0%float; 0x1.4f9b2769d2ca7p0%float; 0x1.5342b569d4f82p0%float; 0x1.56f4736b527dap0%float; 0x1.5ab07dd485429p0%float; 0x1.5e76f15ad2148p0%float; 0x1.6247eb03a5585p0%float; 0x1.6623882552225p0%float; 0x1.6a09e667f3bcdp0%float; 0x1.6dfb23c651a2fp0%float; 0x1.71f75e8ec5f74p0%float; 0x1.75feb564267c9p0%float; 0x1.7a11473eb0187p0%float; 0x1.7e2f336cf4e62p0%float; 0x1.82589994cce13p0%float; 0x1.868d99b4492edp0%float; 0x1.8ace5422aa0dbp0%float; 0x1.8f1ae99157736p0%float; 0x1.93737b0cdc5e5p0%float; 0x1.97d829fde4e50p0%float; 0x1.9c49182a3f090p0%float; 0x1.a0c667b5de565p0%float; 0x1.a5503b23e255dp0%float; 0x1.a9e6b5579fdbfp0%float; 0x1.ae89f995ad3adp0%float; 0x1.b33a2b84f15fbp0%float; 0x1.b7f76f2fb5e47p0%float; 0x1.bcc1e904bc1d2p0%float; 0x1.c199bdd85529cp0%float; 0x1.c67f12e57d14bp0%float; 0x1.cb720dcef9069p0%float; 0x1.d072d4a07897cp0%float; 0x1.d5818dcfba487p0%float; 0x1.da9e603db3285p0%float; 0x1.dfc97337b9b5fp0%float; 0x1.e502ee78b3ff6p0%float; 0x1.ea4afa2a490dap0%float; 0x1.efa1bee615a27p0%float; 0x1.f50765b6e4540p0%float; 0x1.fa7c1819e90d8p0%float| 0%float|]. Definition InvLog2_64 := 0x1.71547652b82fep6%float. Definition Log2div64h := 0x1.62e42fefap-7%float. Definition Log2div64l := 0x1.cf79abc9e3b3ap-46%float. Definition q1 := 0x1p0%float. Definition q2 := 0x1.fffffffffdb3bp-2%float. Definition q3 := 0x1.555555555653ep-3%float. Definition q4 := 0x1.555573f218b93p-5%float. Definition q5 := 0x1.111112d9f54c8p-7%float. Definition g0 : ArithExpr (BinFloat :: nil) BinFloat := Op MUL (Var 0) (Op ADD (BinFl q1) (Op MUL (Var 0) (Op ADD (BinFl q2) (Op MUL (Var 0) (Op ADD (BinFl q3) (Op MUL (Var 0) (Op ADD (BinFl q4) (Op MUL (Var 0) (BinFl q5))))))))). Definition Papprox (t : PrimFloat.float) := Eval cbv in evalPrim g0 (t, tt). Definition exp_aux (x : F.type) := if PrimFloat.ltb x (-0x1.74385446d71c4p9)%float then (0%float, 0x1p-1074%float) else if PrimFloat.ltb 0x1.62e42fefa39efp9%float x then (0x1.fffffffffffffp1023%float, infinity) else let k0 := (x * InvLog2_64 + 0x1.8p52)%float in let kf := (k0 - 0x1.8p52)%float in let tf := (x - kf * Log2div64h - kf * Log2div64l)%float in let ki := (normfr_mantissa (fst (frshiftexp k0)) - 6755399440921280)%uint63 in let C := consts.[PrimInt63.land ki 63] in let kq := PrimInt63.asr ki 6 in let y := (C * Papprox tf)%float in let lb := (C + (y + -0x1.25p-57))%float in let ub := (C + (y + 0x1.25p-57))%float in (next_down (ldshiftexp lb kq), next_up (ldshiftexp ub kq)). Lemma exp_aux_correct : forall x, is_finite (Prim2B x) = true -> (let lb := fst (exp_aux x) in F.valid_lb lb = true /\ match F.toX lb with | Xreal.Xnan => True | Xreal.Xreal r => r <= Rtrigo_def.exp (B2R (Prim2B x)) end) /\ (let ub := snd (exp_aux x) in F.valid_ub ub = true /\ match F.toX ub with | Xreal.Xnan => True | Xreal.Xreal r => Rtrigo_def.exp (B2R (Prim2B x)) <= r end). Proof. intros x Fx. unfold exp_aux. rewrite 2ltb_equiv, 2Bltb_correct by easy. set (xr := B2R (Prim2B x)). fold xr in Fx. case Rlt_bool_spec. { intros. change ((true = true /\ 0 <= Rtrigo_def.exp xr) /\ true = true /\ Rtrigo_def.exp xr <= 1 * Rpow2 (-1074)). clearbody xr. cbv -[Rinv Rmult Rlt IZR]in H. refine ((fun J => conj (conj eq_refl (proj1 J)) (conj eq_refl (proj2 J))) _). interval with (i_prec 80). } case Rlt_bool_spec. { intros H _. change ((true = true /\ IZR (9007199254740991 * 2 ^ 971) <= Rtrigo_def.exp xr) /\ true = true /\ True). refine ((fun J => conj (conj eq_refl J) (conj eq_refl I)) _). apply (@succ_le_lt radix2 (FLT_exp (-1074) 53)) in H. 2: now apply FLT_exp_valid. 2, 3: apply generic_format_B2R. clearbody xr. revert H. unfold succ. rewrite Rle_bool_true by now apply F2R_ge_0. set (f := Prim2B _). generalize (@Bulp_correct prec emax Hprec Hmax f eq_refl). change (fexp prec emax) with (FLT_exp (-1074) 53). intros [<- _] H. cbv -[Rinv Rmult Rle IZR] in H. interval with (i_prec 80). } intros H0 H1. assert (Hx : -6548164122079684 * Rpow2 (-43) <= xr <= 6243314768165359 * Rpow2 (-43)). { clearbody xr. cbv -[Rinv Rmult Rle IZR] in H0, H1 |- *. lra. } clear H0 H1. change 6755399440921280%uint63 with (PrimInt63.sub 6755399441055744 134464). rewrite sub_sub_assoc. set (ki := (normfr_mantissa _ - _)%uint63). replace (PrimInt63.land _ _) with (PrimInt63.land ki 63). 2: { rewrite <-(Uint63.of_to_Z (PrimInt63.land ki 63)), <-(Uint63.of_to_Z (PrimInt63.land (ki + 134464) 63)). rewrite 2land_spec', Uint63.add_spec. change (_ 63%uint63) with (Z.ones 6). rewrite 2Z.land_ones by easy. rewrite <-Znumtheory.Zmod_div_mod; [| easy | easy |]. 2: { now exists (2 ^ 57)%Z. } change (_ 134464%uint63) with (2101 * 64)%Z. now rewrite Z.mod_add by easy. } set (kr := PrimInt63.land ki 63). set (dlb := (-0x1.25p-57)%float). set (dub := 0x1.25p-57%float). set (d := 0x1.25p-57). assert (d = Rabs (SF2R radix2 (Prim2SF dlb)) /\ d = Rabs (SF2R radix2 (Prim2SF dub))) as [Hdlb Hdub]. { cbn. unfold F2R, d. cbn. change (Z.neg 5154510511013888) with (Z.opp 5154510511013888)%Z. rewrite opp_IZR, <-Ropp_mult_distr_l, Rabs_Ropp, Rabs_pos_eq; lra. } unfold xr in Hx |- *. clear xr. rewrite <-is_finite_SF_B2SF, B2SF_Prim2B in Fx. rewrite <-Prim2SF2R_Prim2B2R in Hx |- *. assert (Hxr_ : -746 <= SF2R radix2 (Prim2SF x) <= 710) by interval. set (xR := SF2R radix2 (Prim2SF x)). assert (HxR : generic_format radix2 (FLT_exp (-1074) 53) xR). { unfold xR. rewrite Prim2SF2R_Prim2B2R. apply generic_format_B2R. } unfold Interval.contains, I.convert. simpl. rewrite 2PrimitiveFloat.toX_Prim2B. unfold I.F.valid_lb, I.F.valid_ub. rewrite 2eqb_equiv, next_down_equiv, next_up_equiv, 2ldshiftexp_equiv. revert kr. rename ki into ki_. set (ki' := @FastNearbyintToInt (BinFloat :: nil) (Op MUL (Var 0) (BinFl InvLog2_64))). change ki_ with (evalPrim ki' (x, tt)). assert_float (fun ki => -68736 <= IZR ki <= 65536). { cbn -[bpow]. unfold Rrnd.rnd, round_mode. interval. } intros ki Hki0 Hki kr. assert (Hki1 : (-68736 <= to_Z ki <= 65536)%Z). { destruct Hki0 as [Hki00 Hki01]. now apply le_IZR in Hki00, Hki01. } assert (Hki2 : (-1074 <= to_Z (asr ki 6) <= 1024)%Z). { rewrite asr_spec. destruct Hki1 as [Hki10 Hki11]. apply (Z.div_le_mono _ _ 64 ltac:(easy)) in Hki10, Hki11. cbn in Hki10, Hki11 |- *. lia. } replace (Uint63.to_Z _) with ((to_Z (asr ki 6)) + 2101)%Z. 2: { rewrite <- to_Z_mod_Uint63to_Z. rewrite 2!asr_spec, Sint63.add_spec, cmod_small by (cbn; lia). change (to_Z 134464) with (2101 * 64)%Z. rewrite Zdiv.Z_div_plus by easy. apply eq_sym, Z.mod_small. revert Hki2. rewrite asr_spec. cbn; lia. } rewrite Z.add_simpl_r. set (kq := asr ki 6). assert (Hkr0 : (0 <= to_Z kr <= 63)%Z). { unfold kr. unfold to_Z. rewrite (proj2 (Uint63.ltb_spec _ _)). - rewrite land_spec'. change (Uint63.to_Z 63) with (Z.ones 6). rewrite Z.land_ones by easy. generalize (Z.mod_pos_bound (Uint63.to_Z ki) (2 ^ 6)%Z ltac:(easy)). lia. - rewrite land_spec'. change (Uint63.to_Z 63) with (Z.ones 6). rewrite Z.land_ones by easy. generalize (Z.mod_pos_bound (Uint63.to_Z ki) (2 ^ 6)%Z ltac:(easy)). change (Uint63.to_Z min_int) with 4611686018427387904%Z. lia. } assert (Hkr1 : to_Z kr = Uint63.to_Z kr). { rewrite <- to_Z_mod_Uint63to_Z. apply eq_sym, Z.mod_small. cbn -[kr]. lia. } assert (Hkr3 : (0 <= IZR (to_Z kr) <= 63)) by (now split; apply IZR_le). set (k0 := (x * InvLog2_64 + 6755399441055744)%float). fold k0 in ki. change (consts.[kr]) with (@evalPrim (Integer :: nil) _ (ArrayAcc consts (Var 0)) (kr, tt)). assert_float (fun C => 0.984375 <= C <= 1.984375 /\ (Uint63.to_Z kr = 0%Z -> C = 1) /\ Rabs (C - Rtrigo_def.exp (IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64))) <= Rpow2 (-53)). { split. simpl. unfold Int32.in_bounds. simpl ; lia. easy. } { split. easy. cbn. fold kr. lia. } { simpl evalRounded. rewrite <- Hkr1. assert (H: forall i, (0 <= i <= 63)%Z -> Rabs (SF2R radix2 (Prim2SF consts.[of_Z i]) - Rtrigo_def.exp (IZR i * (Rpower.ln 2 / 64))) <= Rpow2 (-53)). { intros i [Hi1 Hi2]. assert (Hi: forall j, (i <= j)%Z -> i = j \/ (i <= Z.pred j)%Z) by lia. do 64 (apply Hi in Hi2 ; destruct Hi2 as [->|Hi2] ; [cbn -[bpow]; interval with (i_prec 61) | simpl Z.pred in Hi2]). now elim (Z.le_trans _ _ _ Hi1 Hi2). } split; [| split]. 3: { now apply H. } 2: { intros ->. now apply Rinv_r, IZR_neq. } replace (SF2R _ _) with (SF2R radix2 (Prim2SF consts.[of_Z (to_Z kr)]) - Rtrigo_def.exp (IZR (to_Z kr) * (Rpower.ln 2 / 64)) + Rtrigo_def.exp (IZR (to_Z kr) * (Rpower.ln 2 / 64))) by ring. generalize (H (to_Z kr) Hkr0). generalize (SF2R radix2 (Prim2SF consts.[of_Z (to_Z kr)]) - Rtrigo_def.exp (IZR (to_Z kr) * (Rpower.ln 2 / 64))). intros; interval. } intros C' [bnd_C [HC1 HC2]] FC _. set (C := SF2R radix2 (Prim2SF C')). set (k'' := FastNearbyint (@Op (BinFloat :: nil) _ MUL (Var 0) (BinFl InvLog2_64))). change (k0 - 6755399441055744)%float with (@evalPrim (BinFloat :: nil) _ k'' (x, tt)). assert_float (fun k => -68736 <= k <= 65536). { cbn -[bpow]. unfold Rrnd.nearbyint, Rrnd.rnd, round_mode. rewrite round_FIX_IZR. interval. } intros k Hk Fk Ek. set (te := xR - IZR (to_Z ki) * (Rpower.ln 2 / 64)). set (t'' := @Op (BinFloat :: BinFloat :: nil) _ SUB (OpExact SUB (Var 1) (OpExact MUL (Var 0) (BinFl Log2div64h))) (Op MUL (Var 0) (BinFl Log2div64l))). change (x - _ - _)%float with (@evalPrim (BinFloat :: BinFloat :: nil) _ t'' (k, (x, tt))). assert_float (fun t => Rabs t <= 355 / 65536 /\ Rabs (t - te) <= 65537 * Rpow2 (-77)). { rewrite Ek. cbn -[bpow]; unfold F2R; cbn -[bpow]. unfold Rrnd.nearbyint, Rrnd.rnd, round_mode, Rrnd.Rnd. fold xR. rewrite round_FIX_IZR. set (k' := ZnearestE (Generic_fmt.round radix2 (FLT_exp Rrnd.emin Rrnd.prec) ZnearestE (xR * _))). replace (6243314768150528 * Rpow2 (-59)) with (47632711549 * Rpow2 (-42)) by (simpl; lra). rewrite <-Rmult_assoc, <-mult_IZR. split. 2: { apply round_generic; [apply valid_rnd_N |]. apply generic_format_FLT. exists (Defs.Float radix2 (k' * 47632711549) (-42)); unfold F2R; cbn; [easy | | easy]. apply lt_IZR. rewrite abs_IZR, mult_IZR. unfold k'. interval. } apply round_generic; [apply valid_rnd_N |]. assert (Rabs xR <= 746) by interval. assert (Rabs xR <= /256 \/ /256 <= Rabs xR) as [H8 | H8] by lra. - replace k' with 0%Z by (apply eq_IZR, Rle_le_eq; unfold k'; interval). rewrite Rmult_0_l, Rminus_0_r. easy. - apply generic_format_FLT. exists (Defs.Float radix2 (Ztrunc (xR * Rpow2 60) - k' * 47632711549 * 262144) (-60)). 3: easy. 2: { cbn. apply lt_IZR. rewrite abs_IZR, minus_IZR, 2mult_IZR. cbn -[Rabs IZR Ztrunc Rmult Rminus Rlt]. unfold k'. interval with (i_taylor xR). } unfold F2R; cbn. rewrite minus_IZR, Rmult_minus_distr_r. apply f_equal2. 2: rewrite !mult_IZR; lra. change (generic_format radix2 (FIX_exp (-60)) xR). revert HxR. apply generic_inclusion_ge with (e1 := (-8)%Z); [| easy]. unfold FIX_exp, FLT_exp. lia. } { unfold te. rewrite Hki. simpl P2M_list. rewrite Ek. simpl evalRounded. rewrite <-round_FIX_IZR with (f := ZnearestE). unfold Rrnd.nearbyint, round_mode. cbn -[bpow]; unfold F2R; cbn -[bpow]. fold xR in Hxr_ |- *. rename k into k_. set (k := Generic_fmt.round radix2 (FIX_exp 0) ZnearestE (Rrnd.rnd (xR * _))). split. { unfold k, Rrnd.rnd, round_mode. interval with (i_taylor xR). } set (RLog2div64l := 8153543309409082 * Rpow2 (-98)). set (RLog2div64h := 6243314768150528 * Rpow2 (-59)). set (u := xR - k * _ - _). set (delt1 := Rrnd.rnd u - u). set (delt2 := Rrnd.rnd (k * RLog2div64l) - k * RLog2div64l). replace (Rrnd.rnd u - (xR - k * (Rpower.ln 2 / 64))) with (delt1 - delt2 - k * (RLog2div64h + RLog2div64l - Rpower.ln 2 / 64)) by (unfold delt1, delt2, u; ring). unfold Rrnd.rnd, round_mode in delt1, delt2, k, u. interval with (i_taylor xR, i_prec 120). } intros t' [b_t err_t] Ft _. set (t := SF2R radix2 (Prim2SF t')). change (Papprox t') with (@evalPrim (BinFloat :: nil) _ g0 (t', tt)). assert_float (fun y => Rabs y <= 0.0055 /\ Rabs (1 + y - Rtrigo_def.exp t) <= 11 * Rpow2 (-62)). { cbn -[bpow]. unfold Rrnd.rnd, Rrnd.emin, round_mode, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax. split. - interval. - fold t in b_t |- *. interval with (i_taylor t, i_bisect t, i_prec 80). } intros y' [b_y Hy] Fy _. set (y := SF2R radix2 (Prim2SF y')). set (penult := @Op (BinFloat :: BinFloat :: BinFloat :: nil) BinFloat ADD (Op MUL (Var 0) (Var 1)) (Var 2)). change (_ * _ + dlb)%float with (evalPrim penult (C', (y', (dlb, tt)))). change (_ * _ + dub)%float with (evalPrim penult (C', (y', (dub, tt)))). set (xred := xR - IZR (to_Z kq) * Rpower.ln 2). assert (Exred: xred = (t - (t - te) + IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64))). { unfold xred, te, kr. rewrite (asr_land ki 6) by easy. rewrite plus_IZR, mult_IZR. change (lsl 1 6 - 1)%uint63 with 63%uint63. change (2 ^ Uint63.to_Z 6)%Z with 64%Z. fold xR kq. field. } assert (Hxred : Rabs (xred - IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64)) <= 356 / 65536). { rewrite Exred. unfold Rminus at 1. rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r. revert err_t. fold t. generalize (t - te). intros r Hr. interval. } assert (Main : forall d : PrimFloat.float, is_finite_SF (Prim2SF d) = true -> Rabs (SF2R radix2 (Prim2SF d)) <= Rpow2 (-52) -> let z := evalPrim penult (C', (y', (d, tt))) in is_finite_SF (Prim2SF z) = true /\ Rabs (SF2R radix2 (Prim2SF z)) <= 0.011 /\ let Y := Rtrigo_def.exp (IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF z) in 0.989 <= Y <= 1.99 /\ Rabs (Y - (Rtrigo_def.exp xred + SF2R radix2 (Prim2SF d))) <= 0x1.24b34edb6f103p-57). { clear d dlb dub Hdlb Hdub. intros d fin_d b_d. unfold penult. assert_float. intros z -> ->. apply (conj eq_refl). simpl in Hki. fold xR in xred, Hx, Hxr_, Hki |- *. clearbody xR. clear ki_ k0 x Fx Ek. simpl evalRounded. set (dR := SF2R radix2 (Prim2SF d)). fold dR C y in b_d |- *. clearbody dR. clear d fin_d. cbn -[bpow consts Uint63.to_Z kr]. unfold Rrnd.rnd, Rrnd.maxval, round_mode, Rrnd.emin, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax, Rrnd.maxval. split. { interval. } split. { rewrite <- Hkr1. interval. } rewrite Exred. fold y. set (eps := 1 + y - Rtrigo_def.exp t). replace y with (Rtrigo_def.exp t - 1 + eps) by (unfold eps; ring). fold y eps in Hy. clearbody eps. fold C. set (Y1 := C * _). set (Y2 := Generic_fmt.round _ _ _ Y1). set (Y3 := Y2 + _). set (Y4 := Generic_fmt.round _ _ _ _). rewrite exp_plus. unfold Rminus at 2. rewrite exp_plus. replace (_ - _) with ((Y4 - Y3) + (Y2 - Y1) + (Rtrigo_def.exp t - 1) * (C - Rtrigo_def.exp (IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64))) - (Rtrigo_def.exp (- (t - te)) - 1) * Rtrigo_def.exp (IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64)) * Rtrigo_def.exp t + C * eps) by (unfold Y4, Y3, Y2, Y1; ring). revert HC2. fold C. generalize (C - Rtrigo_def.exp (IZR (Uint63.to_Z kr) * (Rpower.ln 2 / 64))). intros r Hr. unfold Y4, Y3, Y2, Y1. rewrite <- Hkr1. rewrite exp_Ropp. revert err_t. fold t. generalize (t - te). intros r0 Hr0. interval with (i_prec 100). } assert (Hb : forall d, is_finite_SF (Prim2SF d) = true -> Rabs (SF2R radix2 (Prim2SF d)) = 0x1.25p-57 -> Rabs (Rrnd.rnd (Rrnd.rnd (SF2R radix2 (Prim2SF C') + SF2R radix2 (Prim2SF (evalPrim penult (C', (y', (d, tt)))))) * Rpow2 (to_Z kq))) < 9007199254740991 * Rpow2 971). { intros d' Hd1 Hd2. refine (_ (Main d' Hd1 _)). 2: rewrite Hd2 ; interval. clear Main. set (y'' := evalPrim penult _). intros [_ [_ [Hb2 Hb3]]]. simpl evalRounded. revert Hx Hd2 Hb2 Hb3 Hki2 HC2. unfold xred. fold C. clear. set (Y := Rtrigo_def.exp _ + _). set (delt := C - _). intros [_ Hx] Hd2 HY'' HY' [_ Hkq] Hdelt. unfold Rrnd.rnd, round_mode. replace (C + _) with (Y + delt) by (unfold Y, delt; ring). unfold Rminus at 2 in HY'. rewrite exp_plus, exp_Ropp in HY'. replace (Rtrigo_def.exp (_ * _)) with (Rpow2 (to_Z kq)) in HY' by now rewrite bpow_exp. assert (Haux := bpow_gt_0 radix2 (to_Z kq)). replace (Y - _) with ((Y * Rpow2 (to_Z kq) - Rtrigo_def.exp xR) / Rpow2 (to_Z kq) - SF2R radix2 (Prim2SF d')) in HY' by (field; lra). refine (_ (Rle_trans _ _ _ ltac:(apply Rabs_triang_inv) HY')). intros HY. clear HY'. apply Rcomplements.Rle_minus_l in HY. rewrite Hd2, Rcomplements.Rabs_div in HY by apply Rgt_not_eq, bpow_gt_0. assert (Hkq' : 0 <= Rpow2 (to_Z kq) <= Rpow2 1024). { split. apply bpow_ge_0. now apply bpow_le. } apply -> Rcomplements.Rle_div_l in HY ; [| now apply Rabs_gt; right]. apply (Rle_trans _ _ (0x1.8p-56 * Rpow2 1024)) in HY. 2: { apply Rmult_le_compat; [ interval | apply Rabs_pos | interval |]. now rewrite Rabs_pos_eq by lra. } unfold emax. assert (Hx' : 0 <= Rtrigo_def.exp xR <= Rpow2 1024 - Rpow2 978) by interval with (i_prec 60). change (Generic_fmt.round _ _ _) with Rrnd.rnd. set (delt1 := Rrnd.rnd (Y + delt) - (Y + delt)). set (delt2 := Rrnd.rnd (Rrnd.rnd (Y + delt) * Rpow2 (to_Z kq)) - Rrnd.rnd (Y + delt) * Rpow2 (to_Z kq)). replace (Rrnd.rnd (_ * _)) with (delt2 + delt1 * Rpow2 (to_Z kq) + (Y * Rpow2 (to_Z kq) - Rtrigo_def.exp xR) + Rtrigo_def.exp xR + delt * Rpow2 (to_Z kq)) by (unfold delt1, delt2; ring). revert HY. generalize (Y * Rpow2 (to_Z kq) - Rtrigo_def.exp xR). intros r Hr. unfold Rrnd.rnd, round_mode in delt1, delt2. interval with (i_prec 60). } assert (Haux_ : forall d, is_finite_SF (Prim2SF d) = true -> Rabs (SF2R radix2 (Prim2SF d)) <= 0x1p-52 -> Uint63.to_Z kr <> 0%Z -> 1.001 <= C + SF2R radix2 (Prim2SF (evalPrim penult (C', (y', (d, tt))))) <= 1.999). { intros d' Hd1 Hd2 Hkz. refine (_ (Main d' Hd1 _)). 2: interval. set (y'' := evalPrim penult _). intros [_ [_ [_ Hb3]]]. replace (_ + _) with (C - Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + (Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF y'') - (Rtrigo_def.exp (xR - IZR (to_Z kq) * Rpower.ln 2) + SF2R radix2 (Prim2SF d'))) + Rtrigo_def.exp (xR - IZR (to_Z kq) * Rpower.ln 2) + SF2R radix2 (Prim2SF d')) by ring. revert Hb3 HC2. fold C xred. generalize (C - Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64))). generalize (Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF y'') - (Rtrigo_def.exp xred + SF2R radix2 (Prim2SF d'))). intros r0 r1 Hr0 Hr1. unfold xred. replace (xR - IZR (to_Z kq) * Rpower.ln 2) with (xR - IZR (to_Z kq) * Rpower.ln 2 - IZR φ (kr)%uint63 * (Rpower.ln 2 / 64) + IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) by ring. revert Hxred. unfold xred. generalize (xR - IZR (to_Z kq) * Rpower.ln 2 - IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)). intros r2 Hr2. assert (Hkr_ : 1 <= IZR (Uint63.to_Z kr) <= 63). { rewrite Hkr1 in Hkr0. split; apply IZR_le; [lia | easy]. } interval. } split. { generalize (Main dlb eq_refl ltac:(cbn; interval)). set (y'' := evalPrim penult _). intros [Hlb1 [Hlb4 [Hlb2 Hlb3]]]. fold k0 kr in Hlb1, Hlb2, Hlb3, Hlb4. generalize (Bldexp_correct _ _ Hprec Hmax mode_NE (Prim2B (C' + y'')) (to_Z (ki >> 6))). specialize (Hb dlb eq_refl (eq_sym Hdlb)). rewrite <- Prim2SF2R_Prim2B2R. change (C' + y'')%float with (@evalPrim (BinFloat :: BinFloat :: nil) BinFloat (Op ADD (Var 0) (Var 1)) (C', (y'', tt))). assert_float. intros p Fp Ep. rewrite Rlt_bool_true. 2: { rewrite Ep. apply Rlt_le_trans with (1 := Hb). interval with (i_prec 60). } set (f := Bldexp _ _ _). intros [Heq [Hfin _]]. refine (_ (Bpred_correct prec emax Hprec Hmax f _)). 2: { now rewrite Hfin, <- is_finite_SF_B2SF, B2SF_Prim2B. } rewrite Heq. case Rlt_bool_spec. 2: { intros _ H. now rewrite <- (SF2B'_B2SF (Bpred f)), H. } intros _ [Heqpred [Hfinpred _]]. replace (Beqb _ _) with false. 2: { simpl. unfold Beqb, SFeqb, SFcompare. now destruct Bpred. } rewrite PrimitiveFloat.B2R_BtoX, Heqpred by easy. split. easy. rewrite Ep. clear Hb Fp Ep. clear dependent f. simpl evalRounded. fold C in bnd_C, HC1, HC2 |- *. clearbody C. eapply Rle_trans. apply pred_FLT_shift_le. easy. apply valid_rnd_round_mode. apply generic_format_round. now apply FLT_exp_valid. apply valid_rnd_round_mode. unfold Rrnd.rnd, round_mode. interval. apply Rmult_le_reg_r with (Rpow2 (- to_Z kq)). { apply bpow_gt_0. } rewrite Rmult_assoc. rewrite <-bpow_plus. rewrite Z.add_opp_diag_r, Rmult_1_r. rewrite bpow_exp, <-exp_plus, opp_IZR. change (IZR radix2) with 2. replace (Rtrigo_def.exp _) with (C + SF2R radix2 (Prim2SF y'') - (C - Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64))) - (Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF y'') - (Rtrigo_def.exp (xR + - IZR (to_Z kq) * Rpower.ln 2) + SF2R radix2 (Prim2SF dlb))) - SF2R radix2 (Prim2SF dlb)) by ring. generalize Hlb3. unfold xred, Rminus at 2. rewrite Ropp_mult_distr_l. fold xR. generalize (Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF y'') - (Rtrigo_def.exp (xR + - IZR (to_Z kq) * Rpower.ln 2) + SF2R radix2 (Prim2SF dlb))). intros r Hr. unfold Rrnd.rnd, round_mode. destruct (Z.eq_dec (Uint63.to_Z kr) 0) as [Hkr | Hkr]. - rewrite Hkr at 1. rewrite HC1 at 1 2 3 by easy. rewrite Rmult_0_l, exp_0, Rminus_eq_0, Rminus_0_r. apply Rle_trans with (1 + SF2R radix2 (Prim2SF y'')). { apply pred_round_le_id. now apply FLT_exp_valid. apply valid_rnd_N. } apply Rminus_le. ring_simplify. cbn -[bpow]. interval. - apply pred_round_N_le with (e := 1%Z). now apply FLT_exp_valid. generalize (Haux_ dlb eq_refl ltac:(rewrite <- Hdlb; interval) Hkr). fold y''. generalize (C + SF2R radix2 (Prim2SF y'')). intros r0 Hr0. interval. revert HC2. generalize (C - Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64))). intros r0 Hr0. ring_simplify. cbn -[bpow]. interval. } clear dlb Hdlb. generalize (Main dub eq_refl ltac:(cbn; interval)). set (y'' := evalPrim penult _). intros [Hub1 [Hub4 [Hub2 Hub3]]]. fold k0 kr in Hub1, Hub2, Hub3, Hub4. generalize (Bldexp_correct _ _ Hprec Hmax mode_NE (Prim2B (C' + y'')) (to_Z (ki >> 6))). specialize (Hb dub eq_refl (eq_sym Hdub)). rewrite <- Prim2SF2R_Prim2B2R. change (C' + y'')%float with (@evalPrim (BinFloat :: BinFloat :: nil) BinFloat (Op ADD (Var 0) (Var 1)) (C', (y'', tt))). assert_float. intros p Fp Ep. rewrite Rlt_bool_true. 2: { rewrite Ep. apply Rlt_le_trans with (1 := Hb). interval with (i_prec 60). } set (f := Bldexp _ _ _). intros [Heq [Hfin _]]. refine (_ (Bsucc_correct prec emax Hprec Hmax f _)). 2: { now rewrite Hfin, <- is_finite_SF_B2SF, B2SF_Prim2B. } rewrite Heq. case Rlt_bool_spec. 2: { intros _ H. now rewrite <- (SF2B'_B2SF (Bsucc f)), H. } intros _ [Heqsucc [Hfinsucc _]]. replace (Beqb _ _) with false. 2: { simpl. unfold Beqb, SFeqb, SFcompare. now destruct Bsucc. } rewrite PrimitiveFloat.B2R_BtoX, Heqsucc by easy. split. easy. rewrite Ep. clear Hb Ep Fp. clear dependent f. simpl evalRounded. fold C in bnd_C, HC1, HC2 |- *. clearbody C. eapply Rle_trans ; cycle 1. apply succ_FLT_shift_ge. easy. apply valid_rnd_round_mode. apply generic_format_round. now apply FLT_exp_valid. apply valid_rnd_round_mode. unfold Rrnd.rnd, round_mode. interval. apply Rmult_le_reg_r with (Rpow2 (- to_Z kq)). { apply bpow_gt_0. } rewrite Rmult_assoc. rewrite <-bpow_plus. rewrite Z.add_opp_diag_r, Rmult_1_r. rewrite bpow_exp, <-exp_plus, opp_IZR. change (IZR radix2) with 2. replace (Rtrigo_def.exp _) with (C + SF2R radix2 (Prim2SF y'') - (C - Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64))) - (Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF y'') - (Rtrigo_def.exp (xR + - IZR (to_Z kq) * Rpower.ln 2) + SF2R radix2 (Prim2SF dub))) - SF2R radix2 (Prim2SF dub)) by ring. generalize Hub3. unfold xred, Rminus at 2. rewrite Ropp_mult_distr_l. fold xR. generalize (Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64)) + SF2R radix2 (Prim2SF y'') - (Rtrigo_def.exp (xR + - IZR (to_Z kq) * Rpower.ln 2) + SF2R radix2 (Prim2SF dub))). intros r Hr. unfold Rrnd.rnd, round_mode. destruct (Z.eq_dec (Uint63.to_Z kr) 0) as [Hkr | Hkr]. - rewrite Hkr at 1. rewrite HC1 at 1 2 3 by easy. rewrite Rmult_0_l, exp_0, Rminus_eq_0, Rminus_0_r. apply Rle_trans with (1 + SF2R radix2 (Prim2SF y'')). 2: { apply succ_round_ge_id. now apply FLT_exp_valid. apply valid_rnd_N. } apply Rminus_le. ring_simplify. cbn -[bpow]. interval. - apply succ_round_N_ge with (e := 1%Z). now apply FLT_exp_valid. generalize (Haux_ dub eq_refl ltac:(rewrite <- Hdub; interval) Hkr). fold y''. generalize (C + SF2R radix2 (Prim2SF y'')). intros r0 Hr0. interval. revert HC2. generalize (C - Rtrigo_def.exp (IZR φ (kr)%uint63 * (Rpower.ln 2 / 64))). intros r0 Hr0. ring_simplify. cbn -[bpow]. interval. Qed. End ExpImpl. Import ExpImpl. Definition exp (prec : F.precision) xi := let aux x := let k0 := (x * InvLog2_64 + 0x1.8p52)%float in let kf := (k0 - 0x1.8p52)%float in let tf := (x - kf * Log2div64h - kf * Log2div64l)%float in let ki := (normfr_mantissa (fst (frshiftexp k0)) - 6755399440921280)%uint63 in let C := consts.[PrimInt63.land ki 63] in let kq := PrimInt63.asr ki 6 in let y := (C * Papprox tf)%float in (C, y, kq) in match xi with | Ibnd xl xu => Ibnd (if F.real xl then if PrimFloat.ltb xl (-0x1.74385446d71c4p9)%float then 0%float else if PrimFloat.ltb 0x1.62e42fefa39efp9%float xl then 0x1.fffffffffffffp1023%float else let '(C, y, kq) := aux xl in next_down (ldshiftexp (C + (y + -0x1.25p-57))%float kq) else 0%float) (if F.real xu then if PrimFloat.ltb xu (-0x1.74385446d71c4p9)%float then 0x1p-1074%float else if PrimFloat.ltb 0x1.62e42fefa39efp9%float xu then infinity else let '(C, y, kq) := aux xu in next_up (ldshiftexp (C + (y + 0x1.25p-57))%float kq) else nan) | Inan => Inan end. Theorem exp_correct : forall prec, extension Xexp (exp prec). Proof. intros prec [|xl xu]. easy. intros [|x]. now simpl; case (_ && _)%bool. unfold convert at 1. case_eq (F.valid_lb xl); [|intros _ [H0 H1]; lra]. case_eq (F.valid_ub xu); [|intros _ _ [H0 H1]; lra]. intros Vxu Vxl [Hxl Hxu]. simpl. assert (Hl := fun H => proj1 (exp_aux_correct xl H)). assert (Hu := fun H => proj2 (exp_aux_correct xu H)). rewrite <- PrimitiveFloat.real_is_finite, F.real_correct, B2Prim_Prim2B in Hl. rewrite <- PrimitiveFloat.real_is_finite, F.real_correct, B2Prim_Prim2B in Hu. set (l := if F.real xl then _ else _). set (u := if F.real xu then _ else _). assert (Vl : F.valid_lb l = true). { unfold l. clear l u. rewrite F.real_correct. destruct (F.toX xl) as [|rxl]. easy. specialize (Hl eq_refl). revert Hl. unfold exp_aux. destruct PrimFloat.ltb. easy. now destruct PrimFloat.ltb. } assert (Vu : F.valid_ub u = true). { unfold u. clear l u Vl. rewrite F.real_correct. destruct (F.toX xu) as [|rxu]. easy. specialize (Hu eq_refl). revert Hu. unfold exp_aux. destruct PrimFloat.ltb. easy. now destruct PrimFloat.ltb. } rewrite Vl, Vu; unfold l, u. split. - clear u Hxu Hu Vu. rewrite F.real_correct. assert (Hxl' := PrimitiveFloat.toX_Prim2B xl). destruct (F.toX xl) as [|rxl]. apply Rlt_le, exp_pos. apply eq_sym, PrimitiveFloat.BtoX_B2R in Hxl'. specialize (Hl eq_refl). revert Hl. unfold exp_aux. intros [_ H]. destruct PrimFloat.ltb. apply Rle_trans with (1 := H). apply Raux.exp_le. now rewrite <- Hxl'. destruct PrimFloat.ltb. apply Rle_trans with (1 := H). apply Raux.exp_le. now rewrite <- Hxl'. revert H. set (yl := next_down _). simpl. destruct F.toX as [|ryl]. easy. intros H. apply Rle_trans with (1 := H). apply Raux.exp_le. now rewrite <- Hxl'. - clear l Hxl Hl Vl. rewrite F.real_correct. assert (Hxu' := PrimitiveFloat.toX_Prim2B xu). destruct (F.toX xu) as [|rxu]. easy. apply eq_sym, PrimitiveFloat.BtoX_B2R in Hxu'. specialize (Hu eq_refl). revert Hu. unfold exp_aux. intros [_ H]. destruct PrimFloat.ltb. apply Rle_trans with (2 := H). apply Raux.exp_le. now rewrite <- Hxu'. destruct PrimFloat.ltb. easy. revert H. set (yl := next_up _). simpl. destruct F.toX as [|ryu]. easy. intros H. apply Rle_trans with (2 := H). apply Raux.exp_le. now rewrite <- Hxu'. Qed. End PrimFloatIntervalFull. interval-4.11.1/src/Interval/Interval.v000066400000000000000000000626761470547631300200030ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Bool Reals Psatz. From Coquelicot Require Import Coquelicot. Require Import Stdlib. Require Import Xreal. Require Import Basic. Inductive interval : Set := | Inan : interval | Ibnd (l u : ExtendedR) : interval. Definition Xlower (xi : interval) : ExtendedR := match xi with | Ibnd xl _ => xl | _ => Xnan end. Definition Xupper (xi : interval) : ExtendedR := match xi with | Ibnd _ xu => xu | _ => Xnan end. Definition contains i v := match i, v with | Ibnd l u, Xreal x => match l with | Xreal r => Rle r x | Xnan => True end /\ match u with | Xreal r => Rle x r | Xnan => True end | Inan, _ => True | _, Xnan => False end. Inductive output_bound : Set := | BInteger : Z -> output_bound | BDecimal : QArith_base.Q -> output_bound | BFraction : Z -> Z -> output_bound. Definition convert_bound b := match b with | BInteger n => IZR n | BDecimal q => Q2R q | BFraction n d => (IZR n / IZR d)%R end. Definition contains_output xi x := match xi with | (None, None) => True | (None, Some xu) => (x <= convert_bound xu)%R | (Some xl, None) => (convert_bound xl <= x)%R | (Some xl, Some xu) => (convert_bound xl <= x <= convert_bound xu)%R end. Lemma contains_connected : forall xi, connected (fun x => contains xi (Xreal x)). Proof. intros [|l u] a b Ha Hb x Hx. exact I. split. destruct l as [|l]. exact I. exact (Rle_trans _ _ _ (proj1 Ha) (proj1 Hx)). destruct u as [|u]. exact I. exact (Rle_trans _ _ _ (proj2 Hx) (proj2 Hb)). Qed. Lemma contains_Xnan : forall xi, contains xi Xnan <-> xi = Inan. Proof. intros xi. now case xi ; split. Qed. Lemma contains_Inan : forall xi x, xi = Inan -> contains xi x. Proof. now intros xi x ->. Qed. Lemma contains_le : forall xl xu v, contains (Ibnd xl xu) v -> le_lower xl v /\ le_upper v xu. Proof. intros xl xu v. case v. intro. elim H. intros r. case xl. intro. exact H. intros l (Hl, Hu). split. exact (Ropp_le_contravar _ _ Hl). exact Hu. Qed. Lemma le_contains : forall xl xu v, le_lower xl (Xreal v) -> le_upper (Xreal v) xu -> contains (Ibnd xl xu) (Xreal v). Proof. intros xl xu v. case xl. intros _ Hu. exact (conj I Hu). intros l Hl Hu. split. exact (Ropp_le_cancel _ _ Hl). exact Hu. Qed. Definition subset xi yi := match xi, yi with | Ibnd xl xu, Ibnd yl yu => match xl, xu with | Xreal xl, Xreal xu => (xu < xl)%R | _, _ => False end \/ (le_lower yl xl /\ le_upper xu yu) | _, Inan => True | _, _ => False end. Definition subset' xi yi := forall x, contains xi x -> contains yi x. Theorem subset_contains : forall xi yi, subset xi yi -> subset' xi yi. Proof. intros xi yi. destruct yi as [|yl yu]. easy. destruct xi as [|xl xu]. easy. intros H [|v] Hv. easy. destruct H as [H|[H1 H2]]. { destruct xl as [|xl]. easy. destruct xu as [|xu]. easy. simpl in Hv. lra. } apply contains_le in Hv. apply le_contains. now apply le_lower_trans with (1 := H1). now apply le_upper_trans with (2 := H2). Qed. Definition domain' P b := forall x, contains b (Xreal x) -> P x. Theorem bisect' : forall P xl xm xu, domain' P (Ibnd xl xm) -> domain' P (Ibnd xm xu) -> domain' P (Ibnd xl xu). Proof. intros P xl xm xu Hl Hu x H. elim H. case_eq xm ; intros. apply Hu. rewrite H0. exact (conj I (proj2 H)). case (Rle_dec x r) ; intros Hr. apply Hl. apply le_contains. exact (proj1 (contains_le _ _ _ H)). rewrite H0. exact Hr. apply Hu. apply le_contains. rewrite H0. unfold le_lower. simpl. apply Ropp_le_contravar. auto with real. exact (proj2 (contains_le _ _ _ H)). Qed. Definition not_empty xi := exists v, contains xi (Xreal v). Lemma contains_Xreal : forall xi x, contains xi x -> contains xi (Xreal (proj_val x)). Proof. intros xi [|x]. now destruct xi. easy. Qed. Lemma not_empty_contains : forall xi x, contains xi x -> not_empty xi. Proof. intros xi x Hx. exists (proj_val x). now apply contains_Xreal. Qed. Lemma contains_lower : forall l u x, contains (Ibnd (Xreal l) u) x -> contains (Ibnd (Xreal l) u) (Xreal l). Proof. intros. split. apply Rle_refl. destruct x as [|x]. elim H. destruct u as [|u]. exact I. apply Rle_trans with (1 := proj1 H) (2 := proj2 H). Qed. Lemma contains_upper : forall l u x, contains (Ibnd l (Xreal u)) x -> contains (Ibnd l (Xreal u)) (Xreal u). Proof. intros. split. destruct x as [|x]. elim H. destruct l as [|l]. exact I. apply Rle_trans with (1 := proj1 H) (2 := proj2 H). apply Rle_refl. Qed. Module Type IntervalBounds. Parameter type : Type. Parameter nan : type. Parameter convert : type -> ExtendedR. Parameter precision : Type. Parameter PtoP : positive -> precision. End IntervalBounds. Module Type IntervalBasicOps. Declare Module F : IntervalBounds. Parameter type : Type. Parameter valid_lb : F.type -> Prop. Parameter valid_ub : F.type -> Prop. Parameter convert : type -> interval. Parameter zero : type. Parameter nai : type. Parameter empty : type. Parameter bnd : F.type -> F.type -> type. Parameter singleton : F.type -> type. Parameter real : type -> bool. Parameter is_empty : type -> bool. Parameter valid_lb_real : forall b, F.convert b = Xreal (proj_val (F.convert b)) -> valid_lb b. Parameter valid_ub_real : forall b, F.convert b = Xreal (proj_val (F.convert b)) -> valid_ub b. Parameter valid_lb_nan : valid_lb F.nan. Parameter valid_ub_nan : valid_ub F.nan. Parameter bnd_correct : forall l u, valid_lb l -> valid_ub u -> convert (bnd l u) = Ibnd (F.convert l) (F.convert u). Parameter singleton_correct : forall b, contains (convert (singleton b)) (Xreal (proj_val (F.convert b))). Parameter zero_correct : convert zero = Ibnd (Xreal 0) (Xreal 0). Parameter nai_correct : convert nai = Inan. Parameter empty_correct : forall x, contains (convert empty) x -> False. Parameter real_correct : forall xi, real xi = match convert xi with Inan => false | _ => true end. Parameter is_empty_correct : forall xi x, contains (convert xi) x -> is_empty xi = true -> False. Parameter output : bool -> type -> option output_bound * option output_bound. Parameter output_correct : forall fmt xi x, contains (convert xi) (Xreal x) -> contains_output (output fmt xi) x. Parameter subset : type -> type -> bool. Parameter subset_correct : forall xi yi v, contains (convert xi) v -> subset xi yi = true -> contains (convert yi) v. Parameter join : type -> type -> type. Parameter meet : type -> type -> type. Parameter sign_large : type -> Xcomparison. Parameter sign_strict : type -> Xcomparison. Parameter sign_large_correct : forall xi, match sign_large xi with | Xeq => forall x, contains (convert xi) x -> x = Xreal 0 | Xlt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rle (proj_val x) 0 | Xgt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rle 0 (proj_val x) | Xund => True end. Parameter sign_strict_correct : forall xi, match sign_strict xi with | Xeq => forall x, contains (convert xi) x -> x = Xreal 0 | Xlt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rlt (proj_val x) 0 | Xgt => forall x, contains (convert xi) x -> x = Xreal (proj_val x) /\ Rlt 0 (proj_val x) | Xund => True end. Parameter join_correct : forall xi yi v, contains (convert xi) v \/ contains (convert yi) v -> contains (convert (join xi yi)) v. Parameter meet_correct : forall xi yi v, contains (convert xi) v -> contains (convert yi) v -> contains (convert (meet xi yi)) v. Parameter meet_correct' : forall xi yi v, contains (convert (meet xi yi)) v -> contains (convert xi) v /\ contains (convert yi) v. Parameter midpoint : type -> F.type. Parameter midpoint_correct : forall xi, not_empty (convert xi) -> F.convert (midpoint xi) = Xreal (proj_val (F.convert (midpoint xi))) /\ contains (convert xi) (F.convert (midpoint xi)). Parameter bisect : type -> type * type. Parameter bisect_correct : forall xi x, contains (convert xi) x -> contains (convert (fst (bisect xi))) x \/ contains (convert (snd (bisect xi))) x. Definition extension f fi := forall b x, contains (convert b) x -> contains (convert (fi b)) (f x). Definition extension_2 f fi := forall ix iy x y, contains (convert ix) x -> contains (convert iy) y -> contains (convert (fi ix iy)) (f x y). Parameter mask : type -> type -> type. Parameter mask_correct : extension_2 Xmask mask. Parameter mask_correct' : forall xi yi x, contains (convert xi) x -> contains (convert (mask xi yi)) x. Definition precision := F.precision. Parameter wider : precision -> type -> type -> bool. Parameter neg : type -> type. Parameter abs : type -> type. Parameter inv : precision -> type -> type. Parameter invnz : precision -> type -> type. Parameter sqr : precision -> type -> type. Parameter sqrt : precision -> type -> type. Parameter add : precision -> type -> type -> type. Parameter sub : precision -> type -> type -> type. Parameter mul : precision -> type -> type -> type. Parameter div : precision -> type -> type -> type. Parameter power_int : precision -> type -> Z -> type. Parameter nearbyint : rounding_mode -> type -> type. Parameter error_fix : precision -> rounding_mode -> Z -> type -> type. Parameter error_flt : precision -> rounding_mode -> Z -> positive -> type -> type. Parameter neg_correct : extension Xneg neg. Parameter abs_correct : extension Xabs abs. Parameter inv_correct : forall prec, extension Xinv (inv prec). Parameter sqr_correct : forall prec, extension Xsqr (sqr prec). Parameter sqrt_correct : forall prec, extension Xsqrt (sqrt prec). Parameter add_correct : forall prec, extension_2 Xadd (add prec). Parameter sub_correct : forall prec, extension_2 Xsub (sub prec). Parameter mul_correct : forall prec, extension_2 Xmul (mul prec). Parameter div_correct : forall prec, extension_2 Xdiv (div prec). Parameter power_int_correct : forall prec n, extension (fun x => Xpower_int x n) (fun x => power_int prec x n). Parameter nearbyint_correct : forall mode, extension (Xnearbyint mode) (nearbyint mode). Parameter error_fix_correct : forall prec mode emin, extension (Xerror_fix mode emin) (error_fix prec mode emin). Parameter error_flt_correct : forall prec mode emin p, extension (Xerror_flt mode emin p) (error_flt prec mode emin p). Parameter neg_correct' : forall xi x, contains (convert (neg xi)) (Xneg x) -> contains (convert xi) x. Parameter invnz_correct : forall prec xi x, x <> Xreal 0 -> contains (convert xi) x -> contains (convert (invnz prec xi)) (Xinv x). Parameter cancel_add : precision -> type -> type -> type. Parameter cancel_sub : precision -> type -> type -> type. Parameter bounded : type -> bool. Parameter lower_bounded : type -> bool. Parameter upper_bounded : type -> bool. Parameter lower_extent : type -> type. Parameter upper_extent : type -> type. Parameter whole : type. Parameter lower_extent_correct : forall xi x y, contains (convert xi) (Xreal y) -> (x <= y)%R -> contains (convert (lower_extent xi)) (Xreal x). Parameter upper_extent_correct : forall xi x y, contains (convert xi) (Xreal y) -> (y <= x)%R -> contains (convert (upper_extent xi)) (Xreal x). Parameter whole_correct : forall x, contains (convert whole) (Xreal x). Parameter lower_complement : type -> type. Parameter upper_complement : type -> type. Parameter lower_complement_correct : forall xi x y, contains (convert xi) (Xreal x) -> contains (convert (lower_complement xi)) (Xreal y) -> (y <= x)%R. Parameter upper_complement_correct : forall xi x y, contains (convert xi) (Xreal x) -> contains (convert (upper_complement xi)) (Xreal y) -> (x <= y)%R. Parameter lower : type -> F.type. Parameter upper : type -> F.type. Parameter lower_correct : forall xi : type, not_empty (convert xi) -> F.convert (lower xi) = Xlower (convert xi). Parameter valid_lb_lower : forall xi : type, not_empty (convert xi) -> valid_lb (lower xi). Parameter upper_correct : forall xi : type, not_empty (convert xi) -> F.convert (upper xi) = Xupper (convert xi). Parameter valid_ub_upper : forall xi : type, not_empty (convert xi) -> valid_ub (upper xi). Definition bounded_prop xi := not_empty (convert xi) -> convert xi = Ibnd (F.convert (lower xi)) (F.convert (upper xi)). Parameter lower_bounded_correct : forall xi, lower_bounded xi = true -> F.convert (lower xi) = Xreal (proj_val (F.convert (lower xi))) /\ bounded_prop xi. Parameter upper_bounded_correct : forall xi, upper_bounded xi = true -> F.convert (upper xi) = Xreal (proj_val (F.convert (upper xi))) /\ bounded_prop xi. Parameter bounded_correct : forall xi, bounded xi = true -> lower_bounded xi = true /\ upper_bounded xi = true. Parameter fromZ_small : Z -> type. Parameter fromZ_small_correct : forall v, (Z.abs v <= 256)%Z -> contains (convert (fromZ_small v)) (Xreal (IZR v)). Parameter fromZ : precision -> Z -> type. Parameter fromZ_correct : forall prec v, contains (convert (fromZ prec v)) (Xreal (IZR v)). Definition propagate_l fi := forall xi yi : type, convert xi = Inan -> convert (fi xi yi) = Inan. Definition propagate_r fi := forall xi yi : type, convert yi = Inan -> convert (fi xi yi) = Inan. Parameter mask_propagate_l : propagate_l mask. Parameter mask_propagate_r : propagate_r mask. Parameter add_propagate_l : forall prec, propagate_l (add prec). Parameter sub_propagate_l : forall prec, propagate_l (sub prec). Parameter mul_propagate_l : forall prec, propagate_l (mul prec). Parameter div_propagate_l : forall prec, propagate_l (div prec). Parameter add_propagate_r : forall prec, propagate_r (add prec). Parameter sub_propagate_r : forall prec, propagate_r (sub prec). Parameter mul_propagate_r : forall prec, propagate_r (mul prec). Parameter div_propagate_r : forall prec, propagate_r (div prec). End IntervalBasicOps. Module Type IntervalOps. Include IntervalBasicOps. Parameter pi : precision -> type. Parameter cos : precision -> type -> type. Parameter sin : precision -> type -> type. Parameter tan : precision -> type -> type. Parameter atan : precision -> type -> type. Parameter exp : precision -> type -> type. Parameter ln : precision -> type -> type. Parameter pi_correct : forall prec, contains (convert (pi prec)) (Xreal PI). Parameter cos_correct : forall prec, extension Xcos (cos prec). Parameter sin_correct : forall prec, extension Xsin (sin prec). Parameter tan_correct : forall prec, extension Xtan (tan prec). Parameter atan_correct : forall prec, extension Xatan (atan prec). Parameter exp_correct : forall prec, extension Xexp (exp prec). Parameter ln_correct : forall prec, extension Xln (ln prec). End IntervalOps. Module IntervalBasicExt (I : IntervalBasicOps). Lemma nai_correct : forall x, contains (I.convert I.nai) x. Proof. intros x. now rewrite I.nai_correct. Qed. Lemma contains_le : forall xi x, contains (I.convert xi) x -> le_lower (I.F.convert (I.lower xi)) x /\ le_upper x (I.F.convert (I.upper xi)). Proof. intros xi x H. assert (H' := not_empty_contains _ _ H). rewrite I.lower_correct, I.upper_correct by easy. destruct I.convert as [|xl xu]. easy. now apply contains_le. Qed. Definition propagate fi := forall xi, I.convert xi = Inan -> I.convert (fi xi) = Inan. Lemma propagate_extension : forall fi f, I.extension (Xbind f) fi -> propagate fi. Proof. intros fi f Hf xi H. specialize (Hf xi Xnan). rewrite H in Hf. specialize (Hf I). clear -Hf. now destruct I.convert. Qed. Lemma neg_propagate : propagate I.neg. Proof. apply propagate_extension with (1 := I.neg_correct). Qed. Lemma inv_propagate : forall prec, propagate (I.inv prec). Proof. intros prec. apply propagate_extension with (1 := I.inv_correct prec). Qed. Lemma sqrt_propagate : forall prec, propagate (I.sqrt prec). Proof. intros prec. apply propagate_extension with (1 := I.sqrt_correct prec). Qed. Lemma power_int_propagate : forall prec n, propagate (fun x => I.power_int prec x n). Proof. intros prec n. apply propagate_extension with (1 := I.power_int_correct prec n). Qed. Lemma error_fix_propagate : forall prec mode emin, propagate (I.error_fix prec mode emin). Proof. intros prec mode emin. apply propagate_extension with (1 := I.error_fix_correct prec mode emin). Qed. Lemma error_flt_propagate : forall prec mode emin p, propagate (I.error_flt prec mode emin p). Proof. intros prec mode emin p. apply propagate_extension with (1 := I.error_flt_correct prec mode emin p). Qed. Definition extension f fi := forall (xi : I.type) (x : R), contains (I.convert xi) (Xreal x) -> contains (I.convert (fi xi)) (Xreal (f x)). Definition extension_2 f fi := forall (xi yi : I.type) (x y : R), contains (I.convert xi) (Xreal x) -> contains (I.convert yi) (Xreal y) -> contains (I.convert (fi xi yi)) (Xreal (f x y)). Lemma neg_correct : extension Ropp I.neg. Proof. intros xi x. now apply I.neg_correct. Qed. Lemma abs_correct : extension Rabs I.abs. Proof. intros xi x. now apply I.abs_correct. Qed. Lemma inv_correct : forall prec, extension Rinv (I.inv prec). Proof. intros prec xi x Hx. generalize (I.inv_correct prec xi _ Hx). unfold Xinv', Xbind. case is_zero ; try easy. now case I.convert. Qed. Lemma invnz_correct : forall prec xi x, x <> 0%R -> contains (I.convert xi) (Xreal x) -> contains (I.convert (I.invnz prec xi)) (Xreal (/ x)). Proof. intros prec xi x Zx Hx. refine (_ (I.invnz_correct prec xi _ _ Hx)). unfold Xinv', Xbind. now rewrite is_zero_false. contradict Zx. now injection Zx. Qed. Lemma sqr_correct : forall prec, extension Rsqr (I.sqr prec). Proof. intros prec xi x. now apply I.sqr_correct. Qed. Lemma sqrt_correct : forall prec, extension sqrt (I.sqrt prec). Proof. intros prec xi x Hx. generalize (I.sqrt_correct prec xi _ Hx). unfold Xsqrt', Xbind. case is_negative ; try easy. Qed. Lemma add_correct : forall prec, extension_2 Rplus (I.add prec). Proof. intros prec xi yi x y. now apply I.add_correct. Qed. Lemma sub_correct : forall prec, extension_2 Rminus (I.sub prec). Proof. intros prec xi yi x y. now apply I.sub_correct. Qed. Lemma mul_correct : forall prec, extension_2 Rmult (I.mul prec). Proof. intros prec xi yi x y. now apply I.mul_correct. Qed. Lemma div_correct : forall prec, extension_2 Rdiv (I.div prec). Proof. intros prec xi yi x y Hx Hy. generalize (I.div_correct prec _ _ _ _ Hx Hy). simpl. unfold Xdiv'. case is_zero ; try easy. now case I.convert. Qed. Lemma nearbyint_correct : forall mode, extension (Rnearbyint mode) (I.nearbyint mode). Proof. intros mode xi x. now apply I.nearbyint_correct. Qed. Definition round_fix prec mode emin xi := I.add prec xi (I.error_fix prec mode emin xi). Lemma round_fix_correct : forall mode prec emin, extension (Basic.round_fix mode emin) (round_fix prec mode emin). Proof. intros mode prec emin xi x Hx. unfold round_fix. replace (Basic.round_fix mode emin x) with (x + (Basic.round_fix mode emin x - x)) by ring. apply add_correct; [easy| ]. now apply I.error_fix_correct with (x := Xreal x). Qed. Lemma round_fix_correct' : forall mode prec emin, I.extension (Xround_fix mode emin) (round_fix prec mode emin). Proof. unfold round_fix. intros mode prec emin xi [ |x] Hx ; simpl. - now apply contains_Xnan, I.add_propagate_l, contains_Xnan. - replace (Basic.round_fix mode emin x) with (x + (Basic.round_fix mode emin x - x)) by ring. apply add_correct; [easy| ]. now apply I.error_fix_correct with (x := Xreal x). Qed. Definition round_flt prec mode emin p xi := I.add prec xi (I.error_flt prec mode emin p xi). Lemma round_flt_correct : forall mode prec emin p, extension (Basic.round_flt mode emin p) (round_flt prec mode emin p). Proof. intros mode prec emin p xi x Hx. unfold round_flt. replace (Basic.round_flt mode emin p x) with (x + (Basic.round_flt mode emin p x - x)) by ring. apply add_correct; [easy| ]. now apply I.error_flt_correct with (x := Xreal x). Qed. Lemma round_flt_correct' : forall mode prec emin p, I.extension (Xround_flt mode emin p) (round_flt prec mode emin p). Proof. unfold round_flt. intros mode prec emin p xi [| x] Hx ; simpl. - now apply contains_Xnan, I.add_propagate_l, contains_Xnan. - replace (Basic.round_flt mode emin p x) with (x + (Basic.round_flt mode emin p x - x)) by ring. apply add_correct; [easy| ]. now apply I.error_flt_correct with (x := Xreal x). Qed. Lemma power_int_correct : forall prec n, extension (fun x => powerRZ x n) (fun xi => I.power_int prec xi n). Proof. intros prec n xi x Hx. generalize (I.power_int_correct prec n xi _ Hx). unfold Xpower_int, Xpower_int', Xbind. destruct n as [|n|n] ; try easy. case is_zero ; try easy. now case I.convert. Qed. Lemma zero_correct : contains (I.convert I.zero) (Xreal 0). Proof. rewrite I.zero_correct. split ; apply Rle_refl. Qed. Lemma contains_only_0 r : contains (I.convert I.zero) (Xreal r) -> r = 0%R. Proof. rewrite I.zero_correct. intros [H1 H2]. now apply Rle_antisym. Qed. Lemma join_correct : forall ui vi u v x, contains (I.convert ui) (Xreal u) -> contains (I.convert vi) (Xreal v) -> (u <= x <= v)%R -> contains (I.convert (I.join ui vi)) (Xreal x). Proof. intros ui vi u v x Iu Iv [H1 H2]. assert (Hu := I.join_correct ui vi (Xreal u)). assert (Hv := I.join_correct ui vi (Xreal v)). destruct (I.convert (I.join ui vi)) as [|p q]. easy. split. destruct p as [|p]. easy. apply Rle_trans with (2 := H1). apply Hu. now left. destruct q as [|q]. easy. apply Rle_trans with (1 := H2). apply Hv. now right. Qed. Lemma contains_RInt prec (f3 : R -> R) x1 x2 Y X1 X2 : ex_RInt f3 x1 x2-> contains (I.convert X1) (Xreal x1) -> contains (I.convert X2) (Xreal x2) -> (forall x, (Rmin x1 x2 <= x <= Rmax x1 x2)%R -> contains (I.convert Y) (Xreal (f3 x))) -> contains (I.convert (I.mul prec (I.sub prec X2 X1) Y)) (Xreal (RInt f3 x1 x2)). Proof. intros Hf3_int HZx1 HZx2 Hext. destruct (Req_dec x2 x1) as [H|H]. { rewrite H, RInt_point. unfold zero ; simpl. rewrite <- (Rmult_0_l (f3 x1)). apply mul_correct. rewrite <- (Rminus_diag_eq x2 x1) by easy. now apply sub_correct. apply Hext. apply Rmin_Rmax_l. } replace (RInt f3 x1 x2) with ((x2 - x1) * ((RInt f3 x1 x2) / (x2 - x1)))%R. 2: { field. now apply Rminus_eq_contra. } apply mul_correct. now apply sub_correct. assert (H': forall x1 x2 : R, x1 < x2 -> (forall x, Rmin x1 x2 <= x <= Rmax x1 x2 -> contains (I.convert Y) (Xreal (f3 x))) -> ex_RInt f3 x1 x2 -> contains (I.convert Y) (Xreal (RInt f3 x1 x2 / (x2 - x1)))). 2: { destruct (Rdichotomy _ _ H) as [H21|H12]. apply ex_RInt_swap in Hf3_int. rewrite <- opp_RInt_swap by easy. replace (-_/_)%R with (RInt f3 x2 x1 / (x1 - x2))%R by (field; lra). apply H' ; try easy. now rewrite Rmin_comm, Rmax_comm. now apply H'. } clear. intros x1 x2 H' Hext Hf3_int. destruct (I.convert Y) as [|l u]. easy. apply le_contains. - destruct l as [|rl]. easy. unfold le_lower, le_upper. simpl. apply Ropp_le_contravar. apply RInt_le_l ; try easy. intros x Hx. apply Hext. now rewrite -> Rmin_left, Rmax_right ; try apply Rlt_le. - destruct u as [|ru]. easy. unfold le_upper. apply RInt_le_r ; try easy. intros x Hx. apply Hext. now rewrite -> Rmin_left, Rmax_right ; try apply Rlt_le. Qed. Definition midpoint xi := let m := I.midpoint xi in I.bnd m m. Lemma midpoint_correct : forall xi, not_empty (I.convert xi) -> I.convert (midpoint xi) = let m := Xreal (proj_val (I.F.convert (I.midpoint xi))) in Ibnd m m. Proof. intros xi Ex. destruct (I.midpoint_correct xi Ex) as [H1 H2]. unfold midpoint. rewrite I.bnd_correct. now rewrite H1. now apply I.valid_lb_real. now apply I.valid_ub_real. Qed. Lemma contains_midpoint : forall xi, not_empty (I.convert xi) -> contains (I.convert (midpoint xi)) (Xreal (proj_val (I.F.convert (I.midpoint xi)))). Proof. intros xi Hx. rewrite (midpoint_correct xi Hx). split ; apply Rle_refl. Qed. Lemma subset_midpoint : forall xi, not_empty (I.convert xi) -> subset' (I.convert (midpoint xi)) (I.convert xi). Proof. intros xi Ex. rewrite (midpoint_correct xi Ex). intros [|x]. easy. intros [H1 H2]. rewrite (Rle_antisym _ _ H2 H1). destruct (I.midpoint_correct xi Ex) as [H3 H4]. now rewrite <- H3. Qed. End IntervalBasicExt. Module IntervalExt (I : IntervalOps). Include (IntervalBasicExt I). Lemma cos_correct : forall prec, extension cos (I.cos prec). Proof. intros prec xi x. now apply I.cos_correct. Qed. Lemma sin_correct : forall prec, extension sin (I.sin prec). Proof. intros prec xi x. now apply I.sin_correct. Qed. Lemma tan_correct : forall prec, extension tan (I.tan prec). Proof. intros prec xi x Hx. generalize (I.tan_correct prec xi _ Hx). unfold Xtan', Xbind. case is_zero ; try easy. now case I.convert. Qed. Lemma atan_correct : forall prec, extension atan (I.atan prec). Proof. intros prec xi x. now apply I.atan_correct. Qed. Lemma exp_correct : forall prec, extension exp (I.exp prec). Proof. intros prec xi x. now apply I.exp_correct. Qed. Lemma ln_correct : forall prec, extension ln (I.ln prec). Proof. intros prec xi x Hx. generalize (I.ln_correct prec xi _ Hx). unfold Xln', Xbind. case is_positive ; try easy. now case I.convert. Qed. End IntervalExt. interval-4.11.1/src/Interval/Interval_compl.v000066400000000000000000000232231470547631300211560ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals Psatz. From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat bigop. From Coquelicot Require Import Coquelicot. Require Import Stdlib. Require Import MathComp. Require Import Xreal. Require Import Interval. Require Import Taylor. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope nat_scope. Notation IInan := Interval.Inan (only parsing). (**************************************************************) (** Some support results relating inequalities and [contains] *) (**************************************************************) Definition intvl a b x := (a <= x <= b)%R. Lemma intvl_connected a b : connected (intvl a b). Proof. move=> x y Hx Hy z Hz; split. - exact: Rle_trans (proj1 Hx) (proj1 Hz). - exact: Rle_trans (proj2 Hz) (proj2 Hy). Qed. Lemma intvl_l l u x0 : intvl l u x0 -> intvl l u l. Proof. by case=> [H1 H2]; split =>//; apply: Rle_refl || apply: Rle_trans H2. Qed. Lemma intvl_u l u x0 : intvl l u x0 -> intvl l u u. Proof. by case=> [H1 H2]; split =>//; apply: Rle_refl || apply: Rle_trans H2. Qed. Lemma intvl_lVu l u x0 x : intvl l u x -> intvl l u x0 -> intvl l x0 x \/ intvl x0 u x. Proof. move=> [H1 H2] [H3 H4]. have [Hle|Hlt] := Rle_lt_dec x x0. by left. by move/Rlt_le in Hlt; right. Qed. (********************************************) (** Some support results about monotonicity *) (********************************************) Section PredArg. Variable P : R -> Prop. Definition Rincr (f : R -> R) := forall x y : R, P x -> P y -> (x <= y -> f x <= f y)%R. Definition Rdecr (f : R -> R) := forall x y : R, P x -> P y -> (x <= y -> f y <= f x)%R. Definition Rmonot (f : R -> R) := Rincr f \/ Rdecr f. Definition Rpos_over (g : R -> R) := forall x : R, (P x -> 0 <= g x)%R. Definition Rneg_over (g : R -> R) := forall x : R, (P x -> g x <= 0)%R. Definition Rcst_sign (g : R -> R) := Rpos_over g \/ Rneg_over g. Definition Rderive_over (f f' : R -> R) := forall x : R, P x -> is_derive f x (f' x). Lemma Rderive_pos_imp_incr (f f' : R -> R) : connected P -> Rderive_over f f' -> Rpos_over f' -> Rincr f. Proof. rewrite /Rpos_over /Rincr. move=> Hco Hder H0 x y Hx Hy Hxy; rewrite //=. eapply (derivable_pos_imp_increasing f f' P) =>//. move=> r Hr. move/(_ _ Hr) in Hder. move/(_ _ Hr) in H0. apply: conj H0. exact/is_derive_Reals. Qed. Lemma Rderive_neg_imp_decr (f f' : R -> R) : connected P -> Rderive_over f f' -> Rneg_over f' -> Rdecr f. Proof. rewrite /Rneg_over /Rdecr. move=> Hco Hder H0 x y Hx Hy Hxy; rewrite //=. eapply (derivable_neg_imp_decreasing f f' P) =>//. move=> r Hr. move/(_ _ Hr) in Hder. move/(_ _ Hr) in H0. apply: conj H0. exact/is_derive_Reals. Qed. Lemma Rderive_cst_sign (f f' : R -> R) : connected P -> Rderive_over f f' -> Rcst_sign f' -> Rmonot f. Proof. move=> Hco Hder [H|H]. left; exact: Rderive_pos_imp_incr H. right; exact: Rderive_neg_imp_decr H. Qed. End PredArg. (********************************************************************) (** Instantiation of [Taylor.Cor_Taylor_Lagrange] for intervals *) (********************************************************************) Lemma sum_f_to_big n (f : nat -> R) : sum_f_R0 f n = \big[Rplus/0%R]_(0 <= i < n.+1) f i. Proof. elim: n =>[|n IHn]; first by rewrite big_nat_recl // big_mkord big_ord0 Rplus_0_r. by rewrite big_nat_recr //= IHn. Qed. Section NDerive. Variable xf : R -> ExtendedR. Let f x := proj_val (xf x). Let Dn := Derive_n f. Variable dom : R -> Prop. Hypothesis Hdom : connected dom. Variable n : nat. Hypothesis Hdef : forall r, dom r -> xf r <> Xnan. Hypothesis Hder : forall n r, dom r -> ex_derive_n f n r. Theorem ITaylor_Lagrange x0 x : dom x0 -> dom x -> exists xi : R, dom xi /\ (f x - \big[Rplus/0%R]_(0 <= i < n.+1) (Dn i x0 / INR (fact i) * (x - x0)^i))%R = (Dn n.+1 xi / INR (fact n.+1) * (x - x0) ^ n.+1)%R /\ (x <= xi <= x0 \/ x0 <= xi <= x)%R. Proof. move=> Hx0 Hx. case (Req_dec x0 x)=> [->|Hneq]. exists x; split =>//=; split; last by auto with real. rewrite (Rminus_diag_eq x) // Rmult_0_l Rmult_0_r. rewrite big_nat_recl // pow_O big1 /Dn /=; try field. by move=> i _; rewrite Rmult_0_l Rmult_0_r. have Hlim x1 x2 : (x1 < x2)%R -> dom x1 -> dom x2 -> forall (k : nat) (r1 : R), (k <= n)%coq_nat -> (fun r2 : R => x1 <= r2 <= x2)%R r1 -> derivable_pt_lim (Dn k) r1 (Dn (S k) r1). move=> Hx12 Hdom1 Hdom2 k y Hk Hy. have Hdy: (dom y) by move: Hdom; rewrite /connected; move/(_ x1 x2); apply. by apply/is_derive_Reals/Derive_correct; apply: (Hder k.+1 Hdy). destruct (total_order_T x0 x) as [[H1|H2]|H3]; last 2 first. by case: Hneq. have H0 : (x <= x0 <= x0)%R by auto with real. have H : (x <= x <= x0)%R by auto with real. case: (Cor_Taylor_Lagrange x x0 n (fun n r => (Dn n r)) (Hlim _ _ (Rgt_lt _ _ H3) Hx Hx0) x0 x H0 H) => [c [Hc Hc1]]. exists c. have Hdc : dom c. move: Hdom; rewrite /connected; move/(_ x x0); apply=>//. by case: (Hc1 Hneq)=> [J|K]; lra. split=>//; split; last by case:(Hc1 Hneq);rewrite /=; [right|left]; intuition. rewrite sum_f_to_big in Hc. exact: Hc. have H0 : (x0 <= x0 <= x)%R by auto with real. have H : (x0 <= x <= x)%R by auto with real. case: (Cor_Taylor_Lagrange x0 x n (fun n r => Dn n r) (Hlim _ _ (Rgt_lt _ _ H1) Hx0 Hx) x0 x H0 H) => [c [Hc Hc1]]. exists c. have Hdc : dom c. move: Hdom; rewrite /connected; move/(_ x0 x); apply=>//. by case: (Hc1 Hneq)=> [J|K]; lra. split=>//; split; last by case:(Hc1 Hneq);rewrite /=; [right|left]; intuition. rewrite sum_f_to_big in Hc. exact: Hc. Qed. End NDerive. (******************************************************************************) (** The sequel of the file is parameterized by an implementation of intervals *) (******************************************************************************) Module IntervalAux (I : IntervalOps). (** The following predicate will be used by [Ztech]. *) Definition isNNegOrNPos (X : I.type) : bool := if I.sign_large X is Xund then false else true. Lemma isNNegOrNPos_false (X : I.type) : I.convert X = IInan -> isNNegOrNPos X = false. Proof. move=> H; rewrite /isNNegOrNPos; have := I.sign_large_correct X. by case: I.sign_large =>//; rewrite H; move/(_ Xnan I) =>//; case. Qed. Definition gt0 xi : bool := if I.sign_strict xi is Xgt then true else false. Definition apart0 xi : bool := match I.sign_strict xi with | Xlt | Xgt => true | _ => false end. Lemma gt0_correct X x : contains (I.convert X) (Xreal x) -> gt0 X -> (0 < x)%R. Proof. move=> Hx; rewrite /gt0. have := I.sign_strict_correct X; case: I.sign_strict=>//. by case/(_ _ Hx) =>/=. Qed. Lemma apart0_correct X x : contains (I.convert X) (Xreal x) -> apart0 X -> (x <> 0)%R. Proof. move=> Hx; rewrite /apart0. have := I.sign_strict_correct X; case: I.sign_strict=>//; by case/(_ _ Hx) =>/=; auto with real. Qed. (******************************************************************************) (** Correctness predicates dealing with reals only, weaker than [I.extension] *) (******************************************************************************) Lemma R_from_nat_correct : forall p (b : I.type) (n : nat), contains (I.convert (I.fromZ p (Z.of_nat n))) (Xreal (INR n)). Proof. move=> p b n; rewrite INR_IZR_INZ; exact: I.fromZ_correct. Qed. Section PrecArgument. Variable prec : I.precision. Lemma mul_0_contains_0_l y Y X : contains (I.convert Y) y -> contains (I.convert X) (Xreal 0) -> contains (I.convert (I.mul prec X Y)) (Xreal 0). Proof. move=> Hy H0. have H0y ry : (Xreal 0) = (Xreal 0 * Xreal ry)%XR by rewrite /= Rmult_0_l. case: y Hy => [|ry] Hy; [rewrite (H0y 0%R)|rewrite (H0y ry)]; apply: I.mul_correct =>//. by case ->: (I.convert Y) Hy. Qed. Lemma mul_0_contains_0_r y Y X : contains (I.convert Y) y -> contains (I.convert X) (Xreal 0) -> contains (I.convert (I.mul prec Y X)) (Xreal 0). Proof. move=> Hy H0. have Hy0 ry : (Xreal 0) = (Xreal ry * Xreal 0)%XR by rewrite /= Rmult_0_r. case: y Hy => [|ry] Hy; [rewrite (Hy0 0%R)|rewrite (Hy0 ry)]; apply: I.mul_correct=>//. by case: (I.convert Y) Hy. Qed. Lemma pow_contains_0 (X : I.type) (n : Z) : (n > 0)%Z -> contains (I.convert X) (Xreal 0) -> contains (I.convert (I.power_int prec X n)) (Xreal 0). Proof. move=> Hn HX. rewrite (_: (Xreal 0) = (Xpower_int (Xreal 0) n)); first exact: I.power_int_correct. case: n Hn =>//= p Hp; rewrite pow_ne_zero //. by zify; auto with zarith. Qed. Lemma subset_sub_contains_0 x0 (X0 X : I.type) : contains (I.convert X0) x0 -> subset' (I.convert X0) (I.convert X) -> contains (I.convert (I.sub prec X X0)) (Xreal 0). Proof. move=> Hx0 Hsub. destruct x0 as [|x0]. rewrite I.sub_propagate_r //. now destruct (I.convert X0). replace (Xreal 0) with (Xreal x0 - Xreal x0)%XR. apply I.sub_correct with (2 := Hx0). now apply Hsub. apply (f_equal Xreal). now apply Rminus_diag_eq. Qed. End PrecArgument. End IntervalAux. interval-4.11.1/src/Interval/Transcend.v000066400000000000000000002142361470547631300201270ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Psatz. From Flocq Require Import Zaux Raux Digits. Require Import Stdlib. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Require Import Float. Module TranscendentalFloatFast (F : FloatOps with Definition sensible_format := true). Module I := FloatInterval F. Module J := IntervalBasicExt I. Module F' := FloatExt F. CoInductive hidden_constant : Type := | HConst : I.type -> hidden_constant. CoInductive constants : Type := | Consts: hidden_constant -> constants -> constants. Fixpoint constant_getter_aux n cst := match n, cst with | O, Consts (HConst xi) _ => xi | S p, Consts _ c => constant_getter_aux p c end. Definition constant_getter cst prec := let nb := Z.abs_nat (Z.pred (fst (Zdiv.Zdiv_eucl_POS (F.prec prec + 30)%positive 31%Z))) in constant_getter_aux nb cst. CoFixpoint hidden_constant_generator gen n := HConst (gen (F.PtoP (n * 31)%positive)). CoFixpoint constant_generator_aux gen n := Consts (hidden_constant_generator gen n) (constant_generator_aux gen (Pos.succ n)). Definition constant_generator gen := constant_generator_aux gen 1. Definition Z2nat x := match x with | Zpos p => nat_of_P p | _ => O end. Definition Z2P x := match x with | Zpos p => p | _ => xH end. Definition c1 := F.fromZ 1. Definition c2 := F.fromZ 2. Definition c3 := F.fromZ 3. Definition cm1 := F.fromZ (-1). Definition i1 := I.fromZ_small 1. Definition i2 := I.fromZ_small 2. Definition i3 := I.fromZ_small 3. Definition i4 := I.fromZ_small 4. Definition i5 := I.fromZ_small 5. Definition i6 := I.fromZ_small 6. Definition i239 := I.fromZ_small 239. Definition c1_2 := F.div2 c1. Definition c1_8 := iter_pos F.div2 8 c1. Definition c1_p_c1_8 := F.add_DN (F.PtoP 52) c1 c1_8. Lemma c1_n_correct : forall x n, (/ 256 * 2^Pos.to_nat n <= Rabs (F.toR x))%R -> F.toX (iter_pos F.div2 n x) = Xmul (F.toX x) (Xreal ((/2)^Pos.to_nat n)). Proof. intros x n Hx. rewrite iter_pos_nat. revert x Hx. elim (Pos.to_nat n); clear n; [|intros n IHn]; intros x Hx. { now simpl; case F.toX; [|intro r; simpl; rewrite Rmult_1_r]. } simpl. rewrite IHn. { rewrite F.div2_correct; [|easy|]. { rewrite Xdiv_split. case F.toX; [easy|]; intro rx. simpl; unfold Xinv'; rewrite is_zero_false; [|easy]. now simpl; rewrite Rmult_assoc. } revert Hx; apply Rle_trans. unfold Rdiv; rewrite Rmult_1_l. rewrite <-(Rmult_1_r (/ 256)) at 1. apply Rmult_le_compat_l; [|apply pow_R1_Rle]; lra. } unfold F.toR; rewrite F.div2_correct; [|easy|]. { revert Hx; unfold F.toR; case F.toX; [|intro rx]. { simpl; change R0 with 0%R; rewrite Rabs_R0. intro H; exfalso; apply (Rlt_irrefl 0); revert H; apply Rlt_le_trans. do 2 (apply Rmult_lt_0_compat; [lra|]). apply pow_lt; lra. } rewrite Xdiv_split; unfold Xinv'. simpl. intro Hx. rewrite is_zero_false; [|easy]. simpl. rewrite Rabs_mult, (Rabs_pos_eq (/ 2)); lra. } revert Hx; apply Rle_trans. unfold Rdiv; rewrite Rmult_1_l. rewrite <-(Rmult_1_r (/ 256)) at 1. apply Rmult_le_compat_l; [|apply pow_R1_Rle]; lra. Qed. Lemma c1_2_correct : F.toX c1_2 = Xreal (/ 2). Proof. change c1_2 with (iter_pos F.div2 1 c1); rewrite c1_n_correct. { unfold c1; rewrite F.fromZ_correct by easy; simpl; apply f_equal; lra. } unfold F.toR, c1; rewrite F.fromZ_correct by easy; simpl; rewrite Rabs_R1; lra. Qed. Lemma c1_8_correct : F.toX c1_8 = Xreal (/ 256). Proof. change c1_8 with (iter_pos F.div2 8 c1); rewrite c1_n_correct. { unfold c1; rewrite F.fromZ_correct by easy; simpl; apply f_equal; lra. } unfold F.toR, c1; rewrite F.fromZ_correct by easy; simpl; rewrite Rabs_R1; lra. Qed. Ltac bound_tac := unfold Xround, Xbind ; match goal with | |- (round ?r_DN ?p ?v <= ?v)%R => apply (proj1 (proj2 (Generic_fmt.round_DN_pt F.radix (FLX.FLX_exp (Zpos p)) v))) | |- (?v <= round ?r rnd_UP ?p ?v)%R => apply (proj1 (proj2 (Generic_fmt.round_UP_pt F.radix (FLX.FLX_exp (Zpos p)) v))) | |- (round ?r_DN ?p ?v <= ?w)%R => apply Rle_trans with (1 := proj1 (proj2 (Generic_fmt.round_DN_pt F.radix (FLX.FLX_exp (Zpos p)) v))) | |- (?w <= round ?r rnd_UP ?p ?v)%R => apply Rle_trans with (2 := proj1 (proj2 (Generic_fmt.round_UP_pt F.radix (FLX.FLX_exp (Zpos p)) v))) end. Notation toR := F.toR (only parsing). (* 0 <= inputs *) Fixpoint atan_fast0_aux prec thre powi sqri divi (nb : nat) { struct nb } := let npwi := I.mul prec powi sqri in let vali := I.div prec npwi divi in match F.cmp (I.upper vali) thre, nb with | Xlt, _ | _, O => I.bnd F.zero (I.upper vali) | _, S n => I.sub prec vali (atan_fast0_aux prec thre npwi sqri (I.add prec divi i2) n) end. (* -1/2 <= input <= 1/2 *) Definition atan_fast0 prec xi := let x2i := I.sqr prec xi in let p := F.prec prec in let thre := F.scale c1 (F.ZtoS (Zneg p)) in let rem := atan_fast0_aux prec thre i1 x2i i3 (nat_of_P p) in I.mul prec (I.sub prec i1 rem) xi. Definition pi4_gen prec := I.sub prec (I.mul2 prec (I.mul2 prec (atan_fast0 prec (I.inv prec i5)))) (atan_fast0 prec (I.inv prec i239)). Definition pi4_seq := constant_generator pi4_gen. Definition pi4 := constant_getter pi4_seq. Definition atan_fastP prec x := let xi := I.bnd x x in if F'.lt c1_2 x then let prec := F.incr_prec prec 2 in let pi4i := pi4 prec in if F'.lt c2 x then I.sub prec (I.mul2 prec pi4i) (atan_fast0 prec (I.inv prec xi)) else let xm1i := I.sub prec xi i1 in let xp1i := I.add prec xi i1 in I.add prec pi4i (atan_fast0 prec (I.div prec xm1i xp1i)) else atan_fast0 (F.incr_prec prec 1) xi. Definition atan_fast prec x := match F'.cmp x F.zero with | Xeq => I.zero | Xlt => I.neg (atan_fastP prec (F.neg x)) | Xgt => atan_fastP prec x | Xund => I.nai end. Lemma atan_fast0_correct : forall prec xi x, (Rabs x <= /2)%R -> contains (I.convert xi) (Xreal x) -> contains (I.convert (atan_fast0 prec xi)) (Xreal (atan x)). Proof. intros prec xi x Bx Ix. unfold atan_fast0. rewrite atan_atanc, Rmult_comm. apply J.mul_correct with (2 := Ix). replace (atanc x) with (1 - (1 - atanc x))%R by ring. apply J.sub_correct. now apply I.fromZ_small_correct. pose (Ai := fun x => sum_f_R0 (fun n : nat => ((-1) ^ n / INR (2 * n + 1) * x ^ (2 * n))%R)). assert (Hexit : forall k powi divi, contains (I.convert powi) (Xreal (x ^ (2 * k))) -> contains (I.convert divi) (Xreal (INR (2 * (k + 1) + 1))) -> contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi (I.sqr prec xi)) divi)))) (Xreal ((-1) ^ (k + 1) * (atanc x - Ai x k)))). { intros k powi divi Hpow Hdiv. assert (A: (0 <= (-1) ^ (k + 1) * (atanc x - Ai x k) <= x ^ (2 * (k + 1)) / INR (2 * (k + 1) + 1))%R). { replace (Ai x k) with (sum_f_R0 (tg_alt (fun n => / INR (2 * n + 1) * x ^ (2 * n))%R) k). { unfold Rdiv. rewrite (Rmult_comm (x ^ _)). replace (k + 1) with (S k) by ring. apply alternated_series_ineq'. { apply Un_decreasing_atanc. lra. } { apply Un_cv_atanc. lra. } unfold atanc. case Ratan.in_int ; intros Hx. { case atanc_exists ; simpl projT1 ; intros l C. exact C. } elim Hx. apply Rabs_le_inv. lra. } apply sum_eq. intros n _. unfold tg_alt. apply sym_eq, Rmult_assoc. } assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi (I.sqr prec xi)) divi))). { exists ((x ^ (2 * k) * (x * x)) / INR (2 * (k + 1) + 1))%R. now apply J.div_correct; [apply J.mul_correct; [|apply J.sqr_correct]|]. } rewrite I.bnd_correct. 2: { now apply I.valid_lb_real; rewrite F.zero_correct. } 2: { now apply I.valid_ub_upper. } rewrite F.zero_correct, (I.upper_correct _ Hne). apply (conj (proj1 A)). assert (Hx2 := J.sqr_correct prec _ _ Ix). assert (H1 := J.mul_correct prec _ _ _ _ Hpow Hx2). assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv). destruct (I.convert (I.div _ _ _)) as [|l [|u]] ; try easy. simpl. apply Rle_trans with (1 := proj2 A). apply Rle_trans with (2 := proj2 H2). apply Req_le. apply Rmult_eq_compat_r. replace (2 * (k + 1)) with (2 * k + 2) by ring. now rewrite pow_add, <- Rsqr_pow2. } generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)). intros thre n. replace 1%R with (Ai x 0) by (unfold Ai ; simpl ; field). refine (_ (I.fromZ_small_correct 1 _) (I.fromZ_small_correct 3 _)) ; [|easy..]. fold i1 i3. generalize i1 i3. intros powi divi. change 1%R with (pow x (2 * 0)). change 3%Z with (Z.of_nat (2 * (0 + 1) + 1)). rewrite <- INR_IZR_INZ. replace (Ai x 0%nat - atanc x)%R with ((-1) * 1 * (atanc x - Ai x 0%nat))%R by ring. change (-1 * 1)%R with (pow (-1) (0 + 1)). rewrite <- (Nat.sub_diag n) at 2 4 7 9. generalize (Nat.le_refl n). generalize n at 1 4 6 7 9 11. intros m. revert powi divi. induction m as [|m IHm] ; intros powi divi Hm Hpow Hdiv. simpl atan_fast0_aux. specialize (Hexit (n - 0) _ _ Hpow Hdiv). now case F.cmp. simpl atan_fast0_aux. set (powi' := I.mul prec powi (I.sqr prec xi)). set (divi' := I.add prec divi i2). specialize (IHm powi' divi'). specialize (Hexit (n - S m) _ _ Hpow Hdiv). assert (H: forall p, n - S m + S p = n - m + p). intros p. clear -Hm ; lia. cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (atan_fast0_aux prec thre powi' (I.sqr prec xi) divi' m))) (Xreal ((-1) ^ (n - S m + 1) * (atanc x - Ai x (n - S m))))). now case F.cmp. replace ((-1) ^ (n - S m + 1) * (atanc x - Ai x (n - S m)%nat))%R with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * x ^ (2 * S (n - S m)) * / INR (2 * S (n - S m) + 1) - (((-1) * (-1) ^ (n - S m + 1)) * (atanc x - (Ai x (n - S m)%nat + ((-1) ^ S (n - S m) * / INR (2 * S (n - S m) + 1) * x ^ (2 * S (n - S m)))))))%R by ring. assert (Hpow': contains (I.convert powi') (Xreal (x ^ (2 * (n - S m + 1))))). replace (2 * (n - S m + 1)) with (2 * (n - S m) + 2) by ring. rewrite pow_add, <- Rsqr_pow2. apply J.mul_correct with (1 := Hpow). now apply J.sqr_correct. apply J.sub_correct. rewrite <- pow_add. replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; lia). rewrite pow_1_even, Rmult_1_l. replace (S (n - S m)) with (n - S m + 1) by now rewrite Nat.add_comm. apply J.div_correct. exact Hpow'. exact Hdiv. evar_last. apply IHm. now apply Nat.lt_le_incl. rewrite <- (Nat.add_0_r (n - m)), <- H. exact Hpow'. rewrite H, Nat.add_0_r in Hdiv. replace (2 * (n - m + 1) + 1) with (2 * (n - m) + 1 + 2) by ring. rewrite plus_INR. apply J.add_correct with (1 := Hdiv). now apply I.fromZ_small_correct. change (Ai x (n - S m)%nat + (-1) ^ S (n - S m) * / INR (2 * S (n - S m) + 1) * x ^ (2 * S (n - S m)))%R with (Ai x (S (n - S m))). change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R. rewrite <- plus_Sn_m. now rewrite <-Nat.sub_succ_l. Qed. Lemma pi4_correct : forall prec, contains (I.convert (pi4 prec)) (Xreal (PI/4)). Proof. intros prec. rewrite Machin_4_5_239. unfold pi4, constant_getter. set (n := Z.abs_nat _). unfold pi4_seq, constant_generator. generalize xH at 1. induction n as [|n]. 2: intros p ; apply IHn. simpl. intros p. generalize (F.PtoP (p * 31)). clear prec p. intros prec. assert (H: forall p, (2 <= p <= 256)%Z -> contains (I.convert (atan_fast0 prec (I.inv prec (I.fromZ_small p)))) (Xreal (atan (/ IZR p)))). intros p Hp. apply atan_fast0_correct. rewrite Rabs_pos_eq. apply Rle_Rinv_pos. apply Rlt_0_2. now apply IZR_le. apply Rlt_le, Rinv_0_lt_compat. apply IZR_lt. now apply Z.lt_le_trans with 2%Z. replace (Xreal (/ IZR p)) with (Xinv (Xreal (IZR p))). apply I.inv_correct. apply I.fromZ_small_correct. rewrite Z.abs_eq. apply Hp. now apply Z.le_trans with 2%Z. unfold Xinv'. simpl. case is_zero_spec ; try easy. intros H. apply (eq_IZR p 0) in H. elim Hp. now rewrite H. unfold pi4_gen. apply (I.sub_correct _ _ _ (Xreal _) (Xreal _)). rewrite Rmult_comm. replace (Xreal (atan (/ 5) * 4)) with (Xreal (atan (/ 5)) * Xreal 2 * Xreal 2)%XR; [|simpl; apply f_equal; ring]. do 2 apply I.mul2_correct. now apply (H 5%Z). now apply (H 239%Z). Qed. Lemma atan_fastP_correct : forall prec x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R -> contains (I.convert (atan_fastP prec x)) (Xreal (atan (toR x))). Proof. intros prec x Rx Bx. unfold atan_fastP, c1_2, c1, c2. rewrite F'.lt_correct with (2 := Rx). 2: { unfold F.toR. now fold c1; fold c1_2; rewrite c1_2_correct. } unfold F.toR at 1. fold c1; fold c1_2; rewrite c1_2_correct. simpl Rlt_bool. assert (Ix: contains (I.convert (I.bnd x x)) (Xreal (toR x))). { rewrite I.bnd_correct; [|apply I.valid_lb_real|apply I.valid_ub_real]; rewrite Rx; [|easy..]. split ; apply Rle_refl. } case Rlt_bool_spec ; intros Bx'. 2: { apply atan_fast0_correct with (2 := Ix). now rewrite Rabs_pos_eq. } rewrite F'.lt_correct with (2 := Rx); [|now unfold F.toR; rewrite F.fromZ_correct; [..|lia]]. unfold F.toR at 1. rewrite F.fromZ_correct by easy. simpl Rlt_bool. case Rlt_bool_spec ; intros Bx'' ; cycle 1. replace (Xreal (atan (toR x))) with (Xadd (Xreal (PI / 4)) (Xatan (Xreal ((toR x - 1) / (toR x + 1))))). apply I.add_correct. apply pi4_correct. apply atan_fast0_correct. apply Rabs_le. assert (Bx1: (0 < toR x + 1)%R) by (clear -Bx ; lra). split. apply Rmult_le_reg_r with (1 := Bx1). unfold Rdiv. rewrite Rmult_assoc, Rinv_l, Rmult_1_r. apply Rminus_le. replace (- / 2 * (toR x + 1) - (toR x - 1))%R with (-3/2 * toR x + /2)%R by field. clear -Bx' ; lra. now apply Rgt_not_eq. apply Rmult_le_reg_r with (1 := Bx1). unfold Rdiv. rewrite Rmult_assoc, Rinv_l, Rmult_1_r. apply Rminus_le. replace (toR x - 1 - / 2 * (toR x + 1))%R with (/2 * toR x - 3/2)%R by field. lra. now apply Rgt_not_eq. apply J.div_correct. apply J.sub_correct with (1 := Ix). now apply I.fromZ_small_correct. apply J.add_correct with (1 := Ix). now apply I.fromZ_small_correct. simpl. apply (f_equal Xreal). rewrite Rplus_comm. apply atan_plus_PI4. lra. replace (Xreal (atan (toR x))) with (Xsub (Xmul (Xreal (PI/4)) (Xreal 2)) (Xatan (Xreal (/ toR x)))). apply I.sub_correct. apply I.mul2_correct. apply pi4_correct. apply atan_fast0_correct. rewrite Rabs_pos_eq. apply Rle_Rinv_pos. apply Rlt_0_2. now apply Rlt_le. apply Rlt_le, Rinv_0_lt_compat. lra. now apply J.inv_correct. simpl. apply f_equal. rewrite atan_inv; lra. Qed. Lemma atan_fast_correct : forall prec x, contains (I.convert (atan_fast prec x)) (Xatan (F.toX x)). Proof. intros prec x. unfold atan_fast. rewrite F'.cmp_correct, F.zero_correct. case_eq (F.toX x) ; simpl. easy. intros r Hr. case Rcompare_spec ; intros H. (* neg *) rewrite <- (Ropp_involutive r). replace (Ropp r) with (toR (F.neg x)). rewrite atan_opp. apply (I.neg_correct _ (Xreal _)). apply atan_fastP_correct. unfold toR. now rewrite F'.neg_correct, Hr. unfold toR. rewrite F'.neg_correct, Hr. simpl. rewrite <- Ropp_0. now apply Ropp_le_contravar, Rlt_le. unfold toR. now rewrite F'.neg_correct, Hr. (* zero *) rewrite H, atan_0. simpl. rewrite F.zero_correct, F'.valid_lb_zero, F'.valid_ub_zero. split ; apply Rle_refl. (* pos *) replace r with (toR x). apply atan_fastP_correct. unfold toR. now rewrite Hr. unfold toR. rewrite Hr. now apply Rlt_le. unfold toR. now rewrite Hr. Qed. (* 0 <= inputs *) Fixpoint ln1p_fast0_aux prec thre powi xi divi (nb : nat) { struct nb } := let npwi := I.mul prec powi xi in let vali := I.div prec npwi divi in match F'.cmp (I.upper vali) thre, nb with | Xlt, _ | _, O => I.bnd F.zero (I.upper vali) | _, S n => I.sub prec vali (ln1p_fast0_aux prec thre npwi xi (I.add prec divi i1) n) end. (* 0 <= input <= 1/2 *) Definition ln1p_fast0 prec xi := let p := F.prec prec in let thre := F.scale c1 (F.ZtoS (Zneg p)) in let rem := ln1p_fast0_aux prec thre i1 xi i2 (nat_of_P p) in I.mul prec (I.sub prec i1 rem) xi. (* 1 <= input *) Definition ln_fast1P prec xi := let th := c1_p_c1_8 in match F'.le' (I.upper xi) th with | true => ln1p_fast0 prec (I.sub prec xi i1) | false => let m := Digits.Zdigits2 (F.StoZ (F.mag (I.upper xi))) in let prec := F.incr_prec prec 10 in let fix reduce xi (nb : nat) {struct nb} := match F'.le' (I.upper xi) th, nb with | true, _ => ln1p_fast0 prec (I.sub prec xi i1) | _, O => I.bnd F.zero F.nan | _, S n => I.mul2 prec (reduce (I.sqrt prec xi) n) end in reduce xi (8 + Z2nat m) end. Definition ln_fast prec x := match F.cmp x F.zero with | Xgt => let xi := I.bnd x x in match F.cmp x c1 with | Xeq => I.zero | Xlt => let m := Z.opp (F.StoZ (F.mag (F.sub_UP prec c1 x))) in let prec := F.incr_prec prec (Z2P m) in I.neg (ln_fast1P prec (I.inv prec xi)) | Xgt => if F.real x then ln_fast1P prec xi else I.nai | Xund => I.nai end | _ => I.nai end. Lemma ln1p_fast0_correct : forall prec xi x, (0 <= x <= /2)%R -> contains (I.convert xi) (Xreal x) -> contains (I.convert (ln1p_fast0 prec xi)) (Xreal (ln (1 + x))). Proof. intros prec xi x Bx Ix. unfold ln1p_fast0. rewrite ln1p_ln1pc. replace (ln1pc x) with (1 - (1 - ln1pc x))%R by ring. rewrite Rmult_comm. apply J.mul_correct with (2 := Ix). apply J.sub_correct. now apply I.fromZ_small_correct. pose (Ai := fun x => sum_f_R0 (fun n : nat => ((-1) ^ n / INR (n + 1) * x ^ n)%R)). assert (Hexit : forall k powi divi, contains (I.convert powi) (Xreal (x ^ k)) -> contains (I.convert divi) (Xreal (INR ((k + 1) + 1))) -> contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi)))) (Xreal ((-1) ^ (k + 1) * (ln1pc x - Ai x k)))). intros k powi divi Hpow Hdiv. rewrite I.bnd_correct. 2: { now apply I.valid_lb_real; rewrite F.zero_correct. } 2: { apply I.valid_ub_upper. exists (x ^ k * x / INR (k + 1 + 1))%R. now apply J.div_correct; [apply J.mul_correct|]. } rewrite F.zero_correct, I.upper_correct. 2: { exists (x ^ k * x / INR (k + 1 + 1))%R. now apply J.div_correct; [apply J.mul_correct|]. } assert (A: (0 <= (-1) ^ (k + 1) * (ln1pc x - Ai x k) <= x ^ (k + 1) / INR ((k + 1) + 1))%R). replace (Ai x k) with (sum_f_R0 (tg_alt (fun n => / INR (n + 1) * x ^ n)%R) k). unfold Rdiv. rewrite (Rmult_comm (x ^ _)). replace (k + 1) with (S k) by ring. apply alternated_series_ineq'. apply Un_decreasing_ln1pc. lra. apply Un_cv_ln1pc. rewrite Rabs_pos_eq ; lra. unfold ln1pc. case ln1pc_in_int ; intros Hx. case ln1pc_exists ; simpl projT1 ; intros l C. exact C. elim Hx. lra. apply sum_eq. intros n _. unfold tg_alt. apply sym_eq, Rmult_assoc. apply (conj (proj1 A)). assert (H1 := J.mul_correct prec _ _ _ _ Hpow Ix). assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv). destruct (I.convert (I.div _ _ _)) as [|l [|u]] ; try easy. apply Rle_trans with (1 := proj2 A). apply Rle_trans with (2 := proj2 H2). apply Req_le, Rmult_eq_compat_r. rewrite pow_add. simpl. now rewrite Rmult_1_r. generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)). intros thre n. replace 1%R with (Ai x 0) by (unfold Ai ; simpl ; field). refine (_ (I.fromZ_small_correct 1 _) (I.fromZ_small_correct 2 _)) ; [|easy..]. fold i1 i2. generalize i1 i2. intros powi divi. change 1%R with (pow x 0). change 2%Z with (Z_of_nat ((0 + 1) + 1)). rewrite <- INR_IZR_INZ. replace (Ai x 0%nat - ln1pc x)%R with ((-1) * 1 * (ln1pc x - Ai x 0%nat))%R by ring. change (-1 * 1)%R with (pow (-1) (0 + 1)). rewrite <- (Nat.sub_diag n) at 1 2 5 7. generalize (Nat.le_refl n). generalize n at 1 4 6 7 9 11. intros m. revert powi divi. induction m as [|m IHm] ; intros powi divi Hm Hpow Hdiv. simpl. cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi)))) (Xreal ((-1) ^ (n - 0 + 1) * (ln1pc x - Ai x (n - 0))))). now destruct F'.cmp. now apply Hexit. simpl ln1p_fast0_aux. set (powi' := I.mul prec powi xi). set (divi' := I.add prec divi i1). specialize (IHm powi' divi'). assert (H: forall p, n - S m + S p = n - m + p). intros p. clear -Hm ; lia. cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (ln1p_fast0_aux prec thre powi' xi divi' m))) (Xreal ((-1) ^ (n - S m + 1) * (ln1pc x - Ai x (n - S m))))). case F'.cmp ; try easy. intros H'. now apply Hexit. replace ((-1) ^ (n - S m + 1) * (ln1pc x - Ai x (n - S m)%nat))%R with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * x ^ (S (n - S m)) * / INR (S (n - S m) + 1) - (((-1) * (-1) ^ (n - S m + 1)) * (ln1pc x - (Ai x (n - S m)%nat + ((-1) ^ S (n - S m) * / INR (S (n - S m) + 1) * x ^ (S (n - S m)))))))%R by ring. apply J.sub_correct. rewrite <- pow_add. replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; lia). replace (S (n - S m)) with (n - S m + 1) by now rewrite Nat.add_comm. apply J.div_correct with (2 := Hdiv). rewrite pow_1_even, Rmult_1_l. rewrite pow_add, pow_1. now apply J.mul_correct. evar_last. apply IHm. clear -Hm ; lia. rewrite <- (Nat.add_0_r (n - m)), <- H. rewrite pow_add, pow_1. now apply J.mul_correct. rewrite <- H. replace (_ + 2 + 1) with (n - S m + 1 + 1 + 1) by ring. rewrite plus_INR. apply J.add_correct with (1 := Hdiv). now apply I.fromZ_small_correct. change (Ai x (n - S m)%nat + (-1) ^ S (n - S m) * / INR (S (n - S m) + 1) * x ^ (S (n - S m)))%R with (Ai x (S (n - S m))). change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R. rewrite <- plus_Sn_m. now rewrite <-Nat.sub_succ_l. Qed. Lemma ln_fast1P_correct : forall prec xi x, (1 <= x)%R -> contains (I.convert xi) (Xreal x) -> contains (I.convert (ln_fast1P prec xi)) (Xreal (ln x)). Proof. set (thre := c1_p_c1_8). assert (H: forall prec xi x, (1 <= x)%R -> (F'.le' (I.upper xi) thre = true) -> contains (I.convert xi) (Xreal x) -> contains (I.convert (ln1p_fast0 prec (I.sub prec xi i1))) (Xreal (ln x))). intros prec xi x Hx Hxu Ix. replace x with (1 + (x - 1))%R by ring. apply ln1p_fast0_correct. split. lra. apply F'.le'_correct in Hxu. rewrite I.upper_correct in Hxu; [|now exists x]. destruct (I.convert xi) as [|l [|u]] ; try easy. revert Hxu. simpl. unfold thre, c1_p_c1_8, c1. elim (F.add_DN_correct (F.PtoP 52) (F.fromZ 1) c1_8). 2: apply F'.valid_lb_real ; now rewrite F.real_correct, F.fromZ_correct. 2: apply F'.valid_lb_real ; now rewrite F.real_correct, c1_8_correct. intros Va. case (F.toX _) ; [easy|intro r]. rewrite c1_8_correct, F.fromZ_correct by easy. simpl. intro Hr. apply Ropp_le_cancel in Hr. intro H. assert (H' : (u <= 1 + / 256)%R). { now apply (Rle_trans _ _ _ H). } generalize (proj2 Ix). lra. apply J.sub_correct with (1 := Ix). now apply I.fromZ_small_correct. intros prec xi x Hx Ix. unfold ln_fast1P. fold thre. case_eq (F'.le' (I.upper xi) thre) ; intros Hxu. now apply H. clear Hxu. set (m := Zdigits2 (F.StoZ (F.mag (I.upper xi)))). clearbody m. generalize (F.incr_prec prec 10). clear prec; intro prec. generalize (8 + Z2nat m). intro nb. revert xi x Hx Ix. induction nb as [|nb] ; intros xi x Hx Ix. (* nb = 0 *) simpl. case_eq (F'.le' (I.upper xi) thre) ; intros Hxu. now apply H. simpl. rewrite F.zero_correct, F'.nan_correct. rewrite F'.valid_lb_zero, F'.valid_ub_nan. refine (conj _ I). destruct (Rlt_dec 1 x) as [Hx'|Hx']. rewrite <- ln_1. apply Rlt_le, ln_increasing. exact Rlt_0_1. exact Hx'. replace x with 1%R by lra. rewrite ln_1. apply Rle_refl. (* nb > 0 *) case_eq (F'.le' (I.upper xi) thre) ; intros Hxu. now apply H. clear H Hxu. replace (ln x) with (ln (sqrt x) * 2)%R. change (Xreal (ln (sqrt x) * 2)) with (Xmul (Xreal (ln (sqrt x))) (Xreal (bpow radix2 1))). apply I.mul2_correct. apply IHnb. clear IHnb. rewrite <- sqrt_1. now apply sqrt_le_1_alt. now apply J.sqrt_correct. rewrite <- (sqrt_sqrt x) at 2 by lra. assert (0 < sqrt x)%R. apply sqrt_lt_R0. lra. rewrite ln_mult by easy. ring. Qed. Theorem ln_fast_correct : forall prec x, contains (I.convert (ln_fast prec x)) (Xln (F.toX x)). Proof. intros prec x. unfold ln_fast. rewrite F.cmp_correct, F.zero_correct, F'.classify_zero. generalize (F.classify_correct x); rewrite F.real_correct. case_eq (F.classify x); intro Cx; [|easy..|]; [case_eq (F.toX x); [easy|]; intros rx Hrx _ |case_eq (F.toX x); [|easy]; intros Hx _]. { (* x real *) unfold Xcmp, c1. case Rcompare_spec; intro Hrx0; [easy..|]. rewrite F.cmp_correct, Cx, Hrx. generalize (F.classify_correct (F.fromZ 1)). rewrite F.real_correct, F.fromZ_correct by easy. case F.classify; [|easy..]; intros _. unfold Xcmp. case Rcompare_spec. { (* x < 1 *) intros Hx'. generalize (F.incr_prec prec (Z2P (Z.opp (F.StoZ (F.mag (F.sub_UP prec (F.fromZ 1) x)))))). intros prec'. rewrite <- (Rinv_involutive rx); [|lra]. unfold Xln, Xln'. rewrite ln_Rinv; [|now apply Rinv_0_lt_compat]. rewrite is_positive_true; [|now do 2 apply Rinv_0_lt_compat]. apply J.neg_correct. apply ln_fast1P_correct. { rewrite <- Rinv_1. apply Rinv_le. { exact Hrx0. } now apply Rlt_le. } apply J.inv_correct. rewrite I.bnd_correct, Hrx. { split ; apply Rle_refl. } { now apply I.valid_lb_real; rewrite Hrx. } now apply I.valid_ub_real; rewrite Hrx. } { (* x = 1 *) intros ->. unfold Xln, Xln'. rewrite is_positive_true; [|lra]. rewrite I.zero_correct, ln_1. split ; apply Rle_refl. } (* x > 1 *) intros Hx'. unfold Xln, Xln'. rewrite is_positive_true; [|lra]. apply ln_fast1P_correct. { now apply Rlt_le. } rewrite I.bnd_correct, Hrx. { split ; apply Rle_refl. } { now apply I.valid_lb_real; rewrite Hrx. } now apply I.valid_ub_real; rewrite Hrx. } (* x = +oo *) rewrite F.cmp_correct, Cx. unfold c1. generalize (F.classify_correct (F.fromZ 1)). rewrite F.real_correct, F.fromZ_correct by easy. now case F.classify. Qed. (* (* 0 <= inputs *) Fixpoint umc_fast0_aux prec thre powl powu sqrl sqru fact div (nb : nat) { struct nb } := let npwu := F.mul_UP prec powu sqru in let valu := F.div_UP prec npwu div in match F.cmp valu thre, nb with | Xlt, _ | _, O => I.bnd F.zero valu | _, S n => let npwl := F.mul_DN prec powl sqrl in let vall := F.div_DN prec npwl div in let one := F.fromZ 1 in let nfact := F.add_exact fact (F.add_exact one one) in let ndiv := F.mul_exact div (F.mul_exact fact (F.add_exact fact one)) in I.sub prec (I.bnd vall valu) (umc_fast0_aux prec thre npwl npwu sqrl sqru nfact ndiv n) end. Definition umc_fast0 prec x := let x2l := F.mul_DN prec x x in let x2u := F.mul_UP prec x x in let c1 := F.fromZ 1 in let p := F.prec prec in let thre := F.scale c1 (F.ZtoS (Zneg p)) in I.scale2 (I.mul prec (I.bnd x2l x2u) (I.sub prec (I.bnd c1 c1) (umc_fast0_aux prec thre c1 c1 x2l x2u (F.fromZ 5) (F.fromZ 12) (nat_of_P p)))) (F.ZtoS (-1)%Z). Definition umc_reduce prec x := let c1 := F.fromZ 1 in let th := F.scale2 c1 (F.ZtoS (-4)%Z) in (*let prec := F.incr_prec prec 1 in*) let c2 := F.fromZ 2 in let i2 := I.bnd c2 c2 in let s1 := F.ZtoS 1 in let sm1 := F.ZtoS (-1)%Z in let fix reduce x (nb : nat) {struct nb} := match le x th, nb with | true, _ => umc_fast0 prec x | _, O => umc_fast0 prec x | _, S n => (*match reduce (F.scale2 x sm1) n with | Ibnd yl yu => I.scale2 (Ibnd (F.mul_DN prec yl (F.sub_DN prec c2 yl)) (F.mul_UP prec yu (F.sub_UP prec c2 yu))) s1 | Inan => Inan end*) let u := reduce (F.scale2 x sm1) n in I.scale2 (I.mul prec u (I.sub prec i2 u)) s1 end in reduce x 10. Definition cos_fast0 prec x := let c1 := F.fromZ 1 in I.sub prec (I.bnd c1 c1) (umc_reduce prec x). *) (* 0 <= inputs *) Fixpoint cos_fast0_aux prec thre powi sqri facti divi (nb : nat) { struct nb } := let npwi := I.mul prec powi sqri in let vali := I.div prec npwi divi in match F'.cmp (I.upper vali) thre, nb with | Xlt, _ | _, O => I.bnd F.zero (I.upper vali) | _, S n => let nfacti := I.add prec facti i2 in let ndivi := I.mul prec divi (I.mul prec facti (I.add prec facti i1)) in I.sub prec vali (cos_fast0_aux prec thre npwi sqri nfacti ndivi n) end. (* -1/2 <= input <= 1/2 *) Definition cos_fast0 prec x := let xi := I.bnd x x in let x2i := I.sqr prec xi in let p := F.prec prec in let thre := F.scale c1 (F.ZtoS (Zneg p)) in let rem := cos_fast0_aux prec thre i1 x2i i3 i2 (nat_of_P p) in I.sub prec i1 rem. (* 0 <= input *) Definition sin_cos_reduce prec x := let th := c1_2 in let fix reduce x (nb : nat) {struct nb} := match F'.le x th, nb with | true, _ => (Gt, cos_fast0 prec x) | _, O => (Eq, I.bnd cm1 c1) | _, S n => match reduce (F.div2 x) n with | (s, c) => (match s, I.sign_large c with | Lt, Xgt => Lt | Lt, Xlt => Gt | Lt, _ => Eq | Gt, Xlt => Lt | Gt, Xgt => Gt | Gt, _ => Eq | _, _ => s end, I.sub prec (I.mul2 prec (I.sqr prec c)) i1) end end in reduce x. Lemma cos_fast0_correct : forall prec x, F.toX x = Xreal (toR x) -> (Rabs (toR x) <= /2)%R -> contains (I.convert (cos_fast0 prec x)) (Xreal (cos (toR x))). Proof. intros prec x Rx Bx. unfold cos_fast0. replace (cos (toR x)) with (1 - (1 - cos (toR x)))%R by ring. apply J.sub_correct. now apply I.fromZ_small_correct. set (xi := I.bnd x x). assert (Ix: contains (I.convert xi) (Xreal (toR x))). unfold xi. rewrite I.bnd_correct, Rx. 2: now apply I.valid_lb_real; rewrite Rx. 2: now apply I.valid_ub_real; rewrite Rx. split ; apply Rle_refl. set (x2i := I.sqr prec xi). assert (Hexit: forall k powi divi, contains (I.convert powi) (Xreal (toR x ^ (2 * k))) -> contains (I.convert divi) (Xreal (INR (fact (2 * (k + 1))))) -> contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi)))) (Xreal ((-1) ^ (k + 1) * (cos (toR x) - A1 (toR x) k)))). intros k powi facti Hpow Hdiv. assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi x2i) facti))). { exists ((F.toR x ^ (2 * k) * (F.toR x * F.toR x)) / INR (fact (2 * (k + 1))))%R. now apply J.div_correct; [apply J.mul_correct; [|apply J.sqr_correct]|]. } rewrite I.bnd_correct. 2: now apply I.valid_lb_real; rewrite F.zero_correct. 2: now apply I.valid_ub_upper. rewrite F.zero_correct, I.upper_correct; [|easy]. assert (A: (0 <= (-1) ^ (k + 1) * (cos (toR x) - A1 (toR x) k) <= toR x ^ (2 * (k + 1)) / INR (fact (2 * (k + 1))))%R). replace (A1 (toR x) k) with (sum_f_R0 (tg_alt (fun n => / INR (fact (2 * n)) * toR x ^ (2 * n))%R) k). unfold Rdiv. rewrite (Rmult_comm (toR x ^ _)). replace (k + 1) with (S k) by ring. apply alternated_series_ineq'. apply Un_decreasing_cos. lra. apply (Un_cv_subseq (fun n => (/ INR (fact n) * toR x ^ n)%R)). clear ; intros n ; lia. eapply Un_cv_ext. intros n. apply Rmult_comm. apply cv_speed_pow_fact. generalize (A1_cvg (toR x)). apply Un_cv_ext. intros n. unfold A1, tg_alt. apply sum_eq. intros i _. apply Rmult_assoc. unfold A1, tg_alt. apply sum_eq. intros i _. apply sym_eq, Rmult_assoc. apply (conj (proj1 A)). assert (Hx2 := J.sqr_correct prec _ _ Ix). assert (H1 := J.mul_correct prec _ _ _ _ Hpow Hx2). assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv). destruct (I.convert (I.div _ _ _)) as [|l [|u]] ; try easy. apply Rle_trans with (1 := proj2 A). apply Rle_trans with (2 := proj2 H2). apply Req_le, Rmult_eq_compat_r. replace (2 * (k + 1)) with (2 * k + 2) by ring. rewrite pow_add. now rewrite Rsqr_pow2. generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)). intros thre n. replace 1%R with (A1 (toR x) 0) by (unfold A1 ; simpl ; field). refine (_ (I.fromZ_small_correct 1 _) (I.fromZ_small_correct 2 _) (I.fromZ_small_correct 3 _)) ; [|easy..]. fold i1 i2 i3. generalize i1 i2 i3. intros powi divi facti. change 1%R with (pow (toR x) (2 * 0)). change 3%Z with (Z_of_nat (2 * (0 + 1) + 1)). change 2%Z with (Z_of_nat (fact (2 * (0 + 1)))). rewrite <- 2!INR_IZR_INZ. replace (A1 (toR x) 0 - cos (toR x))%R with ((-1) * 1 * (cos (toR x) - A1 (toR x) 0))%R by ring. change (-1 * 1)%R with (pow (-1) (0 + 1)). rewrite <- (Nat.sub_diag n) at 2 4 7 10 12. generalize (Nat.le_refl n). generalize n at 1 4 6 8 9 11 13. intros m. revert powi divi facti. induction m as [|m IHm] ; intros powi divi facti Hm Hpow Hdiv Hfact. simpl cos_fast0_aux. cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi)))) (Xreal ((-1) ^ (n - 0 + 1) * (cos (toR x) - A1 (toR x) (n - 0))))). now destruct F'.cmp. now apply Hexit. simpl cos_fast0_aux. set (powi' := I.mul prec powi x2i). set (divi' := I.mul prec divi (I.mul prec facti (I.add prec facti i1))). set (facti' := I.add prec facti i2). specialize (IHm powi' divi' facti'). assert (H: forall p, n - S m + S p = n - m + p). intros p. clear -Hm ; lia. cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (cos_fast0_aux prec thre powi' x2i facti' divi' m))) (Xreal ((-1) ^ (n - S m + 1) * (cos (toR x) - A1 (toR x) (n - S m))))). case F'.cmp ; try easy. intros H'. now apply Hexit. replace ((-1) ^ (n - S m + 1) * (cos (toR x) - A1 (toR x) (n - S m)))%R with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * (toR x) ^ (2 * S (n - S m)) * / INR (fact (2 * S (n - S m))) - (((-1) * (-1) ^ (n - S m + 1)) * (cos (toR x) - (A1 (toR x) (n - S m) + ((-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m))) * (toR x) ^ (2 * S (n - S m)))))))%R by ring. assert (Hpow': contains (I.convert powi') (Xreal (toR x ^ (2 * (n - S m + 1))))). replace (2 * (n - S m + 1)) with (2 * (n - S m) + 2) by ring. rewrite pow_add, <- Rsqr_pow2. apply J.mul_correct with (1 := Hpow). now apply J.sqr_correct. apply J.sub_correct. rewrite <- pow_add. replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; lia). rewrite pow_1_even, Rmult_1_l. replace (S (n - S m)) with (n - S m + 1) by now rewrite Nat.add_comm. now apply J.div_correct. evar_last. apply IHm. clear -Hm ; lia. now rewrite <- (Nat.add_0_r (n - m)), <- H. rewrite <- H. replace (2 * (n - S m + 2)) with (S (S (2 * (n - S m + 1)))) by ring. rewrite 2!fact_simpl. rewrite 2!mult_INR, <- Rmult_assoc, Rmult_comm. apply J.mul_correct with (1 := Hdiv). rewrite Rmult_comm. apply J.mul_correct. now rewrite <- Nat.add_1_r. rewrite <- 2!Nat.add_1_r. rewrite plus_INR. apply J.add_correct with (1 := Hfact). now apply I.fromZ_small_correct. rewrite <- H. replace (2 * (n - S m + 2) + 1) with (2 * (n - S m + 1) + 1 + 2) by ring. rewrite plus_INR. apply J.add_correct with (1 := Hfact). now apply I.fromZ_small_correct. apply f_equal. change (A1 (toR x) (n - S m) + (-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m))) * toR x ^ (2 * S (n - S m)))%R with (A1 (toR x) (S (n - S m))). change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R. rewrite <- plus_Sn_m. now rewrite <-Nat.sub_succ_l. Qed. Lemma sin_cos_reduce_correct : forall prec nb x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R -> match sin_cos_reduce prec x nb with | (ss, ci) => contains (I.convert ci) (Xreal (cos (toR x))) /\ match ss with | Lt => (sin (toR x) <= 0)%R | Gt => (0 <= sin (toR x))%R | _ => True end end. Proof. intros prec. assert (forall x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R -> F'.le x c1_2 = true -> contains (I.convert (cos_fast0 prec x)) (Xreal (cos (toR x))) /\ (0 <= sin (toR x))%R). { intros x Hxr Hx0 H. unfold c1_2, c1 in H. assert (toR x <= /2)%R. { rewrite F'.le_correct with (1 := Hxr) in H. 2: { unfold F.toR. now fold c1; fold c1_2; rewrite c1_2_correct. } revert H. case Rle_bool_spec ; try easy. unfold F.toR. now fold c1; fold c1_2; rewrite c1_2_correct. } split. { apply cos_fast0_correct with (1 := Hxr). now rewrite Rabs_right; [|apply Rle_ge]. } apply sin_ge_0 with (1 := Hx0). (* x <= pi *) apply Rle_trans with (1 := H0). apply Rlt_le. apply Rmult_lt_reg_l with (/4)%R. { apply Rinv_0_lt_compat. now apply IZR_lt. } rewrite <- (Rmult_comm PI). apply Rlt_le_trans with (2 := proj1 (PI_ineq 0)). unfold tg_alt, PI_tg. simpl. lra. } induction nb ; intros x Hxr Hx. { (* nb = 0 *) simpl. case_eq (F'.le x c1_2). { intros. exact (H x Hxr Hx H0). } intros _. simpl. unfold cm1, c1. rewrite F'.valid_lb_real, F'.valid_ub_real by now rewrite F.real_correct, F.fromZ_correct. rewrite 2!F.fromZ_correct by easy. refine (conj _ I). apply COS_bound. } (* nb > 0 *) simpl. case_eq (F'.le x c1_2). { intros. exact (H x Hxr Hx H0). } rewrite F'.le_correct; try (unfold F.toR; rewrite c1_2_correct); [simpl|easy..]. intros Hxhalf. refine (_ (IHnb (F.div2 x) _ _)). { destruct (sin_cos_reduce prec (F.div2 x) nb) as (ss, ci). fold (F.toR x). replace (F.toR x) with (2 * (toR (F.div2 x)))%R. { generalize (toR (F.div2 x)). revert Hxr Hxhalf; clear; intros Hxr Hxhalf. intros hx (Hc, Hs). split. { (* - cos *) replace (Xreal (cos (2 * hx))) with (Xsub (Xmul (Xsqr (Xreal (cos hx))) (Xreal 2)) (Xreal 1)). { apply I.sub_correct. { apply I.mul2_correct. apply I.sqr_correct. exact Hc. } now apply I.fromZ_small_correct. } simpl. apply f_equal. rewrite cos_2a_cos. unfold Rsqr. ring. } (* - sin *) rewrite sin_2a. destruct ss. { exact I. } { change (cos hx) with (proj_val (Xreal (cos hx))). generalize (I.sign_large_correct ci). case (I.sign_large ci) ; intros ; try exact I. { apply Rmult_le_neg_neg. { apply Rmult_le_pos_neg. { now apply IZR_le. } exact Hs. } exact (proj2 (H _ Hc)). } apply Rmult_le_neg_pos. { apply Rmult_le_pos_neg. { now apply IZR_le. } exact Hs. } exact (proj2 (H _ Hc)). } change (cos hx) with (proj_val (Xreal (cos hx))). generalize (I.sign_large_correct ci). case (I.sign_large ci) ; intros ; try exact I. { apply Rmult_le_pos_neg. { apply Rmult_le_pos_pos. { now apply IZR_le. } exact Hs. } exact (proj2 (H _ Hc)). } apply Rmult_le_pos_pos. { apply Rmult_le_pos_pos. { now apply IZR_le. } exact Hs. } exact (proj2 (H _ Hc)). } unfold toR; rewrite F.div2_correct; [|easy|]. { rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy]. rewrite Hxr; simpl; lra. } rewrite (Rabs_pos_eq _ Hx). revert Hxhalf; case Rle_bool_spec; [easy|]; fold (F.toR x); lra. } { unfold toR; rewrite F.div2_correct; [|easy|]. { rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy]. now rewrite Hxr. } rewrite (Rabs_pos_eq _ Hx). revert Hxhalf; case Rle_bool_spec; [easy|]; fold (F.toR x); lra. } unfold toR; rewrite F.div2_correct; [|easy|]. { rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy]. rewrite Hxr; simpl; lra. } rewrite (Rabs_pos_eq _ Hx). revert Hxhalf; case Rle_bool_spec; [easy|]; fold (F.toR x); lra. Qed. (* 0 <= input *) Definition cos_fastP prec x := let th := c1_2 in match F'.le' x th with | true => cos_fast0 prec x | _ => let m := F.StoZ (F.mag x) in let prec := F.incr_prec prec (Z2P (m + 6)) in snd (sin_cos_reduce prec x (S (Z2nat m))) end. Lemma cos_fastP_correct : forall prec x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R -> contains (I.convert (cos_fastP prec x)) (Xreal (cos (toR x))). Proof. intros prec x Hxr Hx0. unfold cos_fastP. case_eq (F'.le' x c1_2) ; intros H. { apply cos_fast0_correct. { easy. } rewrite Rabs_pos_eq with (1 := Hx0). apply F'.le'_correct in H. revert H. now rewrite c1_2_correct, Hxr. } generalize (S (Z2nat (F.StoZ (F.mag x)))) (F.incr_prec prec (Z2P (F.StoZ (F.mag x) + 6))). intros nb prec'. generalize (sin_cos_reduce_correct prec' nb x Hxr Hx0). destruct sin_cos_reduce as [ss ci]. apply proj1. Qed. Definition cos_fast prec x := match F'.cmp x F.zero with | Xeq => i1 | Xlt => cos_fastP prec (F.neg x) | Xgt => cos_fastP prec x | Xund => I.nai end. Theorem cos_fast_correct : forall prec x, contains (I.convert (cos_fast prec x)) (Xcos (F.toX x)). Proof. intros prec x. unfold cos_fast. rewrite F'.cmp_correct, F.zero_correct. case_eq (F.toX x). easy. intros r Hr. simpl. case Rcompare_spec ; intros H. (* neg *) replace r with (- toR (F.neg x))%R. rewrite cos_neg. apply cos_fastP_correct. unfold toR. now rewrite F'.neg_correct, Hr. unfold toR. rewrite F'.neg_correct, Hr. rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. unfold toR. rewrite F'.neg_correct, Hr. apply Ropp_involutive. (* zero *) rewrite H, cos_0. unfold c1. simpl. rewrite F'.valid_lb_real, F'.valid_ub_real by now rewrite F.real_correct, F.fromZ_correct. rewrite F.fromZ_correct by easy. split ; apply Rle_refl. (* pos *) replace r with (toR x). apply cos_fastP_correct. unfold toR. now rewrite Hr. unfold toR. rewrite Hr. now apply Rlt_le. unfold toR. now rewrite Hr. Qed. (* -1/2 <= input <= 1/2 *) Definition sin_fast0 prec x := let xi := I.bnd x x in let x2i := I.sqr prec xi in let p := F.prec prec in let thre := F.scale c1 (F.ZtoS (Zneg p)) in let rem := cos_fast0_aux prec thre i1 x2i i4 i6 (nat_of_P p) in I.mul prec (I.sub prec i1 rem) xi. Lemma sin_fast0_correct : forall prec x, F.toX x = Xreal (toR x) -> (Rabs (toR x) <= /2)%R -> contains (I.convert (sin_fast0 prec x)) (Xreal (sin (toR x))). Proof. intros prec x Rx Bx. unfold sin_fast0. rewrite sin_sinc. replace (sinc (toR x)) with (1 - (1 - sinc (toR x)))%R by ring. rewrite Rmult_comm. set (xi := I.bnd x x). assert (Ix: contains (I.convert xi) (Xreal (toR x))). unfold xi. rewrite I.bnd_correct, Rx. split ; apply Rle_refl. apply F'.valid_lb_real ; now rewrite F.real_correct, Rx. apply F'.valid_ub_real ; now rewrite F.real_correct, Rx. apply J.mul_correct with (2 := Ix). apply J.sub_correct. now apply I.fromZ_small_correct. set (x2i := I.sqr prec xi). pose (Si := fun x => sum_f_R0 (fun n : nat => ((-1) ^ n / INR (fact (2 * n + 1)) * x ^ (2 * n))%R)). assert (Hexit : forall k powi divi, contains (I.convert powi) (Xreal (toR x ^ (2 * k))) -> contains (I.convert divi) (Xreal (INR (fact (2 * (k + 1) + 1)))) -> contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi)))) (Xreal ((-1) ^ (k + 1) * (sinc (toR x) - Si (toR x) k)))). intros k powi divi Hpow Hdiv. assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi x2i) divi))). { exists ((F.toR x ^ (2 * k) * (F.toR x * F.toR x)) / INR (fact (2 * (k + 1) + 1)))%R. now apply J.div_correct; [apply J.mul_correct; [|apply J.sqr_correct]|]. } rewrite I.bnd_correct. 2: now apply I.valid_lb_real; rewrite F.zero_correct. 2: now apply I.valid_ub_upper. rewrite F.zero_correct, I.upper_correct by easy. assert (A: (0 <= (-1) ^ (k + 1) * (sinc (toR x) - Si (toR x) k) <= toR x ^ (2 * (k + 1)) / INR (fact (2 * (k + 1) + 1)))%R). replace (Si (toR x) k) with (sum_f_R0 (tg_alt (fun n => / INR (fact (2 * n + 1)) * toR x ^ (2 * n))%R) k). unfold Rdiv. rewrite (Rmult_comm (toR x ^ _)). replace (k + 1) with (S k) by ring. apply alternated_series_ineq'. apply Un_decreasing_sinc. lra. destruct (Req_dec (toR x) 0) as [Zx|Zx]. rewrite Zx. intros eps Heps. exists 1%nat. intros n Hn. rewrite pow_ne_zero by (clear -Hn ; lia). unfold R_dist, Rminus. now rewrite Rmult_0_r, Rplus_opp_r, Rabs_R0. rewrite <- (Rmult_0_l (/toR x)). apply Un_cv_ext with (fun n : nat => (/ INR (fact (2 * n + 1)) * toR x ^ (2 * n + 1) * / toR x)%R). intros n. rewrite pow_add. field. split. apply Rgt_not_eq. apply INR_fact_lt_0. exact Zx. apply CV_mult. apply (Un_cv_subseq (fun n => (/ INR (fact n) * toR x ^ n)%R)). clear ; intros n ; lia. eapply Un_cv_ext. intros n. apply Rmult_comm. apply cv_speed_pow_fact. intros eps Heps. exists 0. intros _ _. unfold R_dist, Rminus. now rewrite Rplus_opp_r, Rabs_R0. unfold sinc. case exist_sin. intro l. change (projT1 _) with l. apply Un_cv_ext. intros n. apply sum_eq. intros i _. unfold sin_n, tg_alt. rewrite pow_Rsqr. apply Rmult_assoc. unfold Si, tg_alt. apply sum_eq. intros i _. apply sym_eq, Rmult_assoc. apply (conj (proj1 A)). assert (Hx2 := J.sqr_correct prec _ _ Ix). assert (H1 := J.mul_correct prec _ _ _ _ Hpow Hx2). assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv). destruct (I.convert (I.div prec _ _)) as [|l [|u]] ; try easy. apply Rle_trans with (1 := proj2 A). apply Rle_trans with (2 := proj2 H2). apply Req_le, Rmult_eq_compat_r. replace (2 * (k + 1)) with (2 * k + 2) by ring. now rewrite pow_add, Rsqr_pow2. generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)). intros thre n. replace 1%R with (Si (toR x) 0) by (unfold Si ; simpl ; field). refine (_ (I.fromZ_small_correct 1 _) (I.fromZ_small_correct 6 _) (I.fromZ_small_correct 4 _)) ; [|easy..]. fold i1 i6 i4. generalize i1 i6 i4. intros powi divi facti. change 1%R with (pow (toR x) (2 * 0)). change 4%Z with (Z_of_nat (2 * (0 + 1) + 2)). change 6%Z with (Z_of_nat (fact (2 * (0 + 1) + 1))). rewrite <- 2!INR_IZR_INZ. replace (Si (toR x) 0%nat - sinc (toR x))%R with ((-1) * 1 * (sinc (toR x) - Si (toR x) 0%nat))%R by ring. change (-1 * 1)%R with (pow (-1) (0 + 1)). rewrite <- (Nat.sub_diag n) at 2 4 8 11 13. generalize (Nat.le_refl n). generalize n at 1 4 6 8 9 11 13. intros m. revert powi divi facti. induction m as [|m IHm] ; intros powi divi facti Hm Hpow Hdiv Hfact. simpl cos_fast0_aux. cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi x2i) divi)))) (Xreal ((-1) ^ (n - 0 + 1) * (sinc (toR x) - Si (toR x) (n - 0))))). now destruct F'.cmp. now apply Hexit. simpl cos_fast0_aux. set (powi' := I.mul prec powi x2i). set (divi' := I.mul prec divi (I.mul prec facti (I.add prec facti i1))). set (facti' := I.add prec facti i2). specialize (IHm powi' divi' facti'). assert (H: forall p, n - S m + S p = n - m + p). intros p. clear -Hm ; lia. cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (cos_fast0_aux prec thre powi' x2i facti' divi' m))) (Xreal ((-1) ^ (n - S m + 1) * (sinc (toR x) - Si (toR x) (n - S m))))). case F'.cmp ; try easy. intros H'. now apply Hexit. replace ((-1) ^ (n - S m + 1) * (sinc (toR x) - Si (toR x) (n - S m)%nat))%R with ((-1) ^ (n - S m + 1) * (-1) ^ S (n - S m) * (toR x) ^ (2 * S (n - S m)) * / INR (fact (2 * S (n - S m) + 1)) - (((-1) * (-1) ^ (n - S m + 1)) * (sinc (toR x) - (Si (toR x) (n - S m)%nat + ((-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m) + 1)) * (toR x) ^ (2 * S (n - S m)))))))%R by ring. assert (Hpow': contains (I.convert powi') (Xreal (toR x ^ (2 * (n - S m + 1))))). replace (2 * (n - S m + 1)) with (2 * (n - S m) + 2) by ring. rewrite pow_add, <- Rsqr_pow2. apply J.mul_correct with (1 := Hpow). now apply J.sqr_correct. apply J.sub_correct. rewrite <- pow_add. replace (n - S m + 1 + S (n - S m)) with (2 * (n - S m + 1)) by (clear -Hm ; lia). rewrite pow_1_even, Rmult_1_l. replace (S (n - S m)) with (n - S m + 1) by now rewrite Nat.add_comm. now apply J.div_correct. evar_last. apply IHm. clear -Hm ; lia. now rewrite <- (Nat.add_0_r (n - m)), <- H. rewrite <- H. replace (2 * (n - S m + 2) + 1) with (S (S (2 * (n - S m + 1) + 1))) by ring. rewrite 2!fact_simpl. rewrite 2!mult_INR, <- Rmult_assoc, Rmult_comm. apply J.mul_correct with (1 := Hdiv). rewrite Rmult_comm. apply J.mul_correct. now rewrite <- Nat.add_1_r, <- Nat.add_assoc. replace (S (S (2 * (n - S m + 1) + 1))) with (2 * (n - S m + 1) + 2 + 1) by ring. rewrite plus_INR. apply J.add_correct with (1 := Hfact). now apply I.fromZ_small_correct. rewrite <- H. replace (2 * (n - S m + 2) + 2) with (2 * (n - S m + 1) + 2 + 2) by ring. rewrite plus_INR. apply J.add_correct with (1 := Hfact). now apply I.fromZ_small_correct. apply f_equal. change (Si (toR x) (n - S m)%nat + (-1) ^ S (n - S m) * / INR (fact (2 * S (n - S m) + 1)) * toR x ^ (2 * S (n - S m)))%R with (Si (toR x) (S (n - S m))). change (-1 * (-1) ^ (n - S m + 1))%R with ((-1) ^ (S (n - S m + 1)))%R. rewrite <- plus_Sn_m. now rewrite <-Nat.sub_succ_l. Qed. (* 0 <= input *) Definition sin_fastP prec x := let th := c1_2 in match F'.le' x th with | true => sin_fast0 (F.incr_prec prec 1) x | _ => let m := F.StoZ (F.mag x) in let prec := F.incr_prec prec (Z2P (m + 6)) in match sin_cos_reduce prec x (S (Z2nat m)) with | (s, c) => let v := I.sqrt prec (I.sub prec i1 (I.sqr prec c)) in match s with | Lt => I.neg v | Gt => v | _ => I.bnd cm1 c1 end end end. Lemma sin_fastP_correct : forall prec x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R -> contains (I.convert (sin_fastP prec x)) (Xreal (sin (toR x))). Proof. intros prec x Hxr Hx0. unfold sin_fastP, cm1, c1. case_eq (F'.le' x c1_2) ; intros Hx. { apply sin_fast0_correct. { easy. } rewrite Rabs_pos_eq with (1 := Hx0). apply F'.le'_correct in Hx. revert Hx. unfold toR, c1. now rewrite Hxr, c1_2_correct. } generalize (S (Z2nat (F.StoZ (F.mag x)))) (F.incr_prec prec (Z2P (F.StoZ (F.mag x) + 6))). intros nb prec'. generalize (sin_cos_reduce_correct prec' nb x Hxr Hx0). destruct sin_cos_reduce as [ss ci]. intros [Hc Hs]. destruct ss. { simpl. rewrite F'.valid_lb_real, F'.valid_ub_real by now rewrite F.real_correct, F.fromZ_correct. rewrite 2!F.fromZ_correct by easy. apply SIN_bound. } { rewrite <- (Ropp_involutive (sin (toR x))). change (Xreal (- - sin (toR x))) with (Xneg (Xreal (- sin (toR x)))). apply I.neg_correct. rewrite <- Rabs_left1 with (1 := Hs). rewrite <- sqrt_Rsqr_abs. replace (Xreal (sqrt (sin (toR x))²)) with (Xsqrt (Xreal (sin (toR x))²)). { apply I.sqrt_correct. rewrite sin2. change (Xreal (1 - (cos (toR x))²)) with (Xsub (Xreal 1) (Xsqr (Xreal (cos (toR x))))). apply I.sub_correct. now apply I.fromZ_small_correct. now apply I.sqr_correct. } unfold Xsqrt'. simpl. destruct (is_negative_spec (sin (toR x))²). { elim (Rlt_not_le _ _ H). apply Rle_0_sqr. } apply refl_equal. } rewrite <- (Rabs_pos_eq (sin (toR x))) with (1 := Hs). rewrite <- sqrt_Rsqr_abs. replace (Xreal (sqrt (sin (toR x))²)) with (Xsqrt (Xreal (sin (toR x))²)). { apply I.sqrt_correct. rewrite sin2. change (Xreal (1 - (cos (toR x))²)) with (Xsub (Xreal 1) (Xsqr (Xreal (cos (toR x))))). apply I.sub_correct. now apply I.fromZ_small_correct. now apply I.sqr_correct. } unfold Xsqrt'. simpl. destruct (is_negative_spec (sin (toR x))²). { elim (Rlt_not_le _ _ H). apply Rle_0_sqr. } apply refl_equal. Qed. Definition sin_fast prec x := match F'.cmp x F.zero with | Xeq => I.zero | Xlt => I.neg (sin_fastP prec (F.neg x)) | Xgt => sin_fastP prec x | Xund => I.nai end. Theorem sin_fast_correct : forall prec x, contains (I.convert (sin_fast prec x)) (Xsin (F.toX x)). Proof. intros prec x. unfold sin_fast. rewrite F'.cmp_correct, F.zero_correct. case_eq (F.toX x). easy. intros r Hr. simpl. case Rcompare_spec ; intros H. (* neg *) rewrite <- (Xneg_involutive (Xreal _)). apply I.neg_correct. simpl. rewrite <- sin_neg. replace (Ropp r) with (toR (F.neg x)). apply sin_fastP_correct. unfold toR. now rewrite F'.neg_correct, Hr. unfold toR. rewrite F'.neg_correct, Hr. rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. unfold toR. now rewrite F'.neg_correct, Hr. (* zero *) rewrite H, sin_0. simpl. rewrite F.zero_correct, F'.valid_lb_zero, F'.valid_ub_zero. split ; apply Rle_refl. (* pos *) replace r with (toR x). apply sin_fastP_correct. unfold toR. now rewrite Hr. unfold toR. rewrite Hr. now apply Rlt_le. unfold toR. now rewrite Hr. Qed. (* 0 <= input *) Definition tan_fastP prec x := let th := c1_2 in match F'.le' x th with | true => let prec := F.incr_prec prec 2 in let s := sin_fast0 prec x in I.div prec s (I.sqrt prec (I.sub prec i1 (I.sqr prec s))) | _ => let m := F.StoZ (F.mag x) in let prec := F.incr_prec prec (Z2P (m + 7)) in match sin_cos_reduce prec x (S (Z2nat m)) with | (s, c) => let v := I.sqrt prec (I.sub prec (I.inv prec (I.sqr prec c)) i1) in match s, I.sign_large c with | Lt, Xgt => I.neg v | Gt, Xlt => I.neg v | Lt, Xlt => v | Gt, Xgt => v | _, _ => I.nai end end end. Definition tan_fast prec x := match F'.cmp x F.zero with | Xeq => I.zero | Xlt => I.neg (tan_fastP prec (F.neg x)) | Xgt => tan_fastP prec x | Xund => I.nai end. Lemma tan_fastP_correct : forall prec x, F.toX x = Xreal (toR x) -> (0 <= toR x)%R -> contains (I.convert (tan_fastP prec x)) (Xtan (Xreal (toR x))). Proof. intros prec x Rx Bx. unfold tan_fastP. case_eq (F'.le' x c1_2) ; intros Hx. - apply F'.le'_correct in Hx. revert Hx. rewrite c1_2_correct, Rx. intros Bx'. replace (Xtan (Xreal (toR x))) with (Xdiv (Xreal (sin (toR x))) (Xsqrt (Xsub (Xreal 1) (Xsqr (Xreal (sin (toR x))))))). apply I.div_correct. apply sin_fast0_correct with (1 := Rx). now rewrite Rabs_pos_eq. apply I.sqrt_correct. apply I.sub_correct. now apply I.fromZ_small_correct. apply I.sqr_correct. apply sin_fast0_correct with (1 := Rx). now rewrite Rabs_pos_eq. unfold Xsqrt'. simpl. set (e := (1 - _)%R). case (Rlt_or_le e 0); unfold e. { intro H. elim Rlt_not_le with (1 := H). apply Rle_0_minus. rewrite <- (Rmult_1_r 1). apply neg_pos_Rsqr_le ; apply SIN_bound. } change (sin (toR x) * sin (toR x))%R with (Rsqr (sin (toR x))). rewrite <- cos2. intros H'. assert (Hc: (0 < cos (toR x))%R). apply cos_gt_0. apply Rlt_le_trans with (2 := Bx). apply Ropp_lt_gt_0_contravar. apply PI2_RGT_0. apply Rle_lt_trans with (1 := Bx'). apply Rlt_trans with (2 := PI2_1). lra. unfold Xdiv'. case is_zero_spec. intros H. elim Rgt_not_eq with (1 := Hc). apply Rsqr_0_uniq. now apply sqrt_eq_0. intros H''. unfold Xtan'. simpl. case is_zero_spec. intros H. rewrite H in Hc. elim Rlt_irrefl with (1 := Hc). intros _. apply (f_equal (fun v => Xreal (_ / v))). apply sqrt_Rsqr. now apply Rlt_le. - generalize (F.incr_prec prec (Z2P (F.StoZ (F.mag x) + 7))). clear prec. intros prec. generalize (sin_cos_reduce_correct prec (S (Z2nat (F.StoZ (F.mag x)))) x Rx Bx). case sin_cos_reduce. intros s c [Hc Hs]. assert (H: contains (I.convert (I.sqrt prec (I.sub prec (I.inv prec (I.sqr prec c)) i1))) (Xabs (Xdiv (Xreal (sin (toR x))) (Xreal (cos (toR x)))))). replace (Xabs (Xdiv (Xreal (sin (toR x))) (Xreal (cos (toR x))))) with (Xsqrt (Xsub (Xinv (Xsqr (Xreal (cos (toR x))))) (Xreal 1))). apply I.sqrt_correct. apply I.sub_correct. apply I.inv_correct. now apply I.sqr_correct. now apply I.fromZ_small_correct. unfold Xdiv', Xinv'. simpl. case is_zero_spec ; intros Zc. rewrite Rsqr_0_uniq with (1 := Zc). now rewrite is_zero_0. case is_zero_spec ; intros Zc'. rewrite Zc' in Zc. elim Zc. apply Rmult_0_l. unfold Xsqrt'. simpl. replace (/ (Rsqr (cos (toR x))) - 1)%R with (Rsqr (sin (toR x) / cos (toR x))). { set (e := (_²)%R). case (Rlt_or_le e 0); unfold e; intro H. { elim Rlt_not_le with (1 := H). apply Rle_0_sqr. } apply f_equal, sqrt_Rsqr_abs. } rewrite Rsqr_div with (1 := Zc'). rewrite sin2. unfold Rsqr. now field. unfold Xdiv', Xbind2 in H. generalize (I.sign_large_correct c). unfold Xtan', Xbind. destruct s ; try easy ; case I.sign_large ; try easy ; intros Hc'. destruct (is_zero_spec (cos (toR x))) as [H0|H0]. easy. evar_last. apply H. apply (f_equal Xreal). apply Rabs_pos_eq. apply Rmult_le_neg_neg with (1 := Hs). apply Rlt_le, Rinv_lt_0_compat. apply Rnot_le_lt. contradict H0. apply Rle_antisym with (2 := H0). now specialize (Hc' _ Hc). rewrite <- (Xneg_involutive (if is_zero _ then _ else _)). apply I.neg_correct. destruct (is_zero_spec (cos (toR x))) as [H0|H0]. easy. evar_last. apply H. apply (f_equal Xreal). apply Rabs_left1. apply Rmult_le_neg_pos with (1 := Hs). apply Rlt_le, Rinv_0_lt_compat. apply Rnot_le_lt. contradict H0. apply Rle_antisym with (1 := H0). now specialize (Hc' _ Hc). rewrite <- (Xneg_involutive (if is_zero _ then _ else _)). apply I.neg_correct. destruct (is_zero_spec (cos (toR x))) as [H0|H0]. easy. evar_last. apply H. apply (f_equal Xreal). apply Rabs_left1. apply Rmult_le_pos_neg with (1 := Hs). apply Rlt_le, Rinv_lt_0_compat. apply Rnot_le_lt. contradict H0. apply Rle_antisym with (2 := H0). now specialize (Hc' _ Hc). destruct (is_zero_spec (cos (toR x))) as [H0|H0]. easy. evar_last. apply H. apply (f_equal Xreal). apply Rabs_pos_eq. apply Rmult_le_pos_pos with (1 := Hs). apply Rlt_le, Rinv_0_lt_compat. apply Rnot_le_lt. contradict H0. apply Rle_antisym with (1 := H0). now specialize (Hc' _ Hc). Qed. Theorem tan_fast_correct : forall prec x, contains (I.convert (tan_fast prec x)) (Xtan (F.toX x)). Proof. intros prec x. unfold tan_fast. rewrite F'.cmp_correct, F.zero_correct. case_eq (F.toX x). easy. intros r Hr. simpl Xcmp. case Rcompare_spec ; intros H. (* neg *) rewrite <- (Xneg_involutive (Xtan _)). apply I.neg_correct. generalize (tan_fastP_correct prec (F.neg x)). unfold toR. rewrite F'.neg_correct, Hr. simpl. intros H'. assert (H1 : (0 <= -r)%R). rewrite <- Ropp_0. apply Ropp_le_contravar. now apply Rlt_le. specialize (H' eq_refl H1). revert H'. unfold Xtan'. simpl. rewrite cos_neg. case is_zero_spec. easy. intros _. now rewrite tan_neg. (* zero *) simpl. rewrite H, F.zero_correct. unfold Xtan'. simpl. case is_zero_spec. rewrite cos_0. intros H'. now elim R1_neq_R0. intros _. rewrite tan_0. rewrite F'.valid_lb_zero, F'.valid_ub_zero. split ; apply Rle_refl. (* pos *) replace r with (toR x). apply tan_fastP_correct. unfold toR. now rewrite Hr. unfold toR. rewrite Hr. now apply Rlt_le. unfold toR. now rewrite Hr. Qed. Definition semi_extension f fi := forall x, contains (I.convert (fi x)) (f (F.toX x)). Definition cos_correct : forall prec, semi_extension Xcos (cos_fast prec) := cos_fast_correct. Definition sin_correct : forall prec, semi_extension Xsin (sin_fast prec) := sin_fast_correct. Definition tan_correct : forall prec, semi_extension Xtan (tan_fast prec) := tan_fast_correct. Definition atan_correct : forall prec, semi_extension Xatan (atan_fast prec) := atan_fast_correct. (* 0 <= inputs *) Fixpoint expn_fast0_aux prec thre powi xi facti divi (nb : nat) { struct nb } := let npwi := I.mul prec powi xi in let vali := I.div prec npwi divi in match F'.cmp (I.upper vali) thre, nb with | Xlt, _ | _, O => I.bnd F.zero (I.upper vali) | _, S n => let nfacti := I.add prec facti i1 in let ndivi := I.mul prec divi facti in I.sub prec vali (expn_fast0_aux prec thre npwi xi nfacti ndivi n) end. (* 0 <= input <= 1/2 *) Definition expn_fast0 prec x := let p := F.prec prec in let thre := F.scale c1 (F.ZtoS (Zneg p)) in let xi := I.bnd x x in let rem := expn_fast0_aux prec thre xi xi i3 i2 (nat_of_P p) in I.sub prec i1 (I.sub prec xi rem). (* 0 <= input *) Definition expn_reduce prec x := let th := c1_8 in match F'.le' x th with | true => expn_fast0 (F.incr_prec prec 1) x | false => let m := F.StoZ (F.mag x) in let prec := F.incr_prec prec (Z2P (9 + m)) in let fix reduce x (nb : nat) {struct nb} := match F'.le' x th, nb with | true, _ => expn_fast0 prec x | _, O => I.bnd F.zero c1 | _, S n => I.sqr prec (reduce (F.div2 x) n) end in reduce x (8 + Z2nat m) end. Definition exp_fast prec x := match F'.cmp x F.zero with | Xeq => i1 | Xlt => expn_reduce prec (F.neg x) | Xgt => let prec := F.incr_prec prec 1 in match I.invnz prec (expn_reduce prec x) with | Ibnd _ _ as b => b | Inai => I.bnd c1 F.nan end | Xund => I.nai end. Lemma expn_fast0_correct : forall prec x, F.toX x = Xreal (toR x) -> (0 <= toR x <= /2)%R -> contains (I.convert (expn_fast0 prec x)) (Xreal (exp (- toR x))). Proof. intros prec x Rx Bx. unfold expn_fast0. replace (exp (-toR x)) with (1 - (toR x - (- (1 - toR x) + exp (-toR x))))%R by ring. apply J.sub_correct. now apply I.fromZ_small_correct. set (xi := I.bnd x x). assert (Ix: contains (I.convert xi) (Xreal (toR x))). unfold xi. rewrite I.bnd_correct, Rx. 2: now apply I.valid_lb_real; rewrite Rx. 2: now apply I.valid_ub_real; rewrite Rx. split ; apply Rle_refl. apply J.sub_correct with (1 := Ix). assert (Hexit : forall k powi divi, contains (I.convert powi) (Xreal (toR x ^ (k + 1))) -> contains (I.convert divi) (Xreal (INR (fact (k + 2)))) -> contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi)))) (Xreal ((-1) ^ k * (exp (- toR x) + - E1 (- toR x) (k + 1))))). intros k powi divi Hpow Hdiv. assert (Hne : not_empty (I.convert (I.div prec (I.mul prec powi xi) divi))). { exists ((F.toR x ^ (k + 1) * F.toR x)/ INR (fact (k + 2)))%R. now apply J.div_correct; [apply J.mul_correct|]. } rewrite I.bnd_correct. 2: now apply I.valid_lb_real; rewrite F.zero_correct. 2: now apply I.valid_ub_upper. rewrite F.zero_correct, I.upper_correct by easy. assert (A: (0 <= (-1) ^ k * (exp (- toR x) + - E1 (- toR x) (k + 1)) <= toR x ^ (k + 2) / INR (fact (k + 2)))%R). replace ((-1) ^ k)%R with ((-1) * ((-1) * (-1) ^ k))%R by ring. change ((-1) * ((-1) * (-1) ^ k))%R with ((-1) ^ (S (S k)))%R. unfold Rdiv. rewrite (Rmult_comm (toR x ^ (k + 2))). replace (E1 (- toR x) (k + 1)) with (sum_f_R0 (tg_alt (fun n => / INR (fact n) * toR x ^ n)%R) (k + 1)). rewrite <- (plus_n_Sm _ 1). replace (S k) with (k + 1) by ring. apply alternated_series_ineq'. apply Un_decreasing_exp. split. apply Bx. lra. eapply Un_cv_ext. intros n. apply Rmult_comm. apply cv_speed_pow_fact. generalize (E1_cvg (- toR x)). apply Un_cv_ext. intros n. unfold E1, tg_alt. apply sum_eq. intros i _. rewrite (Rmult_comm _ (toR x ^ i)), <- Rmult_assoc. rewrite <- Rpow_mult_distr. rewrite Rmult_comm. apply (f_equal (fun v => (v ^ i * _)%R)). ring. unfold E1, tg_alt. apply sum_eq. intros i _. unfold Rdiv. rewrite Rmult_comm, Rmult_assoc. rewrite <- Rpow_mult_distr. apply (f_equal (fun v => (_ * v ^ i)%R)). ring. apply (conj (proj1 A)). assert (H1 := J.mul_correct prec _ _ _ _ Hpow Ix). assert (H2 := J.div_correct prec _ _ _ _ H1 Hdiv). destruct (I.convert (I.div prec _ _)) as [|l [|u]] ; try easy. apply Rle_trans with (1 := proj2 A). apply Rle_trans with (2 := proj2 H2). apply Req_le, Rmult_eq_compat_r. rewrite <- plus_n_Sm. apply Rmult_comm. generalize (F.scale c1 (F.ZtoS (Z.neg (F.prec prec)))) (Pos.to_nat (F.prec prec)). intros thre n. replace (1 - toR x)%R with (E1 (- toR x) (0 + 1)) by (unfold E1 ; simpl ; field). refine (_ Ix (I.fromZ_small_correct 2 _) (I.fromZ_small_correct 3 _)) ; [|easy..]. fold i2 i3. generalize i2 i3. generalize xi at 1 2. intros powi divi facti. rewrite <- (pow_1 (toR x)) at 1. rewrite Rplus_comm. change 1 with (0 + 1) at 1. change 3%Z with (Z_of_nat (0 + 3)). change 2%Z with (Z_of_nat (fact (0 + 2))). rewrite <- 2!INR_IZR_INZ. rewrite <- (Rmult_1_l (_ + _)). change 1%R with ((-1)^0)%R. rewrite <- (Nat.sub_diag n) at 1 3 5 7 8. generalize (Nat.le_refl n). generalize n at 1 4 6 8 9 11 13. intros m. revert powi divi facti. induction m as [|m IHm] ; intros powi divi facti Hm Hpow Hdiv Hfact. simpl expn_fast0_aux. cut (contains (I.convert (I.bnd F.zero (I.upper (I.div prec (I.mul prec powi xi) divi)))) (Xreal ((-1) ^ (n - 0) * (exp (- toR x) + - E1 (- toR x) (n - 0 + 1))))). now destruct F'.cmp. now apply Hexit. simpl expn_fast0_aux. set (powi' := I.mul prec powi xi). set (divi' := I.mul prec divi facti). set (facti' := I.add prec facti i1). specialize (IHm powi' divi' facti'). assert (H: forall p, n - m + p = n - S m + p + 1). intros p. clear -Hm ; lia. cut (contains (I.convert (I.sub prec (I.div prec powi' divi) (expn_fast0_aux prec thre powi' xi facti' divi' m))) (Xreal ((-1) ^ (n - S m) * (exp (- toR x) + - E1 (- toR x) (n - S m + 1))))). case F'.cmp ; try easy. intros H'. now apply Hexit. replace ((-1) ^ (n - S m) * (exp (- toR x) + - E1 (- toR x) (n - S m + 1)))%R with ((toR x) ^ (n - m + 1) * / INR (fact (n - m + 1)) - (((-1) * (-1) ^ (n - S m)) * (exp (- toR x) + - E1 (- toR x) (n - S m + 1)) + / INR (fact (n - m + 1)) * (toR x) ^ (n - m + 1)))%R by ring. change (-1 * (-1) ^ (n - S m))%R with ((-1) ^ (S (n - S m)))%R. rewrite <-Nat.sub_succ_l with (1 := Hm). simpl (S n - S m). assert (Hpow': contains (I.convert powi') (Xreal (toR x ^ (n - m + 1)))). rewrite H. rewrite pow_add, pow_1. now apply J.mul_correct. apply J.sub_correct. apply J.div_correct with (1 := Hpow'). now rewrite H, <-Nat.add_assoc. evar_last. apply IHm. clear -Hm ; lia. exact Hpow'. rewrite H. rewrite Nat.add_comm, fact_simpl. rewrite Nat.mul_comm, mult_INR. apply J.mul_correct with (1 := Hdiv). now rewrite plus_n_Sm. rewrite H. rewrite plus_INR. apply J.add_correct with (1 := Hfact). now apply I.fromZ_small_correct. apply f_equal. rewrite 2!Rmult_plus_distr_l. rewrite Rplus_assoc. apply f_equal. rewrite <- plus_n_Sm at 1. unfold E1. change (sum_f_R0 (fun k : nat => / INR (fact k) * (- toR x) ^ k) (S (n - m + 0)))%R with (sum_f_R0 (fun k : nat => / INR (fact k) * (- toR x) ^ k) (n - m + 0) + / INR (fact (S (n - m + 0))) * (- toR x) ^ (S (n - m + 0)))%R. rewrite H, <-Nat.add_assoc at 1. rewrite Ropp_plus_distr, Rmult_plus_distr_l. apply f_equal. rewrite <- Ropp_mult_distr_r_reverse. rewrite (Rmult_comm (_ ^ _)), Rmult_assoc. rewrite plus_n_Sm. apply f_equal. replace (- (- toR x) ^ (n - m + 1) * (-1) ^ (n - m))%R with ((- toR x) ^ (n - m + 1) * ((-1) * (-1) ^ (n - m)))%R by ring. change (-1 * (-1) ^ (n - m))%R with ((-1) ^ (S (n - m)))%R . rewrite <- plus_n_Sm, <- plus_n_O. rewrite <- Rpow_mult_distr. now replace (- toR x * -1)%R with (toR x) by ring. Qed. Lemma expn_reduce_correct : forall prec x, F.toX x = Xreal (toR x) -> (0 < toR x)%R -> contains (I.convert (expn_reduce prec x)) (Xreal (exp (- toR x))). Proof. assert (forall prec x, F.toX x = Xreal (toR x) -> (0 < toR x)%R -> F'.le' x c1_8 = true -> contains (I.convert (expn_fast0 prec x)) (Xreal (exp (- toR x)))). { intros prec x Hx1 Hx2 Hx3. apply expn_fast0_correct. { exact Hx1. } split. { now apply Rlt_le. } apply F'.le'_correct in Hx3. revert Hx3. rewrite Hx1. rewrite c1_8_correct. lra. } intros prec x Hx H0. unfold expn_reduce. case_eq (F'.le' x c1_8) ; intros Hx'. { (* . no reduction *) now apply H. } (* . reduction *) clear Hx'. generalize (F.incr_prec prec (Z2P (9 + F.StoZ (F.mag x)))). clear prec. intro prec. generalize (8 + Z2nat (F.StoZ (F.mag x))). intro nb. revert x Hx H0. induction nb ; intros ; simpl. { (* nb = 0 *) case_eq (F'.le' x c1_8) ; intros Hx'. { now apply H. } simpl. unfold c1. rewrite F'.valid_lb_zero. rewrite F'.valid_ub_real by now rewrite F.real_correct, F.fromZ_correct. rewrite F.zero_correct, F.fromZ_correct by easy. split. { apply Rlt_le. apply exp_pos. } simpl. rewrite <- exp_0. apply Rlt_le. apply exp_increasing. rewrite <- Ropp_0. now apply Ropp_lt_contravar. } (* nb > 0 *) case_eq (F'.le' x c1_8) ; intros Hx'. { now apply H. } assert (1 / 256 <= Rabs (F.toR x))%R. { rewrite (Rabs_pos_eq _ (Rlt_le _ _ H0)). revert Hx'. unfold F'.le'. rewrite F'.cmp_correct. rewrite Hx. rewrite c1_8_correct. unfold Rdiv; rewrite Rmult_1_l. simpl. now case Rcompare_spec; [easy..|]; intros H' _; apply Rlt_le. } assert (toR (F.div2 x) = toR x * /2)%R. { unfold toR; rewrite F.div2_correct; [|easy..]. rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy]. rewrite Hx; simpl; lra. } replace (toR x) with (toR (F.div2 x) + toR (F.div2 x))%R. { rewrite Ropp_plus_distr. rewrite exp_plus. change (Xreal (exp (- toR (F.div2 x)) * exp (- toR (F.div2 x)))) with (Xsqr (Xreal (exp (- toR (F.div2 x))))). apply I.sqr_correct. apply IHnb. { unfold F.toR; rewrite F.div2_correct; [|easy..]. rewrite Xdiv_split; simpl; unfold Xinv'; rewrite is_zero_false; [|easy]. now rewrite Hx. } rewrite H2; lra. } rewrite H2. apply sym_eq, double_var. Qed. Theorem exp_fast_correct : forall prec x, contains (I.convert (exp_fast prec x)) (Xexp (F.toX x)). Proof. intros prec x. unfold exp_fast. rewrite F'.cmp_correct, F.zero_correct. case_eq (F.toX x). easy. intros r Hr. (* neg *) simpl. case Rcompare_spec ; intros H. replace r with (Ropp (toR (F.neg x))). apply expn_reduce_correct. unfold toR. now rewrite F'.neg_correct, Hr. unfold toR. rewrite F'.neg_correct, Hr. rewrite <- Ropp_0. now apply Ropp_lt_contravar. unfold toR. rewrite F'.neg_correct, Hr. apply Ropp_involutive. (* zero *) rewrite H, exp_0. now apply I.fromZ_small_correct. (* pos *) generalize (F.incr_prec prec 1). clear prec. intro prec. case_eq (I.invnz prec (expn_reduce prec x)) ; intros. (* pos too big *) unfold c1. rewrite I.bnd_correct. 2: apply I.valid_lb_real ; now rewrite F.fromZ_correct. 2: now apply I.valid_ub_nan. split. rewrite F.fromZ_correct by easy. simpl. rewrite <- exp_0. apply Rlt_le. now apply exp_increasing. now rewrite F'.nan_correct. (* pos fine *) rewrite <- H0. rewrite <- (Ropp_involutive r). rewrite exp_Ropp. replace (Xreal (/ exp (- r))) with (Xinv (Xreal (exp (- toR x)))). apply I.invnz_correct. { intros H1. injection H1. apply Rgt_not_eq. apply exp_pos. } apply expn_reduce_correct. unfold toR. now rewrite Hr. unfold toR. now rewrite Hr. unfold toR. rewrite Hr. unfold Xinv'. simpl. case is_zero_spec ; intro H1. elim Rgt_not_eq with (2 := H1). apply exp_pos. apply refl_equal. Qed. End TranscendentalFloatFast. (* Require Import Interval_specific_ops. Require Import Interval_stdz_carrier. Module F := SpecificFloat StdZRadix2. Module A := TranscendentalFloatFast F. Time Eval vm_compute in (A.exp_fast 50%Z (Float 201%Z (-8)%Z)). Time Eval vm_compute in (A.atan_fast 50%Z (Float 201%Z (-8)%Z)). Time Eval vm_compute in (A.cos_fast 50%Z (Float 201%Z (-8)%Z)). Time Eval vm_compute in (A.tan_fast 50%Z (Float 3619%Z (-8)%Z)). Time Eval vm_compute in (A.sin_fast 50%Z (Float 201%Z (-8)%Z)). Time Eval vm_compute in (A.ln_fast 50%Z (Float 1%Z 20009%Z)). Time Eval vm_compute in (A.ln_fast 50%Z (Float 1125899906842623%Z (-50)%Z)). *) interval-4.11.1/src/Interval/Univariate_sig.v000066400000000000000000000115331470547631300211520ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2013-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals. Require Import Interval. Require Import Xreal. Module Type UnivariateApprox (I : IntervalOps). (* Local Coercion I.convert : I.type >-> interval. *) Parameter T : Type. Definition U := (I.precision * nat (* for degree *) )%type. Parameter approximates : I.type -> T -> (R -> ExtendedR) -> Prop. Parameter approximates_ext : forall f g xi t, (forall x, f x = g x) -> approximates xi t f -> approximates xi t g. Parameter const : I.type -> T. Parameter const_correct : forall (c : I.type) (r : R), contains (I.convert c) (Xreal r) -> forall (X : I.type), approximates X (const c) (fun _ => Xreal r). Parameter dummy : T. Parameter dummy_correct : forall xi f, approximates xi dummy f. Parameter var : T. Parameter var_correct : forall (X : I.type), approximates X var Xreal. Parameter eval : U -> T -> I.type -> I.type -> I.type. Parameter eval_correct : forall u (Y : I.type) t f, approximates Y t f -> I.extension (Xbind f) (eval u t Y). (* Parameter prim : U -> I.type -> I.type -> I.type -> T -> T. Parameter prim_correct : forall u (X X1 Y1 : I.type) tf f f0 x1 y1, contains (I.convert X1) (Xreal x1) -> contains (I.convert Y1) (Xreal y1) -> approximates X tf f -> (forall r : R, f0 r = toR_fun f r) -> approximates X (prim u X X1 Y1 tf) (fun x => match x with | Xnan => Xnan | Xreal r => Xreal (RInt f0 x1 r + y1) end). *) Parameter add : U -> I.type -> T -> T -> T. Parameter add_correct : forall u (Y : I.type) tf tg f g, approximates Y tf f -> approximates Y tg g -> approximates Y (add u Y tf tg) (fun x => Xadd (f x) (g x)). Parameter opp : U -> I.type -> T -> T. Parameter opp_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (opp u Y tf) (fun x => Xneg (f x)). Parameter sub : U -> I.type -> T -> T -> T. Parameter sub_correct : forall u (Y : I.type) tf tg f g, approximates Y tf f -> approximates Y tg g -> approximates Y (sub u Y tf tg) (fun x => Xsub (f x) (g x)). Parameter mul : U -> I.type -> T -> T -> T. Parameter mul_correct : forall u (Y : I.type) tf tg f g, approximates Y tf f -> approximates Y tg g -> approximates Y (mul u Y tf tg) (fun x => Xmul (f x) (g x)). Parameter abs : U -> I.type -> T -> T. Parameter abs_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (abs u Y tf) (fun x => Xabs (f x)). Parameter div : U -> I.type -> T -> T -> T. Parameter div_correct : forall u (Y : I.type) tf tg f g, approximates Y tf f -> approximates Y tg g -> approximates Y (div u Y tf tg) (fun x => Xdiv (f x) (g x)). Parameter inv : U -> I.type -> T -> T. Parameter inv_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (inv u Y tf) (fun x => Xinv (f x)). Parameter sqrt : U -> I.type -> T -> T. Parameter sqrt_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (sqrt u Y tf) (fun x => Xsqrt (f x)). Parameter exp : U -> I.type -> T -> T. Parameter exp_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (exp u Y tf) (fun x => Xexp (f x)). Parameter ln : U -> I.type -> T -> T. Parameter ln_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (ln u Y tf) (fun x => Xln (f x)). Parameter cos : U -> I.type -> T -> T. Parameter cos_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (cos u Y tf) (fun x => Xcos (f x)). Parameter sin : U -> I.type -> T -> T. Parameter sin_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (sin u Y tf) (fun x => Xsin (f x)). Parameter tan : U -> I.type -> T -> T. Parameter tan_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (tan u Y tf) (fun x => Xtan (f x)). Parameter atan : U -> I.type -> T -> T. Parameter atan_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (atan u Y tf) (fun x => Xatan (f x)). End UnivariateApprox. interval-4.11.1/src/Language/000077500000000000000000000000001470547631300157465ustar00rootroot00000000000000interval-4.11.1/src/Language/Lang_expr.v000066400000000000000000003527771470547631300201010ustar00rootroot00000000000000From Coq Require Import PrimInt63 Sint63 Floats PArray. From Coq Require Import Bool List Reals Lia Lra. From Flocq Require Import Core PrimFloat BinarySingleNaN Operations. Require Generic_proof. Local Open Scope R_scope. (** Signed computer integers: operations and constants **) Definition Zcmod a b := let c := Z.quot b 2 in ((a + c) mod b - c)%Z. Infix "cmod" := Zcmod (at level 40, no associativity) : Z_scope. Lemma mod_mul_add_mod : forall a b m n c, (b <> 0)%Z -> (exists k, b = (k * c)%Z) -> ((a mod b * m + n) mod c = (a * m + n) mod c)%Z. Proof. intros a b m n c Ib_neq_0 [k Heq_b]. generalize (Zdiv.Z_div_mod_eq_full a b). intros Haux. rewrite Z.add_comm in Haux. apply Z.sub_move_r in Haux. rewrite <-Haux. clear Haux. rewrite Heq_b at 1. rewrite Z.mul_sub_distr_r, <-Z.add_sub_swap. unfold Z.sub. rewrite (Z.mul_comm k c), <-!Z.mul_assoc, (Z.mul_comm c), <-Z.mul_opp_l. apply Z.mod_add. lia. Qed. Corollary cmod_mul_add_mod : forall a b m n c, (b <> 0)%Z -> (exists k, b = (k * c)%Z) -> ((a cmod b * m + n) mod c = (a * m + n) mod c)%Z. Proof. intros a b m n c. unfold Zcmod. rewrite Z.mul_sub_distr_r. replace (a * m)%Z with ((a + Z.quot b 2) * m - (Z.quot b 2) * m)%Z by ring. unfold Z.sub. rewrite <-2Z.add_assoc. apply mod_mul_add_mod. Qed. Corollary mod_add_mod : forall a b n c, (b <> 0)%Z -> (exists k, b = (k * c)%Z) -> ((a mod b + n) mod c = (a + n) mod c)%Z. Proof. intros a b n c. rewrite <-(Z.mul_1_r (a mod b)). rewrite <-(Z.mul_1_r a) at 2. apply mod_mul_add_mod. Qed. Corollary mod_mul_mod : forall a b n c, (b <> 0)%Z -> (exists k, b = (k * c)%Z) -> ((a mod b * n) mod c = (a * n) mod c)%Z. Proof. intros a b n c. rewrite <-(Z.add_0_r (a mod b * n)). rewrite <-(Z.add_0_r (a * n)). apply mod_mul_add_mod. Qed. Corollary cmod_add_mod : forall a b n c, (b <> 0)%Z -> (exists k, b = (k * c)%Z) -> ((a cmod b + n) mod c = (a + n) mod c)%Z. Proof. intros a b n c. rewrite <-(Z.mul_1_r (a cmod b)). rewrite <-(Z.mul_1_r a) at 2. apply cmod_mul_add_mod. Qed. Corollary cmod_mul_mod : forall a b n c, (b <> 0)%Z -> (exists k, b = (k * c)%Z) -> ((a cmod b * n) mod c = (a * n) mod c)%Z. Proof. intros a b n c. rewrite <-(Z.add_0_r (a cmod b * n)). rewrite <-(Z.add_0_r (a * n)). apply cmod_mul_add_mod. Qed. Lemma cmod_cmod : forall a b, (0 < b)%Z -> (a cmod b)%Z = Sint63.cmod a b. Proof. intros a b H. unfold Zcmod, Sint63.cmod. now rewrite Zquot.Zquot_Zdiv_pos; [| lia |]. Qed. Lemma cmod_bounded : forall a b, (0 < b)%Z -> (- (b / 2) <= a cmod b <= b - b / 2 - 1)%Z. Proof. intros a b H0. rewrite cmod_cmod by assumption. generalize (Z.mod_pos_bound (a + b / 2) b H0). unfold Sint63.cmod. lia. Qed. Module Type Size. Parameter bits : positive. End Size. Module Size32 <: Size. Definition bits := 32%positive. End Size32. Module Size63 <: Size. Definition bits := 63%positive. End Size63. Module Size64 <: Size. Definition bits := 64%positive. End Size64. Module SI (S : Size). Definition bits := S.bits. Definition N := Z.pow_pos 2 bits. Definition norm n := Zcmod n N. Definition in_bounds n := (- (N/2) <= n <= N/2 - 1)%Z. Lemma in_bounds_norm : forall n, in_bounds (norm n). Proof. intros n. unfold in_bounds, norm. replace (N / 2)%Z with (N - N / 2)%Z at 2. { apply cmod_bounded. now apply Zpower_pos_gt_0. } unfold N. rewrite Z.pow_pos_fold. replace (Z.pos bits) with (Z.pos bits - 1 + 1)%Z at 1 by ring. rewrite Z.pow_add_r ; [|lia|easy]. rewrite Z.pow_sub_r ; [|easy|lia]. change (2 ^ 1)%Z with 2%Z. ring. Qed. Lemma norm_in_bounds : forall n, in_bounds n -> norm n = n. Proof. intros n. unfold in_bounds, norm. rewrite cmod_cmod by now apply Zpower_pos_gt_0. intros H. apply Sint63.cmod_small. lia. Qed. Definition add n1 n2 := norm (n1 + n2)%Z. Definition sub n1 n2 := norm (n1 - n2)%Z. Definition mul n1 n2 := norm (n1 * n2)%Z. Definition div n1 n2 := norm (n1 / n2)%Z. (* Not expected to be useful for now *) Definition quot n1 n2 := norm (Z.quot n1 n2). End SI. Module Int32 := SI Size32. Module Int63 := SI Size63. Module Int64 := SI Size64. (** Real numbers: operations and constants **) Notation Rpow2 := (bpow radix2). Module Type Format. Parameter prec : positive. Parameter emax : Z. End Format. Module Format64 <: Format. Definition prec := 53%positive. Definition emax := 1024%Z. End Format64. Module RoundedR (F : Format). Definition prec := Z.pos F.prec. Definition emax := F.emax. Definition emin := (3 - prec - emax)%Z. Definition Rnd m := (round radix2 (FLT_exp emin prec) (round_mode m)). Delimit Scope rnd_scope with rnd. Notation rnd := (Rnd mode_NE). Notation "x + y" := (rnd (x + y)) : rnd_scope. Notation "x - y" := (rnd (x - y)) : rnd_scope. Notation "x * y" := (rnd (x * y)) : rnd_scope. Notation "x / y" := (rnd (x / y)) : rnd_scope. Definition fma {md} x y z := Rnd md (x * y + z). Definition sqrt {md} x := Rnd md (sqrt x). Definition ldexp {md} x e := Rnd md (x * Rpow2 e). Definition nearbyint {md} x := round radix2 (FIX_exp 0) (round_mode md) x. Notation trunc := (@nearbyint mode_ZR). Lemma nearbyint_IZR : forall md x, @nearbyint md x = IZR ((round_mode md) x). Proof. unfold nearbyint, round, F2R, scaled_mantissa. simpl. intros md x. now rewrite 2Rmult_1_r. Qed. Definition maxval := IZR (radix2 ^ prec - 1)%Z * Rpow2 (emax - prec)%Z. Definition minval := Rpow2 emin. Lemma maxval_lt : maxval < Rpow2 emax. Proof. unfold maxval. replace emax with (prec + (emax - prec))%Z at 2 by (* lia *) now rewrite Z.add_comm, Z.sub_add. rewrite bpow_plus. apply Rmult_lt_compat_r; [apply bpow_gt_0 |]. rewrite minus_IZR. rewrite IZR_Zpower by easy. apply (Rplus_lt_reg_r 1). unfold Rminus. rewrite Rplus_assoc. rewrite Rplus_opp_l. rewrite Rplus_0_r. apply Rlt_plus_1. Qed. Lemma minval_gt : minval > 0. Proof. apply bpow_gt_0. Qed. End RoundedR. Module Rrnd := RoundedR Format64. (** On primitive arrays **) Definition float_max x y := if ltb x y then y else x. Definition float_min x y := if ltb x y then x else y. Definition finite_array a := snd (N.iter (Z.to_N (Uint63.to_Z (PArray.length a))) (fun '(i, b) => (Z.succ i, b && is_finite_SF (Prim2SF (get a (of_Z i))))) (0%Z, true)). Definition float_array_max_partial a i := snd (N.iter (Z.to_N i) (fun '(n, x) => (Z.succ n, float_max x (PArray.get a (Uint63.of_Z n)))) (0%Z, neg_infinity)). Definition float_array_min_partial a i := snd (N.iter (Z.to_N i) (fun '(n, x) => (Z.succ n, float_min x (PArray.get a (Uint63.of_Z n)))) (0%Z, infinity)). Definition float_array_max a := float_array_max_partial a (Uint63.to_Z (PArray.length a)). Definition float_array_min a := float_array_min_partial a (Uint63.to_Z (PArray.length a)). Lemma finite_array_correct : forall a, finite_array a = true -> forall i, (Uint63.to_Z i < Uint63.to_Z (PArray.length a))%Z -> is_finite (Prim2B a.[i]) = true. Proof. intros a fina_a i bnd_i. unfold finite_array in fina_a. set (P := fun n '(i, b) => (Z.of_N n <= Uint63.to_Z (PArray.length a))%Z -> b = true -> i = Z.of_N n /\ forall j, (0 <= j < Z.of_N n)%Z -> is_finite (Prim2B a.[of_Z j]) = true). set (f := fun '(i, b) => (Z.succ i, b && is_finite_SF (Prim2SF a.[of_Z i]))). cut (forall n, P n (N.iter n f (0%Z, true))). 2: { apply N.iter_ind; [intros _ _; split; [easy | lia] |]. intros n [i' b]. simpl. intros IHn H1 H2. destruct IHn as [IHn_1 IHn_2]; [lia | now apply andb_prop in H2 |]. split; [lia |]. intros j Hj'. rewrite IHn_1 in H2. rewrite <-B2SF_Prim2B, is_finite_SF_B2SF in H2. assert (Hj : (0 <= j < Z.of_N n)%Z \/ j = Z.of_N n) by lia. clear Hj'. now destruct Hj as [Hj | ->]; [now apply IHn_2 | now apply andb_prop in H2]. } intros Haux. specialize (Haux (Z.to_N (Uint63.to_Z (PArray.length a)))). unfold P in Haux. revert fina_a Haux. destruct N.iter as [i' b]. simpl. intros -> He. rewrite <-(Uint63.of_to_Z i). generalize (Uint63.to_Z_bounded (PArray.length a)). intros Hy. apply He; [lia | easy |]. generalize (Uint63.to_Z_bounded i). lia. Qed. Lemma float_array_max_partial_correct : forall a, finite_array a = true -> forall i, (Uint63.to_Z i <= Uint63.to_Z (PArray.length a))%Z -> let f := float_array_max_partial a (Uint63.to_Z i) in ((0 < Uint63.to_Z i)%Z -> is_finite (Prim2B f) = true) /\ forall j, (0 <= Uint63.to_Z j < Uint63.to_Z i)%Z -> PrimFloat.leb a.[j] f = true. Proof. intros a fina_a i bnd_i. generalize (Uint63.to_Z_bounded i). intros Hi. destruct (Uint63.to_Z i); [split; lia | | lia]. unfold float_array_max_partial. simpl. set (P := fun p '(n, x) => (Z.pos p <= Uint63.to_Z (PArray.length a))%Z -> n = Z.pos p /\ is_finite (Prim2B x) = true /\ forall j, (0 <= Uint63.to_Z j < n)%Z -> PrimFloat.leb a.[j] x = true). set (f := fun '(n, x) => (Z.succ n, float_max x a.[of_Z n])). assert (non_empty_a : (0 < Uint63.to_Z (PArray.length a))%Z) by lia. revert bnd_i. cut (forall p', P p' (Pos.iter f (0%Z, neg_infinity) p')). 2: { apply Pos.iter_ind. { unfold P, f, float_max. simpl. intros _. split; [easy |]. rewrite ltb_spec. cbn -[Uint63.to_Z]. unfold SFltb, SFcompare. generalize (finite_array_correct a fina_a 0 non_empty_a). intros fin_a_0. generalize fin_a_0. rewrite <-is_finite_SF_B2SF, B2SF_Prim2B. split; [now destruct Prim2SF; [| destruct s | |] |]. intros j bnd_j. rewrite <-(Uint63.of_to_Z j). replace (Uint63.to_Z j) with 0%Z by lia. assert (a_0_leb_self : PrimFloat.leb a.[0] a.[0] = true). { now rewrite leb_equiv, Bleb_correct, Rle_bool_true; [| apply Rle_refl | ..]. } revert fin_a_1. now destruct Prim2SF; [| destruct s | |]; clear -a_0_leb_self. (* That "clear" instruction is necessary, otherwise it loops indefinitely for some reason *) } intros p' [n x]. unfold P, f, float_max. simpl. intros IHp' bnd_p'. rewrite Pos2Z.inj_succ in bnd_p' |- *. split; [lia |]. destruct IHp' as [eq_n [fin_x a_j_le_x']]; [lia |]. rewrite ltb_equiv. assert (fin_a_n : is_finite (Prim2B a.[of_Z n]) = true). { apply finite_array_correct; [easy |]. generalize (Uint63.to_Z_bounded (PArray.length a)). intros Haux. rewrite Uint63.of_Z_spec, Z.mod_small; lia. } split. { now rewrite (Bltb_correct prec emax (Prim2B x) (Prim2B a.[of_Z n])); [destruct Rlt_bool | |]. } intros j [bnd_j_0 bnd_j_1]. apply Z.lt_succ_r, Zle_lt_or_eq in bnd_j_1. destruct bnd_j_1 as [bnd_j_1 | bnd_j_1]. - rewrite Bltb_correct by easy. assert (fin_a_j : is_finite (Prim2B a.[j]) = true) by (now apply finite_array_correct; [| lia]). assert (a_j_le_x : (a.[j] <=? x)%float = true) by (now apply a_j_le_x'; split). clear a_j_le_x'. case Rlt_bool_spec; intros comp_x; [| apply a_j_le_x]. rewrite leb_equiv, Bleb_correct in a_j_le_x |- * by easy. apply Rle_bool_true. destruct (Rle_or_lt (B2R (Prim2B a.[j])) (B2R (Prim2B x))) as [Haux | Haux]; [lra |]. apply Rle_bool_false in Haux. rewrite a_j_le_x in Haux. lia. (* again, "easy" does not terminate *) - rewrite <-(Uint63.of_to_Z j), bnd_j_1. rewrite Bltb_correct by easy. case Rlt_bool_spec; intros comp_x; rewrite leb_equiv, Bleb_correct by easy; apply Rle_bool_true; [apply Rle_refl | easy]. } intros Haux. destruct Uint63.to_Z as [| p' |] eqn:Hlen; [lia | | lia]. clear non_empty_a. intros comp_p_p'. generalize Haux. intros Haux'. specialize (Haux p). specialize (Haux' p'). unfold P in Haux. revert Haux. destruct (Pos.iter _ _ p) as [p'' x] eqn:H. simpl. intros H'. apply H' in comp_p_p'. destruct comp_p_p' as [-> [fin_x prop_x]]. now split. Qed. Lemma float_array_min_partial_correct : forall a, finite_array a = true -> forall i, (Uint63.to_Z i <= Uint63.to_Z (PArray.length a))%Z -> let f := float_array_min_partial a (Uint63.to_Z i) in ((0 < Uint63.to_Z i)%Z -> is_finite (Prim2B f) = true) /\ forall j, (0 <= Uint63.to_Z j < Uint63.to_Z i)%Z -> PrimFloat.leb f a.[j] = true. Proof. intros a fina_a i bnd_i. generalize (Uint63.to_Z_bounded i). intros Hi. destruct (Uint63.to_Z i); [split; lia | | lia]. unfold float_array_min_partial. simpl. set (P := fun p '(n, x) => (Z.pos p <= Uint63.to_Z (PArray.length a))%Z -> n = Z.pos p /\ is_finite (Prim2B x) = true /\ forall j, (0 <= Uint63.to_Z j < n)%Z -> PrimFloat.leb x a.[j] = true). set (f := fun '(n, x) => (Z.succ n, float_min x a.[of_Z n])). assert (non_empty_a : (0 < Uint63.to_Z (PArray.length a))%Z) by lia. revert bnd_i. cut (forall p', P p' (Pos.iter f (0%Z, infinity) p')). 2: { apply Pos.iter_ind. { unfold P, f, float_min. simpl. intros _. split; [easy |]. rewrite ltb_spec. cbn -[Uint63.to_Z]. unfold SFltb, SFcompare. generalize (finite_array_correct a fina_a 0 non_empty_a). intros fin_a_0. generalize fin_a_0. rewrite <-is_finite_SF_B2SF, B2SF_Prim2B. split; [now destruct Prim2SF; [| destruct s | |] |]. intros j bnd_j. rewrite <-(Uint63.of_to_Z j). replace (Uint63.to_Z j) with 0%Z by lia. assert (a_0_leb_self : PrimFloat.leb a.[0] a.[0] = true). { now rewrite leb_equiv, Bleb_correct, Rle_bool_true; [| apply Rle_refl | ..]. } revert fin_a_1. now destruct Prim2SF; [| destruct s | |]; clear -a_0_leb_self. } intros p' [n x]. unfold P, f, float_min. simpl. intros IHp' bnd_p'. rewrite Pos2Z.inj_succ in bnd_p' |- *. split; [lia |]. destruct IHp' as [eq_n [fin_x x_le_a_j']]; [lia |]. rewrite ltb_equiv. assert (fin_a_n : is_finite (Prim2B a.[of_Z n]) = true). { apply finite_array_correct; [easy |]. generalize (Uint63.to_Z_bounded (PArray.length a)). intros Haux. rewrite Uint63.of_Z_spec, Z.mod_small; lia. } split. { now rewrite (Bltb_correct prec emax (Prim2B x) (Prim2B a.[of_Z n])); [destruct Rlt_bool | |]. } intros j [bnd_j_0 bnd_j_1]. apply Z.lt_succ_r, Zle_lt_or_eq in bnd_j_1. destruct bnd_j_1 as [bnd_j_1 | bnd_j_1]. - rewrite Bltb_correct by easy. assert (fin_a_j : is_finite (Prim2B a.[j]) = true) by (now apply finite_array_correct; [| lia]). assert (x_le_a_j : (x <=? a.[j])%float = true) by (now apply x_le_a_j'; split). clear x_le_a_j'. case Rlt_bool_spec; intros comp_x; [apply x_le_a_j |]. rewrite leb_equiv, Bleb_correct in x_le_a_j |- * by easy. apply Rle_bool_true. destruct (Rle_or_lt (B2R (Prim2B x)) (B2R (Prim2B a.[j]))) as [Haux | Haux]; [lra |]. apply Rle_bool_false in Haux. rewrite x_le_a_j in Haux. lia. (* again, "easy" does not terminate *) - rewrite <-(Uint63.of_to_Z j), bnd_j_1. rewrite Bltb_correct by easy. case Rlt_bool_spec; intros comp_x; rewrite leb_equiv, Bleb_correct by easy; apply Rle_bool_true; [lra | apply Rle_refl]. } intros Haux. destruct Uint63.to_Z as [| p' |] eqn:Hlen; [lia | | lia]. clear non_empty_a. intros comp_p_p'. generalize Haux. intros Haux'. specialize (Haux p). specialize (Haux' p'). unfold P in Haux. revert Haux. destruct (Pos.iter _ _ p) as [p'' x] eqn:H. simpl. intros H'. apply H' in comp_p_p'. destruct comp_p_p' as [-> [fin_x prop_x]]. now split. Qed. (** Floating point numbers: operations and constants **) Definition HPrec_gt_0 : Prec_gt_0 Rrnd.prec := Hprec. Definition HPrec_lt_emax : Prec_lt_emax Rrnd.prec Rrnd.emax := Hmax. Definition binnorm md m e := @binary_normalize _ _ HPrec_gt_0 HPrec_lt_emax md m e false. Definition FPadd md x y := @Bplus _ _ HPrec_gt_0 HPrec_lt_emax md x y. Definition FPsub md x y := @Bminus _ _ HPrec_gt_0 HPrec_lt_emax md x y. Definition FPmul md x y := @Bmult _ _ HPrec_gt_0 HPrec_lt_emax md x y. Definition FPdiv md x y := @Bdiv _ _ HPrec_gt_0 HPrec_lt_emax md x y. Definition FPfma md x y z := @Bfma _ _ HPrec_gt_0 HPrec_lt_emax md x y z. Definition FPnearbyint md x := @Bnearbyint _ _ HPrec_lt_emax md x. Definition FPtrunc x := @Btrunc Rrnd.prec Rrnd.emax x. Definition FPldexp md x e := @Bldexp _ _ HPrec_gt_0 HPrec_lt_emax md x e. Definition FPsqrt md x := @Bsqrt _ _ HPrec_gt_0 HPrec_lt_emax md x. (** Typed arithmetic expression trees **) (* 1. Types and operations on them *) Inductive ExprType := Integer | BinFloat (*| Pair: ExprType -> ExprType -> ExprType *). (* 1.0. Evaluation as primitive types *) Definition evalExprTypePrim T := match T with | Integer => PrimInt63.int | BinFloat => PrimFloat.float end. Fixpoint evalExprTypePrim_list Tl : Set := match Tl with | nil => unit | T :: Tl' => evalExprTypePrim T * evalExprTypePrim_list Tl' end. Fixpoint nthExprTypePrim {Tl DefaultT} n (l : evalExprTypePrim_list Tl) (default : evalExprTypePrim DefaultT) := match n with | O => match Tl return evalExprTypePrim_list Tl -> evalExprTypePrim (nth O Tl DefaultT) with | nil => fun l' => default | T :: Tl' => fun l' => fst l' end l | S n' => match Tl return evalExprTypePrim_list Tl -> evalExprTypePrim (nth (S n') Tl DefaultT) with | nil => fun l' => default | T :: Tl' => fun l' => nthExprTypePrim n' (snd l') default end l end. (* Why is it not defined the other way around? *) (* 1.1. Evaluation as computer types *) Definition evalExprTypeFloat T := match T with | Integer => Z | BinFloat => binary_float Rrnd.prec Rrnd.emax end. Fixpoint evalExprTypeFloat_list Tl : Set := match Tl with | nil => unit | T :: Tl' => evalExprTypeFloat T * evalExprTypeFloat_list Tl' end. Fixpoint nthExprTypeFloat {Tl DefaultT} n (l : evalExprTypeFloat_list Tl) (default : evalExprTypeFloat DefaultT) := match n with | O => match Tl return evalExprTypeFloat_list Tl -> evalExprTypeFloat (nth O Tl DefaultT) with | nil => fun l' => default | T :: Tl' => match T with | Integer => fun l' => Int32.norm (fst l') | BinFloat => fun l' => fst l' end end l | S n' => match Tl return evalExprTypeFloat_list Tl -> evalExprTypeFloat (nth (S n') Tl DefaultT) with | nil => fun l' => default | T :: Tl' => fun l' => nthExprTypeFloat n' (snd l') default end l end. (* 1.2. Evaluation as math types *) Definition evalExprTypeRounded T := match T with | Integer => Z | BinFloat => R end. Fixpoint evalExprTypeRounded_list Tl : Set := match Tl with | nil => unit | T :: Tl' => evalExprTypeRounded T * evalExprTypeRounded_list Tl' end. Fixpoint evalExprTypeRounded_fun (Tl : list ExprType) := match Tl with | nil => Prop | T :: Tl' => evalExprTypeRounded T -> evalExprTypeRounded_fun Tl' end. Fixpoint uncurrify {Tl} := match Tl return evalExprTypeRounded_fun Tl -> evalExprTypeRounded_list Tl -> Prop with | nil => fun f l => f | _ :: Tl' => fun f l => uncurrify (f (fst l)) (snd l) end. Fixpoint nthExprTypeRounded {Tl DefaultT} n (l : evalExprTypeRounded_list Tl) (default : evalExprTypeRounded DefaultT) := match n with | O => match Tl return evalExprTypeRounded_list Tl -> evalExprTypeRounded (nth O Tl DefaultT) with | nil => fun l' => default | T :: Tl' => fun l' => fst l' end l | S n' => match Tl return evalExprTypeRounded_list Tl -> evalExprTypeRounded (nth (S n') Tl DefaultT) with | nil => fun l' => default | T :: Tl' => fun l' => nthExprTypeRounded n' (snd l') default end l end. (* 1.3. Evaluation as real numbers *) Fixpoint evalExprTypeReal_list (Tl : list ExprType) : Set := match Tl with | nil => unit | _ :: Tl' => R * evalExprTypeReal_list Tl' end. (* Fixpoint evalExprTypeReal_fun (Tl : list ExprType) := match Tl with | nil => Prop | _ :: Tl' => R -> evalExprTypeReal_fun Tl' end. *) Fixpoint nthExprTypeReal {Tl} n (l : evalExprTypeReal_list Tl) (default : R) := match n with | O => match Tl return evalExprTypeReal_list Tl -> _ with | nil => fun l' => default | T :: Tl' => fun l' => fst l' end l | S n' => match Tl return evalExprTypeReal_list Tl -> _ with | nil => fun l' => default | T :: Tl' => fun l' => nthExprTypeReal n' (snd l') default end l end. (* Conversions between the different evaluation types *) Definition P2C {T} : evalExprTypePrim T -> evalExprTypeFloat T := match T with | Integer => fun x => Sint63.to_Z x | BinFloat => fun x => Prim2B x end. Fixpoint P2C_list {Tl} : evalExprTypePrim_list Tl -> evalExprTypeFloat_list Tl := match Tl with | nil => fun l => tt | _ :: _ => fun l => (P2C (fst l), P2C_list (snd l)) end. Definition C2M {T} : evalExprTypeFloat T -> evalExprTypeRounded T := match T with | Integer => fun x => x | BinFloat => fun x => B2R x end. Fixpoint C2M_list {Tl} : evalExprTypeFloat_list Tl -> evalExprTypeRounded_list Tl := match Tl with | nil => fun l => tt | _ :: _ => fun l => (C2M (fst l), C2M_list (snd l)) end. Definition M2R {T} : evalExprTypeRounded T -> R := match T with | Integer => fun x => IZR x | BinFloat => fun x => x end. Fixpoint M2R_list {Tl} : evalExprTypeRounded_list Tl -> evalExprTypeReal_list Tl := match Tl with | nil => fun l => tt | _ :: _ => fun l => (M2R (fst l), M2R_list (snd l)) end. Definition P2M {T} : evalExprTypePrim T -> evalExprTypeRounded T := match T with | Integer => fun x => Sint63.to_Z x | BinFloat => fun x => SF2R radix2 (Prim2SF x) end. Fixpoint P2M_list {Tl} : evalExprTypePrim_list Tl -> evalExprTypeRounded_list Tl := match Tl with | nil => fun l => tt | _ :: _ => fun l => (P2M (fst l), P2M_list (snd l)) end. (* 1.4. Binary arithmetic operations *) Inductive ArithOp := ADD | SUB | MUL | DIV. Definition PIOpToFunction OP := match OP with | ADD => PrimInt63.add | SUB => PrimInt63.sub | MUL => PrimInt63.mul | DIV => PrimInt63.divs end. Definition PFOpToFunction OP := match OP with | ADD => PrimFloat.add | SUB => PrimFloat.sub | MUL => PrimFloat.mul | DIV => PrimFloat.div end. Definition SIOpToFunction OP := match OP with | ADD => Int32.add | SUB => Int32.sub | MUL => Int32.mul | DIV => Int32.quot end. Definition FPOpToFunction OP := match OP with | ADD => FPadd | SUB => FPsub | MUL => FPmul | DIV => FPdiv end. Definition ZOpToFunction OP := match OP with | ADD => Z.add | SUB => Z.sub | MUL => Z.mul | DIV => Z.quot end. Definition ROpToFunction OP := match OP with | ADD => Rplus | SUB => Rminus | MUL => Rmult | DIV => Rdiv end. Definition RrndOpToFunction OP md x y := match OP with | ADD => @Rrnd.Rnd md (x + y) | SUB => @Rrnd.Rnd md (x - y) | MUL => @Rrnd.Rnd md (x * y) | DIV => @Rrnd.Rnd md (x / y) end. (* 3. Arithmetic expressions as trees with dependent types *) (* 3.1. Definition of said trees *) Inductive ArithExpr : list ExprType -> ExprType -> Type := | Int: forall {Tl}, Z -> ArithExpr Tl Integer | BinFl: forall {Tl}, PrimFloat.float -> ArithExpr Tl BinFloat | Var: forall {Tl} n, ArithExpr Tl (nth n Tl Integer) (* forall {Tl T} n, T = (nth n Tl Integer) -> ArithExpr Tl T *) | Op: forall {Tl T}, ArithOp -> ArithExpr Tl T -> ArithExpr Tl T -> ArithExpr Tl T | OpExact: forall {Tl}, ArithOp -> ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat | Fma: forall {Tl}, ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat | FmaExact: forall {Tl}, ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat | Nearbyint: forall {Tl}, ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat | FastNearbyint: forall {Tl}, ArithExpr Tl BinFloat -> ArithExpr Tl BinFloat | FastNearbyintToInt: forall {Tl}, ArithExpr Tl BinFloat -> ArithExpr Tl Integer | TruncToInt: forall {Tl}, ArithExpr Tl BinFloat -> ArithExpr Tl Integer | FloatInj: forall {Tl}, ArithExpr Tl Integer -> ArithExpr Tl BinFloat (*| Ldexp: forall {Tl}, Z -> ArithExpr Tl BinFloat -> ArithExpr Tl Integer -> ArithExpr Tl BinFloat *) | Sqrt: forall {Tl T}, ArithExpr Tl T -> ArithExpr Tl T | Let: forall {Tl T1 T2}, ArithExpr Tl T1 -> ArithExpr (T1 :: Tl) T2 -> ArithExpr Tl T2 | ArrayAcc: forall {Tl}, array PrimFloat.float -> ArithExpr Tl Integer -> ArithExpr Tl BinFloat | Assert: forall {Tl T}, (evalExprTypeRounded T -> evalExprTypeRounded_fun Tl) -> ArithExpr Tl T -> ArithExpr Tl T | Postcond: forall {Tl T}, (evalExprTypeRounded T -> evalExprTypeRounded_fun Tl) -> ArithExpr Tl T -> ArithExpr Tl T. Arguments Op {Tl} & {T} OP t1 t2. Arguments OpExact {Tl} & OP t1 t2. Arguments Fma {Tl} & t1 t2 t3. Arguments FmaExact {Tl} & t1 t2 t3. Arguments Nearbyint {Tl} & t. Arguments FastNearbyint {Tl} & t. Arguments FastNearbyintToInt {Tl} & t. Arguments TruncToInt {Tl} & t. Arguments FloatInj {Tl} & t. (* Arguments Ldexp {Tl} & n t1 t2. *) Arguments Sqrt {Tl} & {T} t. Arguments Let {Tl} & {T1 T2} t1 t2. Arguments ArrayAcc {Tl} & a t. Arguments Assert {Tl} & {T} P t. Arguments Postcond {Tl} & {T} P t. Set Asymmetric Patterns. (* 3.2. Definition of evaluation functions *) Fixpoint evalPrim {Tl T} (t: ArithExpr Tl T) {struct t} : evalExprTypePrim_list Tl -> evalExprTypePrim T := match t (* in ArithExpr Tl'' T'' return evalExprTypePrim_list Tl'' -> evalExprTypePrim T'' *) with (* uncomment for debugging *) | Int _ p => fun l => Uint63.of_Z p | BinFl _ x => fun l => x | Var _ n => fun l => @nthExprTypePrim _ Integer n l (Uint63.of_Z 0) | Op Tl' T' OP t1 t2 => fun l => match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> evalExprTypePrim T' with | Integer => fun t1' t2' => PIOpToFunction OP (evalPrim t1' l) (evalPrim t2' l) | BinFloat => fun t1' t2' => PFOpToFunction OP (evalPrim t1' l) (evalPrim t2' l) end t1 t2 | OpExact _ OP t1 t2 => fun l => PFOpToFunction OP (evalPrim t1 l) (evalPrim t2 l) | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => fun l => B2Prim (FPfma mode_NE (Prim2B (evalPrim t1 l)) (Prim2B (evalPrim t2 l)) (Prim2B (evalPrim t3 l))) | Nearbyint _ t => fun l => B2Prim (FPnearbyint mode_NE (Prim2B (evalPrim t l))) | FastNearbyint _ t => fun l => (evalPrim t l + 0x1.8p52 - 0x1.8p52)%float | FastNearbyintToInt _ t => fun l => (normfr_mantissa (fst (frshiftexp (evalPrim t l + 0x1.8p52)%float)) - 6755399441055744)%uint63 (*| Nearbyint _ t => fun l => Primitive_ops.PrimitiveFloat.nearbyint (PrimFloat.of_uint63 (Uint63.of_Z 0)) Basic.rnd_NE (evalPrim t l) *) | TruncToInt _ t => fun l => Uint63.of_Z (FPtrunc (Prim2B (evalPrim t l))) | FloatInj _ t => fun l => let x := evalPrim t l in let absx := Sint63.abs x in let f := PrimFloat.of_uint63 absx in if (0 <=? x)%sint63 then f else PrimFloat.opp f (*| FloatInj _ t => fun l => let x := evalPrim t l in let aux1 := PrimInt63.land 0x4000000000000000%uint63 x in let shift := 0x3e%uint63 in let sign := PrimInt63.lsr aux1 shift in let aux2 := PrimInt63.asr aux1 shift in let f := PrimFloat.of_uint63 (PrimInt63.add (PrimInt63.lxor x aux2) sign) in if PrimInt63.eqb sign 0x1%uint63 then f else PrimFloat.opp f *) (*| Ldexp _ _ t1 t2 => fun l => PrimFloat.ldshiftexp (evalPrim t1 l) (Uint63.add (evalPrim t2 l) 2101%uint63) ID := 1 *) | Sqrt Tl' T' t => fun l => match T' return ArithExpr Tl' T' -> evalExprTypePrim T' with | Integer => fun t' => Uint63.sqrt (evalPrim t' l) | BinFloat => fun t' => PrimFloat.sqrt (evalPrim t' l) end t | Let _ _ _ t1 t2 => fun l => let x := evalPrim t1 l in evalPrim t2 (x, l) | ArrayAcc _ a t => fun l => get a (evalPrim t l) | Assert _ _ _ t | Postcond _ _ _ t => fun l => evalPrim t l end. Fixpoint evalFloat {Tl T} (t: ArithExpr Tl T) {struct t} : evalExprTypeFloat_list Tl -> mode -> evalExprTypeFloat T := match t in ArithExpr Tl'' T'' return evalExprTypeFloat_list Tl'' -> mode -> evalExprTypeFloat T'' with | Int _ p => fun l md => Int32.norm p | BinFl _ x => fun l md => Prim2B x | Var _ n => fun l md => @nthExprTypeFloat _ Integer n l 0%Z | Op Tl' T' OP t1 t2 => fun l md => match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> evalExprTypeFloat T' with | Integer => fun t1' t2' => SIOpToFunction OP (evalFloat t1' l md) (evalFloat t2' l md) | BinFloat => fun t1' t2' => FPOpToFunction OP md (evalFloat t1' l md) (evalFloat t2' l md) end t1 t2 | OpExact _ OP t1 t2 => fun l md => FPOpToFunction OP md (evalFloat t1 l md) (evalFloat t2 l md) | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => fun l md => FPfma md (evalFloat t1 l md) (evalFloat t2 l md) (evalFloat t3 l md) | Nearbyint _ t => fun l md => FPnearbyint mode_NE (evalFloat t l md) | FastNearbyint _ t => fun l md => FPsub mode_NE (FPadd mode_NE (evalFloat t l md) (Prim2B 0x1.8p52%float)) (Prim2B 0x1.8p52%float) | FastNearbyintToInt _ t => fun l md => Int32.norm (FPtrunc (FPsub mode_NE (FPadd mode_NE (evalFloat t l md) (Prim2B 0x1.8p52%float)) (Prim2B 0x1.8p52%float))) | TruncToInt _ t => fun l md => Int32.norm (FPtrunc (evalFloat t l md)) | FloatInj _ t => fun l md => binnorm mode_NE (evalFloat t l md) 0 (*| Ldexp _ _ t1 t2 => fun l md => FPldexp md (evalFloat t1 l md) (evalFloat t2 l md) *) | Sqrt Tl' T' t => fun l md => match T' return ArithExpr Tl' T' -> evalExprTypeFloat T' with | Integer => fun t' => Z.sqrt (evalFloat t' l md) | BinFloat => fun t' => FPsqrt md (evalFloat t' l md) end t | Let _ _ _ t1 t2 => fun l md => let x := evalFloat t1 l md in evalFloat t2 (x, l) md | ArrayAcc _ a t => fun l md => Prim2B (get a (of_Z (evalFloat t l md))) | Assert _ _ _ t | Postcond _ _ _ t => fun l md => evalFloat t l md end. Fixpoint evalRounded {Tl T} (t: ArithExpr Tl T) {struct t} : evalExprTypeRounded_list Tl -> mode -> evalExprTypeRounded T := match t in ArithExpr Tl'' T'' return evalExprTypeRounded_list Tl'' -> mode -> evalExprTypeRounded T'' with | Int _ p => fun l md => p | BinFl _ x => fun l md => SF2R radix2 (Prim2SF x) | Var _ n => fun l md => @nthExprTypeRounded _ Integer n l 0%Z | Op Tl' T' OP t1 t2 => fun l md => match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> evalExprTypeRounded T' with | Integer => fun t1' t2' => ZOpToFunction OP (evalRounded t1' l md) (evalRounded t2' l md) | BinFloat => fun t1' t2' => RrndOpToFunction OP md (evalRounded t1' l md) (evalRounded t2' l md) end t1 t2 | OpExact _ OP t1 t2 => fun l md => ROpToFunction OP (evalRounded t1 l md) (evalRounded t2 l md) | Fma _ t1 t2 t3 => fun l md => @Rrnd.fma md (evalRounded t1 l md) (evalRounded t2 l md) (evalRounded t3 l md) | FmaExact _ t1 t2 t3 => fun l md => (evalRounded t1 l md) * (evalRounded t2 l md) + (evalRounded t3 l md) | Nearbyint _ t | FastNearbyint _ t => fun l md => @Rrnd.nearbyint mode_NE (evalRounded t l md) | FastNearbyintToInt _ t => fun l md => ZnearestE (evalRounded t l md) | TruncToInt _ t => fun l md => Ztrunc (evalRounded t l md) | FloatInj _ t => fun l md => IZR (evalRounded t l md) (*| Ldexp _ _ t1 t2 => fun l md => @Rrnd.ldexp md (evalRounded t1 l md) (evalRounded t2 l md) *) | Sqrt Tl' T' t => fun l md => match T' return ArithExpr Tl' T' -> evalExprTypeRounded T' with | Integer => fun t' => Z.sqrt (evalRounded t' l md) | BinFloat => fun t' => @Rrnd.sqrt md (evalRounded t' l md) end t | Let _ _ _ t1 t2 => fun l md => let x := evalRounded t1 l md in evalRounded t2 (x, l) md | ArrayAcc _ a t => fun l md => SF2R radix2 (Prim2SF (get a (of_Z (evalRounded t l md)))) | Assert _ _ _ t | Postcond _ _ _ t => fun l md => evalRounded t l md end. (* Deprecated *) Fixpoint evalExact {Tl T} (t: ArithExpr Tl T) {struct t} : evalExprTypeRounded_list Tl -> evalExprTypeRounded T := match t with | Int _ p => fun l => p | BinFl _ x => fun l => SF2R radix2 (Prim2SF x) | Var _ n => fun l => @nthExprTypeRounded _ Integer n l 0%Z | Op Tl' T' OP t1 t2 => fun l => match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> evalExprTypeRounded T' with | Integer => fun t1' t2' => ZOpToFunction OP (evalExact t1' l) (evalExact t2' l) | BinFloat => fun t1' t2' => ROpToFunction OP (evalExact t1' l) (evalExact t2' l) end t1 t2 | OpExact _ OP t1 t2 => fun l => ROpToFunction OP (evalExact t1 l) (evalExact t2 l) | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => fun l => (evalExact t1 l) * (evalExact t2 l) + (evalExact t3 l) | Nearbyint _ t | FastNearbyint _ t => fun l => 0 | FastNearbyintToInt _ t => fun l => 0%Z | TruncToInt _ t => fun l => 0%Z | FloatInj _ t => fun l => IZR (evalExact t l) (*| Ldexp _ _ t1 t2 => fun l => (evalExact t1 l) * Rpow2 (evalExact t2 l) *) | Sqrt Tl' T' t => fun l => match T' return ArithExpr Tl' T' -> evalExprTypeRounded T' with | Integer => fun t' => Z.sqrt (evalExact t' l) | BinFloat => fun t' => sqrt (evalExact t' l) end t | Let _ _ _ t1 t2 => fun l => let x := evalExact t1 l in evalExact t2 (x, l) | ArrayAcc _ a t => fun l => 0 | Assert _ _ _ t | Postcond _ _ _ t => fun l => evalExact t l end. (* TODO: move to Compute.v *) Fixpoint evalReal {Tl T} (t: ArithExpr Tl T) {struct t} : evalExprTypeReal_list Tl -> _ := match t with | Int _ p => fun l md => IZR p | BinFl _ x => fun l md => B2R (Prim2B x) | Var _ n => fun l md => nthExprTypeReal n l 0 | Op Tl' T' OP t1 t2 => fun l md => match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> _ with | Integer => fun t1' t2' => match OP with | DIV => Rrnd.trunc (evalReal t1' l md / evalReal t2' l md) | _ => ROpToFunction OP (evalReal t1' l md) (evalReal t2' l md) end | BinFloat => fun t1' t2' => RrndOpToFunction OP md (evalReal t1' l md) (evalReal t2' l md) end t1 t2 | OpExact _ OP t1 t2 => fun l md => ROpToFunction OP (evalReal t1 l md) (evalReal t2 l md) | Fma _ t1 t2 t3 => fun l md => @Rrnd.fma md (evalReal t1 l md) (evalReal t2 l md) (evalReal t3 l md) | FmaExact _ t1 t2 t3 => fun l md => evalReal t1 l md * evalReal t2 l md + evalReal t3 l md | Nearbyint _ t | FastNearbyint _ t | FastNearbyintToInt _ t => fun l md => @Rrnd.nearbyint mode_NE (evalReal t l md) | TruncToInt _ t => fun l md => Rrnd.trunc (evalReal t l md) | FloatInj _ t => fun l md => evalReal t l md (*| Ldexp _ _ t1 t2 => fun l md => round radix2 (FLT_exp Rrnd.emin Rrnd.prec) (round_mode md) (evalReal t1 l md * Rpower 2 (evalReal t2 l md)) *) | Sqrt Tl' T' t => fun l md => match T' return ArithExpr Tl' T' -> _ with | Integer => fun t' => Rrnd.trunc (sqrt (evalReal t' l md)) | BinFloat => fun t' => @Rrnd.sqrt md (evalReal t' l md) end t | Let _ _ _ t1 t2 => fun l md => let x := evalReal t1 l md in evalReal t2 (x, l) md | ArrayAcc _ a t => fun l md => SF2R radix2 (Prim2SF (get a (of_Z (Ztrunc (evalReal t l md))))) | Assert _ _ _ t | Postcond _ _ _ t => fun l md => evalReal t l md end. Definition convertibleFloat {T} : evalExprTypeFloat T -> Prop := match T with | Integer => fun n => Int32.in_bounds n (* When Integer translates to 32-bit integers *) | BinFloat => fun f => @is_finite Rrnd.prec Rrnd.emax f = true end. Definition convertiblePrim {T} : evalExprTypePrim T -> Prop := match T with | Integer => fun n => Int32.in_bounds (to_Z n) (* When Integer translates to 32-bit integers *) | BinFloat => fun f => @is_finite_SF (Prim2SF f) = true end. Fixpoint convertibleFloat_list {Tl} : evalExprTypeFloat_list Tl -> Prop := match Tl with | nil => fun lC => True | T :: _ => fun lC => convertibleFloat (fst lC) /\ convertibleFloat_list (snd lC) end. Fixpoint convertiblePrim_list {Tl} : evalExprTypePrim_list Tl -> Prop := match Tl with | nil => fun lC => True | T :: _ => fun lC => convertiblePrim (fst lC) /\ convertiblePrim_list (snd lC) end. Definition isConversionFloat {T} : evalExprTypeFloat T -> evalExprTypeRounded T -> Prop := match T with | Integer => fun n1 n2 => n1 = n2 | BinFloat => fun f r => @B2R Rrnd.prec Rrnd.emax f = r end. Definition isConversionPrim {T} : evalExprTypePrim T -> evalExprTypeRounded T -> Prop := match T with | Integer => fun n1 n2 => Sint63.to_Z n1 = n2 | BinFloat => fun f r => @SF2R radix2 (Prim2SF f) = r end. Definition eqExprTypeFloat {T} (e1 : evalExprTypeFloat T) (e2 : evalExprTypeRounded T) := convertibleFloat e1 /\ isConversionFloat e1 e2. Definition eqExprTypePrim {T} (e1 : evalExprTypePrim T) (e2 : evalExprTypeRounded T) := convertiblePrim e1 /\ isConversionPrim e1 e2. Fixpoint assertions {Tl T} (t : ArithExpr Tl T) : evalExprTypeRounded_list Tl -> _ := match t with | Int _ _ | BinFl _ _ | Var _ _ | ArrayAcc _ _ _ => fun l md => True | Op _ _ _ t1 t2 | OpExact _ _ t1 t2 (*| Ldexp _ _ t1 t2 *)=> fun l md => assertions t1 l md /\ assertions t2 l md | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => fun l md => assertions t1 l md /\ assertions t2 l md /\ assertions t3 l md | Nearbyint _ t | FastNearbyint _ t | FastNearbyintToInt _ t | TruncToInt _ t | FloatInj _ t | Sqrt _ _ t => fun l md => assertions t l md | Let _ _ _ t1 t2 => fun l md => assertions t1 l md /\ let x := evalRounded t1 l md in assertions t2 (x, l) md | Assert _ _ P t => fun l md => let P' := P (evalExact t l) in uncurrify P' l /\ assertions t l md | Postcond _ _ _ t => fun l md => assertions t l md end. Fixpoint wellDefined {Tl T} (t: ArithExpr Tl T) : evalExprTypeRounded_list Tl -> _ := match t with | Int _ _ | BinFl _ _ | Var _ _ => fun l md => True | Op _ T' OP t1 t2 => fun l md => let P := wellDefined t1 l md /\ wellDefined t2 l md in match OP with | DIV => P /\ evalRounded t2 l md <> match T' with Integer => 0%Z | _ => 0 end | _ => P end | OpExact _ OP t1 t2 => fun l md => let P := wellDefined t1 l md /\ wellDefined t2 l md in match OP with | DIV => P /\ evalRounded t2 l md <> 0 | _ => P end | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => fun l md => wellDefined t1 l md /\ wellDefined t2 l md /\ wellDefined t3 l md | Nearbyint _ t | FastNearbyint _ t | FastNearbyintToInt _ t | TruncToInt _ t | FloatInj _ t => fun l md => wellDefined t l md | Sqrt Tl' T' t => fun l md => wellDefined t l md /\ match T' return ArithExpr Tl' T' -> _ with | Integer => fun t' => 0 <= IZR (evalRounded t' l md) | _ => fun t' => 0 <= evalRounded t' l md end t (*| Ldexp _ _ t1 t2 => fun l md => wellDefined t1 l md /\ wellDefined t2 l md *) | Let _ _ _ t1 t2 => fun l md => wellDefined t1 l md /\ wellDefined t2 (evalRounded t1 l md, l) md | ArrayAcc _ _ t | Assert _ _ _ t | Postcond _ _ _ t => fun l md => wellDefined t l md end. Fixpoint operationsExact {Tl T} (t: ArithExpr Tl T) : evalExprTypeRounded_list Tl -> _ := (* TODO: find better name *) match t with | Int _ _ | BinFl _ _ | Var _ _ => fun l md => True | Op Tl' T' OP t1 t2 => fun l md => operationsExact t1 l md /\ operationsExact t2 l md /\ match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> _ with | Integer => fun t1' t2' => - IZR (Int32.N / 2) <= IZR (ZOpToFunction OP (evalRounded t1' l md) (evalRounded t2' l md)) <= IZR (Int32.N / 2 - 1) | BinFloat => fun t1' t2' => Rabs (RrndOpToFunction OP md (evalRounded t1' l md) (evalRounded t2' l md)) <= Rrnd.maxval end t1 t2 | OpExact _ OP t1 t2 => fun l md => operationsExact t1 l md /\ operationsExact t2 l md /\ Rabs (ROpToFunction OP (evalRounded t1 l md) (evalRounded t2 l md)) <= Rrnd.maxval /\ RrndOpToFunction OP md (evalRounded t1 l md) (evalRounded t2 l md) = ROpToFunction OP (evalRounded t1 l md) (evalRounded t2 l md) | Fma _ t1 t2 t3 => fun l md => operationsExact t1 l md /\ operationsExact t2 l md /\ operationsExact t3 l md /\ Rabs (@Rrnd.fma md (evalRounded t1 l md) (evalRounded t2 l md) (evalRounded t3 l md)) <= Rrnd.maxval | FmaExact _ t1 t2 t3 => fun l md => operationsExact t1 l md /\ operationsExact t2 l md /\ operationsExact t3 l md /\ Rabs ((evalRounded t1 l md) * (evalRounded t2 l md) + (evalRounded t3 l md)) <= Rrnd.maxval /\ @Rrnd.fma md (evalRounded t1 l md) (evalRounded t2 l md) (evalRounded t3 l md) = (evalRounded t1 l md) * (evalRounded t2 l md) + (evalRounded t3 l md) | Nearbyint _ t => fun l md => operationsExact t l md | FastNearbyint _ t => fun l md => operationsExact t l md /\ -2251799813685248 <= evalRounded t l md <= 2251799813685247 | FastNearbyintToInt _ t => fun l md => operationsExact t l md /\ -2147483648 <= evalRounded t l md <= 2147483647 | TruncToInt _ t => fun l md => operationsExact t l md /\ (- Int32.N / 2 <= Ztrunc (evalRounded t l md) <= Int32.N / 2 - 1)%Z | FloatInj _ t => fun l md => operationsExact t l md /\ Rabs (IZR (evalRounded t l md)) <= Rpow2 53 | Sqrt _ _ t => fun l md => operationsExact t l md (*| Ldexp _ n t1 t2 => fun l md => operationsExact t1 l md /\ operationsExact t2 l md /\ Rabs (evalRounded t1 l md) <= IZR (radix2 ^ Rrnd.prec - 1) * Rpow2 (n - Rrnd.prec) /\ IZR (n + evalRounded t2 l md) <= IZR Rrnd.emax *) | ArrayAcc _ a t => fun l md => operationsExact t l md /\ (0 <= evalRounded t l md < Uint63.to_Z (PArray.length a))%Z | Let _ _ _ t1 t2 => fun l md => operationsExact t1 l md /\ operationsExact t2 (evalRounded t1 l md, l) md | Assert _ _ _ t | Postcond _ _ _ t => fun l md => operationsExact t l md end. Fixpoint wellBehaved {Tl T} (t: ArithExpr Tl T) : evalExprTypeRounded_list Tl -> _ := (* TODO: rename *) match t with | Int _ _ | BinFl _ _ | Var _ _ => fun l md => True | Op Tl' T' OP t1 t2 => fun l md => wellBehaved t1 l md /\ wellBehaved t2 l md /\ let P := match T' return ArithExpr Tl' T' -> ArithExpr Tl' T' -> _ with | Integer => fun t1' t2' => - IZR (Int32.N / 2) <= IZR (ZOpToFunction OP (evalRounded t1' l md) (evalRounded t2' l md)) <= IZR (Int32.N / 2 - 1) | BinFloat => fun t1' t2' => Rabs (RrndOpToFunction OP md (evalRounded t1' l md) (evalRounded t2' l md)) <= Rrnd.maxval end t1 t2 in match OP with | DIV => P /\ evalRounded t2 l md <> match T' with Integer => 0%Z | _ => 0 end | _ => P end | OpExact _ OP t1 t2 => fun l md => let P := wellBehaved t1 l md /\ wellBehaved t2 l md /\ Rabs (ROpToFunction OP (evalRounded t1 l md) (evalRounded t2 l md)) <= Rrnd.maxval /\ RrndOpToFunction OP md (evalRounded t1 l md) (evalRounded t2 l md) = ROpToFunction OP (evalRounded t1 l md) (evalRounded t2 l md) in match OP with | DIV => P /\ evalRounded t2 l md <> 0 |_ => P end | Fma _ t1 t2 t3 => fun l md => wellBehaved t1 l md /\ wellBehaved t2 l md /\ wellBehaved t3 l md /\ Rabs (@Rrnd.fma md (evalRounded t1 l md) (evalRounded t2 l md) (evalRounded t3 l md)) <= Rrnd.maxval | FmaExact _ t1 t2 t3 => fun l md => wellBehaved t1 l md /\ wellBehaved t2 l md /\ wellBehaved t3 l md /\ Rabs ((evalRounded t1 l md) * (evalRounded t2 l md) + (evalRounded t3 l md)) <= Rrnd.maxval /\ @Rrnd.fma md (evalRounded t1 l md) (evalRounded t2 l md) (evalRounded t3 l md) = (evalRounded t1 l md) * (evalRounded t2 l md) + (evalRounded t3 l md) | Nearbyint _ t => fun l md => wellBehaved t l md | FastNearbyint _ t => fun l md => wellBehaved t l md /\ -2251799813685248 <= evalRounded t l md <= 2251799813685247 | FastNearbyintToInt _ t => fun l md => wellBehaved t l md /\ -2147483648 <= evalRounded t l md <= 2147483647 (* TODO: - ... - 1/2 <= ... < ... + 1/2 *) | TruncToInt _ t => fun l md => wellBehaved t l md /\ (- Int32.N / 2 <= Ztrunc (evalRounded t l md) <= Int32.N / 2 - 1)%Z | FloatInj _ t => fun l md => wellBehaved t l md /\ Rabs (IZR (evalRounded t l md)) <= Rpow2 53 | Sqrt Tl' T' t => fun l md => wellBehaved t l md /\ match T' return ArithExpr Tl' T' -> _ with | Integer => fun t' => 0 <= IZR (evalRounded t' l md) | _ => fun t' => 0 <= evalRounded t' l md end t (*| Ldexp _ n t1 t2 => fun l md => wellBehaved t1 l md /\ wellBehaved t2 l md /\ Rabs (evalRounded t1 l md) <= IZR (radix2 ^ Rrnd.prec - 1) * Rpow2 (n - Rrnd.prec) /\ IZR (n + evalRounded t2 l md) <= IZR Rrnd.emax *) | Let _ _ _ t1 t2 => fun l md => wellBehaved t1 l md /\ wellBehaved t2 (evalRounded t1 l md, l) md | ArrayAcc _ a t => fun l md => wellBehaved t l md /\ (0 <= evalRounded t l md < Uint63.to_Z (PArray.length a))%Z | Assert _ _ _ t | Postcond _ _ _ t => fun l md => wellBehaved t l md end. Fixpoint postconditions {Tl T} (t : ArithExpr Tl T) : evalExprTypeRounded_list Tl -> _ := match t with | Int _ _ | BinFl _ _ | Var _ _ => fun l md => True | Op _ _ _ t1 t2 | OpExact _ _ t1 t2 (*| Ldexp _ _ t1 t2 *)=> fun l md => postconditions t1 l md /\ postconditions t2 l md | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => fun l md => postconditions t1 l md /\ postconditions t2 l md /\ postconditions t3 l md | Nearbyint _ t | FastNearbyint _ t | FastNearbyintToInt _ t | TruncToInt _ t | FloatInj _ t | Sqrt _ _ t => fun l md => postconditions t l md | Let _ _ _ t1 t2 => fun l md => postconditions t1 l md /\ let x := evalRounded t1 l md in postconditions t2 (x, l) md | ArrayAcc _ a t => fun l md => True | Assert _ _ _ t => fun l md => postconditions t l md | Postcond _ _ P t => fun l md => let P' := P (evalRounded t l md) in uncurrify P' l /\ postconditions t l md end. Definition fullyCorrect {Tl T} (t: ArithExpr Tl T) l md := assertions t l md -> (wellBehaved t l md /\ postconditions t l md). (* TODO: maybe move those proof obligations to the constructors *) Fixpoint wellFormed {Tl T} (t: ArithExpr Tl T) := match t with | Int _ n => (- Z.pow_pos 2 (Int32.bits - 1) <=? n)%Z && (n is_finite_SF (Prim2SF x) | Var _ _ => true | Op _ _ _ t1 t2 | OpExact _ _ t1 t2 (*| Ldexp _ _ t1 t2 *)=> wellFormed t1 && wellFormed t2 | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => wellFormed t1 && wellFormed t2 && wellFormed t3 | Let _ _ _ t1 t2 => wellFormed t1 && wellFormed t2 | ArrayAcc _ a t => wellFormed t && finite_array a | Nearbyint _ t | FastNearbyint _ t | FastNearbyintToInt _ t | TruncToInt _ t | FloatInj _ t | Sqrt _ _ t | Assert _ _ _ t | Postcond _ _ _ t => wellFormed t end. Lemma Ztrunc_div_ : forall x y : Z, Ztrunc (IZR x / IZR y) = (x ÷ y)%Z. Proof. intros x y. destruct (Zeq_bool y 0) eqn:Hy; [apply Zeq_bool_eq in Hy | apply Zeq_bool_neq in Hy]. - rewrite Hy. unfold Rdiv. now rewrite Rinv_0, Rmult_0_r, Zquot.Zquot_0_r, Ztrunc_IZR. - now apply Ztrunc_div. Qed. Lemma Zfloor_add : forall x n, (Zfloor x + n)%Z = Zfloor (x + IZR n). Proof. intros x n. symmetry. apply Zfloor_imp. rewrite !plus_IZR. rewrite Rplus_assoc, (Rplus_comm _ 1), <-Rplus_assoc. split. - apply Rplus_le_compat_r, Zfloor_lb. - apply Rplus_lt_compat_r, Zfloor_ub. Qed. Lemma Zfloor_mul : forall x, 0 <= x -> Z.le (Zfloor x * Zfloor x)%Z (Zfloor (x * x)). Proof. intros x Hx. apply Zfloor_lub. rewrite mult_IZR. apply Rmult_le_compat. 3, 4: apply Zfloor_lb. all: apply IZR_le, Zlt_succ_le; unfold Z.succ; apply lt_IZR; rewrite plus_IZR; apply Rle_lt_trans with (1 := Hx), Zfloor_ub. Qed. Lemma trunc_sqrt: forall n, Zfloor (sqrt (IZR n)) = Z.sqrt n. Proof. intros [| p | p ]; [now rewrite sqrt_0, Zfloor_IZR | |]. - symmetry. apply Z.sqrt_unique. unfold Z.succ. rewrite <-(Zfloor_IZR (Z.pos p)), <-(sqrt_def (IZR (Z.pos p))) at 3 4 by now apply IZR_le. rewrite Zfloor_add. split; [apply Zfloor_mul, sqrt_ge_0 |]. apply (Z.le_lt_trans _ (Z.pos p)). + apply le_IZR. rewrite <-(sqrt_def (IZR (Z.pos p))) at 3 by now apply IZR_le. apply Zfloor_lb. + apply lt_IZR. rewrite <-(sqrt_def (IZR (Z.pos p))) at 1 by now apply IZR_le. rewrite mult_IZR. apply Rmult_lt_compat; [apply sqrt_ge_0 | apply sqrt_ge_0 | rewrite <-Zfloor_add; rewrite plus_IZR; apply Zfloor_ub..]. - rewrite sqrt_neg; [| now apply IZR_le]. now rewrite Zfloor_IZR. Qed. Lemma evalReal_evalRounded {Tl T} : forall (t: ArithExpr Tl T) (lM : evalExprTypeRounded_list Tl) md, let lR := M2R_list lM in evalReal t lR md = M2R (evalRounded t lM md). Proof. induction t as [| | | Tl T OP | Tl OP | | | | | | | | Tl T | | | |]. - easy. - simpl. intros _ _. now rewrite <-B2SF_Prim2B, SF2R_B2SF. - intros lM. revert n. induction Tl as [| T Tl]; [now destruct n |]. destruct T; (destruct n; [easy |]); simpl in *; apply IHTl. - intros lM md lR. destruct OP; destruct T; simpl; unfold lR; rewrite (IHt1 lM), (IHt2 lM); try reflexivity; [| | | now unfold Rrnd.nearbyint, round, F2R, scaled_mantissa; simpl; rewrite !Rmult_1_r, Ztrunc_div_]. + now rewrite <-plus_IZR. + now rewrite <-minus_IZR. + now rewrite <-mult_IZR. - intros lM md lR. now destruct OP; simpl; unfold lR; rewrite (IHt1 lM), (IHt2 lM). - intros lM md lR. simpl in *. unfold lR. now rewrite IHt1, IHt2, IHt3. - intros lM md lR. simpl in *. unfold lR. now rewrite IHt1, IHt2, IHt3. - intros lM md lR. simpl in *. unfold lR. now rewrite IHt. - intros lM md lR. simpl in *. unfold lR. now rewrite IHt. - intros lM md lR. simpl in *. unfold lR, Rrnd.nearbyint. now rewrite IHt, round_FIX_IZR. - intros lM md lR. simpl in *. unfold lR. rewrite <-round_FIX_IZR. now rewrite IHt. - intros lM md lR. simpl in *. unfold lR. apply IHt. (*intros lM md lR. simpl in *. unfold lR, Rrnd.ldexp. rewrite bpow_exp. now rewrite IHt1, IHt2. *) - intros lM md lR. simpl in *. unfold lR. destruct T. + unfold Rrnd.nearbyint, round, F2R, scaled_mantissa. simpl. rewrite 2Rmult_1_r. rewrite Ztrunc_floor by apply sqrt_ge_0. apply f_equal. rewrite IHt. apply trunc_sqrt. + now rewrite IHt. - intros lM md lR. now destruct T1; unfold lR in *; simpl in *; rewrite IHt1; fold evalExprTypeReal_list in *; fold evalExprTypeRounded_list in *; specialize (IHt2 (evalRounded t1 lM md, lM)); simpl in IHt2; rewrite IHt2. - intros lM md lR. simpl in *. unfold lR. now rewrite IHt, Ztrunc_IZR. - easy. - intros lM md lR. simpl in *. unfold lR. now apply IHt. Qed. Lemma wellBehaved_decompose {Tl T} : forall (t: ArithExpr Tl T) (l : evalExprTypeRounded_list Tl) md, wellBehaved t l md <-> wellDefined t l md /\ operationsExact t l md. Proof. induction t as [| | | Tl T OP | Tl OP | | | | | | | | Tl T | | | |]. - easy. - easy. - easy. - intros l md. now destruct OP; simpl; rewrite IHt1, IHt2; [| | | destruct T]. - intros l md. now destruct OP; simpl; rewrite IHt1, IHt2. - intros l md. simpl. now rewrite IHt1, IHt2, IHt3. - intros l md. simpl. now rewrite IHt1, IHt2, IHt3. - easy. - intros l md. simpl. now rewrite IHt. - intros l md. simpl. now rewrite IHt. - intros l md. simpl. now rewrite IHt. - intros l md. simpl. now rewrite IHt. (*intros l md. simpl. now rewrite IHt1, IHt2. *) - intros l md. simpl. now rewrite IHt. - intros l md. simpl. now rewrite IHt1, IHt2. - intros l md. simpl. now rewrite IHt. - easy. - easy. Qed. Lemma equivFloat_Int {Tl} : forall n (lC : evalExprTypeFloat_list Tl) md, (- Z.pow_pos 2 (Int32.bits - 1) <= n < Z.pow_pos 2 (Int32.bits - 1))%Z -> let lM := C2M_list lC in eqExprTypeFloat (evalFloat (Int n) lC md) (evalRounded (Int n) lM md). Proof. intros n lC md H lM. simpl. split; [apply Int32.in_bounds_norm | apply Int32.norm_in_bounds]. unfold Int32.in_bounds, Int32.N. unfold Int32.bits. revert H. cbn. lia. Qed. Lemma equivPrim_Int {Tl} : forall n (lP : evalExprTypePrim_list Tl), (- Z.pow_pos 2 (Int32.bits - 1) <= n < Z.pow_pos 2 (Int32.bits - 1))%Z -> let lM := P2M_list lP in eqExprTypePrim (evalPrim (Int n) lP) (evalRounded (Int n) lM mode_NE). Proof. intros n lP H lM. unfold eqExprTypePrim. simpl. rewrite of_Z_spec. rewrite cmod_small; [| cbn in H |- *; lia]. split; [| easy]. revert H. unfold Int32.in_bounds. cbn. lia. Qed. Lemma equivFloat_Op_ADD_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> Rabs (@Rrnd.Rnd md (evalRounded t1 lM md + evalRounded t2 lM md)) <= Rrnd.maxval -> eqExprTypeFloat (evalFloat (Op ADD t1 t2) lC md) (evalRounded (Op ADD t1 t2) lM md). Proof. intros t1 t2 lC md lM [convt1 isconvt1] [convt2 isconvt2] H. generalize (Bplus_correct _ _ HPrec_gt_0 HPrec_lt_emax md (evalFloat t1 lC md) (evalFloat t2 lC md)). rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. simpl round_mode. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]; [assumption.. |]. unfold eqExprTypeFloat; simpl. now unfold FPadd; rewrite H1, isconvt1, isconvt2. Qed. Lemma Prim2SF2R_Prim2B2R : forall x, SF2R radix2 (Prim2SF x) = B2R (Prim2B x). Proof. intros x. now rewrite <-SF2R_B2SF, B2SF_Prim2B. Qed. Lemma equivPrim_Op_ADD_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> Rabs (@Rrnd.Rnd mode_NE (evalRounded t1 lM mode_NE + evalRounded t2 lM mode_NE)) <= Rrnd.maxval -> eqExprTypePrim (evalPrim (Op ADD t1 t2) lP) (evalRounded (Op ADD t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [convt1 isconvt1] [convt2 isconvt2] H. unfold eqExprTypePrim; simpl. generalize (Bplus_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (Prim2B (evalPrim t1 lP)) (Prim2B (evalPrim t2 lP))). rewrite <-add_equiv, <-3is_finite_SF_B2SF, <-3SF2R_B2SF, 3B2SF_Prim2B. rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. simpl round_mode. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]; [assumption.. |]. unfold eqExprTypePrim. simpl. unfold FloatOps.prec, FloatOps.emax, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax in *. unfold HPrec_gt_0, HPrec_lt_emax in H1. now rewrite H1, isconvt1, isconvt2. Qed. Lemma equivFloat_Op_SUB_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> Rabs (@Rrnd.Rnd md (evalRounded t1 lM md - evalRounded t2 lM md)) <= Rrnd.maxval -> eqExprTypeFloat (evalFloat (Op SUB t1 t2) lC md) (evalRounded (Op SUB t1 t2) lM md). Proof. intros t1 t2 lC md lM [convt1 isconvt1] [convt2 isconvt2] H. generalize (Bminus_correct _ _ HPrec_gt_0 HPrec_lt_emax md (evalFloat t1 lC md) (evalFloat t2 lC md)). rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. simpl round_mode. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]; [assumption.. |]. unfold eqExprTypeFloat; simpl. now unfold FPsub; rewrite H1, isconvt1, isconvt2. Qed. Lemma equivPrim_Op_SUB_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> Rabs (@Rrnd.Rnd mode_NE (evalRounded t1 lM mode_NE - evalRounded t2 lM mode_NE)) <= Rrnd.maxval -> eqExprTypePrim (evalPrim (Op SUB t1 t2) lP) (evalRounded (Op SUB t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [convt1 isconvt1] [convt2 isconvt2] H. unfold eqExprTypePrim; simpl. generalize (Bminus_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (Prim2B (evalPrim t1 lP)) (Prim2B (evalPrim t2 lP))). rewrite <-sub_equiv, <-3is_finite_SF_B2SF, <-3SF2R_B2SF, 3B2SF_Prim2B. rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. simpl round_mode. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]; [assumption.. |]. unfold eqExprTypePrim. simpl. unfold FloatOps.prec, FloatOps.emax, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax in *. unfold HPrec_gt_0, HPrec_lt_emax in H1. now rewrite H1, isconvt1, isconvt2. Qed. Lemma equivFloat_Op_MUL_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> Rabs (@Rrnd.Rnd md (evalRounded t1 lM md * evalRounded t2 lM md)) <= Rrnd.maxval -> eqExprTypeFloat (evalFloat (Op MUL t1 t2) lC md) (evalRounded (Op MUL t1 t2) lM md). Proof. intros t1 t2 lC md lM [convt1 isconvt1] [convt2 isconvt2] H. generalize (Bmult_correct _ _ HPrec_gt_0 HPrec_lt_emax md (evalFloat t1 lC md) (evalFloat t2 lC md)). rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]. unfold eqExprTypeFloat. simpl. unfold FPmul. rewrite H2. split; [now apply andb_true_intro |]. rewrite H1. unfold Rrnd.Rnd, SpecFloat.fexp, FLT_exp, SpecFloat.emin, Rrnd.emin. now rewrite isconvt1, isconvt2. Qed. Lemma equivPrim_Op_MUL_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> Rabs (@Rrnd.Rnd mode_NE (evalRounded t1 lM mode_NE * evalRounded t2 lM mode_NE)) <= Rrnd.maxval -> eqExprTypePrim (evalPrim (Op MUL t1 t2) lP) (evalRounded (Op MUL t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [convt1 isconvt1] [convt2 isconvt2] H. unfold eqExprTypePrim; simpl. generalize (Bmult_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (Prim2B (evalPrim t1 lP)) (Prim2B (evalPrim t2 lP))). rewrite <-mul_equiv, <-3is_finite_SF_B2SF, <-3SF2R_B2SF, 3B2SF_Prim2B. rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]. unfold eqExprTypePrim. simpl. unfold FPmul. unfold FloatOps.prec, FloatOps.emax, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax in *. unfold HPrec_gt_0, HPrec_lt_emax in H1, H2. rewrite H1, H2, isconvt1, isconvt2. now split; [apply andb_true_intro |]. Qed. Lemma equivFloat_Op_DIV_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> evalRounded t2 lM md <> 0 -> Rabs (@Rrnd.Rnd md (evalRounded t1 lM md / evalRounded t2 lM md)) <= Rrnd.maxval -> eqExprTypeFloat (evalFloat (Op DIV t1 t2) lC md) (evalRounded (Op DIV t1 t2) lM md). Proof. intros t1 t2 lC md lM [convt1 isconvt1] [convt2 isconvt2] H0 H. generalize (Bdiv_correct _ _ HPrec_gt_0 HPrec_lt_emax md (evalFloat t1 lC md) (evalFloat t2 lC md)). rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]; [now rewrite isconvt2 |]. unfold eqExprTypeFloat. simpl. unfold FPdiv. rewrite H2. split; [assumption |]. rewrite H1. unfold Rrnd.Rnd, SpecFloat.fexp, FLT_exp, SpecFloat.emin, Rrnd.emin. now rewrite isconvt1, isconvt2. Qed. Lemma equivPrim_Op_DIV_BinFloat {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> evalRounded t2 lM mode_NE <> 0 -> Rabs (@Rrnd.Rnd mode_NE (evalRounded t1 lM mode_NE / evalRounded t2 lM mode_NE)) <= Rrnd.maxval -> eqExprTypePrim (evalPrim (Op DIV t1 t2) lP) (evalRounded (Op DIV t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [convt1 isconvt1] [convt2 isconvt2] H0 H. unfold eqExprTypePrim; simpl. generalize (Bdiv_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (Prim2B (evalPrim t1 lP)) (Prim2B (evalPrim t2 lP))). rewrite <-div_equiv, <-2is_finite_SF_B2SF, <-3SF2R_B2SF, 3B2SF_Prim2B. rewrite Rlt_bool_true. 2: { rewrite isconvt1, isconvt2. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. } intros [H1 [H2 H3]]; [now rewrite isconvt2 |]. unfold eqExprTypePrim. simpl. unfold FPdiv. unfold FloatOps.prec, FloatOps.emax, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax in *. unfold HPrec_gt_0, HPrec_lt_emax in H1, H2. now rewrite H1, H2, isconvt1, isconvt2. Qed. Lemma equivFloat_Op_ADD_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> - IZR (Int32.N / 2) <= IZR ((evalRounded t1 lM md) + (evalRounded t2 lM md)) <= IZR (Int32.N / 2 - 1) -> eqExprTypeFloat (evalFloat (Op ADD t1 t2) lC md) (evalRounded (Op ADD t1 t2) lM md). Proof. intros t1 t2 lC md lM [bndt1 eqt1] [bndt2 eqt2] [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypeFloat. simpl. rewrite eqt1, eqt2. split; [apply Int32.in_bounds_norm | now apply Int32.norm_in_bounds]. Qed. Lemma equivPrim_Op_ADD_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> - IZR (Int32.N / 2) <= IZR ((evalRounded t1 lM mode_NE) + (evalRounded t2 lM mode_NE)) <= IZR (Int32.N / 2 - 1) -> eqExprTypePrim (evalPrim (Op ADD t1 t2) lP) (evalRounded (Op ADD t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [bndt1 eqt1] [bndt2 eqt2] [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypePrim. simpl in *. rewrite <-eqt1, <-eqt2 in H1, H2 |- *. now rewrite Sint63.add_spec, Sint63.cmod_small; [| cbn -[evalPrim] in *; lia]. Qed. Lemma equivFloat_Op_SUB_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> - IZR (Int32.N / 2) <= IZR ((evalRounded t1 lM md) - (evalRounded t2 lM md)) <= IZR (Int32.N / 2 - 1) -> eqExprTypeFloat (evalFloat (Op SUB t1 t2) lC md) (evalRounded (Op SUB t1 t2) lM md). Proof. intros t1 t2 lC md lM [bndt1 eqt1] [bndt2 eqt2] [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypeFloat. simpl. rewrite eqt1, eqt2. split; [apply Int32.in_bounds_norm | now apply Int32.norm_in_bounds]. Qed. Lemma equivPrim_Op_SUB_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> - IZR (Int32.N / 2) <= IZR ((evalRounded t1 lM mode_NE) - (evalRounded t2 lM mode_NE)) <= IZR (Int32.N / 2 - 1) -> eqExprTypePrim (evalPrim (Op SUB t1 t2) lP) (evalRounded (Op SUB t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [bndt1 eqt1] [bndt2 eqt2] [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypePrim. simpl in *. rewrite <-eqt1, <-eqt2 in H1, H2 |- *. now rewrite Sint63.sub_spec, Sint63.cmod_small; [| cbn -[evalPrim] in *; lia]. Qed. Lemma equivFloat_Op_MUL_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> - IZR (Int32.N / 2) <= IZR ((evalRounded t1 lM md) * (evalRounded t2 lM md)) <= IZR (Int32.N / 2 - 1) -> eqExprTypeFloat (evalFloat (Op MUL t1 t2) lC md) (evalRounded (Op MUL t1 t2) lM md). Proof. intros t1 t2 lC md lM [bndt1 eqt1] [bndt2 eqt2] [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypeFloat. simpl. rewrite eqt1, eqt2. split; [apply Int32.in_bounds_norm | now apply Int32.norm_in_bounds]. Qed. Lemma equivPrim_Op_MUL_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> - IZR (Int32.N / 2) <= IZR ((evalRounded t1 lM mode_NE) * (evalRounded t2 lM mode_NE)) <= IZR (Int32.N / 2 - 1) -> eqExprTypePrim (evalPrim (Op MUL t1 t2) lP) (evalRounded (Op MUL t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [bndt1 eqt1] [bndt2 eqt2] [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypePrim. simpl in *. rewrite <-eqt1, <-eqt2 in H1, H2 |- *. now rewrite Sint63.mul_spec, Sint63.cmod_small; [| cbn -[evalPrim] in *; lia]. Qed. Lemma equivFloat_Op_DIV_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> (evalRounded t2 lM md <> 0)%Z -> - IZR (Int32.N / 2) <= IZR (Z.quot (evalRounded t1 lM md) (evalRounded t2 lM md)) <= IZR (Int32.N / 2 - 1) -> eqExprTypeFloat (evalFloat (Op DIV t1 t2) lC md) (evalRounded (Op DIV t1 t2) lM md). Proof. intros t1 t2 lC md lM [bndt1 eqt1] [bndt2 eqt2] H0 [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypeFloat. simpl. rewrite eqt1, eqt2. split; [apply Int32.in_bounds_norm | now apply Int32.norm_in_bounds]. Qed. Lemma equivPrim_Op_DIV_Integer {Tl} : forall (t1 t2 : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> (evalRounded t2 lM mode_NE <> 0)%Z -> - IZR (Int32.N / 2) <= IZR (Z.quot (evalRounded t1 lM mode_NE) (evalRounded t2 lM mode_NE)) <= IZR (Int32.N / 2 - 1) -> eqExprTypePrim (evalPrim (Op DIV t1 t2) lP) (evalRounded (Op DIV t1 t2) lM mode_NE). Proof. intros t1 t2 lP lM [bndt1 eqt1] [bndt2 eqt2] H0 [H1 H2]. rewrite <-opp_IZR in H1. apply le_IZR in H1, H2. unfold eqExprTypePrim. simpl in *. rewrite <-eqt1 in H1, H2 |- *. rewrite <-eqt2 in H0, H1, H2 |- *. assert (H: Sint63.to_Z (evalPrim t1 lP) <> Sint63.to_Z Sint63.min_int). { revert bndt1. unfold Int32.in_bounds. cbn -[evalPrim]. lia. } clear eqt1. now rewrite Sint63.div_spec; [| left]. Qed. Lemma equivFloat_OpExact {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) OP (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> match OP with DIV => evalRounded t2 lM md <> 0 | _ => True end -> Rabs (ROpToFunction OP (evalRounded t1 lM md) (evalRounded t2 lM md)) <= Rrnd.maxval -> RrndOpToFunction OP md (evalRounded t1 lM md) (evalRounded t2 lM md) = ROpToFunction OP (evalRounded t1 lM md) (evalRounded t2 lM md) -> eqExprTypeFloat (evalFloat (OpExact OP t1 t2) lC md) (evalRounded (OpExact OP t1 t2) lM md). Proof. intros t1 t2 OP lC md lM eqt1 eqt2 H0 H1 H2. simpl. rewrite <-H2 in H1 |- *. destruct OP. - now apply equivFloat_Op_ADD_BinFloat. - now apply equivFloat_Op_SUB_BinFloat. - now apply equivFloat_Op_MUL_BinFloat. - now apply equivFloat_Op_DIV_BinFloat. Qed. Lemma equivPrim_OpExact {Tl} : forall (t1 t2 : ArithExpr Tl BinFloat) OP (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> match OP with DIV => evalRounded t2 lM mode_NE <> 0 | _ => True end -> Rabs (ROpToFunction OP (evalRounded t1 lM mode_NE) (evalRounded t2 lM mode_NE)) <= Rrnd.maxval -> RrndOpToFunction OP mode_NE (evalRounded t1 lM mode_NE) (evalRounded t2 lM mode_NE) = ROpToFunction OP (evalRounded t1 lM mode_NE) (evalRounded t2 lM mode_NE) -> eqExprTypePrim (evalPrim (OpExact OP t1 t2) lP) (evalRounded (OpExact OP t1 t2) lM mode_NE). Proof. intros t1 t2 OP lC lM eqt1 eqt2 H0 H1 H2. simpl. rewrite <-H2 in H1 |- *. destruct OP. - now apply equivPrim_Op_ADD_BinFloat. - now apply equivPrim_Op_SUB_BinFloat. - now apply equivPrim_Op_MUL_BinFloat. - now apply equivPrim_Op_DIV_BinFloat. Qed. Lemma equivFloat_Fma {Tl} : forall (t1 t2 t3 : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> eqExprTypeFloat (evalFloat t3 lC md) (evalRounded t3 lM md) -> Rabs (@Rrnd.fma md (evalRounded t1 lM md) (evalRounded t2 lM md) (evalRounded t3 lM md)) <= Rrnd.maxval -> eqExprTypeFloat (evalFloat (Fma t1 t2 t3) lC md) (evalRounded (Fma t1 t2 t3) lM md). Proof. intros t1 t2 t3 lC md lM [convt1 isconvt1] [convt2 isconvt2] [convt3 isconvt3] H. generalize (Bfma_correct _ _ HPrec_gt_0 HPrec_lt_emax md (evalFloat t1 lC md) (evalFloat t2 lC md) (evalFloat t3 lC md)). unfold eqExprTypeFloat. simpl. rewrite Rlt_bool_true. { intros [H1 [H2 H3]]; [assumption.. |]. now unfold FPfma; rewrite H1, isconvt1, isconvt2, isconvt3. } rewrite isconvt1, isconvt2, isconvt3. simpl round_mode. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. Qed. Lemma equivPrim_Fma {Tl} : forall (t1 t2 t3 : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> eqExprTypePrim (evalPrim t3 lP) (evalRounded t3 lM mode_NE) -> Rabs (@Rrnd.fma mode_NE (evalRounded t1 lM mode_NE) (evalRounded t2 lM mode_NE) (evalRounded t3 lM mode_NE)) <= Rrnd.maxval -> eqExprTypePrim (evalPrim (Fma t1 t2 t3) lP) (evalRounded (Fma t1 t2 t3) lM mode_NE). Proof. intros t1 t2 t3 lP lM [convt1 isconvt1] [convt2 isconvt2] [convt3 isconvt3] H. generalize (Bfma_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (P2C (evalPrim t1 lP)) (P2C (evalPrim t2 lP)) (P2C (evalPrim t3 lP))). unfold eqExprTypePrim. simpl. unfold isConversionPrim in isconvt1, isconvt2, isconvt3. rewrite <-4is_finite_SF_B2SF, 3B2SF_Prim2B. rewrite <-B2SF_Prim2B, SF2R_B2SF in isconvt1, isconvt2, isconvt3. rewrite Rlt_bool_true. { intros [H1 [H2 H3]]; [assumption.. |]. rewrite Prim2SF_B2Prim. split; [easy |]. unfold FPfma. change Rrnd.prec with prec in H1 |- *. change Rrnd.emax with emax in H1 |- *. rewrite SF2R_B2SF. now rewrite H1, isconvt1, isconvt2, isconvt3. } change Rrnd.prec with prec. change Rrnd.emax with emax. rewrite isconvt1, isconvt2, isconvt3. simpl round_mode. apply Rle_lt_trans with Rrnd.maxval; [assumption |]. apply Rrnd.maxval_lt. Qed. Lemma equivFloat_FmaExact {Tl} : forall (t1 t2 t3 : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t1 lC md) (evalRounded t1 lM md) -> eqExprTypeFloat (evalFloat t2 lC md) (evalRounded t2 lM md) -> eqExprTypeFloat (evalFloat t3 lC md) (evalRounded t3 lM md) -> Rabs (evalRounded t1 lM md * evalRounded t2 lM md + evalRounded t3 lM md) <= Rrnd.maxval -> (@Rrnd.fma md (evalRounded t1 lM md) (evalRounded t2 lM md) (evalRounded t3 lM md)) = evalRounded t1 lM md * evalRounded t2 lM md + evalRounded t3 lM md-> eqExprTypeFloat (evalFloat (FmaExact t1 t2 t3) lC md) (evalRounded (FmaExact t1 t2 t3) lM md). Proof. intros t1 t2 t3 lC md lM [convt1 isconvt1] [convt2 isconvt2] [convt3 isconvt3] H0 H1. simpl. rewrite <-H1 in H0 |- *. now apply equivFloat_Fma. Qed. Lemma equivPrim_FmaExact {Tl} : forall (t1 t2 t3 : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t1 lP) (evalRounded t1 lM mode_NE) -> eqExprTypePrim (evalPrim t2 lP) (evalRounded t2 lM mode_NE) -> eqExprTypePrim (evalPrim t3 lP) (evalRounded t3 lM mode_NE) -> Rabs (evalRounded t1 lM mode_NE * evalRounded t2 lM mode_NE + evalRounded t3 lM mode_NE) <= Rrnd.maxval -> (@Rrnd.fma mode_NE (evalRounded t1 lM mode_NE) (evalRounded t2 lM mode_NE) (evalRounded t3 lM mode_NE)) = evalRounded t1 lM mode_NE * evalRounded t2 lM mode_NE + evalRounded t3 lM mode_NE -> eqExprTypePrim (evalPrim (FmaExact t1 t2 t3) lP) (evalRounded (FmaExact t1 t2 t3) lM mode_NE). Proof. intros t1 t2 t3 lP lM [convt1 isconvt1] [convt2 isconvt2] [convt3 isconvt3] H0 H1. simpl. rewrite <-H1 in H0 |- *. now apply equivPrim_Fma. Qed. Lemma equivFloat_Nearbyint {Tl} : forall (t : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> eqExprTypeFloat (evalFloat (Nearbyint t) lC md) (evalRounded (Nearbyint t) lM md). Proof. intros t lC md lM [fint eqt]. generalize (Bnearbyint_correct _ _ HPrec_lt_emax mode_NE (evalFloat t lC md)). unfold eqExprTypeFloat. simpl. intros [H0 [H1 _]]. unfold FPnearbyint. rewrite H1, H0. now split; [| rewrite <-eqt]. Qed. Lemma equivPrim_Nearbyint {Tl} : forall (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> eqExprTypePrim (evalPrim (Nearbyint t) lP) (evalRounded (Nearbyint t) lM mode_NE). Proof. intros t lP lM [fint eqt]. generalize (Bnearbyint_correct _ _ HPrec_lt_emax mode_NE (P2C (evalPrim t lP))). unfold eqExprTypePrim. simpl. rewrite <-2is_finite_SF_B2SF. intros [H0 [H1 _]]. unfold FPnearbyint. rewrite <-B2SF_Prim2B, SF2R_B2SF, Prim2B_B2Prim. change prec with Rrnd.prec. change emax with Rrnd.emax. rewrite <-eqt, H1, H0. rewrite B2SF_Prim2B. split; [easy |]. now rewrite <-B2SF_Prim2B, SF2R_B2SF. Qed. Lemma ZnearestE_plus_even : forall x n, Z.even n = true -> (ZnearestE x + n = ZnearestE (x + IZR n))%Z. Proof. intros x n Hneven. unfold ZnearestE, Zceil. rewrite Ropp_plus_distr, <-opp_IZR, <-2Zfloor_add, plus_IZR. ring_simplify (x + IZR n - (IZR (Zfloor x) + IZR n)). rewrite Z.even_add_even by now apply Z.even_spec. case negb, Rcompare; ring. Qed. Lemma aux_2 : generic_format radix2 (fexp prec emax) (Rpow2 53 - 1). Proof. simpl. rewrite <-minus_IZR. simpl. apply generic_format_FLT. exists (Float radix2 9007199254740991 0); [| easy..]. unfold F2R. simpl. symmetry. apply Rmult_1_r. Qed. Lemma aux_3 : forall x', x' <= Rpow2 53 - 1 -> round radix2 (fexp prec emax) ZnearestE x' < Rpow2 53. Proof. intros x' Hx'. apply Rle_lt_trans with (Rpow2 53 - 1); [| lra]. now apply round_le_generic; [now apply FLT_exp_valid | apply valid_rnd_N | apply aux_2 |]. Qed. Lemma aux_4 : forall (x : binary_float prec emax), -2251799813685248 <= B2R x <= 2251799813685247 -> Rpow2 52 <= B2R x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1. Proof. intros x Hx. cbn -[IZR Rplus Ropp Rmult Rinv]. unfold F2R; simpl. lra. Qed. Lemma fastnearbyint_correct : forall x, is_finite (Prim2B x) = true -> -2251799813685248 <= B2R (Prim2B x) <= 2251799813685247 -> (* TODO: float --> R *) Uint63.to_Z (normfr_mantissa (fst (frshiftexp (x + 6755399441055744)))) = (ZnearestE (SF2R radix2 (Prim2SF x)) + 6755399441055744)%Z. Proof. intros x Hfinx Hx. (* C3 *) destruct frshiftexp as (m, e) eqn:Heqaux. simpl. (* C4 *) rewrite normfr_mantissa_equiv. (* A2 *) assert (Hbndexpr_aux : Rpow2 52 <= B2R (Prim2B x) + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1) by now apply aux_4. (* A3 <- A2 *) generalize (Bplus_correct prec emax Hprec Hmax mode_NE (Prim2B x) (Prim2B 6755399441055744) Hfinx). rewrite Rlt_bool_true; [intros [Hplus_1 [Hplus_2 Hplus_3]]; [easy |] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. generalize (aux_4 _ Hx); cbn -[Rle Rplus IZR Prim2B]. lra. } (* clear Hplus_2 Hplus_3 Hfinx. *) (* A4 <- A3, A2 *) assert (Hx' : Rpow2 52 <= B2R (Prim2B (x + 6755399441055744)) < Rpow2 53). { rewrite add_equiv, Hplus_1. split. - now apply round_ge_generic; [apply FLT_exp_valid | apply valid_rnd_N | apply generic_format_bpow | apply aux_4]. - now apply aux_3, aux_4. } (* clear Hplus_1. *) (* A5 <- A4 *) assert (Hfinsx : is_finite_strict (Prim2B (x + 6755399441055744)) = true). { unfold is_finite_strict. destruct (Prim2B (x + 6755399441055744)); [.. | easy]; simpl in Hx'; lra. } (* clear Hx. *) (* A6 <- A5, C3 *) generalize (frshiftexp_equiv (x + 6755399441055744)). rewrite Heqaux. intros Hfrexp_aux. simpl. generalize (Bfrexp_correct prec emax Hprec (Prim2B (x + 6755399441055744)) Hfinsx). rewrite <-Hfrexp_aux. intros [Hfrexp_1 [Hfrexp_2 Hfrexp_3]]; [easy |]. clear Hfinsx Heqaux Hfrexp_aux (* Hfrexp_1 Hfrexp_3 *). (* A7 <- A6 *) generalize (Bnormfr_mantissa_correct prec emax Hprec (Prim2B m) Hfrexp_2). intros Hnormfr. (* clear Hfrexp_2. *) (* C5 <- A7, C4 *) destruct (Prim2B m) as [| | | sm mm em Hem]; [easy.. |]. (* C6 <- C5 *) destruct Hnormfr as [Hnormfr_1 [Hnormfr_2 ->]]. rewrite Hnormfr_1. simpl. (* clear Hem Hnormfr_1 Hnormfr_2. *) (* <- *) set (e' := mag_val _ _ (mag radix2 (B2R (Prim2B (x + 6755399441055744))))). fold e' in Hfrexp_3. rewrite add_equiv in Hx', Hfrexp_1. rewrite Hfrexp_3 in Hfrexp_1. rewrite Hfrexp_1 in Hplus_1, Hx'. assert (He' : e' = 53%Z). { clear -Hx' Hfrexp_2. rewrite <-(Rabs_pos_eq (B2R _)) in Hx'. 2: { clear Hfrexp_2. clearbody e'. generalize (bpow_gt_0 radix2 e'). cbn -[Rle Rlt Rmult B2R prec] in Hx'. nra. } revert Hx' Hfrexp_2. generalize (Rabs (B2R (B754_finite sm mm (- prec) Hem))). intros r H0 Hr. generalize H0; intros H1. destruct H0 as [H00 H01]. destruct H1 as [H10 H11]. apply (Rmult_le_compat_r (Rpow2 (-54))) in H00; [| now apply bpow_ge_0]. apply (Rmult_lt_compat_r (Rpow2 (-54))) in H01; [| now apply bpow_gt_0]. apply (Rmult_le_compat_r (Rpow2 (-52))) in H10; [| now apply bpow_ge_0]. apply (Rmult_lt_compat_r (Rpow2 (-52))) in H11; [| now apply bpow_gt_0]. rewrite <-bpow_plus in H00, H01, H10, H11. simpl Z.add in H00, H01, H10, H11. assert (Hr' : 0 < r) by lra. change (/ 2) with (Rpow2 (-1)) in Hr. change 1 with (Rpow2 0) in Hr. assert (Haux: Rpow2 (-54) * Rpow2 (e') < 1 < Rpow2 (-52) * Rpow2 (e')) by nra. change 1 with (Rpow2 0) in Haux. rewrite <-2bpow_plus in Haux. destruct Haux as [Hauxl Hauxr]. apply lt_bpow in Hauxl, Hauxr. lia. } rewrite He' in Hplus_1. rewrite <-2Prim2SF2R_Prim2B2R in Hplus_1. unfold B2R, F2R in Hplus_1. simpl in Hplus_1. field_simplify in Hplus_1; [| lra]. clear -Hbndexpr_aux Hplus_1 Hx'. destruct sm; [unfold B2R, F2R in Hx'; simpl in Hx' |]. { assert (IZR (Z.neg mm) < 0) by now apply IZR_lt. cbn -[IZR Rle Rmult Rinv bpow] in Hx'. generalize (bpow_gt_0 radix2 e'). nra. } simpl in Hplus_1. apply eq_IZR. rewrite Hplus_1. unfold round, F2R, scaled_mantissa; simpl. unfold cexp. rewrite <-2Prim2SF2R_Prim2B2R in Hbndexpr_aux. rewrite mag_unique_pos with (e := 53%Z) by (simpl Z.sub; lra). cbn. unfold F2R. simpl. rewrite 3Rmult_1_r. f_equal. symmetry. now apply ZnearestE_plus_even. Qed. Lemma equivFloat_FastNearbyint {Tl} : forall (t : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> -2251799813685248 <= evalRounded t lM md <= 2251799813685247 -> eqExprTypeFloat (evalFloat (FastNearbyint t) lC md) (evalRounded (FastNearbyint t) lM md). Proof. intros t lC md lM [finx eqt] [Hx0 Hx1]. simpl. unfold eqExprTypeFloat, convertibleFloat, isConversionFloat in *. change Rrnd.prec with prec in *. change Rrnd.emax with emax in *. rewrite <-eqt in Hx0, Hx1 |- *. set (x := evalFloat t lC md). fold x in finx, Hx0, Hx1 |- *. generalize (Bplus_correct prec emax Hprec Hmax mode_NE x (Prim2B 6755399441055744) finx eq_refl). rewrite Rlt_bool_true; [intros [Hplus_1 [Hplus_2 Hplus_3]] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. cut (Rpow2 52 <= @B2R prec emax x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. now apply aux_4. } generalize (Bminus_correct prec emax Hprec Hmax mode_NE (@Bplus prec emax _ _ mode_NE x (Prim2B 6755399441055744)) (Prim2B 6755399441055744) Hplus_2 eq_refl). rewrite Rlt_bool_true; [intros [Hminus_1 [Hminus_2 Hminus_3]] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. rewrite Hplus_1. unfold round, F2R, scaled_mantissa, cexp. simpl Fnum. simpl Fexp. rewrite mag_unique_pos with (e := 53%Z); [cbn; unfold F2R; simpl; rewrite 3Rmult_1_r |]. 2: { cut (Rpow2 52 <= @B2R prec emax x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. now apply aux_4. } rewrite <-2minus_IZR; simpl. unfold Z.sub. rewrite ZnearestE_plus_even by easy. rewrite opp_IZR. rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r, <-opp_IZR. generalize (valid_rnd_N (fun n => negb (Z.even n))). intros Hmon. apply Hmon in Hx0, Hx1. rewrite Generic_proof.Znearest_IZR in Hx0, Hx1. split; apply IZR_le; lia. } split; [easy |]. unfold FPsub, FPadd. change Rrnd.prec with prec. change Rrnd.emax with emax. unfold HPrec_gt_0, HPrec_lt_emax. rewrite Hminus_1, Hplus_1. set (x' := round _ _ _ (_ + _)). assert (Hx' : x' = x') by easy. unfold x' at 2 in Hx'. clearbody x'. unfold round, F2R, scaled_mantissa, cexp in Hx'. simpl in Hx'. rewrite mag_unique_pos with (e := 53%Z) in Hx'. 2: { cut (Rpow2 52 <= @B2R prec emax x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. now apply aux_4. } cbn in Hx' |- *. unfold F2R in Hx' |- *. simpl in Hx' |- *. rewrite 3Rmult_1_r in Hx'. rewrite <-ZnearestE_plus_even, plus_IZR in Hx' by easy. rewrite Hx'. ring_simplify (IZR (ZnearestE (@B2R prec emax x)) + 6755399441055744 - 6755399441055744 * 1). unfold Rrnd.nearbyint. unfold round at 2. unfold F2R, scaled_mantissa; simpl. rewrite 2Rmult_1_r. apply round_generic; [apply valid_rnd_N |]. clear -Hx0 Hx1. apply (valid_rnd_N (fun n => negb (Z.even n))) in Hx0, Hx1. rewrite Generic_proof.Znearest_IZR in Hx0, Hx1. apply generic_format_FLT. now exists (Float radix2 (ZnearestE (@B2R prec emax x)) 0); [unfold F2R; simpl; ring | simpl; lia |]. Qed. Lemma equivPrim_FastNearbyint {Tl} : forall (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> -2251799813685248 <= evalRounded t lM mode_NE <= 2251799813685247 -> eqExprTypePrim (evalPrim (FastNearbyint t) lP) (evalRounded (FastNearbyint t) lM mode_NE). Proof. intros t lP lM [finx eqt] [Hx0 Hx1]. simpl. unfold eqExprTypePrim, convertiblePrim, isConversionPrim in *. rewrite <-B2SF_Prim2B, is_finite_SF_B2SF in finx |- *. rewrite <-eqt, Prim2SF2R_Prim2B2R in Hx0, Hx1 |- *. set (x := (evalPrim t lP)). fold x in finx, Hx0, Hx1. rewrite sub_equiv, add_equiv. generalize (Bplus_correct prec emax Hprec Hmax mode_NE (Prim2B x) (Prim2B 6755399441055744) finx). rewrite Rlt_bool_true; [intros [Hplus_1 [Hplus_2 Hplus_3]]; [easy |] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. cut (Rpow2 52 <= B2R (Prim2B x) + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. now apply aux_4. } generalize (Bminus_correct prec emax Hprec Hmax mode_NE (Bplus mode_NE (Prim2B x) (Prim2B 6755399441055744)) (Prim2B 6755399441055744) Hplus_2). rewrite Rlt_bool_true; [intros [Hminus_1 [Hminus_2 Hminus_3]]; [easy |] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. rewrite Hplus_1. unfold round, F2R, scaled_mantissa, cexp. simpl Fnum. simpl Fexp. rewrite mag_unique_pos with (e := 53%Z); [cbn; unfold F2R; simpl; rewrite 3Rmult_1_r |]. 2: { cut (Rpow2 52 <= B2R (Prim2B x) + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. now apply aux_4. } rewrite <-2minus_IZR; simpl. unfold Z.sub. rewrite ZnearestE_plus_even by easy. rewrite opp_IZR. rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r, <-opp_IZR. generalize (valid_rnd_N (fun n => negb (Z.even n))). intros Hmon. apply Hmon in Hx0, Hx1. rewrite Generic_proof.Znearest_IZR in Hx0, Hx1. split; apply IZR_le; lia. } split; [easy |]. rewrite SF2R_B2SF, Hminus_1, Hplus_1. set (x' := round _ _ _ (_ + _)). assert (Hx' : x' = x') by easy. unfold x' at 2 in Hx'. clearbody x'. unfold round, F2R, scaled_mantissa, cexp in Hx'. simpl in Hx'. rewrite mag_unique_pos with (e := 53%Z) in Hx'. 2: { cut (Rpow2 52 <= B2R (Prim2B x) + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. now apply aux_4. } cbn in Hx' |- *. unfold F2R in Hx' |- *. simpl in Hx' |- *. rewrite 3Rmult_1_r in Hx'. rewrite <-ZnearestE_plus_even, plus_IZR in Hx' by easy. rewrite Hx'. ring_simplify (IZR (ZnearestE (B2R (Prim2B x))) + 6755399441055744 - 6755399441055744 * 1). unfold Rrnd.nearbyint. unfold round at 2. unfold F2R, scaled_mantissa; simpl. rewrite 2Rmult_1_r. apply round_generic; [apply valid_rnd_N |]. clear -Hx0 Hx1. apply (valid_rnd_N (fun n => negb (Z.even n))) in Hx0, Hx1. rewrite Generic_proof.Znearest_IZR in Hx0, Hx1. apply generic_format_FLT. now exists (Float radix2 (ZnearestE (B2R (Prim2B x))) 0); [unfold F2R; simpl; ring | simpl; lia |]. Qed. Lemma equivFloat_FastNearbyintToInt {Tl} : forall (t : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> (-2147483648 <= evalRounded t lM md <= 2147483647)%R -> eqExprTypeFloat (evalFloat (FastNearbyintToInt t) lC md) (evalRounded (FastNearbyintToInt t) lM md). Proof. intros t lC md lM [finx eqt] [Hx0 Hx1]. simpl. unfold eqExprTypeFloat, convertibleFloat, isConversionFloat in *. change Rrnd.prec with prec in *. change Rrnd.emax with emax in *. rewrite <-eqt in Hx0, Hx1 |- *. set (x := evalFloat t lC md). fold x in finx, Hx0, Hx1 |- *. generalize (Bplus_correct prec emax Hprec Hmax mode_NE x (Prim2B 6755399441055744) finx eq_refl). rewrite Rlt_bool_true; [intros [Hplus_1 [Hplus_2 _]] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. cut (Rpow2 52 <= @B2R prec emax x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. apply aux_4. lra. } generalize (Bminus_correct prec emax Hprec Hmax mode_NE (@Bplus prec emax _ _ mode_NE x (Prim2B 6755399441055744)) (Prim2B 6755399441055744) Hplus_2 eq_refl). rewrite Rlt_bool_true; [intros [Hminus_1 _] |]. 2: { apply Rlt_trans with (Rpow2 53); [| now apply bpow_lt]. rewrite <-round_NE_abs by now apply FLT_exp_valid. apply aux_3, Rabs_le. rewrite Hplus_1. unfold round, F2R, scaled_mantissa, cexp. simpl Fnum. simpl Fexp. rewrite mag_unique_pos with (e := 53%Z); [cbn; unfold F2R; simpl; rewrite 3Rmult_1_r |]. 2: { cut (Rpow2 52 <= @B2R prec emax x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. apply aux_4. lra. } rewrite <-2minus_IZR; simpl. unfold Z.sub. rewrite ZnearestE_plus_even by easy. rewrite opp_IZR. rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r, <-opp_IZR. generalize (valid_rnd_N (fun n => negb (Z.even n))). intros Hmon. apply Hmon in Hx0, Hx1. rewrite Generic_proof.Znearest_IZR in Hx0, Hx1. split; apply IZR_le; lia. } split; [apply Int32.in_bounds_norm |]. unfold FPsub, FPadd. change Rrnd.prec with prec. change Rrnd.emax with emax. unfold FPtrunc, HPrec_gt_0, HPrec_lt_emax. assert (H : @Btrunc Rrnd.prec Rrnd.emax (@Bminus prec emax Hprec Hmax mode_NE (@Bplus prec emax Hprec Hmax mode_NE x (Prim2B 6755399441055744)) (Prim2B 6755399441055744)) = ZnearestE (@B2R prec emax x)). { apply eq_IZR. rewrite Btrunc_correct by easy. change Rrnd.prec with prec. change Rrnd.emax with emax. rewrite Hminus_1, Hplus_1. set (x' := round _ _ _ (_ + _)). assert (Hx' : x' = x') by easy. unfold x' at 2 in Hx'. clearbody x'. unfold round, F2R, scaled_mantissa, cexp in Hx'. simpl in Hx'. rewrite mag_unique_pos with (e := 53%Z) in Hx'. 2: { cut (Rpow2 52 <= @B2R prec emax x + B2R (Prim2B 6755399441055744) <= Rpow2 53 - 1); [unfold bpow, Z.pow_pos; simpl; lra |]. apply aux_4. lra. } cbn in Hx' |- *. unfold F2R in Hx' |- *. simpl in Hx' |- *. rewrite 3Rmult_1_r in Hx'. rewrite <-ZnearestE_plus_even, plus_IZR in Hx' by easy. rewrite Hx'. ring_simplify (IZR (ZnearestE (@B2R prec emax x)) + 6755399441055744 - 6755399441055744 * 1). rewrite round_generic. 2: apply valid_rnd_ZR. { apply round_generic; [apply valid_rnd_N |]. clear -Hx0 Hx1. apply (valid_rnd_N (fun n => negb (Z.even n))) in Hx0, Hx1. rewrite Generic_proof.Znearest_IZR in Hx0, Hx1. apply generic_format_FLT. now exists (Float radix2 (ZnearestE (@B2R prec emax x)) 0); [unfold F2R; simpl; ring | simpl; lia |]. } apply generic_round_generic; auto with typeclass_instances; [now apply fexp_correct |]. rewrite <-round_FIX_IZR. apply generic_format_round; auto with typeclass_instances. } rewrite Int32.norm_in_bounds; [easy |]. rewrite H. split; cbn. - apply Z.le_trans with (2 := Znearest_ge_floor _ _). now apply Zfloor_lub. - apply Z.le_trans with (1 := Znearest_le_ceil _ _). now apply Zceil_glb. Qed. Lemma equivPrim_FastNearbyintToInt {Tl} : forall (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> -2147483648 <= evalRounded t lM mode_NE <= 2147483647 -> eqExprTypePrim (evalPrim (FastNearbyintToInt t) lP) (evalRounded (FastNearbyintToInt t) lM mode_NE). Proof. intros t lP lM [finx eqt] H. simpl. unfold eqExprTypePrim, convertiblePrim, isConversionPrim in *. rewrite <-B2SF_Prim2B, is_finite_SF_B2SF in finx. rewrite <-eqt, Prim2SF2R_Prim2B2R in H |- *. set (x := evalPrim t lP). generalize (fastnearbyint_correct x). set (i := normfr_mantissa _). intros Hx. rewrite Sint63.sub_spec. unfold to_Z. cbn in H. fold x in H. destruct H as [Hx0 Hx1]. set (Rx := B2R (Prim2B x)). fold Rx in Hx0, Hx1. assert (HRx : (-2147483648 <= ZnearestE Rx <= 2147483647)%Z). { split; cbn. - apply Z.le_trans with (2 := Znearest_ge_floor _ _). now apply Zfloor_lub. - apply Z.le_trans with (1 := Znearest_le_ceil _ _). now apply Zceil_glb. } assert (Hi : (φ (i)%uint63 < φ (min_int)%uint63)%Z). { rewrite Hx; [| easy | unfold Rx in Hx0, Hx1; lra]. unfold min_int, Uint63.to_Z, x. simpl. rewrite Prim2SF2R_Prim2B2R. fold x Rx. lia. } destruct (Uint63.ltbP i min_int) as [_ | Hi_]; [| easy]. rewrite Hx; [| easy | unfold Rx in Hx0, Hx1; lra]. cbn. unfold Z.sub. rewrite <-Z.add_assoc. simpl. rewrite Z.add_0_r. rewrite cmod_small; [| rewrite Prim2SF2R_Prim2B2R; fold Rx; cbn; lia]. rewrite Prim2SF2R_Prim2B2R. now fold Rx. Qed. Lemma equivFloat_TruncToInt {Tl} : forall (t : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> (- Int32.N / 2 <= Ztrunc (evalRounded t lM md) <= Int32.N / 2 - 1)%Z -> eqExprTypeFloat (evalFloat (TruncToInt t) lC md) (evalRounded (TruncToInt t) lM md). Proof. intros t lC md lM [fint eqt] H. generalize (Btrunc_correct _ _ HPrec_lt_emax (evalFloat t lC md)). unfold eqExprTypeFloat. simpl. rewrite round_FIX_IZR. intros H0. apply eq_IZR in H0. rewrite <-eqt, <-H0 in H |- *. unfold FPtrunc. rewrite Int32.norm_in_bounds; [| easy]. now split. Qed. Lemma equivPrim_TruncToInt {Tl} : forall (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> (- Int32.N / 2 <= Ztrunc (evalRounded t lM mode_NE) <= Int32.N / 2 - 1)%Z -> eqExprTypePrim (evalPrim (TruncToInt t) lP) (evalRounded (TruncToInt t) lM mode_NE). Proof. intros t lP lM [fint eqt] H. generalize (Btrunc_correct _ _ HPrec_lt_emax (P2C (evalPrim t lP))). unfold eqExprTypePrim. simpl. rewrite round_FIX_IZR. intros H0. apply eq_IZR in H0. revert H. rewrite <-eqt, <-B2SF_Prim2B, SF2R_B2SF. change prec with Rrnd.prec. change emax with Rrnd.emax. rewrite <-H0. unfold FPtrunc. intros H. now rewrite Sint63.of_Z_spec, Sint63.cmod_small; [| clear -H; cbn in *; lia]. Qed. Lemma PrimInt63_opp_involutive : forall x, (- - x)%uint63 = x. Proof. intros x. apply Uint63.to_Z_inj. now rewrite 2Uint63.opp_spec, <-Z.sub_0_l, Zdiv.Zminus_mod_idemp_r, Z.sub_0_l, Z.opp_involutive, Z.mod_small; [| apply Uint63.to_Z_bounded]. Qed. Lemma PrimInt63_opp_inj : forall x y, (- x)%uint63 = (- y)%uint63 -> x = y. Proof. intros x y H. rewrite <-(PrimInt63_opp_involutive x), <-(PrimInt63_opp_involutive y). now apply f_equal. Qed. Lemma lesb_ltb : forall x, lesb 0 x = Uint63.ltb x min_int. Proof. intros x. destruct (Uint63.ltb x min_int) eqn:H; destruct (lesb 0 x) eqn:H'; [easy | | | easy]. { destruct (lebP 0 x) as [_ | P]; [easy |]. clear H'. change (to_Z 0) with 0%Z in P. unfold to_Z in P. rewrite H in P. generalize (Uint63.to_Z_bounded x); lia. } destruct (lebP 0 x) as [P | _]; [| easy]. clear H'. change (to_Z 0) with 0%Z in P. unfold to_Z in P. rewrite H in P. destruct (Uint63.ltbP x min_int) as [_ | P']; [easy |]. clear H. destruct (Uint63.eqb (- x) 0) eqn:H. { apply eqb_correct in H. change 0%uint63 with (- 0)%uint63 in H. apply PrimInt63_opp_inj in H. rewrite H in P'. cbn in P'. lia. } destruct (eqbP (- x) 0) as [_ | P'']; [easy |]. assert (H': x <> 0%uint63) by now intros ->. apply Zle_lt_or_eq in P. destruct P as [P | P]; [generalize (Uint63.to_Z_bounded (- x)); lia |]. change 0%Z with (- 0)%Z in P. apply Z.opp_inj in P. change 0%Z with (Uint63.to_Z 0) in P. apply Uint63.to_Z_inj in P. now rewrite <- P in P''. Qed. Lemma generic_format_fexp_IZR : forall n prec emax, (0 < prec)%Z -> (3 - prec < emax)%Z -> (Z.abs n <= 2 ^ prec)%Z -> generic_format radix2 (fexp prec emax) (IZR n). Proof. intros n prec emax Hprec Hemax H. apply generic_format_abs_inv. rewrite <-abs_IZR. apply generic_format_FLT. unfold SpecFloat.emin. apply Zle_lt_or_eq in H. destruct H as [H | H]. - now apply (FLT_spec _ _ _ _ (Float radix2 (Z.abs n) 0)); [unfold F2R; simpl; rewrite Rmult_1_r |simpl; rewrite Z.abs_involutive |simpl Fexp; lia]. - rewrite H. now apply (FLT_spec _ _ _ _ (Float radix2 1 prec)); [unfold F2R; simpl; rewrite Rmult_1_l; destruct prec |simpl Fnum; apply Zpower_gt_1 |simpl Fexp; lia]. Qed. Lemma equivFloat_FloatInj {Tl} : forall (t : ArithExpr Tl Integer) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> Rabs (IZR (evalRounded t lM md)) <= Rpow2 53 -> eqExprTypeFloat (evalFloat (FloatInj t) lC md) (evalRounded (FloatInj t) lM md). Proof. intros t lC md lM [bndt eqt] H. generalize (binary_normalize_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (evalRounded t lM md) 0%Z false). simpl. rewrite Rlt_bool_true. 2: { unfold F2R. simpl. rewrite Rmult_1_r. apply (Rle_lt_trans _ (IZR (Z.pow_pos 2 53))); [| now apply IZR_lt]. rewrite <-round_NE_abs; [| now apply fexp_correct]. unfold Rpow2 in H. apply round_le_generic; [now apply fexp_correct | apply valid_rnd_N | | apply H]. now apply generic_format_fexp_IZR. } unfold F2R, eqExprTypeFloat. simpl. rewrite Rmult_1_r. intros [H1 [H2 _]]. rewrite eqt. split; [easy | unfold binnorm; rewrite H1]. apply round_generic; [apply valid_rnd_N |]. rewrite <-abs_IZR in H. apply le_IZR in H. now apply generic_format_fexp_IZR. Qed. Lemma equivPrim_FloatInj {Tl} : forall (t : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> Rabs (IZR (evalRounded t lM mode_NE)) <= Rpow2 53 -> eqExprTypePrim (evalPrim (FloatInj t) lP) (evalRounded (FloatInj t) lM mode_NE). Proof. intros t lP lM [bndt eqt] H. generalize (binary_normalize_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (evalRounded t lM mode_NE) 0%Z false). simpl. rewrite Rlt_bool_true. 2: { unfold F2R. simpl. rewrite Rmult_1_r. apply (Rle_lt_trans _ (IZR (Z.pow_pos 2 53))); [| now apply IZR_lt]. rewrite <-round_NE_abs; [| now apply fexp_correct]. unfold Rpow2 in H. apply round_le_generic; [now apply fexp_correct | apply valid_rnd_N | | apply H]. now apply generic_format_fexp_IZR. } unfold F2R, eqExprTypePrim. simpl. rewrite Rmult_1_r. revert H. rewrite <-eqt. unfold to_Z, Sint63.abs. rewrite lesb_ltb. rewrite <-is_finite_SF_B2SF. intros H [H1 [H2 _]]. rewrite <-B2SF_Prim2B, SF2R_B2SF. destruct Uint63.ltb eqn:Haux'. - apply Uint63.ltb_spec in Haux'. rewrite of_int63_equiv. change prec with Rrnd.prec. change emax with Rrnd.emax. split; [assumption |]. unfold HPrec_gt_0, HPrec_lt_emax in H1. rewrite H1. apply round_generic; [apply valid_rnd_N |]. rewrite <-abs_IZR in H. apply le_IZR in H. now apply generic_format_fexp_IZR. (* keyword "rew" *) - rewrite is_finite_SF_B2SF in H2 |- *. rewrite opp_equiv, is_finite_Bopp, B2R_Bopp, of_int63_equiv. generalize (binary_normalize_correct prec emax Hprec Hmax mode_NE (Uint63.to_Z ((- evalPrim t lP)%sint63)%uint63) 0 false). unfold F2R. simpl. rewrite Rmult_1_r. rewrite Rlt_bool_true. 2: { rewrite <-Rabs_Ropp, <-round_NE_opp, <-opp_IZR, <-round_NE_abs; [| now apply fexp_correct]. apply (Rle_lt_trans _ (Rpow2 53)); [| now apply IZR_lt]. apply round_le_generic; [now apply fexp_correct | apply valid_rnd_N | | assumption]. now apply generic_format_fexp_IZR. } intros [H'1 [H'2 _]]. split; [easy |]. change Rrnd.prec with prec. change Rrnd.emax with emax. (* TODO: get rid of those lines? *) rewrite H'1, opp_IZR. apply f_equal. rewrite opp_IZR, <-Rabs_Ropp, Ropp_involutive, <-abs_IZR in H. apply le_IZR in H. apply round_generic; [apply valid_rnd_N |]. now apply generic_format_fexp_IZR. Qed. Lemma Uint63_to_Z_sqrt : forall x, Uint63.to_Z (Uint63.sqrt x) = Z.sqrt (Uint63.to_Z x). Proof. intros x. generalize (Uint63.sqrt_spec x). rewrite 2Z.pow_2_r. intros H. symmetry. now apply Z.sqrt_unique. Qed. Lemma Uint63_sqrt_small : forall x, (Uint63.sqrt x Int32.in_bounds (Uint63.to_Z (Uint63.sqrt x)). Proof. intros x H0. generalize (Uint63.sqrt_spec x), (Uint63.to_Z_bounded x). rewrite Uint63_to_Z_sqrt. change wB with 9223372036854775808%Z. intros [H1 _] H2. unfold Int32.in_bounds. simpl. lia. Qed. Lemma equivFloat_Sqrt_Integer {Tl} : forall (t : ArithExpr Tl Integer) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> (0 <= evalRounded t lM md)%Z -> (* TODO: replace hypothesis above with - IZR (Int32.N / 2) <= IZR (evalRounded t1 lM md) <= IZR (Int32.N / 2 - 1) -> *) eqExprTypeFloat (evalFloat (Sqrt t) lC md) (evalRounded (Sqrt t) lM md). Proof. intros t lC md lM [bndt eqt] nonnegt. unfold eqExprTypeFloat. simpl. rewrite eqt in bndt. rewrite eqt. split; [| easy]. clear -bndt nonnegt. revert bndt. unfold convertibleFloat, Int32.in_bounds. generalize (Z.sqrt_spec (evalRounded t lM md) nonnegt). simpl. lia. Qed. Lemma equivPrim_Sqrt_Integer {Tl} : forall (t : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> (0 <= evalRounded t lM mode_NE)%Z -> (* TODO: replace hypothesis above with - IZR (Int32.N / 2) <= IZR (evalRounded t1 lM mode_NE) <= IZR (Int32.N / 2 - 1) -> *) eqExprTypePrim (evalPrim (Sqrt t) lP) (evalRounded (Sqrt t) lM mode_NE). Proof. intros t lP lM [bndt eqt] nonnegt. unfold eqExprTypePrim. simpl in *. rewrite eqt in bndt. rewrite <-eqt in bndt, nonnegt |- *. change 0%Z with (to_Z 0) in nonnegt. apply Sint63.leb_spec in nonnegt. unfold to_Z. rewrite lesb_ltb in nonnegt. rewrite nonnegt, Uint63_sqrt_small. split; [| apply Uint63_to_Z_sqrt]. unfold to_Z in bndt. rewrite nonnegt in bndt. unfold convertiblePrim, Int32.in_bounds in bndt. simpl in bndt. apply in_bounds_to_Z_Uint63_sqrt. lia. Qed. Lemma equivFloat_Sqrt_BinFloat {Tl} : forall (t : ArithExpr Tl BinFloat) (lC : evalExprTypeFloat_list Tl) md, let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> 0 <= evalRounded t lM md -> eqExprTypeFloat (evalFloat (Sqrt t) lC md) (evalRounded (Sqrt t) lM md). Proof. intros t lC md lM [fint B2Rt] H. simpl. generalize (Bsqrt_correct _ _ HPrec_gt_0 HPrec_lt_emax md (evalFloat t lC md)). intros [H1 [H2' H3]]. assert (H2 : is_finite (@Bsqrt Rrnd.prec Rrnd.emax HPrec_gt_0 HPrec_lt_emax md (evalFloat t lC md)) = true). { destruct evalFloat; [easy.. | destruct s; [| easy]]. rewrite <-B2Rt in H. simpl in H. unfold F2R in H. simpl in H. generalize (bpow_gt_0 radix2 e). intros H'. assert (H'' : 0 <= IZR (Z.neg m)) by nra. now apply le_IZR in H''. } clear H2'. unfold eqExprTypeFloat. simpl. unfold FPsqrt. split; [assumption |]. rewrite H1. unfold Rrnd.sqrt, Rrnd.Rnd, SpecFloat.fexp, FLT_exp, SpecFloat.emin, Rrnd.emin. now rewrite B2Rt. Qed. Lemma equivPrim_Sqrt_BinFloat {Tl} : forall (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> 0 <= evalRounded t lM mode_NE -> eqExprTypePrim (evalPrim (Sqrt t) lP) (evalRounded (Sqrt t) lM mode_NE). Proof. intros t lP lM [fint B2Rt] H. simpl. generalize (Bsqrt_correct _ _ HPrec_gt_0 HPrec_lt_emax mode_NE (P2C (evalPrim t lP))). rewrite <-is_finite_SF_B2SF. intros [H1 [H2' H3]]. simpl in fint, B2Rt. unfold P2C in *. rewrite <-B2SF_Prim2B, SF2R_B2SF in B2Rt. rewrite <-B2SF_Prim2B in fint. assert (H2 : is_finite_SF (B2SF (@Bsqrt Rrnd.prec Rrnd.emax HPrec_gt_0 HPrec_lt_emax mode_NE (Prim2B (evalPrim t lP)))) = true). { destruct Prim2B; [easy.. | destruct s; [| easy]]. rewrite <-B2Rt in H. simpl in H. unfold F2R in H. simpl in H. generalize (bpow_gt_0 radix2 e). intros H'. assert (H'' : 0 <= IZR (Z.neg m)) by nra. now apply le_IZR in H''. } clear H2'. unfold eqExprTypePrim. simpl. unfold FPsqrt. rewrite <-B2SF_Prim2B, SF2R_B2SF. rewrite sqrt_equiv. split; [assumption |]. unfold FloatOps.prec, FloatOps.emax, Rrnd.prec, Rrnd.emax, Format64.prec, Format64.emax in *. unfold HPrec_gt_0, HPrec_lt_emax in H1. now rewrite H1, B2Rt. Qed. Lemma equivFloat_ArrayAcc {Tl} : forall (t : ArithExpr Tl Integer) a (lC : evalExprTypeFloat_list Tl) md, finite_array a = true -> let lM := C2M_list lC in eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md) -> (0 <= evalRounded t lM md < Uint63.to_Z (PArray.length a))%Z -> eqExprTypeFloat (evalFloat (ArrayAcc a t) lC md) (evalRounded (ArrayAcc a t) lM md). Proof. intros t a lC md H' lM [fint B2Rt] H. simpl. unfold eqExprTypeFloat. rewrite Prim2SF2R_Prim2B2R, B2Rt. split; [| easy]. unfold finite_array in H'. set (P := fun n '(i, b) => (Z.of_N n <= Uint63.to_Z (PArray.length a))%Z -> b = true -> i = Z.of_N n /\ forall j, (0 <= j < Z.of_N n)%Z -> is_finite (Prim2B a.[of_Z j]) = true). set (f := fun '(i, b) => (Z.succ i, b && is_finite_SF (Prim2SF a.[of_Z i]))). generalize (N.iter_ind (Z * bool) f (0%Z, true) P). intros H''. cut (forall n, P n (N.iter n f (0%Z, true))). 2: { apply H''; [intros _ _; split; [easy | lia] |]. intros n [i b]. simpl. intros IHn H1 H2. destruct IHn as [IHn_1 IHn_2]; [lia | now apply andb_prop in H2 |]. split; [lia |]. intros j Hj'. rewrite IHn_1 in H2. rewrite <-B2SF_Prim2B, is_finite_SF_B2SF in H2. assert (Hj : (0 <= j < Z.of_N n)%Z \/ j = Z.of_N n) by lia. clear Hj'. now destruct Hj as [Hj | ->]; [now apply IHn_2 | now apply andb_prop in H2]. } intros Haux. specialize (Haux (Z.to_N φ (PArray.length a)%uint63)). unfold P in Haux. revert H' Haux. destruct N.iter as [i b]. simpl. intros -> Hè. now apply Hè; [lia | | lia]. Qed. Lemma equivPrim_ArrayAcc {Tl} : forall (t : ArithExpr Tl Integer) a (lP : evalExprTypePrim_list Tl), finite_array a = true -> let lM := P2M_list lP in eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE) -> (0 <= evalRounded t lM mode_NE < Uint63.to_Z (PArray.length a))%Z -> eqExprTypePrim (evalPrim (ArrayAcc a t) lP) (evalRounded (ArrayAcc a t) lM mode_NE). Proof. intros t a lP H' lM [fint B2Rt] H. simpl. unfold eqExprTypeFloat. apply (f_equal of_Z) in B2Rt. rewrite of_to_Z in B2Rt. rewrite B2Rt. split; [| easy]. unfold finite_array in H'. set (P := fun n '(i, b) => (Z.of_N n <= Uint63.to_Z (PArray.length a))%Z -> b = true -> i = Z.of_N n /\ forall j, (0 <= j < Z.of_N n)%Z -> is_finite (Prim2B a.[of_Z j]) = true). set (f := fun '(i, b) => (Z.succ i, b && is_finite_SF (Prim2SF a.[of_Z i]))). generalize (N.iter_ind (Z * bool) f (0%Z, true) P). intros H''. cut (forall n, P n (N.iter n f (0%Z, true))). 2: { apply H''; [intros _ _; split; [easy | lia] |]. intros n [i b]. simpl. intros IHn H1 H2. destruct IHn as [IHn_1 IHn_2]; [lia | now apply andb_prop in H2 |]. split; [lia |]. intros j Hj'. rewrite IHn_1 in H2. rewrite <-B2SF_Prim2B, is_finite_SF_B2SF in H2. assert (Hj : (0 <= j < Z.of_N n)%Z \/ j = Z.of_N n) by lia. clear Hj'. now destruct Hj as [Hj | ->]; [now apply IHn_2 | now apply andb_prop in H2]. } intros Haux. specialize (Haux (Z.to_N φ (PArray.length a)%uint63)). unfold P in Haux. revert H' Haux. destruct N.iter as [i b] eqn:Hô. simpl. intros -> Hè. rewrite <-B2SF_Prim2B, is_finite_SF_B2SF. now apply Hè; [lia | | lia]. Qed. Theorem equivFloat {Tl T} : forall (t: ArithExpr Tl T) (lC : evalExprTypeFloat_list Tl) md, convertibleFloat_list lC -> let lM := C2M_list lC in wellBehaved t lM md -> wellFormed t = true -> eqExprTypeFloat (evalFloat t lC md) (evalRounded t lM md). Proof. simpl. intros t lC md HlC. rewrite wellBehaved_decompose. intros [IWD IOE] IWF. (* TODO: get rid of wellBehaved_decompose *) induction t as [| | | Tl T OP | Tl OP | | | | | | | | Tl T | | | |]. 2: { simpl in IWF |- *; intros. rewrite <-B2SF_Prim2B in IWF |- *. rewrite SF2R_B2SF. split; [| easy]. simpl. now rewrite <-is_finite_SF_B2SF. } 15, 16: now apply IHt. - apply equivFloat_Int. simpl in IWF. apply andb_prop in IWF. now rewrite <-Zle_is_le_bool, <-Zlt_is_lt_bool in IWF. - revert n IWD IOE IWF. induction Tl as [| T Tl]; [now destruct n |]. destruct T; (destruct n; simpl in *; [| apply IHTl]); [| easy..]. intros _ _ _. split; [apply Int32.in_bounds_norm | now apply Int32.norm_in_bounds]. - simpl in IWF. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct T. + destruct OP; simpl in *. * now apply equivFloat_Op_ADD_Integer; [apply IHt1 | apply IHt2 |]. * now apply equivFloat_Op_SUB_Integer; [apply IHt1 | apply IHt2 |]. * now apply equivFloat_Op_MUL_Integer; [apply IHt1 | apply IHt2 |]. * now apply equivFloat_Op_DIV_Integer; [apply IHt1 | apply IHt2 | |]. + destruct OP; simpl in *. * now apply equivFloat_Op_ADD_BinFloat; [apply IHt1 | apply IHt2 |]. * now apply equivFloat_Op_SUB_BinFloat; [apply IHt1 | apply IHt2 |]. * now apply equivFloat_Op_MUL_BinFloat; [apply IHt1 | apply IHt2 |]. * now apply equivFloat_Op_DIV_BinFloat; [apply IHt1 | apply IHt2 | |]. - simpl in IWF. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IOE as [IOEt1 [IOEt2 morphOp]]. now apply equivFloat_OpExact; destruct OP; simpl in *; try apply IHt1; try apply IHt2. - simpl in *. apply andb_prop in IWF. destruct IWF as [IWF IWFt3]. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IOE as [IOEt1 [IOEt2 [IOEt3 morphOp]]]. destruct IWD as [IWDt1 [IWDt2 IWDt3]]. now apply equivFloat_Fma; [apply IHt1 | apply IHt2 | apply IHt3 |]. - simpl in *. apply andb_prop in IWF. destruct IWF as [IWF IWFt3]. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IOE as [IOEt1 [IOEt2 [IOEt3 morphOp]]]. destruct IWD as [IWDt1 [IWDt2 IWDt3]]. now apply equivFloat_FmaExact; [apply IHt1 | apply IHt2 | apply IHt3 | |]. - now apply equivFloat_Nearbyint, IHt. - simpl in *. now apply equivFloat_FastNearbyint; [apply IHt |]. - simpl in *. now apply equivFloat_FastNearbyintToInt; [apply IHt |]. - simpl in *. now apply equivFloat_TruncToInt; [apply IHt |]. - simpl in *. now apply equivFloat_FloatInj; [apply IHt |]. - destruct T; simpl in *. + apply equivFloat_Sqrt_Integer; [now apply IHt |]. destruct IWD as [_ IWD]. apply le_IZR. lra. + apply equivFloat_Sqrt_BinFloat; [now apply IHt | lra]. - simpl in IWF. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IWD as [IWDt1 IWDt2]. destruct IOE as [IOEt1 IOEt2]. destruct (IHt1 lC) as [fint1 B2Rt1]; try easy. destruct T1; simpl in *; [now rewrite B2Rt1 in fint1 |- *; try easy; apply IHt2 |]. specialize (IHt2 (evalFloat t1 lC md, lC)). simpl in IHt2. rewrite B2Rt1 in IHt2. now apply IHt2. - simpl in *. apply andb_prop in IWF. now apply equivFloat_ArrayAcc; [| apply IHt |]. Qed. Theorem equivPrim {Tl T} : forall (t: ArithExpr Tl T) (lP : evalExprTypePrim_list Tl), convertiblePrim_list lP -> let lM := P2M_list lP in wellBehaved t lM mode_NE -> wellFormed t = true -> eqExprTypePrim (evalPrim t lP) (evalRounded t lM mode_NE). Proof. simpl. intros t lP HlP. rewrite wellBehaved_decompose. intros [IWD IOE] IWF. induction t as [| | | Tl T OP | Tl OP | | | | | | | | Tl T | | | |]; [| easy | ..]. 15, 16: now apply IHt. - apply equivPrim_Int. simpl in IWF. apply andb_prop in IWF. now rewrite <-Zle_is_le_bool, <-Zlt_is_lt_bool in IWF. - revert n IWD IOE IWF. induction Tl as [| T Tl]; [now destruct n |]. destruct T; (destruct n; simpl in *; [| apply IHTl]); [easy.. | split; [easy |] | easy]. unfold isConversionPrim. now rewrite <-B2SF_Prim2B, SF2R_B2SF. - simpl in IWF. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct T. + destruct OP; simpl in *. * now apply equivPrim_Op_ADD_Integer; [apply IHt1 | apply IHt2 |]. * now apply equivPrim_Op_SUB_Integer; [apply IHt1 | apply IHt2 |]. * now apply equivPrim_Op_MUL_Integer; [apply IHt1 | apply IHt2 |]. * now apply equivPrim_Op_DIV_Integer; [apply IHt1 | apply IHt2 | |]. + destruct OP; simpl in *. * now apply equivPrim_Op_ADD_BinFloat; [apply IHt1 | apply IHt2 |]. * now apply equivPrim_Op_SUB_BinFloat; [apply IHt1 | apply IHt2 |]. * now apply equivPrim_Op_MUL_BinFloat; [apply IHt1 | apply IHt2 |]. * now apply equivPrim_Op_DIV_BinFloat; [apply IHt1 | apply IHt2 | |]. - simpl in IWF. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IOE as [IOEt1 [IOEt2 morphOp]]. now apply equivPrim_OpExact; destruct OP; simpl in *; try apply IHt1; try apply IHt2. - simpl in *. apply andb_prop in IWF. destruct IWF as [IWF IWFt3]. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IOE as [IOEt1 [IOEt2 [IOEt3 morphOp]]]. destruct IWD as [IWDt1 [IWDt2 IWDt3]]. now apply equivPrim_Fma; [apply IHt1 | apply IHt2 | apply IHt3 |]. - simpl in *. apply andb_prop in IWF. destruct IWF as [IWF IWFt3]. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IOE as [IOEt1 [IOEt2 [IOEt3 morphOp]]]. destruct IWD as [IWDt1 [IWDt2 IWDt3]]. now apply equivPrim_FmaExact; [apply IHt1 | apply IHt2 | apply IHt3 | |]. - now apply equivPrim_Nearbyint, IHt. - simpl in *. now apply equivPrim_FastNearbyint; [apply IHt |]. - simpl in *. now apply equivPrim_FastNearbyintToInt; [apply IHt |]. - simpl in *. now apply equivPrim_TruncToInt; [apply IHt |]. - simpl in *. now apply equivPrim_FloatInj; [apply IHt |]. - destruct T; simpl in *. + apply equivPrim_Sqrt_Integer; [now apply IHt |]. destruct IWD as [_ IWD]. apply le_IZR. lra. + apply equivPrim_Sqrt_BinFloat; [now apply IHt | lra]. - simpl in IWF. apply andb_prop in IWF. destruct IWF as [IWFt1 IWFt2]. destruct IWD as [IWDt1 IWDt2]. destruct IOE as [IOEt1 IOEt2]. destruct (IHt1 lP) as [fint1 B2Rt1]; try easy. destruct T1; simpl in *; [now rewrite <-B2Rt1 in IWDt2, IOEt2 |- *; now apply IHt2 |]. specialize (IHt2 (evalPrim t1 lP, lP)). simpl in IHt2. rewrite <-B2Rt1 in IWDt2, IOEt2 |- *. now apply IHt2. - simpl in *. apply andb_prop in IWF. now apply equivPrim_ArrayAcc; [| apply IHt |]. Qed. interval-4.11.1/src/Language/Lang_simpl.v000066400000000000000000001513651470547631300202350ustar00rootroot00000000000000From Coq Require Import Bool Floats Reals List Lia Lra. From Flocq Require Import Core PrimFloat BinarySingleNaN Operations. Require Import Specific_bigint Specific_ops. Require Import Interval_helper. Require Import Float_full. Require Import Prog. Require Import Lang_expr. Local Open Scope R_scope. Ltac destruct_tuple := try match goal with | |- match ?t with _ => _ end => match type of t with | prod _ _ => rewrite (surjective_pairing t); destruct_tuple end end. Ltac destruct_tuple_hyp H := try match type of H with | match ?t with _ => _ end => match type of t with | prod _ _ => rewrite (surjective_pairing t) in H; destruct_tuple_hyp H end end. Ltac destruct_tuple_obj t := try match type of t with | prod _ _ => rewrite (surjective_pairing t) in *; destruct_tuple_obj (fst t) end. Fixpoint toList {Tl} : evalExprTypeReal_list Tl -> list R := match Tl with | nil => fun _ => nil | _ :: Tl' => fun l => let x := fst l in let l' := snd l in x :: toList l' end. Fixpoint exprsucc t := match t with | Tree.Evar n => Tree.Evar (S n) | Tree.Econst _ => t | Tree.Eunary op t' => Tree.Eunary op (exprsucc t') | Tree.Ebinary op t1 t2 => Tree.Ebinary op (exprsucc t1) (exprsucc t2) end. Lemma eval_exprsucc : forall t l x, Tree.eval (exprsucc t) (x :: l) = Tree.eval t l. Proof. now induction t; simpl; intros; [| | rewrite IHt | rewrite IHt1, IHt2]. Qed. (* Computable/Compatible arithmetic expressions *) Inductive CArithOp := CADD | CSUB | CMUL | CFLTDIV | CINTDIV. Definition ArithOpToCArithOp T OP := match OP with | ADD => CADD | SUB => CSUB | MUL => CMUL | DIV => match T with | Integer => CINTDIV | BinFloat => CFLTDIV end end. Definition rounding_mode_of_mode md := match md with | mode_NE | mode_NA => Basic.rnd_NE | mode_ZR => Basic.rnd_ZR | mode_DN => Basic.rnd_DN | mode_UP => Basic.rnd_UP end. Inductive CArithExpr := | CInt: Z -> CArithExpr | CBinFl: Z -> Z -> CArithExpr | CVar: nat -> CArithExpr | COp: CArithOp -> CArithExpr -> CArithExpr -> CArithExpr | CRnd: mode -> CArithExpr -> CArithExpr | CNearbyint: CArithExpr -> CArithExpr | CTrunc: CArithExpr -> CArithExpr | CLdexp: CArithExpr -> CArithExpr -> CArithExpr | CSqrt: CArithExpr -> CArithExpr. Fixpoint CArithExprToTree t := match t with | CInt n => Tree.Econst (Tree.Int n) | CBinFl n1 n2 => Tree.Ebinary Tree.Mul (Tree.Econst (Tree.Int n1)) (Tree.Econst (Tree.Bpow 2 n2)) | CVar n => Tree.Evar n | COp OP t1 t2 => let u1 := CArithExprToTree t1 in let u2 := CArithExprToTree t2 in match OP with | CADD => Tree.Ebinary Tree.Add u1 u2 | CSUB => Tree.Ebinary Tree.Sub u1 u2 | CMUL => Tree.Ebinary Tree.Mul u1 u2 | CFLTDIV => Tree.Ebinary Tree.Div u1 u2 | CINTDIV => Tree.Eunary (Tree.Nearbyint Basic.rnd_ZR) (Tree.Ebinary Tree.Div u1 u2) end | CRnd md t' => Tree.Eunary (Tree.RoundFlt (rounding_mode_of_mode md) Rrnd.emin Format64.prec) (CArithExprToTree t') | CNearbyint t' => Tree.Eunary (Tree.Nearbyint Basic.rnd_NE) (CArithExprToTree t') | CTrunc t' => Tree.Eunary (Tree.Nearbyint Basic.rnd_ZR) (CArithExprToTree t') | CLdexp t' p => Tree.Econst (Tree.Int 0) (* not compatible *) | CSqrt t' => Tree.Eunary Tree.Sqrt (CArithExprToTree t') end. Fixpoint Psucc t := match t with | CInt _ | CBinFl _ _ => t | CVar n => CVar (S n) | COp OP t1 t2 => COp OP (Psucc t1) (Psucc t2) | CRnd md t' => CRnd md (Psucc t') | CNearbyint t' => CNearbyint (Psucc t') | CTrunc t' => CTrunc (Psucc t') | CLdexp t' p => CLdexp (Psucc t') (Psucc p) | CSqrt t' => CSqrt (Psucc t') end. Lemma CArithExprToTree_Psucc : forall t, CArithExprToTree (Psucc t) = exprsucc (CArithExprToTree t). Proof. induction t as [| | | OP | | | | |]; simpl; intros. 5, 6, 7, 9: now rewrite IHt. 1, 2, 3, 5: easy. now destruct OP; rewrite IHt1; rewrite IHt2. Qed. Definition evalCArithExpr1 t l := Tree.eval (CArithExprToTree t) l. Fixpoint evalCArithExpr2 t l := match t with | CInt n => IZR n | CBinFl n1 n2 => IZR n1 * Rpow2 n2 | CVar n => nth n l R0 | COp OP t1 t2 => let x1 := evalCArithExpr2 t1 l in let x2 := evalCArithExpr2 t2 l in match OP with | CADD => (evalCArithExpr2 t1 l) + (evalCArithExpr2 t2 l) | CSUB => (evalCArithExpr2 t1 l) - (evalCArithExpr2 t2 l) | CMUL => (evalCArithExpr2 t1 l) * (evalCArithExpr2 t2 l) | CFLTDIV => (evalCArithExpr2 t1 l) / (evalCArithExpr2 t2 l) | CINTDIV => @Rrnd.nearbyint mode_ZR ((evalCArithExpr2 t1 l) / (evalCArithExpr2 t2 l)) end | CRnd md t' => round radix2 (FLT_exp emin prec) (round_mode md) (evalCArithExpr2 t' l) | CNearbyint t' => @Rrnd.nearbyint mode_NE (evalCArithExpr2 t' l) | CTrunc t' => @Rrnd.nearbyint mode_ZR (evalCArithExpr2 t' l) | CLdexp t' p => ((evalCArithExpr2 t' l) * Rpower 2 (evalCArithExpr2 p l)) | CSqrt t' => sqrt (evalCArithExpr2 t' l) end. Lemma evalCArithExpr2_succ : forall t l x, evalCArithExpr2 (Psucc t) (x :: l) = evalCArithExpr2 t l. Proof. induction t as [| | | OP | | | | |]; simpl; intros. 5, 6, 7, 9: now rewrite IHt. 1, 2, 3: easy. - now destruct OP; rewrite IHt1, IHt2. - now rewrite IHt1; rewrite IHt2. Qed. (* Computable Prop *) Inductive Atom := (*| Ne: CArithExpr -> CArithExpr -> Atom | Lt: CArithExpr -> CArithExpr -> Atom | Le: CArithExpr -> CArithExpr -> Atom | Ge: CArithExpr -> CArithExpr -> Atom | Gt: CArithExpr -> CArithExpr -> Atom | Eq: CArithExpr -> CArithExpr -> Atom | LeLe: CArithExpr -> CArithExpr -> CArithExpr -> Atom | AbsLe: CArithExpr -> CArithExpr -> Atom *) | InInt32: CArithExpr -> Atom (* - IZR (Int32.N / 2) <= t <= IZR (Int32.N / 2 - 1) *) | InInt51: CArithExpr -> Atom | InInt64: CArithExpr -> Atom (* - IZR (Int64.N / 2) <= t <= IZR (Int64.N / 2 - 1) *) | InFloat64: CArithExpr -> Atom (* Rabs t <= Rrnd.maxval *) | InFloat64Int: CArithExpr -> Atom (* Rabs t <= Rpow2 53 *) | NonZero: CArithExpr -> Atom (* t <> 0 *) | NonNeg: CArithExpr -> Atom (* 0 <= t *) | RndExact: mode -> CArithExpr -> Atom (* Rrnd.rnd t = t *) | LdexpControl: Z -> CArithExpr -> CArithExpr -> Atom (* (Rabs (evalReal _ _ t1 vars)) <= IZR (radix2 ^ Rrnd.prec - 1) * Rpow2 (n - Rrnd.prec) /\ IZR n + evalReal _ _ t2 vars <= IZR Rrnd.emax *). Definition AtomToProp g l := match g with | InInt32 t => - IZR (Int32.N / 2) <= evalCArithExpr2 t l <= IZR (Int32.N / 2 - 1) | InInt51 t => -2251799813685248 <= evalCArithExpr2 t l <= 2251799813685247 | InInt64 t => - IZR (Int64.N / 2) <= evalCArithExpr2 t l <= IZR (Int64.N / 2 - 1) | InFloat64 t => Rabs (evalCArithExpr2 t l) <= Rrnd.maxval | InFloat64Int t => Rabs (evalCArithExpr2 t l) <= Rpow2 53 | NonZero t => evalCArithExpr2 t l <> 0 | NonNeg t => 0 <= evalCArithExpr2 t l | RndExact md t => let u := evalCArithExpr2 t l in round radix2 (FLT_exp emin prec) (round_mode md) u = u | LdexpControl n t p => Rabs (evalCArithExpr2 t l) <= IZR (radix2 ^ Rrnd.prec - 1) * Rpow2 (n - Rrnd.prec) /\ IZR n + evalCArithExpr2 p l <= IZR Rrnd.emax end. Inductive CProp := | CTrue | CFalse | CAtom: Atom -> CProp (*| CNot: CProp -> CProp | COr: CProp -> CProp -> CProp *) | CAnd: CProp -> CProp -> CProp. Fixpoint CPropToProp p l := match p with | CFalse => False | CTrue => True | CAtom i => AtomToProp i l | CAnd p1 p2 => CPropToProp p1 l /\ CPropToProp p2 l end. Fixpoint simplifyCProp p := match p with | CFalse => CFalse | CTrue => CTrue | CAtom i => CAtom i | CAnd p1 p2 => match simplifyCProp p1, simplifyCProp p2 with | CTrue, p' | p', CTrue => p' | p1', p2' => CAnd p1' p2' end end. Lemma simplifyCProp_correct : forall p l, CPropToProp (simplifyCProp p) l <-> CPropToProp p l. Proof. split. - induction p; simpl; [easy.. |]. now destruct (simplifyCProp p1), (simplifyCProp p2); simpl; intros; (split; [apply IHp1 | apply IHp2]). - induction p; simpl; [easy.. |]. intros [H1 H2]. now destruct (simplifyCProp p1), (simplifyCProp p2); simpl in *; apply IHp1 in H1; apply IHp2 in H2; [easy | ..]; repeat split. Qed. (* Auxiliary functions on computables *) Fixpoint list_var_aux n init := match n with | O => nil | S n' => CVar init :: list_var_aux n' (S init) end. Lemma length_list_var_aux : forall n i, length (list_var_aux n i) = n. Proof. now induction n; [| intros i; simpl; rewrite (IHn (S i))]. Qed. Lemma nth_list_var_aux_S: forall n k i t, nth (S n) (list_var_aux (S k) i) (Psucc t) = Psucc (nth n (list_var_aux k i) t). Proof. induction n; destruct k; [easy.. |]. intros i t. simpl in *. now rewrite (IHn k (S i) t). Qed. Definition list_var n := list_var_aux n O. Lemma list_var_correct1 : forall Tl (l : evalExprTypeReal_list Tl) n, evalCArithExpr1 (nth n (list_var (length Tl)) (CInt 0)) (toList l) = nthExprTypeReal n l 0. Proof. unfold evalCArithExpr1. induction Tl as [| T' Tl]; destruct n; [easy | easy | easy |]. simpl length. simpl toList. change (CInt 0) with (Psucc (CInt 0)). unfold list_var in *. rewrite nth_list_var_aux_S. rewrite CArithExprToTree_Psucc, eval_exprsucc. now rewrite IHTl. Qed. Lemma list_var_correct2 : forall Tl (l : evalExprTypeReal_list Tl) n, evalCArithExpr2 (nth n (list_var (length Tl)) (CInt 0)) (toList l) = nthExprTypeReal n l 0. Proof. induction Tl as [| T' Tl]; destruct n; [easy | easy | easy |]. simpl length. simpl toList. change (CInt 0) with (Psucc (CInt 0)). unfold list_var in *. rewrite nth_list_var_aux_S. rewrite evalCArithExpr2_succ. now rewrite IHTl. Qed. Fixpoint compatible t := match t with | CInt _ | CBinFl _ _ | CVar _ => true | COp _ t1 t2 => andb (compatible t1) (compatible t2) | CNearbyint t | CTrunc t | CSqrt t => compatible t | CRnd md t => match md with mode_NA => false | _ => compatible t end | CLdexp _ _ => false end. Lemma compatible_correct : forall t l, compatible t = true -> evalCArithExpr1 t l = evalCArithExpr2 t l. Proof. unfold evalCArithExpr1. induction t as [| | | OP | | | | |]; simpl; intros. 6, 7: now rewrite IHt, Rrnd.nearbyint_IZR. 1, 2, 3, 6: easy. - apply andb_prop in H. destruct H as [H1 H2]. destruct OP; simpl; (rewrite IHt1, IHt2; [| easy | easy]); [easy | easy | easy | easy |]. now rewrite Rrnd.nearbyint_IZR. - destruct m; [.. | easy]; now rewrite IHt. - now rewrite IHt. Qed. Definition compatible_atom a := match a with | InInt32 t | InInt51 t | InInt64 t | InFloat64 t | InFloat64Int t | NonZero t | NonNeg t => compatible t | _ => false end. Definition add_compatibility t := (t, compatible t). (* Separate proof obligations *) Inductive BTree := | Void: BTree | Leaf: Atom -> BTree | Node: BTree -> BTree -> BTree. Fixpoint BTreeToList_aux bt acc := match bt with | Void => acc | Leaf i => i :: acc | Node bt1 bt2 => let acc' := BTreeToList_aux bt2 acc in BTreeToList_aux bt1 acc' end. Definition BTreeToList bt := BTreeToList_aux bt nil. Lemma BTreeToList_aux_concat : forall bt acc, BTreeToList_aux bt acc = BTreeToList bt ++ acc. Proof. induction bt as [| i | bt1 IHbt1 bt2 IHbt2]; [easy | easy |]. intros acc. unfold BTreeToList. simpl. rewrite IHbt2. rewrite 2IHbt1. now rewrite app_assoc. Qed. Fixpoint merge l p := match l with | nil => p | i :: l' => merge l' (CAnd p (CAtom i)) end. Lemma merge_decomp : forall l1 p l, CPropToProp (merge l1 p) l <-> CPropToProp (merge l1 CTrue) l /\ CPropToProp p l. Proof. induction l1 as [| t l1]; [easy |]. simpl. intros p l. destruct_tuple_obj t. split; intros H. - apply IHl1 in H. destruct H as [H1 H]. simpl in H. destruct H as [h H]. split; apply IHl1. + now split; [| simpl]. + now apply IHl1. - destruct H as [H1 h]. apply IHl1 in H1. destruct H1 as [H1 H]. simpl in H. apply IHl1. now split; [| simpl]. Qed. Lemma merge_app : forall l1 l2 p l, CPropToProp (merge (l1 ++ l2) p) l <-> (CPropToProp (merge l1 p) l /\ CPropToProp (merge l2 p) l). Proof. intros l1 l2 p l. rewrite (merge_decomp (l1 ++ l2)). rewrite (merge_decomp l1). rewrite (merge_decomp l2). induction l1 as [| t l1]; simpl; [easy |]. destruct_tuple_obj t. rewrite (merge_decomp (l1 ++ l2)). rewrite (merge_decomp l1). split. - intros [[H12 H] h]. simpl in H. now repeat split; try easy; apply IHl1; split. - intros [[[H1 H] h] [H2 _]]. simpl in H. repeat split; try easy. now apply IHl1. Qed. Fixpoint well_formed {Tl} : evalExprTypeReal_list Tl -> _ := match Tl with | nil => fun _ vars _ => vars = nil (* Possibly improvable *) | _ :: Tl' => fun lR vars l => let x := fst lR in let lR' := snd lR in match vars with | nil => False | (t, b) :: vars' => (b = true -> compatible t = true) /\ (evalCArithExpr2 t l) = x /\ well_formed lR' vars' l end end. Lemma well_formed_list_var_aux {Tl} : forall (lR : evalExprTypeReal_list Tl) l, well_formed lR (map add_compatibility (list_var_aux (length Tl) (length l))) (l ++ toList lR). Proof. induction Tl; [easy |]. intros [xR lR] l. simpl. repeat split. - apply nth_middle. - rewrite <-(app_nil_l (toList lR)), app_comm_cons, app_assoc. rewrite <-(last_length l xR). apply IHTl. Qed. Corollary well_formed_list_var {Tl} : forall (lR : evalExprTypeReal_list Tl), well_formed lR (map add_compatibility (list_var (length Tl))) (toList lR). Proof. intros lR. rewrite <-(app_nil_l (toList lR)). unfold list_var. fold (@length R nil). apply well_formed_list_var_aux. Qed. Fixpoint ArrayFree {Tl T} (t : ArithExpr Tl T) := match t with | Int _ _ | BinFl _ _ | Var _ _ => True | Op _ _ _ t1 t2 | OpExact _ _ t1 t2 (*| Ldexp _ _ t1 t2 *)=> ArrayFree t1 /\ ArrayFree t2 | Fma _ t1 t2 t3 | FmaExact _ t1 t2 t3 => ArrayFree t1 /\ ArrayFree t2 /\ ArrayFree t3 | Let _ _ _ t1 t2 => ArrayFree t1 /\ ArrayFree t2 | ArrayAcc _ _ _ => False | Nearbyint _ t | FastNearbyint _ t | FastNearbyintToInt _ t | TruncToInt _ t | FloatInj _ t | Sqrt _ _ t | Assert _ _ _ t | Postcond _ _ _ t => ArrayFree t end. Fixpoint decomposeToCProp {Tl T} (t : ArithExpr Tl T) vars md := match t with | Int _ n => (CInt n, true, Void, CTrue) | BinFl _ x => let f := Prim2B x in match f with | B754_zero _ => (CBinFl 0 0, true, Void, CTrue) | B754_finite s m e _ => (CBinFl (if s then Z.neg m else Z.pos m) e, true, Void, CTrue) | _ => (CInt 0%Z, false, Void, CTrue) end | Var _ n => let (u, b) := nth n vars (CInt 0%Z, false) in (u, b, Void, CTrue) | Op _ T'' OP t1 t2 => let '(u1, b1, bt1, p1) := decomposeToCProp t1 vars md in let '(u2, b2, bt2, p2) := decomposeToCProp t2 vars md in let b := andb b1 b2 in let bt := Node (if b2 then match OP with | DIV => Leaf (NonZero u2) | _ => Void end else Void) (Node bt1 bt2) in let p := CAnd (if b2 then CTrue else match OP with | DIV => CAtom (NonZero u2) | _ => CTrue end) (CAnd p1 p2) in match T'' with | Integer => let t := COp (ArithOpToCArithOp T'' OP) u1 u2 in let bt' := Node (if b then Leaf (InInt32 t) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (InInt32 t)) p in (t, b, bt', p') | BinFloat => let t := CRnd md (COp (ArithOpToCArithOp T'' OP) u1 u2) in let bt' := Node (if b then Leaf (InFloat64 t) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (InFloat64 t)) p in (t, b, bt', p') end | OpExact _ OP t1 t2 => let '(u1, b1, bt1, p1) := decomposeToCProp t1 vars md in let '(u2, b2, bt2, p2) := decomposeToCProp t2 vars md in let t := COp (ArithOpToCArithOp BinFloat OP) u1 u2 in let b := andb b1 b2 in let bt := Node (if b then match OP with | DIV => Node (Leaf (NonZero u2)) (Leaf (InFloat64 t)) | _ => Leaf (InFloat64 t) end else Void) (Node bt1 bt2) in let p := CAnd (CAnd (if b then CTrue else match OP with | DIV => CAnd (CAtom (NonZero u2)) (CAtom (InFloat64 t)) | _ => CAtom (InFloat64 t) end) (CAtom (RndExact md t))) (CAnd p1 p2) in (t, b, bt, p) | Fma _ t1 t2 t3 => let '(u1, b1, bt1, p1) := decomposeToCProp t1 vars md in let '(u2, b2, bt2, p2) := decomposeToCProp t2 vars md in let '(u3, b3, bt3, p3) := decomposeToCProp t3 vars md in let t := CRnd md (COp CADD (COp CMUL u1 u2) u3) in let b := andb (andb b1 b2) b3 in let bt := Node (if b then Leaf (InFloat64 t) else Void) (Node (Node bt1 bt2) bt3) in let p := CAnd (if b then CTrue else CAtom (InFloat64 t)) (CAnd (CAnd p1 p2) p3) in (t, b, bt, p) | FmaExact _ t1 t2 t3 => let '(u1, b1, bt1, p1) := decomposeToCProp t1 vars md in let '(u2, b2, bt2, p2) := decomposeToCProp t2 vars md in let '(u3, b3, bt3, p3) := decomposeToCProp t3 vars md in let t := COp CADD (COp CMUL u1 u2) u3 in let b := andb (andb b1 b2) b3 in let bt := Node (if b then Leaf (InFloat64 t) else Void) (Node (Node bt1 bt2) bt3) in let p := CAnd (if b then CTrue else CAtom (InFloat64 t)) (CAnd (CAnd p1 p2) p3) in (t, b, bt, CAnd p (CAtom (RndExact md t))) | Nearbyint _ t => let '(u, b, bt, p) := decomposeToCProp t vars md in (CNearbyint u, b, bt, p) | FastNearbyint _ t => let '(u, b, bt, p) := decomposeToCProp t vars md in let t := CNearbyint u in let bt' := Node (if b then Leaf (InInt51 u) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (InInt51 u)) p in (t, b, bt', p') | FastNearbyintToInt _ t => let '(u, b, bt, p) := decomposeToCProp t vars md in let t := CNearbyint u in let bt' := Node (if b then Leaf (InInt32 u) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (InInt32 u)) p in (t, b, bt', p') | TruncToInt _ t => let '(u, b, bt, p) := decomposeToCProp t vars md in let t := CTrunc u in let bt' := Node (if b then Leaf (InInt32 t) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (InInt32 t)) p in (t, b, bt', p') | FloatInj _ t => let '(u, b, bt, p) := decomposeToCProp t vars md in let bt' := Node (if b then Leaf (InFloat64Int u) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (InFloat64Int u)) p in (u, b, bt', p') (*| Ldexp _ n t1 t2 => let '(u1, _, bt1, p1) := decomposeToCProp t1 vars md in let '(u2, _, bt2, p2) := decomposeToCProp t2 vars md in let t := CRnd md (CLdexp u1 u2) in let bt := Node bt1 bt2 in let p := CAnd (CAtom (LdexpControl n u1 u2)) (CAnd p1 p2) in (t, false, bt, p) *) | Sqrt _ T'' t => let '(u, b, bt, p) := decomposeToCProp t vars md in let t := CSqrt u in let bt' := Node (if b then Leaf (NonNeg u) else Void) bt in let p' := CAnd (if b then CTrue else CAtom (NonNeg u)) p in match T'' with | Integer => (CTrunc t, b, bt', p') | BinFloat => (CRnd md t, b, bt', p') end | ArrayAcc _ _ _ => (CInt 0%Z, false, Void, CTrue) | Let _ _ _ t1 t2 => let '(u, b1, bt1, p1) := decomposeToCProp t1 vars md in let '(t, b2, bt2, p2) := decomposeToCProp t2 ((u, b1) :: vars) md in let b := b2 in let bt := Node bt2 bt1 (* Preserving some sort of order *) in let p := CAnd p1 p2 in (t, b, bt, p) | Assert _ _ _ t | Postcond _ _ _ t => decomposeToCProp t vars md end. Lemma decomposeToCProp_correct {Tl T} : forall (t : ArithExpr Tl T), ArrayFree t -> forall (lM : evalExprTypeRounded_list Tl) vars l md, md <> mode_NA -> let lR := M2R_list lM in well_formed lR vars l -> let '(t', b, bt, p) := decomposeToCProp t vars md in let l' := BTreeToList bt in ( ((b = true -> compatible t' = true) /\ (evalCArithExpr2 t' l = evalReal t lR md)) /\ forall k, compatible_atom (nth k l' (InInt32 (CInt 0))) = true) /\ (CPropToProp (merge l' p) l -> wellBehaved t lM md). Proof. assert (Haux : forall l', (forall k, compatible_atom (nth k l' (InInt32 (CInt 0))) = true) <-> map (fun p => compatible_atom p) l' = repeat true (length l')). { induction l'; [now split; [| intros _ [|]] |]. destruct IHl' as [IHl'_0 IHl'_1]. simpl. split; intros H. - rewrite (H O). now rewrite IHl'_0; [| intros k; specialize (H (S k))]. - inversion H as [[H0 H1]]. clear H. intros [| k]; [easy |]. rewrite H0 in H1. rewrite H0. now apply IHl'_1. } induction t as [| | Tl n | Tl T OP | Tl OP | | | | | | | | Tl T | | | |]; intros IAF lM vars l md Hmd lR Iwf. 16, 17: now apply IHt. 15: easy. { repeat split. now intros [|]. } (* { repeat split. now intros [|]. } (* BinFl *) *) all: simpl. - now destruct Prim2B; (split; [| easy]); [simpl; rewrite Rmult_1_r | | | unfold B2R, F2R; destruct s; simpl]; (split; [| destruct k]). - set (d := nth n vars (CInt 0, false)). destruct_tuple_obj d. unfold d. clear d. split; [| easy]. split; [| now intros [|]]. clear IAF. revert n vars l Iwf. induction Tl as [| T Tl]; [now intros [|] [|] | intros [|] [| tb vars] l Hl; destruct_tuple_obj tb; simpl]; [easy | now destruct Hl | easy |]. destruct lM as (xM, lM). apply (IHTl lM _ _ l). now simpl in Hl. - destruct IAF as [IAF1 IAF2]. specialize (IHt1 IAF1 lM vars l md Hmd Iwf). specialize (IHt2 IAF2 lM vars l md Hmd Iwf). revert IHt1 IHt2. fold lR. set (q1 := decomposeToCProp t1 vars md). destruct_tuple_obj q1. set (pq1 := snd q1). set (lq1 := snd (fst q1)). set (bq1 := snd (fst (fst q1))). set (tq1 := fst (fst (fst q1))). set (q2 := decomposeToCProp t2 vars md). destruct_tuple_obj q2. set (pq2 := snd q2). set (lq2 := snd (fst q2)). set (bq2 := snd (fst (fst q2))). set (tq2 := fst (fst (fst q2))). unfold evalCArithExpr1. intros [[[IHt1_1 IHt1_2] IHt1_3] IHt1_4] [[[IHt2_1 IHt2_2] IHt2_3] IHt2_4]. rewrite merge_decomp in IHt1_4, IHt2_4. rewrite Haux in IHt1_3, IHt2_3. destruct T; rewrite Haux. + split. { destruct bq1, bq2; (split; [split | unfold BTreeToList; simpl BTreeToList_aux]); [intros _ | | | easy | | | easy | | | easy | |]. { apply andb_true_intro. now split; [apply IHt1_1 | apply IHt2_1]. } 1, 3, 5, 7: now destruct OP; rewrite <-IHt1_2, <-IHt2_2. all: rewrite (BTreeToList_aux_concat lq1); rewrite (BTreeToList_aux_concat lq2). 2, 4: rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. 2: destruct OP; simpl; [| | | rewrite IHt2_1 by easy]; rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. destruct OP; simpl; rewrite IHt1_1, IHt2_1 by easy; simpl; rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. } rewrite merge_decomp. unfold BTreeToList. simpl. rewrite 3BTreeToList_aux_concat. rewrite 3merge_app. intros [[HOP [Hm1 [Hm2 Hm3]]] [HP [HP1 [HP2 HP3]]]]. fold (BTreeToList lq2) in Hm2. split; [now apply IHt1_4; split | split; [now apply IHt2_4; split |]]. destruct OP; [.. | split]; (destruct bq1, bq2; simpl in HOP; [destruct HOP as [H HOP] | | |]). all: simpl in *. 17-20: now apply neq_IZR; fold (M2R (evalRounded t2 lM md)); rewrite <-evalReal_evalRounded; fold lR; rewrite <-IHt2_2; destruct Hm1. 1-4: rewrite plus_IZR; fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. 1-4: rewrite minus_IZR; fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. 1-4: rewrite mult_IZR; fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. 1-4: rewrite <-Ztrunc_div_; change Ztrunc with (round_mode mode_ZR); rewrite <-Rrnd.nearbyint_IZR; fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. + split. { destruct bq1, bq2; (split; [split | unfold BTreeToList; simpl BTreeToList_aux]); [intros _ | | | easy | | | easy | | | easy | |]. { destruct md; [.. | easy]; apply andb_true_intro; now split; [apply IHt1_1 | apply IHt2_1]. } 1, 3, 5, 7: now destruct OP; rewrite <-IHt1_2, <-IHt2_2. all: rewrite (BTreeToList_aux_concat lq1); rewrite (BTreeToList_aux_concat lq2). 2, 4: rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. 2: destruct OP; simpl; [| | | rewrite IHt2_1 by easy]; rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. destruct OP; simpl; rewrite IHt1_1, IHt2_1 by easy; simpl; rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; destruct md; easy. } rewrite merge_decomp. unfold BTreeToList. simpl. rewrite 3BTreeToList_aux_concat. rewrite 3merge_app. intros [[HOP [Hm1 [Hm2 Hm3]]] [HP [HP1 [HP2 HP3]]]]. fold (BTreeToList lq2) in Hm2. split; [now apply IHt1_4; split | split; [now apply IHt2_4; split |]]. destruct OP; [.. | split]; (destruct bq1, bq2; simpl in HOP; [destruct HOP as [H HOP] | | |]). all: simpl in *. 17-20: now fold (M2R (evalRounded t2 lM md)); rewrite <-evalReal_evalRounded; fold lR; rewrite <-IHt2_2; destruct Hm1. 1-4: fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. 1-4: fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. 1-4: fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. 1-4: fold (M2R (evalRounded t1 lM md)); fold (M2R (evalRounded t2 lM md)); rewrite <-2evalReal_evalRounded; fold lR; now rewrite <-IHt1_2, <-IHt2_2. - destruct IAF as [IAF1 IAF2]. specialize (IHt1 IAF1 lM vars l md Hmd Iwf). specialize (IHt2 IAF2 lM vars l md Hmd Iwf). revert IHt1 IHt2. fold lR. set (q1 := decomposeToCProp t1 vars md). destruct_tuple_obj q1. set (pq1 := snd q1). set (lq1 := snd (fst q1)). set (bq1 := snd (fst (fst q1))). set (tq1 := fst (fst (fst q1))). set (q2 := decomposeToCProp t2 vars md). destruct_tuple_obj q2. set (pq2 := snd q2). set (lq2 := snd (fst q2)). set (bq2 := snd (fst (fst q2))). set (tq2 := fst (fst (fst q2))). unfold evalCArithExpr1. intros [[[IHt1_1 IHt1_2] IHt1_3] IHt1_4] [[[IHt2_1 IHt2_2] IHt2_3] IHt2_4]. rewrite merge_decomp in IHt1_4, IHt2_4. rewrite Haux in IHt1_3, IHt2_3. rewrite Haux. split. { destruct bq1, bq2; (split; [split | unfold BTreeToList; simpl BTreeToList_aux]); [intros _ | | | easy | | | easy | | | easy | |]. { destruct md; [.. | easy]; apply andb_true_intro; now split; [apply IHt1_1 | apply IHt2_1]. } 1, 3, 5, 7: now destruct OP; rewrite <-IHt1_2, <-IHt2_2. all: rewrite (BTreeToList_aux_concat lq1); rewrite (BTreeToList_aux_concat lq2). 2, 4: rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. 2: destruct OP; simpl; rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; easy. destruct OP; simpl; rewrite IHt1_1, IHt2_1 by easy; simpl; rewrite 2app_length, 2repeat_app, 2map_app; rewrite IHt1_3, IHt2_3; destruct md; easy. } rewrite merge_decomp. unfold BTreeToList. simpl. rewrite 3BTreeToList_aux_concat. rewrite 3merge_app. intros [[HOP [Hm1 Hm2]] [[HP HP3] [HP1 HP2]]]. fold (BTreeToList lq2) in Hm2. destruct OP; [| | | split]. 5: { fold (M2R (evalRounded t2 lM md)). rewrite <-evalReal_evalRounded. fold lR. rewrite <-IHt2_2. destruct bq1, bq2; simpl in HOP; [destruct HOP as [[_ H] HOP] | | |]; now simpl in HP. } 1-4: split; [now apply IHt1_4; split | split; [now apply IHt2_4; split | split]]. 1-8: fold (M2R (evalRounded t1 lM md)). 1-8: fold (M2R (evalRounded t2 lM md)). 1-8: rewrite <-2evalReal_evalRounded. 1-8: fold lR. 1-8: rewrite <-IHt1_2, <-IHt2_2. 1, 3, 5, 7: destruct bq1, bq2; simpl in *; now destruct HOP. 1-4: now simpl in HP3. - destruct IAF as [IAF1 [IAF2 IAF3]]. specialize (IHt1 IAF1 lM vars l md Hmd Iwf). specialize (IHt2 IAF2 lM vars l md Hmd Iwf). specialize (IHt3 IAF3 lM vars l md Hmd Iwf). revert IHt1 IHt2 IHt3. set (q1 := decomposeToCProp t1 vars md). destruct_tuple_obj q1. set (pq1 := snd q1). set (lq1 := snd (fst q1)). set (bq1 := snd (fst (fst q1))). set (tq1 := fst (fst (fst q1))). set (q2 := decomposeToCProp t2 vars md). destruct_tuple_obj q2. set (pq2 := snd q2). set (lq2 := snd (fst q2)). set (bq2 := snd (fst (fst q2))). set (tq2 := fst (fst (fst q2))). set (q3 := decomposeToCProp t3 vars md). destruct_tuple_obj q3. set (pq3 := snd q3). set (lq3 := snd (fst q3)). set (bq3 := snd (fst (fst q3))). set (tq3 := fst (fst (fst q3))). unfold evalCArithExpr1. intros [[[IHt1_1 IHt1_2] IHt1_3] IHt1_4] [[[IHt2_1 IHt2_2] IHt2_3] IHt2_4] [[[IHt3_1 IHt3_2] IHt3_3] IHt3_4]. rewrite merge_decomp in IHt1_4, IHt2_4, IHt3_4. rewrite Haux in IHt1_3, IHt2_3, IHt3_3. rewrite Haux. split. { destruct bq1, bq2, bq3; (split; [split | unfold BTreeToList; simpl BTreeToList_aux]); [intros _ | | | easy | | | easy | | | easy | | | easy | | | easy | | | easy | | | easy | |]. { destruct md; [.. | easy]; apply andb_true_intro; (split; [| now apply IHt3_1]); apply andb_true_intro; now split; [apply IHt1_1 | apply IHt2_1]. } 2: simpl; rewrite IHt1_1, IHt2_1, IHt3_1 by easy; simpl. 2, 4, 6, 8, 10, 12, 14, 16: rewrite (BTreeToList_aux_concat lq1); rewrite (BTreeToList_aux_concat lq2); rewrite (BTreeToList_aux_concat lq3); rewrite 3app_length, 3repeat_app, 3map_app; rewrite IHt1_3, IHt2_3, IHt3_3; destruct md; easy. all: now unfold lR; rewrite <-IHt1_2, <-IHt2_2, <-IHt3_2. } rewrite merge_decomp. unfold BTreeToList. simpl. rewrite 3BTreeToList_aux_concat. rewrite 3merge_app. intros [[HOP [Hm1 [Hm2 Hm3]]] [HP [[HP1 HP2] HP3]]]. fold (BTreeToList lq3) in Hm3. split; [now apply IHt1_4; split | split; [now apply IHt2_4; split | split; [now apply IHt3_4; split |]]]. destruct bq1, bq2, bq3; simpl in HOP; [destruct HOP as [_ HOP] | | | | | | |]. 1-8: simpl in HP. 1-8: fold (M2R (evalRounded t1 lM md)). 1-8: fold (M2R (evalRounded t2 lM md)). 1-8: fold (M2R (evalRounded t3 lM md)). 1-8: rewrite <-3evalReal_evalRounded. 1-8: now rewrite <-IHt1_2, <-IHt2_2, <-IHt3_2. - destruct IAF as [IAF1 [IAF2 IAF3]]. specialize (IHt1 IAF1 lM vars l md Hmd Iwf). specialize (IHt2 IAF2 lM vars l md Hmd Iwf). specialize (IHt3 IAF3 lM vars l md Hmd Iwf). revert IHt1 IHt2 IHt3. set (q1 := decomposeToCProp t1 vars md). destruct_tuple_obj q1. set (pq1 := snd q1). set (lq1 := snd (fst q1)). set (bq1 := snd (fst (fst q1))). set (tq1 := fst (fst (fst q1))). set (q2 := decomposeToCProp t2 vars md). destruct_tuple_obj q2. set (pq2 := snd q2). set (lq2 := snd (fst q2)). set (bq2 := snd (fst (fst q2))). set (tq2 := fst (fst (fst q2))). set (q3 := decomposeToCProp t3 vars md). destruct_tuple_obj q3. set (pq3 := snd q3). set (lq3 := snd (fst q3)). set (bq3 := snd (fst (fst q3))). set (tq3 := fst (fst (fst q3))). unfold evalCArithExpr1. intros [[[IHt1_1 IHt1_2] IHt1_3] IHt1_4] [[[IHt2_1 IHt2_2] IHt2_3] IHt2_4] [[[IHt3_1 IHt3_2] IHt3_3] IHt3_4]. rewrite merge_decomp in IHt1_4, IHt2_4, IHt3_4. rewrite Haux in IHt1_3, IHt2_3, IHt3_3. rewrite Haux. split. { destruct bq1, bq2, bq3; (split; [split | unfold BTreeToList; simpl BTreeToList_aux]); [intros _ | | | easy | | | easy | | | easy | | | easy | | | easy | | | easy | | | easy | |]. { destruct md; [.. | easy]; apply andb_true_intro; (split; [| now apply IHt3_1]); apply andb_true_intro; now split; [apply IHt1_1 | apply IHt2_1]. } 2: simpl; rewrite IHt1_1, IHt2_1, IHt3_1 by easy; simpl. 2, 4, 6, 8, 10, 12, 14, 16: rewrite (BTreeToList_aux_concat lq1); rewrite (BTreeToList_aux_concat lq2); rewrite (BTreeToList_aux_concat lq3); rewrite 3app_length, 3repeat_app, 3map_app; rewrite IHt1_3, IHt2_3, IHt3_3; destruct md; easy. all: now unfold lR; rewrite <-IHt1_2, <-IHt2_2, <-IHt3_2. } rewrite merge_decomp. unfold BTreeToList. simpl. rewrite 3BTreeToList_aux_concat. rewrite 3merge_app. intros [[HOP [Hm1 [Hm2 Hm3]]] [[HP [[HP1 HP2] HP3]] HP4]]. fold (BTreeToList lq3) in Hm3. split; [now apply IHt1_4; split | split; [now apply IHt2_4; split | split; [now apply IHt3_4; split |]]]. fold (M2R (evalRounded t1 lM md)). fold (M2R (evalRounded t2 lM md)). fold (M2R (evalRounded t3 lM md)). rewrite <-3evalReal_evalRounded. unfold Rrnd.fma. rewrite <-IHt1_2, <-IHt2_2, <-IHt3_2. split; [| easy]. now destruct bq1, bq2, bq3; simpl in HOP; [destruct HOP as [_ HOP] | | | | | | |]. - specialize (IHt IAF lM vars l md Hmd Iwf). revert IHt. set (q := decomposeToCProp t vars md). destruct_tuple_obj q. set (pq := snd q). set (lq := snd (fst q)). set (bq := snd (fst (fst q))). set (tq := fst (fst (fst q))). intros [[[IHt_1 IHt_2] IHt_3] IHt_4]. rewrite Haux in IHt_3. rewrite Haux. split; [| assumption]. now destruct bq; simpl; (split; [split | assumption]); [assumption | | easy |]; rewrite IHt_2. - specialize (IHt IAF lM vars l md Hmd Iwf). simpl in IHt. revert IHt. set (q := decomposeToCProp t vars md). destruct_tuple_obj q. set (pq := snd q). set (lq := snd (fst q)). set (bq := snd (fst (fst q))). set (tq := fst (fst (fst q))). intros [[[IHt_1 IHt_2] IHt_3] IHt_4]. rewrite Haux in IHt_3. rewrite Haux. destruct bq; simpl; (split; [split; [split; [assumption | now rewrite IHt_2] |] |]); [rewrite IHt_1 by easy; now apply f_equal | | assumption | unfold BTreeToList]; rewrite merge_decomp; cbn; rewrite IHt_2, evalReal_evalRounded; simpl; [intros [H0 [[_ H1] [H2 H3]]] | intros [H0 [[H2 H3] H1]]]; (split; [| easy]); apply IHt_4; rewrite merge_decomp; split; assumption. - specialize (IHt IAF lM vars l md Hmd Iwf). simpl in IHt. revert IHt. set (q := decomposeToCProp t vars md). destruct_tuple_obj q. set (pq := snd q). set (lq := snd (fst q)). set (bq := snd (fst (fst q))). set (tq := fst (fst (fst q))). intros [[[IHt_1 IHt_2] IHt_3] IHt_4]. rewrite Haux in IHt_3. rewrite Haux. destruct bq; simpl; (split; [split; [split; [assumption | now rewrite IHt_2] |] |]); [rewrite IHt_1 by easy; now apply f_equal | | assumption | unfold BTreeToList]; rewrite merge_decomp; cbn; rewrite IHt_2, evalReal_evalRounded; simpl; [intros [H0 [[_ H1] [H2 H3]]] | intros [H0 [[H2 H3] H1]]]; (split; [| easy]); apply IHt_4; rewrite merge_decomp; split; assumption. - specialize (IHt IAF lM vars l md Hmd Iwf). simpl in IHt. revert IHt. set (q := decomposeToCProp t vars md). destruct_tuple_obj q. set (pq := snd q). set (lq := snd (fst q)). set (bq := snd (fst (fst q))). set (tq := fst (fst (fst q))). intros [[[IHt_1 IHt_2] IHt_3] IHt_4]. rewrite Haux in IHt_3. rewrite Haux. destruct bq; simpl; (split; [split; [split; [assumption | now rewrite IHt_2] |] |]); [rewrite IHt_1 by easy; now apply f_equal | | assumption | unfold BTreeToList]; rewrite merge_decomp; cbn; unfold Rrnd.trunc; rewrite IHt_2, round_FIX_IZR, evalReal_evalRounded; simpl; [intros [H0 [[_ H1] [H2 H3]]] | intros [H0 [[H2 H3] H1]]]; rewrite <-opp_IZR in H2; apply le_IZR in H2, H3; (split; [| easy]); apply IHt_4; rewrite merge_decomp; split; assumption. - specialize (IHt IAF lM vars l md Hmd Iwf). simpl in IHt. revert IHt. set (q := decomposeToCProp t vars md). destruct_tuple_obj q. set (pq := snd q). set (lq := snd (fst q)). set (bq := snd (fst (fst q))). set (tq := fst (fst (fst q))). intros [[[IHt_1 IHt_2] IHt_3] IHt_4]. rewrite Haux in IHt_3. rewrite Haux. split; [split; [easy |] |]. + destruct bq; simpl; unfold BTreeToList in IHt_3; [now rewrite IHt_1, IHt_3 |]. now unfold BTreeToList. + intros H. destruct bq; rewrite merge_decomp in H; simpl in H; destruct H as [H1 [H3 H4]]; rewrite merge_decomp in H1; destruct H1 as [H1 H2]; simpl in H1, H2; destruct H2; (split; [now apply IHt_4; unfold BTreeToList; rewrite merge_decomp |]); fold (M2R (evalRounded t lM md)); rewrite <-evalReal_evalRounded; now rewrite <-IHt_2. - specialize (IHt IAF lM vars l md Hmd Iwf). simpl in IHt. revert IHt. set (q := decomposeToCProp t vars md). destruct_tuple_obj q. set (pq := snd q). set (lq := snd (fst q)). set (bq := snd (fst (fst q))). set (tq := fst (fst (fst q))). intros [[[IHt_1 IHt_2] IHt_3] IHt_4]. rewrite Haux in IHt_3. destruct T; rewrite Haux. + split; [split; [split; [easy | now simpl; unfold lR; rewrite IHt_2] |] |]. * destruct bq; simpl; unfold BTreeToList in IHt_3; [now rewrite IHt_1, IHt_3 |]. now unfold BTreeToList. * intros H. destruct bq; rewrite merge_decomp in H; simpl in H; destruct H as [H1 [H3 H4]]; rewrite merge_decomp in H1; destruct H1 as [H1 H2]; simpl in H1, H2; destruct H2; (split; [now apply IHt_4; unfold BTreeToList; rewrite merge_decomp |]); fold (M2R (evalRounded t lM md)); rewrite <-evalReal_evalRounded; rewrite <-IHt_2; lra. + split; [split; [split; [now destruct md | now simpl; unfold lR; rewrite IHt_2] |] |]. * destruct bq; simpl; unfold BTreeToList in IHt_3; [now rewrite IHt_1, IHt_3 |]. now unfold BTreeToList. * intros H. destruct bq; rewrite merge_decomp in H; simpl in H; destruct H as [H1 [H3 H4]]; rewrite merge_decomp in H1; destruct H1 as [H1 H2]; simpl in H1, H2; destruct H2; (split; [now apply IHt_4; unfold BTreeToList; rewrite merge_decomp |]); fold (M2R (evalRounded t lM md)); rewrite <-evalReal_evalRounded; rewrite <-IHt_2; lra. - set (xM := evalRounded t1 lM md). set (xR := evalReal t1 lR md). destruct IAF as [IAF1 IAF2]. specialize (IHt1 IAF1 lM vars l md Hmd Iwf). revert IHt1. set (q1 := decomposeToCProp t1 vars md). destruct_tuple_obj q1. set (pq1 := snd q1). set (lq1 := snd (fst q1)). set (bq1 := snd (fst (fst q1))). set (tq1 := fst (fst (fst q1))). unfold evalCArithExpr1. intros [[[IHt1_1 IHt1_2] IHt1_3] IHt1_4]. specialize (IHt2 IAF2 (xM, lM) ((tq1, bq1) :: vars) l md Hmd). simpl in IHt2. assert (H : (bq1 = true -> compatible tq1 = true) /\ evalCArithExpr2 tq1 l = xR /\ well_formed lR vars l). { now repeat split. } unfold xR, lR in H. rewrite evalReal_evalRounded in H. fold xM in H. specialize (IHt2 H). revert IHt2. set (q2 := decomposeToCProp t2 ((tq1, bq1) :: vars) md). destruct_tuple_obj q2. set (pq2 := snd q2). set (lq2 := snd (fst q2)). set (bq2 := snd (fst (fst q2))). set (tq2 := fst (fst (fst q2))). intros [[[IHt2_1 IHt2_2] IHt2_3] IHt2_4]. rewrite merge_decomp in IHt1_4, IHt2_4. rewrite Haux in IHt1_3, IHt2_3. rewrite Haux. split. { split; [split; [easy |]; rewrite IHt2_2; unfold xM, xR, lR; now rewrite evalReal_evalRounded |]. unfold BTreeToList. simpl. rewrite (BTreeToList_aux_concat lq1). rewrite (BTreeToList_aux_concat lq2). rewrite 2app_length, 2repeat_app, 2map_app. now rewrite IHt1_3, IHt2_3. } rewrite merge_decomp. unfold BTreeToList. simpl. rewrite 2BTreeToList_aux_concat. rewrite 2merge_app. intros [[Hm1 [Hm2 _]] [HP1 HP2]]. split; [now apply IHt1_4 | now apply IHt2_4]. Qed. Definition extractCProp {Tl T} (t : ArithExpr Tl T) md := let '(_, _, l, p) := decomposeToCProp t (map add_compatibility (list_var (length Tl))) md in (l, simplifyCProp p). Corollary extractCProp_correct {Tl T} : forall (t : ArithExpr Tl T), ArrayFree t -> forall (lM : evalExprTypeRounded_list Tl) md, md <> mode_NA -> let lR := M2R_list lM in let '(bt, p) := extractCProp t md in let l' := BTreeToList bt in (forall k, compatible_atom (nth k l' (InInt32 (CInt 0))) = true) /\ (CPropToProp (merge l' p) (toList lR) -> wellBehaved t lM md). Proof. intros t IAF lM md Hmd lR. unfold extractCProp. set (l := toList lR). set (vars := (map add_compatibility (list_var (length Tl)))). generalize (decomposeToCProp_correct t IAF lM vars l md Hmd). set (q := decomposeToCProp _ _ _). destruct_tuple_obj q. unfold vars. unfold l at 1. intros H. specialize (H (well_formed_list_var lR)). rewrite merge_decomp in H. rewrite merge_decomp. rewrite simplifyCProp_correct. split; apply H. Qed. (* Try to solve compatible goals using Interval *) Module Faux := SpecificFloat BigIntRadix2. Module Iaux := FloatIntervalFull Faux. Module IH := IntervalTacticAux Iaux. Definition prec := Faux.PtoP 80. Definition degree := 10%nat. Definition AtomToGoal g := match g with | InInt32 _ => Reify.Glele (Tree.Econst (Tree.Int (- Int32.N / 2))) (Tree.Econst (Tree.Int (Int32.N / 2 - 1))) | InInt51 _ => Reify.Glele (Tree.Econst (Tree.Int (-2251799813685248))) (Tree.Econst (Tree.Int 2251799813685247)) | InInt64 _ => Reify.Glele (Tree.Econst (Tree.Int (- Int64.N / 2))) (Tree.Econst (Tree.Int (Int64.N / 2 - 1))) | InFloat64 _ => Reify.Gabsle true (* (Tree.Econst (Tree.Int ((2 ^ 53 - 1) * 2 ^ 971))) *) (Tree.Ebinary Tree.Mul (Tree.Ebinary Tree.Sub (Tree.Econst (Tree.Bpow 2 53)) (Tree.Econst (Tree.Int 1))) (Tree.Econst (Tree.Bpow 2 971))) | InFloat64Int _ => Reify.Gabsle true (Tree.Econst (Tree.Bpow 2 53)) | NonZero _ => Reify.Gne true (Tree.Econst (Tree.Int 0)) | NonNeg _ => Reify.Gge true (Tree.Econst (Tree.Int 0)) | _ => Reify.Glt (Tree.Evar O) (* goals that we will not solve using interval. TODO: think harder about the case LdExpControl as we may be able to use interval to solve this one *) end. Definition getCArithExpr g := match g with | InInt32 t | InInt64 t | InInt51 t | InFloat64 t | InFloat64Int t | NonZero t | NonNeg t => t | _ => CInt 0 (* goals that we will not solve using interval. TODO: think harder about the case LdExpControl as we may be able to use interval to solve this one *) end. Lemma AtomToGoal_correct : forall i a l, compatible_atom a = true -> Interval.contains (Iaux.convert i) (Xreal.Xreal (Tree.eval (CArithExprToTree (getCArithExpr a)) l)) -> IH.R.eval_goal_bnd prec (AtomToGoal a) i = true -> AtomToProp a l. Proof. intros i a l Ha Hcont Heg. generalize IH.R.eval_goal_bnd_correct. intros H. specialize (H prec (AtomToGoal a) i (Tree.eval (CArithExprToTree (getCArithExpr a)) l) Hcont Heg). clear Hcont Heg. destruct a; simpl in *; [| | | unfold Rrnd.maxval;rewrite minus_IZR | | | | easy..]; apply (compatible_correct _ l) in Ha; now rewrite <-Ha. Qed. Fixpoint compareResults goals results := match goals with | nil => nil | g :: goals' => match results with | nil => nil (* should not happen in normal use *) | res :: results' => IH.R.eval_goal_bnd prec g res :: compareResults goals' results' end end. Fixpoint par_construct Al (bl : list bool) := match Al with | nil => CTrue | p :: Al' => match bl with | nil => CTrue | b :: bl' => let P := par_construct Al' bl' in if b then (CAnd P (CAtom p)) else P end end. Fixpoint par_mergerest Al (bl : list bool) P := match Al with | nil => P | p :: Al' => match bl with | nil => merge Al' (CAnd P (CAtom p)) | b :: bl' => let P' := if b then P else (CAnd P (CAtom p)) in par_mergerest Al' bl' P' end end. Lemma par_mergerest_decomp : forall Al bl P l, CPropToProp (par_mergerest Al bl P) l <-> CPropToProp (par_mergerest Al bl CTrue) l /\ CPropToProp P l. Proof. induction Al; [easy |]. intros [| [|] bl] P l; simpl; [| apply IHAl |]. - rewrite merge_decomp. rewrite (merge_decomp _ (CAnd _ _) _). now simpl. - rewrite IHAl. rewrite (IHAl _ (CAnd _ _) _). now simpl. Qed. Lemma par_construct_mergerest : forall Al bl P l, CPropToProp (par_construct Al bl) l /\ CPropToProp (par_mergerest Al bl P) l <-> CPropToProp (merge Al P) l. Proof. induction Al; intros bl P l; simpl; destruct bl; [easy.. |]. rewrite par_mergerest_decomp, merge_decomp. now case b; simpl; rewrite <-(IHAl bl). Qed. Definition generateCProp {Tl T} (t : ArithExpr Tl T) md vars hyps := let (tointerval, unsolvable) := extractCProp t md in let tointerval := BTreeToList tointerval in let lexpr := map (fun p => CArithExprToTree (getCArithExpr p)) tointerval in match extract_list lexpr vars with | Eabort => merge tointerval unsolvable | Eprog prog consts => let goals := map (fun p => AtomToGoal p) tointerval in let ieval := fun xi => IH.A.BndValuator.eval prec prog xi in let bounds := IH.compute_inputs prec hyps consts in let results := ieval bounds in let compared := compareResults goals results in par_mergerest tointerval compared unsolvable end. Theorem generateCProp_correct {Tl T} : forall (t : ArithExpr Tl T), ArrayFree t -> forall (lM : evalExprTypeRounded_list Tl) md hyps P, md <> mode_NA -> let lR := M2R_list lM in let l := toList lR in generateCProp t md (length l) hyps = P -> Reify.eval_hyps hyps l (CPropToProp P l -> wellBehaved t lM md). Proof. intros t IAF lM md hyps P Hmd lR l <-. apply (IH.R.eval_hyps_bnd_correct prec). generalize (extractCProp_correct t IAF lM md). unfold generateCProp. set (p0 := extractCProp _ _). destruct_tuple_obj p0. set (unsolved := snd p0). intros [Hm Hm'] Hh Hg; [easy |]. apply Hm'. revert Hm Hg. set (tointerval := BTreeToList (fst p0)). set (goals := map (fun p => AtomToGoal p) tointerval). set (lexpr := map (fun p => CArithExprToTree (getCArithExpr p)) tointerval). generalize (extract_list_correct lexpr l). destruct extract_list as [|prog consts]; [easy |]. intros H Hm Hg. eapply par_construct_mergerest. revert Hm Hg. set (ieval := fun xi => IH.A.BndValuator.eval prec prog xi). set (bounds := IH.compute_inputs prec hyps consts). set (results := ieval bounds). set (compared := compareResults goals results). intros Hm Hg. split; [| exact Hg]. fold ieval. fold bounds. apply (IH.app_merge_hyps_eval_bnd _ _ _ consts) in Hh. fold bounds in Hh. set (l' := l ++ map (fun c : Tree.expr => Tree.eval c nil) consts). fold l' in Hh. clear Hm' Hg. generalize (IH.A.BndValuator.eval_correct' prec prog bounds l' Hh). destruct Hh as [Hl Hh]. intros H'. clearbody tointerval. clear p0 unsolved results compared. unfold goals. clear goals. unfold ieval. clear ieval. clear T t IAF. fold lR l. clearbody l. clear Tl lM lR. clearbody bounds. unfold eval_real_nth in H. fold l' in H. revert H'. generalize (IH.A.BndValuator.eval prec prog bounds). intros l0 H'. cut (forall k, nth k (compareResults (map (fun p : Atom => AtomToGoal p) tointerval) l0) false = true -> AtomToProp (nth k tointerval (InInt32 (CInt 0))) l). { clear. revert l0. induction tointerval; [easy |]. intros l0 H''. simpl. destruct l0 as [| i l0]; [easy |]. simpl in H''. generalize (H'' O). destruct IH.R.eval_goal_bnd; intros Ha. - split; [| now apply Ha]. apply IHtointerval. intros k. apply (H'' (S k)). - apply IHtointerval. intros k. apply (H'' (S k)). } intros k Hk. destruct (Nat.lt_ge_cases k (length tointerval)) as [Hkl | Hkl]. 2: { rewrite nth_overflow in Hk; [easy |]. clear -Hkl. revert l0 k Hkl. induction tointerval; [easy |]. simpl. intros l0 k. destruct l0 as [| i l0]; [intros _; apply Nat.le_0_l |]. intros Hkl. simpl. destruct k as [| k]; [easy |]. apply le_n_S, (IHtointerval l0 k). now apply le_S_n in Hkl. } apply AtomToGoal_correct with (i := (nth k l0 Iaux.nai)) (1 := (Hm k)). - specialize (H' k). rewrite H in H' by (unfold lexpr; now rewrite map_length). unfold lexpr in H'. rewrite (Eval.nth_map_lt (InInt32 (CInt 0))) in H' by easy. apply H'. - clear -Hk Hkl. revert l0 k Hk Hkl. induction tointerval; [easy |]. simpl. intros [| i l0]; [now intros [|] |]. simpl. intros [| k]; [easy |]. simpl. intros Hk Hkl. apply IHtointerval; [easy |]. now apply Nat.succ_lt_mono. Qed. Definition generateCProp_taylor {Tl T} (t : ArithExpr Tl T) md vars hyps := let (tointerval, unsolvable) := extractCProp t md in let tointerval := BTreeToList tointerval in let lexpr := map (fun p => CArithExprToTree (getCArithExpr p)) tointerval in match extract_list lexpr vars with | Eabort => merge tointerval unsolvable | Eprog prog consts => let goals := map (fun p => AtomToGoal p) tointerval in let bounds := IH.compute_inputs prec hyps consts in match bounds with | nil => merge tointerval unsolvable | xi :: li => let li := IH.A.TaylorValuator.TM.var :: map IH.A.TaylorValuator.TM.const li in let polys := (IH.A.TaylorValuator.eval prec degree xi prog li) in let results := map (fun p => IH.A.TaylorValuator.TM.eval (prec, degree) p xi xi) polys in let compared := compareResults goals results in par_mergerest tointerval compared unsolvable end end. Theorem generateCProp_taylor_correct {Tl T} : forall (t : ArithExpr Tl T), ArrayFree t -> forall (lM : evalExprTypeRounded_list Tl) md hyps P, md <> mode_NA -> let lR := M2R_list lM in let l := toList lR in generateCProp_taylor t md (length l) hyps = P -> Reify.eval_hyps hyps l (CPropToProp P l -> wellBehaved t lM md). Proof. intros t IAF lM md hyps P Hmd lR l <-. apply (IH.R.eval_hyps_bnd_correct prec). generalize (extractCProp_correct t IAF lM md). unfold generateCProp_taylor. set (p0 := extractCProp _ _). destruct_tuple_obj p0. set (unsolved := snd p0). intros [Hm Hm'] Hh Hg; [easy |]. apply Hm'. revert Hm Hg. set (tointerval := BTreeToList (fst p0)). set (goals := map (fun p => AtomToGoal p) tointerval). set (lexpr := map (fun p => CArithExprToTree (getCArithExpr p)) tointerval). generalize (extract_list_correct lexpr l). destruct extract_list as [|prog consts]; [easy |]. intros H. unfold eval_real_nth in H. set (bounds := IH.compute_inputs prec hyps consts). destruct bounds as [| xi li] eqn:Hbounds; [easy |]. intros Hm Hg. eapply par_construct_mergerest. split; [| exact Hg]. apply (IH.app_merge_hyps_eval_bnd _ _ _ consts) in Hh. fold bounds in Hh. set (l' := l ++ map (fun c : Tree.expr => Tree.eval c nil) consts). fold l' in H, Hh. clear Hm' Hg. rewrite Hbounds in Hh. destruct Hh as [Hl Hh]. destruct l' as [| x l']; [easy |]. assert (Hh' : IH.A.contains_all li l'). { split. - now injection Hl. - intros n. apply (Hh (S n)). } generalize (fun n => IH.A.TaylorValuator.eval_correct prec degree prog li l' Hh' n xi xi x (Hh 0%nat)). intros H'. clearbody tointerval. clear p0 unsolved. unfold goals. clear goals. clear T t IAF. fold lR l. clearbody l. clear Tl lM lR. clearbody bounds. revert H'. generalize ((IH.A.TaylorValuator.eval prec degree xi prog (IH.A.TaylorValuator.TM.var :: map IH.A.TaylorValuator.TM.const li))). intros l0 H'. set (l0' := (map (fun p : IH.A.TaylorValuator.TM.T => IH.A.TaylorValuator.TM.eval (prec, degree) p xi xi) l0)). cut (forall k, nth k (compareResults (map (fun p : Atom => AtomToGoal p) tointerval) l0') false = true -> AtomToProp (nth k tointerval (InInt32 (CInt 0))) l). { generalize l0'. clear. induction tointerval; [easy |]. intros l0' H''. simpl. destruct l0' as [| i l0']; [easy |]. simpl in H''. generalize (H'' O). destruct IH.R.eval_goal_bnd; intros Ha. - split; [| now apply Ha]. apply IHtointerval. intros k. apply (H'' (S k)). - apply IHtointerval. intros k. apply (H'' (S k)). } intros k Hk. destruct (Nat.lt_ge_cases k (length tointerval)) as [Hkl | Hkl]. 2: { rewrite nth_overflow in Hk; [easy |]. clearbody l0'. clear -Hkl. revert l0' k Hkl. induction tointerval; [easy |]. simpl. intros l0' k Hkl. destruct l0' as [| i l0']; [apply Nat.le_0_l |]. simpl. destruct k as [| k]; [easy |]. apply le_n_S, (IHtointerval l0' k). now apply le_S_n in Hkl. } apply AtomToGoal_correct with (i := (nth k l0' Iaux.nai)) (1 := (Hm k)). - specialize (H' k). rewrite H in H' by (unfold lexpr; now rewrite map_length). unfold lexpr in H'. rewrite (Eval.nth_map_lt (InInt32 (CInt 0))) in H' by easy. revert Hk Hkl. unfold l0'. clear -H'. revert tointerval l0 H'. induction k. + intros [| a tointerval] [| x0 l0]; easy. + intros [| a tointerval] [| x0 l0]; try easy. simpl. intros H' Hk Hkl. apply IHk. 3: now apply Nat.succ_lt_mono. easy. easy. - clearbody l0'. clear -Hk Hkl. revert l0' k Hk Hkl. induction tointerval; [easy |]. simpl. intros [| i l0']; [now intros [|] |]. simpl. intros [| k]; [easy |]. simpl. intros Hk Hkl. apply IHtointerval; [easy |]. now apply Nat.succ_lt_mono. Qed. interval-4.11.1/src/Language/Lang_tac.v000066400000000000000000000266721470547631300176620ustar00rootroot00000000000000From Coq Require Import Reals List. From Flocq Require Import Core BinarySingleNaN Operations. Require Import Lang_expr Lang_simpl. Local Open Scope R_scope. Module Import Private. Ltac vm_reflexivity := (repeat match reverse goal with | H: _ |- _ => clear H end); vm_compute; reflexivity. Lemma destructLet : forall Tl T1 T2 (P : evalExprTypeRounded T1 -> evalExprTypeRounded T2 -> Prop) (Q : evalExprTypeRounded T1 -> Prop) (x : ArithExpr Tl T1) (t : ArithExpr (T1 :: Tl) T2) (lM : evalExprTypeRounded_list Tl) md, let xM := evalRounded x lM md in wellBehaved x lM md -> (wellBehaved x lM md -> Q (evalRounded x lM md)) -> (forall xM', Q xM' -> wellBehaved t (xM', lM) md /\ P xM' (evalRounded t (xM', lM) md)) -> wellBehaved (Let x t) lM md /\ P xM (evalRounded (Let x t) lM md). Proof. intros Tl T1 T2 P Q x t lM md xM IWB IQ H. specialize (IQ IWB). simpl. now split; [split; [assumption |] | fold xM]; apply H. Qed. Ltac do_assert_let Q := lazymatch goal with | |- context [@Let ?Tl ?T1 ?T2 ?x ?t] => let lM := lazymatch goal with | |- context [evalRounded (Let x t) ?lM ?md] => lM | |- context [evalRounded t ?lM ?md] => lM end in (* Why t and not x? *) let md := lazymatch goal with | |- context [evalRounded (Let x t) lM ?md] => md | |- context [evalRounded t lM ?md] => md end in (* Why t and not x? *) pattern (evalRounded (Let x t) lM md); pattern (evalRounded x lM md); lazymatch goal with | |- (fun vM => (fun wM => wellBehaved (Let x t) ?lM ?md /\ ?P) ?yM) ?xM => change ((fun vM => (fun wM => wellBehaved (Let x t) lM md /\ P) yM) xM) with (wellBehaved (Let x t) lM md /\ (fun vM wM => P) xM yM); apply (destructLet Tl T1 T2 (fun vM wM => P) Q x t lM) end end. Ltac remove_Let_x x xR G := match G with | context G' [wellBehaved (Let x ?t) ?lR ?md] => let G'' := context G' [wellBehaved t (xR, lR) md] in remove_Let_x x xR G'' | context G' [wellBehaved x ?lR ?md] => let G'' := context G' [True] in remove_Let_x x xR G'' | context G' [evalRounded (Let x ?t) ?lR ?md] => let G'' := context G' [evalRounded t (xR, lR) md] in remove_Let_x x xR G'' | _ => G end. Ltac do_assert_multilet Q := lazymatch goal with | |- ?G => lazymatch G with | context [@Let ?Tl ?T1 ?T2 ?x _] => let lR := lazymatch goal with | |- context [evalRounded (Let x _) ?lR ?md] => lR | |- context [evalRounded x ?lR ?md] => lR end in let md := lazymatch goal with | |- context [evalRounded (Let x _) lR ?md] => md | |- context [evalRounded x lR ?md] => md end in let xR := constr:(evalRounded x lR md) in let WBx := constr:(wellBehaved x lR md) in let G' := constr:(WBx -> Q xR) in let G'' := remove_Let_x x xR constr:(G' -> G) in let H := fresh "__H" in let xR' := fresh "__xR" in cut G'; [cut (WBx /\ G''); [intuition; try easy | split; [| generalize xR; intros xR' H; specialize (H I)]] |] end end. Ltac compute_vars v := match v with | tt => constr:(@nil R) | (?a, ?v') => let l := compute_vars v' in match True with | True => constr:(a :: l) | True => constr:(IZR a :: l) end end. Ltac compute_vars_Real v := match v with | tt => constr:(@nil R) | (?a, ?v') => let l := compute_vars v' in constr:(a :: l) end. Ltac remove P G := match G with | context G' [P /\ ?P'] => let G'' := context G' [P'] in remove P G'' | context G' [?P' /\ P] => let G'' := context G' [P'] in remove P G'' | context G' [?P' \/ P] => let G'' := context G' [True] in remove P G'' | context G' [P \/ ?P'] => let G'' := context G' [True] in remove P G'' | _ => G end. (* is_finite, is_finite_strict, B2R, fp_classsify *) Ltac replace_term t t' G := lazymatch G with | context G' [t] => let G'' := (context G' [t']) in replace_term t t' G'' | _ => G end. Ltac clean t G := lazymatch G with | context [is_finite t = ?b] => let G' := remove (is_finite t = b) G in clean t G' | context [is_finite_SF t = ?b] => let G' := remove (is_finite_SF t = b) G in clean t G' | _ => G end. Ltac do_reify_var x := revert dependent x; intros x; cut (generic_format radix2 (FLT_exp (-1074) 53) (B2R x)); [| apply generic_format_B2R]; generalize (B2R x); let r := fresh "__r" in intros r; intros; clear dependent x; revert dependent r. (* TODO: Add hypothesis -maxval <= B2R x <= maxval *) Ltac do_reify_var' x := revert dependent x; intros x; rewrite <-(Prim2SF2R_Prim2B2R x); cut (generic_format radix2 (FLT_exp (-1074) 53) (B2R (PrimFloat.Prim2B x))); [| apply generic_format_B2R]; generalize (B2R (PrimFloat.Prim2B x)); let r := fresh "__r" in intros r; intros; clear dependent x; revert dependent r. (* TODO: merge with previous tactic *) Lemma cut_Prim_Integer : forall Tl (P : PrimInt63.int -> Prop) (Q : Z -> Prop) (t : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), convertiblePrim_list lP -> let lR := P2M_list lP in wellFormed t = true -> wellBehaved t lR mode_NE -> Q (evalRounded t lR mode_NE) -> (forall x, Q (Sint63.to_Z x) -> Sint63.to_Z x = evalRounded t lR mode_NE -> P x) -> P (evalPrim t lP). Proof. intros Tl P Q t lP IC lR IWF IWB IQ H. destruct (equivPrim t lP IC IWB IWF) as [H0 H1]. apply H. now rewrite H1. easy. Qed. Lemma cut_Prim_BinFloat : forall Tl (P : PrimFloat.float -> Prop) (Q : R -> Prop) (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), convertiblePrim_list lP -> let lR := P2M_list lP in wellFormed t = true -> wellBehaved t lR mode_NE -> Q (evalRounded t lR mode_NE) -> (forall x, Q (SF2R radix2 (FloatOps.Prim2SF x)) -> is_finite_SF (FloatOps.Prim2SF x) = true -> SF2R radix2 (FloatOps.Prim2SF x) = evalRounded t lR mode_NE -> P x) -> P (evalPrim t lP). Proof. intros Tl P Q t lP IC lR IWF IWB IQ H. destruct (equivPrim t lP IC IWB IWF) as [H0 H1]. apply H. now rewrite H1. easy. easy. Qed. Lemma cut_trivial_Prim_Integer : forall Tl (P : PrimInt63.int -> Prop) (t : ArithExpr Tl Integer) (lP : evalExprTypePrim_list Tl), convertiblePrim_list lP -> let lR := P2M_list lP in wellFormed t = true -> wellBehaved t lR mode_NE -> (forall x, Sint63.to_Z x = evalRounded t lR mode_NE -> P x) -> P (evalPrim t lP). Proof. intros Tl P t lP IC lR IWF IWB H. destruct (equivPrim t lP IC IWB IWF) as [H0 H1]. apply H. now rewrite H1. Qed. Lemma cut_trivial_Prim_BinFloat : forall Tl (P : PrimFloat.float -> Prop) (t : ArithExpr Tl BinFloat) (lP : evalExprTypePrim_list Tl), convertiblePrim_list lP -> let lR := P2M_list lP in wellFormed t = true -> wellBehaved t lR mode_NE -> (forall x, is_finite_SF (FloatOps.Prim2SF x) = true -> SF2R radix2 (FloatOps.Prim2SF x) = evalRounded t lR mode_NE -> P x) -> P (evalPrim t lP). Proof. intros Tl P t lP IC lR IWF IWB H. destruct (equivPrim t lP IC IWB IWF) as [H0 H1]. apply H. easy. now rewrite H1. Qed. Ltac do_simplify_wb := let P := fresh "__P" in evar (P : Prop); lazymatch goal with | |- @wellBehaved ?Tl ?T ?t ?v ?md => let l := compute_vars v in cut P; [Reify.find_hyps l; change l with (@toList Tl (@M2R_list Tl v)); simple refine (@generateCProp_correct Tl T t _ v md _ _ _ _); [easy.. | let n := eval lazy in (length l) in change (length _) with n; vm_reflexivity |] |unfold P; clear P; cbn -[bpow (* evalCArithExpr2 *)]] end. Ltac do_simplify_wb_taylor := let P := fresh "__P" in evar (P : Prop); lazymatch goal with | |- @wellBehaved ?Tl ?T ?t ?v ?md => let l := compute_vars v in cut P; [Reify.find_hyps l; change l with (@toList Tl (@M2R_list Tl v)); eapply (@generateCProp_taylor_correct Tl T t _ v md); [easy.. | let n := eval lazy in (length l) in change (length _) with n; vm_reflexivity |] |unfold P; clear P; cbn -[bpow (* evalCArithExpr2 *)]] end. Ltac do_assert_float Q := lazymatch goal with | |- context [@evalPrim ?Tl Integer ?t ?lP] => pattern (@evalPrim Tl Integer t lP); refine (cut_Prim_Integer Tl _ Q t lP _ _ _ _ _); [ try now intuition | vm_reflexivity | simpl P2M_list ; try do_simplify_wb ; try easy | | ] | |- context [@evalPrim ?Tl BinFloat ?t ?lP] => pattern (@evalPrim Tl BinFloat t lP); refine (cut_Prim_BinFloat Tl _ Q t lP _ _ _ _ _); [ try now intuition | vm_reflexivity | simpl P2M_list ; try do_simplify_wb ; try easy | | ] end. Ltac do_remove_float := lazymatch goal with | |- context [@evalPrim ?Tl Integer ?t ?lP] => pattern (@evalPrim Tl Integer t lP); refine (cut_trivial_Prim_Integer Tl _ t lP _ _ _ _); [ try now intuition | vm_reflexivity | simpl P2M_list ; try do_simplify_wb ; try easy | ] | |- context [@evalPrim ?Tl BinFloat ?t ?lP] => pattern (@evalPrim Tl BinFloat t lP); refine (cut_trivial_Prim_BinFloat Tl _ t lP _ _ _ _); [ try now intuition | vm_reflexivity | simpl P2M_list ; try do_simplify_wb ; try easy | ] end. End Private. Ltac simplify_wb := do_simplify_wb. Ltac simplify_wb_taylor := do_simplify_wb_taylor. Ltac remove_floats := let G0 := lazymatch goal with |- ?G0 => G0 end in lazymatch goal with | |- context [@evalFloat ?Tl ?T ?t ?lC ?md] => (* clean_goal (evalFloat t lC md) G0; *) let G1 := clean (evalFloat t lC md) G0 in let G2 := replace_term (B2R (@evalFloat Tl T t lC md)) (@evalRounded Tl T t (@C2M_list Tl lC) md) G1 in let G3 := match G2 with | context G' [?g] => context G' [@wellBehaved Tl T t (@C2M_list Tl lC) md /\ g] end in let IWB := fresh "IWB" in let Hgoal := fresh "Hgoal" in let Iconv := fresh "Iconv" in let IisConv := fresh "IisConv" in cut G3; [intros [IWB Hgoal]; refine (_ (@equivFloat Tl T t lC md _ IWB _)); [intros [Iconv ->]; intuition | clear IWB Hgoal; repeat lazymatch goal with |- convertibleFloat_list _ => split ; try easy end | try easy] | simpl C2M_list] | |- context [@evalPrim ?Tl ?T ?t ?lP] => (* clean_goal (evalPrim t lC md) G0; *) let G2 := lazymatch T with | Integer => replace_term (Sint63.to_Z (@evalPrim Tl T t lP)) (@evalRounded Tl T t (@P2M_list Tl lP) mode_NE) G0 | BinFloat => let G1 := clean (FloatOps.Prim2SF (@evalPrim Tl T t lP)) G0 in replace_term (SF2R radix2 (FloatOps.Prim2SF (@evalPrim Tl T t lP))) (@evalRounded Tl T t (@P2M_list Tl lP) mode_NE) G1 end in let G3 := match G2 with | context [@evalPrim Tl T t lP] => constr:(eqExprTypePrim (@evalPrim Tl T t lP) (@evalRounded Tl T t (@P2M_list Tl lP) mode_NE) -> G2) | _ => G2 end in let G4 := constr:(@wellBehaved Tl T t (@P2M_list Tl lP) mode_NE /\ G3) in let IWB := fresh "IWB" in let Hgoal := fresh "Hgoal" in let Iconv := fresh "Iconv" in let IisConv := fresh "IisConv" in cut G4; [intros [IWB Hgoal]; refine (_ (@equivPrim Tl T t lP _ IWB _)); [let H := fresh "__H" in intros [Iconv H]; unfold isConversionPrim in H; rewrite ?H; intuition; apply Hgoal; easy | clear IWB Hgoal; repeat lazymatch goal with |- convertiblePrim_list _ => split ; try easy end | try easy] | simpl P2M_list] end. Tactic Notation "reify_var" ident(x) "as" ident(xM) ident(Hformat_xM) := do_reify_var x; intros xM Hformat_xM. Tactic Notation "reify_var'" ident(x) "as" ident(xM) ident(Hformat_xM) := do_reify_var' x; intros xM Hformat_xM. Tactic Notation "assert_let" open_constr(Q) := do_assert_let Q. Tactic Notation "assert_let" open_constr(Q) "as" ident(xM) simple_intropattern(H) := do_assert_let Q; [| | intros xM H]. Tactic Notation "assert_multilet" open_constr(Q) := do_assert_multilet Q. Tactic Notation "assert_float" open_constr(Q) := do_assert_float Q. Tactic Notation "assert_float" := do_remove_float. interval-4.11.1/src/Missing/000077500000000000000000000000001470547631300156345ustar00rootroot00000000000000interval-4.11.1/src/Missing/Coquelicot.v000066400000000000000000000376261470547631300201500ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2015-2016, Inria. Copyright (C) 2015-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Psatz. From Coquelicot Require Import Coquelicot. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop. Require Import Stdlib. Require Import MathComp. Lemma is_RInt_translation_add V g a b x Ig : @is_RInt V g (a + x) (b + x) Ig -> is_RInt (fun y : R => g (y + x)%R) a b Ig. Proof. have -> : a + x = (1 * a + x) by rewrite Rmult_1_l. have -> : b + x = (1 * b + x) by rewrite Rmult_1_l. move /is_RInt_comp_lin. apply: is_RInt_ext => t. now rewrite Rmult_1_l scal_one. Qed. Lemma is_RInt_translation_sub V g x a b Ig : @is_RInt V g (a - x) (b - x) Ig -> is_RInt (fun y : R => g (y - x)) a b Ig. Proof. exact: is_RInt_translation_add. Qed. Lemma ex_RInt_translation_add V g x a b : @ex_RInt V g a b -> @ex_RInt V (fun t => g (t + x)) (a - x) (b - x). Proof. intros [Ig HI]. exists Ig. apply: is_RInt_translation_add. by rewrite 2!Rplus_assoc Rplus_opp_l 2!Rplus_0_r. Qed. Lemma ex_RInt_translation_sub V g a b x : @ex_RInt V g a b -> @ex_RInt V (fun t => g (t - x)) (a + x) (b + x). Proof. intros [Ig HI]. exists Ig. apply: is_RInt_translation_sub. by rewrite /Rminus 2!Rplus_assoc Rplus_opp_r 2!Rplus_0_r. Qed. Lemma RInt_translation_add V g a b x : ex_RInt g (a + x) (b + x) -> @RInt V (fun y : R => g (y + x)%R) a b = RInt g (a + x) (b + x). Proof. intros HI. apply is_RInt_unique. apply is_RInt_translation_add. exact: RInt_correct. Qed. Lemma RInt_translation_sub V g a b x : ex_RInt g (a - x) (b - x) -> @RInt V (fun y : R => g (y - x)%R) a b = RInt g (a - x) (b - x). Proof. intros HI. apply is_RInt_unique. apply is_RInt_translation_sub. exact: RInt_correct. Qed. Lemma ball_to_lra a y eps : ball a eps y <-> a - eps < y < a + eps. Proof. split. - rewrite /ball /= /AbsRing_ball /abs /= /minus; move/Rabs_def2. by rewrite /plus /= /opp /=; lra. - move => Haeps. rewrite /ball /= /AbsRing_ball /abs /= /minus /= /plus /opp /= . rewrite /Rabs. case: Rcase_abs; lra. Qed. Lemma Derive_nS f n : Derive_n f n.+1 = Derive_n (Derive f) n. Proof. elim: n => [//|n IHn]. by rewrite -[in LHS]addn1 /= -addnE addn1 IHn. (* SSReflect trick *) Qed. Lemma ex_derive_nSS f n : ex_derive_n f n.+2 = ex_derive_n (Derive f) n.+1. Proof. case: n => [//|n]. by rewrite /ex_derive_n Derive_nS. Qed. Lemma ex_derive_n_is_derive_n : forall f n x l, is_derive_n f n x l -> ex_derive_n f n x. Proof. intros f [|n] x l. easy. rewrite /is_derive_n /ex_derive_n => H. eexists. apply H. Qed. Lemma ex_derive_is_derive : forall (f : R -> R) x l, is_derive f x l -> ex_derive f x. Proof. move=> f x l; rewrite /is_derive_n /ex_derive_n => H. eexists; exact: H. Qed. Lemma is_derive_ext_alt f g x (f' : R -> R) (P : R -> Prop) : P x -> open P -> (forall t : R, P t -> f t = g t) -> (forall t : R, P t -> is_derive f t (f' t)) -> is_derive g x (f' x). Proof. move=> Hx HP Hfg Hf. apply: (is_derive_ext_loc f); last exact: Hf. exact: (@locally_open _ P _ HP Hfg). Qed. (** The following two tactics allows one to easily start proving goals that have the form [forall n x, is_derive_n f n x (D n x)] or the form [forall n x, P x -> is_derive_n f n x (D n x)] Then, we obtain 3 (resp. 4) subgoals that can be proved by relying on the [auto_derive] Coquelicot tactic. See [is_derive_n_exp] or [is_derive_n_tan] for usage examples. *) Ltac help_is_derive_n_whole fresh_n fresh_x := match goal with [ |- forall n x, is_derive_n ?f n x (@?D n x) ] => let IHn := fresh "IH" fresh_n in case; [(*1: f is defined*) try done |elim=> [/=|fresh_n IHn] fresh_x; [(*2: f is derivable*) (*OPTIONAL: (try auto_derive); try done *) |apply: (@is_derive_ext _ _ (D fresh_n.+1) (Derive_n f fresh_n.+1) fresh_x _); [let t := fresh "t" in by move=> t; rewrite (is_derive_n_unique _ _ _ _ (IHn t)) |(*3: the invariant holds*) clear IHn]]] end. Ltac help_is_derive_n fresh_n fresh_x := match goal with [ |- forall n x, @?P x -> is_derive_n ?f n x (@?D n x) ] => let IHn := fresh "IH" fresh_n in let Hx := fresh "H" fresh_x in case; [(*1: f is defined*) try done |elim=> [/=|fresh_n IHn] fresh_x; [(*2: f is derivable*) (*OPTIONAL: move=> Hx; auto_derive; try done *) |move=> Hx; apply: (@is_derive_ext_alt (D fresh_n.+1) (Derive_n f fresh_n.+1) x (D fresh_n.+2) P Hx); clear fresh_x Hx; [(*3: P is open*) |let t := fresh "t" in let Ht := fresh "Ht" in by move=> t Ht; rewrite (is_derive_n_unique _ _ _ _ (IHn t Ht)) |(*4: the invariant holds*) clear IHn]]] end. Lemma is_derive_n_pow : forall m, (0 < m)%nat -> forall n x, is_derive_n (fun x => x ^ m)%R n x (\big[Rmult/1%R]_(i < n) INR (m - i) * x ^ (m - n))%R. Proof. move=> m Hm; help_is_derive_n_whole n x. - move=> x; rewrite big1 /= ?(addn0, subn0, Rmult_1_l) //. by case. - auto_derive =>//. by rewrite big_ord_recl big_ord0 /= subn0 subn1 /= Rmult_1_l Rmult_1_r. - auto_derive =>//. rewrite [in RHS]big_ord_recr /= /Rdiv; rewrite Rmult_assoc; congr Rmult. by rewrite Rmult_1_l !subnS. Qed. Lemma is_derive_n_inv_pow : forall m, (0 < m)%nat -> forall n x, x <> 0 -> is_derive_n (fun x => / x ^ m)%R n x (\big[Rmult/1%R]_(i < n) - INR (m + i) / x ^ (m + n))%R. Proof. move=> m Hm; help_is_derive_n n x. - move=> x Hx; rewrite big1 /= ?addn0; first by field; apply: pow_nonzero. by case. - move=> Hx; auto_derive; first by apply: pow_nonzero. rewrite big_ord_recl big_ord0 /= addn0 addn1 /= Rmult_1_l Rmult_1_r. apply: Rdiv_eq_reg. rewrite -(prednK Hm); simpl; ring. apply: Rmult_neq0; exact: pow_nonzero. by apply: Rmult_neq0; try apply: pow_nonzero. - exact: open_neq. - move=> t Ht; auto_derive; first exact: pow_nonzero. rewrite [in RHS]big_ord_recr /= /Rdiv; rewrite Rmult_assoc; congr Rmult. rewrite Rmult_1_l; apply: Rdiv_eq_reg; first last. exact: pow_nonzero. apply: Rmult_neq0; exact: pow_nonzero. rewrite !addnS /=; ring. Qed. Lemma is_derive_n_powerRZ m n x : (0 <= m)%Z \/ x <> 0 -> is_derive_n (powerRZ^~ m) n x (match m with | Z0 => if n is O then 1%R else 0%R | Z.pos p => \big[Rmult/1%R]_(i < n) INR (Pos.to_nat p - i) * x ^ (Pos.to_nat p - n) | Z.neg p => \big[Rmult/1%R]_(i < n) - INR (Pos.to_nat p + i) * / x ^ (Pos.to_nat p + n) end). Proof. move=> Hor. rewrite /powerRZ; case: m Hor => [|p|p] Hor. - case: n => [|n] //; exact: is_derive_n_const. - by apply: is_derive_n_pow; apply/ltP/Pos2Nat.is_pos. - apply: is_derive_n_inv_pow; first exact/ltP/Pos2Nat.is_pos. by case: Hor; first by case. Qed. Lemma ex_derive_n_powerRZ m n x : (0 <= m)%Z \/ x <> 0 -> ex_derive_n (powerRZ^~ m) n x. Proof. by move=> Hor; eapply ex_derive_n_is_derive_n; eapply is_derive_n_powerRZ. Qed. Lemma is_derive_n_Rpower n a x : 0 < x -> is_derive_n (Rpower^~ a) n x (\big[Rmult/1%R]_(i < n) (a - INR i) * Rpower x (a - INR n)). Proof. move: a x; elim: n => [|n IHn] a x Hx. rewrite big_ord0. by rewrite /= Rmult_1_l Rminus_0_r. apply is_derive_Sn. apply: locally_open x Hx. apply open_gt. move => /= x Hx. eexists. now apply is_derive_Reals, derivable_pt_lim_power. apply is_derive_n_ext_loc with (fun x => a * Rpower x (a - 1)). apply: locally_open x Hx. apply open_gt. move => /= x Hx. apply sym_eq, is_derive_unique. now apply is_derive_Reals, derivable_pt_lim_power. rewrite big_ord_recl; rewrite [INR ord0]/= Rminus_0_r Rmult_assoc. apply is_derive_n_scal_l. rewrite S_INR. replace (a - (INR n + 1)) with (a - 1 - INR n) by ring. rewrite (eq_bigr (P := xpredT) (fun i2 : 'I_n => a - 1 - INR i2)); last first. move=> [i Hi] _; rewrite plus_INR /=; ring. exact: IHn. Qed. Lemma is_derive_n_inv n x : x <> 0 -> is_derive_n Rinv n x (\big[Rmult/1%R]_(i < n) - INR (1 + i) * / x ^ (1 + n))%R. Proof. move=> Hx. have := is_derive_n_powerRZ (-1) n x (or_intror Hx). apply: is_derive_n_ext. by move=> t; rewrite /= Rmult_1_r. Qed. Lemma is_derive_n_ln n x : 0 < x -> is_derive_n ln n x (match n with | 0 => ln x | n.+1 => (\big[Rmult/1%R]_(i < n) - INR (1 + i) * / x ^ (1 + n))%R end). Proof. case: n => [|n] Hx; first done. apply is_derive_Sn. apply: locally_open x Hx. apply open_gt. move => /= x Hx. eexists. now apply is_derive_Reals, derivable_pt_lim_ln. have := is_derive_n_inv n x (Rgt_not_eq _ _ Hx). apply: is_derive_n_ext_loc. apply: locally_open x Hx. apply open_gt. move => /= x Hx. apply sym_eq, is_derive_unique. now apply is_derive_Reals, derivable_pt_lim_ln. Qed. Lemma is_derive_n_sqrt n x : 0 < x -> is_derive_n sqrt n x (\big[Rmult/1%R]_(i < n) (/2 - INR i) * Rpower x (/2 - INR n)). Proof. move=> Hx. have := is_derive_n_Rpower n (/2) x Hx. apply: is_derive_n_ext_loc. apply: locally_open x Hx. apply open_gt. exact Rpower_sqrt. Qed. Lemma is_derive_n_invsqrt n x : 0 < x -> is_derive_n (fun t => / sqrt t) n x (\big[Rmult/1%R]_(i < n) (-/2 - INR i) * Rpower x (-/2 - INR n)). Proof. move=> Hx. have := is_derive_n_Rpower n (-/2) x Hx. apply: is_derive_n_ext_loc. apply: locally_open x Hx. apply open_gt. by move=> x Hx; rewrite Rpower_Ropp Rpower_sqrt. Qed. Lemma is_derive_2n_sin n x : is_derive_n sin (n + n) x ((-1)^n * sin x). Proof. elim: n x => [|n IHn] x. by rewrite /= Rmult_1_l. rewrite -addSnnS 2!addSn /=. apply is_derive_ext with (f := fun x => (-1)^n * cos x). move => /= {} x. apply sym_eq, is_derive_unique. eapply is_derive_ext. move => /= {} x. apply sym_eq, is_derive_n_unique. apply IHn. apply is_derive_scal. apply is_derive_Reals, derivable_pt_lim_sin. replace (-1 * (-1)^n * sin x) with ((-1)^n * -sin x) by ring. apply is_derive_scal. apply is_derive_Reals, derivable_pt_lim_cos. Qed. Lemma is_derive_n_sin n (x : R) : is_derive_n sin n x (if odd n then (-1)^n./2 * cos x else ((-1)^n./2 * sin x)). Proof. rewrite -{1}(odd_double_half n); case: odd => /=. 2: rewrite -addnn; exact: is_derive_2n_sin. set n' := n./2. eapply is_derive_ext. move => /= {} x. apply sym_eq, is_derive_n_unique. rewrite -addnn; apply: is_derive_2n_sin. apply is_derive_scal. apply is_derive_Reals, derivable_pt_lim_sin. Qed. Lemma is_derive_2n_cos n x : is_derive_n cos (n + n) x ((-1)^n * cos x). Proof. elim: n x => [|n IHn] x. by rewrite /= Rmult_1_l. rewrite -addSnnS 2!addSn /=. apply is_derive_ext with (f := fun x => (-1)^n * -sin x). move => /= {} x. apply sym_eq, is_derive_unique. eapply is_derive_ext. move => /= {} x. apply sym_eq, is_derive_n_unique. apply IHn. apply is_derive_scal. apply is_derive_Reals, derivable_pt_lim_cos. replace (-1 * (-1)^n * cos x) with ((-1)^n * -cos x) by ring. apply is_derive_scal. apply: is_derive_opp. apply is_derive_Reals, derivable_pt_lim_sin. Qed. Lemma is_derive_n_cos n (x : R) : is_derive_n cos n x (if odd n then (-1)^(n./2) * - sin x else ((-1)^(n./2) * cos x)). Proof. rewrite -{1}(odd_double_half n); case: odd => /=. 2: rewrite -addnn; exact: is_derive_2n_cos. set n' := n./2. eapply is_derive_ext. move => /= {} x. apply sym_eq, is_derive_n_unique. rewrite -addnn; apply: is_derive_2n_cos. apply is_derive_scal. apply is_derive_Reals, derivable_pt_lim_cos. Qed. Lemma prod_to_single {T U V : UniformSpace} {F: (U -> Prop) -> Prop} {FF : Filter F} (G : (V -> Prop) -> Prop) x (f : T -> U -> V) : filterlim (fun tu : T * U => f tu.1 tu.2) (filter_prod (at_point x) F) G <-> filterlim (fun u : U => f x u) F G. Proof. split => H P GP. - rewrite /filtermap. destruct (H _ GP) as [Q R HAQ HFR HPf]. apply: filter_imp HFR => y HRy. exact: HPf. - specialize (H P GP). econstructor. exact: Logic.eq_refl. exact: H. by move => t u <-. Qed. Lemma prodi_to_single_l {T U V : UniformSpace} {F: (U -> Prop) -> Prop} {FF : Filter F} (G : (V -> Prop) -> Prop) x (f : T -> U -> V -> Prop) : filterlimi (fun tu : T * U => f tu.1 tu.2) (filter_prod (at_point x) F) G <-> filterlimi (fun u : U => f x u) F G. Proof. split => H P GP. - rewrite /filtermapi. destruct (H _ GP) as [Q R HAQ HFR HPf]. apply: filter_imp HFR => y HRy. exact: HPf. - specialize (H P GP). econstructor. exact: Logic.eq_refl. exact: H. by move => t u <-. Qed. Lemma prodi_to_single_r {T U V : UniformSpace} {F: (U -> Prop) -> Prop} {FF : Filter F} (G : (V -> Prop) -> Prop) x (f : U -> T -> V -> Prop) : filterlimi (fun tu : U * T => f tu.1 tu.2) (filter_prod F (at_point x)) G <-> filterlimi (fun u : U => f u x) F G. Proof. split => H P GP. - rewrite /filtermapi. destruct (H _ GP) as [Q R HAQ HFR HPf]. apply: filter_imp HAQ => y HRy. exact: HPf. - specialize (H P GP). econstructor. exact: H. exact: Logic.eq_refl. move => t u /= . by case => y Hy <-; exists y. Qed. Lemma is_RInt_gen_exp_infty a lam (Hlam : 0 < lam) : is_RInt_gen (fun x => exp (- (lam * x))) (at_point a) (Rbar_locally p_infty) (exp (-(lam * a)) / lam). Proof. rewrite /is_RInt_gen. rewrite prodi_to_single_l. apply: (filterlimi_lim_ext_loc (* (fun x => - (exp(- lam * x) - exp(-lam * a)) / lam) *)). exists a. move => x Hx. apply: (is_RInt_derive (fun x => - exp (-(lam * x)) / lam)). move => x0 Hx0. by auto_derive => // ; try field; lra. move => x0 Hx0. apply: continuous_exp_comp. apply: continuous_opp. apply: continuous_mult. exact: continuous_const. exact: continuous_id. rewrite /=. apply: (filterlim_ext (fun x => minus (exp (-(lam * a)) / lam) (exp (-(lam * x)) / lam))). move => x;rewrite /minus plus_comm; congr plus. rewrite /opp /=; field; lra. rewrite /opp /=; field; lra. rewrite /minus. apply: (filterlim_comp _ _ _ (fun x => opp (exp (-(lam * x)) / lam)) (fun x => plus (exp (- (lam * a)) / lam) x) (Rbar_locally p_infty) (locally (0)) (locally (exp (- (lam * a)) / lam))); last first. rewrite -[X in (_ _ _ (locally X))]Rplus_0_r. apply: (continuous_plus (fun x => exp (-(lam*a)) / lam) (fun x => x) 0). exact: continuous_const. exact: continuous_id. apply: filterlim_comp; last first. rewrite -[0]Ropp_involutive. exact: filterlim_opp. have -> : - 0 = Rbar_mult (Rbar.Finite 0) (Rbar.Finite (/ lam)) by rewrite /=; ring. rewrite /Rdiv. apply: (is_lim_mult (fun x => exp (-(lam * x))) (fun x => / lam) p_infty 0 (/ lam)) => // . apply: is_lim_comp. exact: is_lim_exp_m. apply: (is_lim_ext (fun x => (-lam) * x)). move => y; ring. have -> : m_infty = (Rbar_mult (- lam) p_infty). rewrite /Rbar_mult /Rbar_mult'. case: (Rle_dec 0 (-lam)) => [Hy1|Hy1] //. exfalso; lra. apply: (is_lim_mult (fun x => (- lam)) (fun x => x) p_infty (-lam) p_infty) => // . exact: is_lim_const. rewrite /ex_Rbar_mult; lra. exists 0 => // . exact: is_lim_const. Qed. Lemma RInt_gen_ext : forall {V : CompleteNormedModule R_AbsRing} {Fa Fb : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f g : R -> V), filter_prod Fa Fb (fun ab => forall x, Rmin (fst ab) (snd ab) < x < Rmax (fst ab) (snd ab) -> f x = g x) -> RInt_gen f Fa Fb = RInt_gen g Fa Fb. Proof. intros V Fa Fb FFa FFb f g Heq. apply eq_close. apply @close_iota. split. now apply is_RInt_gen_ext. apply is_RInt_gen_ext. revert Heq. apply filter_imp. intros [u v] H t Ht. now rewrite <- H. Qed. Lemma RInt_gen_ext_eq : forall {V : CompleteNormedModule R_AbsRing} {Fa Fb : (R -> Prop) -> Prop} {FFa : ProperFilter Fa} {FFb : ProperFilter Fb} (f g : R -> V), (forall x, f x = g x) -> RInt_gen f Fa Fb = RInt_gen g Fa Fb. Proof. intros V Fa Fb FFa FFb f g Heq. apply (RInt_gen_ext f g). apply filter_forall. now intros uv x _. Qed. interval-4.11.1/src/Missing/Flocq.v000066400000000000000000000030271470547631300170710ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2023-2023, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith SpecFloat. From Flocq Require Import BinarySingleNaN. Definition SF2B' {prec emax} (x : spec_float) : binary_float prec emax := match x with | S754_zero s => B754_zero s | S754_infinity s => B754_infinity s | S754_nan => B754_nan | S754_finite s m e => match bounded prec emax m e as b return bounded prec emax m e = b -> _ with | true => B754_finite s m e | false => fun H => B754_nan end eq_refl end. Lemma SF2B'_B2SF : forall {prec emax} (x : binary_float prec emax), SF2B' (B2SF x) = x. Proof. intros prec emax [s|s| |s m e H] ; try easy. apply B2SF_inj. simpl. generalize (eq_refl (bounded prec emax m e)). pattern (bounded prec emax m e) at 2 3. apply eq_sym in H. now elim H. Qed. interval-4.11.1/src/Missing/Int63Compat.v.in000066400000000000000000000014441470547631300205020ustar00rootroot00000000000000(* Generated from Int63Compat.v.in, *do not edit*. *) (* This is a compatibility module for Coq < 8.14 which does not provide Uint63. It is bound to disappear once Interval requires Coq >= 8.14. *) @INT63_EXPORT@ Module Int63. Notation of_pos := of_pos (only parsing). Notation of_Z := of_Z (only parsing). Notation of_Z_spec := of_Z_spec (only parsing). Notation to_Z := to_Z (only parsing). Notation to_Z_bounded := to_Z_bounded (only parsing). Notation to_Z_inj := to_Z_inj (only parsing). Notation to_Z_1 := to_Z_1 (only parsing). Notation leb := leb (only parsing). Notation eqb := eqb (only parsing). Notation eqbP := eqbP (only parsing). Notation add_spec := add_spec (only parsing). Notation sub_spec := sub_spec (only parsing). Notation land_spec' := land_spec' (only parsing). End Int63. interval-4.11.1/src/Missing/Int63Copy.v000066400000000000000000000312051470547631300175620ustar00rootroot00000000000000(** Compatibility file copied from Coq 8.14, to be removed once we require Coq >= 8.14 *) Require Export DoubleType. Require Export PrimInt63. Require Uint63. Bind Scope int63_scope with int. Notation mod := Uint63.mod (only parsing). Notation lor := Uint63.lor (only parsing). Notation land := Uint63.land (only parsing). Notation lxor := Uint63.lxor (only parsing). Import Uint63. Notation size := size (only parsing). Notation int := int (only parsing). Notation lsl := lsl (only parsing). Notation lsr := lsr (only parsing). Notation add := add (only parsing). Notation sub := sub (only parsing). Notation mul := mul (only parsing). Notation mulc := mulc (only parsing). Notation div := div (only parsing). Notation eqb := eqb (only parsing). Notation ltb := ltb (only parsing). Notation leb := leb (only parsing). Module Import Int63NotationsInternalB. Infix "<<" := Uint63.lsl (at level 30, no associativity) : int63_scope. Infix ">>" := Uint63.lsr (at level 30, no associativity) : int63_scope. Infix "land" := Uint63.land (at level 40, left associativity) : int63_scope. Infix "lor" := Uint63.lor (at level 40, left associativity) : int63_scope. Infix "lxor" := Uint63.lxor (at level 40, left associativity) : int63_scope. Infix "+" := Uint63.add : int63_scope. Infix "-" := Uint63.sub : int63_scope. Infix "*" := Uint63.mul : int63_scope. Infix "/" := Uint63.div : int63_scope. Infix "mod" := Uint63.mod (at level 40, no associativity) : int63_scope. Infix "=?" := Uint63.eqb (at level 70, no associativity) : int63_scope. Infix " [|n IHn] m; first by rewrite addn0 subn0. rewrite subnS -addSnnS. move/(_ m) in IHn. have H := leqSpred (m - n). apply: leq_trans IHn _. exact: leq_add H _. Qed. Lemma leq_addLR m n p : n <= p -> (m + n <= p) = (m <= p - n). Proof. by move => H; rewrite -!subn_eq0 subnBA. Qed. Lemma leq_addLRI m n p : (m + n <= p) -> (m <= p - n). Proof. move=> Hmnp. - have Hnp : n <= p by exact: leq_trans (leq_addl _ _) Hmnp. - move: Hmnp; rewrite -!subn_eq0 subnBA //. Qed. Lemma ltn_leqN m n : m < n <= m = false. Proof. by apply/andP=> [[_n n_]]; have:= leq_ltn_trans n_ _n; rewrite ltnn. Qed. Lemma max1n n : maxn 1 n = n.-1.+1. Proof. by case: n =>//; case. Qed. Lemma ltn_leq_pred m n : m < n -> m <= n.-1. Proof. by move=> H; rewrite -ltnS (ltn_predK H). Qed. Lemma addn_pred_leqI a b k i : (a + b).-1 <= k -> i <= k -> a <= i \/ b <= k - i. Proof. move=> Hk Hi; case: (leqP a i) => Ha; [by left|right]. apply: leq_addLRI. apply: leq_trans _ Hk. apply: ltn_leq_pred. by rewrite addnC ltn_add2r. Qed. End NatCompl. (** Missing result(s) about bigops *) Section bigops. Lemma big_nat_leq_idx : forall (R : Type) (idx : R) (op : Monoid.law idx) (m n : nat) (F : nat -> R), n <= m -> (forall i : nat, n <= i < m -> F i = idx) -> \big[op/idx]_(0 <= i < n) F i = \big[op/idx]_(0 <= i < m) F i. Proof. move=> R idx op m n F Hmn H. rewrite [RHS](big_cat_nat _ (n := n)) //. rewrite [in X in _ = op _ X]big_nat_cond. rewrite [in X in _ = op _ X]big1 ?Monoid.mulm1 //. move=> i; rewrite andbT; move=> *; exact: H. Qed. End bigops. (** Missing results about lists (aka sequences) *) Section Head_Last. Variables (T : Type) (d : T). Definition hb s := head d (behead s). Lemma nth_behead s n : nth d (behead s) n = nth d s n.+1. Proof. by case: s =>//; rewrite /= nth_nil. Qed. Lemma last_rev : forall s, last d (rev s) = head d s. Proof. by elim=> [//|s IHs]; rewrite rev_cons last_rcons. Qed. End Head_Last. Lemma nth_map_dflt (C : Type) (x0 : C) (f : C -> C) (n : nat) (s : seq C) : nth x0 (map f s) n = if size s <= n then x0 else f (nth x0 s n). Proof. case: (leqP (size s) n); last exact: nth_map. by move=> ?; rewrite nth_default // size_map. Qed. Section Map2. Variable C : Type. Variable x0 : C. Variable op : C -> C -> C. Variable op' : C -> C. (* will be [id] or [opp] *) Fixpoint map2 (s1 : seq C) (s2 : seq C) : seq C := match s1, s2 with | _, [::] => s1 | [::], b :: s4 => op' b :: map2 [::] s4 | a :: s3, b :: s4 => op a b :: map2 s3 s4 end. Lemma size_map2 s1 s2 : size (map2 s1 s2) = maxn (size s1) (size s2). Proof. elim: s1 s2 => [|x1 s1 IHs1] s2; elim: s2 => [|x2 s2 IHs2] //=. - by rewrite IHs2 !max0n. - by rewrite IHs1 maxnSS. Qed. Lemma nth_map2_dflt (n : nat) (s1 s2 : seq C) : nth x0 (map2 s1 s2) n = match size s1 <= n, size s2 <= n with | true, true => x0 | true, false => op' (nth x0 s2 n) | false, true => nth x0 s1 n | false, false => op (nth x0 s1 n) (nth x0 s2 n) end. Proof. elim: s1 s2 n => [|x1 s1 IHs1] s2 n. elim: s2 n => [|x2 s2 /= IHs2] n //=; first by rewrite nth_nil. by case: n =>[|n] //=; rewrite IHs2. case: s2 => [|x2 s2] /=. by case: leqP => H; last rewrite nth_default. case: n => [|n] /=. done. exact: IHs1. Qed. End Map2. Lemma nth_mkseq_dflt (C : Type) (x0 : C) (f : nat -> C) (n i : nat) : nth x0 (mkseq f n) i = if n <= i then x0 else f i. Proof. case: (leqP n i); last exact: nth_mkseq. by move=> ?; rewrite nth_default // size_mkseq. Qed. Lemma nth_take_dflt (n0 : nat) (T : Type) (x0 : T) (i : nat) (s : seq T) : nth x0 (take n0 s) i = if n0 <= i then x0 else nth x0 s i. Proof. case: (leqP n0 i) => Hi; last by rewrite nth_take. by rewrite nth_default // size_take; case: ltnP=>// H'; apply: leq_trans H' Hi. Qed. (** Generic results to be instantiated for polynomials' opp, add, sub, mul... *) Section map_proof. Variables (V T : Type) (Rel : V -> T -> Prop). Variables (dv : V) (dt : T). Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Variables (vop : V -> V) (top : T -> T). Hypothesis H0 : Rel dv dt. Hypothesis H0t : forall v : V, Rel v dt -> Rel (vop v) dt. Hypothesis H0v : forall t : T, Rel dv t -> Rel dv (top t). Hypothesis Hop : forall v t, Rel v t -> Rel (vop v) (top t). Lemma map_correct : forall sv st, RelP sv st -> RelP (map vop sv) (map top st). Proof. move=> sv st Hnth k; move/(_ k) in Hnth. rewrite !nth_map_dflt. do 2![case:ifP]=> A B //; rewrite ?(nth_default _ A) ?(nth_default _ B) in Hnth. - exact: H0v. - exact: H0t. - exact: Hop. Qed. End map_proof. Section map2_proof. Variables (V T : Type) (Rel : V -> T -> Prop). Variables (dv : V) (dt : T). Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Variables (vop : V -> V -> V) (vop' : V -> V). Variables (top : T -> T -> T) (top' : T -> T). Hypothesis H0 : Rel dv dt. Hypothesis H0t : forall v : V, Rel v dt -> Rel (vop' v) dt. Hypothesis H0v : forall t : T, Rel dv t -> Rel dv (top' t). Hypothesis Hop' : forall v t, Rel v t -> Rel (vop' v) (top' t). Hypothesis H0eq : forall v, Rel v dt -> v = dv. Hypothesis H0t1 : forall (v1 v2 : V) (t1 : T), Rel v1 t1 -> Rel v2 dt -> Rel (vop v1 v2) t1. Hypothesis H0t2 : forall (v1 v2 : V) (t2 : T), Rel v1 dt -> Rel v2 t2 -> Rel (vop v1 v2) (top' t2). Hypothesis H0v1 : forall (v1 : V) (t1 t2 : T), Rel v1 t1 -> Rel dv t2 -> Rel v1 (top t1 t2). Hypothesis H0v2 : forall (v2 : V) (t1 t2 : T), Rel dv t1 -> Rel v2 t2 -> Rel (vop' v2) (top t1 t2). Hypothesis Hop : forall v1 v2 t1 t2, Rel v1 t1 -> Rel v2 t2 -> Rel (vop v1 v2) (top t1 t2). Lemma map2_correct : forall sv1 sv2 st1 st2, RelP sv1 st1 -> RelP sv2 st2 -> RelP (map2 vop vop' sv1 sv2) (map2 top top' st1 st2). Proof using H0 H0t H0v Hop' H0eq H0t1 H0t2 H0v1 H0v2 Hop. move=> sv1 sv2 st1 st2 H1 H2 k; move/(_ k) in H1; move/(_ k) in H2. rewrite !nth_map2_dflt. do 4![case:ifP]=> A B C D; rewrite ?(nth_default _ A) ?(nth_default _ B) ?(nth_default _ C) ?(nth_default _ D) // in H1 H2; try solve [exact: H0t1|exact: H0t2|exact: H0v1|exact: H0v2|exact: Hop'|exact: Hop|exact: H0t|exact: H0v]. - rewrite (H0eq (H0t H2)); exact: H1. - rewrite (H0eq H1); apply: H0v; exact: H2. Qed. End map2_proof. Section fold_proof. Variables (V T : Type). Variable Rel : V -> T -> Prop. Variables (dv : V) (dt : T). Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Hypothesis H0 : Rel dv dt. Lemma foldr_correct fv ft sv st : RelP sv st -> (forall xv yv, Rel xv dt -> Rel yv dt -> Rel (fv xv yv) dt) -> (forall xt yt, Rel dv xt -> Rel dv yt -> Rel dv (ft xt yt)) -> (forall xv xt yv yt, Rel xv xt -> Rel yv yt -> Rel (fv xv yv) (ft xt yt)) -> Rel (foldr fv dv sv) (foldr ft dt st). Proof. move=> Hs H0t H0v Hf. elim: sv st Hs => [ | xv sv IH1] st Hs /=. - elim: st Hs => [ | xt st IH2] Hs //=. apply: H0v; first by move/(_ 0): Hs. by apply: IH2 => k; move/(_ k.+1): Hs; rewrite /= nth_nil. - case: st Hs => [ | xt st] Hs /=. + apply: H0t; first by move/(_ 0): Hs. change dt with (foldr ft dt [::]). apply/IH1 => k. by move/(_ k.+1): Hs; rewrite /= nth_nil. + apply: Hf; first by move/(_ 0): Hs. apply: IH1. move=> k; by move/(_ k.+1): Hs. Qed. Lemma seq_foldr_correct fv ft sv st (zv := [::]) (zt := [::]) : RelP sv st -> (forall xv yv, Rel xv dt -> RelP yv zt -> RelP (fv xv yv) zt) -> (forall xt yt, Rel dv xt -> RelP zv yt -> RelP zv (ft xt yt)) -> (forall xv xt yv yt, Rel xv xt -> RelP yv yt -> RelP (fv xv yv) (ft xt yt)) -> RelP (foldr fv zv sv) (foldr ft zt st). Proof. move=> Hs H0t H0v Hf. elim: sv st Hs => [ | xv sv IH1] st Hs /=. - elim: st Hs => [ | xt st IH2] Hs //=. apply: H0v; first by move/(_ 0): Hs. by apply: IH2 => k; move/(_ k.+1): Hs; rewrite /= nth_nil. - case: st Hs => [ | xt st] Hs /=. + apply: H0t; first by move/(_ 0): Hs. change zt with (foldr ft zt [::]). apply/IH1 => k. by move/(_ k.+1): Hs; rewrite /= nth_nil. + apply: Hf; first by move/(_ 0): Hs. apply: IH1. move=> k; by move/(_ k.+1): Hs. Qed. End fold_proof. Section Foldri. Variables (T R : Type) (f : T -> nat -> R -> R) (z0 : R). Fixpoint foldri (s : seq T) (i : nat) : R := match s with | [::] => z0 | x :: s' => f x i (foldri s' i.+1) end. End Foldri. Section foldri_proof. Variables (V T : Type). Variable Rel : V -> T -> Prop. Variables (dv : V) (dt : T). Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Hypothesis H0 : Rel dv dt. Lemma seq_foldri_correct fv ft sv st (zv := [::]) (zt := [::]) i : RelP sv st -> (* RelP zv zt -> *) (forall xv yv i, Rel xv dt -> RelP yv zt -> RelP (fv xv i yv) zt) -> (forall xt yt i, Rel dv xt -> RelP zv yt -> RelP zv (ft xt i yt)) -> (forall xv xt yv yt i, Rel xv xt -> RelP yv yt -> RelP (fv xv i yv) (ft xt i yt)) -> RelP (foldri fv zv sv i) (foldri ft zt st i). Proof. move=> Hs H0t H0v Hf. elim: sv st Hs i => [ | xv sv IH1] st Hs i /=. - elim: st Hs i => [ | xt st IH2] Hs i //=. apply: H0v; first by move/(_ 0): Hs. by apply: IH2 => k; move/(_ k.+1): Hs; rewrite /= nth_nil. - case: st Hs => [ | xt st] Hs /=. + apply: H0t; first by move/(_ 0): Hs. change zt with (foldri ft zt [::] i.+1). apply/IH1 => k. by move/(_ k.+1): Hs; rewrite /= nth_nil. + apply: Hf; first by move/(_ 0): Hs. apply: IH1. move=> k; by move/(_ k.+1): Hs. Qed. End foldri_proof. Section mkseq_proof. Variables (V T : Type). Variable Rel : V -> T -> Prop. Variables (dv : V) (dt : T). Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Hypothesis H0 : Rel dv dt. Lemma mkseq_correct fv ft (mv mt : nat) : (forall k : nat, Rel (fv k) (ft k)) -> (* the following 2 hyps hold if mv <> mt *) (forall k : nat, mv <= k < mt -> fv k = dv) -> (forall k : nat, mt <= k < mv -> fv k = dv) -> RelP (mkseq fv mv) (mkseq ft mt). Proof. move=> Hk Hv1 Hv2 k; rewrite !nth_mkseq_dflt. do 2![case: ifP]=> A B. - exact: H0. - by rewrite -(Hv1 k) // B ltnNge A. - by rewrite (Hv2 k) // A ltnNge B. - exact: Hk. Qed. End mkseq_proof. Section misc_proofs. Variables (V T : Type). Variable Rel : V -> T -> Prop. Variables (dv : V) (dt : T). Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Lemma set_nth_correct sv st bv bt n : RelP sv st -> Rel bv bt -> RelP (set_nth dv sv n bv) (set_nth dt st n bt). Proof. by move=> Hs Hb k; rewrite !nth_set_nth /=; case: ifP. Qed. Lemma drop_correct sv st n : RelP sv st -> RelP (drop n sv) (drop n st). Proof. by move=> Hs k; rewrite !nth_drop; apply: Hs. Qed. Hypothesis H0 : Rel dv dt. Lemma ncons_correct sv st n : RelP sv st -> RelP (ncons n dv sv) (ncons n dt st). Proof. by move=> Hs k; rewrite !nth_ncons; case: ifP. Qed. End misc_proofs. interval-4.11.1/src/Missing/MathComp1.v000066400000000000000000000037361470547631300176250ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Rdefinitions Raxioms RIneq Rbasic_fun. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq bigop. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Definition eqr (r1 r2 : R) : bool := if Req_EM_T r1 r2 is left _ then true else false. Lemma eqrP : Equality.axiom eqr. Proof. by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP). Qed. Canonical Structure real_eqMixin := EqMixin eqrP. Canonical Structure real_eqType := Eval hnf in EqType R real_eqMixin. Fact RplusA : associative (Rplus). Proof. by move=> *; rewrite Rplus_assoc. Qed. Fact RmultA : associative (Rmult). Proof. by move=> *; rewrite Rmult_assoc. Qed. Import Monoid. Canonical Radd_monoid := Law RplusA Rplus_0_l Rplus_0_r. Canonical Radd_comoid := ComLaw Rplus_comm. Canonical Rmul_monoid := Law RmultA Rmult_1_l Rmult_1_r. Canonical Rmul_comoid := ComLaw Rmult_comm. Canonical Rmul_mul_law := MulLaw Rmult_0_l Rmult_0_r. Canonical Radd_add_law := AddLaw Rmult_plus_distr_r Rmult_plus_distr_l. Canonical Zmul_monoid := Monoid.Law Z.mul_assoc Z.mul_1_l Z.mul_1_r. interval-4.11.1/src/Missing/MathComp1or2.v.in000066400000000000000000000003561470547631300206500ustar00rootroot00000000000000(* Compatibility file for MathComp1 (to be removed when dropping support for MathComp 1). This file is automatically generated, do not edit (edit MathComp1.v or MathComp2.v instead).*) Require Export MathComp@MATHCOMP_1_OR_2@. interval-4.11.1/src/Missing/MathComp2.v000066400000000000000000000040421470547631300176150ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From HB Require Import structures. From Coq Require Import Rdefinitions Raxioms RIneq Rbasic_fun. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq bigop. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Definition eqr (r1 r2 : R) : bool := if Req_EM_T r1 r2 is left _ then true else false. Lemma eqrP : Equality.axiom eqr. Proof. by move=> r1 r2; rewrite /eqr; case: Req_EM_T=> H; apply: (iffP idP). Qed. HB.instance Definition _ := hasDecEq.Build R eqrP. Fact RplusA : associative (Rplus). Proof. by move=> *; rewrite Rplus_assoc. Qed. Fact RmultA : associative (Rmult). Proof. by move=> *; rewrite Rmult_assoc. Qed. Import Monoid. HB.instance Definition _ := isComLaw.Build R 0%R Rplus RplusA Rplus_comm Rplus_0_l. HB.instance Definition _ := isComLaw.Build R 1%R Rmult RmultA Rmult_comm Rmult_1_l. HB.instance Definition _ := isMulLaw.Build R 0%R Rmult Rmult_0_l Rmult_0_r. HB.instance Definition _ := isAddLaw.Build R Rmult Rplus Rmult_plus_distr_r Rmult_plus_distr_l. HB.instance Definition _ := Monoid.isLaw.Build Z 1%Z Z.mul Z.mul_assoc Z.mul_1_l Z.mul_1_r. Module BigOp. Notation bigopE := bigop.unlock. End BigOp. interval-4.11.1/src/Missing/Stdlib.v000066400000000000000000000715531470547631300172570ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals Psatz. From Flocq Require Import Raux. Ltac evar_last := match goal with | |- ?f ?x => let tx := type of x in let tx := eval simpl in tx in let tmp := fresh "tmp" in evar (tmp : tx) ; refine (@eq_ind tx tmp f _ x _) ; unfold tmp ; clear tmp end. Lemma Rmult_le_compat_neg_r : forall r r1 r2 : R, (r <= 0)%R -> (r1 <= r2)%R -> (r2 * r <= r1 * r)%R. Proof. intros. rewrite (Rmult_comm r2). rewrite (Rmult_comm r1). apply Rmult_le_compat_neg_l. exact H. exact H0. Qed. Lemma Rsqr_plus1_pos x : (0 < 1 + Rsqr x)%R. Proof. now apply (Rplus_lt_le_0_compat _ _ Rlt_0_1 (Rle_0_sqr x)). Qed. Lemma Rsqr_plus1_neq0 x : (1 + Rsqr x <> 0)%R. Proof. now apply Rgt_not_eq; apply Rlt_gt; apply Rsqr_plus1_pos. Qed. Lemma Rmin_Rle : forall r1 r2 r, (Rmin r1 r2 <= r)%R <-> (r1 <= r)%R \/ (r2 <= r)%R. Proof. intros. unfold Rmin. split. case (Rle_dec r1 r2) ; intros. left. exact H. right. exact H. intros [H|H] ; case (Rle_dec r1 r2) ; intros H0. exact H. apply Rle_trans with (2 := H). apply Rlt_le. apply Rnot_le_lt with (1 := H0). apply Rle_trans with r2 ; assumption. exact H. Qed. Lemma Rle_Rinv_pos : forall x y : R, (0 < x)%R -> (x <= y)%R -> (/y <= /x)%R. Proof. intros. apply Rle_Rinv. exact H. apply Rlt_le_trans with x ; assumption. exact H0. Qed. Lemma Rle_Rinv_neg : forall x y : R, (y < 0)%R -> (x <= y)%R -> (/y <= /x)%R. Proof. intros. apply Ropp_le_cancel. repeat rewrite Ropp_inv_permute. apply Rle_Rinv. auto with real. apply Rlt_le_trans with (Ropp y). auto with real. auto with real. auto with real. apply Rlt_dichotomy_converse. left. exact H. apply Rlt_dichotomy_converse. left. apply Rle_lt_trans with y ; assumption. Qed. Lemma Rmult_le_pos_pos : forall x y : R, (0 <= x)%R -> (0 <= y)%R -> (0 <= x * y)%R. Proof. exact Rmult_le_pos. Qed. Lemma Rmult_le_pos_neg : forall x y : R, (0 <= x)%R -> (y <= 0)%R -> (x * y <= 0)%R. Proof. intros. rewrite <- (Rmult_0_r x). apply Rmult_le_compat_l ; assumption. Qed. Lemma Rmult_le_neg_pos : forall x y : R, (x <= 0)%R -> (0 <= y)%R -> (x * y <= 0)%R. Proof. intros. rewrite <- (Rmult_0_l y). apply Rmult_le_compat_r ; assumption. Qed. Lemma Rmult_le_neg_neg : forall x y : R, (x <= 0)%R -> (y <= 0)%R -> (0 <= x * y)%R. Proof. intros. rewrite <- (Rmult_0_r x). apply Rmult_le_compat_neg_l ; assumption. Qed. Lemma Rabs_def1_le : forall x a, (x <= a)%R -> (-a <= x)%R -> (Rabs x <= a)%R. Proof. intros. case (Rcase_abs x) ; intros. rewrite (Rabs_left _ r). rewrite <- (Ropp_involutive a). apply Ropp_le_contravar. exact H0. rewrite (Rabs_right _ r). exact H. Qed. Lemma Rabs_def2_le : forall x a, (Rabs x <= a)%R -> (-a <= x <= a)%R. Proof. intros x a H. assert (0 <= a)%R. apply Rle_trans with (2 := H). apply Rabs_pos. generalize H. clear H. unfold Rabs. case (Rcase_abs x) ; split. rewrite <- (Ropp_involutive x). apply Ropp_le_contravar. exact H. apply Rlt_le. apply Rlt_le_trans with (1 := r). exact H0. generalize (Rge_le _ _ r). clear r. intro. apply Rle_trans with (2 := H1). rewrite <- Ropp_0. apply Ropp_le_contravar. exact H0. exact H. Qed. Theorem derivable_pt_lim_eq : forall f g, (forall x, f x = g x) -> forall x l, derivable_pt_lim f x l -> derivable_pt_lim g x l. Proof. intros f g H x l. unfold derivable_pt_lim. intros. destruct (H0 _ H1) as (delta, H2). exists delta. intros. do 2 rewrite <- H. apply H2 ; assumption. Qed. Definition locally_true x (P : R -> Prop) := exists delta, (0 < delta)%R /\ forall h, (Rabs h < delta)%R -> P (x + h)%R. Theorem derivable_pt_lim_eq_locally : forall f g x l, locally_true x (fun v => f v = g v) -> derivable_pt_lim f x l -> derivable_pt_lim g x l. Proof. intros f g x l (delta1, (Hd, Heq)) Hf eps Heps. destruct (Hf eps Heps) as (delta2, H0). clear Hf. assert (0 < Rmin delta1 delta2)%R. apply Rmin_pos. exact Hd. exact (cond_pos delta2). exists (mkposreal (Rmin delta1 delta2) H). intros. rewrite <- Heq. pattern x at 2 ; rewrite <- Rplus_0_r. rewrite <- Heq. rewrite Rplus_0_r. apply H0. exact H1. apply Rlt_le_trans with (1 := H2). simpl. apply Rmin_r. rewrite Rabs_R0. exact Hd. apply Rlt_le_trans with (1 := H2). simpl. apply Rmin_l. Qed. Theorem locally_true_and : forall P Q x, locally_true x P -> locally_true x Q -> locally_true x (fun x => P x /\ Q x). Proof. intros P Q x HP HQ. destruct HP as (e1, (He1, H3)). destruct HQ as (e2, (He2, H4)). exists (Rmin e1 e2). split. apply Rmin_pos ; assumption. intros. split. apply H3. apply Rlt_le_trans with (1 := H). apply Rmin_l. apply H4. apply Rlt_le_trans with (1 := H). apply Rmin_r. Qed. Theorem locally_true_imp : forall P Q : R -> Prop, (forall x, P x -> Q x) -> forall x, locally_true x P -> locally_true x Q. Proof. intros P Q H x (d, (Hd, H0)). exists d. split. exact Hd. intros. apply H. apply H0. exact H1. Qed. Theorem continuity_pt_lt : forall f x y, (f x < y)%R -> continuity_pt f x -> locally_true x (fun u => (f u < y)%R). Proof. intros. assert (0 < y - f x)%R. apply Rplus_lt_reg_l with (f x). rewrite Rplus_0_r. replace (f x + (y - f x))%R with y. 2: ring. exact H. destruct (H0 _ H1) as (delta, (Hdelta, H2)). clear H0. exists delta. split. exact Hdelta. intros. case (Req_dec h 0) ; intro H3. rewrite H3. rewrite Rplus_0_r. exact H. generalize (H2 (x + h)%R). clear H2. unfold R_met, R_dist, D_x, no_cond. simpl. intro. apply Rplus_lt_reg_r with (- f x)%R. apply Rle_lt_trans with (1 := RRle_abs (f (x + h) - f x)%R). apply H2. assert (x + h - x = h)%R. ring. split. split. exact I. intro H5. elim H3. rewrite <- H4. rewrite <- H5. exact (Rplus_opp_r _). rewrite H4. exact H0. Qed. Theorem continuity_pt_gt : forall f x y, (y < f x)%R -> continuity_pt f x -> locally_true x (fun u => (y < f u)%R). Proof. intros. generalize (Ropp_lt_contravar _ _ H). clear H. intro H. generalize (continuity_pt_opp _ _ H0). clear H0. intro H0. destruct (continuity_pt_lt (opp_fct f) _ _ H H0) as (delta, (Hdelta, H1)). exists delta. split. exact Hdelta. intros. apply Ropp_lt_cancel. exact (H1 _ H2). Qed. Theorem continuity_pt_ne : forall f x y, f x <> y -> continuity_pt f x -> locally_true x (fun u => f u <> y). Proof. intros. destruct (Rdichotomy _ _ H) as [H1|H1]. destruct (continuity_pt_lt _ _ _ H1 H0) as (delta, (Hdelta, H2)). exists delta. split. exact Hdelta. intros. apply Rlt_not_eq. exact (H2 _ H3). destruct (continuity_pt_gt _ _ _ H1 H0) as (delta, (Hdelta, H2)). exists delta. split. exact Hdelta. intros. apply Rgt_not_eq. exact (H2 _ H3). Qed. Theorem derivable_pt_lim_tan : forall x, (cos x <> 0)%R -> derivable_pt_lim tan x (1 + Rsqr (tan x))%R. Proof. intros x Hx. change (derivable_pt_lim (sin/cos) x (1 + Rsqr (tan x))%R). replace (1 + Rsqr (tan x))%R with ((cos x * cos x - (-sin x) * sin x) / Rsqr (cos x))%R. apply derivable_pt_lim_div. apply derivable_pt_lim_sin. apply derivable_pt_lim_cos. exact Hx. unfold Rsqr, tan. field. exact Hx. Qed. Definition connected (P : R -> Prop) := forall x y, P x -> P y -> forall z, (x <= z <= y)%R -> P z. Lemma connected_and : forall d1 d2, connected d1 -> connected d2 -> connected (fun t => d1 t /\ d2 t). Proof. intros d1 d2 H1 H2 u v [D1u D2u] [D1v D2v] t Ht. split. now apply H1 with (3 := Ht). now apply H2 with (3 := Ht). Qed. Lemma connected_ge : forall x, connected (Rle x). Proof. intros x u v Hu _ t [Ht _]. exact (Rle_trans _ _ _ Hu Ht). Qed. Lemma connected_le : forall x, connected (fun t => Rle t x). Proof. intros x u v _ Hv t [_ Ht]. exact (Rle_trans _ _ _ Ht Hv). Qed. Theorem derivable_pos_imp_increasing : forall f f' dom, connected dom -> (forall x, dom x -> derivable_pt_lim f x (f' x) /\ (0 <= f' x)%R) -> forall u v, dom u -> dom v -> (u <= v)%R -> (f u <= f v)%R. Proof. intros f f' dom Hdom Hd u v Hu Hv [Huv|Huv]. assert (forall w, (u <= w <= v)%R -> derivable_pt_lim f w (f' w)). intros w Hw. refine (proj1 (Hd _ _)). exact (Hdom _ _ Hu Hv _ Hw). destruct (MVT_cor2 _ _ _ _ Huv H) as (w, (Hw1, Hw2)). replace (f v) with (f u + (f v - f u))%R by ring. rewrite Hw1. pattern (f u) at 1 ; rewrite <- Rplus_0_r. apply Rplus_le_compat_l. apply Rmult_le_pos. refine (proj2 (Hd _ _)). refine (Hdom _ _ Hu Hv _ _). exact (conj (Rlt_le _ _ (proj1 Hw2)) (Rlt_le _ _ (proj2 Hw2))). rewrite <- (Rplus_opp_r u). unfold Rminus. apply Rplus_le_compat_r. exact (Rlt_le _ _ Huv). rewrite Huv. apply Rle_refl. Qed. Theorem derivable_neg_imp_decreasing : forall f f' dom, connected dom -> (forall x, dom x -> derivable_pt_lim f x (f' x) /\ (f' x <= 0)%R) -> forall u v, dom u -> dom v -> (u <= v)%R -> (f v <= f u)%R. Proof. intros f f' dom Hdom Hd u v Hu Hv Huv. apply Ropp_le_cancel. refine (derivable_pos_imp_increasing (opp_fct f) (opp_fct f') _ Hdom _ _ _ Hu Hv Huv). intros. destruct (Hd x H) as (H1, H2). split. apply derivable_pt_lim_opp with (1 := H1). rewrite <- Ropp_0. apply Ropp_le_contravar with (1 := H2). Qed. Lemma even_or_odd : forall n : nat, exists k, n = 2 * k \/ n = S (2 * k). Proof. induction n. exists 0. now left. destruct IHn as [k [Hk|Hk]]. exists k. right. now apply f_equal. exists (S k). left. lia. Qed. Lemma alternated_series_ineq' : forall u l, Un_decreasing u -> Un_cv u 0 -> Un_cv (fun n => sum_f_R0 (tg_alt u) n) l -> forall n, (0 <= (-1)^(S n) * (l - sum_f_R0 (tg_alt u) n) <= u (S n))%R. Proof. intros u l Du Cu Cl n. destruct (even_or_odd n) as [p [Hp|Hp]]. - destruct (alternated_series_ineq u l p Du Cu Cl) as [H1 H2]. rewrite Hp, pow_1_odd. split. + lra. + apply Rplus_le_reg_r with (- sum_f_R0 (tg_alt u) (2 * p))%R. ring_simplify. replace (- sum_f_R0 (tg_alt u) (2 * p) + u (S (2 * p)))%R with (- (sum_f_R0 (tg_alt u) (2 * p) + (-1) * u (S (2 * p))))%R by ring. rewrite <- (pow_1_odd p). now apply Ropp_le_contravar. - assert (H0: S (S (2 * p)) = 2 * (p + 1)) by ring. rewrite Hp. rewrite H0 at 1 2. rewrite pow_1_even, Rmult_1_l. split. + apply Rle_0_minus. now apply alternated_series_ineq. + apply Rplus_le_reg_l with (sum_f_R0 (tg_alt u) (S (2 * p))). ring_simplify. rewrite <- (Rmult_1_l (u (S (S (2 * p))))). rewrite <- (pow_1_even (p + 1)). rewrite <- H0. destruct (alternated_series_ineq u l (p + 1) Du Cu Cl) as [_ H1]. now rewrite <- H0 in H1. Qed. Lemma Un_decreasing_exp : forall x : R, (0 <= x <= 1)%R -> Un_decreasing (fun n => / INR (fact n) * x ^ n)%R. Proof. intros x Hx n. change (fact (S n)) with (S n * fact n). rewrite mult_INR. rewrite Rinv_mult_distr. simpl pow. rewrite <- (Rmult_1_r (/ _ * _ ^ n)). replace (/ INR (S n) * / INR (fact n) * (x * x ^ n))%R with (/ INR (fact n) * x ^ n * (/ INR (S n) * x))%R by ring. apply Rmult_le_compat_l. apply Rmult_le_pos. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply lt_O_fact. now apply pow_le. rewrite <- (Rmult_1_r 1). apply Rmult_le_compat. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply Nat.lt_0_succ. apply Hx. rewrite <- Rinv_1. apply Rle_Rinv_pos. apply Rlt_0_1. apply (le_INR 1). apply le_n_S, le_0_n. apply Hx. now apply not_0_INR. apply INR_fact_neq_0. Qed. Lemma Un_decreasing_cos : forall x : R, (Rabs x <= 1)%R -> Un_decreasing (fun n => / INR (fact (2 * n)) * x ^ (2 * n))%R. Proof. intros x Hx n. replace (2 * S n) with (2 + 2 * n) by ring. rewrite pow_add. rewrite <- Rmult_assoc. apply Rmult_le_compat_r. rewrite pow_sqr. apply pow_le. apply Rle_0_sqr. change (fact (2 + 2 * n)) with ((2 + 2 * n) * ((1 + 2 * n) * fact (2 * n))). rewrite Nat.mul_assoc, Nat.mul_comm. rewrite mult_INR. rewrite <- (Rmult_1_r (/ INR (fact _))). rewrite Rinv_mult_distr. rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply lt_O_fact. rewrite <- (Rmult_1_r 1). apply Rmult_le_compat. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply Nat.lt_0_succ. unfold pow. rewrite Rmult_1_r. apply Rle_0_sqr. rewrite <- Rinv_1. apply Rle_Rinv_pos. apply Rlt_0_1. apply (le_INR 1). apply le_n_S, le_0_n. replace 1%R with (1 * (1 * 1))%R by ring. apply pow_maj_Rabs with (1 := Hx). apply INR_fact_neq_0. now apply not_0_INR. Qed. Lemma Un_cv_subseq : forall (u : nat -> R) (f : nat -> nat) (l : R), (forall n, f n < f (S n)) -> Un_cv u l -> Un_cv (fun n => u (f n)) l. Proof. intros u f l Hf Cu eps He. destruct (Cu eps He) as [N HN]. exists N. intros n Hn. apply HN. apply Nat.le_trans with (1 := Hn). clear -Hf. induction n. apply le_0_n. specialize (Hf n). lia. Qed. Definition sinc (x : R) := proj1_sig (exist_sin (Rsqr x)). Lemma sin_sinc : forall x, sin x = (x * sinc x)%R. Proof. intros x. unfold sin, sinc. now case exist_sin. Qed. Lemma sinc_0 : sinc 0 = 1%R. Proof. unfold sinc. case exist_sin. simpl. unfold sin_in. intros y Hy. apply uniqueness_sum with (1 := Hy). intros eps He. exists 1. intros n Hn. rewrite (tech2 _ 0) by easy. simpl sum_f_R0 at 1. rewrite sum_eq_R0. unfold R_dist, sin_n. simpl. replace (1 / 1 * 1 + 0 - 1)%R with 0%R by field. now rewrite Rabs_R0. clear. intros m _. rewrite Rsqr_0, pow_i. apply Rmult_0_r. apply Nat.lt_0_succ. Qed. Lemma Un_decreasing_sinc : forall x : R, (Rabs x <= 1)%R -> Un_decreasing (fun n : nat => (/ INR (fact (2 * n + 1)) * x ^ (2 * n)))%R. Proof. intros x Hx n. replace (2 * S n) with (2 + 2 * n) by ring. rewrite pow_add. rewrite <- Rmult_assoc. apply Rmult_le_compat_r. rewrite pow_sqr. apply pow_le. apply Rle_0_sqr. change (fact (2 + 2 * n + 1)) with ((2 + 2 * n + 1) * ((1 + 2 * n + 1) * fact (2 * n + 1))). rewrite Nat.mul_assoc, Nat.mul_comm. rewrite mult_INR. rewrite <- (Rmult_1_r (/ INR (fact _))). rewrite Rinv_mult_distr. rewrite Rmult_assoc. apply Rmult_le_compat_l. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply lt_O_fact. rewrite <- (Rmult_1_r 1). apply Rmult_le_compat. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply Nat.lt_0_succ. unfold pow. rewrite Rmult_1_r. apply Rle_0_sqr. rewrite <- Rinv_1. apply Rle_Rinv_pos. apply Rlt_0_1. apply (le_INR 1). apply le_n_S, le_0_n. rewrite <- (pow1 2). apply pow_maj_Rabs with (1 := Hx). apply INR_fact_neq_0. now apply not_0_INR. Qed. Lemma atan_plus_PI4 : forall x, (-1 < x)%R -> (atan ((x - 1) / (x + 1)) + PI / 4)%R = atan x. Proof. intros x Hx. assert (H1: ((x - 1) / (x + 1) < 1)%R). apply Rmult_lt_reg_r with (x + 1)%R. lra. unfold Rdiv. rewrite Rmult_1_l, Rmult_assoc, Rinv_l, Rmult_1_r. lra. apply Rgt_not_eq. lra. assert (H2: (- PI / 2 < atan ((x - 1) / (x + 1)) + PI / 4 < PI / 2)%R). split. rewrite <- (Rplus_0_r (- PI / 2)). apply Rplus_lt_compat. apply atan_bound. apply PI4_RGT_0. apply Rplus_lt_reg_r with (-(PI / 4))%R. rewrite Rplus_assoc, Rplus_opp_r, Rplus_0_r. replace (PI/2 + - (PI/4))%R with (PI/4)%R by field. rewrite <- atan_1. now apply atan_increasing. apply tan_is_inj. exact H2. apply atan_bound. rewrite atan_right_inv. rewrite tan_plus. rewrite atan_right_inv. rewrite tan_PI4. field. split. apply Rgt_not_eq. lra. apply Rgt_not_eq. ring_simplify. apply Rlt_0_2. apply Rgt_not_eq, cos_gt_0. unfold Rdiv. rewrite <- Ropp_mult_distr_l_reverse. apply atan_bound. apply atan_bound. rewrite cos_PI4. apply Rgt_not_eq. unfold Rdiv. rewrite Rmult_1_l. apply Rinv_0_lt_compat. apply sqrt_lt_R0. apply Rlt_0_2. apply Rgt_not_eq, cos_gt_0. unfold Rdiv. now rewrite <- Ropp_mult_distr_l_reverse. apply H2. rewrite tan_PI4, Rmult_1_r. rewrite atan_right_inv. apply Rgt_not_eq. now apply Rgt_minus. Qed. Lemma atan_inv : forall x, (0 < x)%R -> atan (/ x) = (PI / 2 - atan x)%R. Proof. intros x Hx. apply tan_is_inj. apply atan_bound. split. apply Rlt_trans with R0. unfold Rdiv. rewrite Ropp_mult_distr_l_reverse. apply Ropp_lt_gt_0_contravar. apply PI2_RGT_0. apply Rgt_minus. apply atan_bound. apply Rplus_lt_reg_r with (atan x - PI / 2)%R. ring_simplify. rewrite <- atan_0. now apply atan_increasing. rewrite atan_right_inv. unfold tan. rewrite sin_shift. rewrite cos_shift. rewrite <- Rinv_Rdiv. apply f_equal, sym_eq, atan_right_inv. apply Rgt_not_eq, sin_gt_0. rewrite <- atan_0. now apply atan_increasing. apply Rlt_trans with (2 := PI2_Rlt_PI). apply atan_bound. apply Rgt_not_eq, cos_gt_0. unfold Rdiv. rewrite <- Ropp_mult_distr_l_reverse. apply atan_bound. apply atan_bound. Qed. Lemma Un_decreasing_atanc : forall x : R, (Rabs x <= 1)%R -> Un_decreasing (fun n : nat => (/ INR (2 * n + 1) * x ^ (2 * n)))%R. Proof. intros x Hx n. replace (2 * S n) with (2 + 2 * n) by ring. rewrite pow_add. rewrite <- Rmult_assoc. apply Rmult_le_compat_r. rewrite pow_sqr. apply pow_le. apply Rle_0_sqr. rewrite <- (Rmult_1_r (/ INR (2 * n + 1))). apply Rmult_le_compat. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply Nat.lt_0_succ. unfold pow. rewrite Rmult_1_r. apply Rle_0_sqr. apply Rlt_le. apply Rinv_lt. apply (lt_INR 0). rewrite Nat.add_comm. apply Nat.lt_0_succ. apply lt_INR. rewrite <- Nat.add_assoc. rewrite <-Nat.add_0_l at 1. rewrite <-Nat.add_lt_mono_r. apply Nat.lt_0_succ. rewrite <- (pow1 2). apply pow_maj_Rabs with (1 := Hx). Qed. Lemma Un_cv_atanc : forall x : R, (Rabs x <= 1)%R -> Un_cv (fun n : nat => (/ INR (2 * n + 1) * x ^ (2 * n)))%R 0. Proof. intros x Hx eps Heps. unfold R_dist. destruct (archimed_cor1 eps Heps) as [N [HN1 HN2]]. exists N. intros n Hn. assert (H: (0 < / INR (2 * n + 1))%R). apply Rinv_0_lt_compat. apply (lt_INR 0). rewrite Nat.add_comm. apply Nat.lt_0_succ. rewrite Rminus_0_r, Rabs_pos_eq. apply Rle_lt_trans with (/ INR (2 * n + 1) * 1)%R. apply Rmult_le_compat_l. now apply Rlt_le. rewrite <- (pow1 (2 * n)). apply pow_maj_Rabs with (1 := Hx). rewrite Rmult_1_r. apply Rlt_trans with (2 := HN1). apply Rinv_lt. now apply (lt_INR 0). apply lt_INR. apply Nat.le_lt_trans with (1 := Hn). clear ; lia. apply Rmult_le_pos. now apply Rlt_le. rewrite pow_Rsqr. apply pow_le. apply Rle_0_sqr. Qed. Lemma atanc_exists : forall x, (Rabs x <= 1)%R -> { l : R | Un_cv (sum_f_R0 (tg_alt (fun n => / INR (2 * n + 1) * x ^ (2 * n))%R)) l }. Proof. intros x Hx. apply alternated_series. now apply Un_decreasing_atanc. now apply Un_cv_atanc. Qed. Definition atanc x := match Ratan.in_int x with | left H => proj1_sig (atanc_exists x (Rabs_le _ _ H)) | right _ => (atan x / x)%R end. Lemma atanc_opp : forall x, atanc (- x) = atanc x. Proof. intros x. unfold atanc. destruct (Ratan.in_int x) as [Hx|Hx] ; case Ratan.in_int ; intros Hx'. do 2 case atanc_exists ; simpl projT1. intros l1 C1 l2 C2. apply UL_sequence with (1 := C2). apply Un_cv_ext with (2 := C1). intros N. apply sum_eq. intros n _. unfold tg_alt. replace (-x)%R with ((-1) * x)%R by ring. now rewrite Rpow_mult_distr, pow_1_even, Rmult_1_l. elim Hx'. split. now apply Ropp_le_contravar. rewrite <- (Ropp_involutive 1). now apply Ropp_le_contravar. elim Hx. split. rewrite <- (Ropp_involutive x). now apply Ropp_le_contravar. now apply Ropp_le_cancel. rewrite atan_opp. field. contradict Hx. rewrite Hx. split. rewrite <- Ropp_0. apply Ropp_le_contravar. apply Rle_0_1. apply Rle_0_1. Qed. Lemma atan_atanc : forall x, atan x = (x * atanc x)%R. Proof. assert (H1: forall x, (0 < x < 1 -> atan x = x * atanc x)%R). intros x Hx. rewrite atan_eq_ps_atan with (1 := Hx). unfold ps_atan, atanc. case Ratan.in_int ; intros H. destruct ps_atan_exists_1 as [l1 C1]. destruct atanc_exists as [l2 C2]. simpl. clear H. apply UL_sequence with (1 := C1). apply Un_cv_ext with (fun N => x * sum_f_R0 (tg_alt (fun n => (/ INR (2 * n + 1) * x ^ (2 * n)))) N)%R. intros N. rewrite scal_sum. apply sum_eq. intros n Hn. unfold tg_alt, Ratan_seq. rewrite pow_add. unfold Rdiv. ring. apply CV_mult with (2 := C2). intros eps Heps. exists 0. intros n _. now rewrite R_dist_eq. elim H. split. apply Rle_trans with 0%R. rewrite <- Ropp_0. apply Ropp_le_contravar. apply Rle_0_1. now apply Rlt_le. now apply Rlt_le. assert (H2: atan 1 = Rmult 1 (atanc 1)). rewrite Rmult_1_l. rewrite atan_1. rewrite <- Alt_PI_eq. unfold Alt_PI. destruct exist_PI as [pi C1]. replace (4 * pi / 4)%R with pi by field. unfold atanc. case Ratan.in_int ; intros H'. destruct atanc_exists as [l C2]. simpl. apply UL_sequence with (1 := C1). apply Un_cv_ext with (2 := C2). intros N. apply sum_eq. intros n _. unfold tg_alt, PI_tg. now rewrite pow1, Rmult_1_r. elim H'. split. apply Rle_trans with (2 := Rle_0_1). rewrite <- Ropp_0. apply Ropp_le_contravar. apply Rle_0_1. apply Rle_refl. assert (H3: forall x, (0 < x -> atan x = x * atanc x)%R). intros x Hx. destruct (Req_dec x 1) as [J1|J1]. now rewrite J1. generalize (H1 x). unfold atanc. case Ratan.in_int ; intros H. destruct (proj2 H) as [J2|J2]. case atanc_exists ; simpl ; intros l _. intros K. apply K. now split. now elim J1. intros _. field. now apply Rgt_not_eq. intros x. destruct (total_order_T 0 x) as [[J|J]|J]. now apply H3. rewrite <- J. now rewrite atan_0, Rmult_0_l. rewrite <- (Ropp_involutive x). rewrite atan_opp, atanc_opp. rewrite H3. apply sym_eq, Ropp_mult_distr_l_reverse. rewrite <- Ropp_0. now apply Ropp_lt_contravar. Qed. Lemma Un_decreasing_ln1pc : forall x : R, (0 <= x <= 1)%R -> Un_decreasing (fun n : nat => (/ INR (n + 1) * x ^ n))%R. Proof. intros x Hx n. change (S n) with (1 + n) at 2. rewrite pow_add. simpl (pow x 1). rewrite Rmult_1_r, <- Rmult_assoc. apply Rmult_le_compat_r. now apply pow_le. rewrite <- (Rmult_1_r (/ INR (n + 1))). apply Rmult_le_compat ; try easy. apply Rlt_le. apply Rinv_0_lt_compat. apply (lt_INR 0). apply Nat.lt_0_succ. apply Rlt_le. apply Rinv_lt. apply (lt_INR 0). rewrite Nat.add_comm. apply Nat.lt_0_succ. apply lt_INR. apply Nat.lt_succ_diag_r. Qed. Lemma Un_cv_ln1pc : forall x : R, (Rabs x <= 1)%R -> Un_cv (fun n : nat => (/ INR (n + 1) * x ^ n))%R 0. Proof. intros x Hx eps Heps. unfold R_dist. destruct (archimed_cor1 eps Heps) as [N [HN1 HN2]]. exists N. intros n Hn. assert (H: (0 < / INR (n + 1))%R). apply Rinv_0_lt_compat. apply (lt_INR 0). rewrite Nat.add_comm. apply Nat.lt_0_succ. rewrite Rminus_0_r. rewrite Rabs_mult, Rabs_pos_eq. apply Rle_lt_trans with (/ INR (n + 1) * 1)%R. apply Rmult_le_compat_l. now apply Rlt_le. rewrite <- (pow1 n). rewrite <- RPow_abs. apply pow_maj_Rabs. now rewrite Rabs_Rabsolu. rewrite Rmult_1_r. apply Rlt_trans with (2 := HN1). apply Rinv_lt. now apply (lt_INR 0). apply lt_INR. apply Nat.le_lt_trans with (1 := Hn). rewrite Nat.add_comm. apply Nat.lt_succ_diag_r. now apply Rlt_le. Qed. Lemma ln1pc_exists : forall x, (0 <= x < 1)%R -> { l : R | Un_cv (sum_f_R0 (tg_alt (fun n => / INR (n + 1) * x ^ n)%R)) l }. Proof. intros x Hx. apply alternated_series. apply Un_decreasing_ln1pc. apply (conj (proj1 Hx)). now apply Rlt_le. apply Un_cv_ln1pc. rewrite Rabs_pos_eq by easy. now apply Rlt_le. Qed. Lemma ln1pc_in_int : forall x, { (0 <= x < 1)%R } + { ~(0 <= x < 1)%R }. Proof. intros x. destruct (Rle_dec 0 x) as [H1|H1]. destruct (Rlt_dec x 1) as [H2|H2]. left. now split. right. now contradict H2. right. now contradict H1. Qed. Definition ln1pc x := match ln1pc_in_int x with | left H => proj1_sig (ln1pc_exists x H) | right _ => (ln (1 + x) / x)%R end. Require Import Coquelicot.Coquelicot. Lemma ln1p_ln1pc : forall x, ln (1 + x) = (x * ln1pc x)%R. Proof. intros x. unfold ln1pc. destruct ln1pc_in_int as [Hx|Hx]. 2: field ; contradict Hx ; rewrite Hx ; split ; [ apply Rle_refl | apply Rlt_0_1 ]. destruct ln1pc_exists as [y Hy]. simpl. replace y with (PSeries (fun n => (-1)^n / INR (n + 1)) x). rewrite <- PSeries_incr_1. replace (ln (1 + x)) with (RInt (fun t => / (1 + t)) 0 x). rewrite <- (PSeries_ext (PS_Int (fun n => (-1)^n))). assert (Hc: Rbar_lt (Rabs x) (CV_radius (fun n : nat => (-1) ^ n))). rewrite (CV_radius_finite_DAlembert _ 1). now rewrite Rinv_1, Rabs_pos_eq. intros n. apply pow_nonzero. now apply IZR_neq. exact Rlt_0_1. apply is_lim_seq_ext with (fun _ => 1%R). intros n. change ((-1)^(S n) / (-1)^n)%R with (-(1) * (-1)^n */ (-1)^n)%R. rewrite Rmult_assoc, Rinv_r, Rmult_1_r, Rabs_Ropp. apply eq_sym, Rabs_R1. apply pow_nonzero. now apply IZR_neq. apply is_lim_seq_const. rewrite <- RInt_PSeries with (1 := Hc). apply RInt_ext. intros t. rewrite Rmin_left, Rmax_right by easy. intros Ht. rewrite <- (Ropp_involutive t) at 1. unfold PSeries. rewrite <- (Series_ext (fun k => (-t)^k)). apply eq_sym, Series_geom. rewrite Rabs_Ropp, Rabs_pos_eq. now apply Rlt_trans with x. now apply Rlt_le. intros n. replace (-t)%R with (-1 * t)%R by ring. apply Rpow_mult_distr. intros [|n]. easy. unfold PS_incr_1. now rewrite Nat.add_comm. apply is_RInt_unique. assert (H: forall t, -1 < t -> is_derive (fun t : R => ln (1 + t)) t (/ (1 + t))). intros t Ht. auto_derive. rewrite <- (Rplus_opp_r 1). now apply Rplus_lt_compat_l. apply Rmult_1_l. apply (is_RInt_ext (Derive (fun t => ln (1 + t)))). intros t. rewrite Rmin_left by easy. intros [Ht _]. apply is_derive_unique. apply H. apply Rlt_trans with (2 := Ht). now apply IZR_lt. replace (ln (1 + x)) with (ln (1 + x) - ln (1 + 0))%R. apply (is_RInt_derive (fun t => ln (1 + t))). intros t. rewrite Rmin_left by easy. intros [Ht _]. apply Derive_correct. eexists. apply H. apply Rlt_le_trans with (2 := Ht). now apply IZR_lt. intros t. rewrite Rmin_left by easy. intros [Ht _]. apply continuous_ext_loc with (fun t : R => /(1 + t)). apply locally_interval with (-1)%R p_infty. apply Rlt_le_trans with (2 := Ht). now apply IZR_lt. easy. clear t Ht. intros t Ht _. apply sym_eq, is_derive_unique. now apply H. apply continuous_comp. apply (continuous_plus (fun t : R => 1)). apply filterlim_const. apply filterlim_id. apply (filterlim_Rbar_inv (1 + t)). apply Rbar_finite_neq. apply Rgt_not_eq. rewrite <- (Rplus_0_l 0). apply Rplus_lt_le_compat with (1 := Rlt_0_1) (2 := Ht). rewrite Rplus_0_r, ln_1. apply Rminus_0_r. apply is_pseries_unique. apply is_lim_seq_Reals. apply Un_cv_ext with (2 := Hy). intros n. rewrite <- sum_n_Reals. apply sum_n_ext. intros m. rewrite pow_n_pow. unfold tg_alt. rewrite <- Rmult_assoc. apply Rmult_comm. Qed. (** Define a shorter name *) Notation Rmult_neq0 := Rmult_integral_contrapositive_currified. Lemma Rdiv_eq_reg a b c d : (a * d = b * c -> b <> 0%R -> d <> 0%R -> a / b = c / d)%R. Proof. intros Heq Hb Hd. apply (Rmult_eq_reg_r (b * d)). field_simplify; trivial. try now rewrite Heq. now apply Rmult_neq0. Qed. Lemma Rlt_neq_sym (x y : R) : (x < y -> y <> x)%R. Proof. now intros Hxy Keq; rewrite Keq in Hxy; apply (Rlt_irrefl _ Hxy). Qed. Lemma Rdiv_pos_compat (x y : R) : (0 <= x -> 0 < y -> 0 <= x / y)%R. Proof. intros Hx Hy. unfold Rdiv; rewrite <- (@Rmult_0_l (/ y)). apply Rmult_le_compat_r; trivial. now left; apply Rinv_0_lt_compat. Qed. Lemma Rdiv_pos_compat_rev (x y : R) : (0 <= x / y -> 0 < y -> 0 <= x)%R. Proof. intros Hx Hy. unfold Rdiv; rewrite <-(@Rmult_0_l y), <-(@Rmult_1_r x). rewrite <-(Rinv_r y); [|now apply Rlt_neq_sym]. rewrite (Rmult_comm y), <-Rmult_assoc. now apply Rmult_le_compat_r; trivial; left. Qed. Lemma Rdiv_neg_compat (x y : R) : (x <= 0 -> 0 < y -> x / y <= 0)%R. Proof. intros Hx Hy. unfold Rdiv; rewrite <-(@Rmult_0_l (/ y)). apply Rmult_le_compat_r; trivial. now left; apply Rinv_0_lt_compat. Qed. Lemma Rdiv_neg_compat_rev (x y : R) : (x / y <= 0 -> 0 < y -> x <= 0)%R. Proof. intros Hx Hy. rewrite <-(@Rmult_0_l y), <-(@Rmult_1_r x). rewrite <-(Rinv_r y); [|now apply Rlt_neq_sym]. rewrite (Rmult_comm y), <-Rmult_assoc. apply Rmult_le_compat_r; trivial. now left. Qed. (** The following definition can be used by doing [rewrite !Rsimpl] *) Definition Rsimpl := (Rplus_0_l, Rplus_0_r, Rmult_1_l, Rmult_1_r, Rmult_0_l, Rmult_0_r, Rdiv_1). Section Integral. Variables (f : R -> R) (ra rb : R). Hypothesis Hab : ra < rb. Hypothesis Hint : ex_RInt f ra rb. Lemma RInt_le_r (u : R) : (forall x : R, ra <= x <= rb -> f x <= u) -> RInt f ra rb / (rb - ra) <= u. Proof. intros Hf. apply Rle_div_l. now apply Rgt_minus. rewrite Rmult_comm, <- (RInt_const (V := R_CompleteNormedModule)). apply RInt_le with (2 := Hint). now apply Rlt_le. apply ex_RInt_const. intros x [Hx1 Hx2]. apply Hf. split; now apply Rlt_le. Qed. Lemma RInt_le_l (l : R) : (forall x : R, ra <= x <= rb -> l <= f x) -> l <= RInt f ra rb / (rb - ra). Proof. intros Hf. apply Rle_div_r. now apply Rgt_minus. rewrite Rmult_comm, <- (RInt_const (V := R_CompleteNormedModule)). apply RInt_le with (3 := Hint). now apply Rlt_le. apply ex_RInt_const. intros x [Hx1 Hx2]. apply Hf. split; now apply Rlt_le. Qed. End Integral. (* TODO: remove once we require Coq >= 8.14. *) Lemma Z_div_mod_eq : forall a b : Z, (b > 0)%Z -> a = (b * (a / b) + a mod b)%Z. Proof. intros a b H. apply Z_div_mod_eq_full ; now apply Zaux.Zgt_not_eq, Z.gt_lt. Qed. interval-4.11.1/src/Plot.v.in000066400000000000000000000000421470547631300157310ustar00rootroot00000000000000Declare ML Module "@PLOTPLUGIN@". interval-4.11.1/src/Plot/000077500000000000000000000000001470547631300151415ustar00rootroot00000000000000interval-4.11.1/src/Plot/META.coq-interval000066400000000000000000000004321470547631300202140ustar00rootroot00000000000000package "plot" ( directory = "." description = "Coq Interval Plot" requires = "coq-core.plugins.ltac" archive(byte) = "interval_plot.cma" archive(native) = "interval_plot.cmxa" plugin(byte) = "interval_plot.cma" plugin(native) = "interval_plot.cmxs" ) directory = "." interval-4.11.1/src/Plot/plot.c000066400000000000000000000245111470547631300162660ustar00rootroot00000000000000open Big_int_Z #if COQVERSION >= 81500 let constr_of_global gr = UnivGen.constr_of_monomorphic_global (Global.env ()) gr #else let constr_of_global = UnivGen.constr_of_monomorphic_global #endif #if COQVERSION >= 81800 let decompose_app = EConstr.decompose_app #else let decompose_app = Termops.decompose_app_vect #endif let find_reference t x = lazy (EConstr.of_constr (constr_of_global (Coqlib.gen_reference_in_modules "Interval" [t] x))) let is_global evd c t = EConstr.eq_constr evd (Lazy.force c) t let coq_ref_Datatypes = find_reference ["Coq"; "Init"; "Datatypes"] let coq_cons = coq_ref_Datatypes "cons" let coq_nil = coq_ref_Datatypes "nil" let coq_pair = coq_ref_Datatypes "pair" let coq_ref_Logic = find_reference ["Coq"; "Init"; "Logic"] let coq_and = coq_ref_Logic "and" let coq_ref_BinNums = find_reference ["Coq"; "Numbers"; "BinNums"] let coq_Z0 = coq_ref_BinNums "Z0" let coq_Zpos = coq_ref_BinNums "Zpos" let coq_Zneg = coq_ref_BinNums "Zneg" let coq_xH = coq_ref_BinNums "xH" let coq_xI = coq_ref_BinNums "xI" let coq_xO = coq_ref_BinNums "xO" let coq_ref_Rdefinitions = find_reference ["Coq"; "Reals"; "Rdefinitions"] let coq_Rdiv = coq_ref_Rdefinitions "Rdiv" let coq_Rle = coq_ref_Rdefinitions "Rle" let coq_IZR = coq_ref_Rdefinitions "IZR" let interval_plot2 = find_reference ["Interval"; "Tactics"; "Plot_helper"] "plot2" exception Unrecognized of EConstr.t let rec tr_positive evd p = match EConstr.kind evd p with | Constr.Construct _ when is_global evd coq_xH p -> unit_big_int | Constr.App (f, [|a|]) when is_global evd coq_xI f -> add_int_big_int 1 (shift_left_big_int (tr_positive evd a) 1) | Constr.App (f, [|a|]) when is_global evd coq_xO f -> shift_left_big_int (tr_positive evd a) 1 | Constr.Cast (p, _, _) -> tr_positive evd p | _ -> raise (Unrecognized p) let rec tr_Z evd t = match EConstr.kind evd t with | Constr.Construct _ when is_global evd coq_Z0 t -> zero_big_int | Constr.App (f, [|a|]) when is_global evd coq_Zpos f -> tr_positive evd a | Constr.App (f, [|a|]) when is_global evd coq_Zneg f -> minus_big_int (tr_positive evd a) | Constr.Cast (t, _, _) -> tr_Z evd t | _ -> raise (Unrecognized t) type rval = | Rcst of big_int | Rdiv of rval * rval let rec tr_R evd t = match EConstr.kind evd t with | Constr.App (f, [|a|]) when is_global evd coq_IZR f -> Rcst (tr_Z evd a) | Constr.App (f, [|a;b|]) when is_global evd coq_Rdiv f -> Rdiv (tr_R evd a, tr_R evd b) | Constr.Cast (t, _, _) -> tr_R evd t | _ -> raise (Unrecognized t) let rec tr_ineq evd t = match EConstr.kind evd t with | Constr.App (f, [|a;b|]) when is_global evd coq_Rle f -> (a, b) | _ -> raise (Unrecognized t) let rec tr_bounds evd t = match EConstr.kind evd t with | Constr.App (f, [|i1;i2|]) when is_global evd coq_and f -> let (b1, x1) = tr_ineq evd i1 in let (x2, b2) = tr_ineq evd i2 in if x1 <> x2 then raise (Unrecognized t); (tr_R evd b1, x1, tr_R evd b2) | _ -> raise (Unrecognized t) let rec tr_point_list evd t acc = match EConstr.kind evd t with | Constr.App (f, [|_|]) when is_global evd coq_nil f -> List.rev acc | Constr.App (f, [|_;a;b|]) when is_global evd coq_cons f -> let h = match EConstr.kind evd a with | Constr.App (f, [|_;_;a;b|]) when is_global evd coq_pair f -> (tr_Z evd a, tr_Z evd b) | _ -> raise (Unrecognized a) in tr_point_list evd b (h :: acc) | Constr.Cast (t, _, _) -> tr_point_list evd t acc | _ -> raise (Unrecognized t) let tr_point_list evd t = tr_point_list evd t [] let tr_plot evd p = match decompose_app evd p with | c, [|_; ox; dx; oy; dy; h; l|] when is_global evd interval_plot2 c -> (tr_R evd ox, tr_R evd dx, tr_R evd oy, tr_R evd dy, tr_Z evd h, tr_point_list evd l) | _ -> raise (Unrecognized p) let rec pr_R fmt = function | Rcst n -> Format.fprintf fmt "%s." (string_of_big_int n) | Rdiv (a,b) -> Format.fprintf fmt "(%a / %a)" pr_R a pr_R b let of_R = function | Rcst n -> float_of_big_int n | Rdiv (Rcst a, Rcst b) -> float_of_big_int a /. float_of_big_int b | _ -> assert false let generate fmt h l = Format.fprintf fmt "set xrange [] noextend@\n"; Format.fprintf fmt "plot '-' using (ox+dx*$1):(oy+dy*$2):(oy+dy*$3) notitle with filledcurves@\n"; let z = ref (h, zero_big_int) in let print_row i y1 y2 = Format.fprintf fmt "%d %s %s@\n" i (string_of_big_int y1) (string_of_big_int y2) in List.iteri (fun i y -> let (z1, z2) = y in let z1 = min_big_int z1 (fst !z) in let z2 = max_big_int z2 (snd !z) in print_row i z1 z2; z := y) l; print_row (List.length l) (fst !z) (snd !z); Format.fprintf fmt "e@\npause mouse close@\n@." let display_plot_aux env evd p f = match tr_plot evd p with | (ox, dx, oy, dy, h, l) -> let file = match f with | None -> Filename.temp_file "interval_plot" "" | Some f -> f in let ch = open_out file in let fmt = Format.formatter_of_out_channel ch in Format.fprintf fmt "ox = %a@\ndx = %a@\noy = %a@\ndy = %a@\n" pr_R ox pr_R dx pr_R oy pr_R dy; generate fmt h l; close_out ch; begin match f with | None -> let e = Sys.command (Printf.sprintf "(gnuplot %s ; rm %s) &" file file) in if e <> 0 then CErrors.user_err ~hdr:"plot" (Pp.str "Gnuplot not found") | Some _ -> () end | exception (Unrecognized e) -> CErrors.user_err ~hdr:"plot" Pp.(str "Cannot parse" ++ spc () ++ Printer.pr_econstr_env env evd e) let display_plot p f ~pstate = let evd, env = match pstate with | None -> let env = Global.env () in Evd.from_env env, env | Some lemma -> Declare.Proof.get_current_context lemma in let evd, p = Constrintern.interp_constr_evars env evd p in let p = Retyping.get_type_of env evd p in display_plot_aux env evd p f #if COQVERSION >= 81800 let decompose_prod_decls = EConstr.decompose_prod_decls #else let decompose_prod_decls = EConstr.decompose_prod_assum #endif let pr_type env evd typ = let (rel, typ) = decompose_prod_decls evd typ in let penv = EConstr.push_rel_context rel env in match tr_bounds evd typ with | (b1, x, b2) -> let b1 = of_R b1 in let b2 = of_R b2 in let c = (b1 +. b2) *. 0.5 in if (b2 -. b1) <= 1e-13 *. c then Pp.(Printer.pr_econstr_env penv evd x ++ str " ≈ " ++ real c) else Pp.(Printer.pr_econstr_env penv evd x ++ str " ∈ [" ++ real b1 ++ str "; " ++ real b2 ++ str "]") | exception Unrecognized _ -> Printer.pr_econstr_env penv evd typ #if COQVERSION >= 81800 let cgenarg a = Constrexpr.CGenarg a #else let cgenarg a = Constrexpr.CHole (None, Namegen.IntroAnonymous, Some a) #endif let perform_tac nam bl tac = let arg = Genarg.in_gen (Genarg.rawwit Ltac_plugin.Tacarg.wit_tactic) tac in let term = CAst.make (cgenarg arg) in let env = Global.env () in let name = match nam with | None -> Namegen.next_global_ident_away (Names.Id.of_string "__") Names.Id.Set.empty | Some n -> n in let evd = Evd.from_env env in let evd, (body, typ), impargs = ComDefinition.interp_definition ~program_mode:false env evd Names.Id.Map.empty bl None term None in let typ = match typ with | Some t -> t | None -> Retyping.get_type_of ~lax:true env evd body in let cinfo = Declare.CInfo.make ~name ~typ:(Some typ) () in let info = Declare.Info.make () in let _r = Flags.silently (Declare.declare_definition ~info ~cinfo ~opaque:true ~body) evd in match decompose_app evd typ with | c, [|_; ox; dx; oy; dy; h; l|] when is_global evd interval_plot2 c -> if nam = None then display_plot_aux env evd typ None | _ -> Feedback.msg_notice (pr_type env evd typ) let __coq_plugin_name = PLOTPLUGIN let _ = Mltop.add_known_module __coq_plugin_name #if COQVERSION >= 81900 let vtreadproofopt = Vernactypes.vtreadproofopt let vtdefault = Vernactypes.vtdefault #elif COQVERSION >= 81500 let vtreadproofopt = Vernacextend.vtreadproofopt let vtdefault = Vernacextend.vtdefault #else let vtreadproofopt x = Vernacextend.VtReadProofOpt x let vtdefault x = Vernacextend.VtDefault x #endif #if COQVERSION >= 81800 let vernac_extend = Vernacextend.static_vernac_extend ~plugin:(Some "coq-interval.plot") #else let vernac_extend = Vernacextend.vernac_extend #endif open Vernacextend let () = vernac_extend ~command:"VernacPlot" ~classifier:(fun _ -> classify_as_query) ?entry:None [TyML (false, TyTerminal ("Plot", TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Stdarg.wit_constr), TyNil)), #if COQVERSION >= 81400 (fun r ?loc ~atts () -> #else (fun r ~atts -> #endif Attributes.unsupported_attributes atts; vtreadproofopt (display_plot r None)), None); TyML (false, TyTerminal ("Plot", TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Stdarg.wit_constr), TyTerminal ("as", TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Stdarg.wit_string), TyNil)))), #if COQVERSION >= 81400 (fun r s ?loc ~atts () -> #else (fun r s ~atts -> #endif Attributes.unsupported_attributes atts; vtreadproofopt (display_plot r (Some s))), None)] let () = vernac_extend ~command:"VernacDo" ?entry:None [TyML (false, TyTerminal ("Def", TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Stdarg.wit_ident), TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Ltac_plugin.G_rewrite.wit_binders), TyTerminal (":=", TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Ltac_plugin.Tacarg.wit_tactic), TyNil))))), #if COQVERSION >= 81400 (fun name bl tac ?loc ~atts () -> #else (fun name bl tac ~atts -> #endif Attributes.unsupported_attributes atts; vtdefault (fun () -> perform_tac (Some name) bl tac)), Some (fun name bl tac -> VtSideff ([name], VtLater))); TyML (false, TyTerminal ("Do", TyNonTerminal (Extend.TUentry (Genarg.get_arg_tag Ltac_plugin.Tacarg.wit_tactic), TyNil)), #if COQVERSION >= 81400 (fun tac ?loc ~atts () -> #else (fun tac ~atts -> #endif Attributes.unsupported_attributes atts; vtdefault (fun () -> perform_tac None [] tac)), Some (fun tac -> VtSideff ([], VtLater)))] interval-4.11.1/src/Plot/plot.py000066400000000000000000000034351470547631300164760ustar00rootroot00000000000000import re import sys real_re = re.compile(r'([^%]*)') int_re = re.compile(r'([-0-9]+)') pair_re = re.compile(r'\(([0-9]+)%?Z?, ([0-9]+)%?Z?\)') def read_real(s): return re.sub(int_re, r'\1.', re.match(real_re, s).group(1)) ox = read_real(sys.stdin.readline()) dx = read_real(sys.stdin.readline()) oy = read_real(sys.stdin.readline()) dy = read_real(sys.stdin.readline()) h = int(re.match(real_re, sys.stdin.readline()).group(1)) values = [] for m in pair_re.finditer(sys.stdin.read()): y1 = m.group(1) y2 = m.group(2) values.append([int(y1), int(y2)]) mode = "vec" w = len(values) print(f"ox = {ox}") print(f"dx = {dx}") print(f"oy = {oy}") print(f"dy = {dy}") if mode == "vec": print("set xrange [] noextend") print("plot '-' using (ox+dx*$1):(oy+dy*$2):(oy+dy*$3) notitle with filledcurves") z1, z2 = values[0] print(0, z1, z2) for i in range(1,w): y1, y2 = values[i] if y1 < z1: z1 = y1 if y2 > z2: z2 = y2 print(i, z1, z2) z1, z2 = y1, y2 print(w, z1, z2) print("e") print("pause mouse close") else: ww = w + 150 hh = h + 100 print(f"set terminal png size {ww},{hh}") print(f"set lmargin at screen {100/ww}") print(f"set rmargin at screen {(100+w)/ww}") print(f"set tmargin at screen {50/hh}") print(f"set bmargin at screen {(50+h)/hh}") #print(f"set size ratio {h/w}") print("set xrange [] noextend") print("set yrange [] noextend") print(f"plot '-' binary array=({w},{h}) scan=yx format='%uchar' origin=(ox+dx/2,oy+dy/2) dx=dx dy=dy using 1:1:1 notitle with rgbimage") sys.stdout.flush() s = b'' for i in range(0, w): y1, y2 = values[i] s = s + (b'\xFF' * y1) + (b'\x00' * (y2 - y1)) + (b'\xFF' * (h - y2)) sys.stdout.buffer.write(s) interval-4.11.1/src/Poly/000077500000000000000000000000001470547631300151465ustar00rootroot00000000000000interval-4.11.1/src/Poly/Basic_rec.v000066400000000000000000000477571470547631300172330ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Rfunctions NaryFunctions Lia. From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop tuple. Require Import MathComp. (* This library defines polymorphic definitions rec1up (resp. rec2up) that make it possible to compute the list [:: u(0); u(1);...; u(n)] for a given function u defined by an order-1 (resp. order-2) recurrence. *) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Ltac flatten := repeat first[rewrite Nat.sub_1_r in *| rewrite<-plusE in *|rewrite<-minusE in *]. Ltac iomega := intros; flatten; (lia || apply/leP; lia). Ltac iomega_le := (repeat move/leP=>?); iomega. (** * Additional lemmas about [seq] *) Notation nth_defaults := set_nth_default. (* for backward compatibility *) Lemma behead_rcons (T : Type) (s : seq T) (x : T) : s <> [::] -> behead (rcons s x) = rcons (behead s) x. Proof. by case: s. Qed. Lemma behead_rev_take (T : Type) (s : seq T) (n : nat) : n <= size s -> behead (rev (take n s)) = rev (take n.-1 s). Proof. elim: n s =>[//|n IHn] [//|x s] H //. rewrite ltnS -/size in H. rewrite /=. case: n IHn H =>[//|n] /= IHn H; first by rewrite take0 //. rewrite [in RHS]rev_cons -IHn // rev_cons behead_rcons //. move/(f_equal size). fold (@take T); fold (@size T) in H. rewrite size_rev size_take. case: leq =>//=. by move=> top; rewrite top in H. Qed. (** * Order-1 recurrences *) Section Defix1. Variable T : Type. Variable F : T -> nat -> T. (** to be instantiated by a function satisfying u(n) = F(u(n-1), n). *) Fixpoint loop1 (n p : nat) (a : T) (s : seq T) {struct n} : seq T := match n with | 0 => s | m.+1 => let c := F a p in loop1 m p.+1 c (c :: s) end. Variable a0 : T. Definition rec1down n := loop1 n 1 a0 [:: a0]. Definition rec1up n := rev (rec1down n). Lemma size_loop1 n p a s : size (loop1 n p a s) = n + size s. Proof. by elim: n p a s => [//|n IHn] *; rewrite IHn addSnnS. Qed. Lemma size_rec1down n : size (rec1down n) = n.+1. Proof. by case: n => [//|n]; rewrite size_loop1 addn1. Qed. Lemma size_rec1up n : size (rec1up n) = n.+1. Proof. by rewrite size_rev size_rec1down. Qed. Variable d : T. Lemma head_loop1S n s a p : head d s = a -> head d (loop1 n.+1 p a s) = F (head d (loop1 n p a s)) (n+p). Proof. by elim: n s a p => [_ _ _->//|n IHn s a p H]; rewrite !IHn // addSnnS. Qed. Theorem head_loop1 (n p : nat) a s : head d s = a -> head d (loop1 n p a s) = iteri n (fun i c => F c (i + p)) a. Proof. elim: n p a s =>[//|n IHn] p a s H. move E: (n.+1) => n'. rewrite /= -{}E IHn //. clear; elim: n =>[//=|n IHn]. by rewrite /= IHn /= addSnnS. Qed. Lemma head_rec1downS n : head d (rec1down n.+1) = F (head d (rec1down n)) n.+1. Proof. by rewrite head_loop1S ?addn1. Qed. Lemma nth_rec1up_last k : nth d (rec1up k) k = last d (rec1up k). Proof. by rewrite (last_nth d) size_rec1up. Qed. Lemma last_rec1up k : last d (rec1up k) = head d (loop1 k 1 a0 [:: a0]). Proof. by rewrite /rec1up /rec1down last_rev. Qed. Lemma nth_rec1upS k : nth d (rec1up k.+1) k.+1 = F (nth d (rec1up k) k) k.+1. Proof. by rewrite !nth_rec1up_last !last_rev head_rec1downS. Qed. Lemma loop1S_ex n p a s : exists c, loop1 n.+1 p a s = c :: (loop1 n p a s). Proof. elim: n p a s=> [|n IH] p a s; first by exists (F a p). remember (S n) as n'; simpl. case: (IH p.+1 (F a p) (F a p :: s))=> [c Hc]. rewrite Hc {}Heqn' /=. by exists c. Qed. Lemma behead_rec1down n : behead (rec1down n.+1) = rec1down n. Proof. by rewrite /rec1down; case: (loop1S_ex n 1 a0 [:: a0])=> [c ->]. Qed. Lemma nth_rec1downD d1 p q n : nth d1 (rec1down (p+q+n)) (p+q) = nth d1 (rec1down (p+n)) p. Proof. elim: q=> [|q IH]; first by rewrite addn0. by rewrite !addnS addSn -nth_behead behead_rec1down. Qed. Lemma nth_rec1downD_dflt2 d1 d2 p q n : nth d1 (rec1down (p+q+n)) (p+q) = nth d2 (rec1down (p+n)) p. Proof. rewrite nth_rec1downD (nth_defaults d1 d2) // size_rec1down. by iomega. Qed. Lemma nth_rec1down_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 -> nth d1 (rec1down m1) (m1 - n) = nth d2 (rec1down m2) (m2 - n). Proof. move=> h1 h2. have h1' := subnKC h1; have h2' := subnKC h2. case: (ltngtP m1 m2)=> Hm; last first. - by rewrite Hm (nth_defaults d1 d2) // size_rec1down; iomega. - set p := m2 - n in h2' *. rewrite -h2' addnC. pose q := m1 - m2. have Hpq : m1 - n = p + q. rewrite /p /q in h2' *. by rewrite addnC addnBA // subnK // ltnW. rewrite Hpq. have->: m1 = p + q + n by rewrite -Hpq subnK. exact: nth_rec1downD_dflt2. set p := m1 - n in h1' *. rewrite -h1' addnC. pose q := m2 - m1. have Hpq : m2 - n = p + q. rewrite /p /q in h2' *. by rewrite addnC addnBA // subnK // ltnW. rewrite Hpq. have->: m2 = p + q + n by rewrite -Hpq subnK. symmetry; exact: nth_rec1downD_dflt2. Qed. Lemma nth_rec1up_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 -> nth d1 (rec1up m1) n = nth d2 (rec1up m2) n. Proof. move=> h1 h2. rewrite !nth_rev; first last. - by rewrite size_loop1 /=; move: h1 h2; iomega_le. - by rewrite size_loop1 /=; move: h1 h2; iomega_le. rewrite !size_loop1 /= !addn1 !subSS. exact: nth_rec1down_indep. Qed. Theorem nth_rec1up n k : nth d (rec1up n) k = if n < k then d else iteri k (fun i c => F c (i + 1)) a0. Proof. case: (ltnP n k) => H; first by rewrite nth_default // size_rec1up. rewrite (@nth_rec1up_indep d d n k k) //. by rewrite nth_rec1up_last last_rec1up head_loop1. Qed. (** For the base case *) Lemma rec1down_co0 n: nth d (rec1down n) n = a0. Proof. elim: n=> [//|n IH]. by rewrite /rec1down; have [c ->] := loop1S_ex n 1 a0 [:: a0]. Qed. Lemma rec1up_co0 n : nth d (rec1up n) 0 = a0. Proof. by rewrite nth_rev size_rec1down // subn1 rec1down_co0. Qed. End Defix1. Section GenDefix1. Variables A T : Type. Variable F : A -> nat -> A. (* may involve symbolic differentiation *) (** to be instantiated by a function satisfying a(n+1)=F(a(n),n+1). *) Variable G : A -> nat -> T. (** to be instantiated by a function satisfying u(N+n)=G(a(n),N+n). Here, N is the size of the list [init]. *) Fixpoint gloop1 (n p : nat) (a : A) (s : seq T) {struct n} : seq T := match n with | 0 => s | m.+1 => let r := G a p in let p1 := p.+1 in let c := F a p1 in gloop1 m p1 c (r :: s) end. Variable a0 : A. Variable init : seq T. (** Remark: [init] can be nil *) Definition grec1down n := if (n.+1 - size init) is n'.+1 then gloop1 n'.+1 (size init) a0 (rev init) else rev (take n.+1 init). Lemma grec1downE (n : nat) : grec1down n = if n >= size init then gloop1 (n - size init).+1 (size init) a0 (rev init) else rev (take n.+1 init). Proof. rewrite /grec1down. case: (leqP (size init) n)=>H; first by rewrite subSn //. by move: H; rewrite -subn_eq0; move/eqP->. Qed. Definition grec1up n := rev (grec1down n). Lemma size_gloop1 n p a s : size (gloop1 n p a s) = n + size s. Proof. by elim: n p a s => [//|n IHn] *; rewrite IHn addSnnS. Qed. Lemma size_grec1down n : size (grec1down n) = n.+1. Proof. rewrite /grec1down. case E: (n.+1 - size init) =>[|k]. rewrite size_rev size_take. move/eqP: E; rewrite subn_eq0 leq_eqVlt. case/orP; last by move->. move/eqP->; rewrite ifF //. by rewrite ltnn. rewrite size_gloop1 /= -E. by rewrite size_rev subnK // ltnW // -subn_gt0 E. Qed. Lemma size_grec1up n : size (grec1up n) = n.+1. Proof. by rewrite size_rev size_grec1down. Qed. Theorem grec1up_init n : n < size init -> grec1up n = take n.+1 init. Proof. by rewrite /grec1up /grec1down -subn_eq0; move/eqP ->; rewrite revK. Qed. Theorem last_grec1up (d : T) (n : nat) : size init <= n -> last d (grec1up n) = head d (gloop1 (n - size init).+1 (size init) a0 (rev init)). Proof. by move=> Hn; rewrite /grec1up /grec1down subSn // last_rev. Qed. Theorem head_gloop1 (d : T) (n p : nat) (a : A) (s : seq T): head d (gloop1 n.+1 p a s) = G (iteri n (fun i c => F c (i + p).+1) a) (n + p). Proof. elim: n p a s =>[//|n IHn] p a s. move E: (n.+1) => n'. rewrite /= -{}E IHn. congr G; last by rewrite addSnnS. clear; elim: n =>[//=|n IHn]. by rewrite /= IHn /= addSnnS. Qed. Lemma gloop1S_ex n p a s : exists c, gloop1 n.+1 p a s = c :: (gloop1 n p a s). Proof. elim: n p a s => [|n IH] p a s; first by exists (G a p). remember (S n) as n'; simpl. case: (IH p.+1 (F a p.+1) (G a p :: s))=> [c Hc]. rewrite Hc {}Heqn' /=. by exists c. Qed. Theorem behead_grec1down (n : nat) : behead (grec1down n.+1) = grec1down n. Proof. pose s := rev init. pose m := size init. rewrite !grec1downE. case: (leqP (size init) n) => H. rewrite leqW // subSn //. have [c Hc] := gloop1S_ex (n - m).+1 m a0 s. by rewrite Hc. rewrite leq_eqVlt in H; case/orP: H; [move/eqP|] => H. rewrite -H subnn /= ifT H //. by rewrite take_oversize. rewrite ifF 1?leqNgt ?H //. by rewrite behead_rev_take. Qed. Lemma nth_grec1downD d1 p q n: nth d1 (grec1down (p+q+n)) (p+q) = nth d1 (grec1down (p+n)) p. Proof. elim: q=> [|q IH]; first by rewrite addn0. by rewrite !addnS addSn -nth_behead behead_grec1down. Qed. Lemma nth_grec1downD_dflt2 d1 d2 p q n: nth d1 (grec1down (p+q+n)) (p+q) = nth d2 (grec1down (p+n)) p. Proof. rewrite nth_grec1downD (set_nth_default d1 d2) //. by rewrite size_grec1down ltnS leq_addr. Qed. Theorem nth_grec1down_indep (d1 d2 : T) (m1 m2 n : nat) : n <= m1 -> n <= m2 -> nth d1 (grec1down m1) (m1 - n) = nth d2 (grec1down m2) (m2 - n). Proof. move=> h1 h2. have h1' := subnKC h1; have h2' := subnKC h2. case: (ltngtP m1 m2)=> Hm. - set p := m1 - n in h1' *. rewrite -h1' addnC. pose q := m2 - m1. have Hpq : m2 - n = p + q. rewrite /p /q in h2' *. by rewrite addnC addnBA // subnK // ltnW. rewrite Hpq. have->: m2 = p + q + n. by rewrite -Hpq subnK. symmetry; exact: nth_grec1downD_dflt2. - set p := m2 - n in h2' *. rewrite -h2' addnC. pose q := m1 - m2. have Hpq : m1 - n = p + q. rewrite /p /q in h2' *. by rewrite addnC addnBA // subnK // ltnW. rewrite Hpq. have->: m1 = p + q + n. by rewrite -Hpq subnK. exact: nth_grec1downD_dflt2. - rewrite Hm (nth_defaults d1 d2) // size_grec1down. exact: leq_ltn_trans (@leq_subr n m2) _. Qed. Theorem nth_grec1up_indep (d1 d2 : T) (m1 m2 n : nat) : n <= m1 -> n <= m2 -> nth d1 (grec1up m1) n = nth d2 (grec1up m2) n. Proof. move=> h1 h2; rewrite !nth_rev; try by rewrite size_grec1down. rewrite !size_grec1down !subSS; exact: nth_grec1down_indep. Qed. Arguments nth_grec1up_indep [d1 d2 m1 m2 n] _ _. Lemma nth_grec1up_last (d : T) k : nth d (grec1up k) k = last d (grec1up k). Proof. by rewrite (last_nth d) size_grec1up. Qed. Theorem nth_grec1up d n k : nth d (grec1up n) k = if n < k then d else if k < size init then nth d init k else G (iteri (k - size init) (fun i c => F c (i + size init).+1) a0) k. Proof. case: (ltnP n k) => H; first by rewrite nth_default // size_grec1up. rewrite (nth_grec1up_indep (d2 := d) (m2 := k)) //. case: (ltnP k (size init)) => H'; first by rewrite grec1up_init // nth_take. rewrite nth_grec1up_last last_grec1up // head_gloop1; congr G. by rewrite subnK. Qed. Arguments nth_grec1up [d] n k. End GenDefix1. Section Defix2. Variable T : Type. Variable F : T -> T -> nat -> T. (** to be instantiated by a function satisfying u(n) = F(u(n-2), u(n-1), n). *) Fixpoint loop2 (n p : nat) (a b : T) (s : seq T) {struct n} : seq T := match n with | 0 => s | m.+1 => let c := F a b p in loop2 m p.+1 b c (c :: s) end. Variables a0 a1 : T. Definition rec2down n := if n is n'.+1 then (loop2 n' 2 a0 a1 [:: a1; a0]) else [:: a0]. Definition rec2up n := rev (rec2down n). Lemma size_loop2 n p a b s : size (loop2 n p a b s) = n + size s. Proof. by elim: n p a b s => [//|n IHn] *; rewrite IHn !addSnnS. Qed. Lemma size_rec2down n : size (rec2down n) = n.+1. Proof. by case: n => [//|[//|n]]; rewrite size_loop2 addn2. Qed. Lemma size_rec2up n : size (rec2up n) = n.+1. Proof. by rewrite size_rev size_rec2down. Qed. Variable d : T. Lemma head_loop2S n s a b p : hb d s = a -> head d s = b -> let s' := (loop2 n p a b s) in head d (loop2 n.+1 p a b s) = F (hb d s') (head d s') (n+p). Proof. elim: n s a b p => [|n IHn] s a b p Ha Hb; first by rewrite /= Ha Hb. by rewrite IHn // addSnnS. Qed. Lemma head_rec2downSS n : head d (rec2down n.+2) = F (hb d (rec2down n.+1)) (head d (rec2down n.+1)) n.+2. Proof. by case: n => [//|n]; rewrite head_loop2S ?addn2. Qed. Lemma behead_loop2 n s a b p : behead (loop2 n.+1 p a b s) = loop2 n p a b s. Proof. by elim: n s a b p => [//|n IHn] s a b p; rewrite IHn. Qed. Lemma behead_rec2down n : behead (rec2down n.+1) = rec2down n. Proof. by case: n => [//|n]; rewrite behead_loop2. Qed. (* Let coa k := nth d (rec2up k) k. Let coa' k := last d (rec2up k). *) Lemma nth_rec2up_last k : nth d (rec2up k) k = last d (rec2up k). Proof. by case: k => [//|k]; rewrite (last_nth d) size_rec2up. Qed. Theorem last_rec2up k : last d (rec2up k.+1) = head d (loop2 k 2 a0 a1 [:: a1; a0]). Proof. by rewrite /rec2up /rec2down last_rev. Qed. Lemma nth_rec2downSS' k : nth d (rec2down k.+2) 0 = F (nth d (rec2down k) 0) (nth d (rec2down k.+1) 0) k.+2. Proof. by rewrite !nth0 -[rec2down k]behead_rec2down head_rec2downSS. Qed. Lemma nth_rec2upSS' k : nth d (rec2up k.+2) k.+2 = F (nth d (rec2up k) k) (nth d (rec2up k.+1) k.+1) k.+2. Proof. by rewrite /rec2up !nth_rev ?size_rec2down // !subnn nth_rec2downSS'. Qed. Lemma nth_rec2downD d1 p q n : nth d1 (rec2down (p+q+n)) (p+q) = nth d1 (rec2down (p+n)) p. Proof. elim: q=> [|q IH]; first by rewrite addn0. by rewrite !addnS addSn -nth_behead behead_rec2down. Qed. Lemma nth_rec2downD_dflt2 d1 d2 p q n : nth d1 (rec2down (p+q+n)) (p+q) = nth d2 (rec2down (p+n)) p. Proof. rewrite nth_rec2downD (nth_defaults d1 d2) // size_rec2down. by iomega. Qed. Lemma nth_rec2down_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 -> nth d1 (rec2down m1) (m1 - n) = nth d2 (rec2down m2) (m2 - n). Proof. move=> h1 h2. have h1' := subnKC h1; have h2' := subnKC h2. case: (ltngtP m1 m2)=> Hm; last first. - rewrite Hm (nth_defaults d1 d2) //. by rewrite size_rec2down; iomega. - set p := m2 - n in h2' *. rewrite -h2' addnC. pose q := m1 - m2. have Hpq : m1 - n = p + q. rewrite /p /q in h2' *. by rewrite addnC addnBA // subnK // ltnW. rewrite Hpq. have->: m1 = p + q + n by rewrite -Hpq subnK. exact: nth_rec2downD_dflt2. - set p := m1 - n in h1' *. rewrite -h1' addnC. pose q := m2 - m1. have Hpq : m2 - n = p + q. rewrite /p /q in h2' *. by rewrite addnC addnBA // subnK // ltnW. rewrite Hpq. have->: m2 = p + q + n by rewrite -Hpq subnK. symmetry; exact: nth_rec2downD_dflt2. Qed. Lemma nth_rec2up_indep d1 d2 m1 m2 n : n <= m1 -> n <= m2 -> nth d1 (rec2up m1) n = nth d2 (rec2up m2) n. Proof. move=> h1 h2. rewrite !nth_rev; first last. - by rewrite size_rec2down /=; move: h1 h2; iomega_le. - by rewrite size_rec2down /=; move: h1 h2; iomega_le. rewrite !size_rec2down /= !subSS. exact: nth_rec2down_indep. Qed. End Defix2. Section RecZ. (* Helper functions to compute [1/0!; p/1!; ...; p*(p-1)*...*(p-n+1)/n!] *) Definition fact_rec (a : Z) (n : nat) : Z := Z.mul a (Z.of_nat n). Definition fact_seq := rec1up fact_rec 1%Z. Theorem fact_seq_correct (d : Z) (n k : nat) : k <= n -> nth d (fact_seq n) k = Z.of_nat (fact k). Proof. elim: k => [|k IHk] Hkn; first by rewrite rec1up_co0. move/(_ (ltnW Hkn)) in IHk. move: IHk. rewrite /fact_seq. rewrite (@nth_rec1up_indep _ _ _ d d _ k); try exact: ltnW || exact: leqnn. move => IHk. rewrite (@nth_rec1up_indep _ _ _ d d _ k.+1) //. rewrite nth_rec1upS IHk /fact_rec. rewrite fact_simpl. zify; ring. Qed. Lemma size_fact_seq n : size (fact_seq n) = n.+1. Proof. by rewrite size_rec1up. Qed. Definition falling_rec (p : Z) (a : Z) (n : nat) : Z := (a * (p - (Z.of_nat n) + 1))%Z. Definition falling_seq (p : Z) := rec1up (falling_rec p) 1%Z. Theorem falling_seq_correct (d : Z) (p : Z) (n k : nat) : k <= n -> nth d (falling_seq p n) k = \big[Z.mul/1%Z]_(0 <= i < k) (p - Z.of_nat i)%Z. Proof. elim: k => [|k IHk] Hkn; first by rewrite rec1up_co0 big_mkord big_ord0. move/(_ (ltnW Hkn)) in IHk. move: IHk. rewrite /falling_seq. rewrite (@nth_rec1up_indep _ _ _ d d _ k); try exact: ltnW || exact: leqnn. move => IHk. rewrite (@nth_rec1up_indep _ _ _ d d _ k.+1) //. rewrite nth_rec1upS IHk /falling_rec. rewrite big_nat_recr //=. congr Z.mul. zify; ring. Qed. Lemma size_falling_seq p n : size (falling_seq p n) = n.+1. Proof. by rewrite size_rec1up. Qed. End RecZ. (** Refinement proofs for rec1, rec2, grec1 *) Section rec_proofs. Variables (V T : Type). Variable Rel : V -> T -> Prop. Variables (dv : V) (dt : T). Hypothesis H0 : Rel dv dt. Local Notation RelP sv st := (forall k : nat, Rel (nth dv sv k) (nth dt st k)) (only parsing). Lemma grec1up_correct (A := seq V) Fi (F : A -> nat -> A) Gi (G : A -> nat -> V) ai a si s n : (forall qi q m, RelP q qi -> RelP (F q m) (Fi qi m)) -> (forall qi q m, RelP q qi -> Rel (G q m) (Gi qi m)) -> RelP a ai -> RelP s si -> size s = size si -> RelP (grec1up F G a s n) (grec1up Fi Gi ai si n). Proof. move=> HF HG Ha Hs Hsize k. pose s1 := (size (grec1up F G a s n)).-1. case: (ltnP n k) => Hnk; first by rewrite !nth_default ?size_grec1up. have H1 : k = (size (grec1up F G a s k)).-1 by rewrite size_grec1up. have H2 : k = (size (grec1up Fi Gi ai si k)).-1 by rewrite size_grec1up. rewrite ?(@nth_grec1up_indep _ _ _ _ _ _ dv dv n k k) ?(@nth_grec1up_indep _ _ _ _ _ _ dt dt n k k) //. case: (ltnP k (size s)) => Hk. - have Hki : k < size si by rewrite -Hsize. rewrite ?(grec1up_init _ _ _ Hk, grec1up_init _ _ _ Hki) ?nth_take_dflt ltnn. exact: Hs. - have Hki : size si <= k by rewrite -Hsize. rewrite {4}H2 {2}H1 !nth_last !last_grec1up ?head_gloop1 // Hsize. apply: HG => j; set l := k - size si. elim: l j => [|l IHl] j /=; by [apply: Ha | apply: HF; apply: IHl]. Qed. Lemma rec1up_correct fi f fi0 f0 n : (forall ai a m, Rel a ai -> Rel (f a m) (fi ai m)) -> Rel f0 fi0 -> RelP (rec1up f f0 n) (rec1up fi fi0 n). Proof. move=> Hf Hf0 k. case: (ltnP n k) => Hnk; first by rewrite !nth_default ?size_rec1up. have H1 : k = (size (rec1up f f0 k)).-1 by rewrite size_rec1up. have H2 : k = (size (rec1up fi fi0 k)).-1 by rewrite size_rec1up. rewrite (@nth_rec1up_indep _ _ _ dv dv n k k) // (@nth_rec1up_indep _ _ _ dt dt n k k) //. rewrite !(nth_rec1up_last, last_rec1up). rewrite !head_loop1 //. elim: k Hnk {H1 H2} => [|k IHk] Hnk //=. apply: Hf; apply: IHk; exact: ltnW. Qed. Lemma rec2up_correct fi f fi0 f0 fi1 f1 n : (forall ai bi a b m, Rel a ai -> Rel b bi -> Rel (f a b m) (fi ai bi m)) -> Rel f0 fi0 -> Rel f1 fi1 -> RelP (rec2up f f0 f1 n) (rec2up fi fi0 fi1 n). Proof. move=> Hf Hf0 Hf1 k. case: (ltnP n k) => Hn; first by rewrite !nth_default ?size_rec2up. have H1 : k = (size (rec2up f f0 f1 k)).-1 by rewrite size_rec2up. have H2 : k = (size (rec2up fi fi0 fi1 k)).-1 by rewrite size_rec2up. rewrite (@nth_rec2up_indep _ _ _ _ dv dv n k k) // (@nth_rec2up_indep _ _ _ _ dt dt n k k) //. case: k Hn {H1 H2} => [//|k] Hn. rewrite !(nth_rec2up_last, last_rec2up). elim: k {-2}k (leqnn k) Hn => [|k IHk] k' Hk' Hn. - by rewrite leqn0 in Hk'; move/eqP: Hk'->. - rewrite leq_eqVlt in Hk'; case/orP: Hk'=> Hk'; last exact: IHk =>//. move/eqP: (Hk')->; rewrite !head_loop2S //; apply: Hf. + case: k IHk Hn Hk' => [|k] IHk Hn Hk' //. rewrite /hb !behead_loop2. apply: IHk =>//. move/eqP in Hk'; rewrite Hk' in Hn; apply: ltnW; exact: ltnW. + apply: IHk =>//. move/eqP in Hk'; rewrite Hk' in Hn; exact: ltnW. Qed. End rec_proofs. interval-4.11.1/src/Poly/Bound.v000066400000000000000000000064231470547631300164110ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals Psatz. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop. Require Import Interval. Require Import MathComp. Require Import Datatypes. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (** The interface *) Module Type PolyBound (I : IntervalOps) (Pol : PolyIntOps I). Import Pol Pol.Notations. Local Open Scope ipoly_scope. Module J := IntervalExt I. Parameter ComputeBound : Pol.U -> Pol.T -> I.type -> I.type. Parameter ComputeBound_correct : forall u pi p, pi >:: p -> J.extension (PolR.horner tt p) (ComputeBound u pi). Parameter ComputeBound_propagate : forall u pi, J.propagate (ComputeBound u pi). End PolyBound. Module PolyBoundThm (I : IntervalOps) (Pol : PolyIntOps I) (Bnd : PolyBound I Pol). Import Pol.Notations Bnd. Local Open Scope ipoly_scope. Theorem ComputeBound_nth0 prec pi p X : pi >:: p -> X >: 0 -> forall r : R, (Pol.nth pi 0) >: r -> ComputeBound prec pi X >: r. Proof. move=> Hpi HX0 r Hr. case E: (Pol.size pi) =>[|n]. have->: r = PolR.horner tt p 0%R. rewrite Pol.nth_default ?E // I.zero_correct /= in Hr. have [A B] := Hr. have H := Rle_antisym _ _ B A. rewrite PolR.hornerE big1 //. by move=> i _; rewrite (Pol.nth_default_alt Hpi) ?E // Rmult_0_l. exact: ComputeBound_correct. have->: r = PolR.horner tt (PolR.set_nth p 0 r) 0%R. rewrite PolR.hornerE PolR.size_set_nth max1n big_nat_recl //. rewrite PolR.nth_set_nth eqxx pow_O Rmult_1_r big1 ?Rplus_0_r //. by move=> i _; rewrite pow_ne_zero ?Rmult_0_r. apply: ComputeBound_correct =>//. have->: pi = Pol.set_nth pi 0 (Pol.nth pi 0). by rewrite Pol.set_nth_nth // E. exact: Pol.set_nth_correct. Qed. End PolyBoundThm. (** Naive implementation: Horner evaluation *) Module PolyBoundHorner (I : IntervalOps) (Pol : PolyIntOps I) <: PolyBound I Pol. Import Pol.Notations. Local Open Scope ipoly_scope. Module J := IntervalExt I. Definition ComputeBound : Pol.U -> Pol.T -> I.type -> I.type := Pol.horner. Theorem ComputeBound_correct : forall prec pi p, pi >:: p -> J.extension (PolR.horner tt p) (ComputeBound prec pi). Proof. move=> Hfifx X x Hx; rewrite /ComputeBound. by move=> *; apply Pol.horner_correct. Qed. Lemma ComputeBound_propagate : forall prec pi, J.propagate (ComputeBound prec pi). Proof. by red=> *; rewrite /ComputeBound Pol.horner_propagate. Qed. End PolyBoundHorner. interval-4.11.1/src/Poly/Bound_quad.v000066400000000000000000000130541470547631300174210ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals. From Flocq Require Import Raux. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop. Require Import Xreal. Require Import Interval. Require Import MathComp. Require Import Datatypes. Require Import Bound. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module PolyBoundHornerQuad (I : IntervalOps) (Pol : PolyIntOps I) <: PolyBound I Pol. Module Import Bnd := PolyBoundHorner I Pol. Module J := IntervalExt I. Definition ComputeBound (prec : Pol.U) (pol : Pol.T) (x : I.type) : I.type := if 3 <= Pol.size pol then let a1 := Pol.nth pol 1 in let a2 := Pol.nth pol 2 in let a2t2 := I.add prec a2 a2 in let a2t4 := I.add prec a2t2 a2t2 in let b1 := I.div prec a1 a2t2 in let b2 := I.div prec (I.sqr prec a1) a2t4 in if (* I.bounded b1 && *) I.bounded b2 then I.add prec (I.add prec (I.sub prec (Pol.nth pol 0) b2) (I.mul prec a2 (I.sqr prec (I.add prec x b1)))) (I.mul prec (I.power_int prec x 3) (Pol.horner prec (Pol.tail 3 pol) x)) else Pol.horner prec pol x else Pol.horner prec pol x. Import Pol.Notations. Local Open Scope ipoly_scope. Theorem ComputeBound_correct prec pi p : pi >:: p -> J.extension (PolR.horner tt p) (ComputeBound prec pi). Proof. move=> Hnth X x Hx; rewrite /ComputeBound. case E: (2 < Pol.size pi); last by apply: Bnd.ComputeBound_correct. case Eb: I.bounded; last by apply: Bnd.ComputeBound_correct. (* case Eb': I.bounded; last by apply: Bnd.ComputeBound_correct. *) simpl. set A0 := Pol.nth pi 0. set A1 := Pol.nth pi 1. set A2 := Pol.nth pi 2. set Q3 := Pol.tail 3 pi. pose a0 := PolR.nth p 0. pose a1 := PolR.nth p 1. pose a2 := PolR.nth p 2. pose q3 := PolR.tail 3 p. have Hi3: Pol.size pi = 3 + (Pol.size pi - 3) by rewrite subnKC //. (* have Hx3: PolR.size p = 3 + (PolR.size p - 3) by rewrite -Hsiz -Hi3. *) suff->: PolR.horner tt p x = (Rplus (Rplus (Rminus a0 (Rdiv (Rsqr a1) (Rplus (Rplus a2 a2) (Rplus a2 a2)))) (Rmult a2 (Rsqr (Rplus x (Rdiv a1 (Rplus a2 a2)))))) (Rmult (powerRZ x 3) (PolR.horner tt q3 x))). have Hnth3 : Q3 >:: q3 by apply(*:*) Pol.tail_correct. apply: J.add_correct; [apply: J.add_correct; [apply: J.sub_correct; [apply: Hnth |apply: J.div_correct; [apply: J.sqr_correct; apply: Hnth |apply: J.add_correct; apply: J.add_correct; apply: Hnth]] |apply: J.mul_correct; [apply: Hnth |apply: J.sqr_correct; apply: J.add_correct; [done |apply: J.div_correct; [apply: Hnth|apply: J.add_correct; apply: Hnth ]]]] |apply: J.mul_correct; [exact: J.power_int_correct|exact: Pol.horner_correct]]. rewrite 2!PolR.hornerE. rewrite (@big_nat_leq_idx _ _ _ (3 + (PolR.size p - 3))). rewrite big_mkord. rewrite 3?big_ord_recl -/a0 -/a1 -/a2 ![[the Monoid.law _ of Rplus] _]/= /q3 PolR.size_tail. (* simpl Z.of_nat. *) set x0 := powerRZ x 0. set x1 := powerRZ x 1. set x2 := powerRZ x 2. set x3 := powerRZ x 3. set s1 := bigop _ _ _. set s2 := bigop _ _ _. have H4 : (a2 + a2 + (a2 + a2) <> 0)%R. intro K. move: Eb. have Hzero : contains (I.convert (I.add prec (I.add prec (Pol.nth pi 2) (Pol.nth pi 2)) (I.add prec (Pol.nth pi 2) (Pol.nth pi 2)))) (Xreal 0). rewrite -K. by apply: J.add_correct; apply: J.add_correct; apply: Hnth. case/(I.bounded_correct _) => _. case/(I.upper_bounded_correct _) => _. rewrite /I.bounded_prop. set d := I.div prec _ _. suff->: I.convert d = Inan. { by rewrite /not_empty; move/(_ (@ex_intro _ (fun _ => True) 0%R I)). } apply -> contains_Xnan. rewrite -(Xdiv_0_r (Xsqr (Xreal a1))). apply: I.div_correct =>//. apply: I.sqr_correct. by apply: Hnth; rewrite Hi3. have H2 : (a2 + a2 <> 0)%R by intro K; rewrite K Rplus_0_r in H4. suff->: s1 = Rmult x3 s2. have->: Rmult a0 x0 = a0 by simpl; rewrite /x0 powerRZ_O Rmult_1_r. rewrite -!Rplus_assoc /Rminus; congr Rplus. rewrite /x1 /x2 /Rsqr. rewrite /=; field. split =>//. by rewrite -Rplus_assoc in H4. rewrite /s1 /s2 /x3; clear. rewrite Rmult_comm. rewrite big_mkord big_distrl. apply: eq_bigr=> i _. rewrite /PolR.tail /PolR.nth nth_drop. (* some bookkeeping about powers *) rewrite -!(pow_powerRZ _ 3). rewrite /= !Rmult_assoc; f_equal; ring. by rewrite addnC leq_subnK. move=> i /andP [Hi _]. by rewrite PolR.nth_default ?Rmult_0_l. Qed. Lemma ComputeBound_propagate : forall prec pi, J.propagate (ComputeBound prec pi). Proof. red=> *; rewrite /ComputeBound /=. by repeat match goal with [|- context [if ?b then _ else _]] => destruct b end; rewrite !(I.add_propagate_r,I.mul_propagate_l,J.power_int_propagate, Pol.horner_propagate). Qed. End PolyBoundHornerQuad. interval-4.11.1/src/Poly/Datatypes.v000066400000000000000000001276431470547631300173100ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals. From Coquelicot Require Import Coquelicot. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop. From Flocq Require Import Core. Require Import Stdlib. Require Import MathComp. Require Import Interval. Require Import Xreal. Require Import Basic_rec. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope nat_scope. Reserved Notation "--> e" (at level 10, e at level 8, no associativity, format "--> e"). Reserved Notation "i >: x" (at level 70, no associativity, format "i >: x"). Reserved Notation "i >:: x" (at level 70, no associativity, format "i >:: x"). Module Type BaseOps. Parameter Inline U : Type. Parameter Inline T : Type. Parameter Inline zero : T. Parameter Inline one : T. Parameter Inline opp : T -> T. Parameter Inline add : U -> T -> T -> T. Parameter Inline sub : U -> T -> T -> T. Parameter Inline mul : U -> T -> T -> T. End BaseOps. (* REM: We may use the new notation features of Coq 8.4 w.r.t. modules. *) Module Type PowDivOps. Include BaseOps. (** [mask c x] is the constant fonction [c], except if [T = I.type] and [x] contains [Xnan], implying that [mask c x] contains [Xnan]. *) Parameter Inline mask : T -> T -> T. Parameter Inline from_nat : U -> nat -> T. Parameter Inline fromZ : U -> Z -> T. Parameter Inline power_int : U -> T -> Z -> T. Parameter Inline sqr : U -> T -> T. Parameter Inline inv : U -> T -> T. Parameter Inline div : U -> T -> T -> T. End PowDivOps. Module Type FullOps. Include PowDivOps. Parameter Inline sqrt : U -> T -> T. Parameter Inline invsqrt : U -> T -> T. Parameter Inline exp : U -> T -> T. Parameter Inline sin : U -> T -> T. Parameter Inline cos : U -> T -> T. Parameter Inline ln : U -> T -> T. Parameter Inline atan : U -> T -> T. Parameter Inline tan : U -> T -> T. End FullOps. Module FullInt (I : IntervalOps) <: FullOps. Definition U := I.precision. Definition T := I.type. Definition zero := I.zero. Definition one := I.fromZ_small 1. Definition opp := I.neg. Definition add := I.add. Definition sub := I.sub. Definition mul := I.mul. Definition div := I.div. Definition power_int := I.power_int. Definition exp := I.exp. Definition ln := I.ln. Definition from_nat := fun u n => I.fromZ u (Z_of_nat n). Definition fromZ := I.fromZ. Definition inv := I.inv. Definition cos := I.cos. Definition sin := I.sin. Definition sqr := I.sqr. Definition sqrt := I.sqrt. Definition invsqrt := fun prec x => I.inv prec (I.sqrt prec x). Definition mask : T -> T -> T := I.mask. Definition tan := I.tan. Definition atan := I.atan. End FullInt. Module Type PolyOps (C : PowDivOps) <: BaseOps. (* Include BaseOps with Definition U := C.U. *) Definition U := C.U. Parameter T : Type. Parameter zero : T. Parameter one : T. Parameter opp : T -> T. Parameter add : U -> T -> T -> T. Parameter sub : U -> T -> T -> T. Parameter mul : U -> T -> T -> T. Parameter toSeq : T -> seq C.T. Parameter nth : T -> nat -> C.T. Parameter size : T -> nat. Parameter rec1 : (C.T -> nat -> C.T) -> C.T -> nat -> T. Parameter rec2 : (C.T -> C.T -> nat -> C.T) -> C.T -> C.T -> nat -> T. Parameter grec1 : forall A : Type, (A -> nat -> A) -> (A -> nat -> C.T) -> A -> seq C.T -> nat -> T. Parameter map : forall f : C.T -> C.T, T -> T. Parameter fold : forall V : Type, (C.T -> V -> V) -> V -> T -> V. Parameter set_nth : T -> nat -> C.T -> T. Parameter mul_trunc : U -> nat -> T -> T -> T. Parameter mul_tail : U -> nat -> T -> T -> T. (** [tlift j pol] represents [pol * X^j] if [pol] is in the monomial basis *) Parameter lift : nat -> T -> T. Parameter tail : nat -> T -> T. Parameter polyC : C.T -> T. Parameter polyX : T. Parameter polyNil : T. Parameter polyCons : C.T -> T -> T. Parameter horner : U -> T -> C.T -> C.T. Parameter deriv : U -> T -> T. Parameter mul_mixed : U -> C.T -> T -> T. Parameter div_mixed_r : U -> T -> C.T -> T. Parameter dotmuldiv : U -> seq Z -> seq Z -> T -> T. Parameter primitive : U -> C.T -> T -> T. (* specifications of toSeq *) Parameter horner_seq : forall u p x, horner u p x = C.mask (foldr (fun a b => C.add u (C.mul u b x) a) C.zero (toSeq p)) x. Parameter nth_toSeq : forall p n, nth p n = seq.nth (C.zero) (toSeq p) n. Parameter polyCE : forall c, polyC c = polyCons c polyNil. Parameter polyXE : polyX = lift 1 one. Parameter oneE : one = polyC C.one. Parameter poly_ind : forall (f : T -> Prop), f polyNil -> (forall a p, f p -> f (polyCons a p)) -> forall p, f p. Parameter size_primitive : forall u c p, size (primitive u c p) = (size p).+1. Parameter size_lift : forall n p, size (lift n p) = n + size p. Parameter size_mul_mixed : forall u a p, size (mul_mixed u a p) = size p. Parameter size_div_mixed_r : forall u p b, size (div_mixed_r u p b) = size p. Parameter size_rec1 : forall F x n, size (rec1 F x n) = n.+1. Parameter size_rec2 : forall F x y n, size (rec2 F x y n) = n.+1. Parameter size_mul_trunc : forall u n p q, size (mul_trunc u n p q) = n.+1. Parameter size_mul_tail : forall u n p q, size (mul_tail u n p q) = ((size p) + (size q)).-1 - n.+1. Parameter size_add : forall u p1 p2, size (add u p1 p2) = maxn (size p1) (size p2). Parameter size_opp : forall p1, size (opp p1) = size p1. Parameter size_map : forall f p, size (map f p) = size p. Parameter size_sub : forall u p1 p2, size (sub u p1 p2) = maxn (size p1) (size p2). Parameter size_polyNil : size polyNil = 0. Parameter size_polyCons : forall a p, size (polyCons a p) = (size p).+1. Parameter size_grec1 : forall (A : Type) (F : A -> nat -> A) (G : A -> nat -> C.T) (q : A) (s : seq C.T) (n : nat), size (grec1 F G q s n) = n.+1. Parameter size_tail : forall p k, size (tail k p) = size p - k. Parameter size_dotmuldiv : forall n u a b p, size p = n -> seq.size a = n -> seq.size b = n -> size (dotmuldiv u a b p) = n. Parameter size_set_nth : forall p n val, size (set_nth p n val) = maxn n.+1 (size p). (* i.e., tsize (tset_nth p n val) = maxn n.+1 (tsize p) = tsize p. *) Parameter nth_polyCons : forall a p k, nth (polyCons a p) k = if k is k'.+1 then nth p k' else a. Parameter nth_polyNil : forall n, nth polyNil n = C.zero. Parameter fold_polyNil : forall U f iv, @fold U f iv polyNil = iv. Parameter fold_polyCons : forall U f iv c p, @fold U f iv (polyCons c p) = f c (@fold U f iv p). Parameter nth_set_nth : forall p n val k, nth (set_nth p n val) k = if k == n then val else nth p k. Parameter nth_default : forall p n, size p <= n -> nth p n = C.zero. (* FIXME: Is the following mandatory? *) Parameter set_nth_nth : forall p n, n < size p -> set_nth p n (nth p n) = p. End PolyOps. Module FullR <: FullOps. Definition U := unit. Local Notation "--> e" := (fun _ : U => e). Definition T := R. Definition zero := 0%R. Definition one := 1%R. Definition opp := Ropp. Definition add := --> Rplus. Definition sub := --> Rminus. Definition mul := --> Rmult. Definition div := --> Rdiv. Definition power_int := --> powerRZ. Definition exp := --> exp. Definition ln := --> ln. Definition from_nat (_:U) := INR. Definition fromZ (_:U) := IZR. Definition inv := --> Rinv. Definition cos := --> cos. Definition sin := --> sin. Definition sqr := --> fun x => Rmult x x. Definition sqrt := --> sqrt. Definition invsqrt := --> fun x => (Rinv (sqrt tt x)). Definition mask : T -> T -> T := fun c _ => c. Definition tan := --> tan. Definition atan := --> atan. End FullR. Module SeqPoly (C : PowDivOps) <: PolyOps C. Definition U := C.U. Definition T := seq C.T. (* TODO Definition recN := @recNup C.T. *) (* TODO Definition lastN : C.T -> forall N : nat, T -> C.T ^ N := @lastN C.T. *) Definition zero : T := [::]. Definition one : T := [:: C.one]. Definition opp := map C.opp. Section PrecIsPropagated. Variable u : U. Definition add := map2 (C.add u) (fun x => x). Definition sub := map2 (C.sub u) C.opp. Definition nth := nth C.zero. (** Advantage of using foldl w.r.t foldr : foldl is tail-recursive *) Definition mul_coeff (p q : T) (k : nat) : C.T := foldl (fun x i => C.add u (C.mul u (nth p i) (nth q (k - i))) x) (C.zero) (rev (iota 0 k.+1)). Lemma mul_coeffE p q k : mul_coeff p q k = \big[C.add u/C.zero]_(0 <= i < k.+1) C.mul u (nth p i) (nth q (k - i)). Proof. rewrite BigOp.bigopE /reducebig /mul_coeff foldl_rev. by congr foldr; rewrite /index_iota subn0. Qed. Definition mul_trunc n p q := mkseq (mul_coeff p q) n.+1. Definition mul_tail n p q := mkseq (fun i => mul_coeff p q (n.+1+i)) ((size p + size q).-1 - n.+1). Definition mul p q := mkseq (mul_coeff p q) (size p + size q).-1. Definition rec1 := @rec1up C.T. Definition rec2 := @rec2up C.T. Definition size := @size C.T. Definition fold := @foldr C.T. Definition horner p x := C.mask (@fold C.T (fun a b => C.add u (C.mul u b x) a) C.zero p) x. Definition set_nth := @set_nth C.T C.zero. Definition map := @map C.T C.T. Definition polyCons := @Cons C.T. Definition polyNil := @Nil C.T. Definition polyC (c : C.T) : T := polyCons c polyNil. Definition polyX := [:: C.zero; C.one]. (* TODO: Revise *) Lemma poly_ind : forall (f : T -> Prop), f polyNil -> (forall a p, f p -> f (polyCons a p)) -> forall p, f p. Proof. by move=> f h1 hrec; elim =>//= a e; apply:hrec. Qed. Definition deriv_loop := foldri (fun a i s => C.mul u a (C.from_nat u i) :: s) [::]. Definition deriv (p : T) := deriv_loop (behead p) 1. Definition grec1 (A : Type) := @grec1up A C.T. Lemma size_grec1 A F G (q : A) s n : size (grec1 F G q s n) = n.+1. Proof. by apply size_grec1up. Qed. Lemma size_rec1 F x n: size (rec1 F x n) = n.+1. Proof. by apply size_rec1up. Qed. Lemma size_rec2 F x y n: size (rec2 F x y n) = n.+1. Proof. by apply size_rec2up. Qed. Lemma size_mul_trunc n p q: size (mul_trunc n p q) = n.+1. Proof. by rewrite /size size_mkseq. Qed. Lemma size_mul_tail n p q: size (mul_tail n p q) = ((size p) + (size q)).-1 - n.+1. Proof. by rewrite /size size_mkseq. Qed. Lemma size_add p1 p2 : size (add p1 p2) = maxn (size p1) (size p2). Proof. by rewrite /size /add size_map2. Qed. Lemma size_opp p1 : size (opp p1) = size p1. Proof. by rewrite /size /opp size_map. Qed. Lemma size_sub p1 p2 : size (sub p1 p2) = maxn (size p1) (size p2). Proof. by rewrite /sub /size size_map2. Qed. Lemma size_deriv p : size (deriv p) = (size p).-1. Proof. rewrite /deriv /deriv_loop. case: p => [|a p] //=. elim: p 1 => [|b p IHp] n //=. by rewrite IHp. Qed. End PrecIsPropagated. Definition tail := @drop C.T. Definition lift (n : nat) p := ncons n C.zero p. Lemma size_lift n p : size (lift n p) = n + size p. Proof (size_ncons n C.zero p). (** FIXME: replace [foldr] by [map] *) Definition mul_mixed (u : U) (a : C.T) (p : T) := @foldr C.T T (fun x acc => (C.mul u a x) :: acc) [::] p. Definition div_mixed_r (u : U) (p : T) (b : C.T) := @foldr C.T T (fun x acc => (C.div u x b) :: acc) [::] p. Lemma size_mul_mixed u a p : size (mul_mixed u a p) = size p. Proof. by elim: p => [//|x p IHp]; rewrite /= IHp. Qed. Lemma size_div_mixed_r u p b : size (div_mixed_r u p b) = size p. Proof. by elim: p => [//|x p IHp]; rewrite /= IHp. Qed. Lemma size_mul u p q : size (mul u p q) = (size p + size q).-1. Proof. by rewrite /size /mul size_mkseq. Qed. Fixpoint dotmuldiv (u : U) (a b : seq Z) (p : T) : T := match a, b, p with | a0 :: a1, b0 :: b1, p0 :: p1 => C.mul u (C.div u (C.fromZ u a0) (C.fromZ u b0)) p0 :: dotmuldiv u a1 b1 p1 | _, _, _ => [::] (* e.g. *) end. Lemma fold_polyNil U f iv : @fold U f iv polyNil = iv. Proof. done. Qed. Lemma fold_polyCons U f iv c p : @fold U f iv (polyCons c p) = f c (@fold U f iv p). Proof. done. Qed. Lemma size_set_nth p n val : size (set_nth p n val) = maxn n.+1 (size p). Proof. by rewrite /size seq.size_set_nth. Qed. Lemma nth_set_nth p n val k : nth (set_nth p n val) k = if k == n then val else nth p k. Proof. by rewrite /nth nth_set_nth. Qed. Lemma nth_default p n : size p <= n -> nth p n = C.zero. Proof. by move=> *; rewrite /nth nth_default. Qed. Lemma set_nth_nth p n : n < size p -> set_nth p n (nth p n) = p. Proof. move=> H. apply: (eq_from_nth (x0 := C.zero)). by rewrite seq.size_set_nth; apply/maxn_idPr. move=> i Hi. rewrite seq.size_set_nth in Hi. move/maxn_idPr: (H) (Hi) =>-> Hn. rewrite seq.nth_set_nth /=. by case E : (i == n); first by rewrite (eqP E). Qed. Lemma size_polyNil : size polyNil = 0. Proof. done. Qed. Lemma size_polyCons a p : size (polyCons a p) = (size p).+1. Proof. by []. Qed. Lemma nth_polyNil n : nth polyNil n = C.zero. Proof. by rewrite nth_default. Qed. Lemma nth_polyCons a p k : (* k <= size p -> *) nth (polyCons a p) k = if k is k'.+1 then nth p k' else a. Proof. by case: k. Qed. Lemma size_dotmuldiv (n : nat) (u : U) a b p : size p = n -> seq.size a = n -> seq.size b = n -> size (dotmuldiv u a b p) = n. Proof. move: a b p n; elim=> [|a0 a1 IH] [|b0 b1] [|p0 p1] =>//. move=> /= n Hp Ha Hb /=. rewrite (IH _ _ n.-1) //. by rewrite -Hp. by rewrite -Hp. by rewrite -Ha. by rewrite -Hb. Qed. Lemma size_tail p k : size (tail k p) = size p - k. Proof. by rewrite /size /tail size_drop. Qed. Definition toSeq (p : T) := p. Lemma horner_seq u p x : horner u p x = C.mask (foldr (fun a b => C.add u (C.mul u b x) a) C.zero (toSeq p)) x. Proof. done. Qed. Lemma nth_toSeq p n : nth p n = seq.nth (C.zero) (toSeq p) n. Proof. by []. Qed. Section precSection. Variable u : U. Definition int_coeff (p : T) (c : C.T) (n : nat) := match n with | 0 => c | S m => C.div u (nth p m) (C.from_nat u n) end. Definition int_coeff_shift (p : T) (k : nat) := C.div u (seq.nth C.zero p k) (C.from_nat u k.+1). Definition primitive (c : C.T) (p : T) := (c::(mkseq (int_coeff_shift p) (size p))) : T. Lemma size_primitive (c : C.T) (p : T): size (primitive c p) = (size p).+1. Proof. by rewrite /size /= size_mkseq. Qed. End precSection. Lemma size_map f p : size (map f p) = size p. Proof (size_map f p). Lemma polyCE c : polyC c = polyCons c polyNil. Proof. done. Qed. Lemma polyXE : polyX = lift 1 one. Proof. done. Qed. Lemma oneE : one = polyC C.one. Proof. done. Qed. Lemma nth_mul u p q k : nth (mul u p q) k = if (size p + size q).-1 <= k then C.zero else mul_coeff u p q k. Proof. by rewrite /nth /mul_trunc [in LHS]nth_mkseq_dflt. Qed. Lemma nth_mul_trunc u n p q k : nth (mul_trunc u n p q) k = if n < k then C.zero else mul_coeff u p q k. Proof. by rewrite /nth /mul_trunc [in LHS]nth_mkseq_dflt. Qed. Lemma nth_mul_tail u n p q k : nth (mul_tail u n p q) k = if (size p + size q).-1 - n.+1 <= k then C.zero else mul_coeff u p q (n.+1 + k). Proof. by rewrite /nth /mul_tail [in LHS]nth_mkseq_dflt. Qed. Lemma nth_dotmuldiv u a b p k : nth (dotmuldiv u a b p) k = if [|| size p <= k, seq.size a <= k | seq.size b <= k] then C.zero else C.mul u (C.div u (C.fromZ u (seq.nth 0%Z a k)) (C.fromZ u (seq.nth 0%Z b k))) (nth p k). Proof. elim: p a b k => [|c p IHp] a b k; case: a; case: b =>//=; rewrite /nth ?nth_nil //. by rewrite orbT. by rewrite orbT. by move=> *; rewrite leq0n !orbT. by move=> a0 a b0 b; case: k => [|k] //=; rewrite [LHS]IHp ltnS; case: ifP. Qed. End SeqPoly. Module PolR <: PolyOps FullR. Include SeqPoly FullR. Module Import Notations. (* Delimit Scope rpoly_scope with P. *) Notation "p .[ x ]" := (PolR.horner tt p x) : R_scope. Notation "p ^` ()" := (PolR.deriv tt p) : R_scope. End Notations. Lemma toSeq_horner0 (u : U) (p : T) : horner u p 0%R = head 0%R (toSeq p). Proof. elim: p=> [| a q HI] ; first by []. by rewrite /= HI; case: u HI; rewrite Rmult_0_r Rplus_0_l. Qed. Lemma mul_coeff_eq0 p q k : (forall i, i <= k -> nth p i = 0%R \/ nth q (k - i) = 0%R) -> (\big[Rplus/R0]_(0 <= i < k.+1) (nth p i * nth q (k - i)) = 0)%R. Proof. move=> H. rewrite big_mkord big1 // => [[i Hi]] _ /=. rewrite ltnS in Hi. by case: (H i Hi) =>->; rewrite ?(Rmult_0_l, Rmult_0_r). Qed. (** Restate [nth_mul] with no if-then-else *) Lemma nth_mul' u p q k : nth (mul u p q) k = \big[Rplus/0%R]_(0 <= i < k.+1) Rmult (nth p i) (nth q (k - i)). Proof. rewrite nth_mul mul_coeffE; case: leqP => [H|//]. rewrite mul_coeff_eq0 //. move/addn_pred_leqI in H. by move=> i Hi; case: (H i Hi); move/nth_default=>->; intuition. Qed. Lemma hornerE p x : horner tt p x = \big[Rplus/0%R]_(0 <= i < size p) Rmult (nth p i) (x ^ i). Proof. elim: p; first by rewrite big_mkord big_ord0 /=. move=> t p /= ->. rewrite big_nat_recl // pow_O /=. rewrite Rmult_1_r Rplus_comm. case: (size p)=> [|n]. by rewrite !big_mkord !big_ord0 /= Rmult_0_l. rewrite Rmult_comm big_distrr /=; congr Rplus. apply: eq_bigr => i _. by rewrite ![Rmult x _]Rmult_comm Rmult_assoc. Qed. Lemma hornerE_wide n p x : size p <= n -> horner tt p x = \big[Rplus/R0]_(0 <= i < n) Rmult (nth p i) (x ^ i). Proof. move=> Hn; rewrite hornerE (big_nat_leq_idx _ Hn) //. by move=> i /andP [Hi _]; rewrite nth_default // Rmult_0_l. Qed. Lemma coef_deriv p i : nth (deriv tt p) i = (nth p i.+1 * INR i.+1)%R. Proof. rewrite /deriv /deriv_loop -{2}[in RHS]addn1. elim: p i 1 => [|a p IHp] i n; first by rewrite /nth !nth_nil Rmult_0_l. case: p IHp => [|b p] IHp; first by rewrite /= /nth !nth_nil Rmult_0_l. case: i => [|i] //=. rewrite IHp; congr Rmult. by rewrite addnS. Qed. Lemma horner_derivE_wide n p x : (size p).-1 <= n -> horner tt (deriv tt p) x = \big[Rplus/R0]_(0 <= i < n) ((nth p i.+1) * (INR i.+1) * (x ^ i))%R. Proof. move=> H. rewrite (@hornerE_wide n); last by rewrite size_deriv. apply: eq_bigr => i _. congr Rmult. exact: coef_deriv. Qed. Lemma horner_derivE p x : horner tt (deriv tt p) x = \big[Rplus/R0]_(0 <= i < (size p).-1) ((nth p i.+1) * (INR i.+1) * (x ^ i))%R. Proof. by rewrite (@horner_derivE_wide (size p).-1). Qed. Lemma is_derive_horner p x : is_derive (horner tt p) x (horner tt (deriv tt p) x). Proof. elim: p => [|a p IHp]. - rewrite /horner /=; exact: is_derive_const. - apply: (@is_derive_ext _ _ (fun x => horner tt p x * x + a)%R); first done. rewrite -[horner _ _ _]Rplus_0_r. apply: is_derive_plus; last by auto_derive. suff->: horner tt (deriv tt (a :: p)) x = ((horner tt (deriv tt p) x) * x + (horner tt p x) * 1)%R. apply: is_derive_mult =>//. apply: is_derive_id. exact: Rmult_comm. rewrite (@horner_derivE_wide (size p)) // (@horner_derivE_wide (size p).-1) // (@hornerE_wide (size p)) //. (* Some bigop bookkeeping *) rewrite Rmult_1_r. rewrite big_distrl. case E: (size p) => [|sp]; first by rewrite !(big_mkord, big_ord0) Rplus_0_l. rewrite [LHS]big_ltn // [in LHS]big_add1. rewrite [in X in _ = (_ + X)%R](big_ltn, big_add1) //. rewrite [in RHS]Rplus_comm [in RHS]Rplus_assoc; congr Rplus. by rewrite !Rmult_1_r. rewrite big_add1. rewrite -big_split. apply: eq_bigr => i _. have->: INR i.+2 = (INR i.+1 + 1)%R by []. have->: nth (a :: p) i.+2 = nth p i.+1 by []. rewrite -tech_pow_Rmult; simpl; ring. Qed. Corollary Derive_horner p x : Derive (horner tt p) x = horner tt (deriv tt p) x. Proof. apply: is_derive_unique; exact: is_derive_horner. Qed. Corollary ex_derive_horner p x : ex_derive (horner tt p) x. Proof. exists (horner tt (deriv tt p) x); exact: is_derive_horner. Qed. Lemma nth_add p1 p2 k : nth (add tt p1 p2) k = Rplus (nth p1 k) (nth p2 k). Proof. rewrite /nth /add nth_map2_dflt -!/(nth _ _). by case: (leqP (size p1) k) => H1; case: (leqP (size p2) k) => H2; rewrite ?(nth_default H1) ?(nth_default H2); auto with real. Qed. Lemma nth_opp p1 k : nth (opp p1) k = Ropp (nth p1 k). Proof. rewrite /nth /add nth_map_dflt -!/(nth _ _). by case: (leqP (size p1) k) => H1; rewrite ?(nth_default H1); auto with real. Qed. Lemma nth_sub p1 p2 k : nth (sub tt p1 p2) k = Rminus (nth p1 k) (nth p2 k). Proof. rewrite /nth /add nth_map2_dflt -!/(nth _ _). by case: (leqP (size p1) k) => H1; case: (leqP (size p2) k) => H2; rewrite ?(nth_default H1) ?(nth_default H2); auto with real. Qed. Lemma nth_mul_mixed a p1 k : nth (mul_mixed tt a p1) k = Rmult a (nth p1 k). Proof. (* TODO: revise proof, using [map] rather than [foldr] ? *) elim: p1 k => [|x p IHp] k; first by rewrite nth_default // Rmult_0_r. case: k IHp => [|k] IHp //; by rewrite /= IHp. Qed. Lemma nth_div_mixed_r p1 b k : nth (div_mixed_r tt p1 b) k = Rdiv (nth p1 k) b. Proof. elim: p1 k => [|x p IHp] k; first by rewrite nth_default // /Rdiv Rmult_0_l. case: k IHp => [|k] IHp //; by rewrite /= IHp. Qed. Lemma nth_lift n p k : nth (lift n p) k = if k < n then 0%R else nth p (k - n). Proof (nth_ncons 0%R n 0%R p k). Lemma horner_polyC c x : horner tt (polyC c) x = c. Proof. rewrite !hornerE polyCE size_polyCons size_polyNil big_nat1 nth_polyCons. by rewrite pow_O Rmult_1_r. Qed. Lemma horner_opp p x : horner tt (opp p) x = Ropp (horner tt p x). Proof. rewrite !hornerE size_opp. rewrite big_endo ?Ropp_0 //; last exact: Ropp_plus_distr. apply: eq_bigr => i _ /=. by rewrite nth_opp Ropp_mult_distr_l_reverse. Qed. Lemma horner_add p q x : horner tt (add tt p q) x = (horner tt p x + horner tt q x)%R. Proof. rewrite !(@hornerE_wide (maxn (size p) (size q))). rewrite -big_split; apply: eq_bigr => i _ /=. by rewrite nth_add Rmult_plus_distr_r. exact: leq_maxr. exact: leq_maxl. by rewrite size_add. Qed. Lemma horner_sub p q x : horner tt (sub tt p q) x = (horner tt p x - horner tt q x)%R. Proof. rewrite !(@hornerE_wide (maxn (size p) (size q))). rewrite /Rminus. rewrite (big_endo Ropp); first last. by rewrite Ropp_0. exact: Ropp_plus_distr. rewrite -big_split; apply: eq_bigr => i _ /=. by rewrite -/(Rminus _ _) nth_sub Rmult_minus_distr_r. exact: leq_maxr. exact: leq_maxl. by rewrite size_sub. Qed. Lemma horner0 p x : (forall n, nth p n = 0%R) -> p.[x] = 0%R. Proof. by move=> Hp; rewrite hornerE big1 // =>[i _]; rewrite Hp Rmult_0_l. Qed. Lemma mul_coeff0l p q : size p = 0 -> forall n, mul_coeff tt p q n = 0%R. Proof. move=> Hp n; rewrite mul_coeffE. rewrite big_mkord big1 // => [i Hi]. rewrite (@nth_default p); by [rewrite Rmult_0_l|rewrite Hp]. Qed. Lemma nth_mulCl c p q i : nth (mul tt (c :: p) q) i.+1 = (c * nth q i.+1 + nth (mul tt p q) i)%R. Proof. by rewrite !nth_mul' big_nat_recl. Qed. Lemma horner_mulCl c p q x : ((mul tt (c :: p) q).[x] = (mul tt p q).[x] * x + c * q.[x])%R. Proof. rewrite (@hornerE_wide (size p + size q).+1); last by rewrite size_mul leq_pred. have HF : forall i, predT i -> (nth (mul tt (c :: p) q) i.+1 * x ^ i.+1 = (c * nth q i.+1) * x ^ i.+1 + nth (mul tt p q) i * x ^ i.+1)%R. by move=> i; rewrite nth_mulCl Rmult_plus_distr_r. rewrite big_nat_recl // (eq_bigr _ HF). rewrite nth_mul' big_nat1 subn0 [nth _ 0]/= pow_O Rmult_1_r. rewrite (@hornerE_wide (size p + size q)); last by rewrite size_mul leq_pred. set q0 := nth q 0. rewrite (big_endo (fun y => y * x)%R); last 1 [by red=> *; rewrite Rmult_plus_distr_r|by rewrite Rmult_0_l]. rewrite (@hornerE_wide (size p + size q).+1); last by rewrite leqW // leq_addl. rewrite big_nat_recl // pow_O Rmult_1_r; fold q0. rewrite Rmult_plus_distr_l. rewrite (big_endo (fun y => c * y)%R); last 1 [by red=> *; rewrite Rmult_plus_distr_l|by rewrite Rmult_0_r]. rewrite [RHS]Rplus_comm !Rplus_assoc; congr Rplus. rewrite -big_split; apply: eq_bigr => i _. simpl; ring. Qed. Lemma horner_mul p q x : horner tt (mul tt p q) x = (horner tt p x * horner tt q x)%R. Proof. elim: p => [|c p IHp]. - rewrite horner0 /= ?Rmult_0_l //. move=> n; rewrite nth_mul; case: ifP =>// H. by rewrite mul_coeff0l. rewrite horner_mulCl IHp /= Rmult_plus_distr_r. by rewrite !Rmult_assoc (Rmult_comm _ x) -!Rmult_assoc. Qed. Lemma horner_lift n p x : horner tt (lift n p) x = (horner tt p x * x ^ n)%R. Proof. rewrite !hornerE (*(@hornerE_wide (size (lift n p))) *). rewrite (big_endo (fun y => y * x ^ n)%R); first last. by rewrite Rmult_0_l. by red=> *; rewrite Rmult_plus_distr_r. rewrite size_lift. rewrite (@big_cat_nat _ _ _ n) ?leq_addr //=. rewrite big1_seq; first last. move=> i /andP [_ Hi]; rewrite nth_lift ifT ?Rmult_0_l //. by move: Hi; rewrite mem_index_iota; case/andP. rewrite Rplus_0_l -{1}(add0n n) big_addn addKn. apply: eq_bigr => i _ /=. rewrite nth_lift ifF ?(ltnNge, leq_addl) //. rewrite addnK Rmult_assoc; congr Rmult. by rewrite pow_add. Qed. Lemma horner_mul_mixed a p x : horner tt (mul_mixed tt a p) x = (a * horner tt p x)%R. Proof. rewrite !hornerE size_mul_mixed. rewrite big_endo; first last. by rewrite Rmult_0_r. by move=> *; rewrite Rmult_plus_distr_l. apply: eq_bigr => i _. by rewrite nth_mul_mixed Rmult_assoc. Qed. Lemma horner_div_mixed_r p b x : horner tt (div_mixed_r tt p b) x = (horner tt p x / b)%R. Proof. rewrite !hornerE size_div_mixed_r /Rdiv Rmult_comm. rewrite big_endo; first last. by rewrite Rmult_0_r. by move=> *; rewrite Rmult_plus_distr_l. apply: eq_bigr => i _. by rewrite nth_div_mixed_r -Rmult_assoc; congr Rmult; rewrite Rmult_comm. Qed. Lemma nth_primitive (p : T) (c : R) (k : nat) : nth (primitive tt c p) k = if size p < k then 0%R else int_coeff tt p c k. Proof. case: ifP => Hk. by rewrite nth_default // size_primitive. case : k Hk => [ _ | m Hm] //=. have HSiota : m < seq.size (iota 0 (size p)). by rewrite size_iota; rewrite ltnNge in Hm; move/negbFE in Hm. rewrite /nth /toSeq /primitive /= . rewrite (nth_map 0) // nth_iota; first by rewrite add0n. by rewrite ltnNge in Hm; move/negbFE in Hm. Qed. End PolR. Module Type PolyIntOps (I : IntervalOps). Module Int := FullInt I. Module J := IntervalExt I. Include PolyOps Int. Definition contains_pointwise pi p : Prop := forall k, contains (I.convert (nth pi k)) (Xreal (PolR.nth p k)). (* Very similar definition, suitable for specifying grec1 *) Definition seq_contains_pointwise si s : Prop := forall k, contains (I.convert (seq.nth Int.zero si k)) (Xreal (PolR.nth s k)). Notation seq_eq_size si s := (seq.size si = seq.size s). Module Import Notations. (*Declare Scope ipoly_scope.*) Notation "i >: x" := (contains (I.convert i) (Xreal x)) : ipoly_scope. Notation "p >:: x" := (contains_pointwise p x) : ipoly_scope. Notation eq_size pi p := (size pi = PolR.size p). End Notations. Local Open Scope ipoly_scope. Parameter horner_correct : forall u pi ci p x, pi >:: p -> ci >: x -> horner u pi ci >: PolR.horner tt p x. Parameter polyC_correct : forall ci c, ci >: c -> polyC ci >:: PolR.polyC c. Parameter polyX_correct : polyX >:: PolR.polyX. Parameter zero_correct : zero >:: PolR.zero. Parameter one_correct : one >:: PolR.one. Parameter opp_correct : forall pi p, pi >:: p -> opp pi >:: PolR.opp p. Parameter map_correct : forall fi f pi p, (f 0%R = 0%R) -> (forall xi x, xi >: x -> fi xi >: f x) -> pi >:: p -> map fi pi >:: PolR.map f p. Parameter dotmuldiv_correct : forall u a b pi p, seq.size a = seq.size b -> pi >:: p -> dotmuldiv u a b pi >:: PolR.dotmuldiv tt a b p. Parameter add_correct : forall u pi qi p q, pi >:: p -> qi >:: q -> add u pi qi >:: PolR.add tt p q. Parameter sub_correct : forall u pi qi p q, pi >:: p -> qi >:: q -> sub u pi qi >:: PolR.sub tt p q. Parameter mul_correct : forall u pi qi p q, pi >:: p -> qi >:: q -> mul u pi qi >:: PolR.mul tt p q. Parameter mul_trunc_correct : forall u n pi qi p q, pi >:: p -> qi >:: q -> mul_trunc u n pi qi >:: PolR.mul_trunc tt n p q. Parameter mul_tail_correct : forall u n pi qi p q, pi >:: p -> qi >:: q -> mul_tail u n pi qi >:: PolR.mul_tail tt n p q. Parameter mul_mixed_correct : forall u ai pi a p, ai >: a -> pi >:: p -> mul_mixed u ai pi >:: PolR.mul_mixed tt a p. Parameter div_mixed_r_correct : forall u pi bi p b, pi >:: p -> bi >: b -> div_mixed_r u pi bi >:: PolR.div_mixed_r tt p b. Parameter horner_propagate : forall u pi, J.propagate (horner u pi). Parameter deriv_correct : forall u pi p, pi >:: p -> deriv u pi >:: (PolR.deriv tt p). Parameter primitive_correct : forall u ci c pi p, ci >: c -> pi >:: p -> primitive u ci pi >:: PolR.primitive tt c p. Parameter lift_correct : forall n pi p, pi >:: p -> lift n pi >:: PolR.lift n p. Parameter tail_correct : forall n pi p, pi >:: p -> tail n pi >:: PolR.tail n p. Parameter set_nth_correct : forall pi p n ai a, pi >:: p -> ai >: a -> set_nth pi n ai >:: PolR.set_nth p n a. Parameter polyNil_correct : polyNil >:: PolR.polyNil. (* strong enough ? *) Parameter polyCons_correct : forall pi xi p x, pi >:: p -> xi >: x -> polyCons xi pi >:: PolR.polyCons x p. Parameter rec1_correct : forall fi f fi0 f0 n, (forall ai a m, ai >: a -> fi ai m >: f a m) -> fi0 >: f0 -> rec1 fi fi0 n >:: PolR.rec1 f f0 n. Parameter rec2_correct : forall fi f fi0 f0 fi1 f1 n, (forall ai bi a b m, ai >: a -> bi >: b -> fi ai bi m >: f a b m) -> fi0 >: f0 -> fi1 >: f1 -> rec2 fi fi0 fi1 n >:: PolR.rec2 f f0 f1 n. Parameter grec1_correct : forall Fi (F : PolR.T -> nat -> PolR.T) Gi (G : PolR.T -> nat -> R) ai a si s n, (forall qi q m, qi >:: q -> Fi qi m >:: F q m) -> (forall qi q m, qi >:: q -> Gi qi m >: G q m) -> ai >:: a -> seq_contains_pointwise si s -> seq_eq_size si s -> grec1 Fi Gi ai si n >:: PolR.grec1 F G a s n. (* TODO size_correct *) (* TODO recN_correct : forall N : nat, C.T ^ N -> C.T ^^ N --> (nat -> C.T) -> nat -> T. *) (* TODO lastN_correct : C.T -> forall N : nat, T -> C.T ^ N. *) Parameter nth_default_alt : forall pi p, pi >:: p -> forall n : nat, size pi <= n -> PolR.nth p n = 0%R. Definition poly_eqNai s := forall k, k < size s -> I.convert (nth s k) = Inan. Definition seq_eqNai s := forall k, k < seq.size s -> I.convert (seq.nth I.zero s k) = Inan. Parameter grec1_propagate : forall A (Fi : A -> nat -> A) (Gi : A -> nat -> I.type) ai si, (forall qi m, I.convert (Gi qi m) = Inan) -> seq_eqNai si -> forall n, poly_eqNai (grec1 Fi Gi ai si n). Parameter dotmuldiv_propagate : forall u a b p, seq.size a = size p -> seq.size b = size p -> poly_eqNai p -> poly_eqNai (dotmuldiv u a b p). Parameter rec1_propagate : forall (Fi : I.type -> nat -> I.type) ai, (forall qi m, I.convert qi = Inan -> I.convert (Fi qi m) = Inan) -> I.convert ai = Inan -> forall n, poly_eqNai (rec1 Fi ai n). Parameter polyCons_propagate : forall xi pi, I.convert xi = Inan -> poly_eqNai pi -> poly_eqNai (polyCons xi pi). End PolyIntOps. (** Note that the implementation(s) of the previous signature will depend on the choice of a particular polynomial basis, especially for the multiplication and polynomial evaluation. *) (** Implementation of PolyOps with sequences and operations in monomial basis *) Module SeqPolyInt (I : IntervalOps) <: PolyIntOps I. Module Int := FullInt I. Include SeqPoly Int. Module J := IntervalExt I. Definition contains_pointwise pi p : Prop := forall k, contains (I.convert (nth pi k)) (Xreal (PolR.nth p k)). (* Very similar definition, suitable for specifying grec1 *) Definition seq_contains_pointwise si s : Prop := forall k, contains (I.convert (seq.nth Int.zero si k)) (Xreal (PolR.nth s k)). Notation seq_eq_size si s := (seq.size si = seq.size s). Module Import Notations. Delimit Scope ipoly_scope with IP. Notation "i >: x" := (contains (I.convert i) (Xreal x)) : ipoly_scope. Notation "p >:: x" := (contains_pointwise p x) : ipoly_scope. Notation eq_size pi p := (size pi = PolR.size p). End Notations. Local Open Scope ipoly_scope. Definition poly_eqNai s := forall k, k < size s -> I.convert (nth s k) = Inan. Definition seq_eqNai s := forall k, k < seq.size s -> I.convert (seq.nth I.zero s k) = Inan. Lemma horner_propagate u pi : J.propagate (horner u pi). Proof. intros x. apply I.mask_propagate_r. Qed. Lemma zero_correct : zero >:: PolR.zero. Proof. by case=> [|k]; exact: J.zero_correct. Qed. Lemma one_correct : one >:: PolR.one. Proof. case=> [|k] /=. exact: I.fromZ_small_correct. exact: zero_correct. Qed. Lemma opp_correct pi p : pi >:: p -> opp pi >:: PolR.opp p. Proof. move=> Hp k; rewrite /opp /PolR.opp /nth /PolR.nth. apply(*:*) (@map_correct R I.type) =>//. - exact: J.zero_correct. - by move=> ? /J.contains_only_0 ->; rewrite Ropp_0; apply: J.zero_correct. - by move=> *; rewrite -(Ropp_0); apply: J.neg_correct. - move=> *; exact: J.neg_correct. Qed. Lemma map_correct fi f pi p : (f 0%R = 0%R) -> (forall xi x, xi >: x -> fi xi >: f x) -> pi >:: p -> map fi pi >:: PolR.map f p. Proof. move=> H0 Hf Hp k; rewrite /map /PolR.map /nth /PolR.nth. apply(*:*) (@map_correct R I.type) =>//. - exact: J.zero_correct. - by move=> ? /J.contains_only_0 ->; rewrite H0; apply: J.zero_correct. - by move=> *; rewrite -(H0); apply: Hf. - move=> *; exact: Hf. Qed. Lemma add_correct u pi qi p q : pi >:: p -> qi >:: q -> add u pi qi >:: PolR.add tt p q. Proof. move=> Hp Hq k; rewrite /PolR.add /add /nth /PolR.nth. apply (@map2_correct R I.type) =>//. - exact: J.zero_correct. - exact: J.contains_only_0. - by move=> ? ? ? H1 /J.contains_only_0 ->; rewrite Rplus_0_r. - by move=> ? ? ? /J.contains_only_0 -> H2; rewrite Rplus_0_l. - by move=> v1 ? ? ? ?; rewrite -(Rplus_0_r v1); apply: J.add_correct. - by move=> v2 ? ? ? ?; rewrite -(Rplus_0_l v2); apply: J.add_correct. - by move=> *; apply: J.add_correct. Qed. Lemma nth_default_alt pi p : pi >:: p -> forall n : nat, size pi <= n -> PolR.nth p n = 0%R. Proof. move=> Hpi n Hn. case: (leqP (PolR.size p) (size pi)) => Hsz. rewrite PolR.nth_default //; exact: leq_trans Hsz Hn. by move/(_ n): Hpi; rewrite nth_default //; move/J.contains_only_0=>->. Qed. Lemma dotmuldiv_correct u a b pi p : seq.size a = seq.size b -> pi >:: p -> dotmuldiv u a b pi >:: PolR.dotmuldiv tt a b p. Proof. move=> Hs Hp. move=> k; rewrite nth_dotmuldiv PolR.nth_dotmuldiv. do ![case: ifP] => /or3P A /or3P B. - exact: J.zero_correct. - case B. by move/nth_default_alt =>->; rewrite ?Rmult_0_r; try exact: J.zero_correct. by move/or3P in A; move=> K; rewrite K orbT in A. by move/or3P in A; move=> K; rewrite K !orbT in A. - case A=> K. rewrite <- (Rmult_0_r (Rdiv (IZR (seq.nth 0%Z a k)) (IZR (seq.nth 0%Z b k)))). apply J.mul_correct. by apply: J.div_correct; apply: I.fromZ_correct. have->: 0%R = PolR.nth p k. by move/PolR.nth_default: K. exact: Hp. by move/or3P in B; rewrite K !orbT in B. by move/or3P in B; rewrite K !orbT in B. - apply: J.mul_correct =>//. apply: J.div_correct =>//; exact: I.fromZ_correct. Qed. Lemma sub_correct u pi qi p q : pi >:: p -> qi >:: q -> sub u pi qi >:: PolR.sub tt p q. Proof. move=> Hp Hq k; rewrite /PolR.sub /sub /nth /PolR.nth. apply (@map2_correct R I.type) =>//. - exact: J.zero_correct. - by move=> v /J.contains_only_0 ->; rewrite Ropp_0; apply: J.zero_correct. - by move=> t ?; rewrite -Ropp_0; apply: J.neg_correct. - move=> *; exact: J.neg_correct. - exact: J.contains_only_0. - by move=> ? ? ? H1 /J.contains_only_0 ->; rewrite Rminus_0_r. - by move=> ? ? ? /J.contains_only_0 -> H2; rewrite Rminus_0_l; apply: J.neg_correct. - by move=> v1 ? ? ? ?; rewrite -(Rminus_0_r v1); apply: J.sub_correct. - by move=> v2 ? ? ? ?; rewrite -(Rminus_0_l v2); apply: J.sub_correct. - by move=> *; apply: J.sub_correct. Qed. Lemma mul_coeff_correct u pi qi p q : pi >:: p -> qi >:: q -> forall k : nat, mul_coeff u pi qi k >: PolR.mul_coeff tt p q k. Proof. move=> Hpi Hqi k. rewrite mul_coeffE PolR.mul_coeffE. apply (@big_ind2 R I.type (fun r i => i >: r)). - exact: J.zero_correct. - move=> *; exact: J.add_correct. - move=> *; exact: J.mul_correct. Qed. Lemma mul_correct u pi qi p q : pi >:: p -> qi >:: q -> mul u pi qi >:: PolR.mul tt p q. Proof. move=> Hp Hq; rewrite /mul /PolR.mul /nth /PolR.nth. apply: (mkseq_correct (Rel := fun r i => i >: r)) =>//. - exact: J.zero_correct. - exact: mul_coeff_correct. - move=> k /andP [Hk _]; rewrite PolR.mul_coeffE. rewrite PolR.mul_coeff_eq0 //. move/addn_pred_leqI in Hk. by move=> i Hi; case: (Hk i Hi); move/PolR.nth_default=>->; intuition. - move=> k /andP [Hk _]; rewrite PolR.mul_coeffE /size. rewrite PolR.mul_coeff_eq0 //. move/addn_pred_leqI in Hk. by move=> i Hi; case: (Hk i Hi); move/nth_default_alt=>->; intuition. Qed. Lemma mul_trunc_correct u n pi qi p q : pi >:: p -> qi >:: q -> mul_trunc u n pi qi >:: PolR.mul_trunc tt n p q. Proof. move=> Hp Hq; rewrite /nth /PolR.nth. apply: (mkseq_correct (Rel := fun r i => i >: r)) =>//. - exact: J.zero_correct. - exact: mul_coeff_correct. - by move=> k; rewrite ltn_leqN. - by move=> k; rewrite ltn_leqN. Qed. Lemma mul_tail_correct u n pi qi p q : pi >:: p -> qi >:: q -> mul_tail u n pi qi >:: PolR.mul_tail tt n p q. Proof. move=> Hp Hq; rewrite /mul_tail /PolR.mul_tail /nth /PolR.nth. apply: (mkseq_correct (Rel := fun r i => i >: r)) =>//. - exact: J.zero_correct. - move=> k; exact: mul_coeff_correct. - move=> k /andP [_k k_]; rewrite PolR.mul_coeffE. rewrite PolR.mul_coeff_eq0 //. move=> i Hi. rewrite leq_subLR in _k. move/addn_pred_leqI in _k. by case: (_k i Hi); move/PolR.nth_default=>->; intuition. - move=> k /andP [Hk _]; rewrite PolR.mul_coeffE /size. rewrite PolR.mul_coeff_eq0 //. rewrite leq_subLR in Hk. move/addn_pred_leqI in Hk. by move=> i Hi; case: (Hk i Hi); move/nth_default_alt=>->; intuition. Qed. Lemma mul_mixed_correct u ai pi a p : ai >: a -> pi >:: p -> mul_mixed u ai pi >:: PolR.mul_mixed tt a p. Proof. move=> Ha Hp; rewrite /mul_mixed /PolR.mul_mixed. apply: (seq_foldr_correct (Rel := fun v t => t >: v)) =>//. - move=> x s /J.contains_only_0 -> Hs [|k] /=; first by rewrite Rmult_0_r; apply: J.zero_correct. by move: (Hs k); rewrite nth_nil. - move=> x s Hx Hs [|k]; first by rewrite -(Rmult_0_r a); apply: J.mul_correct. by move: (Hs k); rewrite nth_nil. - move=> x y s t Hx Hs [|k]; first by apply: J.mul_correct. by apply: Hs. Qed. Lemma div_mixed_r_correct u pi bi p b : pi >:: p -> bi >: b -> div_mixed_r u pi bi >:: PolR.div_mixed_r tt p b. Proof. move=> Ha Hp; rewrite /div_mixed_r /PolR.div_mixed_r. apply: (seq_foldr_correct (Rel := fun v t => t >: v)) =>//. - move=> x s /J.contains_only_0 -> Hs [|k] /=; first by rewrite /Rdiv Rmult_0_l; apply: J.zero_correct. by move: (Hs k); rewrite nth_nil. - move=> x s Hx Hs [|k]; last by move: (Hs k); rewrite nth_nil. by rewrite -(Rmult_0_l (Rinv b)); apply: J.div_correct. - move=> x y s t Hx Hs [|k]; first by apply: J.div_correct. by apply: Hs. Qed. Lemma horner_correct u pi ai p a : pi >:: p -> ai >: a -> horner u pi ai >: PolR.horner tt p a. Proof. move=> Hp Ha. rewrite /horner /PolR.horner. apply: I.mask_correct'. apply: (foldr_correct (Rel := fun v t => t >: v)) =>//. - exact: J.zero_correct. - move=> x y /J.contains_only_0 -> /J.contains_only_0 ->; rewrite Rmult_0_l Rplus_0_r; exact: J.zero_correct. - move=> x y Hx Hy; rewrite -(Rplus_0_r 0) -{1}(Rmult_0_l a). apply: J.add_correct =>//; exact: J.mul_correct. - move=> x xi y yi Hx Hy; apply: J.add_correct=>//; exact: J.mul_correct. Qed. Lemma deriv_correct u pi p : pi >:: p -> deriv u pi >:: PolR.deriv tt p. Proof. move=> Hpi; rewrite /deriv /PolR.deriv /deriv_loop /PolR.deriv_loop. apply: (seq_foldri_correct (Rel := fun v t => t >: v)) =>//. - by move=> k; rewrite !nth_behead. - move=> x s i Hx Hs [|k] /=. + by move/J.contains_only_0: Hx->; rewrite Rmult_0_l; apply: J.zero_correct. + by move: (Hs k); rewrite nth_nil. - move=> x s i Hx Hs [|k] /=. rewrite -(Rmult_0_l (INR i)). apply: J.mul_correct =>//; rewrite INR_IZR_INZ; apply: I.fromZ_correct. by move: (Hs k); rewrite nth_nil. - move=> x xi y yi i Hx Hy [|k] //=. by apply: J.mul_correct =>//; rewrite INR_IZR_INZ; apply: I.fromZ_correct. Qed. Lemma set_nth_correct pi p n ai a : pi >:: p -> ai >: a -> set_nth pi n ai >:: PolR.set_nth p n a. Proof. move=> Hp Ha k; rewrite /nth /PolR.nth. exact: (MathComp.set_nth_correct (Rel := fun v t => t >: v)). Qed. Lemma lift_correct n pi p : pi >:: p -> lift n pi >:: PolR.lift n p. Proof. move=> Hp k; rewrite /nth /PolR.nth. by apply: (ncons_correct (Rel := fun v t => t >: v)); first exact: J.zero_correct. Qed. Lemma tail_correct n pi p : pi >:: p -> tail n pi >:: PolR.tail n p. move=> Hp k; rewrite /nth /PolR.nth. exact: (drop_correct (Rel := fun v t => t >: v)). Qed. Lemma polyNil_correct : polyNil >:: PolR.polyNil. Proof. intro; rewrite /nth /PolR.nth ![seq.nth _ _ _]nth_nil; exact: J.zero_correct. Qed. Lemma polyCons_correct pi xi p x : pi >:: p -> xi >: x -> polyCons xi pi >:: PolR.polyCons x p. Proof. by move=> Hp Hx [|k] /=. Qed. Lemma rec1_correct fi f fi0 f0 n : (forall ai a m, ai >: a -> fi ai m >: f a m) -> fi0 >: f0 -> rec1 fi fi0 n >:: PolR.rec1 f f0 n. Proof. move=> Hf Hf0. by apply: (rec1up_correct (Rel := fun r i => i >: r)); first exact: J.zero_correct. Qed. Lemma rec2_correct fi f fi0 f0 fi1 f1 n : (forall ai bi a b m, ai >: a -> bi >: b -> fi ai bi m >: f a b m) -> fi0 >: f0 -> fi1 >: f1 -> rec2 fi fi0 fi1 n >:: PolR.rec2 f f0 f1 n. Proof. move=> Hf Hf0 Hf1. by apply: (rec2up_correct (Rel := fun r i => i >: r)); first exact: J.zero_correct. Qed. Lemma grec1_correct Fi (F : PolR.T -> nat -> PolR.T) Gi (G : PolR.T -> nat -> R) ai a si s n : (forall qi q m, qi >:: q -> Fi qi m >:: F q m) -> (forall qi q m, qi >:: q -> Gi qi m >: G q m) -> ai >:: a -> seq_contains_pointwise si s -> eq_size si s -> grec1 Fi Gi ai si n >:: PolR.grec1 F G a s n. Proof. move=> HF HG Ha Hs Hsize. by apply: (grec1up_correct (Rel := fun r i => i >: r)); first exact: J.zero_correct. Qed. Lemma polyC_correct ci c : ci >: c -> polyC ci >:: PolR.polyC c. Proof. move=> Hc [//|k]. rewrite /polyC /PolR.polyC. rewrite nth_polyCons PolR.nth_polyCons. rewrite nth_polyNil PolR.nth_polyNil. exact: J.zero_correct. Qed. Lemma polyX_correct : polyX >:: PolR.polyX. Proof. case=> [|k] /=; first exact: J.zero_correct. case: k => [|k] /=. exact: I.fromZ_small_correct. rewrite /nth /PolR.nth !nth_nil. exact: J.zero_correct. Qed. Lemma primitive_correct u ci c pi p : ci >: c -> pi >:: p -> primitive u ci pi >:: PolR.primitive tt c p. Proof. move=> Hc Hp; rewrite /primitive /PolR.primitive /nth /PolR.nth. apply: polyCons_correct =>//. apply: (mkseq_correct (Rel := fun r i => i >: r)) =>//. - exact: J.zero_correct. - move=> k; rewrite /int_coeff_shift /PolR.int_coeff_shift. apply: J.div_correct =>//. rewrite INR_IZR_INZ. exact: I.fromZ_correct. - move=> k /andP [_k k_]; rewrite /PolR.int_coeff_shift. by rewrite [seq.nth _ _ _](PolR.nth_default _k) /Rdiv Rmult_0_l. - move=> k /andP [_k k_]; rewrite /PolR.int_coeff_shift. by rewrite [seq.nth _ _ _](nth_default_alt Hp _k) /Rdiv Rmult_0_l. Qed. (* Check all_nthP *) Lemma grec1_propagate A (Fi : A -> nat -> A) (Gi : A -> nat -> I.type) ai si : (forall qi m, I.convert (Gi qi m) = Inan) -> seq_eqNai si -> forall n, poly_eqNai (grec1 Fi Gi ai si n). Proof. move=> HG Hs n k Hk. rewrite /grec1 /size size_grec1up ltnS in Hk. rewrite /grec1 /nth nth_grec1up. rewrite ltnNge Hk /=. case: ltnP => H2. - exact: Hs. - exact: HG. Qed. Arguments nth_rec1up_indep [T F a0 d1 d2 m1 m2 n] _ _. Lemma rec1_propagate (Fi : I.type -> nat -> I.type) ai : (forall qi m, I.convert qi = Inan -> I.convert (Fi qi m) = Inan) -> I.convert ai = Inan -> forall n, poly_eqNai (rec1 Fi ai n). Proof. move=> HF Ha n k Hk. rewrite /size size_rec1up ltnS in Hk. rewrite /nth /rec1. (* TODO/Erik: to tidy...*) rewrite (nth_rec1up_indep (d2 := I.zero) (m2 := k)) //. rewrite nth_rec1up_last. rewrite last_rec1up head_loop1 //. elim: k Hk => [//|k IHk] Hk /=. apply: HF. apply: IHk. exact: ltnW. Qed. (* TODO size_correct *) (* TODO recN_correct : forall N : nat, C.T ^ N -> C.T ^^ N --> (nat -> C.T) -> nat -> T. *) (* TODO lastN_correct : C.T -> forall N : nat, T -> C.T ^ N. *) Lemma dotmuldiv_propagate u a b p : seq.size a = size p -> seq.size b = size p -> poly_eqNai p -> poly_eqNai (dotmuldiv u a b p). Proof. move=> Ha Hb Hp; red => k Hk. rewrite (@size_dotmuldiv (size p)) // in Hk. rewrite nth_dotmuldiv Ha Hb !orbb ifF. rewrite I.mul_propagate_r //. exact: Hp. by rewrite leqNgt Hk. Qed. Lemma polyCons_propagate xi pi : I.convert xi = Inan -> poly_eqNai pi -> poly_eqNai (polyCons xi pi). Proof. move=> Hxi Hpi [|k]; rewrite size_polyCons nth_polyCons // ltnS; exact: Hpi. Qed. End SeqPolyInt. interval-4.11.1/src/Poly/Taylor_model.v000066400000000000000000001151601470547631300177730ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2013-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals ZArith Psatz. From mathcomp.ssreflect Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq bigop. Require Import Interval. Require Import Xreal. Require Import Basic. Require Import Interval_compl. Require Import Datatypes. Require Import Taylor_model_sharp. Require Import Bound. Require Import Bound_quad. Require Import Univariate_sig. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. (** * Auxiliary lemmas on natural numbers *) Local Open Scope nat_scope. Lemma maxnS (m n : nat) : 0 < maxn m n.+1. Proof. by case: m =>[//|m]; rewrite maxnSS. Qed. Lemma maxSn (m n : nat) : 0 < maxn m.+1 n. Proof. by rewrite maxnC maxnS. Qed. (** * Parameterized Module for Taylor Models *) Module TM (I : IntervalOps) <: UnivariateApprox I. (* Erik: We might add a Boolean counterpart of not_empty in IntervalOps *) (** ** Load the CoqApprox modules *) Module Pol := SeqPolyInt I. Module Bnd := PolyBoundHornerQuad I Pol. Module Import TMI := TaylorModel I Pol Bnd. (** ** Main type definitions *) Inductive t_ := Const of I.type | Var | Tm of rpa. Definition T := t_. Definition U := (I.precision * nat)%type. Definition i1 := I.fromZ_small 1. Definition i2 := I.fromZ_small 2. Definition im1 := I.fromZ_small (-1). (** ** Auxiliary material *) Definition tmsize (tm : rpa) := Pol.size (approx tm). Definition tsize (t : T) : nat := match t with | Const _ => 1 | Var => 2 | Tm tm => tmsize tm end. Definition get_tm (u : U) X (t : T) : rpa := match t with | Const c => TM_cst X c | Var => TM_var X (J.midpoint X) | Tm tm => tm (* ignore u, X in this branch *) end. Lemma size_get_tm u X t : tmsize (get_tm u X t) = tsize t. Proof. by case: t. Qed. (** ** Define the main validity predicate *) Definition approximates (X : I.type) (tf : T) (f : R -> ExtendedR) : Prop := not_empty (I.convert X) -> match tf with | Const c => I.convert c = Inan \/ is_const f (I.convert X) (I.convert c) | Var => forall x : R, contains (I.convert X) (Xreal x) -> f x = Xreal x | Tm tm => let x0 := proj_val (I.F.convert (I.midpoint X)) in i_validTM x0 (I.convert X) tm f end. Theorem approximates_ext f g xi t : (forall x, f x = g x) -> approximates xi t f -> approximates xi t g. Proof. move=> Hfg Hmain. case: t Hmain =>[c| |tm] Hmain Hne. destruct Hmain as [H|Hmain] =>//. now left. right. exact: is_const_ext_weak Hmain. by move=> *; rewrite -Hfg; apply: Hmain. move/(_ Hne): Hmain. exact: TM_fun_eq. Qed. Lemma contains_midpoint : forall X : I.type, not_empty (I.convert X) -> contains (I.convert X) (Xreal (proj_val (I.F.convert (I.midpoint X)))). Proof. intros X H. destruct (I.midpoint_correct X H) as [H1 H2]. now rewrite <- H1. Qed. Lemma get_tm_correct u Y tf f : approximates Y tf f -> approximates Y (Tm (get_tm u Y tf)) f. Proof. case: tf =>[c||tm]; rewrite /approximates // => H Hne. move/(_ Hne) in H. - destruct H as [H|H]. split ; intros ; rewrite ?I.mask_propagate_r //. exact: contains_midpoint. exists (PolR.polyC 0). now apply Pol.polyC_correct ; rewrite H. easy. apply TM_cst_correct_strong =>//. exact: contains_midpoint. - apply: TM_var_correct_strong=>//. exact: J.subset_midpoint. exact: J.contains_midpoint. - exact: H. Qed. (** ** Main definitions and correctness claims *) Definition const : I.type -> T := Const. Theorem const_correct (c : I.type) (r : R) : contains (I.convert c) (Xreal r) -> forall (X : I.type), approximates X (const c) (fun _ => Xreal r). Proof. move=> Hcr X. right. now exists (Xreal r). Qed. Definition dummy : T := Const I.nai. Theorem dummy_correct xi f : TM.approximates xi dummy f. Proof. left. apply I.nai_correct. Qed. Definition var : T := Var. Theorem var_correct (X : I.type) : approximates X var Xreal. Proof. done. Qed. Definition eval (u : U) (t : T) (Y X : I.type) : I.type := if I.subset X Y then match t with | Const c => I.mask c X (* the need for I.mask comes from I.extension below *) | Var => X | Tm tm => let X0 := J.midpoint Y in let tm := get_tm u Y t in I.add u.1 (Bnd.ComputeBound u.1 (approx tm) (I.sub u.1 X X0)) (error tm) end else I.nai. Theorem eval_correct u (Y : I.type) tf f : approximates Y tf f -> I.extension (Xbind f) (eval u tf Y). Proof. move=> Hf X x Hx. rewrite /eval. case HXY: I.subset; last by rewrite I.nai_correct. move/I.subset_correct: (HXY) => Hsubset. specialize (Hsubset _ Hx). have HneY: not_empty (I.convert Y). { apply (not_empty_contains _ x). exact: Hsubset. } case: tf Hf => [c| |tm]. (* Const *) case. { easy. } { move=> Hne. now rewrite I.mask_propagate_l. } { move=> H. destruct x as [|x]. now apply contains_Xnan, I.mask_propagate_r, contains_Xnan. apply I.mask_correct'. rewrite /is_const in H. case: H => y H1 H2. now rewrite /= (H2 x). } (* Var *) by case: x Hx Hsubset => [|x] Hx Hsubset //= ->. (* Tm *) move=> Hf. have /= {Hf} := get_tm_correct u Hf=> Htm. move/(_ HneY): Htm. case => [Hdef Hnai Hzero _ Hmain]. set c0 := proj_val (I.F.convert (I.midpoint Y)). have [qx Hcont Hdelta] := Hmain. destruct x as [|x] ; simpl. { rewrite I.add_propagate_l //. apply: Bnd.ComputeBound_propagate. rewrite I.sub_propagate_l //. now apply contains_Xnan. } move/(_ x) in Hdelta. have->: f x = Xadd (Xreal (PolR.horner tt qx (Rminus x c0))) (Xsub (f x) (Xreal (PolR.horner tt qx (Rminus x c0)))). case Efx : (f x) => [|r]; first by rewrite Xadd_comm. simpl. by congr Xreal; ring. apply I.add_correct =>//. apply: Bnd.ComputeBound_correct =>//. apply: J.sub_correct Hx _. exact: J.contains_midpoint. case Efx: (f x) => [|fx]. apply/contains_Xnan. apply: Hdef Efx. exact: Hsubset. rewrite Efx in Hdelta. apply: Hdelta. exact: Hsubset. Qed. Definition add_slow (u : U) (X : I.type) (t1 : T) (t2 : T) : T := let M1 := get_tm u X t1 in let M2 := get_tm u X t2 in Tm (TM_add u.1 M1 M2). Definition add (u : U) (X : I.type) (t1 : T) (t2 : T) : T := match t1, t2 with | Const c1, Const c2 => Const (I.add u.1 c1 c2) | _, _ => add_slow u X t1 t2 end. Lemma add_slow_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (add_slow u Y tf tg) (fun x => Xadd (f x) (g x)). Proof. intros Hf Hg Hne. now apply TM_add_correct ; apply get_tm_correct. Qed. Theorem add_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (add u Y tf tg) (fun x => Xadd (f x) (g x)). Proof. move: tf tg => [cf| |tf] [cg| |tg] Hf Hg; try exact: add_slow_correct. move=> Hne. case: (Hf Hne) => {Hf}[Hf|[yf Hyf1 /= Hyf2]]. left. now apply I.add_propagate_l. case: (Hg Hne) => {Hg}[Hg|[yg Hyg1 /= Hyg2]]. left. now apply I.add_propagate_r. right. exists (Xadd yf yg); first exact: I.add_correct. by move=> x Hx; rewrite /= Hyf2 // Hyg2. Qed. Definition opp_slow (u : U) (X : I.type) (t : T) : T := Tm (TM_opp (get_tm u X t)). Definition opp (u : U) (X : I.type) (t : T) : T := match t with | Const c => Const (I.neg c) | _ => opp_slow u X t end. Lemma opp_slow_correct u (Y : I.type) tf f : approximates Y tf f -> approximates Y (opp_slow u Y tf) (fun x => Xneg (f x)). Proof. intros Hf Hne. now apply TM_opp_correct ; apply get_tm_correct. Qed. Theorem opp_correct u (Y : I.type) tf f : approximates Y tf f -> approximates Y (opp u Y tf) (fun x => Xneg (f x)). Proof. move: tf => [cf| |tf] Hmain; try exact: opp_slow_correct. move=> Hne. destruct (Hmain Hne) as [H|[y Hy1 Hy2]]. left. now apply J.neg_propagate. right. exists (Xneg y); first exact: I.neg_correct. by move=> x Hx; rewrite /= Hy2. Qed. Definition sub_slow (u : U) (X : I.type) (t1 : T) (t2 : T) : T := let M1 := get_tm u X t1 in let M2 := get_tm u X t2 in Tm (TM_sub u.1 M1 M2). Definition sub (u : U) (X : I.type) (t1 : T) (t2 : T) : T := match t1, t2 with | Const c1, Const c2 => Const (I.sub u.1 c1 c2) (*| Var, Var => Const I.zero : FIXME *) | _, _ => sub_slow u X t1 t2 end. Lemma sub_slow_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (sub_slow u Y tf tg) (fun x => Xsub (f x) (g x)). Proof. intros Hf Hg Hne. now apply TM_sub_correct ; apply get_tm_correct. Qed. Theorem sub_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (sub u Y tf tg) (fun x => Xsub (f x) (g x)). Proof. move: tf tg => [cf| |tf] [cg| |tg] Hf Hg; try exact: sub_slow_correct. move=> Hne. move: Hf => /(_ Hne) [Hf|[yf Hyf1 /= Hyf2]]. left. now apply I.sub_propagate_l. move: Hg => /(_ Hne) [Hg|[yg Hyg1 /= Hyg2]]. left. now apply I.sub_propagate_r. right. exists (Xsub yf yg); first exact: I.sub_correct. by move=> x Hx; rewrite /= Hyf2 // Hyg2. Qed. Definition mul_slow (u : U) (X : I.type) (t1 : T) (t2 : T) : T := let M1 := get_tm u X t1 in let M2 := get_tm u X t2 in let X0 := J.midpoint X in Tm (TM_mul u.1 M1 M2 X0 X u.2). Definition mul (u : U) (X : I.type) (t1 : T) (t2 : T) : T := match t1, t2 with | Const c1, Const c2 => Const (I.mul u.1 c1 c2) | Const c1, _ => Tm (TM_mul_mixed u.1 c1 (get_tm u X t2) ) | _, Const c2 => Tm (TM_mul_mixed u.1 c2 (get_tm u X t1) ) | _, _ => mul_slow u X t1 t2 end. Lemma mul_slow_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (mul_slow u Y tf tg) (fun x => Xmul (f x) (g x)). Proof. intros Hf Hg Hne. apply TM_mul_correct ; try apply get_tm_correct ; try easy. exact: J.contains_midpoint. Qed. Theorem mul_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (mul u Y tf tg) (fun x => Xmul (f x) (g x)). Proof. move: tf tg => [cf| |tf] [cg| |tg] Hf Hg; try exact: mul_slow_correct. (* Const . Const *) move=> Hne. move: Hf => /(_ Hne) [Hf|[yf Hyf1 /= Hyf2]]. left. now apply I.mul_propagate_l. move: Hg => /(_ Hne) [Hg|[yg Hyg1 /= Hyg2]]. left. now apply I.mul_propagate_r. right. exists (Xmul yf yg); first exact: I.mul_correct. by move=> x Hx; rewrite /= Hyf2 // Hyg2. (* Const . Var *) intros Hne. move: Hf => /(_ Hne) [Hf|Hf]. apply TM_mul_mixed_nai with (f := g) (1 := Hf). now apply get_tm_correct. apply: TM_mul_mixed_correct_strong =>//. now apply get_tm_correct. (* Const . Tm *) intros Hne. move: Hf => /(_ Hne) [Hf|Hf]. apply TM_mul_mixed_nai with (f := g) (1 := Hf). now apply get_tm_correct. apply: TM_mul_mixed_correct_strong =>//. now apply get_tm_correct. (* Var . Const *) intros Hne. apply: (@TM_fun_eq (fun x => Xmul (g x) (f x)) _) =>//. by move=> *; exact: Xmul_comm. move: Hg => /(_ Hne) [Hg|Hg]. apply TM_mul_mixed_nai with (f := f) (1 := Hg). now apply get_tm_correct. apply: TM_mul_mixed_correct_strong =>//. now apply get_tm_correct. (* Tm . Const *) intros Hne. apply: (@TM_fun_eq (fun x => Xmul (g x) (f x)) _) =>//. by move=> *; exact: Xmul_comm. move: Hg => /(_ Hne) [Hg|Hg]. apply TM_mul_mixed_nai with (f := f) (1 := Hg). now apply get_tm_correct. apply: TM_mul_mixed_correct_strong =>//. now apply get_tm_correct. Qed. Definition div_slow (u : U) (X : I.type) (t1 : T) (t2 : T) : T := let M1 := get_tm u X t1 in let M2 := get_tm u X t2 in let X0 := J.midpoint X in Tm (TM_div u.1 M1 M2 X0 X u.2). Definition div (u : U) (X : I.type) (t1 : T) (t2 : T) : T := match t1, t2 with | Const c1, Const c2 => Const (I.div u.1 c1 c2) | _, Const c2 => Tm (TM_div_mixed_r u.1 (get_tm u X t1) c2) (*| Var, Var => Const (I.fromZ 1) : FIXME *) | _, _ => div_slow u X t1 t2 end. Lemma div_slow_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (div_slow u Y tf tg) (fun x => Xdiv (f x) (g x)). Proof. intros Hf Hg Hne. apply TM_div_correct ; try apply get_tm_correct ; try easy. exact: J.contains_midpoint. Qed. Theorem div_correct u (Y : I.type) tf tg f g : approximates Y tf f -> approximates Y tg g -> approximates Y (div u Y tf tg) (fun x => Xdiv (f x) (g x)). Proof. move: tf tg => [cf| |tf] [cg| |tg] Hf Hg; try exact: div_slow_correct. (* Const . Const *) move=> Hne. move: Hf => /(_ Hne) [Hf|[yf Hyf1 /= Hyf2]]. left. now apply I.div_propagate_l. move: Hg => /(_ Hne)[Hg|[yg Hyg1 /= Hyg2]]. left. now apply I.div_propagate_r. right. exists (Xdiv yf yg); first exact: I.div_correct. by move=> x Hx; rewrite /= Hyf2 // Hyg2. (* Var . Const *) intros Hne. move: Hg => /(_ Hne) [Hg|Hg]. apply TM_div_mixed_r_nai with (f := f) (1 := Hg). now apply get_tm_correct. apply: TM_div_mixed_r_correct_strong =>//. apply: TM_var_correct_strong =>//. - exact: J.subset_midpoint. - exact: J.contains_midpoint. - exact: Hf. (* Const . Tm *) move=> Hne. move: Hg => /(_ Hne) [Hg|Hg]. apply TM_div_mixed_r_nai with (f := f) (1 := Hg). now apply get_tm_correct. apply: TM_div_mixed_r_correct_strong =>//. now apply get_tm_correct. Qed. Definition abs (u : U) (X : I.type) (t : T) : T := let e := eval u t X X in match I.sign_large e with | Xeq | Xgt => t | Xlt => opp u X t | Xund => Tm (TM_any u.1 (I.abs e) X u.2) end. Lemma Isign_large_Xabs (u : U) (tf : T) (Y X : I.type) f : approximates Y tf f -> match I.sign_large (eval u tf Y X) with | Xeq => forall x, contains (I.convert X) (Xreal x) -> f x = Xabs (f x) (* weak but sufficient *) | Xgt => forall x, contains (I.convert X) (Xreal x) -> f x = Xabs (f x) | Xlt => forall x, contains (I.convert X) (Xreal x) -> Xneg (f x) = Xabs (f x) | Xund => True end. Proof. intros Hmain. case: I.sign_large (I.sign_large_correct (eval u tf Y X)) =>//. - move=> H x Hx. rewrite (H (f x)) /= ?Rabs_R0 //. exact: eval_correct Hx. - move=> H x Hx. set fx := f x. have [|Hfx Hsign] := H fx. exact: eval_correct Hx. rewrite /Xabs Hfx /=; congr Xreal. by rewrite Rabs_left1. move=> H x Hx. set fx := f x. have [|Hfx Hsign] := H fx. exact: eval_correct Hx. rewrite /Xabs Hfx /=; congr Xreal. by rewrite Rabs_right; auto with real. Qed. Local Ltac byp a b := move=> x Hx; rewrite -a //; exact: b. Local Ltac byp' a b := let Hne := fresh in move=> Hne x Hx; rewrite -a //; exact: (b Hne). Local Ltac foo := by move=> Hne; apply: TM_any_correct; [ exact: contains_midpoint | intros x Hx; apply: I.abs_correct; exact: eval_correct Hx]. Theorem abs_correct u (Y : I.type) tf f : approximates Y tf f -> approximates Y (abs u Y tf) (fun x => Xabs (f x)). Proof. move=> Hf. rewrite /abs. case: I.sign_large (@Isign_large_Xabs u tf Y Y f Hf) => Habs; case: tf Hf => [cf| |tf] Hmain //. - move=> Hne. case: (Hmain Hne) => [Hf|Hf]. now left. right. apply: is_const_ext Hf. intros x Hx. now apply Habs. - byp' Habs Hmain. - move=> Hne; apply: (@TM_fun_eq f). byp Habs Hf. exact: Hmain. - move=> Hne; destruct (Hmain Hne) as [Hf|[y Hy1 Hy2]]. left. now apply J.neg_propagate. right. exists (Xneg y). exact: I.neg_correct. move => /= x Hx. by rewrite -Habs // Hy2. - red=> Hne. apply (TM_fun_eq Habs). apply: TM_opp_correct. apply: TM_var_correct_strong =>//. exact: J.subset_midpoint. exact: J.contains_midpoint. exact: Hmain Hne. - red=> Hne. apply (TM_fun_eq Habs). apply: TM_opp_correct. exact: Hmain. - move=> Hne; destruct (Hmain Hne) as [Hf|[y Hy1 Hy2]]. now left. right. exists y => //= x Hx. by rewrite -Habs // Hy2. - byp' Habs Hmain. - move=> Hne; move: (Hmain Hne); apply: TM_fun_eq; byp Habs Hmain. - foo. - foo. - foo. Qed. Definition Iconst (i : I.type) := I.bounded i && I.subset i (I.bnd (I.lower i) (I.lower i)). Lemma Iconst_true_correct i x : Iconst i = true -> contains (I.convert i) x -> x = Xlower (I.convert i). Proof. rewrite /Iconst. case E1 : I.bounded => // . have [/(I.lower_bounded_correct _) /= [F1 F2] /(I.upper_bounded_correct _) /= [F3 _]] := I.bounded_correct _ E1. intros H1 H2. have {H1} := I.subset_correct _ _ _ H2 H1. specialize (F2 (not_empty_contains _ _ H2)). rewrite F2 /=. rewrite I.bnd_correct. case E3 : x => [|r] //. elim. rewrite F1. intros H3 H4. apply f_equal. now apply Rle_antisym. exact: I.valid_lb_real. exact: I.valid_ub_real. Qed. Definition nearbyint (m : rounding_mode) (u : U) (X : I.type) (t : T) : T := let e := eval u t X X in let e1 := I.nearbyint m e in if Iconst e1 then Const (I.bnd (I.lower e1) (I.lower e1)) else let (p, i) := match m with | rnd_UP => let vm1 := I.lower im1 in let v1 := I.upper i1 in let i := I.bnd vm1 v1 in (I.div u.1 i1 i2, I.div u.1 i i2) | rnd_DN => let vm1 := I.lower im1 in let v1 := I.upper i1 in let i := I.bnd vm1 v1 in (I.div u.1 im1 i2, I.div u.1 i i2) | rnd_ZR => match I.sign_large e with | Xlt => let vm1 := I.lower im1 in let v1 := I.upper i1 in let i := I.bnd vm1 v1 in (I.div u.1 i1 i2, I.div u.1 i i2) | Xund => let vm1 := I.lower im1 in let v1 := I.upper i1 in (I.zero, I.bnd vm1 v1) | _ => let vm1 := I.lower im1 in let v1 := I.upper i1 in let i := I.bnd vm1 v1 in (I.div u.1 im1 i2, I.div u.1 i i2) end | rnd_NE => let vm1 := I.lower im1 in let v1 := I.upper i1 in let i := I.bnd vm1 v1 in (I.zero, I.div u.1 i i2) end in add u X t (Tm {|approx := Pol.polyC p; error := I.mask i e1 |}). Lemma contains_fromZ_lower_upper z1 z2 i : (-256 <= z1 <= 0)%Z -> (0 <= z2 <= 256)%Z -> contains (I.convert (I.mask (I.bnd (I.lower (I.fromZ_small z1)) (I.upper (I.fromZ_small z2))) i)) (Xreal 0). Proof. move=> z1N z2P. apply: I.mask_correct'. rewrite I.bnd_correct. refine (_ (I.fromZ_small_correct z1 _) (I.fromZ_small_correct z2 _)) ; [|lia..]. move=> Hz2 Hz1. rewrite I.lower_correct; [|now exists (IZR z1)]. rewrite I.upper_correct; [|now exists (IZR z2)]. move: Hz2 Hz1. set i1 := I.convert _. set i2 := I.convert _. assert (H1 := IZR_le _ _ (proj2 z1N)). assert (H2 := IZR_le _ _ (proj1 z2P)). case: i1 => [|[|x1] [|x2]] /=; case: i2 => [|[|x3] [|x4]] //=; lra. apply: I.valid_lb_lower; exists (IZR z1); apply I.fromZ_small_correct; lia. apply: I.valid_ub_upper; exists (IZR z2); apply I.fromZ_small_correct; lia. Qed. Lemma contains_fromZ_lower_upper_div prec z1 z2 z3 i : (-256 <= z1 <= 0)%Z -> (0 <= z2 <= 256)%Z -> (0 < z3 <= 256)%Z -> contains (I.convert (I.mask (I.div prec (I.bnd (I.lower (I.fromZ_small z1)) (I.upper (I.fromZ_small z2))) (I.fromZ_small z3)) i)) (Xreal 0). Proof. move=> z1N z2P z3P. apply: I.mask_correct'. rewrite (_ : Xreal _ = Xdiv (Xreal 0) (Xreal (IZR z3))); last first. rewrite /= /Xdiv'. case: is_zero_spec => [/eq_IZR| _]; first by lia. by congr (Xreal); rewrite /Rdiv; ring. apply I.div_correct; last by apply: I.fromZ_small_correct; lia. rewrite I.bnd_correct. refine (_ (I.fromZ_small_correct z1 _) (I.fromZ_small_correct z2 _)) ; [|lia..]. move=> Hz2 Hz1. rewrite I.lower_correct; [|now exists (IZR z1)]. rewrite I.upper_correct; [|now exists (IZR z2)]. move: Hz2 Hz1. set i1 := I.convert _. set i2 := I.convert _. assert (H1 := IZR_le _ _ (proj2 z1N)). assert (H2 := IZR_le _ _ (proj1 z2P)). case: i1 => [|[|x1] [|x2]] /=; case: i2 => [|[|x3] [|x4]] //=; lra. apply: I.valid_lb_lower; exists (IZR z1); apply I.fromZ_small_correct; lia. apply: I.valid_ub_upper; exists (IZR z2); apply I.fromZ_small_correct; lia. Qed. Theorem nearbyint_correct m u (Y : I.type) tf f : approximates Y tf f -> approximates Y (nearbyint m u Y tf) (fun x => Xnearbyint m (f x)). Proof. move=> Hf. rewrite /nearbyint. set i := I.nearbyint _ _. set i1 := I.bnd _ _. set i2 := I.bnd _ _. set i3 := I.div _ _ _. set i4 := I.div _ _ _. set i5 := I.div _ _ _. case E1 : Iconst => /=. { have H := Iconst_true_correct E1. move=> Y0; right. exists (Xlower (I.convert i)); last first. { move=> x Hx; apply: H. apply: I.nearbyint_correct. by have := eval_correct u Hf Hx. } have Hi : not_empty (I.convert i). { rewrite /i. have [y Hy] := Y0. apply (not_empty_contains _ (Xlift (Rnearbyint m) (Xbind f (Xreal y)))). apply: I.nearbyint_correct. exact: eval_correct. } rewrite I.bnd_correct /=. - rewrite -I.lower_correct //. case/andP: E1 => /I.bounded_correct [/I.lower_bounded_correct [-> _] _] _; lra. - exact: I.valid_lb_lower. - apply: I.valid_ub_real. by case/andP: E1 => /I.bounded_correct [/I.lower_bounded_correct [-> _] _] _. } apply: (@approximates_ext (fun x : R => Xadd (f x) (Xsub (Xlift (Rnearbyint m) (f x)) (f x)))). { by move=> x; case: (f x) => //= r; congr Xreal; lra. } set vv := match m with rnd_UP => _ | rnd_DN => _ | rnd_NE => _ |rnd_ZR => _ end. rewrite (surjective_pairing vv). apply: add_correct => //=. intros He. split=> //=. - move=> x Hx. have /(@I.nearbyint_correct m) := eval_correct u Hf Hx. rewrite -/i /=. case: (f x) => //= Hi _. apply: I.mask_propagate_r. by case: I.convert Hi. - move=> HY. have F1 : contains (I.convert Y) Xnan by rewrite HY. apply: I.mask_propagate_r. have /= := eval_correct u Hf F1. have := I.nearbyint_correct m (eval u tf Y Y) Xnan. case: I.convert => //=. rewrite -/i. by case: I.convert => /=. - rewrite {}/vv; case m => //=; try apply: contains_fromZ_lower_upper_div; try lia. case: I.sign_large; try apply: contains_fromZ_lower_upper_div; try lia. by apply: contains_fromZ_lower_upper; lia. - exact: contains_midpoint. move: E1. have F1 : Pol.contains_pointwise (Pol.polyC i3) (PolR.polyC (1/2)). apply: Pol.polyC_correct. rewrite (_ : Xreal _ = Xdiv (Xreal 1) (Xreal 2)). apply: I.div_correct; exact: I.fromZ_small_correct. rewrite /= /Xdiv'. now rewrite is_zero_false. have Him1 : not_empty (I.convert im1). { rewrite /im1. by exists (IZR (-1)); apply: I.fromZ_small_correct. } have Hi1 : not_empty (I.convert (TM.i1)). { rewrite /TM.i1. by exists (IZR 1); apply: I.fromZ_small_correct. } have Hlim1 : I.valid_lb (I.lower im1) by exact: I.valid_lb_lower. have Hui1 : I.valid_ub (I.upper TM.i1) by exact: I.valid_ub_upper. have F2 : contains (I.convert (I.mask i4 i)) (Xreal (- (1/2))). { apply: I.mask_correct'. rewrite (_ : Xreal (- (1 / 2)) = Xdiv (Xreal (-1)) (Xreal 2)); last first. rewrite /= /Xdiv'. by case: is_zero_spec; try lra; move=> _; congr Xreal; lra. apply: I.div_correct; last by exact: I.fromZ_small_correct. rewrite I.bnd_correct // I.lower_correct // I.upper_correct //. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. by ((do 2 case: I.convert) => //= [] [|x1] [|y1] //; try lra) => [] [|x2] [|y2] //; lra. } have F3 r : contains (I.convert (I.mask i4 i)) (Xreal (Rnearbyint rnd_UP r - r - 1 / 2)). { apply: I.mask_correct' => /=. set ir := IZR _. rewrite (_ : Xreal _ = Xdiv (Xreal (2 * (ir - r - 1/2))) (Xreal 2)); last first. rewrite /= /Xdiv'. case: is_zero_spec; try lra; move=> _. by congr Xreal; lra. apply: I.div_correct; last by exact: I.fromZ_small_correct. rewrite I.bnd_correct // /contains. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy ..]. rewrite I.lower_correct // I.upper_correct //. set iv1 := I.convert _. set iv2 := I.convert _. have HR := Rnearbyint_error_UP r. rewrite /= -/ir in HR. by case: iv1 => [|[|x1] [|x2]] /=; case: iv2 => [|[|x3] [|x4]] //=; try lra. } have F4 : Pol.contains_pointwise (Pol.polyC i5) (PolR.polyC (- (1/2))). apply: Pol.polyC_correct. rewrite (_ : Xreal _ = Xdiv (Xreal (-1)) (Xreal 2)). by apply: I.div_correct; exact: I.fromZ_small_correct. { rewrite /= /Xdiv'. by case: is_zero_spec; try lra; move=> _; congr Xreal; lra. } have F5 : contains (I.convert (I.mask i4 i)) (Xreal (1/2)). { apply: I.mask_correct'. rewrite (_ : Xreal (1 / 2) = Xdiv (Xreal 1) (Xreal 2)); last first. rewrite /= /Xdiv'. by case: is_zero_spec; try lra; move=> _; congr Xreal; lra. apply: I.div_correct; last by exact: I.fromZ_small_correct. rewrite I.bnd_correct // I.lower_correct // I.upper_correct //. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. by ((do 2 case: I.convert) => //= [] [|x1] [|y1] //; try lra) => [] [|x2] [|y2] //; lra. } have F6 r : contains (I.convert (I.mask i4 i)) (Xreal (Rnearbyint rnd_DN r - r + 1 / 2)). { apply: I.mask_correct' => /=. set ir := IZR _. rewrite (_ : Xreal _ = Xdiv (Xreal (2 * (ir - r + 1/2))) (Xreal 2)); last first. rewrite /= /Xdiv'. case: is_zero_spec; try lra; move=> _. by congr Xreal; lra. apply: I.div_correct; last by exact: I.fromZ_small_correct. rewrite I.bnd_correct //. rewrite /contains. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. rewrite I.lower_correct // I.upper_correct //. set iv1 := I.convert _. set iv2 := I.convert _. have HR := Rnearbyint_error_DN r. rewrite /= -/ir in HR. by case: iv1 => [|[|x1] [|x2]] /=; case: iv2 => [|[|x3] [|x4]] //=; try lra. } move: F2 F3 F5 F6. rewrite {}/vv {}/i1 {}/i. case: m => //=; set i := I.nearbyint _ _ => F2 F3 F5 F6 E1. - exists (PolR.polyC (1/2)) => //= y _. rewrite Rmult_0_l Rplus_0_l. case: (f y) => [|r] //=. by rewrite Rminus_0_l. - exists (PolR.polyC (-(1/2))) => //= y _. rewrite Rmult_0_l Rplus_0_l /Rminus Ropp_involutive. case: (f y) => //=. by rewrite Rplus_0_l. - case: I.sign_large (I.sign_large_correct (eval u tf Y Y)) => Hsign. - exists (PolR.polyC (-(1/2))) => //= y Cy. rewrite Rmult_0_l Rplus_0_l. case Er : (f y) => [|r] //=. by rewrite Rminus_0_l Ropp_involutive. rewrite {1}/Rminus Ropp_involutive. rewrite Raux.Ztrunc_floor //. have : f y = Xreal 0. apply: Hsign. by apply: (eval_correct u Hf Cy). by rewrite Er => [[]]; lra. - exists (PolR.polyC (1/2)) => //= y Cy. rewrite Rmult_0_l Rplus_0_l. case Er : (f y) => [|r] //=. by rewrite Rminus_0_l. rewrite Raux.Ztrunc_ceil //. have [_ /=] := Hsign _ (eval_correct u Hf Cy). by rewrite Er. - exists (PolR.polyC (-(1/2))) => //= y Cy. rewrite Rmult_0_l Rplus_0_l. case Er : (f y) => [|r] /=. by rewrite Rminus_0_l Ropp_involutive. rewrite Raux.Ztrunc_floor //. rewrite /Rminus Ropp_involutive. by apply F6. have [_ /=] := Hsign _ (eval_correct u Hf Cy). by rewrite Er. - exists (PolR.polyC 0) => //= [|y _]. apply: Pol.polyC_correct. by apply: J.zero_correct. rewrite Rmult_0_l Rplus_0_l. case Er : (f y) => [|r] /=. rewrite Rminus_0_l. apply: I.mask_correct'. rewrite I.bnd_correct // I.lower_correct // I.upper_correct //. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. by ((do 2 case: I.convert) => //= [] [|x1] [|y1] //; try lra) => [] [|x2] [|y2] //; lra. apply: I.mask_correct'. rewrite I.bnd_correct //. rewrite /contains. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. rewrite I.lower_correct // I.upper_correct //. set iv1 := I.convert _. set iv2 := I.convert _. have HR := Rnearbyint_error_ZR r. rewrite /= in HR. by case: iv1 => [|[|x1] [|x2]] /=; case: iv2 => [|[|x3] [|x4]] //=; try lra. exists (PolR.polyC 0) => //= [|y Cy]. apply: Pol.polyC_correct; exact: J.zero_correct. rewrite Rmult_0_l Rplus_0_r Rminus_0_r. case: (f y) => /=. apply: I.mask_correct'. rewrite (_ : Xreal _ = Xdiv (Xreal 0) (Xreal 2)); last first. rewrite /= /Xdiv'. by case: is_zero_spec; try lra; move=> _; congr Xreal; lra. apply: I.div_correct; last by exact: I.fromZ_small_correct. rewrite I.bnd_correct // I.lower_correct // I.upper_correct //. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. by ((do 2 case: I.convert) => //= [] [|x1] [|y1] //; try lra) => [] [|x2] [|y2] //; lra. move=> r. apply: I.mask_correct'. set ir := IZR _. rewrite (_ : Xreal _ = Xdiv (Xreal (2 * (ir - r))) (Xreal 2)); last first. rewrite /= /Xdiv'. case: is_zero_spec; try lra; move=> _. by congr Xreal; lra. apply: I.div_correct; last by exact: I.fromZ_small_correct. rewrite I.bnd_correct //. rewrite /contains. refine (_ (I.fromZ_small_correct (-1) _) (I.fromZ_small_correct 1 _)) ; [|easy..]. rewrite I.lower_correct // I.upper_correct //. set iv1 := I.convert _. set iv2 := I.convert _. have HR := Rnearbyint_error_NE r. rewrite /= -/ir in HR. by case: iv1 => [|[|x1] [|x2]] /=; case: iv2 => [|[|x3] [|x4]] //=; try lra. Qed. Definition error_flt (u : U) (m : rounding_mode) (emin : Z) (prec : positive) (X : I.type) (t : T) : T := let e := eval u t X X in let err := I.error_flt u.1 m emin prec e in Tm (TM_any u.1 err X 0). Theorem error_flt_correct u m e p (Y : I.type) tf f : approximates Y tf f -> approximates Y (error_flt u m e p Y tf) (fun x => Xerror_flt m e p (f x)). Proof. move=> Hf. rewrite /error_flt. set i := I.error_flt _ _ _ _. intros He x0. apply TM_any_correct. now apply contains_midpoint. intros x. destruct (f x) eqn:Hfx; move=> Hx /=. - rewrite {}/i contains_Xnan. apply J.error_flt_propagate. apply (eval_correct u) in Hf. apply Hf in Hx. simpl in Hx. rewrite Hfx in Hx. now apply contains_Xnan. - generalize (@eval_correct u Y tf f). move=> Haux. apply Haux in Hf. unfold I.extension in Hf. apply Hf in Hx. simpl in Hx. unfold Basic.round_flt. generalize (I.error_flt_correct u.1 m e p (eval u tf Y Y) (f x)). rewrite -/i /= {}/Xerror_flt {}/error_flt {}/Xbind Hfx. rewrite Hfx in Hx. now intros; revert Hx. Qed. Definition round_flt (u : U) (m : rounding_mode) (emin : Z) (prec : positive) (X : I.type) (t : T) : T := add u X t (error_flt u m emin prec X t). Theorem round_flt_correct u m e p (Y : I.type) tf f : approximates Y tf f -> approximates Y (round_flt u m e p Y tf) (fun x => Xround_flt m e p (f x)). Proof. move=> Hf. rewrite /round_flt. apply: (@approximates_ext (fun x : R => Xadd (f x) (Xerror_flt m e p (f x)))). { move=> x. case: (f x) => //= xr. congr Xreal; rewrite /Basic.error_flt /Basic.round_flt. ring. } apply: add_correct => //=. exact: error_flt_correct. Qed. Definition error_fix (u : U) (m : rounding_mode) (emin : Z) (X : I.type) (t : T) : T := let e := eval u t X X in let err := I.error_fix u.1 m emin e in Tm (TM_any u.1 err X 0). Theorem error_fix_correct u m e (Y : I.type) tf f : approximates Y tf f -> approximates Y (error_fix u m e Y tf) (fun x => Xerror_fix m e (f x)). Proof. move=> Hf. rewrite /error_fix. set i := I.error_fix _ _ _. intros He x0. apply TM_any_correct. now apply contains_midpoint. intros x. destruct (f x) eqn:Hfx; move=> Hx /=. - rewrite {}/i contains_Xnan. apply J.error_fix_propagate. apply (eval_correct u) in Hf. apply Hf in Hx. simpl in Hx. rewrite Hfx in Hx. now apply contains_Xnan. - generalize (@eval_correct u Y tf f). move=> Haux. apply Haux in Hf. unfold I.extension in Hf. apply Hf in Hx. simpl in Hx. unfold Basic.round_fix. generalize (I.error_fix_correct u.1 m e (eval u tf Y Y) (f x)). rewrite -/i /= {}/Xerror_fix {}/error_fix {}/Xbind Hfx. rewrite Hfx in Hx. now intros; revert Hx. Qed. Definition round_fix (u : U) (m : rounding_mode) (emin : Z) (X : I.type) (t : T) : T := add u X t (error_fix u m emin X t). Theorem round_fix_correct u m e (Y : I.type) tf f : approximates Y tf f -> approximates Y (round_fix u m e Y tf) (fun x => Xround_fix m e (f x)). Proof. move=> Hf. rewrite /round_fix. apply: (@approximates_ext (fun x : R => Xadd (f x) (Xerror_fix m e (f x)))). { move=> x. case: (f x) => //= xr. congr Xreal; rewrite /Basic.error_fix /Basic.round_fix. ring. } apply: add_correct => //=. exact: error_fix_correct. Qed. (** ** Generic implementation of basic functions *) Definition fun_gen (fi : I.precision -> I.type -> I.type) (ftm : I.precision -> TM_type) (u : U) (X : I.type) (t : T) : T := match t with | Const c => Const (fi u.1 c) | Var => let X0 := J.midpoint X in Tm (ftm u.1 X0 X u.2) | Tm tm => let X0 := J.midpoint X in Tm (TM_comp u.1 (ftm u.1) tm X0 X u.2) end. Lemma fun_gen_correct (fi : I.precision -> I.type -> I.type) (ftm : I.precision -> TM_type) (fx : R -> ExtendedR) (ft := fun_gen fi ftm) : (forall prec : I.precision, I.extension (Xbind fx) (fi prec)) -> (forall prec X0 X n, tmsize (ftm prec X0 X n) = n.+1) -> (forall prec x0 X0 X n, subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (ftm prec X0 X n) fx) -> forall (u : U) (X : I.type) (tf : T) (f : R -> ExtendedR), approximates X tf f -> approximates X (ft u X tf) (fun x => Xbind fx (f x)). Proof. move=> Hext Hsiz Hvalid u X [c| |tm] f Hmain Hne. - destruct (Hmain Hne) as [Hf|[y Hy1 Hy2]]. left. { apply contains_Xnan. apply (Hext u.1 c (Xbind fx Xnan)). now apply contains_Xnan. } right. exists (Xbind fx y); first exact: Hext. by move=> x Hx; rewrite /= Hy2. - apply: (@TM_fun_eq fx). by move=> *; rewrite Hmain. apply: Hvalid. exact: J.subset_midpoint. exact: J.contains_midpoint. - move/(_ Hne) in Hmain. have [Hdef Hnai Hzero Hsubset Htm] := Hmain. apply (TM_comp_correct u.1) =>//. exact: J.contains_midpoint. move=> *; exact: Hvalid. Qed. (* Definition prim (u : U) (X : I.type) (t : T) : T := match t with | Dummy => Dummy | Const c => let X0 := Imid X in Tm (TM_integral u.1 X0 X (TM_cst u.1 c X0 X u.2)) | Var => let X0 := Imid X in Tm (TM_integral u.1 X0 X (TM_var u.1 X0 X u.2)) | Tm tm => let X0 := Imid X in Tm (TM_integral u.1 X0 X tm) end. *) (* Definition prim (u : U) (X X1 Y1 : I.type) (t : T) : T := if I.subset X1 X then let X0 := Imid X in let tm := match t with | Dummy => TM_any u.1 I.nai X u.2 | Const c => TM_cst c | Var => TM_var X0 | Tm tm => tm end in let tm0 := TM_integral u.1 X0 X tm in let c := I.add u.1 Y1 (I.neg (Bnd.ComputeBound u.1 (approx tm0) X1)) in Tm (RPA (Pol.set_nth (approx tm0) 0 c) (I.add u.1 (error tm0) (error tm0))) else Tm (TM_any u.1 I.nai X u.2). Conjecture prim_correct : forall u (X X1 Y1 : I.type) tf f f0 x1 y1, contains (I.convert X1) (Xreal x1) -> contains (I.convert Y1) (Xreal y1) -> approximates X tf f -> (forall r : R, f0 r = toR_fun f r) -> approximates X (prim u X X1 Y1 tf) (fun x => match x with | Xnan => Xnan | Xreal r => Xreal (RInt f0 x1 r + y1) end). *) Definition inv := Eval hnf in fun_gen I.inv TM_inv. Theorem inv_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (inv u Y tf) (fun x => Xinv (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.inv_correct. - exact: size_TM_inv. - exact: TM_inv_correct. Qed. Definition sqrt := Eval hnf in fun_gen I.sqrt TM_sqrt. Theorem sqrt_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (sqrt u Y tf) (fun x => Xsqrt (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.sqrt_correct. - exact: size_TM_sqrt. - exact: TM_sqrt_correct. Qed. Definition exp := Eval hnf in fun_gen I.exp TM_exp. Theorem exp_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (exp u Y tf) (fun x => Xexp (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.exp_correct. - exact: size_TM_exp. - exact: TM_exp_correct. Qed. Definition ln := Eval hnf in fun_gen I.ln TM_ln. Theorem ln_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (ln u Y tf) (fun x => Xln (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.ln_correct. - exact: size_TM_ln. - exact: TM_ln_correct. Qed. Definition cos := Eval hnf in fun_gen I.cos TM_cos. Theorem cos_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (cos u Y tf) (fun x => Xcos (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.cos_correct. - exact: size_TM_cos. - exact: TM_cos_correct. Qed. Definition sin := Eval hnf in fun_gen I.sin TM_sin. Theorem sin_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (sin u Y tf) (fun x => Xsin (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.sin_correct. - exact: size_TM_sin. - exact: TM_sin_correct. Qed. Definition tan := Eval hnf in fun_gen I.tan TM_tan. Theorem tan_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (tan u Y tf) (fun x => Xtan (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.tan_correct. - exact: size_TM_tan. - exact: TM_tan_correct. Qed. Definition atan := Eval hnf in fun_gen I.atan TM_atan. Theorem atan_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (atan u Y tf) (fun x => Xatan (f x)). Proof. apply: fun_gen_correct =>//. - exact: I.atan_correct. - exact: size_TM_atan. - exact: TM_atan_correct. Qed. Definition power_int p := Eval cbv delta[fun_gen] beta in match p with (*| 0%Z => fun u xi t => Const (I.fromZ 1) *) | 1%Z => fun u xi t => t | _ => fun_gen (fun prec x => I.power_int prec x p) (fun prec => TM_power_int prec p) end. Theorem power_int_correct : forall (p : Z) u (Y : I.type) tf f, approximates Y tf f -> approximates Y (power_int p u Y tf) (fun x => Xbind (fun y => Xpower_int (Xreal y) p) (f x)). Proof. move=> p u Y tf f Hmain. have [Hp|Hp] := Z.eq_dec p 1%Z. (* . *) rewrite Hp. apply (@approximates_ext f)=>//. move=> x; rewrite /Xinv. case: (f x) =>[//|r]. by rewrite /= Rmult_1_r. (* . *) case: p Hp =>[|p'|p']=>//; (try case: p'=>[p''|p''|]) =>// H; apply: (fun_gen_correct (fi := fun prec x => I.power_int prec x _) (ftm := fun prec => TM_power_int prec _) (fx := fun x => Xpower_int (Xreal x) _)) =>//; try (by move=> *; apply: I.power_int_correct); try (by move=> *; rewrite /tmsize size_TM_power_int); by move=> *; apply: TM_power_int_correct. Qed. Definition sqr := power_int 2. Theorem sqr_correct : forall u (Y : I.type) tf f, approximates Y tf f -> approximates Y (sqr u Y tf) (fun x => Xsqr (f x)). Proof. move=> u Y tf f Hf. apply: (@approximates_ext (fun x => Xpower_int (f x) 2%Z)). move=> x; rewrite /Xpower_int /Xsqr. case: (f x) =>[//|r]. by rewrite /= Rmult_1_r. exact: power_int_correct. Qed. End TM. interval-4.11.1/src/Poly/Taylor_model_sharp.v000066400000000000000000003433251470547631300211760ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Psatz Reals. From Flocq Require Import Raux. From Coquelicot Require Import Coquelicot. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop. Require Import Stdlib. Require Import MathComp. Require Import Coquelicot. Require Import Xreal. Require Import Interval. Require Import Basic. Require Import Xreal_derive. Require Import Interval_compl. Require Import Datatypes. Require Import Taylor_poly. Require Import Basic_rec. Require Import Bound. (********************************************************************) (** This theory implements Taylor models with interval polynomials for univariate real-valued functions. The implemented algorithms rely on the so-called Zumkeller's technique, which allows one to obtain sharp enclosures of the approximation error, when it detects that the Taylor-Lagrange remainder of the elementary function at stake is monotonic over the interval under study. *) (********************************************************************) Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Local Open Scope nat_scope. (** Rigorous Polynomial Approximation structure *) Record rpa {pol int : Type} : Type := RPA { approx : pol ; error : int }. Module TR := TaylorPoly FullR PolR. Module TaylorModel (I : IntervalOps) (Pol : PolyIntOps I) (Bnd : PolyBound I Pol). Import Pol.Notations. Import PolR.Notations. Local Open Scope ipoly_scope. Module Export Aux := IntervalAux I. Module Import TI := TaylorPoly Pol.Int Pol. Module Import BndThm := PolyBoundThm I Pol Bnd. Module J := IntervalExt I. (* POSSIBLE UTF-8 NOTATION Notation "X ∋ x" := (contains X x) (at level 70). Notation "X ⊂ Y" := (I.subset_ X Y) (at level 70). *) Ltac step_xr xr := match goal with [ |- contains ?i ?g ] => rewrite -(_ : xr = g) end. Ltac step_r r := match goal with [ |- contains ?i (Xreal ?g) ] => rewrite -(_ : r = g) end. Ltac step_xi xi := match goal with [ |- contains ?g ?xr ] => rewrite -(_ : xi = g) end. Ltac step_i i := match goal with [ |- contains (I.convert ?g) ?xr ] => rewrite -(_ : i = g) end. (* Erik: Some lemmas could be generalized from [I.type] to [interval]. *) Notation rpa := (@rpa Pol.T I.type). Section PrecArgument. (** For greater convenience, set the precision as a section variable. Note that this will not hinder any dynamic-change of the precision inside the functions that are defined or called below. *) Variable prec : I.precision. Section TaylorModel. Variable M : rpa. Variable Tcoeffs : I.type -> nat -> Pol.T. (** For complexity reasons, [Tcoeffs] must return more than one coefficient. *) (** The generic functions [TLrem]/[Ztech] are intended to ease the computation of the interval remainder for basic functions. *) Definition TLrem (X0 X : I.type) n := let N := S n in let NthCoeff := Pol.nth (Tcoeffs X N) N in let NthPower := I.power_int prec (I.sub prec X X0) (Z_of_nat N) (* improvable *) in I.mul prec NthCoeff NthPower. (** The first argument of [Ztech] will be instantiated with [Tcoeffs X0 n]. *) Definition Ztech (P : Pol.T) F (X0 X : I.type) n := let N := S n in let NthCoeff := Pol.nth (Tcoeffs X N) N in if isNNegOrNPos NthCoeff && I.bounded X then let a := I.lower X in let b := I.upper X in let A := I.bnd a a in let B := I.bnd b b in (* If need be, we could replace Pol.horner with Bnd.ComputeBound *) let Da := I.sub prec (F A) (Pol.horner prec P (I.sub prec A X0)) in let Db := I.sub prec (F B) (Pol.horner prec P (I.sub prec B X0)) in let Dx0 := I.sub prec (F X0) (Pol.nth P 0) (* :-D *) in I.join (I.join Da Db) Dx0 else let NthPower := I.power_int prec (I.sub prec X X0) (Z_of_nat N) in I.mul prec NthCoeff NthPower. End TaylorModel. (** Note that Zumkeller's technique is not necessary for [TM_cst] & [TM_var]. *) Definition TM_cst (X c : I.type) : rpa := RPA (Pol.polyC c) (I.mask (I.mask I.zero X) c). Definition TM_var (X X0 : I.type) := RPA (Pol.set_nth Pol.polyX 0 X0) (I.mask I.zero X). Definition TM_exp (X0 X : I.type) (n : nat) : rpa := (** Note that this let-in is essential in call-by-value context. *) let P := (T_exp prec X0 n) in RPA P (Ztech (T_exp prec) P (I.exp prec) X0 X n). Definition TM_sin (X0 X : I.type) (n : nat) : rpa := let P := (T_sin prec X0 n) in RPA P (Ztech (T_sin prec) P (I.sin prec) X0 X n). Definition TM_cos (X0 X : I.type) (n : nat) : rpa := let P := (T_cos prec X0 n) in RPA P (Ztech (T_cos prec) P (I.cos prec) X0 X n). Definition TM_atan (X0 X : I.type) (n : nat) : rpa := let P := (T_atan prec X0 n) in RPA P (Ztech (T_atan prec) P (I.atan prec) X0 X n). Definition TM_add (Mf Mg : rpa) : rpa := RPA (Pol.add prec (approx Mf) (approx Mg)) (I.add prec (error Mf) (error Mg)). Definition TM_opp (M : rpa) : rpa := RPA (Pol.opp (approx M)) (I.neg (error M)). Definition TM_sub (Mf Mg : rpa) : rpa := RPA (Pol.sub prec (approx Mf) (approx Mg)) (I.sub prec (error Mf) (error Mg)). Definition i_validTM (x0 : R) (X : interval) (M : rpa) (xf : R -> ExtendedR) := [/\ forall x : R, contains X (Xreal x) -> xf x = Xnan -> I.convert (error M) = IInan, X = IInan -> I.convert (error M) = IInan, contains (I.convert (error M)) (Xreal 0), contains X (Xreal x0) & exists2 Q, approx M >:: Q & forall x, contains X (Xreal x) -> error M >: proj_val (xf x) - Q.[x - x0]]. Lemma TM_fun_eq f g (x0 : R) (X : interval) TMf : (forall x, contains X (Xreal x) -> f x = g x) -> i_validTM x0 X TMf f -> i_validTM x0 X TMf g. Proof. move=> Hfg [Hdom Hnai H0 Hsubs Hmain]. split=>//. move=> x Hx Dx. apply: (Hdom x) =>//. by rewrite Hfg. have [Q HQ Hf] := Hmain. exists Q =>//. move=> x Hx. rewrite -Hfg //. exact: Hf. Qed. Section TM_integral. Local Open Scope R_scope. Lemma Rpol_continuous p (x : R) : continuous (PolR.horner tt p) x. Proof. have Hext : forall t, foldr (fun a b => (b * t) + a) 0 (PolR.toSeq p) = PolR.horner tt p t => [t|]. by rewrite PolR.horner_seq. apply: (continuous_ext _ _ _ Hext). (* implicit parameters? *) elim: (PolR.toSeq p) => [|a q HI] /=. - exact: continuous_const. - apply: continuous_plus; last by exact: continuous_const. by apply: continuous_mult => //; exact: continuous_id. Qed. Lemma Rpol_integrable p (x1 x2 : R) : ex_RInt (PolR.horner tt p) x1 x2. Proof. apply: ex_RInt_continuous => x _. exact: Rpol_continuous. Qed. (* Check Derive_sum_n. *) Lemma ex_derive_big I (s : seq I) : forall (f : I -> R -> R) (x : R), (forall k : I, ex_derive (f k) x) -> ex_derive (fun x0 : Rdefinitions.R => \big[Rplus/0]_(i <- s) f i x0) x. Proof. move => f x Hf. elim: s => [ | a b Hrec] => /= . apply: (ex_derive_ext (fun x0 => 0)) => [t|]; first by rewrite big_nil. apply: ex_derive_const. apply: (ex_derive_ext (fun t => f a t + \big[Rplus/0]_(j <- b) f j t)). by move => t; rewrite big_cons. apply: ex_derive_plus. by apply: Hf. by apply: Hrec. Qed. Lemma derive_big I (s : seq I) : forall (f : I -> R -> R) (x : R), (forall k : I, ex_derive (f k) x) -> Derive (fun y : Rdefinitions.R => \big[Rplus/0]_(i <- s) (f i y)) x = \big[(fun _ : unit => Rplus) tt/0]_(i <- s) ((Derive (f i)) x). Proof. move => f x Hf. elim: s => [ | a b Hrec] => /= . - rewrite (Derive_ext _ (fun x0 => 0)) => [|t]. by rewrite big_nil Derive_const. by rewrite big_nil. - rewrite (Derive_ext _ (fun t => f a t + \big[Rplus/0]_(j <- b) f j t)). + rewrite Derive_plus ?big_cons. * congr Rplus. by rewrite Hrec. * by apply: Hf. * by apply: ex_derive_big. + move => t. by rewrite big_cons. Qed. Lemma horner_primitive (c : R) (p : PolR.T) (t : R): PolR.horner tt (PolR.primitive tt c p) t = c + \big[Rplus/0]_(0 <= i < (size p)) (PolR.nth (PolR.primitive tt c p) i.+1 * powerRZ t (Z.of_nat i.+1)). Proof. rewrite PolR.hornerE PolR.size_primitive big_nat_recl //. congr (_ + _); first by rewrite /= Rmult_1_r. by apply: eq_big_nat => i Hi; rewrite pow_powerRZ. Qed. Lemma Rpol_derive p (c : R) (x : R) : Derive (PolR.horner tt (PolR.primitive tt c p)) x = PolR.horner tt p x. Proof. have derMonom : forall k : (* ordinal_finType (size p), *) nat, ex_derive (fun y : R => PolR.nth (PolR.primitive tt c p) k.+1 * powerRZ y (Z.of_nat k.+1)) x. move => k. apply: ex_derive_mult. apply: ex_derive_const. apply: (ex_derive_ext (fun x => x ^ (k.+1))). by move => t; rewrite -pow_powerRZ. apply: ex_derive_pow; apply: ex_derive_id. rewrite PolR.hornerE. rewrite (Derive_ext _ _ _ (horner_primitive c p)). (* visibily there lack some implicit parameters *) set X := RHS. have -> : X = 0 + X by rewrite Rplus_0_l. rewrite Derive_plus; [ |by apply: ex_derive_const |]. - congr (_ + _); first by apply: Derive_const. rewrite derive_big. rewrite [LHS]big_nat_cond /X [RHS]big_nat_cond. apply: eq_bigr => i; rewrite andbT => Hi. rewrite Derive_mult. have -> : Derive (fun _ : R => PolR.nth (PolR.primitive tt c p) i.+1) x = 0. by apply: Derive_const. ring_simplify. rewrite (Derive_ext _ (fun x => x ^ (i.+1))); last first. by move => t; rewrite -pow_powerRZ. rewrite PolR.nth_primitive ifF /PolR.int_coeff => //. rewrite Derive_pow ?Derive_id -?pred_Sn. field. apply: not_0_INR => // . exact: ex_derive_id. by apply/negbTE; rewrite -leqNgt; case/andP: Hi. apply: ex_derive_const. apply: (ex_derive_ext (fun x => x ^ (i.+1))). by move => t; rewrite -pow_powerRZ. apply: ex_derive_pow; apply: ex_derive_id. by []. by apply: ex_derive_big. Qed. Lemma Rpol_integral_0 (x1 x2 : R) (p : PolR.T) : RInt (PolR.horner tt p) x1 x2 = PolR.horner tt (PolR.primitive tt 0 p) x2 - PolR.horner tt (PolR.primitive tt 0 p) x1. Proof. apply is_RInt_unique. apply: (is_RInt_ext (Derive (PolR.horner tt (PolR.primitive tt R0 p)))). by move => x _; rewrite Rpol_derive. apply: is_RInt_derive. move => x _; apply: Derive_correct; apply: PolR.ex_derive_horner. move => x _. apply: (continuous_ext (PolR.horner tt p) ) => [t|] . by rewrite Rpol_derive. exact: Rpol_continuous. Qed. Local Notation Isub := (I.sub prec). Local Notation Imul := (I.mul prec). Local Notation Iadd := (I.add prec). Variables (X0 X : I.type). Variable xF : R -> ExtendedR. Let f := fun x => proj_val (xF x). Let iX0 := I.convert X0. Let iX := I.convert X. (* Hypothesis extF : extension f1 f. *) (* to correct *) Hypothesis f_int : forall x x0 : R, contains iX (Xreal x) -> contains iX0 (Xreal x0) -> ex_RInt f x0 x. Hypothesis x_Def : forall x : R, contains iX (Xreal x) -> xF x <> Xnan. Variable Mf : rpa. (* here we define a function which takes a Taylor Model for f and returns a Taylor model for the primitive of f which evaluates to *) Definition TM_integral_poly := Pol.primitive prec (I.zero) (approx Mf). Definition TM_integral_error := Imul (Isub X X0) (error Mf). Local Open Scope R_scope. Lemma pol_int_sub pol x1 x2 x3 : ex_RInt (fun y : R => pol.[y - x3]) x1 x2. Proof. have -> : x1 = x1 - x3 + x3 by ring. have -> : x2 = x2 - x3 + x3 by ring. apply: ex_RInt_translation_sub. exact: Rpol_integrable. Qed. (** the following section is now concerned with computing just one integral from a to b, for the "interval" tactic *) Section NumericIntegration. Local Open Scope R_scope. Variables (x0 a b : R) (ia ib : I.type). Hypothesis Hx0 : contains iX0 (Xreal x0). Hypothesis Ha : contains iX (Xreal a). Hypothesis Hb : contains iX (Xreal b). Hypothesis Hia : contains (I.convert ia) (Xreal a). Hypothesis Hib : contains (I.convert ib) (Xreal b). Hypothesis f_int_numeric : ex_RInt f a b. Definition polIntegral := Isub (Pol.horner prec TM_integral_poly (Isub ib X0)) (Pol.horner prec TM_integral_poly (Isub ia X0)). Definition integralError := Imul (Isub ib ia) (error Mf). Definition integralEnclosure := Iadd polIntegral integralError. Lemma integralEnclosure_correct : i_validTM x0 iX Mf xF -> contains (I.convert integralEnclosure) (Xreal (RInt f a b)). Proof. move => [Hdef Hnai Hcontains0 HX0X H]. have {H} [q HMfq Herror] := H. have HI: ex_RInt (fun x => q.[x - x0]) a b by exact: pol_int_sub. have ->: RInt f a b = RInt (fun x => q.[x - x0]) a b + RInt (fun x => f x - q.[x - x0]) a b. rewrite RInt_minus //. by rewrite -[minus _ _]/(Rplus _ (Ropp _)) Rplus_comm Rplus_assoc Rplus_opp_l Rplus_0_r. apply: J.add_correct. rewrite RInt_translation_sub. rewrite Rpol_integral_0. have H: forall x xi, xi >: x -> Pol.horner prec TM_integral_poly (Isub xi X0) >: (PolR.primitive tt 0 q).[x - x0]. move => x xi Hx. apply: Pol.horner_correct. exact: Pol.primitive_correct J.zero_correct HMfq. exact: J.sub_correct. apply: J.sub_correct ; exact: H. eapply ex_RInt_ext. 2: apply: ex_RInt_translation_add HI. intros t. by rewrite /= /Rminus Rplus_assoc Rplus_opp_r Rplus_0_r. apply: J.contains_RInt => //. exact: ex_RInt_minus. move => x Hx. apply: Herror. apply: contains_connected Hx. now apply Rmin_case. now apply Rmax_case. Qed. End NumericIntegration. Lemma contains_interval_float_integral (p : PolR.T) : approx Mf >:: p -> TM_integral_poly >:: (PolR.primitive tt 0%R p). Proof. move=> Hp; rewrite /TM_integral_poly. by apply: Pol.primitive_correct; first exact: J.zero_correct. Qed. Lemma TM_integral_error_0 (x0 : R) : contains iX0 (Xreal x0) -> i_validTM x0 iX Mf xF -> contains (I.convert TM_integral_error) (Xreal 0). Proof. move => Hx0X0 [_ _ ErrMf0 HX0X HPol]. case: HPol => [p Hcontains _]. replace 0 with ((x0 - x0) * 0) by ring. apply: J.mul_correct ErrMf0. apply: J.sub_correct (Hx0X0). exact: HX0X. Qed. Definition TM_integral := RPA TM_integral_poly TM_integral_error. Lemma TM_integral_correct (x0 : Rdefinitions.R) : contains iX0 (Xreal x0) -> i_validTM x0 iX Mf xF -> i_validTM x0 iX TM_integral (fun x => Xreal (RInt f x0 x)). Proof. move => Hx0X0 [Hdef Hnai ErrMf0 HX0X HPol] /= ; split =>//. rewrite /TM_integral /TM_integral_error /= /iX => H. by rewrite I.mul_propagate_l // I.sub_propagate_l. by apply: (@TM_integral_error_0 _ Hx0X0). case: HPol => [p Hcontains H3]. exists (PolR.primitive tt 0 p). - by apply: Pol.primitive_correct; first exact: J.zero_correct. - move => x hxX. have -> : (PolR.primitive tt 0 p).[x - x0] = RInt (fun t => p.[t - x0]) x0 x. + rewrite RInt_translation_sub. have -> : (PolR.primitive tt 0 p).[x - x0] = (PolR.primitive tt 0 p).[x - x0] - (PolR.primitive tt 0 p).[x0 - x0]. * rewrite Rminus_eq_0. set t0 := (X in (_ = _ - X)). have->: t0 = 0; last by rewrite Rminus_0_r. rewrite /t0 PolR.hornerE PolR.size_primitive big1 // => i _. rewrite PolR.nth_primitive. case: ifP; first by rewrite Rmult_0_l. rewrite /PolR.int_coeff; case: i; first by rewrite Rmult_0_l. by move=> *; rewrite /= Rmult_0_l Rmult_0_r. by rewrite Rpol_integral_0. exact: Rpol_integrable. set i1 := (X in (X - _)). set i2 := (X in (_ - X)). have -> : i1 - i2 = RInt (fun t => f t - p.[t - x0]) x0 x. apply sym_eq. apply is_RInt_unique. apply: is_RInt_minus ; apply RInt_correct. + by apply: f_int. + have {2}-> : x0 = (0 + x0) by ring. have -> : x = (x - x0) + x0 by ring. apply: ex_RInt_translation_sub. exact: Rpol_integrable. rewrite /TM_integral_error {i1 i2}. apply: J.contains_RInt => //. apply: ex_RInt_minus. exact: f_int. exact: pol_int_sub. move => x2 Hx2. apply: H3. apply: contains_connected Hx2. now apply Rmin_case. now apply Rmax_case. Qed. End TM_integral. Section Const_prelim. Definition is_const (f : R -> ExtendedR) (X c : interval) : Prop := exists2 y : ExtendedR, contains c y & forall x : R, contains X (Xreal x) -> f x = y. Lemma is_const_ext (f g : R -> ExtendedR) (X c : interval) : (forall x : R, contains X (Xreal x) -> f x = g x) -> is_const f X c -> is_const g X c. Proof. move=> Hmain [a Ha1 Ha2]. exists a =>//. move=> x Hx. rewrite -Hmain //. exact: Ha2. Qed. Corollary is_const_ext_weak (f g : R -> ExtendedR) (X c : interval) : (forall x : R, f x = g x) -> is_const f X c -> is_const g X c. Proof. move=> Hmain. apply: is_const_ext. move=> x _; exact: Hmain. Qed. End Const_prelim. Section GenericProof. (** Generic proof for [TLrem] and [Ztech]. *) Variable xf : R -> ExtendedR. Variable P : R -> nat -> PolR.T. Let f0 := fun x => proj_val (xf x). Let Dn n := Derive_n f0 n. Let Rdelta (n : nat) (x0 x : R) := (f0 x - (P x0 n).[x - x0])%R. (** We now define the derivative of [Rdelta n x0] *) Let Rdelta' (n : nat) (x0 x : R) := (Dn 1 x - (PolR.deriv tt (P x0 n)).[x - x0])%R. Section aux. Variable dom : R -> Prop. Hypothesis Hdom : connected dom. Lemma Rmonot_contains (g : R -> R) : Rmonot dom g -> forall (x y z : R), dom x -> dom y -> intvl x y z -> intvl (g x) (g y) (g z) \/ intvl (g y) (g x) (g z). Proof. move=> Hmonot x y z Hx Hy Hz. have Dz: dom z by exact: Hdom Hz. case: Hmonot; rewrite /Rincr /Rdecr =>H; [left|right]; split; apply: H =>//; move: Hz; rewrite /intvl /=; by move=> [H1 H2]. Qed. Lemma upper_Rpos_over (c x0 : R) (nm1 : nat) (n := nm1.+1) : dom x0 -> Rpos_over dom (Dn n.+1) -> forall x : R, (x0 <= x)%R -> dom x -> intvl x x0 c \/ intvl x0 x c -> (0 <= (Dn n.+1 c) / INR (fact n) * (x - x0) ^ n)%R. Proof. move=> Hx0 Hsign x Hx Dx [Hc|Hc]. have ->: x = x0. by move: Hx Hc; rewrite /intvl; lra. by rewrite Rminus_diag_eq // pow_ne_zero // Rmult_0_r; auto with real. apply: Rmult_le_pos_pos. apply: Rdiv_pos_compat. apply: Hsign. exact: Hdom Hc. exact: INR_fact_lt_0. apply: pow_le. now apply Rle_0_minus. Qed. Lemma upper_Rneg_over (c x0 : R) (nm1 : nat) (n := nm1.+1) : dom x0 -> Rneg_over dom (Dn n.+1) -> forall x : R, (x0 <= x)%R -> dom x -> intvl x x0 c \/ intvl x0 x c -> (Dn n.+1 c / INR (fact n) * (x - x0) ^ n <= 0)%R. Proof. move=> Hx0 Hsign x Hx Dx [Hc|Hc]. have ->: x = x0. by move: Hx Hc; rewrite /intvl; lra. by rewrite Rminus_diag_eq // pow_ne_zero // Rmult_0_r; auto with real. apply: Rmult_le_neg_pos. apply: Rdiv_neg_compat. apply: Hsign. exact: Hdom Hc. exact: INR_fact_lt_0. apply: pow_le. now apply Rle_0_minus. Qed. Lemma pow_Rabs_sign (r : R) (n : nat) : (r ^ n = powerRZ (if Rle_bool R0 r then 1 else -1) (Z_of_nat n) * (Rabs r) ^ n)%R. Proof. elim: n =>[|n /= ->]; first by rewrite Rmult_1_l. case: Rle_bool_spec => Hr. rewrite powerRZ_R1 Rmult_1_l SuccNat2Pos.id_succ. by rewrite pow1 Rabs_pos_eq // Rmult_1_l. by rewrite {-1 3}Rabs_left // SuccNat2Pos.id_succ -pow_powerRZ /=; ring. Qed. Lemma powerRZ_1_even (k : Z) : (0 <= powerRZ (-1) (2 * k))%R. Proof. by case: k =>[|p|p] /=; rewrite ?Pos2Nat.inj_xO ?pow_1_even; auto with real. Qed. Lemma ZEven_pow_le (r : R) (n : nat) : Z.Even (Z_of_nat n) -> (0 <= r ^ n)%R. Proof. move=> [k Hk]. rewrite pow_Rabs_sign; case: Rle_bool_spec =>[_|Hr]. rewrite powerRZ_R1 Rmult_1_l. apply: pow_le. exact: Rabs_pos. rewrite Hk. apply: Rmult_le_pos_pos; first exact: powerRZ_1_even. by apply: pow_le; exact: Rabs_pos. Qed. Lemma Ropp_le_0 (x : R) : (0 <= x -> - x <= 0)%R. Proof. by move=> ?; auto with real. Qed. Lemma ZOdd_pow_le (r : R) (n : nat) : Z.Odd (Z_of_nat n) -> (r <= 0 -> r ^ n <= 0)%R. Proof. move=> [k Hk] Hneg. rewrite pow_Rabs_sign; case: Rle_bool_spec =>[Hr|Hr]. have->: r = R0 by psatzl R. rewrite Rabs_R0 pow_ne_zero ?Rmult_0_r; first by auto with real. by lia. (* odd => nonzero *) rewrite Hk. apply: Rmult_le_neg_pos; last by apply: pow_le; exact: Rabs_pos. rewrite powerRZ_add; discrR. apply: Rmult_le_pos_neg; first exact: powerRZ_1_even. by rewrite /= Rmult_1_r; apply: Ropp_le_0; apply: Rle_0_1. Qed. Lemma lower_even_Rpos_over (c x0 : R) (nm1 : nat) (n := nm1.+1) : Z.Even (Z_of_nat n) -> dom x0 -> Rpos_over dom (Dn n.+1) -> forall x : R, (x <= x0)%R -> dom x -> intvl x x0 c \/ intvl x0 x c -> (0 <= Dn n.+1 c / INR (fact n) * (x - x0) ^ n)%R. Proof. move=> Hev Hx0 Hsign x Hx Dx [Hc|Hc]; last first. have ->: x = x0 by move: Hx Hc; rewrite /intvl; lra. by rewrite Rminus_diag_eq // pow_ne_zero // Rmult_0_r; auto with real. apply: Rmult_le_pos_pos. apply: Rdiv_pos_compat. apply: Hsign. exact: Hdom Hc. exact: INR_fact_lt_0. exact: ZEven_pow_le. Qed. Lemma lower_even_Rneg_over (c x0 : R) (nm1 : nat) (n := nm1.+1) : Z.Even (Z_of_nat n) -> dom x0 -> Rneg_over dom (Dn n.+1) -> forall x : R, (x <= x0)%R -> dom x -> intvl x x0 c \/ intvl x0 x c -> (Dn n.+1 c / INR (fact n) * (x - x0) ^ n <= 0)%R. Proof. move=> Hev Hx0 Hsign x Hx Dx [Hc|Hc]; last first. have ->: x = x0 by move: Hx Hc; rewrite /intvl; lra. by rewrite Rminus_diag_eq // pow_ne_zero // Rmult_0_r; auto with real. apply: Rmult_le_neg_pos. apply: Rdiv_neg_compat. apply: Hsign. exact: Hdom Hc. exact: INR_fact_lt_0. exact: ZEven_pow_le. Qed. Lemma lower_odd_Rpos_over (c x0 : R) (nm1 : nat) (n := nm1.+1) : Z.Odd (Z_of_nat n) -> dom x0 -> Rpos_over dom (Dn n.+1) -> forall x : R, (x <= x0)%R -> dom x -> intvl x x0 c \/ intvl x0 x c -> (Dn n.+1 c / INR (fact n) * (x - x0) ^ n <= 0)%R. Proof. move=> Hev Hx0 Hsign x Hx Dx [Hc|Hc]; last first. have ->: x = x0 by move: Hx Hc; rewrite /intvl; lra. by rewrite Rminus_diag_eq // pow_ne_zero // Rmult_0_r; auto with real. apply: Rmult_le_pos_neg. apply: Rdiv_pos_compat. apply: Hsign. exact: Hdom Hc. exact: INR_fact_lt_0. apply: ZOdd_pow_le Hev _. now apply Rle_minus. Qed. Lemma lower_odd_Rneg_over (c x0 : R) (nm1 : nat) (n := nm1.+1) : Z.Odd (Z_of_nat n) -> dom x0 -> Rneg_over dom (Dn n.+1) -> forall x : R, dom x -> (x <= x0)%R -> intvl x x0 c \/ intvl x0 x c -> (0 <= (Dn n.+1 c) / INR (fact n) * (x - x0) ^ n)%R. Proof. move=> Hev Hx0 Hsign x Hx Dx [Hc|Hc]; last first. have ->: x = x0 by move: Hx Hc; rewrite /intvl; lra. by rewrite Rminus_diag_eq // pow_ne_zero // Rmult_0_r; auto with real. apply: Rmult_le_neg_neg. apply: Rdiv_neg_compat. apply: Hsign. exact: Hdom Hc. exact: INR_fact_lt_0. apply: ZOdd_pow_le Hev _. now apply Rle_minus. Qed. Hypothesis Hder_n : forall n x, dom x -> ex_derive_n f0 n x. Lemma Rderive_delta (Pr : R -> Prop) (n : nat) (x0 : R) : dom x0 -> Pr x0 -> Rderive_over (fun t => dom t /\ Pr t) (Rdelta n x0) (Rdelta' n x0). Proof. move=> Dx0 HPr x Hx. rewrite /Rdelta /Rdelta'. apply: is_derive_minus. apply: Derive_correct. now apply (Hder_n 1). set d := (_ ^`()).[_]. have->: d = scal R1 d by rewrite /scal /= /mult /= Rmult_1_l. apply: is_derive_comp; last first. rewrite -[R1]Rminus_0_r; apply: is_derive_minus; by auto_derive. rewrite /d. exact: PolR.is_derive_horner. Qed. Hypothesis Poly_size : forall (x0 : R) n, PolR.size (P x0 n) = n.+1. Hypothesis Poly_nth : forall (x : R) n k, dom x -> k <= n -> PolR.nth (P x n) k = Rdiv (Dn k x) (INR (fact k)). Lemma bigXadd'_P (m n : nat) (x0 s : R) : dom x0 -> ex_derive_n f0 n x0 -> m <= n -> \big[Rplus/R0]_(0 <= i < m) (PolR.nth (P x0 n) i.+1 * INR i.+1 * s ^ i)%R = \big[Rplus/R0]_(0 <= i < m) ((Dn i.+1 x0) / INR (fact i) * s ^ i)%R. Proof. move=> H0 Hx0 Hmn; rewrite !big_mkord. case: m Hmn =>[|m] Hmn; first by rewrite !big_ord0. elim/big_ind2: _ =>[//|x1 x2 y1 y2 -> ->//|i _]. rewrite Poly_nth //; last by case: i => [i Hi] /=; exact: leq_trans Hi Hmn. rewrite fact_simpl mult_INR. field. split; by [apply: INR_fact_neq_0 | apply: not_0_INR ]. Qed. (** Proposition 2.2.1 in Mioara Joldes' thesis, adapted from Lemma 5.12 in Roland Zumkeller's thesis *) Theorem Zumkeller_monot_rem (x0 : R) (n : nat) : dom x0 -> Rcst_sign dom (Dn n.+1) -> Rmonot (fun t => dom t /\ (t <= x0)%R) (Rdelta n x0) /\ Rmonot (fun t => dom t /\ (x0 <= t)%R) (Rdelta n x0). Proof. move=> Hx0. case: n =>[|nm1] ; last set n := nm1.+1. move=> Hsign; split; apply (@Rderive_cst_sign _ _ (Dn 1)) =>//. - apply: connected_and => //. exact: connected_le. - move=> x [Hx1 Hx2]. rewrite -[Dn 1 x]Rminus_0_r. apply: is_derive_minus. apply: Derive_correct. exact: (Hder_n 1). auto_derive. exact: PolR.ex_derive_horner. rewrite Rmult_1_l (Derive_ext _ (fun r => PolR.nth (P x0 0) 0)). by rewrite Derive_const. by move=> r; rewrite PolR.hornerE Poly_size big_nat1 pow_O Rmult_1_r. - case: Hsign => Hsign; [left|right]; move: Hsign; rewrite /Rpos_over /Rneg_over. + move=> Htop x [Hx1 Hx2]; exact: Htop. + move=> Htop x [Hx1 Hx2]; exact: Htop. - apply: connected_and => //. exact: connected_ge. - move=> x [Hx1 Hx2]. rewrite -[Dn 1 x]Rminus_0_r. apply: is_derive_minus. apply: Derive_correct. exact: (Hder_n 1). auto_derive. exact: PolR.ex_derive_horner. rewrite Rmult_1_l (Derive_ext _ (fun r => PolR.nth (P x0 0) 0)). by rewrite Derive_const. by move=> r; rewrite PolR.hornerE Poly_size big_nat1 pow_O Rmult_1_r. case: Hsign => Hsign; [left|right]; move: Hsign; rewrite /Rpos_over /Rneg_over. + move=> Htop x [Hx1 Hx2]; exact: Htop. + move=> Htop x [Hx1 Hx2]; exact: Htop. have TL := @ITaylor_Lagrange (fun x => Xreal (Derive f0 x)) dom Hdom n.-1 _ x0 _ Hx0. case=>[Hpos|Hneg]. split. apply: (@Rderive_cst_sign _ _ (Rdelta' n x0)) =>//. * apply: connected_and => //. exact: connected_le. * apply: Rderive_delta => //. exact: Rle_refl. { have [Heven|Hodd] := (Z.Even_or_Odd (Z_of_nat nm1.+1)). - left. move=> x [Hx1 Hx2]. have [||c [H1 [H2 H3]]] := TL _ x =>//. move=> k t Ht. case: k => [//|k]; rewrite -ex_derive_nSS. exact: (Hder_n k.+2). rewrite /Rdelta' PolR.horner_derivE Poly_size. rewrite bigXadd'_P //; last exact/Hder_n. set b := \big[Rplus/R0]_(_ <= i < _) _. set b2 := \big[Rplus/R0]_(_ <= i < _) _ in H2. have->: b = b2 by apply: eq_bigr => i _; rewrite -Derive_nS. rewrite /b /b2 H2 -Derive_nS. exact: (@lower_even_Rpos_over c x0 nm1). - right. move=> x [Hx1 Hx2]. have [||c [H1 [H2 H3]]] := TL _ x =>//. move=> k t Ht. case: k => [//|k]; rewrite -ex_derive_nSS. exact: (Hder_n k.+2). rewrite /Rdelta' PolR.horner_derivE Poly_size. rewrite bigXadd'_P //; last exact/Hder_n. set b := \big[Rplus/R0]_(_ <= i < _) _. set b2 := \big[Rplus/R0]_(_ <= i < _) _ in H2. have->: b = b2 by apply: eq_bigr => i _; rewrite -Derive_nS. rewrite /b /b2 H2 -Derive_nS. exact: (@lower_odd_Rpos_over c x0 nm1). } apply: (@Rderive_cst_sign _ _ (Rdelta' n x0)) =>//. * apply: connected_and => //. exact: connected_ge. * apply: Rderive_delta => //. exact: Rle_refl. left. move=> x [Hx1 Hx2]. have [||c [H1 [H2 H3]]] := TL _ x =>//. move=> k t Ht. case: k => [//|k]; rewrite -ex_derive_nSS. exact: (Hder_n k.+2). rewrite /Rdelta' PolR.horner_derivE Poly_size. rewrite bigXadd'_P //; last exact/Hder_n. set b := \big[Rplus/R0]_(_ <= i < _) _. set b2 := \big[Rplus/R0]_(_ <= i < _) _ in H2. have->: b = b2 by apply: eq_bigr => i _; rewrite -Derive_nS. rewrite /b /b2 H2 -Derive_nS. exact: (@upper_Rpos_over c x0 nm1). split. apply: (@Rderive_cst_sign _ _ (Rdelta' n x0)) =>//. * apply: connected_and => //. exact: connected_le. * apply: Rderive_delta => //. exact: Rle_refl. { have [Heven|Hodd] := (Z.Even_or_Odd (Z_of_nat nm1.+1)). - right. move=> x [Hx1 Hx2]. have [||c [H1 [H2 H3]]] := TL _ x =>//. move=> k t Ht. case: k => [//|k]; rewrite -ex_derive_nSS. exact: (Hder_n k.+2). rewrite /Rdelta' PolR.horner_derivE Poly_size. rewrite bigXadd'_P //; last exact/Hder_n. set b := \big[Rplus/R0]_(_ <= i < _) _. set b2 := \big[Rplus/R0]_(_ <= i < _) _ in H2. have->: b = b2 by apply: eq_bigr => i _; rewrite -Derive_nS. rewrite /b /b2 H2 -Derive_nS. exact: (@lower_even_Rneg_over c x0 nm1). - left. move=> x [Hx1 Hx2]. have [||c [H1 [H2 H3]]] := TL _ x =>//. move=> k t Ht. case: k => [//|k]; rewrite -ex_derive_nSS. exact: (Hder_n k.+2). rewrite /Rdelta' PolR.horner_derivE Poly_size. rewrite bigXadd'_P //; last exact/Hder_n. set b := \big[Rplus/R0]_(_ <= i < _) _. set b2 := \big[Rplus/R0]_(_ <= i < _) _ in H2. have->: b = b2 by apply: eq_bigr => i _; rewrite -Derive_nS. rewrite /b /b2 H2 -Derive_nS. exact: (@lower_odd_Rneg_over c x0 nm1). } apply: (@Rderive_cst_sign _ _ (Rdelta' n x0)) =>//. * apply: connected_and => //. exact: connected_ge. * apply: Rderive_delta => //. exact: Rle_refl. right. move=> x [Hx1 Hx2]. have [||c [H1 [H2 H3]]] := TL _ x =>//. move=> k t Ht. case: k => [//|k]; rewrite -ex_derive_nSS. exact: (Hder_n k.+2). rewrite /Rdelta' PolR.horner_derivE Poly_size. rewrite bigXadd'_P //; last exact/Hder_n. set b := \big[Rplus/R0]_(_ <= i < _) _. set b2 := \big[Rplus/R0]_(_ <= i < _) _ in H2. have->: b = b2 by apply: eq_bigr => i _; rewrite -Derive_nS. rewrite /b /b2 H2 -Derive_nS. exact: (@upper_Rneg_over c x0 nm1). Qed. End aux. Variable F : I.type -> I.type. Variable IP : I.type -> nat -> Pol.T. Hypothesis F_contains : I.extension (Xbind xf) F. Variables X : I.type. Class validPoly : Prop := ValidPoly { Poly_size : forall (x0 : R) n, PolR.size (P x0 n) = n.+1; Poly_nth : forall (x : R) n k, X >: x -> k <= n -> PolR.nth (P x n) k = Rdiv (Dn k x) (INR (fact k)) }. Class validIPoly : Prop := ValidIPoly { IPoly_size : forall (X0 : I.type) x0 n, eq_size (IP X0 n) (P x0 n); IPoly_nth : forall (X0 : I.type) x0 n, X0 >: x0 -> IP X0 n >:: P x0 n; IPoly_nai : forall X, forall r : R, contains (I.convert X) (Xreal r) -> xf r = Xnan -> forall n k, k <= n -> I.convert (Pol.nth (IP X n) k) = IInan }. Context { validPoly_ : validPoly }. Context { validIPoly_ : validIPoly }. Hypothesis Hder_n : forall n x, X >: x -> ex_derive_n f0 n x. Lemma Poly_nth0 x n : X >: x -> PolR.nth (P x n) 0 = f0 x. Proof. by move=> H; rewrite Poly_nth // ?Rcomplements.Rdiv_1 //. Qed. Theorem i_validTM_TLrem (x0 : R) (X0 : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (RPA (IP X0 n) (TLrem IP X0 X n)) xf. Proof. move=> Hsubs Hx0. pose err := TLrem IP X0 X n. have H0 : X >: x0 by exact: Hsubs. split=>//=. (* Def *) move=> x Hx Nx. rewrite /TLrem. apply I.mul_propagate_l. exact: (IPoly_nai Hx Nx). (* Nai *) move=> HX; rewrite /TLrem. by rewrite I.mul_propagate_r // J.power_int_propagate // I.sub_propagate_l. (* |- 0 \in err *) set V := (I.power_int prec (I.sub prec X X0) (Z_of_nat n.+1)). apply (mul_0_contains_0_r _ (y := Xreal (PolR.nth (P x0 n.+1) n.+1))). apply: IPoly_nth =>//. apply: pow_contains_0 =>//. exact: subset_sub_contains_0 Hx0 Hsubs. (* |- Main condition for i_validTM *) exists (P x0 n); first by apply: IPoly_nth. move=> x Hx. rewrite PolR.hornerE Poly_size //. have Hbig : \big[Rplus/R0]_(0 <= i < n.+1) (PolR.nth (P x0 n) i * (x - x0) ^ i)%R = \big[Rplus/R0]_(0 <= i < n.+1) (Dn i x0 / INR (fact i) * (x - x0)^i)%R. by apply: eq_big_nat => i Hi; rewrite Poly_nth. rewrite Hbig. have Hder' : forall n r, X >: r -> ex_derive_n f0 n r. move=> m r Hr. exact: Hder_n. have [c [Hcin [Hc Hc']]] := (@ITaylor_Lagrange xf _ (contains_connected (I.convert X)) n Hder' x0 x H0 Hx). rewrite Hc /TLrem. apply: J.mul_correct=>//. rewrite -(@Poly_nth _ c n.+1 n.+1) //; exact: IPoly_nth. rewrite pow_powerRZ. apply: J.power_int_correct. exact: J.sub_correct. Qed. Lemma Ztech_derive_sign (n : nat) : isNNegOrNPos (Pol.nth (IP X n.+1) n.+1) = true -> Rcst_sign (fun t => contains (I.convert X) (Xreal t)) (Dn n.+1). Proof. move=> Hsign. have: Rcst_sign (fun t => contains (I.convert X) (Xreal t)) (fun x => (Dn n.+1 x) / INR (fact n.+1))%R. move: Hsign; set Gamma := Pol.nth _ _. set g := fun x => ((Dn n.+1 x) / INR (fact n.+1))%R. have inGamma : forall x, X >: x -> Gamma >: g x. move => x Hx. rewrite /g -(Poly_nth _ (n:=n.+1)) //. exact: IPoly_nth. rewrite /isNNegOrNPos. case E : I.sign_large =>// _; have := I.sign_large_correct Gamma; rewrite E => Hmain. - left; move=> x Hx. case/(_ _ (inGamma x Hx)): Hmain =>->. exact: Rle_refl. - right; move=> x Hx. now apply (Hmain (Xreal (g x))), inGamma. - left; move=> x Hx. now apply (Hmain (Xreal (g x))), inGamma. case=>[Htop|Htop]; [left|right]; intros x Hx. - apply: Rdiv_pos_compat_rev (Htop x Hx) _. exact: INR_fact_lt_0. - apply: Rdiv_neg_compat_rev (Htop x Hx) _. exact: INR_fact_lt_0. Qed. Lemma F_Rcontains : forall X x, X >: x -> F X >: f0 x. Proof. clear -F_contains. move => X x /F_contains. rewrite /f0 /Xbind. case: xf => //. by case I.convert. Qed. Theorem i_validTM_Ztech (x0 : R) (X0 : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (RPA (IP X0 n) (Ztech IP (IP X0 n) F X0 X n)) xf. Proof. move=> Hsubs Hx0. have H0 : X >: x0 by exact: Hsubs. case E1 : (isNNegOrNPos (Pol.nth (IP X n.+1) n.+1)); last first. rewrite /Ztech E1 /=. exact: i_validTM_TLrem. case E2 : (I.bounded X); last first. rewrite /Ztech E2 andbC /=. exact: i_validTM_TLrem. set err := Ztech IP (IP X0 n) F X0 X n. have Hdef : forall r : R, X >: r -> xf r <> Xnan. move=> r Hr Kr. have Knai := @IPoly_nai validIPoly_ X r Hr Kr n.+1 n.+1 (leqnn _). by rewrite isNNegOrNPos_false in E1. split=>//. - by move=> x Hx /(Hdef x Hx). - have /I.bounded_correct [E1l E1u] := E2. rewrite (proj2 (I.lower_bounded_correct _ _)) =>//. exists x0; exact: Hsubs. - rewrite /= /err /Ztech E1 E2 /=. apply: I.join_correct; right. have E0 : xf x0 = Xreal (PolR.nth (P x0 n) 0). rewrite Poly_nth0 // /f0. by case: (xf x0) (Hdef x0 H0). pose r'0 := PolR.nth (P x0 n) 0. have->: Xreal 0 = Xsub (xf x0) (Xreal r'0) by rewrite E0 /= Rminus_diag_eq. apply: I.sub_correct. exact: F_contains Hx0. exact: IPoly_nth. clear Hdef. exists (P x0 n); first by move=> k; apply: IPoly_nth. pose Rdelta0 := Rdelta n x0. move=> x Hx. rewrite /err /Ztech E1 E2 /=. set Delta := I.join (I.join _ _) _; rewrite -/(Rdelta n x0 x) -/(Rdelta0 x). have [Hbl Hbu] := I.bounded_correct _ E2. have [Hcl _] := I.lower_bounded_correct _ Hbl. have [Hcu _] := I.upper_bounded_correct _ Hbu. set (l := (proj_val (I.F.convert (I.lower X)))) in Hcl. set (u := (proj_val (I.F.convert (I.upper X)))) in Hcu. have HX: I.convert X = Ibnd (Xreal l) (Xreal u). rewrite -Hcl -Hcu. apply I.lower_bounded_correct =>//. exists x0; exact: Hsubs. have {Hcl Hbl} Hlower : Delta >: Rdelta0 l. apply: I.join_correct; left; apply: I.join_correct; left. have Hlower : contains (I.convert (I.bnd (I.lower X) (I.lower X))) (Xreal l). rewrite I.bnd_correct; first last. - apply: I.valid_ub_real. by rewrite Hcl. - apply: I.valid_lb_real. by rewrite Hcl. - rewrite Hcl; split; apply Rle_refl. apply: J.sub_correct. - exact: F_Rcontains. - apply: Pol.horner_correct. exact: IPoly_nth. exact: J.sub_correct. have {Hcu Hbu} Hupper : Delta >: Rdelta0 u. apply: I.join_correct; left; apply: I.join_correct; right. have Hupper : contains (I.convert (I.bnd (I.upper X) (I.upper X))) (Xreal u). rewrite I.bnd_correct; first last. - apply: I.valid_ub_real. by rewrite Hcu. - apply: I.valid_lb_real. by rewrite Hcu. - rewrite Hcu; split; apply Rle_refl. apply: J.sub_correct. - exact: F_Rcontains. - apply: Pol.horner_correct. exact: IPoly_nth. exact: J.sub_correct. have H'x0 : X >: x0 by exact: Hsubs. have HX0 : Delta >: Rdelta0 x0. apply: I.join_correct; right. apply: J.sub_correct; first exact: F_Rcontains. rewrite Rminus_diag_eq //. suff->: ((P x0 n).[0%R]) = PolR.nth (P x0 n) 0 by apply: IPoly_nth. rewrite PolR.hornerE Poly_size big_nat_recl // pow_O Rmult_1_r. rewrite big1 ?(Rplus_0_r, Rmult_1_r) //. move=> i _. by rewrite /= Rmult_0_l Rmult_0_r. clearbody Delta l u. rewrite -> HX in Hx, H'x0. have [||Hlow|Hup] := @intvl_lVu l u x0 x => //. have [|||H1|H2] := @Rmonot_contains _ (@intvl_connected l x0) Rdelta0 _ _ _ _ _ _ Hlow. + have [|||||H _] := @Zumkeller_monot_rem _ (contains_connected (I.convert X)) _ _ _ x0 n => //. apply Poly_size. apply Poly_nth. exact: Ztech_derive_sign. case: H => H ; [left|right] ; intros p q Hp Hq Hpq ; apply H => // ; rewrite HX ; split ; try apply: intvl_connected (intvl_l H'x0) (H'x0) _ _ => // ; try apply Hp ; try apply Hq. exact: intvl_l Hlow. exact: intvl_u Hlow. + exact: contains_connected H1. + exact: contains_connected H2. have [|||H1|H2] := @Rmonot_contains _ (@intvl_connected x0 u) Rdelta0 _ _ _ _ _ _ Hup. + have [|||||_ H] := @Zumkeller_monot_rem _ (contains_connected (I.convert X)) _ _ _ x0 n => //. apply Poly_size. apply Poly_nth. exact: Ztech_derive_sign. case: H => H ; [left|right] ; intros p q Hp Hq Hpq ; apply H => // ; rewrite HX ; split ; try apply: intvl_connected (H'x0) (intvl_u H'x0) _ _ => // ; try apply Hp ; try apply Hq. exact: intvl_l Hup. exact: intvl_u Hup. + exact: contains_connected H1. + exact: contains_connected H2. Qed. End GenericProof. Lemma size_TM_cst (X c : I.type) : Pol.size (approx (TM_cst X c)) = 1. Proof. by rewrite /TM_cst Pol.polyCE Pol.size_polyCons Pol.size_polyNil. Qed. Theorem TM_cst_correct (x0 : R) (ci X : I.type) (c : ExtendedR) : contains (I.convert X) (Xreal x0) -> contains (I.convert ci) c -> i_validTM x0 (I.convert X) (TM_cst X ci) (fun _ => c). Proof. move=> Hx0 Hc. split=>//=. move=> x Hx Nx. apply I.mask_propagate_r, contains_Xnan. by rewrite -Nx. by move=> HX; apply I.mask_propagate_l, I.mask_propagate_r. apply I.mask_correct', I.mask_correct', J.zero_correct. case: c Hc => [|c]; first move/contains_Xnan; move => Hc. exists (PolR.polyC 0%R); first by apply: Pol.polyC_correct; rewrite Hc. by move=> x Hx; rewrite I.mask_propagate_r. exists (PolR.polyC c); first exact: Pol.polyC_correct. move=> x Hx /=. rewrite Rmult_0_l Rplus_0_l Rminus_diag_eq //. apply I.mask_correct', I.mask_correct', J.zero_correct. Qed. Theorem TM_cst_correct_strong (x0 : R) (ci X : I.type) (f : R -> ExtendedR) : contains (I.convert X) (Xreal x0) -> is_const f (I.convert X) (I.convert ci) -> i_validTM x0 (I.convert X) (TM_cst X ci) f. Proof. move=> Hx0 [c H1 H2]. apply: TM_fun_eq; last apply: TM_cst_correct Hx0 H1. move=> x Hx /=. by apply sym_eq, H2. Qed. (** Return a dummy Taylor model of order [n] that contains every point of [Y] *) Definition TM_any (Y : I.type) (X : I.type) (n : nat) := let mid := J.midpoint Y in let pol := Pol.polyC mid in {| approx := if n == 0 then pol else Pol.set_nth pol n Pol.Int.zero; error := I.mask (I.sub prec Y mid) X |}. Definition sizes := (Pol.size_polyNil, Pol.size_polyCons, PolR.size_polyNil, PolR.size_polyCons, Pol.size_set_nth, PolR.size_set_nth, Pol.polyCE). Lemma size_TM_any (c X : I.type) n : Pol.size (approx (TM_any c X n)) = n.+1. Proof. rewrite /TM_any /=. case: n =>[|n] /=. by rewrite !sizes. by rewrite Pol.size_set_nth !sizes maxnSS maxn0. Qed. Theorem TM_any_correct (x0 : R) (Y X : I.type) (n : nat) (f : R -> ExtendedR) : contains (I.convert X) (Xreal x0) -> (forall x : R, contains (I.convert X) (Xreal x) -> contains (I.convert Y) (f x)) -> i_validTM x0 (I.convert X) (TM_any Y X n) f. Proof. move=> H0 Hf. have Hrr := Hf _ H0. set r := proj_val (f x0). have Hr : contains (I.convert Y) (Xreal r). exact: contains_Xreal. set (m := proj_val (I.F.convert (I.midpoint Y))). assert (Hm': contains (I.convert (J.midpoint Y)) (Xreal m)). apply J.contains_midpoint. now exists r. split=>//. move=> /= x Hx Nx. rewrite /TM_any /= in Nx. apply I.mask_propagate_l, I.sub_propagate_l, contains_Xnan. rewrite -Nx. exact: Hf. apply I.mask_propagate_r. apply I.mask_correct'. apply: subset_sub_contains_0 Hm' _. apply J.subset_midpoint. now exists r. set pol0 := PolR.polyC m. set pol' := if n == 0 then pol0 else PolR.set_nth pol0 n 0%R. exists pol'. rewrite /pol' {pol'} /pol0 /TM_any /=. + case: ifP => H. exact: Pol.polyC_correct. apply: Pol.set_nth_correct. exact: Pol.polyC_correct. exact: J.zero_correct. + move=> x Hx /=. apply I.mask_correct', J.sub_correct. now apply contains_Xreal, Hf. rewrite /pol' /pol0; case: ifP => H. by rewrite PolR.horner_polyC. rewrite PolR.hornerE !sizes maxnSS maxn0. step_r (pol0.[x - x0])%R. by rewrite PolR.horner_polyC. rewrite /pol0 (@PolR.hornerE_wide n.+1) ?sizes //. apply: eq_bigr => i _. congr Rmult. rewrite PolR.polyCE !(PolR.nth_polyCons, PolR.nth_set_nth). case: i => [//|i]; first by rewrite eq_sym H. by rewrite PolR.nth_polyNil if_same. Qed. Lemma size_TM_var (X X0 : I.type) : Pol.size (approx (TM_var X X0)) = 2. Proof. rewrite /TM_var Pol.size_set_nth Pol.polyXE Pol.size_lift Pol.oneE Pol.polyCE. by rewrite Pol.size_polyCons Pol.size_polyNil. Qed. Lemma TM_var_correct (x0 : R) (X0 X : I.type) : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_var X X0) Xreal. Proof. move=> Hsubs Hx0. split=>//. apply I.mask_propagate_r. apply I.mask_correct', J.zero_correct. exact: Hsubs. exists (PolR.set_nth PolR.polyX 0 x0). apply: Pol.set_nth_correct =>//. exact: Pol.polyX_correct. move=> x Hx /=. replace (x - _)%R with 0%R by ring. apply I.mask_correct', J.zero_correct. Qed. Theorem TM_var_correct_strong (x0 : R) (X0 X : I.type) (f : R -> ExtendedR) : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> (forall x : R, contains (I.convert X) (Xreal x) -> f x = Xreal x) -> i_validTM x0 (I.convert X) (TM_var X X0) f. Proof. move=> Hsubset Hx0 Hid. apply: TM_fun_eq; last apply: TM_var_correct Hsubset Hx0. by move=> *; rewrite Hid. Qed. Lemma size_TM_exp (X0 X : I.type) (n : nat) : Pol.size (approx (TM_exp X0 X n)) = n.+1. Proof. by rewrite Pol.size_rec1. Qed. Lemma TM_exp_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_exp X0 X n) (fun x => Xreal (exp x)). Proof. move=> Hsubset Hex. apply i_validTM_Ztech with (TR.T_exp tt); last 2 first =>//. exact: I.exp_correct. constructor. - by move=> *; rewrite PolR.size_rec1. - { move=> {X0 n Hsubset Hex} x n k Hx Hk; rewrite /PolR.nth. elim: k Hk => [|k IHk] Hk. - by rewrite (nth_rec1up_indep _ _ _ 0%R (m2 := 0)) //= Rdiv_1. rewrite (nth_rec1up_indep _ _ _ 0%R (m2 := k)) // in IHk; last exact: ltnW. rewrite (nth_rec1up_indep _ _ _ 0%R (m2 := k.+1)) // nth_rec1upS. rewrite {}IHk /TR.exp_rec; last exact: ltnW. rewrite !(is_derive_n_unique _ _ _ _ (is_derive_n_exp _ _)). rewrite fact_simpl mult_INR. change eq with (@eq R); field; split. apply INR_fact_neq_0. now apply not_0_INR. } constructor. - by move=> *; rewrite PolR.size_rec1 Pol.size_rec1. - { move => {X n Hsubset Hex} X0 xi0 n Hx. apply: Pol.rec1_correct =>//. by move=> *; repeat first [apply: J.div_correct |apply: R_from_nat_correct ]. exact: J.exp_correct. } - done. - move=> {} n x Hx; eapply ex_derive_n_is_derive_n; exact: is_derive_n_exp. Qed. Lemma nat_ind2 (P : nat -> Prop) : P 0 -> P 1 -> (forall k, P k -> P k.+1 -> P k.+2) -> forall k, P k. Proof. move=> H0 H1 Hind k. suff : P k /\ P k.+1 by case. elim: k => [|k [IHk0 IHk1]]; first by split. split; by [|apply: Hind]. Qed. Lemma size_TM_sin (X0 X : I.type) (n : nat) : Pol.size (approx (TM_sin X0 X n)) = n.+1. Proof. by rewrite Pol.size_rec2. Qed. Lemma TM_sin_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_sin X0 X n) (fun x => Xreal (sin x)). Proof. move=> Hsubset Hex. apply i_validTM_Ztech with (TR.T_sin tt); last 2 first =>//. exact: I.sin_correct. constructor. - by move=> x m; rewrite /TR.T_sin PolR.size_rec2. - move=> x m k Dx Hk; rewrite /TR.T_sin. rewrite /PolR.nth /PolR.rec2; clear - Hk. { move: k Hk; apply: nat_ind2. - by move=> _; rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := 0)) //= Rdiv_1. - move=> Hm; rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := 1)) //=. (* typical script: *) by rewrite Rdiv_1; symmetry; apply: is_derive_unique; auto_derive; auto with real. - move=> k Hk0 Hk1 Hm. rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := k.+2)) // nth_rec2upSS'. rewrite /TR.sin_rec in Hk0 Hk1 *. set F := (fun (a _ : FullR.T) (n : nat) => - a / (INR n * INR n.-1))%R in Hk0 Hk1 *. have Hkm : k <= m by do 2![apply: ltnW]. move/(_ Hkm) in Hk0. rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := k)) // in Hk0. rewrite Hk0 !Derive_nS; clear. rewrite [in RHS](Derive_n_ext _ (fun x => - sin x)); last first. move=> t; change (Derive _ t) with (Derive_n sin 2 t). rewrite (is_derive_n_unique _ _ _ _ (is_derive_n_sin _ _)) /= Rmult_1_r. by rewrite Ropp_mult_distr_l_reverse Rmult_1_l. rewrite Derive_n_opp 2!fact_simpl 2!mult_INR. change (Derive_n (fun x => _)) with (Derive_n sin). simpl (k.+2.-1). change eq with (@eq R); field; split. apply INR_fact_neq_0. split ; exact: not_0_INR. } constructor. - by move=> x m k; rewrite /TR.T_sin Pol.size_rec2 PolR.size_rec2. - by move=> Y x m Hx; apply: Pol.rec2_correct; first move=> ai bi a b l Ha Hb; repeat first [apply: J.div_correct| apply: J.neg_correct| apply: J.mul_correct| apply: R_from_nat_correct| apply: J.sin_correct| apply: J.cos_correct]. - move=> Y x Hx Dx m k Hk; rewrite /T_sin. - done. - move=> *; apply/ex_derive_n_is_derive_n/is_derive_n_sin. Qed. Lemma size_TM_cos (X0 X : I.type) (n : nat) : Pol.size (approx (TM_cos X0 X n)) = n.+1. Proof. by rewrite Pol.size_rec2. Qed. Lemma TM_cos_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_cos X0 X n) (fun x => Xreal (cos x)). Proof. move=> Hsubset Hex. apply i_validTM_Ztech with (TR.T_cos tt); last 2 first =>//. exact: I.cos_correct. constructor. - by move=> x m; rewrite /TR.T_cos PolR.size_rec2. - move=> x m k Dx Hk; rewrite /TR.T_cos. rewrite /PolR.nth /PolR.rec2; clear - Hk. { move: k Hk; apply: nat_ind2. - by move=> _; rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := 0)) //= Rdiv_1. - move=> Hm; rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := 1)) //=. (* typical script: *) by rewrite Rdiv_1; symmetry; apply: is_derive_unique; auto_derive; auto with real. - move=> k Hk0 Hk1 Hm. rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := k.+2)) // nth_rec2upSS'. rewrite /TR.cos_rec in Hk0 Hk1 *. set F := (fun (a _ : FullR.T) (n : nat) => - a / (INR n * INR n.-1))%R in Hk0 Hk1 *. have Hkm : k <= m by do 2![apply: ltnW]. move/(_ Hkm) in Hk0. rewrite (nth_rec2up_indep _ _ _ _ 0%R (m2 := k)) // in Hk0. rewrite Hk0 !Derive_nS; clear. rewrite [in RHS](Derive_n_ext _ (fun x => - cos x)); last first. move=> t; change (Derive _ t) with (Derive_n cos 2 t). rewrite (is_derive_n_unique _ _ _ _ (is_derive_n_cos _ _)) /= Rmult_1_r. by rewrite Ropp_mult_distr_l_reverse Rmult_1_l. rewrite Derive_n_opp 2!fact_simpl 2!mult_INR. change (Derive_n (fun x => _)) with (Derive_n cos). simpl (k.+2.-1). change eq with (@eq R); field; split. apply INR_fact_neq_0. split ; exact: not_0_INR. } constructor. - by move=> x m k; rewrite /TR.T_cos Pol.size_rec2 PolR.size_rec2. - by move=> Y x m Hx; apply: Pol.rec2_correct; first move=> ai bi a b l Ha Hb; repeat first [apply: J.div_correct| apply: J.neg_correct| apply: J.mul_correct| apply: R_from_nat_correct| apply: J.sin_correct| apply: J.cos_correct]. - done. - move=> *; apply/ex_derive_n_is_derive_n/is_derive_n_cos. Qed. Lemma is_derive_n_atan n (x : R) : let q n := iteri n (fun i c => PolR.div_mixed_r tt (PolR.sub tt (PolR.add tt c^`() (PolR.lift 2 c^`())) (PolR.mul_mixed tt (INR (i.+1).*2) (PolR.lift 1 c))) (INR i.+2)) PolR.one in is_derive_n atan n x (if n is n.+1 then PolR.horner tt (q n) x / (1 + x²) ^ (n.+1) * INR (fact n.+1) else atan x)%R. Proof. move=> q; move: n x. help_is_derive_n_whole n x. - rewrite /Rdiv !Rsimpl. have := is_derive_atan x; exact: is_derive_ext. - set Q := (1 + x * x)%R. have HQ : Q <> 0%R by exact: Rsqr_plus1_neq0. have HQ' : (Q ^ n <> 0)%R by exact: pow_nonzero. have HQ'' : (Q * Q ^ n <> 0)%R. rewrite Rmult_comm -(Rmult_0_l (1 + x * x)). by apply:Rmult_neq_compat_r; try apply: pow_nonzero; exact: Rsqr_plus1_neq0. auto_derive; first split. + exact: PolR.ex_derive_horner. + by split. + rewrite Rmult_1_l PolR.Derive_horner [q n.+1]iteriS -/(q n). rewrite PolR.horner_div_mixed_r PolR.horner_sub PolR.horner_add. rewrite PolR.horner_mul_mixed !PolR.horner_lift. rewrite -{1}[in RHS](Rmult_1_r (q n)^`().[x]) -Rmult_plus_distr_l. have->: (x ^ 2 = x²)%R by simpl; rewrite Rmult_1_r. rewrite pow_1 /Rdiv. have H1 : (if n is _.+1 then (INR n + 1)%R else 1%R) = INR n.+1 by []. rewrite H1. rewrite !Rinv_mult_distr // -/pow -/Q. have->: INR (fact n + (n * fact n))%coq_nat = INR (fact n.+1) by []. rewrite [in RHS]fact_simpl mult_INR. set A := (((q n)^`()).[x] * Q - INR (n.+1).*2 * ((q n).[x] * x))%R. have->: (A * / INR n.+2 * (/ Q * (/ Q * / Q ^ n)) * (INR n.+2 * INR (fact n.+1)) = A * (/ INR n.+2 * INR n.+2) * (/ Q * (/ Q * / Q ^ n)) * INR (fact n.+1))%R by ring. rewrite Rinv_l; last exact: not_0_INR. rewrite /A !Rsimpl. rewrite -mul2n [INR (2 * _)%N]mult_INR; simpl (INR 2). field; by split. Qed. Lemma size_TM_atan (X0 X : I.type) (n : nat) : Pol.size (approx (TM_atan X0 X n)) = n.+1. Proof. by rewrite Pol.size_grec1. Qed. Lemma TM_atan_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_atan X0 X n) (fun x => Xreal (atan x)). Proof. move=> Hsubset Hex. apply i_validTM_Ztech with (TR.T_atan tt); last 2 first =>//. exact: I.atan_correct. constructor. - by move=> ? ?; rewrite PolR.size_grec1. - { (* The proof of this goal might be shortened by reusing is_derive_n_atan *) move=> {X0 n Hsubset Hex} x n k Hx H; rewrite /TR.T_atan /PolR.nth /PolR.grec1 (nth_grec1up_indep _ _ _ _ _ 0%R (m2 := k)) // nth_grec1up_last. case: k H => [|k H]; first by rewrite /= ?Rdiv_1. rewrite last_grec1up // head_gloop1. rewrite [size _]/= subn1 [_.+1.-1]/=. elim: k H x {Hx} =>[|k IHk] H x. + rewrite /= Rmult_0_l Rplus_0_l Rmult_1_r Rdiv_1. symmetry; apply: is_derive_unique; auto_derive =>//. by rewrite Rmult_1_r. + move/ltnW in H; move/(_ H) in IHk. rewrite [INR]lock [PolR.lift]lock [fact]lock /= -!lock. set qk := iteri k (fun i c => PolR.div_mixed_r tt _ (INR (i + 1).+1)) PolR.one in IHk *. rewrite (@Derive_ext _ (fun x => qk.[x] / (1+x*x) ^ (k+1) * INR (fact k.+1))%R); first last. move=> t; move/(_ t) in IHk; rewrite -pow_powerRZ in IHk. rewrite IHk /Rdiv Rmult_assoc Rinv_l ?Rmult_1_r //. exact: INR_fact_neq_0. clear IHk. rewrite PolR.horner_div_mixed_r PolR.horner_sub PolR.horner_add. rewrite PolR.horner_mul_mixed !PolR.horner_lift Derive_scal_l. rewrite Derive_div; first last. * by apply: pow_nonzero; apply: Rsqr_plus1_neq0. * by auto_derive. * exact: PolR.ex_derive_horner. rewrite Derive_pow; try by auto_derive. rewrite Derive_plus; try by auto_derive. rewrite Derive_const ?Rplus_0_l. rewrite Derive_mult; try by auto_derive. rewrite Derive_id. rewrite PolR.Derive_horner. rewrite -{1}(Rmult_1_r (qk^`().[x])) -Rmult_plus_distr_l. rewrite SuccNat2Pos.id_succ. rewrite -addnE addn1 Rmult_1_r Rmult_1_l; simpl predn. (* Now, some reals' bookkeeping *) rewrite -mul2n (fact_simpl k.+1) 2!mult_INR -[INR 2]/2%R. rewrite -pow_mult multE muln2 -addnn addSnnS pow_add. have ->: (((1 + x * x) ^ k.+1) = (1 + x ^ 2) * (1 + x * x) ^ k)%R by rewrite /= Rmult_1_r. change eq with (@eq R); field. repeat first [ split | exact: INR_fact_neq_0 | exact: not_0_INR | apply pow_nonzero, Rsqr_plus1_neq0 ]. } constructor. - by move=> *; rewrite PolR.size_grec1 Pol.size_grec1. - { move => {X n Hsubset Hex} X0 xi0 n Hx. apply: Pol.grec1_correct =>//. + move=> qi q m Hq. by repeat first [apply: Pol.div_mixed_r_correct| apply: Pol.sub_correct| apply: Pol.add_correct| apply: Pol.deriv_correct| apply: Pol.lift_correct| apply: Pol.mul_mixed_correct| apply: R_from_nat_correct]. + move=> qi q m Hq. by repeat first [apply: J.div_correct| apply: J.power_int_correct| apply: Pol.horner_correct| apply: J.add_correct| apply: J.sqr_correct| apply: I.fromZ_correct| exact: I.fromZ_small_correct| apply: Pol.one_correct]. + exact: Pol.one_correct. + move=> [/=|k]; last by rewrite /PolR.nth !nth_default //; apply: J.zero_correct. exact: J.atan_correct. } - done. - by move=> m x Hx; apply: ex_derive_n_is_derive_n (is_derive_n_atan m x). Qed. Definition TM_tan (X0 X : I.type) (n : nat) : rpa := let P := (T_tan prec X0 n) in let ic := I.cos prec X in if apart0 ic then RPA P (Ztech (T_tan prec) P (I.tan prec) X0 X n) else RPA P I.nai. Lemma is_derive_n_tan n x : cos x <> 0%R -> let q n := iteri n (fun i c => PolR.div_mixed_r tt (PolR.add tt c^`() (PolR.lift 2 c^`())) (INR i.+1)) (PolR.lift 1 PolR.one) in is_derive_n tan n x ((q n).[tan x] * INR (fact n)). Proof. move=> Hx q; move: n x Hx. help_is_derive_n n x. - by move=> x Hx; rewrite /= !Rsimpl. - move=> Hx; auto_derive. + by eapply ex_derive_is_derive; apply: is_derive_tan. + rewrite !Rsimpl; rewrite (is_derive_unique _ _ _ (is_derive_tan _ Hx)). ring. - exact: (open_comp cos (fun y => y <> 0%R) (fun y _ => continuous_cos y) (open_neq 0%R)). - move=> x Hx. move En1 : n.+1 => n1. (* Remember n.+1 as n1 to have a more tidy context after auto_derive *) auto_derive; repeat split. + apply: PolR.ex_derive_horner. + by eapply ex_derive_is_derive; apply: is_derive_tan. + rewrite Rmult_1_l. rewrite (is_derive_unique _ _ _ (is_derive_tan _ Hx)). rewrite PolR.Derive_horner [q n1.+1]iteriS -/(q n1). rewrite PolR.horner_div_mixed_r PolR.horner_add. rewrite !PolR.horner_lift. rewrite fact_simpl mult_INR. set A := (((q n1)^`()).[tan x] + ((q n1)^`()).[tan x] * tan x ^ 2)%R. rewrite /Rdiv. have->: (A * / INR n1.+1 * (INR n1.+1 * INR (fact n1)) = A * INR (fact n1) * (/ INR n1.+1 * INR n1.+1))%R by ring. rewrite Rinv_l; last exact: not_0_INR. rewrite /A; ring. Qed. Lemma size_TM_tan (X0 X : I.type) (n : nat) : Pol.size (approx (TM_tan X0 X n)) = n.+1. Proof. by rewrite /TM_tan; case: apart0; rewrite Pol.size_grec1. Qed. Lemma TM_tan_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_tan X0 X n) Xtan'. Proof. move=> Hsubset Hex. rewrite /TM_tan. case E0: apart0. apply i_validTM_Ztech with (TR.T_tan tt); last 2 first =>//. exact: I.tan_correct. constructor. - by move=> ? ?; rewrite PolR.size_grec1. - { (* The proof of this goal might be shortened by reusing is_derive_n_tan *) move=> {X0 n Hsubset Hex} x n k Hx H; rewrite /TR.T_tan /PolR.nth /PolR.grec1 (nth_grec1up_indep _ _ _ _ _ 0%R (m2 := k)) // nth_grec1up_last. have->: Derive_n (fun t => proj_val (Xtan' t)) k x = Derive_n tan k x. apply: (@Derive_n_ext_loc _ tan). have Hdef : cos x <> 0%R. move/apart0_correct in E0. by apply: E0; apply: J.cos_correct. eapply locally_open with (1 := open_comp cos (fun y => y <> 0%R) (fun y _ => continuous_cos y) (open_neq R0)) (3 := Hdef). move=> {Hdef Hx} x Hdef. by rewrite /Xtan' is_zero_false. rewrite last_grec1up // head_gloop1. rewrite [size _]/= subn0. have Hdef : cos x <> 0%R. move/apart0_correct in E0. by apply: E0; apply: J.cos_correct. elim: k H x {Hx} Hdef =>[|k IHk] H x Hdef. + by rewrite /= !Rsimpl. + move/ltnW in H; move/(_ H) in IHk. rewrite [INR]lock [PolR.lift]lock [fact]lock /= -!lock. set qk := iteri k (fun i c => PolR.div_mixed_r tt _ (INR (i + 0).+1)) (PolR.lift 1 PolR.one) in IHk *. rewrite (@Derive_ext_loc _ (fun x => qk.[tan x] * INR (fact k))%R); first last. eapply locally_open with (1 := open_comp cos (fun y => y <> 0%R) (fun y _ => continuous_cos y) (open_neq 0%R)) (3 := Hdef). move=> t Hdef'; move/(_ t Hdef') in IHk. rewrite IHk /Rdiv Rmult_assoc Rinv_l ?Rmult_1_r //. exact: INR_fact_neq_0. clear IHk. rewrite PolR.horner_div_mixed_r. rewrite PolR.horner_add addn0. rewrite !PolR.horner_lift Derive_scal_l. rewrite Derive_comp; first last. * by eexists; apply: is_derive_tan. * exact: PolR.ex_derive_horner. rewrite !PolR.Derive_horner. rewrite (is_derive_unique _ _ _ (is_derive_tan _ Hdef)). rewrite /Rdiv Rmult_assoc. rewrite -simpl_fact Rinv_involutive. change eq with (@eq R); ring. exact: INR_fact_neq_0. } constructor. - by move=> *; rewrite PolR.size_grec1 Pol.size_grec1. - { move => {X n Hsubset Hex E0} X0 xi0 n Hx. apply: Pol.grec1_correct =>//. + move=> qi q m Hq. by repeat first [apply: Pol.div_mixed_r_correct| apply: Pol.sub_correct| apply: Pol.add_correct| apply: Pol.deriv_correct| apply: Pol.lift_correct| apply: Pol.mul_mixed_correct| apply: R_from_nat_correct]. + move=> qi q m Hq. by repeat first [apply: J.div_correct| apply: J.power_int_correct| apply: Pol.horner_correct| apply: J.add_correct| apply: J.sqr_correct| apply: I.fromZ_correct| apply: Pol.one_correct| apply: J.tan_correct]. + apply: Pol.lift_correct; exact: Pol.one_correct. + move=> [/=|k]; rewrite /PolR.nth ?nth_default //; exact: J.zero_correct. } - { move => {n Hsubset Hex E0} X x Hx Dx n k Hk. apply/Pol.grec1_propagate =>//. move=> q _. apply/Pol.horner_propagate/contains_Xnan. rewrite -Dx. exact: I.tan_correct Hx. by rewrite Pol.size_grec1. } - move=> m x Hx. have {}E0: cos x <> R0. apply: apart0_correct E0. exact: J.cos_correct. eapply (@ex_derive_n_ext_loc tan); last first. exact: ex_derive_n_is_derive_n (is_derive_n_tan m E0). eapply locally_open with (1 := open_comp cos (fun y => y <> 0%R) (fun y _ => continuous_cos y) (open_neq 0%R)) (3 := E0). move => /= x1 Hx1. by rewrite /Xtan' is_zero_false. simpl. split =>//. by move=> *; apply I.nai_correct. by move=> Hx; rewrite /= I.nai_correct. by rewrite I.nai_correct. exact: Hsubset. exists (TR.T_tan tt x0 n); last by rewrite I.nai_correct. apply: Pol.grec1_correct; by repeat first [move=> *; apply: Pol.div_mixed_r_correct |apply: Pol.add_correct |apply: Pol.deriv_correct |apply: Pol.lift_correct |apply: Pol.deriv_correct |apply: R_from_nat_correct |move=> *; apply: Pol.horner_correct |apply: J.tan_correct |apply: Pol.lift_correct |apply: Pol.one_correct |move=> [|k]; rewrite /PolR.nth ?nth_default //; exact: J.zero_correct ]. Qed. (* Definition Ztech_sqrt prec P X0 X := let F := I.sqrt prec in let a := I.lower X in let b := I.upper X in let A := I.bnd a a in let B := I.bnd b b in (* If need be, we could replace Pol.horner with Bnd.ComputeBound *) let Da := I.sub prec (F A) (Pol.horner prec P (I.sub prec A X0)) in let Db := I.sub prec (F B) (Pol.horner prec P (I.sub prec B X0)) in let Dx0 := I.sub prec (F X0) (Pol.nth P 0) (* :-D *) in I.join (I.join Da Db) Dx0. *) Definition TM_sqrt (X0 X : I.type) (n : nat) : rpa := (* assuming X0 \subset X *) let P := (T_sqrt prec X0 n) in if gt0 X then RPA P (Ztech (T_sqrt prec) P (I.sqrt prec) X0 X n) else RPA P I.nai. Lemma size_TM_sqrt (X0 X : I.type) (n : nat) : Pol.size (approx (TM_sqrt X0 X n)) = n.+1. Proof. by rewrite /TM_sqrt; case: gt0; rewrite Pol.size_rec1. Qed. Lemma TM_sqrt_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_sqrt X0 X n) Xsqrt'. Proof. move=> Hsubset Hex. rewrite /TM_sqrt. case E1: gt0. apply i_validTM_Ztech with (TR.T_sqrt tt); last 2 first =>//. exact: I.sqrt_correct. constructor. - by move=> *; rewrite PolR.size_rec1. - { move=> {X0 n Hsubset Hex} x n k Hx Hkn. rewrite (Derive_n_ext_loc _ sqrt); last first. apply: (locally_open (fun t => 0 < t)%R); [exact: open_gt| |exact: gt0_correct E1]. by move=> y Hy; rewrite /Xsqrt' //; apply: Rlt_le. rewrite /PolR.nth; elim: k Hkn => [|k IHk] Hkn. by rewrite rec1up_co0 /= Rdiv_1. rewrite nth_rec1up ifF; last by apply: negbTE; rewrite ltnNge Hkn. move/(_ (ltnW Hkn)) in IHk. rewrite nth_rec1up ifF in IHk; last by apply: negbTE; rewrite ltnNge ltnW. rewrite iteriS IHk /TR.sqrt_rec. have gt0_x : (0 < x)%R by move/(gt0_correct Hx) in E1. rewrite !(is_derive_n_unique _ _ _ _ (is_derive_n_sqrt _ _ gt0_x)). rewrite big_ord_recr. set big := \big[Rmult/1%R]_(i < k) _. simpl ([the Monoid.law _ of Rmult] _ _). rewrite fact_simpl mult_INR !addn1. have->: (/2 - INR k.+1 = /2 - INR k + (- 1))%R by rewrite -addn1 plus_INR /=; ring. rewrite Rpower_plus Rpower_Ropp Rpower_1 // /Rdiv. have->: ((/ 2 - INR k) = (INR 1 - INR 2 * INR k.+1.-1) / INR 2)%R by simpl; field. move/(gt0_correct Hx)/Rgt_not_eq in E1. simpl (INR 1). simpl (INR 2). rewrite /=; field. split; [exact: INR_fact_neq_0|split; [|exact: E1]]. change (INR k.+1 <> 0%R); exact: not_0_INR. } constructor. - by move=> *; rewrite PolR.size_rec1 Pol.size_rec1. - { move => {X n Hsubset Hex E1} X0 xi0 n Hx. apply: Pol.rec1_correct =>//. by move=> *; repeat first [apply: J.div_correct |apply: J.mul_correct |apply: J.sub_correct |apply: I.fromZ_correct |apply: J.mul_correct |apply: I.fromZ_correct |exact: I.fromZ_small_correct |apply: R_from_nat_correct ]. exact: J.sqrt_correct. } - move=> I r Ir /= {E1 Hex Hsubset X X0 n} //. - { clear - E1. move=> n x Hx. move/(gt0_correct Hx) in E1. apply: (ex_derive_n_ext_loc sqrt). apply: locally_open E1; first exact: open_gt. simpl=> y Hy; rewrite /Xsqrt' //. exact: ex_derive_n_is_derive_n (is_derive_n_sqrt n x E1). } simpl. split =>//. by move=> *; rewrite I.nai_correct. by rewrite I.nai_correct. exact: Hsubset. exists (TR.T_sqrt tt x0 n). apply: Pol.rec1_correct. by move=> *; repeat first [apply: J.div_correct |apply: J.mul_correct |apply: J.sub_correct |apply: I.fromZ_correct |apply: J.mul_correct |apply: I.fromZ_correct |exact: I.fromZ_small_correct |apply: R_from_nat_correct ]. exact: J.sqrt_correct. by rewrite I.nai_correct. Qed. Definition I_invsqrt prec x := I.inv prec (I.sqrt prec x). Definition TM_invsqrt (X0 X : I.type) (n : nat) : rpa := (* assuming X0 \subset X *) let P := (T_invsqrt prec X0 n) in if gt0 X then RPA P (Ztech (T_invsqrt prec) P (I_invsqrt prec) X0 X n) else RPA P I.nai. Lemma size_TM_invsqrt (X0 X : I.type) (n : nat) : Pol.size (approx (TM_invsqrt X0 X n)) = n.+1. Proof. by rewrite /TM_invsqrt; case: gt0; rewrite Pol.size_rec1. Qed. Ltac Inc := rewrite (*?*) INR_IZR_INZ; apply: I.fromZ_correct. Lemma TM_invsqrt_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_invsqrt X0 X n) (fun x => Xinv (Xsqrt (Xreal x))). Proof. move=> Hsubset Hex. rewrite /TM_invsqrt. case E1: gt0. apply i_validTM_Ztech with (TR.T_invsqrt tt); last 2 first =>//. move=> Y y Hy. replace (Xbind _ y) with (Xinv (Xsqrt y)) by now case y. apply: I.inv_correct; exact: I.sqrt_correct. constructor. - by move=> *; rewrite PolR.size_rec1. - { move=> {X0 n Hsubset Hex} x n k Hx Hkn. rewrite (Derive_n_ext_loc _ (fun t => / sqrt t)); last first. apply: (locally_open (fun t => 0 < t)%R); [exact: open_gt| |exact: gt0_correct E1]. move=> y Hy. rewrite /Xinv' /Xsqrt' /= ?is_zero_false //. now apply Rgt_not_eq, sqrt_lt_R0. rewrite /PolR.nth; elim: k Hkn => [|k IHk] Hkn. by rewrite rec1up_co0 /= Rdiv_1. rewrite nth_rec1up ifF; last by apply: negbTE; rewrite ltnNge Hkn. move/(_ (ltnW Hkn)) in IHk. rewrite nth_rec1up ifF in IHk; last by apply: negbTE; rewrite ltnNge ltnW. rewrite iteriS IHk /TR.invsqrt_rec. have gt0_x : (0 < x)%R by move/(gt0_correct Hx) in E1. rewrite !(is_derive_n_unique _ _ _ _ (is_derive_n_invsqrt _ _ gt0_x)). rewrite big_ord_recr. set big := \big[Rmult/1%R]_(i < k) _. simpl ([the Monoid.law _ of Rmult] _ _). rewrite fact_simpl mult_INR !addn1. have->: (-/2 - INR k.+1 = -/2 - INR k + (- 1))%R by rewrite -addn1 plus_INR /=; ring. rewrite Rpower_plus Rpower_Ropp Rpower_1 // /Rdiv. have->: (-/ 2 - INR k = - (INR 1 + INR 2 * INR k.+1.-1) / INR 2)%R by simpl; field. move/(gt0_correct Hx)/Rgt_not_eq in E1. simpl (INR 1). simpl (INR 2). rewrite /=; field. split; [exact: INR_fact_neq_0|split; [|exact: E1]]. change (INR k.+1 <> 0%R); exact: not_0_INR. } constructor. - by move=> *; rewrite PolR.size_rec1 Pol.size_rec1. - { move => {X n Hsubset Hex E1} X0 xi0 n Hx. apply: Pol.rec1_correct =>//. by move=> *; repeat first [apply: J.div_correct |apply: J.mul_correct |apply: J.sub_correct |apply: I.fromZ_correct |apply: J.mul_correct |apply: I.fromZ_correct |exact: I.fromZ_small_correct |apply/eqNaiPy: R_from_nat_correct |apply: J.add_correct |apply: J.neg_correct |Inc ]. apply: J.inv_correct; exact: J.sqrt_correct. } - move=> I r Ir {X0 X n Hsubset Hex E1} Dx n k Hkn. apply: Pol.rec1_propagate. - move=> q m Hq; rewrite /invsqrt_rec. rewrite I.div_propagate_l //. rewrite I.mul_propagate_r //; exact:eqNaiP. - apply/contains_Xnan; rewrite -Dx. exact/I.inv_correct/I.sqrt_correct. by rewrite Pol.size_rec1. - { clear - E1. move=> n x Hx. move/(gt0_correct Hx) in E1. apply: (ex_derive_n_ext_loc (fun t => / sqrt t)). apply: locally_open E1; first exact: open_gt. simpl=> y Hy; rewrite /Xsqrt' /Xinv' /Xbind ?is_zero_false //. apply: Rgt_not_eq; exact: sqrt_lt_R0. exact: ex_derive_n_is_derive_n (is_derive_n_invsqrt n x E1). } constructor =>//. by move=> *; rewrite I.nai_correct. by move=> Hx; rewrite /= I.nai_correct. by rewrite I.nai_correct. exact: Hsubset. exists (TR.T_invsqrt tt x0 n). apply: Pol.rec1_correct. by move=> *; repeat first [apply: J.div_correct |apply: J.mul_correct |apply: J.sub_correct |apply: I.fromZ_correct |apply: J.mul_correct |apply: I.fromZ_correct |exact: I.fromZ_small_correct |apply/eqNaiPy: R_from_nat_correct |apply: J.add_correct |apply: J.neg_correct |Inc ]. by apply: J.inv_correct; apply: J.sqrt_correct. by rewrite I.nai_correct. Qed. Definition TM_power_int (p : Z) (X0 X : I.type) (n : nat) := let P := (T_power_int prec p X0 n) in if p is Z.neg _ then if apart0 X then RPA P (Ztech (T_power_int prec p) P (fun x => I.power_int prec x p) X0 X n) else RPA P I.nai else RPA P (Ztech (T_power_int prec p) P (fun x => I.power_int prec x p) X0 X n). Lemma size_TM_power_int (p : Z) (X0 X : I.type) (n : nat) : Pol.size (approx (TM_power_int p X0 X n)) = n.+1. Proof. rewrite /TM_power_int. case: p => [|p|p]; last case: apart0; by rewrite (@Pol.size_dotmuldiv (n.+1)) ?(Pol.size_rec1, size_rec1up). Qed. Lemma toR_power_int p x : (0 <= p)%Z \/ x <> R0 -> powerRZ x p = proj_val (Xpower_int' x p). Proof. case => [Hp|Hx]. by case: p Hp =>// p []. by case: p =>//; rewrite /Xpower_int' is_zero_false. Qed. Lemma toR_power_int_loc p x : (0 <= p)%Z \/ x <> R0 -> locally x (fun t => powerRZ t p = proj_val (Xpower_int' t p)). Proof. case: p => [|p|p] Hx. - eapply (locally_open (fun _ => True)) =>//; exact: open_true. - eapply (locally_open (fun _ => True)) =>//; exact: open_true. - eapply (@locally_open _ (fun x => x <> 0)%R) =>//; first exact: open_neq. by move => {Hx} x Hx; rewrite /= is_zero_false. case: Hx => // ; by case. Qed. Lemma TM_power_int_correct_aux (p : Z) (x0 : R) (X0 X : I.type) n : (0 <= p)%Z \/ apart0 X -> subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (let P := (T_power_int prec p X0 n) in RPA P (Ztech (T_power_int prec p) P (fun x => I.power_int prec x p) X0 X n)) (fun x => Xpower_int' x p). Proof. move=> Hyp Hsubset Hex. apply i_validTM_Ztech with (TR.T_power_int tt p); last 2 first =>//. exact: I.power_int_correct. constructor. - by move=> {n} ? n; rewrite ?(@PolR.size_dotmuldiv n.+1, @Pol.size_dotmuldiv n.+1, Pol.size_rec1, size_rec1up, PolR.size_rec1) //. - { move=> x m k Hx Hk. rewrite /TR.T_power_int PolR.nth_dotmuldiv ifF; last first. rewrite PolR.size_rec1. rewrite size_falling_seq size_fact_seq. by rewrite !orbb ltnNge Hk. case: k Hk => [|k] Hk. simpl Derive_n; simpl INR; rewrite Rdiv_1. rewrite falling_seq_correct // fact_seq_correct //. rewrite big_mkord big_ord0. rewrite [PolR.nth _ _]nth_rec1up /= Rdiv_1 Rmult_1_l. rewrite toR_power_int //. by case: Hyp => [Hyp|Hyp]; by [left|right; exact: apart0_correct Hyp]. rewrite -(Derive_n_ext_loc _ _ k.+1 x (toR_power_int_loc _)); last by case: Hyp => [Hyp|Hyp]; by [left|right; exact: apart0_correct Hyp]. symmetry; apply: (Rmult_eq_reg_r (INR (fact k.+1))); last exact: INR_fact_neq_0. rewrite {1}/Rdiv Rmult_assoc Rinv_l ?Rmult_1_r; last exact: INR_fact_neq_0. clear - Hyp Hk Hx. rewrite /powerRZ. case: p Hyp Hx =>[|p|p] Hyp Hx. - rewrite Derive_n_const. rewrite /PolR.nth /PolR.rec1 nth_rec1up ifF; last first. by apply: negbTE; rewrite ltnNge Hk. rewrite iteriS /TR.pow_aux_rec ifF ?(Rmult_0_r, Rmult_0_l) //. apply: negbTE; rewrite negb_or /=; apply/negP; move/Z.geb_le. by change Z0 with (Z.of_nat O); move/Nat2Z.inj_le/leP; rewrite addn1. - rewrite (is_derive_n_unique _ _ _ _ (is_derive_n_pow _ _ _ _)); last first. exact/ltP/Pos2Nat.is_pos. rewrite falling_seq_correct // fact_seq_correct //. have Hpow: PolR.nth (PolR.rec1 (TR.pow_aux_rec tt (Z.pos p) x) (x ^ Pos.to_nat p) m)%R k.+1 = if (Z.of_nat (k + 1) <=? Z.pos p)%Z then (x ^ (Pos.to_nat p - k.+1))%R else 0%R. rewrite /PolR.nth /PolR.rec1 nth_rec1up. rewrite ifF; last first. by apply: negbTE; rewrite ltnNge Hk. case: Z.leb_spec. move=> /Zle_is_le_bool Hpk; rewrite iteriS /TR.pow_aux_rec Z.geb_leb Hpk. rewrite orbT pow_powerRZ; congr powerRZ. rewrite Nat2Z.inj_sub ?(positive_nat_Z, addn1) //. apply/Nat2Z.inj_le; rewrite positive_nat_Z -addn1. by move: Hpk; case: Z.leb_spec. move=> Hpk; rewrite iteriS /TR.pow_aux_rec Z.geb_leb ifF //. apply: negbTE; rewrite negb_or /=. by rewrite -Z.ltb_antisym; move/Zlt_is_lt_bool in Hpk. case: (Z.leb_spec (Z.of_nat (k + 1)) (Z.pos p)) => Hpk. move/Zle_is_le_bool in Hpk. rewrite Hpow Hpk. rewrite /Rdiv; ring_simplify (*!*). rewrite -INR_IZR_INZ Rmult_assoc Rinv_l; last exact: INR_fact_neq_0. rewrite Rmult_1_r Rmult_comm; congr Rmult. rewrite (big_morph IZR (id1 := 1%R) (op1 := Rmult)) //; last exact: mult_IZR. rewrite big_mkord; apply: eq_bigr => [[i Hi] _]. rewrite INR_IZR_INZ. rewrite Nat2Z.inj_sub ?(positive_nat_Z, addn1) //=. apply/leP; rewrite ltnS in Hi. apply: leq_trans Hi _. move/Zle_is_le_bool in Hpk. rewrite -positive_nat_Z in Hpk; move/Nat2Z.inj_le/leP in Hpk. by apply: leq_trans _ Hpk; rewrite addn1. rewrite [in LHS]big_ord_recr big_mkord [in RHS]big_ord_recr. try simpl (Rmul_monoid _ _). have->: Pos.to_nat p - k = 0. rewrite -positive_nat_Z addn1 in Hpk; move/Nat2Z.inj_lt/ltP in Hpk. rewrite ltnS in Hpk. by apply/eqP; rewrite subn_eq0. rewrite Hpow ifF /= ?Rmult_0_l ?Rmult_0_r ?Rmult_0_l//. apply: negbTE. by move/Zlt_is_lt_bool: Hpk; rewrite Z.ltb_antisym =>->. - rewrite (is_derive_n_unique _ _ _ _ (is_derive_n_inv_pow _ _ _ _ _)); first last. case: Hyp; first case =>//. by move/apart0_correct; apply. exact/ltP/Pos2Nat.is_pos. rewrite falling_seq_correct // fact_seq_correct //. have Hpow: PolR.nth (PolR.rec1 (TR.pow_aux_rec tt (Z.neg p) x) (/ x ^ Pos.to_nat p) m)%R k.+1 = (/ x ^ (Pos.to_nat p + k.+1))%R. rewrite /PolR.nth /PolR.rec1 nth_rec1up. rewrite ifF; last first. by apply: negbTE; rewrite ltnNge Hk. rewrite iteriS /TR.pow_aux_rec addn1 /= Pos.of_nat_succ. by rewrite Pos2Nat.inj_add Nat2Pos.id. rewrite Hpow. rewrite /Rdiv; ring_simplify (*!*). rewrite -INR_IZR_INZ Rmult_assoc Rinv_l; last exact: INR_fact_neq_0. rewrite Rmult_1_r Rmult_comm; congr Rmult. rewrite (big_morph IZR (id1 := 1%R) (op1 := Rmult)) //; last exact: mult_IZR. rewrite big_mkord; apply: eq_bigr => [[i Hi] _]. rewrite INR_IZR_INZ -opp_IZR; congr IZR. rewrite Nat2Z.inj_add positive_nat_Z. by rewrite Z.opp_add_distr. } constructor. - by move=> {n} ? ? n; rewrite ?(@PolR.size_dotmuldiv n.+1, @Pol.size_dotmuldiv n.+1, Pol.size_rec1, size_rec1up, PolR.size_rec1) //. - { move=> {x0 n Hsubset Hex} X0 x0 n Hx0. unfold T_power_int, TR.T_power_int. apply: Pol.dotmuldiv_correct. by rewrite size_falling_seq size_fact_seq. apply: Pol.rec1_correct =>//. + rewrite /pow_aux_rec /TR.pow_aux_rec; move=> _ _ m _. case: ifP => H. exact: J.power_int_correct. apply I.mask_correct', J.zero_correct. + exact: J.power_int_correct. } - { move=> {X0 n Hsubset Hex} Y x Hx Dx n k Hk. rewrite /T_power_int. apply: Pol.dotmuldiv_propagate; last 1 first. rewrite (@Pol.size_dotmuldiv n.+1) //. by rewrite Pol.size_rec1. by rewrite size_falling_seq. by rewrite size_fact_seq. by rewrite Pol.size_rec1 size_falling_seq. by rewrite Pol.size_rec1 size_fact_seq. apply: Pol.rec1_propagate. move=> y m _. rewrite /pow_aux_rec ifT. apply/contains_Xnan. have->: Xnan = Xpower_int^~ (p - Z.of_nat m)%Z (Xreal x). move: Dx; rewrite /Xpower_int /Xpower_int' /Xbind. by case Ep: p =>//; case: is_zero =>//; case: m. exact: I.power_int_correct. match goal with |- is_true ?a => rewrite -(negbK a) negb_or end. apply/negP; case/andP => /negbTE H0 /negbTE Hm. move: Dx; rewrite /Xpower_int. by case: {Hyp} p H0 Hm. apply/contains_Xnan. rewrite -Dx. exact: I.power_int_correct Hx. } - move=> k x Hx. have [Hp|/(apart0_correct Hx) Nx] := Hyp. apply: (ex_derive_n_ext_loc _ _ _ _ (@toR_power_int_loc p x _)). by left. by apply: ex_derive_n_powerRZ; left. apply: (ex_derive_n_ext_loc _ _ _ _ (@toR_power_int_loc p x _)). by right. by apply: ex_derive_n_powerRZ; right. Qed. Lemma TM_power_int_correct (p : Z) (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_power_int p X0 X n) (fun x => Xpower_int' x p). Proof. move=> Hsubs Hnex. rewrite /TM_power_int. case Ep: p => [|p'|p']; last case E0: apart0; try apply: TM_power_int_correct_aux; intuition. constructor =>//. by move=> *; rewrite I.nai_correct. by move=> Hx; rewrite /= I.nai_correct. by rewrite I.nai_correct. exact: Hsubs. exists (TR.T_power_int tt (Z.neg p') x0 n). apply: Pol.dotmuldiv_correct. by rewrite size_falling_seq size_fact_seq. apply: Pol.rec1_correct. rewrite /pow_aux_rec /TR.pow_aux_rec -Ep. move=> ai a m Ha. case: ((p =? Z.of_nat m))%Z. exact: J.power_int_correct. apply I.mask_correct', J.zero_correct. exact: J.power_int_correct. by move=> x Hx; rewrite I.nai_correct. Qed. Definition TM_inv (X0 X : I.type) (n : nat) := let P := (T_inv prec X0 n) in if apart0 X then RPA P (Ztech (T_inv prec) P (I.inv prec) X0 X n) else RPA P I.nai. Lemma size_TM_inv (X0 X : I.type) (n : nat) : Pol.size (approx (TM_inv X0 X n)) = n.+1. Proof. by rewrite /TM_inv; case: apart0 =>/=; rewrite Pol.size_rec1. Qed. Lemma TM_inv_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_inv X0 X n) Xinv'. Proof. move=> Hsubset Hex. rewrite /TM_inv /=. case E0: apart0. apply i_validTM_Ztech with (TR.T_inv tt); last 2 first =>//. exact: I.inv_correct. constructor. - by move=> {n} ? n; rewrite PolR.size_rec1. - { move=> {X0 n Hsubset Hex} x n k Hx Hkn. rewrite (Derive_n_ext_loc _ Rinv); last first. apply: (locally_open (fun t => t <> 0)%R); [exact: open_neq| |exact: apart0_correct E0]. by move=> y Hy; rewrite /Xinv' is_zero_false. rewrite /PolR.nth; elim: k Hkn => [|k IHk] Hkn. by rewrite rec1up_co0 /= Rdiv_1. rewrite nth_rec1up ifF; last by apply: negbTE; rewrite ltnNge Hkn. move/(_ (ltnW Hkn)) in IHk. rewrite nth_rec1up ifF in IHk; last by apply: negbTE; rewrite ltnNge ltnW. rewrite iteriS IHk /TR.inv_rec. have neq0_x : (x <> 0)%R by move/(apart0_correct Hx) in E0. rewrite !(is_derive_n_unique _ _ _ _ (is_derive_n_inv _ _ neq0_x)). rewrite big_ord_recr. set big := \big[Rmult/1%R]_(i < k) _. try simpl (Rmul_monoid _). rewrite /Rdiv !Rmult_assoc; congr Rmult. rewrite fact_simpl mult_INR. rewrite !add1n -[(x ^ k.+2)%R]/(x * x ^ k.+1)%R. set Xk1 := (x ^ k.+1)%R. set k_ := INR (fact k). set k1 := INR k.+1. rewrite Rinv_mult_distr //; last exact: pow_nonzero. rewrite Rinv_mult_distr; try solve [exact: INR_fact_neq_0|exact: not_0_INR]. rewrite !Rmult_assoc -Ropp_inv_permute //. have->: (- k1 * (/ x * (/ Xk1 * (/ k1 * / k_))))%R = ((k1 * / k1) * - (/ x * (/ Xk1 * (/ k_))))%R by ring. rewrite Rinv_r; last exact: not_0_INR. ring. } constructor. - by move=> {n} ? ? n; rewrite PolR.size_rec1 Pol.size_rec1. - { move=> {X0 n Hsubset Hex} X1 x1 n Hx0. apply: Pol.rec1_correct; last exact: J.inv_correct. move=> ai a m Ha; apply: J.div_correct =>//. exact: J.neg_correct. } - { move=> {X0 n Hsubset Hex} Y x Hx Dx n k Hk. apply/Pol.rec1_propagate =>//. - move=> q m Hqm; apply/contains_Xnan; rewrite /inv_rec. by rewrite I.div_propagate_l. - apply/contains_Xnan. rewrite -Dx. exact: (I.inv_correct _ _ (Xreal x)). - by rewrite Pol.size_rec1. } - { move=> {X0 Hsubset Hex} n x Hx. move/(apart0_correct Hx) in E0. apply: (ex_derive_n_ext_loc Rinv). apply: (locally_open (fun t => t <> 0)%R) =>//. exact: open_neq. by simpl=> y Hy; rewrite /Xinv' is_zero_false. exact: ex_derive_n_is_derive_n (is_derive_n_inv n x E0). } split =>//. by move=> *; rewrite I.nai_correct. by move=> Hx; rewrite /= I.nai_correct. by rewrite I.nai_correct. exact: Hsubset. exists (TR.T_inv tt x0 n). apply: Pol.rec1_correct. by move=> *; repeat first [apply: J.div_correct |apply: J.inv_correct |apply: J.neg_correct ]. exact: J.inv_correct. by rewrite I.nai_correct. Qed. Definition TM_ln (X0 X : I.type) (n : nat) : rpa := let P := (T_ln prec X0 n) in if gt0 X then RPA P (Ztech (T_ln prec) P (I.ln prec) X0 X n) else RPA P I.nai. Lemma size_TM_ln (X0 X : I.type) (n : nat) : Pol.size (approx (TM_ln X0 X n)) = n.+1. Proof. by rewrite /TM_ln; case: gt0; case: n => [|n] /=; rewrite !sizes ?(@Pol.size_dotmuldiv n.+1, Pol.size_rec1, size_rec1up, size_behead). Qed. Lemma powerRZ_opp x n : x <> 0%R -> powerRZ x (- n) = / (powerRZ x n). Proof. move=> Hx. case: n =>[|p|p] //; first by rewrite Rinv_1. rewrite Rinv_involutive //. exact: pow_nonzero. Qed. Lemma TM_ln_correct (x0 : R) (X0 X : I.type) n : subset' (I.convert X0) (I.convert X) -> contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) (TM_ln X0 X n) Xln'. Proof. move=> Hsubset Hex. rewrite /TM_ln. case E0: gt0. apply i_validTM_Ztech with (TR.T_ln tt); last 2 first =>//. exact: I.ln_correct. constructor. - by move=> {n} x [|n]; rewrite /TR.T_ln // !sizes ?(@PolR.size_dotmuldiv n.+1, PolR.size_rec1, size_rec1up, size_behead). - { move=> {X0 n Hsubset Hex} x n k Hx Hkn. rewrite (Derive_n_ext_loc _ ln); last first. apply: (locally_open (fun t => 0 < t)%R); [exact: open_gt| |exact: gt0_correct E0]. by move=> y Hy; rewrite /Xln' is_positive_true. rewrite /PolR.nth; case: k Hkn => [|k] Hkn; first by rewrite Rdiv_1. case: n Hkn => [|n] Hkn //. rewrite [nth _ _ _]PolR.nth_dotmuldiv ifF; last first. rewrite PolR.size_rec1. rewrite size_falling_seq size_behead size_fact_seq. by rewrite !orbb ltnNge -ltnS Hkn. move/(gt0_correct Hx) in E0. case: k Hkn => [|k] Hkn. simpl Derive_n; simpl INR; rewrite Rdiv_1. rewrite falling_seq_correct // nth_behead fact_seq_correct //. rewrite big_mkord big_ord0. rewrite [PolR.nth _ _]nth_rec1up /= Rdiv_1 Rmult_1_l. by rewrite (is_derive_unique _ _ _ (is_derive_ln _ E0)) Rmult_1_r. symmetry; apply: (Rmult_eq_reg_r (INR (fact k.+2))); last exact: INR_fact_neq_0. rewrite {1}/Rdiv Rmult_assoc Rinv_l ?Rmult_1_r; last exact: INR_fact_neq_0. rewrite (is_derive_n_unique _ _ _ _ (is_derive_n_ln _ _ _)) //. rewrite falling_seq_correct // nth_behead fact_seq_correct //. have Hpow: (PolR.nth (PolR.rec1 (TR.pow_aux_rec tt (-1) x) (powerRZ x (-1)) n)%R k.+1 = / x ^ (1 + k.+1))%R. rewrite /PolR.nth /PolR.rec1 nth_rec1up. rewrite ifF; last first. by apply: negbTE; rewrite ltnNge -ltnS Hkn. rewrite iteriS /TR.pow_aux_rec. suff->: powerRZ x (-1 - Z.of_nat (k + 1))%Z = / (x ^ (1 + k.+1))%R by done. rewrite pow_powerRZ -powerRZ_opp; last exact: Rgt_not_eq. congr powerRZ; change (-1)%Z with (- Z.of_nat 1)%Z. rewrite -Z.add_opp_r -Z.opp_sub_distr -Z.add_opp_r Z.opp_involutive. by f_equal; rewrite -Nat2Z.inj_add; f_equal; rewrite plusE addn1. rewrite Hpow big_mkord. rewrite -INR_IZR_INZ /Rdiv Rmult_assoc. rewrite (big_morph IZR (id1 := 1%R) (op1 := Rmult)) //; last exact: mult_IZR. set bigRhs := \big[Rmult/1%R]_i IZR _. set fk2 := INR (fact k.+2). have->: (bigRhs * / fk2 * (/ x ^ (1 + k.+1) * fk2) = (/ fk2 * fk2) * bigRhs * / (x ^ (1 + k.+1)))%R by ring. rewrite Rinv_l ?Rmult_1_l; last exact: INR_fact_neq_0. congr Rmult; rewrite {}/bigRhs. apply: eq_bigr => [[i Hi] _]. rewrite INR_IZR_INZ. rewrite Nat2Z.inj_add -opp_IZR; congr IZR. simpl Z.of_nat. by rewrite Z.opp_add_distr. } constructor. - by move=> {n Hsubset E0} X x [|n]; rewrite /TR.T_ln !sizes //= ?(@Pol.size_dotmuldiv n.+1, Pol.size_rec1, @PolR.size_dotmuldiv n.+1, PolR.size_rec1, size_rec1up, size_behead). - { move=> {x0 n Hsubset Hex} X0 x0 n Hx0. rewrite /T_ln /TR.T_ln. apply: Pol.polyCons_correct; last exact: J.ln_correct. case: n => [|n]; first exact: Pol.polyNil_correct. apply: Pol.dotmuldiv_correct; first by rewrite size_falling_seq size_behead size_fact_seq. apply: Pol.rec1_correct; first move=> *; repeat first [apply: J.div_correct |apply: J.power_int_correct |apply: J.ln_correct ]; exact: I.mask_correct'. } - { move=> {X0 n Hsubset Hex} Y x Hx Dx n k Hk. apply: Pol.polyCons_propagate. - apply/contains_Xnan. rewrite -Dx. exact: I.ln_correct Hx. - case: n Hk => [|n] Hk m; first by rewrite Pol.size_polyNil. rewrite ?(@Pol.size_dotmuldiv n.+1, Pol.size_rec1, size_falling_seq, size_behead, size_fact_seq) //. move=> Hm. apply: Pol.dotmuldiv_propagate; rewrite ?(size_falling_seq, size_behead, size_fact_seq) ?Pol.size_rec1 //. apply: Pol.rec1_propagate. move=> q l Hq. apply J.power_int_propagate, I.mask_propagate_r, contains_Xnan. by rewrite -Dx; apply: I.ln_correct Hx. apply J.power_int_propagate, I.mask_propagate_r, contains_Xnan. by rewrite -Dx; apply: I.ln_correct Hx. by rewrite ?(@Pol.size_dotmuldiv n.+1, Pol.size_rec1, size_falling_seq, size_behead, size_fact_seq). - rewrite Pol.size_polyCons. case: n Hk => [|n] Hk; first by rewrite ltnS Pol.size_polyNil. by rewrite ?(@Pol.size_dotmuldiv n.+1, Pol.size_rec1, size_falling_seq, size_behead, size_fact_seq). } - { clear - E0. move=> n x Hx. move/(gt0_correct Hx) in E0. apply: (ex_derive_n_ext_loc ln). apply: locally_open E0; first exact: open_gt. by simpl=> t Ht; rewrite /Xln' is_positive_true. exact: ex_derive_n_is_derive_n (is_derive_n_ln n x E0). } split =>//. by move=> *; rewrite I.nai_correct. by move=> Hx; rewrite /= I.nai_correct. by rewrite I.nai_correct. exact: Hsubset. exists (TR.T_ln tt x0 n). apply: Pol.polyCons_correct; case: n =>[|n]/=; first exact: Pol.polyNil_correct. - apply: Pol.dotmuldiv_correct; first by rewrite size_falling_seq size_behead size_fact_seq. apply: Pol.rec1_correct; first move=> *; repeat first [apply: J.div_correct |apply: J.power_int_correct |apply: J.ln_correct ]; exact: I.mask_correct'. - exact: J.ln_correct. - exact: J.ln_correct. by rewrite I.nai_correct. Qed. (******************************************************************************) (** The rest of the file is devoted to arithmetic operations on Taylor models *) (******************************************************************************) Local Notation "a + b" := (Xadd a b). Local Notation "a - b" := (Xsub a b). Lemma TM_add_correct (x0 : R) (X : interval) (TMf TMg : rpa) f g : i_validTM x0 X TMf f -> i_validTM x0 X TMg g -> i_validTM x0 X (TM_add TMf TMg) (fun xr => Xadd (f xr) (g xr)). Proof. move=> [Fdef Fnai Fzero Fsubs Fmain] [Gdef Gnai Gzero Gsubs Gmain]. have HL : forall x : R, contains X (Xreal x) -> Xadd (f x) (g x) = Xnan -> I.convert (I.add prec (error TMf) (error TMg)) = IInan. move=> x Hx. case Ef: (f x) => [|fx]. rewrite I.add_propagate_l //; exact: Fdef Ef. case Eg: (g x) => [|gx //]. rewrite I.add_propagate_r //; exact: Gdef Eg. split=>//=. by move=> H; move/(_ H) in Fnai; rewrite I.add_propagate_l. rewrite -(Rplus_0_l 0). exact: J.add_correct. move: Fmain Gmain => [pf Hf1 Hf2] [pg Hg1 Hg2]. exists (PolR.add tt pf pg); first exact: Pol.add_correct. move=> x Hx /=. rewrite PolR.horner_add. case E0: (I.convert (I.add prec _ _)) {HL} (HL x Hx) => [|zl zu] //. set pfx := pf.[_]; set pgx := pg.[_]. case Ef: f => [|fx]. by move => ->. case Eg: g => [|gx]. by move => ->. intros _. rewrite /proj_val /Xbind2 -E0. replace (fx + gx - (pfx + pgx))%R with ((fx - pfx) + (gx - pgx))%R by ring. apply: J.add_correct. rewrite -[fx](f_equal proj_val Ef). exact: Hf2. rewrite -[gx](f_equal proj_val Eg). exact: Hg2. Qed. Lemma TM_opp_correct (x0 : R) (X : interval) (TMf : rpa) f : i_validTM x0 X TMf f -> i_validTM x0 X (TM_opp TMf) (fun xr => Xneg (f xr)). Proof. move=> [Hdef Hnai Hzero Hsubset /= Hmain]. have HL : forall x : R, contains X (Xreal x) -> Xneg (f x) = Xnan -> I.convert (I.neg (error TMf)) = IInan. move=> x Hx Dx. apply J.neg_propagate, (Hdef x Hx). by case: (f x) Dx. split=>//. by move=> HX; rewrite J.neg_propagate // Hnai. rewrite -Ropp_0. exact: J.neg_correct. have [Q H1 H2] := Hmain. exists (PolR.opp Q); first exact: Pol.opp_correct. move=> x Hx. rewrite PolR.horner_opp. case Efx: (f x) (H2 x Hx) => [|fx] /=. rewrite /Rminus 2!Rplus_0_l. exact: J.neg_correct. replace (- fx - - Q.[x - x0])%R with (-(fx - Q.[x - x0]))%R by ring. exact: J.neg_correct. Qed. Lemma TM_sub_correct (x0 : R) (X : interval) (TMf TMg : rpa) f g : i_validTM x0 X TMf f -> i_validTM x0 X TMg g -> i_validTM x0 X (TM_sub TMf TMg) (fun xr => Xsub (f xr) (g xr)). Proof. move=> [Fdef Fnai Fzero Hsubset /= Fmain] [Gdef Gnai Gzero _ /= Gmain]. have HL : forall x : R, contains X (Xreal x) -> Xsub (f x) (g x) = Xnan -> I.convert (I.sub prec (error TMf) (error TMg)) = IInan. move=> x Hx. case Ef: (f x) => [|fx]. rewrite I.sub_propagate_l //; exact: Fdef Ef. case Eg: (g x) => [|gx //]. rewrite I.sub_propagate_r //; exact: Gdef Eg. split=>//=. by move=> HX; rewrite I.sub_propagate_l // Fnai. suff->: Xreal 0 = (Xreal 0 - Xreal 0)%XR by apply: I.sub_correct. by rewrite /= Rminus_0_r. move: Fmain Gmain => [pf Hf1 Hf2] [pg Hg1 Hg2]. exists (PolR.sub tt pf pg); first exact: Pol.sub_correct. move=> x Hx /=. rewrite PolR.horner_sub. case E0: (I.convert (I.sub prec _ _)) {HL} (HL x Hx) => [|zl zu] //. set pfx := pf.[_]; set pgx := pg.[_]. case Ef: f => [|fx]. by move => ->. case Eg: g => [|gx]. by move => ->. intros _. rewrite /Xbind2 /proj_val -E0. replace (fx - gx - (pfx - pgx))%R with ((fx - pfx) - (gx - pgx))%R by ring. apply: J.sub_correct. move: (Hf2 x Hx). by rewrite Ef. move: (Hg2 x Hx). by rewrite Eg. Qed. Definition TM_mul_mixed (a : I.type) (M : rpa) : rpa := RPA (Pol.map (I.mul prec a) (approx M)) (I.mul prec a (error M)). Definition TM_div_mixed_r (M : rpa) (b : I.type) : rpa := RPA (Pol.map (I.div prec ^~ b) (approx M)) (I.div prec (error M) b). Lemma size_TM_mul_mixed (a : I.type) M : Pol.size (approx (TM_mul_mixed a M)) = Pol.size (approx M). Proof. by rewrite Pol.size_map. Qed. Lemma size_TM_div_mixed_r M (b : I.type) : Pol.size (approx (TM_div_mixed_r M b)) = Pol.size (approx M). Proof. by rewrite Pol.size_map. Qed. Lemma TM_mul_mixed_correct (a : I.type) M (x0 : R) (X : interval) f (y : R) : a >: y -> i_validTM x0 X M f -> i_validTM x0 X (TM_mul_mixed a M) (fun x => Xmul (Xreal y) (f x)). Proof. move=> Hy [Hdef Hnai Hzero Hsubs Hmain]. split=>//. move=> x Hx Dx; apply/contains_Xnan. rewrite I.mul_propagate_r //. apply (Hdef x Hx). by case: (f x) Dx. by move=> HX; rewrite I.mul_propagate_r // Hnai. have->: (Xreal 0) = (Xmul (Xreal y) (Xreal 0)) by simpl; congr Xreal; ring. exact: I.mul_correct. have [q H1 H2] := Hmain. exists (PolR.map (Rmult y) q). - apply: Pol.map_correct =>//. by rewrite Rmult_0_r. by move=> *; apply: J.mul_correct. - move=> x Hx. move/(_ x Hx) in H2. rewrite PolR.horner_mul_mixed. case Dx: (f x) => [|fx]. by rewrite I.mul_propagate_r // (Hdef x Hx Dx). rewrite /Xbind2 /proj_val. replace (y * fx - y * q.[x - x0])%R with (y * (fx - q.[x - x0]))%R by ring. rewrite Dx in H2. exact: J.mul_correct. Qed. Lemma TM_mul_mixed_nai M (x0 : R) (X : interval) a f g : I.convert a = Inan -> i_validTM x0 X M f -> i_validTM x0 X (TM_mul_mixed a M) g. Proof. intros Ha [Hdef Hnai Hzero Hsubs Hmain]. rewrite /i_validTM /= I.mul_propagate_l //. split=> //. destruct Hmain as [Q H1 H2]. exists (PolR.map (Rmult 0) Q) => //. apply: Pol.map_correct =>//. apply Rmult_0_l. intros xi x Hx. apply J.mul_correct. now rewrite Ha. exact Hx. Qed. Lemma TM_mul_mixed_correct_strong (a : I.type) M (x0 : R) (X : interval) f g : is_const f X (I.convert a) -> i_validTM x0 X M g -> i_validTM x0 X (TM_mul_mixed a M) (fun x => Xmul (f x) (g x)). Proof. move=> [[|y] Hy1 Hy2] Hg. - apply TM_mul_mixed_nai with (2 := Hg). now apply contains_Xnan. - apply: TM_fun_eq; last exact: TM_mul_mixed_correct Hy1 Hg. move=> x Hx /=. by rewrite Hy2. Qed. Lemma TM_div_mixed_r_aux0 M (b : I.type) (x0 : R) (X : interval) f : b >: 0%R -> i_validTM x0 X M f (* hyp maybe too strong *) -> i_validTM x0 X (TM_div_mixed_r M b) (fun x => Xdiv (f x) (Xreal 0)). Proof. move=> Hb0 [Hdef Hnai Hzero Hsubs /= Hmain]. have Lem : contains (I.convert (error (TM_div_mixed_r M b))) Xnan. rewrite /TM_div_mixed_r. simpl. rewrite -(Xdiv_0_r (Xreal R0)). exact: I.div_correct. split=>//. by move=> x Hx Dx; apply/contains_Xnan. by rewrite (proj1 (contains_Xnan _) Lem). by rewrite (proj1 (contains_Xnan _) Lem). have [Q Happrox Herr] := Hmain. exists (PolR.map (Rdiv^~ 0)%R Q) =>/=. apply: Pol.map_correct =>//; first by rewrite /Rdiv Rmult_0_l. move=> *; exact: J.div_correct. by move=> x Hx; move/contains_Xnan: Lem ->. Qed. Lemma TM_div_mixed_r_correct M (b : I.type) (x0 : R) (X : interval) f (y : R) : b >: y -> i_validTM x0 X M f -> i_validTM x0 X (TM_div_mixed_r M b) (fun x => Xdiv (f x) (Xreal y)). Proof. have [->|Hy0] := Req_dec y R0. exact: TM_div_mixed_r_aux0. move=> Hy [Hdef Hnai Hzero Hsubs Hmain]. split=>//. move=> x Hx Dx; rewrite /TM_div_mixed_r /=. rewrite I.div_propagate_l //; apply/(Hdef x Hx). case: (f x) Dx => [|fx] //=. by rewrite /Xdiv' is_zero_false. by move=> HX; rewrite I.div_propagate_l // Hnai. have->: (Xreal 0) = (Xdiv (Xreal 0) (Xreal y)). by rewrite /Xdiv' /= is_zero_false // /Rdiv Rmult_0_l. exact: I.div_correct. have [q H1 H2] := Hmain. exists (PolR.map (Rdiv ^~ y) q). - apply: Pol.map_correct =>//. by rewrite /Rdiv Rmult_0_l. by move=> *; apply: J.div_correct. - move=> x Hx /=. move/(_ x Hx) in H2. case Df: (f x) => [|fx]. by rewrite I.div_propagate_l // (Hdef x Hx). clear - H2 Hy Hy0 Df Hdef Hx. rewrite PolR.horner_div_mixed_r /Xdiv' /Xbind2 is_zero_false // /proj_val. rewrite Df in H2. replace (fx / y - q.[x - x0] / y)%R with ((fx - q.[x - x0]) / y)%R by now field. exact: J.div_correct. Qed. Lemma TM_div_mixed_r_nai M (x0 : R) (X : interval) a f g : I.convert a = Inan -> i_validTM x0 X M f -> i_validTM x0 X (TM_div_mixed_r M a) g. Proof. intros Ha [Hdef Hnai Hzero Hsubs Hmain]. rewrite /i_validTM /= I.div_propagate_r //. split=> //. destruct Hmain as [Q H1 H2]. exists (PolR.map (fun x => Rdiv x 0) Q) => //. apply: Pol.map_correct =>//. apply Rmult_0_l. intros xi x Hx. apply J.div_correct. exact Hx. now rewrite Ha. Qed. Lemma TM_div_mixed_r_correct_strong M (b : I.type) (x0 : R) (X : interval) f g : i_validTM x0 X M f -> is_const g X (I.convert b) -> i_validTM x0 X (TM_div_mixed_r M b) (fun x => Xdiv (f x) (g x)). Proof. move=> Hf [[|y] Hy1 Hy2]. - apply TM_div_mixed_r_nai with (2 := Hf). now apply contains_Xnan. - apply: (@TM_fun_eq (fun x => f x / Xreal y)%XR). by move=> x Hx /=; rewrite Hy2. exact: TM_div_mixed_r_correct. Qed. Definition mul_error prec n (f g : rpa) (X0 X : I.type) := let pf := approx f in let pg := approx g in let sx := (I.sub prec X X0) in let B := I.mul prec (Bnd.ComputeBound prec (Pol.mul_tail prec n pf pg) sx) (I.power_int prec sx (Z_of_nat n.+1)) in let Bf := Bnd.ComputeBound prec pf sx in let Bg := Bnd.ComputeBound prec pg sx in I.add prec B (I.add prec (I.mul prec (error f) Bg) (I.add prec (I.mul prec (error g) Bf) (I.mul prec (error f) (error g)))). Definition TM_mul (Mf Mg : rpa) (X0 X : I.type) n : rpa := RPA (Pol.mul_trunc prec n (approx Mf) (approx Mg)) (mul_error prec n Mf Mg X0 X). Lemma TM_mul_correct (x0 : R) (X0 X : I.type) (TMf TMg : rpa) f g n : contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) TMf f -> i_validTM x0 (I.convert X) TMg g -> i_validTM x0 (I.convert X) (TM_mul TMf TMg X0 X n) (fun xr => Xmul (f xr) (g xr)). Proof. move=> Hx0 [Fdef Fnai Fzero HinX Fmain] [Gdef Gnai Gzero _ Gmain]. split =>//. - move=> x Hx Dx. rewrite /= /mul_error. do 3![rewrite I.add_propagate_r //]. case Ef: (f x) => [|fx]. rewrite I.mul_propagate_l //; exact: Fdef Ef. case Eg: (g x) => [|gx //]. rewrite I.mul_propagate_r //; exact: Gdef Eg. by rewrite Ef Eg in Dx. - move=> HX; rewrite /TM_mul /= /mul_error. rewrite I.add_propagate_r // I.add_propagate_r // I.add_propagate_r //. by rewrite I.mul_propagate_l // Fnai. - have [qf Hf1 Hf2] := Fmain. have [qg Hg1 Hg2] := Gmain. step_xr (Xreal 0 + Xreal 0)%XR; last by rewrite /= Rplus_0_l. apply: J.add_correct. apply: (mul_0_contains_0_r _ (y := (Xreal (PolR.mul_tail tt n qf qg).[x0 - x0]))); last first. apply: pow_contains_0 =>//. rewrite <- (Rminus_eq_0 x0). now apply J.sub_correct. apply: Bnd.ComputeBound_correct. exact: Pol.mul_tail_correct. exact: J.sub_correct. step_xr (Xreal 0 + Xreal 0)%XR; last by rewrite /= Rplus_0_l. apply: J.add_correct. apply: (mul_0_contains_0_l _ (y := (Xreal qg.[x0 - x0]))) =>//. apply: Bnd.ComputeBound_correct=>//. exact: J.sub_correct. step_xr (Xreal 0 + Xreal 0)%XR; last by rewrite /= Rplus_0_l. apply: J.add_correct. apply: (mul_0_contains_0_l _ (y := (Xreal qf.[x0 - x0]))) =>//. apply: Bnd.ComputeBound_correct=>//. exact: J.sub_correct. exact: (mul_0_contains_0_l _ (*!*) (y := Xreal 0)). have [pf Hf1 Hf2] := Fmain. have [pg Hg1 Hg2] := Gmain. exists (PolR.mul_trunc tt n pf pg); first exact: Pol.mul_trunc_correct. move=> x Hx. case Dx: (Xmul (f x) (g x)) => [|mfg]. step_xi IInan =>//; rewrite /mul_error; do 3![rewrite I.add_propagate_r //]. case Ef: (f x) Dx => [|fx]. rewrite I.mul_propagate_l //; exact: Fdef Ef. case Eg: (g x) => [|gx //]. rewrite I.mul_propagate_r //; exact: Gdef Eg. move/(_ x Hx) in Hf2; move/(_ x Hx) in Hg2. step_r ((PolR.mul_tail tt n pf pg).[x - x0] * (x - x0)^n.+1 + (((proj_val (f x) - pf.[x - x0]) * pg.[x - x0] + ((proj_val (g x) - pg.[x - x0]) * pf.[x - x0] + (proj_val (f x) - pf.[x - x0]) * (proj_val (g x) - pg.[x - x0])))))%R. apply: J.add_correct. apply: J.mul_correct. apply: Bnd.ComputeBound_correct. exact: Pol.mul_tail_correct. apply: J.sub_correct =>//; exact: HinX0. rewrite pow_powerRZ; apply: J.power_int_correct. apply: J.sub_correct=>//; exact: HinX0. apply: J.add_correct. apply: J.mul_correct =>//. apply: Bnd.ComputeBound_correct =>//. by apply: J.sub_correct =>//; exact: HinX0. apply: J.add_correct. apply: J.mul_correct =>//. apply: Bnd.ComputeBound_correct =>//. by apply: J.sub_correct =>//; exact: HinX0. exact: J.mul_correct. clear - Fdef Gdef Dx Hx. have Hdfx := Fdef x Hx. have Hdgx := Gdef x Hx. set sf := pf.[x - x0]%R. set sg := pg.[x - x0]%R. rewrite !PolR.hornerE PolR.size_mul_trunc PolR.size_mul_tail. rewrite (big_endo (fun r => r * (x-x0) ^ n.+1)%R); first last. by rewrite Rmult_0_l. by move=> a b /=; rewrite Rmult_plus_distr_r. rewrite (eq_big_nat _ _ (F2 := fun i => PolR.mul_coeff tt pf pg (i + n.+1) * (x - x0) ^ (i + n.+1))%R); last first. move=> i Hi; rewrite Rmult_assoc; congr Rmult; last by rewrite pow_add. rewrite PolR.nth_mul_tail ifF; first by rewrite addnC. by case/andP: Hi; case: leqP. rewrite -(big_addn 0 _ n.+1 predT (fun i => PolR.mul_coeff tt pf pg i * (x - x0) ^ i)%R). set e := ((proj_val _ - sf) * sg + ((_ - sg) * sf + (_ - sf) * (_ - sg)))%R. rewrite Rplus_comm. have->: e = (proj_val (f x * g x)%XR - sf * sg)%R. (* begin flip-flop *) rewrite /e. case: (f x) Dx => [|fx] //. case: (g x) => [|gx] //. intros _. rewrite /=. ring. (* end flip-flop *) rewrite Rplus_assoc -Dx; congr Rplus. rewrite {}/e {}/sf {}/sg. rewrite !PolR.hornerE. apply: (Rplus_eq_reg_r (proj_val (f x * g x)%XR)). congr Rplus. rewrite -!PolR.hornerE /=. rewrite -PolR.horner_mul PolR.hornerE. set bign1 := \big[Rplus/0%R]_(0 <= i < n.+1) _. apply: (Rplus_eq_reg_r bign1); rewrite Rplus_opp_l /bign1. set big := \big[Rplus/0%R]_(0 <= i < _) _. apply: (Rplus_eq_reg_l big); rewrite -!Rplus_assoc Rplus_opp_r /big Rplus_0_l. rewrite PolR.size_mul add0n Rplus_0_r. case: (ltnP n ((PolR.size pf + PolR.size pg).-1)) => Hn. rewrite [RHS](big_cat_nat _ _ (n := n.+1)) //=. rewrite Rplus_comm; congr Rplus. rewrite !big_mkord; apply: eq_bigr. move=> [i Hi] _ /=; rewrite PolR.nth_mul_trunc ifF; last by apply: negbTE; rewrite -leqNgt. rewrite PolR.nth_mul ifF //. apply: negbTE; rewrite -ltnNge; rewrite ltnS in Hi. exact: leq_ltn_trans Hi Hn. rewrite -(add0n n.+1) !big_addn !big_mkord; apply: eq_bigr. move=> [i Hi] _ /=; rewrite PolR.nth_mul ifF //. apply: negbTE; rewrite -ltnNge. by rewrite -addSn leq_addLR. rewrite -{1}(add0n n.+1) big_addn big_mkord big1; last first. move=> [i Hi] _ /=. rewrite -subn_eq0 in Hn. by rewrite -subn_gt0 subnS (eqP Hn) in Hi. rewrite Rplus_0_l. set np := (PolR.size pf + PolR.size pg).-1. rewrite [in LHS](big_cat_nat _ _ (n := np)) //=; last exact: leqW. set big0 := \big[Rplus/0%R]_(_.-1 <= i < n.+1) _. have->: big0 = 0%R. rewrite /big0. rewrite /big0 -/np -(add0n np) big_addn big_mkord. rewrite big1 // => [[i Hi] _] /=. rewrite PolR.nth_mul_trunc ifF; last first. rewrite ltn_subRL addnC in Hi. by rewrite -ltnS ltnNge Hi. rewrite PolR.mul_coeffE PolR.mul_coeff_eq0 ?Rmult_0_l //. move=> k Hk. case: (leqP (PolR.size pf) k) => Hk0. left; rewrite PolR.nth_default //. right; rewrite PolR.nth_default //. rewrite -leq_addLR //. rewrite -(ltn_add2l (PolR.size pg)) [addn (_ pg) (_ pf)]addnC in Hk0. move/ltn_leq_pred in Hk0. apply: leq_trans Hk0 _. by rewrite leq_addl. rewrite Rplus_0_r !big_mkord; apply: eq_bigr. move=> [i Hi] _ /=. rewrite PolR.nth_mul_trunc PolR.nth_mul' ifF ?PolR.mul_coeffE //. apply: negbTE; rewrite -ltnNge ltnS. exact: leq_trans (ltnW Hi) Hn. Qed. Lemma size_TM_add Mf Mg : Pol.size (approx (TM_add Mf Mg)) = maxn (Pol.size (approx Mf)) (Pol.size (approx Mg)). Proof. by rewrite /TM_add /= Pol.size_add. Qed. Lemma size_TM_mul Mf Mg n (X0 X : I.type) : Pol.size (approx (TM_mul Mf Mg X0 X n)) = n.+1. Proof. by rewrite /TM_mul /= Pol.size_mul_trunc. Qed. Lemma size_TM_sub Mf Mg : Pol.size (approx (TM_sub Mf Mg)) = maxn (Pol.size (approx Mf)) (Pol.size (approx Mg)). Proof. by rewrite /TM_sub /= Pol.size_sub. Qed. Lemma size_TM_opp Mf : Pol.size (approx (TM_opp Mf)) = Pol.size (approx Mf). Proof. by rewrite /TM_opp /= Pol.size_opp. Qed. Definition TM_horner n p (Mf : rpa) (X0 X : I.type) : rpa := @Pol.fold rpa (fun a b => (TM_add (TM_cst X a) (TM_mul b Mf X0 X n))) (TM_cst X I.zero) p. Lemma size_TM_horner n p Mf (X0 X : I.type) : Pol.size (approx (TM_horner n p Mf X0 X)) = (if 0 < Pol.size p then n else 0).+1. Proof. rewrite /TM_horner. elim/Pol.poly_ind: p =>[|a p IHp]. by rewrite Pol.fold_polyNil Pol.size_polyNil size_TM_cst. by rewrite Pol.fold_polyCons Pol.size_polyCons size_TM_add size_TM_mul size_TM_cst max1n. Qed. (** A padding function to change the size of a polynomial over R while keeping the same coefficients. *) Let pad pi pr : PolR.T := take (Pol.size pi) (PolR.set_nth pr (Pol.size pi) 0%R). Lemma size_pad pi pr : eq_size pi (pad pi pr). Proof. rewrite /PolR.size size_take size_set_nth ifT //. exact: leq_maxl. Qed. Lemma pad_correct pi pr : pi >:: pr -> pi >:: pad pi pr. Proof. move=> Hp k. rewrite /PolR.nth nth_take_dflt. case: ifP => Hk. rewrite Pol.nth_default //; exact: J.zero_correct. rewrite nth_set_nth /= ifF; first exact: Hp. by apply/negP => /eqP K; rewrite K leqnn in Hk. Qed. Lemma horner_pad pi pr x : pi >:: pr -> pr.[x] = (pad pi pr).[x]. Proof. move=> Hp. rewrite !(@PolR.hornerE_wide (maxn (Pol.size pi) (PolR.size pr))) -?size_pad; rewrite ?(leq_maxl, leq_maxr) //. apply: eq_bigr => i _. congr Rmult. rewrite /pad /PolR.nth nth_take_dflt /PolR.nth nth_set_nth. case: ifP => [Hi| /negbT Hi]. by rewrite [LHS](Pol.nth_default_alt Hp). rewrite -ltnNge in Hi; rewrite /= ifF //. by apply/negbTE; rewrite neq_ltn Hi. Qed. Lemma TM_horner_correct (x0 : R) (X0 X : I.type) Mf f pi pr n : contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) Mf f -> pi >:: pr -> i_validTM x0 (I.convert X) (TM_horner n pi Mf X0 X) (fun x : R => Xreal pr.[proj_val (f x)]). Proof. move=> Hne [Fdef Fnai Fzero Fsubs Fmain] Hp. wlog Hsize : pi pr Hp / Pol.size pi = PolR.size pr => [Hwlog|]. apply: (@TM_fun_eq (fun x : R => Xreal (pad pi pr).[proj_val (f x)])). by move=> x Hx; rewrite /= [in RHS](@horner_pad pi). apply: Hwlog. exact: pad_correct. exact: size_pad. elim/PolR.poly_ind: pr pi Hp Hsize => [|ar pr IHpr] pi Hp Hsize; elim/Pol.poly_ind: pi Hp Hsize =>[|ai pi _] Hp Hsize. + rewrite /TM_horner Pol.fold_polyNil /=. apply: TM_cst_correct =>//. exact: J.zero_correct. + by rewrite sizes in Hsize. + by rewrite sizes in Hsize. + rewrite /= /TM_horner Pol.fold_polyCons. apply: (@TM_fun_eq (fun x : R => Xreal ar + Xreal pr.[proj_val (f x)] * Xreal (proj_val (f x)))%XR). move=> x Hx /=. congr Xreal; ring. apply: TM_add_correct. apply: TM_cst_correct=>//. by have := Hp 0; rewrite Pol.nth_polyCons PolR.nth_polyCons. apply: TM_mul_correct =>//. apply: IHpr. by move=> k; have := Hp k.+1; rewrite Pol.nth_polyCons PolR.nth_polyCons. by move: Hsize; rewrite !sizes; case. Qed. Definition TM_type := I.type -> I.type -> nat -> rpa. Definition TMset0 (Mf : rpa) t := RPA (Pol.set_nth (approx Mf) 0 t) (error Mf). Definition TM_comp (TMg : TM_type) (Mf : rpa) (X0 X : I.type) n := let Bf := Bnd.ComputeBound prec (approx Mf) (I.sub prec X X0) in let A0 := Pol.nth (approx Mf) 0 in let a0 := J.midpoint A0 in let Mg := TMg a0 (I.add prec Bf (error Mf)) n in let M1 := TMset0 Mf (I.sub prec A0 a0) in let M0 := TM_horner n (approx Mg) M1 X0 X in RPA (approx M0) (I.add prec (error M0) (error Mg)). Lemma TMset0_correct (x0 : R) (X : I.type) Mf f : let: A0 := Pol.nth (approx Mf) 0 in forall a0 alpha0, a0 >: alpha0 -> i_validTM x0 (I.convert X) Mf f -> i_validTM x0 (I.convert X) (TMset0 Mf (I.sub prec A0 a0)) (fun x => f x - Xreal alpha0). Proof. move=> a0 alpha0 in_a0 Hf. rewrite /TMset0. have [Mfdef Mfnai Mfzero Mfsubs Mfmain] := Hf. split ; try easy. intros x Hx Hfx. apply (Mfdef x Hx). revert Hfx ; clear. by case f. destruct Mfmain as [Q H1 H2]. exists (PolR.set_nth Q 0 (PolR.nth Q 0 - alpha0)%R). intros k. specialize (H1 k). clear - H1 in_a0. rewrite Pol.nth_set_nth PolR.nth_set_nth. destruct k as [|k] ; simpl. by apply (I.sub_correct _ _ _ _ (Xreal _) H1). exact H1. intros x Hx. specialize (H2 x Hx). move: (Mfdef x Hx). clear -H2. case Df: (f x) => [|fx]. by move ->. intros _. rewrite /Xbind2 /proj_val. replace (PolR.set_nth Q 0 (PolR.nth Q 0 - alpha0)%R).[x - x0] with (Q.[x - x0] - alpha0)%R. replace (fx - alpha0 - (Q.[x - x0] - alpha0))%R with (fx - Q.[x - x0])%R by ring. by rewrite Df in H2. destruct Q as [|q0 Q]. by rewrite /= Rmult_0_l Rplus_0_l. by rewrite /= /Rminus Rplus_assoc. Qed. Lemma TM_comp_correct (x0 : R) (X0 X : I.type) (TMg : TM_type) (Mf : rpa) g f : contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) Mf f -> (forall y0 Y0 Y k, subset' (I.convert Y0) (I.convert Y) -> contains (I.convert Y0) (Xreal y0) -> i_validTM y0 (I.convert Y) (TMg Y0 Y k) g) -> forall n, i_validTM x0 (I.convert X) (TM_comp TMg Mf X0 X n) (fun xr => Xbind g (f xr)). Proof. move=> Hne Hf Hg n; rewrite /TM_comp. set A0 := Pol.nth (approx Mf) 0. set a0 := J.midpoint A0. set Bf := Bnd.ComputeBound prec (approx Mf) (I.sub prec X X0). set BfMf := I.add prec Bf (error Mf). set Mg := TMg a0 (I.add prec Bf (error Mf)) n. set M1 := TMset0 Mf (I.sub prec A0 a0). set M0 := TM_horner n (approx Mg) M1 X0 X. (* Preliminary facts *) have [Fdef Fnai Fzero Hsubs Fmain] := Hf. have ne_A0 : not_empty (I.convert A0). have [q hq1 hq2] := Fmain. by eexists; eapply hq1. pose alpha0 := proj_val (I.F.convert (I.midpoint A0)). have in_a0 : a0 >: alpha0. exact: J.contains_midpoint. have subs_a0 : subset' (I.convert a0) (I.convert BfMf). rewrite /a0 /BfMf. move=> [|v] Hv. apply/contains_Xnan; rewrite I.add_propagate_r //. rewrite /A0 in Hv. apply/contains_Xnan. rewrite J.midpoint_correct in Hv. easy. have [Q HQ1 _] := Fmain. move/(_ 0) in HQ1. by exists (PolR.nth Q O). rewrite /Bf. step_xr (Xadd (Xreal v) (Xreal 0)); last by rewrite Xadd_0_r. apply: I.add_correct =>//. have [qf hq1 hq2] := Fmain. apply: (@ComputeBound_nth0 _ _ qf) =>//. rewrite <- (Rminus_eq_0 x0). now apply J.sub_correct. exact: J.subset_midpoint. have [Gdef Gnai Gzero Gsubs Gmain] := Hg alpha0 a0 BfMf n subs_a0 in_a0. have inBfMf : forall x : R, X >: x -> contains (I.convert BfMf) (f x). move=> x Hx; rewrite /BfMf /Bf. have [qf hq1 hq2] := Fmain. move/(_ x Hx) in hq2. step_xr (Xreal (qf.[x - x0]) + (f x - Xreal (qf.[x - x0])))%XR =>//. apply: I.add_correct. apply: Bnd.ComputeBound_correct =>//. exact: J.sub_correct. case Df: (f x) => [|fx]. by rewrite (Fdef x Hx Df). by rewrite Df in hq2. case: (f) =>// r; simpl; congr Xreal; ring. have HM1 : i_validTM x0 (I.convert X) M1 (fun x => f x - Xreal (alpha0)). exact: TMset0_correct. split=>//=. (* Def *) - move=> x Hx Dx. rewrite I.add_propagate_r //. case Efx: (f x) => [|r]. rewrite Gnai // /Bf. rewrite I.add_propagate_r //. exact: Fdef Efx. rewrite Efx in Dx. apply: Gdef Dx. rewrite -Efx. exact: inBfMf. (* Nai *) - move=> HX; rewrite I.add_propagate_r // Gnai //. by rewrite I.add_propagate_r // Fnai. (* Zero *) rewrite /M0 /Mg /Bf. step_xr (Xreal 0 + Xreal 0)%XR; last by rewrite /= Rplus_0_l. have [Q HQ1 HQ2] := Gmain. have [F HF1 HF2] := Fmain. apply: I.add_correct =>//. apply (@TM_horner_correct x0 X0 X M1 _ (approx Mg) Q n Hne HM1 HQ1). (* Main *) have HMg : i_validTM alpha0 (I.convert BfMf) Mg g by exact: Hg. (* now we need not [pose smallX0 := IIbnd (Xreal x0) (Xreal x0).] anymore... *) have [M1def M1nai M1zero M1subs M1main] := HM1. have [Ga0 HGa0 HGa0'] := Gmain. pose f0 := (fun x => f x - Xreal alpha0). have HM0 : i_validTM x0 (I.convert X) M0 (fun r => Xreal Ga0.[proj_val (f0 r)]). exact: TM_horner_correct. have [M0def M0nai M0zero M0subs M0main] := HM0. have [Q0 HQ0 HQ0'] := M0main. exists Q0 =>//. move=> x Hx. case Enai: (I.convert (I.add prec (error M0) (error Mg))) => [|el eu] //. rewrite -Enai. case Efx: (f x) => [|fx]. rewrite I.add_propagate_r //. apply/Gnai/contains_Xnan. rewrite -Efx; exact: inBfMf. rewrite /Xbind. case Egfx: (g fx) => [|gfx]. rewrite I.add_propagate_r //. apply: Gdef Egfx. rewrite -Efx; exact: inBfMf. pose intermed := Ga0.[proj_val (f0 x)]. rewrite /proj_val. replace (gfx - Q0.[x - x0])%R with (intermed - Q0.[x - x0] + (gfx - intermed))%R by ring. apply: J.add_correct. exact: HQ0'. rewrite /intermed /f0 Efx /=. rewrite -[gfx](f_equal proj_val Egfx). apply: HGa0'. rewrite -Efx. exact: inBfMf. Qed. Definition TM_inv_comp Mf (X0 X : I.type) (n : nat) := TM_comp TM_inv Mf X0 X n. Lemma TM_inv_comp_correct (x0 : R) (X0 X : I.type) (TMf : rpa) f : contains (I.convert X0) (Xreal x0) -> forall n, i_validTM x0 (I.convert X) TMf f -> i_validTM x0 (I.convert X) (TM_inv_comp TMf X0 X n) (fun xr => Xinv (f xr)). Proof. move=> Ht n Hf. apply: TM_comp_correct=> //. have {Hf} [Hdef Hnai Hzero Hsubs Hmain] := Hf. move=> Y0 Y k HY HY0. exact: TM_inv_correct. Qed. Definition TM_div Mf Mg (X0 X : I.type) n := TM_mul Mf (TM_inv_comp Mg X0 X n) X0 X n. Lemma TM_div_correct (x0 : R) (X0 X : I.type) (TMf TMg : rpa) f g n : contains (I.convert X0) (Xreal x0) -> i_validTM x0 (I.convert X) TMf f -> i_validTM x0 (I.convert X) TMg g -> i_validTM x0 (I.convert X) (TM_div TMf TMg X0 X n) (fun xr => Xdiv (f xr) (g xr)). Proof. move=> Hne Hf Hg. apply: (TM_fun_eq (f := fun xr => Xmul (f xr) (Xinv (g xr)))). by move=> x; rewrite Xdiv_split. rewrite /TM_div. apply: TM_mul_correct =>//. exact: TM_inv_comp_correct. Qed. Lemma size_TM_comp (X0 X : I.type) (Tyg : TM_type) (TMf : rpa) (n : nat) : (forall Y0 Y k, 0 < Pol.size (approx (Tyg Y0 Y k))) -> Pol.size (approx (TM_comp Tyg TMf X0 X n)) = n.+1. Proof. by move=> Hsize; rewrite size_TM_horner ifT // Hsize. Qed. End PrecArgument. End TaylorModel. (* FIXME: Generalize TM_integral to handle "X1" and "Y1" FIXME: Finish the experiment below to define "TM_atan" using "TM_integral" Definition TM_atan2 (u : U) (X0 X : I.type) : T := let one := TM_cst u.1 (I.fromZ 1) X0 X u.2 in let tm := TM_div u.1 X one (TM_add u X one (TM_power_int u.1 2 X0 X n)) in (* prim *) TM_integral u X X1 (I.atan u.1 X1) t'. Definition atan2 := Eval hnf in fun_gen I.atan TM_atan2. Lemma Xatan_RInt_f : forall (xF : ExtendedR -> ExtendedR) x1, let f := toR_fun xF in let xG := toXreal_fun (fun r => RInt (fun x => Derive f x / (1 + (f x)^2)) x1 r + Ratan.atan (f x1))%R in forall x, xG x = Xatan (xF x). Proof. (* TODO: Coquelicot proof *) Qed. Theorem atan2_correct : forall u (X : I.type) tf xF, approximates X tf xF -> approximates X (atan2 u X tf) (fun x => Xatan (xF x)). Proof. intros. pose x1 := proj_val (I.convert_bound (I.midpoint X)). pose f := toR_fun xF. pose xG := toXreal_fun (fun r => RInt (fun x => Derive f x / (1 + (f x)^2)) x1 r + Ratan.atan (f x1))%R. apply: approximates_ext. apply: xG. move=> x; apply: Xatan_RInt_f. rewrite /atan2. rewrite /xG /toXreal_fun. apply: prim_correct. exact: toXreal_fun (fun r : R => Derive f r / (1 + f r ^ 2)). (* TODO: midpoint *) apply: I.atan_correct. split =>//. (* TODO: to see later *) rewrite /atan2 /prim. case: tf H. apply: prim_correct. move=> u Y tf f [Hnan Hnil Hmain]. split=>//; first by rewrite Hnan. by rewrite /= /tmsize size_TM_any. move=> Hne; apply: TM_any_correct. exact: not_empty_Imid. exact: Imid_subset. move=> x Hx. apply: I.atan_correct. exact: horner_correct. Qed. *) interval-4.11.1/src/Poly/Taylor_poly.v000066400000000000000000000136701470547631300176610ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import ZArith Reals. From Flocq Require Import Raux. From mathcomp.ssreflect Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq fintype bigop. Require Import Interval. Require Import Datatypes Basic_rec. Set Implicit Arguments. Unset Strict Implicit. Unset Printing Implicit Defensive. Module TaylorPoly (C : FullOps) (P : PolyOps C). (** Needs functions defining the recurrences, as well as rec1, rec2, grec1. *) Definition cst_rec (x : C.T) (n : nat) := C.mask C.zero x. Definition var_rec (a b : C.T) (n : nat) := C.mask (C.mask C.zero a) b. Definition T_cst c (x : C.T) := P.rec1 cst_rec (C.mask c x). (** Note that in addition to the Taylor expansion point that is the 2nd parameter of T_cst, the first one is the value of the constant itself. *) Definition T_var x := P.rec2 var_rec x (C.mask C.one x). Section PrecIsPropagated1. Variable u : C.U. Definition inv_rec (x : C.T) (a : C.T) (n : nat) : C.T := C.div u a (C.opp x). Definition exp_rec (a : C.T) (n : nat) : C.T := C.div u a (C.from_nat u n). Definition sin_rec (a b : C.T) (n : nat) : C.T := C.div u (C.opp a) (C.mul u (C.from_nat u n) (C.from_nat u n.-1)). Definition cos_rec (a b : C.T) (n : nat) : C.T := C.div u (C.opp a) (C.mul u (C.from_nat u n) (C.from_nat u n.-1)). Definition pow_aux_rec (p : Z) (x : C.T) (_ : C.T) (n : nat) := if Z.ltb p Z0 || Z.geb p (Z.of_nat n) then C.power_int u x (p - Z.of_nat n)%Z else C.mask C.zero x. (* Erik: These notations could be used globally *) Local Notation "i + j" := (C.add u i j). Local Notation "i - j" := (C.sub u i j). Local Notation "i * j" := (C.mul u i j). Local Notation "i / j" := (C.div u i j). Definition sqrt_rec (x : C.T) (a : C.T) (n : nat) := let nn := C.from_nat u n in let n1 := C.from_nat u n.-1 in let two := C.from_nat u 2 in (C.one - two * n1) * a / (two * x * nn). Definition invsqrt_rec (x : C.T) (a : C.T) (n : nat) := let nn := C.from_nat u n in let n1 := C.from_nat u n.-1 in let two := C.from_nat u 2 in C.opp (C.one + two * n1) * a / (two * x * nn). (* Definition ln_rec (x : T) (a b : T) (n : nat) := let nn := tnat n in let n1 := tnat n.-1 in let n2 := tnat n.-2 in topp (n1 * b) / (nn * x). Definition Deriv_atan J := tinv u (tnat 1 + (tsqr u J)). (* (2*loc0+2*a*loc1-(loc0+2*a*loc1)*(i1+1))/((1+a^2)*(i1+1)) *) Definition atan_rec (x0 : T) (a b : T) (np2 : nat) := let n := tnat (np2.-2) in let one := tnat 1 in let two := tnat 2 in (*(two*loc0+two*a*loc1-(loc0+two*a*loc1)*(nn))/((one+a*a)*(nn)). (*OLD*)*) topp ((n*a+two*b*x0*n+two*b*x0) / (n+n*(tsqr u x0)+two+two*(tsqr u x0))). (* topp ((nn*u+two*v*a*nn+two*v*a)/((one+(tsqr a))*(nn+two)). (*TESTER*)*) Definition Deriv_asin (x : T) := (tinvsqrt u (tnat 1 - tsqr u x)). (* -(u(n+1)*(n+1)*(1+2*n)*z0+n^2*u(n))/((n+1)*(n+2)*z0^2-(n+1)*(n+2)) *) Definition asin_rec (x : T) (a b : T) (n : nat) := let nn := tnat n in let n1 := tnat n.-1 in let n2 := tnat n.-2 in let one := tnat 1 in let two := tnat 2 in (b*(n1)*(one+two*n2)*x+n2*n2*a)/((n1)*(nn)*(one-tsqr u x)). Definition Deriv_acos x := (* Eval unfold Deriv_asin in *) topp (Deriv_asin x). Definition acos_rec := asin_rec. (* acos & asin satisfy the same diffeq *) *) End PrecIsPropagated1. Section PrecIsPropagated2. Variable u : P.U. (* Definition T_ln x := trec2 (ln_rec u x) (tln u x) (C.inv u x). Definition T_atan x := trec2 (atan_rec u x) (tatan u x) (Deriv_atan u x). Definition T_asin x := trec2 (asin_rec u x) (tasin u x) (Deriv_asin u x). Definition T_acos x := trec2 (acos_rec u x) (tacos u x) (Deriv_acos u x). *) Definition T_inv x := P.rec1 (inv_rec u x) (C.inv u x). Definition T_exp x := P.rec1 (exp_rec u) (C.exp u x). Definition T_sin x := P.rec2 (sin_rec u) (C.sin u x) (C.cos u x). Definition T_cos x := P.rec2 (cos_rec u) (C.cos u x) (C.opp (C.sin u x)). Definition T_sqrt x := P.rec1 (sqrt_rec u x) (C.sqrt u x). Definition T_invsqrt x := P.rec1 (invsqrt_rec u x) (C.invsqrt u x). Definition T_power_int (p : Z) x (n : nat) := P.dotmuldiv u (falling_seq p n) (fact_seq n) (P.rec1 (pow_aux_rec u p x) (C.power_int u x p) n). Definition T_tan x := let polyX := P.lift 1 P.one (* in monomial basis *) in let J := C.tan u x in let s := [::] in let F q n := let q' := P.deriv u q in P.div_mixed_r u (P.add u q' (P.lift 2 q')) (C.from_nat u n) in let G q _ := P.horner u q J (* in monomial basis *) in P.grec1 F G polyX s. Definition T_atan x := let q1 := P.one in let J := C.atan u x in let s := [:: J] in let F q n := let q2nX := P.mul_mixed u (C.from_nat u ((n.-1).*2)) (P.lift 1 q) in let q' := P.deriv u q in P.div_mixed_r u (P.sub u (P.add u q' (P.lift 2 q')) q2nX) (C.from_nat u n) in let G q n := C.div u (P.horner u q x) (C.power_int u (C.add u C.one (C.sqr u x)) (Z_of_nat n)) in P.grec1 F G q1 s. Definition T_ln x n := let lg := C.ln u x in let y := C.mask x lg in P.polyCons lg (if n is n'.+1 then let p1 := (-1)%Z in P.dotmuldiv u (falling_seq p1 n') (behead (fact_seq n)) (P.rec1 (pow_aux_rec u p1 y) (C.power_int u y p1) n') else P.polyNil). End PrecIsPropagated2. End TaylorPoly. interval-4.11.1/src/Real/000077500000000000000000000000001470547631300151065ustar00rootroot00000000000000interval-4.11.1/src/Real/Taylor.v000066400000000000000000000252701470547631300165550ustar00rootroot00000000000000(** This file is part of the CoqApprox formalization of rigorous polynomial approximation in Coq: http://tamadi.gforge.inria.fr/CoqApprox/ Copyright (C) 2010-2012, ENS de Lyon. Copyright (C) 2010-2016, Inria. Copyright (C) 2014-2016, IRIT. This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Psatz. From Coquelicot Require Import Coquelicot. Require Import Stdlib. Local Open Scope R_scope. Lemma Rolle_lim (f : R -> R) (a b : R) (h : R -> R) : (forall x : R, a < x < b \/ b < x < a -> derivable_pt_lim f x (h x)) -> (forall x : R, a <= x <= b \/ b <= x <= a -> continuity_pt f x) -> a <> b -> f a = f b -> exists c : R, (a < c < b \/ b < c < a) /\ derivable_pt_lim f c 0. Proof. intros Hd Hc hdif Heq. destruct (total_order_T a b) as [[H1|H2]|H3]. - assert (pr : forall x : R, a < x < b -> derivable_pt f x). { intros y hy. unfold derivable_pt, derivable_pt_abs. exists (h y). now apply Hd; left. } destruct (Rolle f a b pr) as [k [P HkP]]; trivial. + now intros y Hy; apply Hc; left. + exists k; split; [now left|]. now rewrite <-derive_pt_eq; apply HkP. - now destruct hdif. - assert (pr : forall x : R, b < x < a -> derivable_pt f x). { intros y hy. unfold derivable_pt, derivable_pt_abs. exists (h y). now apply Hd; right. } destruct (Rolle f b a pr) as [k [P HkP]]; trivial. + now intros y Hy; apply Hc; right. + now symmetry. + exists k; split; [now right|]. rewrite <-derive_pt_eq; apply HkP. Qed. Section TaylorLagrange. Variables a b : R. Variable n : nat. Notation Cab x := (a <= x <= b) (only parsing). Notation Oab x := (a < x < b) (only parsing). Variable D : nat -> R -> R. Notation Tcoeff n x0 := (D n x0 / (INR (fact n))) (only parsing). Notation Tterm n x0 x := (Tcoeff n x0 * (x - x0)^n) (only parsing). Notation Tsum n x0 x := (sum_f_R0 (fun i => Tterm i x0 x) n) (only parsing). Lemma continuity_pt_sum (f : nat -> R -> R) (x : R) : (forall k, (k <= n)%nat -> continuity_pt (f k) x) -> continuity_pt (fun y => (sum_f_R0 (fun n => f n y) n)) x. Proof. elim n. now intro Hf; simpl; apply continuity_pt_ext with (f O); trivial; apply Hf. intros n' IHn Hf; simpl; apply continuity_pt_plus. apply IHn; intros k Hk; apply Hf; lia. now apply Hf. Qed. Lemma derivable_pt_lim_sum (f : nat -> R -> R) (x : R) (lf : nat -> R) : (forall i, (i <= n)%nat -> derivable_pt_lim (f i) x (lf i)) -> derivable_pt_lim (fun y => (sum_f_R0 (fun n => f n y) n)) x (sum_f_R0 lf n). Proof. elim n. intros Hf; simpl; apply derivable_pt_lim_eq with (f O); trivial. now apply (Hf 0%nat). intros n' IHn Hf; simpl; apply derivable_pt_lim_plus. now apply IHn; intros i Hi; apply Hf; auto. now apply Hf. Qed. Section TL. Hypothesis derivable_pt_lim_Dp : forall k x, (k <= n)%nat -> Oab x -> derivable_pt_lim (D k) x (D (S k) x). Hypothesis continuity_pt_Dp : forall k x, (k <= n)%nat -> Cab x -> continuity_pt (D k) x. Variables x0 x : R. (** Define [c : R] so that the function [g : R -> R] below satisfies g(x0)=0. *) Let c := (D 0 x - Tsum n x0 x) / (x - x0)^(S n). Let g := fun y => D 0 x - Tsum n y x - c * (x - y)^(S n). Hypotheses (Hx0 : Cab x0) (Hx : Cab x). Lemma derivable_pt_lim_aux (y : R) : Oab y -> derivable_pt_lim g y (- ((D (S n) y) / (INR (fact n)) * (x - y)^n) + c * (INR (S n)) * (x - y)^n). Proof. intros Hy. unfold g. apply derivable_pt_lim_eq with ((fun y : R => (D 0 x - Tsum n y x)%R) + (fun y : R => - c *(x-y)^(S n))%R)%F. intros t; unfold plus_fct; simpl; ring. apply derivable_pt_lim_plus. - change (fun x1 : R => (D 0 x - Tsum n x1 x)%R) with ((fun x1 : R => D 0 x)%R - (fun x1 => Tsum n x1 x)%R)%F. rewrite <-Rminus_0_l. apply derivable_pt_lim_minus. now apply derivable_pt_lim_const. assert (Hdtt : forall i : nat, (i <= n)%nat -> derivable_pt_lim (fun x1 : R => Tterm i x1 x) y (/ INR (fact i) * D (S i) y * (x - y) ^ i + (Tcoeff i y) * ((INR i * (x - y) ^ pred i) * (-1)))). { intros i Hi. change (fun y : R => (Tcoeff i y * (x - y) ^ i)%R) with ((fun y : R => Tcoeff i y) * (fun y => (x - y) ^ i)%R)%F. assert (Hmul := derivable_pt_lim_mult (fun y0 : R => Tcoeff i y0) (fun y0 : R => (x - y0) ^ i) y (/ INR (fact i) * D (S i) y) ((INR i * (x - y) ^ pred i) * -(1))). simpl in Hmul. apply Hmul; clear Hmul. - unfold Rdiv. apply derivable_pt_lim_eq with (mult_real_fct (/ INR (fact i)) (D i))%R. now intros; unfold mult_real_fct; rewrite Rmult_comm. apply derivable_pt_lim_scal. now apply derivable_pt_lim_Dp. - apply derivable_pt_lim_eq with (comp (fun y => y ^ i) (fun y => x - y)). now intros y'; unfold comp. apply derivable_pt_lim_comp; [|apply derivable_pt_lim_pow]. rewrite <-Rminus_0_l. apply derivable_pt_lim_minus. now apply derivable_pt_lim_const. now apply derivable_pt_lim_id. } assert (Hs := derivable_pt_lim_sum (fun n x1 => Tterm n x1 x) y (fun i => / INR (fact i) * D (S i) y * (x - y) ^ i + D i y / INR (fact i) * (INR i * (x - y) ^ pred i * -1)) Hdtt). simpl in Hs. replace (D (S n) y / INR (fact n) * (x - y) ^ n) with (sum_f_R0 (fun i : nat => / INR (fact i) * D (S i) y * (x - y) ^ i + D i y / INR (fact i) * (INR i * (x - y) ^ pred i * -1)) n). now apply Hs. rewrite sum_eq with _ (fun i : nat => D (S i) y * / INR (fact i) * (x + - y) ^ i - D i y / INR (fact i) * INR i * (x + - y) ^ pred i) n. + elim n; [simpl; field|intros n' IHn]. simpl sum_f_R0. rewrite IHn. assert (Hinr : INR (S n') = match n' with 0%nat => 1 | S _ => INR n' + 1 end) by easy. rewrite <-Hinr. change (fact n' + n' * fact n')%nat with (fact (S n')). replace (D (S n') y / INR (fact (S n')) * INR (S n')) with (D (S n') y / INR (fact n')). change ((x + - y) * (x + - y) ^ n') with ((x + - y) ^ S n'). unfold Rdiv, Rminus; ring. replace (fact (S n')) with (fact n' * (S n'))%nat. rewrite mult_INR; unfold Rdiv; field. split; apply not_0_INR; [easy|apply fact_neq_0]. simpl; ring. + intros i Hi; unfold Rdiv, Rminus; ring. - replace (c * INR (S n) * (x - y)^n) with (- c * (INR (S n) * (x - y)^ pred (S n) * -(1))) by (simpl ; ring). apply derivable_pt_lim_scal. apply derivable_pt_lim_eq with (comp (fun y => y ^ (S n)) (fun y => x - y)). now intros y'; unfold comp. apply derivable_pt_lim_comp; [|now apply derivable_pt_lim_pow]. rewrite <-Rminus_0_l. apply derivable_pt_lim_minus. now apply derivable_pt_lim_const. now apply derivable_pt_lim_id. Qed. Theorem Taylor_Lagrange : exists xi : R, D 0 x - Tsum n x0 x = Tcoeff (S n) xi * (x - x0)^(S n) /\ (x0 <> x -> x0 < xi < x \/ x < xi < x0). Proof. intros. destruct (Req_dec x0 x) as [Heq|Hdif]. rewrite Heq. exists x. split; [|now intros H'; case H']. rewrite Rminus_diag_eq; [|trivial]. now rewrite Rminus_diag_eq; [simpl|easy]; rewrite Rmult_0_l, Rmult_0_r. elim n. simpl; field. intros k Hk; simpl. now rewrite Hk, Rminus_diag_eq; [simpl|easy]; rewrite Rmult_0_l, Rmult_0_r, Rplus_0_r. case (Rolle_lim g x0 x (fun d => (- ((D (S n) d) / (INR (fact n)) * (x - d)^n) + c * (INR (S n)) * (x - d)^n))). - intros y Hy; apply derivable_pt_lim_aux. split; destruct Hy as [H|H]; case Hx0; case Hx; case H; psatzl R. - intros y Hy. apply continuity_pt_minus; [|reg]. apply continuity_pt_minus; [reg|]. apply continuity_pt_sum. intros n' hn'; apply continuity_pt_mult. + unfold Rdiv; apply continuity_pt_mult. apply continuity_pt_Dp; [easy|]. split; destruct Hy as [H|H]; case Hx0; case Hx; case H; psatzl R. now reg. + now reg. - easy. - assert (Hgx0 : g x0 = 0). unfold g, c, Rdiv. rewrite Rmult_assoc, <-Rinv_l_sym; [ring|]. now apply pow_nonzero; apply Rminus_eq_contra; intros H; case Hdif. assert (Hgx : g x = 0). unfold g, c, Rminus. rewrite Rplus_opp_r, pow_ne_zero; [|easy]. ring_simplify. assert (Htsum : forall p, D 0 x - Tsum p x x = 0). induction p as [|n' IHn]. simpl; field. unfold Rminus in IHn |-*; simpl. rewrite Ropp_plus_distr, <- Rplus_assoc, IHn; ring_simplify; trivial. now rewrite Rminus_diag_eq in Htsum. now rewrite Hgx0, Hgx. - intros d [Hd1 Hd2]. exists d. split. + assert (Hk : Oab d). destruct Hd1 as [Hy|Hy]; split; case Hy; case Hx0; case Hx; psatzl R. assert (H1 := derivable_pt_lim_aux d Hk). assert ((- (D (S n) d / INR (fact n) * (x - d) ^ n) + c * INR (S n) * (x - d) ^ n) = 0). now apply uniqueness_limite with g d. assert (Hc : c = D (S n) d / INR (fact (S n))). assert (Hc1 := Rplus_opp_r_uniq _ _ H). rewrite Ropp_involutive in Hc1. assert (Hc2 : c * INR (S n) = D (S n) d / INR (fact n)). apply Rmult_eq_reg_r with ((x-d)^n); [easy|]. apply pow_nonzero. destruct Hd1 as [H0|H0]; apply Rminus_eq_contra. now apply Rgt_not_eq; case H0. now apply Rlt_not_eq; case H0. apply Rmult_eq_reg_r with (INR (S n)); [|now apply not_0_INR]. rewrite Hc2. replace (fact (S n)) with (fact n * (S n))%nat by (simpl; ring). rewrite mult_INR; field. split; apply not_0_INR; [easy|apply fact_neq_0]. unfold c in Hc. apply Rmult_eq_reg_r with (/(x - x0) ^ S n). unfold Rdiv in Hc at 1; rewrite Hc; field. split; [|apply not_0_INR; apply fact_neq_0]. apply pow_nonzero; apply Rminus_eq_contra; trivial. now intros H'; case Hdif. apply Rinv_neq_0_compat; apply pow_nonzero; apply Rminus_eq_contra. now intros H'; case Hdif. + now case Hd1. Qed. End TL. Section CorTL. Hypothesis derivable_pt_lim_Dp : forall k x, (k <= n)%nat -> Cab x -> derivable_pt_lim (D k) x (D (S k) x). Theorem Cor_Taylor_Lagrange (x0 x : R) : Cab x0 -> Cab x -> exists c, D 0 x - Tsum n x0 x = Tcoeff (S n) c * (x - x0)^(S n) /\ (x0 <> x -> x0 < c < x \/ x < c < x0). Proof. intros Hx0 Hx. apply Taylor_Lagrange. - intros k x1 Hk Hab; apply derivable_pt_lim_Dp; trivial. now split; case Hab; left. - intros k x1 Hk Hab. apply derivable_continuous_pt. unfold derivable_pt, derivable_pt_abs. exists (D (S k) x1). now apply derivable_pt_lim_Dp. - exact Hx0. - exact Hx. Qed. End CorTL. End TaylorLagrange. interval-4.11.1/src/Real/Xreal.v000066400000000000000000000175451470547631300163640ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals Bool. From Flocq Require Import Raux. From mathcomp.ssreflect Require Import ssreflect. Require Import Stdlib. Definition is_zero x := Req_bool x 0. Definition is_positive x := Rlt_bool 0 x. Definition is_negative x := Rlt_bool x 0. Lemma is_zero_spec : forall x, Req_bool_prop x 0 (is_zero x). Proof. intros x. exact (Req_bool_spec x 0). Qed. Lemma is_zero_0 : is_zero 0 = true. Proof. now apply Req_bool_true. Qed. Lemma is_zero_true : forall x, x = 0%R -> is_zero x = true. Proof. intros x ->. exact is_zero_0. Qed. Lemma is_zero_false : forall x, x <> 0%R -> is_zero x = false. Proof. intros x Hx. now apply Req_bool_false. Qed. Lemma is_positive_spec : forall x, Rlt_bool_prop 0 x (is_positive x). Proof. exact (Rlt_bool_spec 0). Qed. Lemma is_positive_true : forall x, (0 < x)%R -> is_positive x = true. Proof. intros x Hx. now apply Rlt_bool_true. Qed. Lemma is_positive_false : forall x, (x <= 0)%R -> is_positive x = false. Proof. intros x Hx. now apply Rlt_bool_false. Qed. Lemma is_negative_spec : forall x, Rlt_bool_prop x 0 (is_negative x). Proof. intros x. exact (Rlt_bool_spec x 0). Qed. Lemma is_negative_true : forall x, (x < 0)%R -> is_negative x = true. Proof. intros x Hx. now apply Rlt_bool_true. Qed. Lemma is_negative_false : forall x, (0 <= x)%R -> is_negative x = false. Proof. intros x Hx. now apply Rlt_bool_false. Qed. (* * Extended reals *) Inductive ExtendedR : Set := | Xnan : ExtendedR | Xreal : R -> ExtendedR. Definition proj_val x := match x with Xreal y => y | Xnan => R0 end. Definition proj_fun v f x := match f (Xreal x) with Xreal y => y | Xnan => v end. (* useful to discriminate over an ExtendedR *) Definition notXnan (xR : ExtendedR) : Prop := match xR with | Xnan => false | Xreal _ => true end = true. Inductive Xcomparison : Set := Xeq | Xlt | Xgt | Xund. Definition Xcmp x y := match x, y with | Xreal u, Xreal v => match Rcompare u v with | Lt => Xlt | Eq => Xeq | Gt => Xgt end | _, _ => Xund end. Definition extension f fx := forall x, match fx x, x with | Xnan, _ => True | Xreal v, Xreal u => f u = v | _, _ => False end. Definition Xbind f x := match x with | Xreal x => f x | Xnan => Xnan end. Definition Xbind2 f x y := match x, y with | Xreal x, Xreal y => f x y | _, _ => Xnan end. Notation Xlift f := (Xbind (fun x => Xreal (f x))). Notation Xlift2 f := (Xbind2 (fun x y => Xreal (f x y))). Lemma Xlift2_nan_r : forall f x, Xlift2 f x Xnan = Xnan. Proof. now intros f [|x]. Qed. Notation Xneg := (Xlift Ropp). Lemma Xneg_involutive : forall x, Xneg (Xneg x) = x. Proof. intros [|x]. easy. apply (f_equal Xreal), Ropp_involutive. Qed. Definition Xinv' x := if is_zero x then Xnan else Xreal (/ x). Definition Xsqrt' x := Xreal (sqrt x). Definition Xsqrt_nan' x := if is_negative x then Xnan else Xreal (sqrt x). Definition Xdiv' x y := if is_zero y then Xnan else Xreal (x / y). Notation Xinv := (Xbind Xinv'). Notation Xsqrt := (Xbind Xsqrt'). Notation Xsqrt_nan := (Xbind Xsqrt_nan'). Notation Xabs := (Xlift Rabs). Notation Xadd := (Xlift2 Rplus). Notation Xsub := (Xlift2 Rminus). Notation Xmul := (Xlift2 Rmult). Notation Xdiv := (Xbind2 Xdiv'). Notation Xmin := (Xlift2 Rmin). Notation Xmax := (Xlift2 Rmax). Definition Xscale beta x e := Xmul x (Xreal (bpow beta e)). Delimit Scope XR_scope with XR. Notation "x + y" := (Xadd x y) : XR_scope. Notation "x - y" := (Xsub x y) : XR_scope. Notation " - y" := (Xneg y) : XR_scope. Notation "x * y" := (Xmul x y) : XR_scope. Notation "x / y" := (Xdiv x y) : XR_scope. Lemma Xsub_split : forall x y, Xsub x y = Xadd x (Xneg y). Proof. now intros [|x] [|y]. Qed. Lemma Xdiv_split : forall x y, Xdiv x y = Xmul x (Xinv y). Proof. intros [|x] [|y] ; try split. unfold Xbind2, Xbind, Xdiv', Xinv'. now case (is_zero y). Qed. Definition Xtan' x := if is_zero (cos x) then Xnan else Xreal (tan x). Definition Xln' x := if is_positive x then Xreal (ln x) else Xnan. Definition Xpower_int' x n := match n with | 0%Z => Xreal 1%R | Zpos p => Xreal (pow x (nat_of_P p)) | Zneg p => if is_zero x then Xnan else Xreal (Rinv (pow x (nat_of_P p))) end. Notation Xsqr := (Xlift Rsqr). Notation Xcos := (Xlift cos). Notation Xsin := (Xlift sin). Notation Xtan := (Xbind Xtan'). Notation Xatan := (Xlift atan). Notation Xexp := (Xlift exp). Notation Xln := (Xbind Xln'). Definition Xpower_int x n := Xbind (fun x => Xpower_int' x n) x. Lemma Xpower_int_correct : forall n, extension (fun x => powerRZ x n) (fun x => Xpower_int x n). Proof. intros [|n|n] [|x] ; try split. unfold Xpower_int, Xpower_int', Xbind. now case (is_zero x). Qed. (* * "Field" structure *) Lemma Xadd_comm : forall x y, Xadd x y = Xadd y x. Proof. intros [|x] [|y] ; try split. simpl. apply f_equal. apply Rplus_comm. Qed. Lemma Xadd_0_l : forall x, Xadd (Xreal 0) x = x. Proof. intros [|x] ; try split. simpl. apply f_equal. apply Rplus_0_l. Qed. Lemma Xadd_0_r : forall x, Xadd x (Xreal 0) = x. Proof. intros [|x] ; try split. simpl. apply f_equal. apply Rplus_0_r. Qed. Lemma Xmul_comm : forall x y, Xmul x y = Xmul y x. Proof. intros [|x] [|y] ; try split. simpl. apply f_equal. apply Rmult_comm. Qed. Lemma Xmul_assoc : forall x y z, Xmul (Xmul x y) z = Xmul x (Xmul y z). Proof. intros [|x] [|y] [|z] ; try split. simpl. apply f_equal. apply Rmult_assoc. Qed. Lemma Xmul_1_l : forall x, Xmul (Xreal 1) x = x. Proof. intros [|x] ; try split. simpl. apply f_equal. apply Rmult_1_l. Qed. Lemma Xmul_1_r : forall x, Xmul x (Xreal 1) = x. Proof. intros [|x] ; try split. simpl. apply f_equal. apply Rmult_1_r. Qed. Lemma Xmul_Xadd_distr_r : forall x y z, Xmul (Xadd x y) z = Xadd (Xmul x z) (Xmul y z). Proof. intros [|x] [|y] [|z] ; try split. simpl. apply f_equal. apply Rmult_plus_distr_r. Qed. Lemma Xmul_Xneg_distr_l : forall x y, Xmul (Xneg x) y = Xneg (Xmul x y). Proof. intros [|x] [|y] ; try split. simpl. apply f_equal. apply Ropp_mult_distr_l_reverse. Qed. Lemma Xmul_Xneg_distr_r : forall x y, Xmul x (Xneg y) = Xneg (Xmul x y). Proof. intros [|x] [|y] ; try split. simpl. apply f_equal. apply Ropp_mult_distr_r_reverse. Qed. Lemma Xinv_Xmul_distr : forall x y, Xinv (Xmul x y) = Xmul (Xinv x) (Xinv y). Proof. intros [|x] [|y] ; try easy ; simpl ; unfold Xinv'. now destruct (is_zero_spec x). destruct (is_zero_spec x). destruct (is_zero_spec (x * y)). apply refl_equal. elim H0. rewrite H. apply Rmult_0_l. destruct (is_zero_spec y). destruct (is_zero_spec (x * y)). apply refl_equal. elim H1. rewrite H0. apply Rmult_0_r. destruct (is_zero_spec (x * y)). elim (prod_neq_R0 _ _ H H0 H1). apply (f_equal Xreal). now apply Rinv_mult_distr. Qed. Definition Xmask x y := match y with | Xreal _ => x | Xnan => Xnan end. Lemma Xmul_Xinv : forall x, Xmul x (Xinv x) = Xmask (Xreal 1) (Xinv x). Proof. intros [|x] ; try easy ; simpl ; unfold Xinv'. destruct (is_zero_spec x). apply refl_equal. apply (f_equal Xreal). now apply Rinv_r. Qed. Lemma Xdiv_0_r : forall x, Xdiv x (Xreal 0) = Xnan. Proof. intros [|x] ; try easy ; simpl ; unfold Xdiv'. case is_zero_spec. easy. intros H. now elim H. Qed. interval-4.11.1/src/Real/Xreal_derive.v000066400000000000000000000550431470547631300177150ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals. From Flocq Require Import Raux. Require Import Stdlib. Require Import Xreal. Theorem derivable_imp_defined : forall f r d u v, f (Xreal r) = Xreal u -> u <> v -> derivable_pt_lim (proj_fun v f) r d -> locally_true r (fun a => exists w, f (Xreal a) = Xreal w). Proof. intros. (* by continuity ... *) assert (continuity_pt (proj_fun v f) r). apply derivable_continuous_pt. exists d. exact H1. clear H1. (* ... the projected result cannot be the default value ... *) replace u with (proj_fun v f r) in H0. destruct (continuity_pt_ne _ _ _ H0 H2) as (delta, (Hdelta, H3)). exists delta. split. exact Hdelta. intros. generalize (H3 _ H1). unfold proj_fun. (* ... so the result is not NaN *) case (f (Xreal (r + h))). intro H4. elim H4. apply refl_equal. intros. exists r0. apply refl_equal. unfold proj_fun. rewrite H. apply refl_equal. Qed. Theorem derivable_imp_defined_any : forall f r d u, f (Xreal r) = Xreal u -> (forall v, derivable_pt_lim (proj_fun v f) r d) -> locally_true r (fun a => exists w, f (Xreal a) = Xreal w). Proof. intros. eapply derivable_imp_defined. apply H. apply Rlt_not_eq. apply Rlt_plus_1. apply H0. Qed. Theorem derivable_imp_defined_any_2 : forall f1 f2 r d1 d2 u1 u2, f1 (Xreal r) = Xreal u1 -> f2 (Xreal r) = Xreal u2 -> (forall v, derivable_pt_lim (proj_fun v f1) r d1) -> (forall v, derivable_pt_lim (proj_fun v f2) r d2) -> locally_true r (fun a => (exists w1, f1 (Xreal a) = Xreal w1) /\ (exists w2, f2 (Xreal a) = Xreal w2)). Proof. intros. apply locally_true_and. apply (derivable_imp_defined_any _ _ _ _ H H1). apply (derivable_imp_defined_any _ _ _ _ H0 H2). Qed. Theorem derivable_imp_defined_gt : forall f r d u t, f (Xreal r) = Xreal u -> (t < u)%R -> (forall v, derivable_pt_lim (proj_fun v f) r d) -> locally_true r (fun a => exists w, (t < w)%R /\ f (Xreal a) = Xreal w). Proof. intros. apply locally_true_imp with (fun a => (exists w, f (Xreal a) = Xreal w) /\ (t < proj_fun 0 f a)%R). intros x ((w, H2), H3). exists w. split. replace (proj_fun 0 f x) with w in H3. exact H3. unfold proj_fun. rewrite H2. apply refl_equal. exact H2. apply locally_true_and. eapply derivable_imp_defined_any ; eassumption. apply continuity_pt_gt. replace (proj_fun 0 f r) with u. exact H0. unfold proj_fun. rewrite H. apply refl_equal. apply derivable_continuous_pt. exists d. apply H1. Qed. Theorem derivable_imp_defined_lt : forall f r d u t, f (Xreal r) = Xreal u -> (u < t)%R -> (forall v, derivable_pt_lim (proj_fun v f) r d) -> locally_true r (fun a => exists w, (w < t)%R /\ f (Xreal a) = Xreal w). Proof. intros. apply locally_true_imp with (fun a => (exists w, f (Xreal a) = Xreal w) /\ (proj_fun 0 f a < t)%R). intros x ((w, H2), H3). exists w. split. replace (proj_fun 0 f x) with w in H3. exact H3. unfold proj_fun. now rewrite H2. exact H2. apply locally_true_and. eapply derivable_imp_defined_any ; eassumption. apply continuity_pt_lt. replace (proj_fun 0 f r) with u. exact H0. unfold proj_fun. rewrite H. apply refl_equal. apply derivable_continuous_pt. exists d. apply H1. Qed. Theorem derivable_imp_defined_ne : forall f r d u t, f (Xreal r) = Xreal u -> (u <> t)%R -> (forall v, derivable_pt_lim (proj_fun v f) r d) -> locally_true r (fun a => exists w, (w <> t)%R /\ f (Xreal a) = Xreal w). Proof. intros. apply locally_true_imp with (fun a => (exists w, f (Xreal a) = Xreal w) /\ (proj_fun 0 f a <> t)%R). intros x ((w, H2), H3). exists w. split. replace (proj_fun 0 f x) with w in H3. exact H3. unfold proj_fun. rewrite H2. apply refl_equal. exact H2. apply locally_true_and. eapply derivable_imp_defined_any ; eassumption. apply continuity_pt_ne. replace (proj_fun 0 f r) with u. exact H0. unfold proj_fun. rewrite H. apply refl_equal. apply derivable_continuous_pt. exists d. apply H1. Qed. Definition Xderive_pt f x y' := match x, y', f x with | Xreal r, Xreal d, Xreal _ => forall v, derivable_pt_lim (proj_fun v f) r d | _, Xnan, _ => True | _, _, _ => False end. Definition Xderive f f' := forall x, Xderive_pt f x (f' x). Ltac xtotal_get_spec1 f := match f with | Req_bool => Req_bool_spec | Rle_bool => Rle_bool_spec | Rlt_bool => Rlt_bool_spec | is_zero => is_zero_spec | is_positive => is_positive_spec | is_negative => is_negative_spec end. Ltac xtotal_destruct_xreal v := match v with | context [?f ?x] => let r := fresh "r" in let X := fresh "X" in case_eq v ; [ intros X | intros r X ] ; try rewrite X in * | _ => let r := fresh "r" in destruct v as [|r] end. Ltac xtotal_aux := trivial ; try discriminate ; match goal with | H: False |- _ => elim H (* | |- ?v = ?v => apply refl_equal | |- True => exact I | H: Xreal _ = Xnan |- _ => discriminate H | H: Xnan = Xreal _ |- _ => discriminate H | H: true = false |- _ => discriminate H | H: false = true |- _ => discriminate H *) | H: ?v = ?v |- _ => clear H | H: Xreal _ = Xreal _ |- _ => injection H ; clear H ; intro H | H: context [match ?v with Xnan => _ | Xreal _ => _ end] |- _ => xtotal_destruct_xreal v ; try discriminate H ; trivial (*| H: match ?v with true => Xnan | false => Xreal _ end = Xreal _ |- _ => (*case_eq v ; intro X ; rewrite X in H ; [ discriminate H | idtac ]*) xtotal_destruct_xreal v ; [ discriminate H | idtac ] | H: match ?v with true => Xnan | false => Xreal _ end = Xnan |- _ => (*case_eq v ; intro X ; rewrite X in H ; [ idtac | discriminate H ]*) xtotal_destruct_xreal v ; [ idtac | discriminate H ]*) | H1 : Xderive ?f1 ?f2 , H2 : context [?f2 ?v] |- _ => generalize (H1 v) ; clear H1 ; intro H1 ; unfold Xderive_pt in H1 | H: ?v = Xreal _ |- _ => rewrite H in * | H: ?v = Xnan |- _ => rewrite H in * | v: R, H: ?v = _ |- _ => try rewrite H in * ; clear H v | v: R, H: _ = ?v |- _ => try rewrite <- H in * ; clear H v | H: context [?f ?v] |- _ => let s := xtotal_get_spec1 f in let Y := fresh "Y" in destruct (s v) as [Y|Y] | H: match ?v with true => Xnan | false => Xreal _ end = _ |- _ => let X := fresh "X" in case_eq v ; intro X ; rewrite X in H ; try discriminate H | |- match ?v with Xnan => _ | Xreal _ => _ end => xtotal_destruct_xreal v | |- context [?f ?v] => let s := xtotal_get_spec1 f in let Y := fresh "Y" in destruct (s v) as [Y|Y] end. Ltac xtotal := unfold Xderive_pt, Xinv', Xdiv', Xsqrt', Xtan', Xln', Xpower_int, Xpower_int', Xmask, Xbind2, Xbind in * ; repeat xtotal_aux. Theorem Xderive_pt_add : forall f g f' g' x, Xderive_pt f x f' -> Xderive_pt g x g' -> Xderive_pt (fun x => Xadd (f x) (g x)) x (Xadd f' g'). Proof. intros f g f' g' x Hf Hg. xtotal. intro v. apply derivable_pt_lim_eq_locally with (plus_fct (proj_fun v f) (proj_fun v g)). apply locally_true_imp with (2 := derivable_imp_defined_any_2 _ _ _ _ _ _ _ X0 X Hf Hg). intros x ((w1, Hw1), (w2, Hw2)). unfold plus_fct, proj_fun. now rewrite Hw1, Hw2. now apply derivable_pt_lim_plus. Qed. Theorem Xderive_pt_sub : forall f g f' g' x, Xderive_pt f x f' -> Xderive_pt g x g' -> Xderive_pt (fun x => Xsub (f x) (g x)) x (Xsub f' g'). Proof. intros f g f' g' x Hf Hg. xtotal. intro v. apply derivable_pt_lim_eq_locally with (minus_fct (proj_fun v f) (proj_fun v g)). apply locally_true_imp with (2 := derivable_imp_defined_any_2 _ _ _ _ _ _ _ X0 X Hf Hg). intros x ((w1, Hw1), (w2, Hw2)). unfold minus_fct, proj_fun. now rewrite Hw1, Hw2. now apply derivable_pt_lim_minus. Qed. Theorem Xderive_pt_mul : forall f g f' g' x, Xderive_pt f x f' -> Xderive_pt g x g' -> Xderive_pt (fun x => Xmul (f x) (g x)) x (Xadd (Xmul f' (g x)) (Xmul g' (f x))). Proof. intros f g f' g' x Hf Hg. xtotal. intro v. apply derivable_pt_lim_eq_locally with (mult_fct (proj_fun v f) (proj_fun v g)). apply locally_true_imp with (2 := derivable_imp_defined_any_2 _ _ _ _ _ _ _ X0 X Hf Hg). intros x ((w1, Hw1), (w2, Hw2)). unfold mult_fct, proj_fun. now rewrite Hw1, Hw2. replace r1 with (proj_fun v g r). replace r3 with (proj_fun v f r). rewrite (Rmult_comm r0). now apply derivable_pt_lim_mult. unfold proj_fun. now rewrite X0. unfold proj_fun. now rewrite X. Qed. Theorem Xderive_pt_div : forall f g f' g' x, Xderive_pt f x f' -> Xderive_pt g x g' -> Xderive_pt (fun x => Xdiv (f x) (g x)) x (Xdiv (Xsub (Xmul f' (g x)) (Xmul g' (f x))) (Xmul (g x) (g x))). Proof. intros f g f' g' x Hf Hg. xtotal. elim Y. apply Rmult_0_l. intro v. apply derivable_pt_lim_eq_locally with (div_fct (proj_fun v f) (proj_fun v g)). generalize (derivable_imp_defined_any _ _ _ _ X0 Hf). generalize (derivable_imp_defined_ne _ _ _ _ _ X Y0 Hg). intros H2 H1. apply locally_true_imp with (2 := locally_true_and _ _ _ H1 H2). intros x ((w1, Hw1), (w2, (Hw2a, Hw2b))). unfold div_fct, proj_fun. rewrite Hw1, Hw2b. destruct (is_zero_spec w2). now elim Hw2a. apply refl_equal. replace r1 with (proj_fun v g r). replace r3 with (proj_fun v f r). fold (Rsqr (proj_fun v g r)). apply derivable_pt_lim_div. apply Hf. apply Hg. unfold proj_fun. now rewrite X. unfold proj_fun. now rewrite X0. unfold proj_fun. now rewrite X. Qed. Theorem Xderive_pt_neg : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xneg (f x)) x (Xneg f'). Proof. intros f f' x Hf. xtotal. intro v. apply derivable_pt_lim_eq_locally with (opp_fct (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold opp_fct, proj_fun. now rewrite Hw. now apply derivable_pt_lim_opp. Qed. Theorem Xderive_pt_abs : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xabs (f x)) x (match Xcmp (f x) (Xreal 0) with Xlt => Xneg f' | Xgt => f' | _ => Xnan end). Proof. intros f f' x Hf. xtotal. revert X. now case Xcmp. revert X. now case Xcmp. simpl Xcmp in X0. destruct (Rcompare_spec r1 0) ; try easy. intro v. apply derivable_pt_lim_eq_locally with (fun x => Ropp (proj_fun v f x)). apply locally_true_imp with (2 := derivable_imp_defined_lt _ _ _ _ _ X H Hf). intros x (w, (Hw1, Hw2)). unfold proj_fun. rewrite Hw2. now rewrite Rabs_left. inversion X0. now apply derivable_pt_lim_opp. intro v. apply derivable_pt_lim_eq_locally with (proj_fun v f). apply locally_true_imp with (2 := derivable_imp_defined_gt _ _ _ _ _ X H Hf). intros x (w, (Hw1, Hw2)). unfold proj_fun. rewrite Hw2. rewrite Rabs_right. apply refl_equal. apply Rle_ge. now apply Rlt_le. inversion X0. now rewrite <- H1. Qed. Theorem Xderive_pt_inv : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xinv (f x)) x (Xneg (Xdiv f' (Xsqr (f x)))). Proof. intros f f' x Hf. xtotal. elim Y. apply Rmult_0_l. intro v. apply derivable_pt_lim_eq_locally with (inv_fct (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_ne _ _ _ _ _ X Y0 Hf). intros x (w, (Hw1, Hw2)). unfold inv_fct, proj_fun. rewrite Hw2. destruct (is_zero_spec w). now elim Hw1. apply refl_equal. apply derivable_pt_lim_eq with (div_fct (fct_cte 1) (proj_fun v f)). intro x. unfold div_fct, fct_cte, Rdiv. apply Rmult_1_l. replace (- (r0 / Rsqr r1))%R with ((0 * proj_fun v f r - r0 * fct_cte 1 r) / Rsqr (proj_fun v f r))%R. apply (derivable_pt_lim_div (fct_cte 1)). apply derivable_pt_lim_const. apply Hf. unfold proj_fun. now rewrite X. unfold proj_fun, fct_cte. rewrite X. now field. Qed. Theorem Xderive_pt_sqrt : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xsqrt (f x)) x (Xdiv f' (Xadd (Xsqrt (f x)) (Xsqrt (f x)))). Proof. intros f f' x Hf. xtotal. intro v. assert (Hx: (0 < r1)%R). { apply Rnot_le_lt; intro Hr1. apply Y. now rewrite sqrt_neg; [rewrite Rplus_0_r|]. } apply derivable_pt_lim_eq_locally with (comp sqrt (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_gt _ _ _ _ R0 X Hx Hf). intros x (w, (Hw1, Hw2)). unfold comp, proj_fun. rewrite Hw2. destruct (is_negative_spec w). elim (Rlt_not_le _ _ Hw1). now left. apply refl_equal. unfold Rdiv. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. replace (sqrt r1 + sqrt r1)%R with (2 * sqrt r1)%R by ring. now apply derivable_pt_lim_sqrt. Qed. Theorem Xderive_pt_sin : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xsin (f x)) x (Xmul f' (Xcos (f x))). Proof. intros f f' x Hf. xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp sin (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold comp, proj_fun. now rewrite Hw. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. apply derivable_pt_lim_sin. Qed. Theorem Xderive_pt_cos : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xcos (f x)) x (Xmul f' (Xneg (Xsin (f x)))). Proof. intros f f' x Hf. xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp cos (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold comp, proj_fun. now rewrite Hw. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. apply derivable_pt_lim_cos. Qed. Theorem Xderive_pt_tan : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xtan (f x)) x (Xmul f' (Xadd (Xreal 1) (Xsqr (Xtan (f x))))). Proof. intros f f' x Hf. xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp tan (proj_fun v f)). assert (continuity_pt (comp cos (proj_fun v f)) r). apply derivable_continuous_pt. exists (- sin (proj_fun v f r) * r0)%R. unfold derivable_pt_abs. apply derivable_pt_lim_comp. apply Hf. apply derivable_pt_lim_cos. replace (cos r1) with (comp cos (proj_fun v f) r) in Y. generalize (derivable_imp_defined_any _ _ _ _ X Hf). generalize (continuity_pt_ne _ _ R0 Y H). intros H2 H1. apply locally_true_imp with (2 := locally_true_and _ _ _ H1 H2). unfold comp, proj_fun. intros x ((w, Hw1), Hw2). rewrite Hw1. rewrite Hw1 in Hw2. destruct (is_zero_spec (cos w)). now elim Hw2. apply refl_equal. unfold comp, proj_fun. now rewrite X. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. change (sin r1 / cos r1 * (sin r1 / cos r1))%R with (Rsqr (tan r1))%R. now apply derivable_pt_lim_tan. Qed. Theorem Xderive_pt_exp : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xexp (f x)) x (Xmul f' (Xexp (f x))). Proof. intros f f' x Hf. xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp exp (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold comp, proj_fun. now rewrite Hw. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. apply (derivable_pt_lim_exp r1). Qed. Theorem Xderive_pt_ln : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xln (f x)) x (match Xcmp (f x) (Xreal 0) with Xgt => Xdiv f' (f x) | _ => Xnan end). Proof. intros f f' x Hf. xtotal. revert X. now case Xcmp. revert X. now case Xcmp. revert X. now case Xcmp. revert X0. now case Xcmp. revert X0. now case Xcmp. simpl Xcmp in X0. destruct (Rcompare_spec r1 0) ; try easy. now elim Rle_not_lt with (1 := Y0). simpl Xcmp in X0. destruct (Rcompare_spec r1 0) ; try easy. intro v. apply derivable_pt_lim_eq_locally with (comp ln (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_gt _ _ _ _ R0 X H Hf). intros x (w, (Hw1, Hw2)). unfold comp, proj_fun. rewrite Hw2. destruct (is_positive_spec w). easy. now elim (Rlt_not_le _ _ Hw1). injection X0. clear X0. intros <-. unfold Rdiv. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. now apply derivable_pt_lim_ln. Qed. Theorem Xderive_pt_atan : forall f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xatan (f x)) x (Xdiv f' (Xadd (Xreal 1) (Xsqr (f x)))). Proof. intros f f' x Hf. xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp atan (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold comp, proj_fun. now rewrite Hw. unfold Rdiv. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. rewrite Rsqr_pow2. apply (derivable_pt_lim_atan r1). Qed. Theorem Xderive_pt_power_int : forall n f f' x, Xderive_pt f x f' -> Xderive_pt (fun x => Xpower_int (f x) n) x (Xmul f' (Xmul (Xreal (IZR n)) (Xpower_int (f x) (Z.pred n)))). Proof. intros n f f' x Hf. destruct n as [|n|n]. (* *) xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp (fun x => powerRZ x 0) (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold comp, proj_fun. now rewrite Hw. rewrite Rmult_0_l, Rmult_0_r. unfold comp, proj_fun. simpl. apply derivable_pt_lim_const. (* *) replace (Xpower_int (f x) (Z.pred (Zpos n))) with (match f x with Xnan => Xnan | Xreal r => Xreal (pow r (pred (nat_of_P n))) end). xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp (fun x => pow x (nat_of_P n)) (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hf). intros x (w, Hw). unfold comp, proj_fun. now rewrite Hw. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. unfold proj_fun. rewrite X. rewrite <- (positive_nat_Z n), <- INR_IZR_INZ. apply derivable_pt_lim_pow_pos. apply lt_O_nat_of_P. case (f x). easy. intros r. unfold Xpower_int, Xpower_int', Xbind. case_eq (Z.pred (Zpos n))%Z. intros H. replace (nat_of_P n) with 1. easy. apply inj_eq_rev. rewrite <- Zpos_eq_Z_of_nat_o_nat_of_P. apply Zsucc_eq_compat in H. now rewrite <- Zsucc_pred in H. intros p H. apply f_equal. apply f_equal. apply inj_eq_rev. rewrite <-Nat.sub_1_r. rewrite inj_minus1. now rewrite <- 2!Zpos_eq_Z_of_nat_o_nat_of_P. rewrite Nat.le_succ_l. apply lt_O_nat_of_P. now case n. (* *) replace (Xpower_int (f x) (Z.pred (Zneg n))) with (match f x with Xnan => Xnan | Xreal r => if is_zero r then Xnan else Xreal (/ (pow r (S (nat_of_P n)))) end). xtotal. intro v. apply derivable_pt_lim_eq_locally with (comp (fun x => Rinv (pow x (nat_of_P n))) (proj_fun v f)). apply locally_true_imp with (2 := derivable_imp_defined_ne _ _ _ _ _ X Y Hf). intros x (w, (Hw1, Hw2)). unfold comp, proj_fun. rewrite Hw2. now case is_zero_spec. rewrite Rmult_comm. apply derivable_pt_lim_comp. apply Hf. change (fun x => (/ x ^ nat_of_P n)%R) with (comp Rinv (fun x => pow x (nat_of_P n))). unfold proj_fun. rewrite X. change (IZR (Zneg n)) with (Ropp (IZR (Zpos n))). rewrite <- positive_nat_Z, <- INR_IZR_INZ. replace (- INR (nat_of_P n) * / (r1 * r1 ^ nat_of_P n))%R with ((0 * r1 ^ (nat_of_P n) - 1 * fct_cte 1 r1) / Rsqr (r1 ^ (nat_of_P n)) * (INR (nat_of_P n) * (r1 ^ pred (nat_of_P n))))%R. apply derivable_pt_lim_comp. apply derivable_pt_lim_pow. apply derivable_pt_lim_eq with (div_fct (fct_cte 1) (fun x => x)). intros x. apply Rmult_1_l. apply derivable_pt_lim_div with (x := (r1 ^ nat_of_P n)%R). apply derivable_pt_lim_const. apply derivable_pt_lim_id. now apply pow_nonzero. unfold fct_cte. unfold Rsqr. pattern (nat_of_P n) at -5 ; replace (nat_of_P n) with (1 + pred (nat_of_P n))%nat. rewrite pow_add. field. refine (conj _ Y). now apply pow_nonzero. rewrite <-Nat.sub_1_r. rewrite Nat.add_comm, Nat.sub_add; [reflexivity|]. rewrite Nat.le_succ_l. apply lt_O_nat_of_P. case (f x). easy. intros r. simpl. rewrite <- Pplus_one_succ_r. now rewrite nat_of_P_succ_morphism. Qed. Theorem Xderive_pt_partial_fun : forall g f f', (forall x y, g x = Xreal y -> f x = Xreal y) -> forall x, Xderive_pt g x f' -> Xderive_pt f x f'. Proof. intros g f f' Heq x Hg. assert (Heqx := Heq x). xtotal. now assert (H := Heqx _ (refl_equal _)). intro v. apply derivable_pt_lim_eq_locally with (2 := Hg v). apply locally_true_imp with (2 := derivable_imp_defined_any _ _ _ _ X Hg). intros x (w, Hw). unfold proj_fun. rewrite Hw. now rewrite (Heq _ _ Hw). Qed. Theorem Xderive_pt_eq_fun : forall g f f', (forall x, f x = g x) -> forall x, Xderive_pt g x f' -> Xderive_pt f x f'. Proof. intros g f f' Heq x Hg. apply Xderive_pt_partial_fun with (2 := Hg). intros. now rewrite Heq. Qed. Theorem Xderive_pt_identity : forall x, Xderive_pt (fun x => x) x (Xmask (Xreal 1) x). Proof. intros [|x]. exact I. intro. apply derivable_pt_lim_id. Qed. Theorem Xderive_pt_constant : forall v x, Xderive_pt (fun _ => Xreal v) x (Xmask (Xreal 0) x). Proof. intros v [|x]. exact I. unfold proj_fun. intros w. apply (derivable_pt_lim_const v). Qed. Theorem Xderive_MVT : forall f f', Xderive f f' -> forall dom : R -> Prop, connected dom -> (forall x, dom x -> f' (Xreal x) <> Xnan) -> forall m, dom m -> forall x, dom x -> exists c, dom c /\ f (Xreal x) = Xadd (f (Xreal m)) (Xmul (f' (Xreal c)) (Xsub (Xreal x) (Xreal m))). Proof. intros f f' Hd dom Hdom Hf'. set (fr := proj_fun 0 f). set (fr' := proj_fun 0 f'). unfold Xderive, Xderive_pt in Hd. (* f defined on [a,b] *) assert (R1: forall x, dom x -> f (Xreal x) = Xreal (fr x)). intros x Hx. generalize (Hd (Xreal x)) (Hf' x Hx). unfold fr, proj_fun at 2. case (f' (Xreal x)). intros _ H. elim H. apply refl_equal. case (f (Xreal x)). intros _ H _. elim H. intros r _ _ _. apply refl_equal. (* f' defined on [a,b] *) assert (R2: forall x, dom x -> f' (Xreal x) = Xreal (fr' x)). intros x Hx. generalize (Hd (Xreal x)) (Hf' x Hx). unfold fr', proj_fun at 2. case (f' (Xreal x)). intros _ H. elim H. apply refl_equal. intros r _ _. apply refl_equal. (* for any u < v *) assert (H9: forall u v, dom u -> dom v -> (u < v)%R -> exists c, dom c /\ f (Xreal v) = Xadd (f (Xreal u)) (Xmul (f' (Xreal c)) (Xsub (Xreal v) (Xreal u)))). intros u v Hu Hv Huv. destruct (MVT_cor3 fr fr' u v Huv) as [c [P1 [P2 P3]]]. intros c Hc1 Hc2. assert (Hc := Hdom _ _ Hu Hv _ (conj Hc1 Hc2)). generalize (Hd (Xreal c)). rewrite (R2 _ Hc), (R1 _ Hc). intro H2. exact (H2 R0). exists c. assert (Hc := Hdom _ _ Hu Hv _ (conj P1 P2)). split. exact Hc. rewrite (R2 _ Hc), (R1 _ Hu), (R1 _ Hv). simpl. apply f_equal. exact P3. (* . *) intros m Hm x Hx. destruct (total_order_T m x) as [[H|H]|H]. now apply (H9 m x). (* m = x *) exists m. split. exact Hm. rewrite H, (R1 _ Hx), (R2 _ Hx). simpl. apply f_equal. ring. (* m > x *) destruct (H9 x m Hx Hm H) as (c, (Hc, H0)). exists c. split. exact Hc. rewrite H0. rewrite (R2 _ Hc), (R1 _ Hx). simpl. apply f_equal. ring. Qed. interval-4.11.1/src/Tactic.v000066400000000000000000000443531470547631300156320ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2016, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List ZArith Psatz. From Flocq Require Import Zaux. From Coquelicot Require Import Coquelicot. Require Import Sig. Require Import Interval_helper. Require Import Integral_helper. Require Import Plot_helper. Require Import Root_helper. Require Import Float_full. Inductive interval_tac_parameters : Set := | i_prec (p : positive) | i_bisect (v : R) | i_autodiff (v : R) | i_taylor (v : R) | i_degree (d : nat) | i_depth (d : nat) | i_fuel (f : positive) | i_width (w : Z) | i_relwidth (w : positive) | i_native_compute | i_size (w : positive) (h : positive) | i_decimal | i_delay. Require Tactic_float. Module IntervalTactic (F : FloatOps with Definition sensible_format := true with Definition radix := radix2). Module Private. Module I1 := FloatIntervalFull F. Module IT1 := IntegralTacticAux F I1. Module PT1 := PlotTacticAux F I1. Module RT1 := RootTacticAux F I1. Module I2 := Tactic_float.Interval. Module IT2 := IntegralTacticAux Tactic_float.Float I2. Module PT2 := PlotTacticAux Tactic_float.Float I2. Module RT2 := RootTacticAux Tactic_float.Float I2. Ltac do_interval_parse params depth := let rec aux fvar bvars prec degree depth native nocheck itm output params := lazymatch params with | nil => constr:((fvar, bvars, prec, degree, depth, native, nocheck, itm, output)) | cons (i_prec ?p) ?t => aux fvar bvars (Some p) degree depth native nocheck itm output t | cons (i_degree ?d) ?t => aux fvar bvars prec d depth native nocheck itm output t | cons (i_bisect ?x) ?t => aux fvar (cons x bvars) prec degree depth native nocheck itm output t | cons (i_autodiff ?x) ?t => aux (Some x) bvars prec degree depth native nocheck itm_autodiff output t | cons (i_taylor ?x) ?t => aux (Some x) bvars prec degree depth native nocheck itm_taylor output t | cons (i_depth ?d) ?t => aux fvar bvars prec degree d native nocheck itm output t | cons i_native_compute ?t => aux fvar bvars prec degree depth true nocheck itm output t | cons i_delay ?t => aux fvar bvars prec degree depth native true itm output t | cons i_decimal ?t => aux fvar bvars prec degree depth native nocheck itm true t | cons ?h _ => fail 100 "Unknown tactic parameter" h end in aux (@None R) (@nil R) (@None positive) 10%nat depth false false itm_naive false params. Ltac do_interval params := match do_interval_parse params 15%nat with | (?fvar, ?bvars, ?prec, ?degree, ?depth, ?native, ?nocheck, ?itm, _) => lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in IT1.IH.do_interval fvar bvars prec degree depth native nocheck itm | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in IT2.IH.do_interval fvar bvars prec degree depth native nocheck itm end end. Ltac do_interval_intro t extend params := match do_interval_parse params 5%nat with | (?fvar, ?bvars, ?prec, ?degree, ?depth, ?native, ?nocheck, ?itm, ?output) => lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in IT1.IH.do_interval_intro t extend fvar bvars prec degree depth native nocheck itm output | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in IT2.IH.do_interval_intro t extend fvar bvars prec degree depth native nocheck itm output end end. Ltac do_integral_parse params := let rec aux prec degree fuel width native nocheck output params := lazymatch params with | nil => constr:((prec, degree, fuel, width, native, nocheck, output)) | cons (i_prec ?p) ?t => aux (Some p) degree fuel width native nocheck output t | cons (i_degree ?d) ?t => aux prec d fuel width native nocheck output t | cons (i_fuel ?f) ?t => aux prec degree f width native nocheck output t | cons (i_width ?w) ?t => aux prec degree fuel (w, false) native nocheck output t | cons (i_relwidth ?w) ?t => aux prec degree fuel (Zneg w, true) native nocheck output t | cons i_native_compute ?t => aux prec degree fuel width true nocheck output t | cons i_delay ?t => aux prec degree fuel width native true output t | cons i_decimal ?t => aux prec degree fuel width native nocheck true t | cons ?h _ => fail 100 "Unknown tactic parameter" h end in aux (@None positive) 10%nat 100%positive (Zneg 10, true) false false false params. Ltac do_integral params := match do_integral_parse params with | (?prec, ?degree, ?fuel, _, ?native, ?nocheck, _) => lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in IT1.do_integral prec degree fuel native nocheck | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in IT2.do_integral prec degree fuel native nocheck end end. Ltac do_integral_intro y extend params := match do_integral_parse params with | (?prec, ?degree, ?fuel, ?width, ?native, ?nocheck, ?output) => lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in IT1.do_integral_intro y extend prec degree fuel width native nocheck output | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in IT2.do_integral_intro y extend prec degree fuel width native nocheck output end end. Ltac do_plot_parse params := let rec aux prec degree width height native params := lazymatch params with | nil => constr:((prec, degree, width, height, native)) | cons (i_prec ?p) ?t => aux (Some p) degree width height native t | cons (i_degree ?d) ?t => aux prec d width height native t | cons (i_size ?w ?h) ?t => aux prec degree w h native t | cons i_native_compute ?t => aux prec degree width height true t | cons ?h _ => fail 100 "Unknown tactic parameter" h end in aux (@None positive) 10%nat 512%positive 384%positive false params. Ltac do_plot t x1 x2 params := match do_plot_parse params with | (?prec, ?degree, ?width, ?height, ?native) => lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in PT1.do_plot t x1 x2 prec degree width height native | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in PT2.do_plot t x1 x2 prec degree width height native end end. Ltac do_plot_y t x1 x2 y1 y2 params := match do_plot_parse params with | (?prec, ?degree, ?width, ?height, ?native) => lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in PT1.do_plot_y t x1 x2 y1 y2 prec degree width height native | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in PT2.do_plot_y t x1 x2 y1 y2 prec degree width height native end end. Ltac do_root_parse params := let rec aux fvar prec depth native nocheck output params := lazymatch params with | nil => constr:((fvar, prec, depth, native, nocheck, output)) | cons (i_autodiff ?v) ?t => aux (Some v) prec depth native nocheck output t | cons (i_prec ?p) ?t => aux fvar (Some p) depth native nocheck output t | cons (i_depth ?d) ?t => aux fvar prec d native nocheck output t | cons i_native_compute ?t => aux fvar prec depth true nocheck output t | cons i_delay ?t => aux fvar prec depth native true output t | cons i_decimal ?t => aux fvar prec depth native nocheck true t | cons ?h _ => fail 100 "Unknown tactic parameter" h end in aux (@None R) (@None positive) 15%nat false false false params. Ltac do_root' Zy params := match do_root_parse params with | (?fvar, ?prec, ?depth, ?native, ?nocheck, _) => let x := lazymatch fvar with | Some ?v => v | None => get_root_var Zy end in lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in RT1.do_root x Zy prec depth native nocheck | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in RT2.do_root x Zy prec depth native nocheck end end. Ltac do_root_intro' Zy params := match do_root_parse params with | (?fvar, ?prec, ?depth, ?native, ?nocheck, ?output) => let x := lazymatch fvar with | Some ?v => v | None => get_root_var Zy end in lazymatch prec with | Some ?p => let prec := eval vm_compute in (F.PtoP p) in RT1.do_root_intro x Zy prec depth native nocheck output | None => let prec := eval vm_compute in (Tactic_float.Float.PtoP 53) in RT2.do_root_intro x Zy prec depth native nocheck output end end. Ltac do_root_intro_prop y1 y2 params := eapply (cut_root y1 y2) ; [ let H := fresh "H" in let K := fresh "K" in intros K H ; lazymatch y2 with | 0%R => idtac | _ => apply (Rminus_diag_eq y1 y2) in H end ; do_root_intro' H params ; eexact K | ]. Ltac do_root_intro Zy params := lazymatch type of Zy with | R => do_root_intro_prop Zy 0%R params | Prop => lazymatch Zy with | ?y1 = ?y2 => do_root_intro_prop y1 y2 params end | _ = 0%R => do_root_intro' Zy params | ?y1 = ?y2 => let H := fresh "H" in assert (H := Rminus_diag_eq y1 y2 Zy) ; do_root_intro' H params ; clear H end. Ltac do_root Zy params := tryif match goal with |- ?G => is_evar G end then let params := constr:(cons i_delay params) in let H := fresh "H" in lazymatch type of Zy with | R => refine (fun H : Zy = 0%R => _) ; do_root_intro' H params | Prop => refine (fun H : Zy => _) ; do_root_intro H params | _ = _ => do_root_intro Zy params end ; exact (fun K => K) else lazymatch type of Zy with | R => cut (Zy = 0%R) ; [ let H := fresh "H" in intros H ; do_root' H params | ] | Prop => cut Zy ; [ let H := fresh "H" in intros H ; do_root H params | ] | _ = 0%R => do_root' Zy params | ?y1 = ?y2 => let H := fresh "H" in assert (H := Rminus_diag_eq y1 y2 Zy) ; do_root' H params end. End Private. Import Private. Tactic Notation "interval" := do_interval (@nil interval_tac_parameters). Tactic Notation "interval" "with" constr(params) := do_interval ltac:(tuple_to_list params (@nil interval_tac_parameters)). Tactic Notation "interval" constr(t) := do_interval_intro t ie_none (cons i_delay nil) ; exact (fun H => H). Tactic Notation "interval" constr(t) "lower" := do_interval_intro t ie_upper (cons i_delay nil) ; exact (fun H => H). Tactic Notation "interval" constr(t) "upper" := do_interval_intro t ie_lower (cons i_delay nil) ; exact (fun H => H). Tactic Notation "interval" constr(t) "with" constr(params) := do_interval_intro t ie_none ltac:(tuple_to_list params (cons i_delay nil)) ; exact (fun H => H). Tactic Notation "interval" constr(t) "lower" "with" constr(params) := do_interval_intro t ie_upper ltac:(tuple_to_list params (cons i_delay nil)) ; exact (fun H => H). Tactic Notation "interval" constr(t) "upper" "with" constr(params) := do_interval_intro t ie_lower ltac:(tuple_to_list params (cons i_delay nil)) ; exact (fun H => H). Tactic Notation "interval_intro" constr(t) := do_interval_intro t ie_none (@nil interval_tac_parameters) ; intro. Tactic Notation "interval_intro" constr(t) "lower" := do_interval_intro t ie_upper (@nil interval_tac_parameters) ; intro. Tactic Notation "interval_intro" constr(t) "upper" := do_interval_intro t ie_lower (@nil interval_tac_parameters) ; intro. Tactic Notation "interval_intro" constr(t) "with" constr(params) := do_interval_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "interval_intro" constr(t) "lower" "with" constr(params) := do_interval_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "interval_intro" constr(t) "upper" "with" constr(params) := do_interval_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "interval_intro" constr(t) "as" simple_intropattern(H) := do_interval_intro t ie_none (@nil interval_tac_parameters) ; intros H. Tactic Notation "interval_intro" constr(t) "lower" "as" simple_intropattern(H) := do_interval_intro t ie_upper (@nil interval_tac_parameters) ; intros H. Tactic Notation "interval_intro" constr(t) "upper" "as" simple_intropattern(H) := do_interval_intro t ie_lower (@nil interval_tac_parameters) ; intros H. Tactic Notation "interval_intro" constr(t) "with" constr(params) "as" simple_intropattern(H) := do_interval_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. Tactic Notation "interval_intro" constr(t) "lower" "with" constr(params) "as" simple_intropattern(H) := do_interval_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. Tactic Notation "interval_intro" constr(t) "upper" "with" constr(params) "as" simple_intropattern(H) := do_interval_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. Tactic Notation "integral" := do_integral (@nil interval_tac_parameters). Tactic Notation "integral" "with" constr(params) := do_integral ltac:(tuple_to_list params (@nil interval_tac_parameters)). Tactic Notation "integral" constr(t) := do_integral_intro t ie_none (cons i_delay nil) ; exact (fun H => H). Tactic Notation "integral" constr(t) "lower" := do_integral_intro t ie_upper (cons i_delay nil) ; exact (fun H => H). Tactic Notation "integral" constr(t) "upper" := do_integral_intro t ie_lower (cons i_delay nil) ; exact (fun H => H). Tactic Notation "integral" constr(t) "with" constr(params) := do_integral_intro t ie_none ltac:(tuple_to_list params (cons i_delay nil)) ; exact (fun H => H). Tactic Notation "integral" constr(t) "lower" "with" constr(params) := do_integral_intro t ie_upper ltac:(tuple_to_list params (cons i_delay nil)) ; exact (fun H => H). Tactic Notation "integral" constr(t) "upper" "with" constr(params) := do_integral_intro t ie_lower ltac:(tuple_to_list params (cons i_delay nil)) ; exact (fun H => H). Tactic Notation "integral_intro" constr(t) := do_integral_intro t ie_none (@nil interval_tac_parameters) ; intro. Tactic Notation "integral_intro" constr(t) "lower" := do_integral_intro t ie_upper (@nil interval_tac_parameters) ; intro. Tactic Notation "integral_intro" constr(t) "upper" := do_integral_intro t ie_lower (@nil interval_tac_parameters) ; intro. Tactic Notation "integral_intro" constr(t) "with" constr(params) := do_integral_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "integral_intro" constr(t) "lower" "with" constr(params) := do_integral_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "integral_intro" constr(t) "upper" "with" constr(params) := do_integral_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "integral_intro" constr(t) "as" simple_intropattern(H) := do_integral_intro t ie_none (@nil interval_tac_parameters) ; intros H. Tactic Notation "integral_intro" constr(t) "lower" "as" simple_intropattern(H) := do_integral_intro t ie_upper (@nil interval_tac_parameters) ; intros H. Tactic Notation "integral_intro" constr(t) "upper" "as" simple_intropattern(H) := do_integral_intro t ie_lower (@nil interval_tac_parameters) ; intros H. Tactic Notation "integral_intro" constr(t) "with" constr(params) "as" simple_intropattern(H) := do_integral_intro t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. Tactic Notation "integral_intro" constr(t) "lower" "with" constr(params) "as" simple_intropattern(H) := do_integral_intro t ie_upper ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. Tactic Notation "integral_intro" constr(t) "upper" "with" constr(params) "as" simple_intropattern(H) := do_integral_intro t ie_lower ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. Tactic Notation "plot" constr(t) constr(x1) constr(x2) := do_plot t x1 x2 (@nil interval_tac_parameters). Tactic Notation "plot" constr(t) constr(x1) constr(x2) "with" constr(params) := do_plot t x1 x2 ltac:(tuple_to_list params (@nil interval_tac_parameters)). Tactic Notation "plot" constr(t) constr(x1) constr(x2) constr(y1) constr(y2) := do_plot_y t x1 x2 y1 y2 (@nil interval_tac_parameters). Tactic Notation "plot" constr(t) constr(x1) constr(x2) constr(y1) constr(y2) "with" constr(params) := do_plot_y t x1 x2 y1 y2 ltac:(tuple_to_list params (@nil interval_tac_parameters)). Tactic Notation "root" constr(Zy) := do_root Zy (@nil interval_tac_parameters). Tactic Notation "root" constr(Zy) "with" constr(params) := do_root Zy ltac:(tuple_to_list params (@nil interval_tac_parameters)). Tactic Notation "root_intro" constr(Zy) constr(x) := do_root_intro x Zy (@nil interval_tac_parameters) ; intro. Tactic Notation "root_intro" constr(Zy) := do_root_intro Zy (@nil interval_tac_parameters) ; intro. Tactic Notation "root_intro" constr(Zy) "with" constr(params) := do_root_intro Zy ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intro. Tactic Notation "root_intro" constr(Zy) "as" simple_intropattern(H) := do_root_intro Zy (@nil interval_tac_parameters) ; intros H. Tactic Notation "root_intro" constr(Zy) "with" constr(params) "as" simple_intropattern(H) := do_root_intro Zy ltac:(tuple_to_list params (@nil interval_tac_parameters)) ; intros H. End IntervalTactic. Require Import Specific_bigint. Require Import Specific_ops. Module SFBI2 := SpecificFloat BigIntRadix2. Module IT := IntervalTactic SFBI2. Export IT. interval-4.11.1/src/Tactic_bignum.v000066400000000000000000000002611470547631300171610ustar00rootroot00000000000000Require Import Specific_bigint. Require Import Specific_ops. Require Import Float_full. Module Float := SpecificFloat BigIntRadix2. Module Interval := FloatIntervalFull Float. interval-4.11.1/src/Tactic_primfloat.v000066400000000000000000000002171470547631300176760ustar00rootroot00000000000000Require Import Primitive_ops. Require Import Float_full. Module Float := PrimitiveFloat. Module Interval := FloatIntervalFull PrimitiveFloat. interval-4.11.1/src/Tactic_primfloat_opt.v000066400000000000000000000002161470547631300205570ustar00rootroot00000000000000Require Import Primitive_ops. Require Import Float_full_primfloat. Module Float := PrimitiveFloat. Module Interval := PrimFloatIntervalFull. interval-4.11.1/src/Tactics/000077500000000000000000000000001470547631300156155ustar00rootroot00000000000000interval-4.11.1/src/Tactics/Integral_helper.v000066400000000000000000001303001470547631300211050ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2021, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List ZArith Psatz. From Flocq Require Import Zaux. From Coquelicot Require Import Coquelicot. Require Import Stdlib. Require Import Coquelicot. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Require Import Integral. Require Import Eval. Require Import Bertrand. Require Import Tree. Require Import Prog. Require Import Reify. Require Import Refine. Require Import Interval_helper. Definition reify_var : R. Proof. exact 0%R. Qed. Ltac get_RInt_vars y i f := let fapp := eval cbv beta in (f reify_var) in let vars := constr:(reify_var :: @nil R) in let vars := match get_vars fapp vars with reify_var :: ?vars => vars end in let vars := constr:(i :: vars) in let vars := match get_vars y vars with i :: ?vars => vars end in vars. Ltac reify_RInt y f u v := let i := constr:(RInt f u v) in let vars := get_RInt_vars y i f in let vars := get_vars u vars in let vars := get_vars v vars in reify_partial y (i :: vars) ; intros <- ; erewrite <- RInt_ext by ( let t := fresh "t" in intros t _ ; hide_lhs ; let fapp := eval cbv beta in (f t) in reify_partial fapp (t :: vars) ; exact (fun H => H)) ; reify_partial u vars ; intros <- ; reify_partial v vars ; intros <- ; find_hyps vars. Ltac reify_RInt_gen_infty y fm u := let i := constr:(RInt_gen fm (at_point u) (Rbar_locally p_infty)) in let f := lazymatch fm with | (fun x => @?f x * _)%R => f | (fun x => @?f x / _)%R => f | (fun x => @?f x * / _)%R => f | _ => fail "Unsupported integrand" end in let vars := get_RInt_vars y i f in let vars := get_vars u vars in reify_partial y (i :: vars) ; intros <- ; erewrite <- RInt_gen_ext_eq by ( let t := fresh "t" in intros t ; hide_lhs ; apply (f_equal (fun x => Rmult x _)) ; let fapp := eval cbv beta in (f t) in reify_partial fapp (t :: vars) ; exact (fun H => H)) ; reify_partial u vars ; intros <- ; find_hyps vars. Ltac reify_RInt_gen_zero y fm v := let i := constr:(RInt_gen fm (at_right 0) (at_point v)) in let f := lazymatch fm with | (fun x => @?f x * _)%R => f | (fun x => @?f x / _)%R => f | (fun x => @?f x * / _)%R => f | _ => fail "Unsupported integrand" end in let vars := get_RInt_vars y i f in let vars := get_vars v vars in reify_partial y (i :: vars) ; intros <- ; erewrite <- RInt_gen_ext_eq by ( let t := fresh "t" in intros t ; hide_lhs ; apply (f_equal (fun x => Rmult x _)) ; let fapp := eval cbv beta in (f t) in reify_partial fapp (t :: vars) ; exact (fun H => H)) ; reify_partial v vars ; intros <- ; find_hyps vars. Module IntegralTacticAux (F : FloatOps with Definition sensible_format := true) (I : IntervalOps with Module F := F). Module F' := FloatExt F. Module IH := IntervalTacticAux I. Import IH. Module BI := BertrandInterval I. Module IR := IntegralRefiner I. Module IT := IntegralTaylor I. Module IU := IntegralTactic I. Definition eval_RInt_init prec deg hyps pf pu pv cf cu cv := let fi := let bounds := hyps ++ map (T.eval_bnd prec) cf in fun b => nth 0 (A.BndValuator.eval prec pf (b :: bounds)) I.nai in let ui := let bounds := hyps ++ map (T.eval_bnd prec) cu in nth 0 (A.BndValuator.eval prec pu bounds) I.nai in let vi := let bounds := hyps ++ map (T.eval_bnd prec) cv in nth 0 (A.BndValuator.eval prec pv bounds) I.nai in let cb := fun x => match x with IR.IBu => ui | IR.IBv => vi | IR.IBp x => I.singleton x end in let mid := fun u v => let u := cb u in let v := cb v in I.midpoint (I.join u v) in let Fi := let bounds := hyps ++ map (T.eval_bnd prec) cf in let bounds := map A.TaylorValuator.TM.const bounds in fun u v => let u := cb u in let v := cb v in let xi := I.join u v in let gi := A.TaylorValuator.TM.get_tm (prec, deg) xi (nth 0 (A.TaylorValuator.eval prec deg xi pf (A.TaylorValuator.TM.var :: bounds)) A.TaylorValuator.TM.dummy) in IT.taylor_integral_naive_intersection prec fi gi xi u v in (mid, Fi). Lemma contains_RInt : forall prec deg limit check vars hyps pf pu pv cf cu cv, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_init prec deg hyps pf pu pv cf cu cv in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt (fun t => Prog.eval_real' pf (t :: vars) cf) (Prog.eval_real' pu vars cu) (Prog.eval_real' pv vars cv))). Proof. intros prec deg limit check vars hyps pf pu pv cf cu cv H' Hp. unfold eval_RInt_init, Prog.eval_real'. simpl. fold (compute_inputs prec hyps cu). fold (compute_inputs prec hyps cv). assert (Hcu := app_merge_hyps_eval_bnd prec _ _ cu H'). assert (Hcv := app_merge_hyps_eval_bnd prec _ _ cv H'). generalize (A.BndValuator.eval_correct' prec pv _ _ Hcv 0). generalize (A.BndValuator.eval_correct' prec pu _ _ Hcu 0). generalize (nth 0 (A.BndValuator.eval prec pv (compute_inputs prec hyps cv)) I.nai). generalize (nth 0 (A.BndValuator.eval prec pu (compute_inputs prec hyps cu)) I.nai). generalize (nth 0 (Prog.eval_real pv (vars ++ map (fun c => eval c nil) cv)) 0%R). generalize (nth 0 (Prog.eval_real pu (vars ++ map (fun c => eval c nil) cu)) 0%R). clear -H' Hp. intros u v ui vi Hu Hv. apply IR.contains_RInt_valid. apply IR.bisect_correct ; [ typeclasses eauto .. | idtac ]. intros u' v'. set (cbu := match u' with IR.IBu => ui | IR.IBv => vi | IR.IBp x => I.singleton x end). set (cbv := match v' with IR.IBu => ui | IR.IBv => vi | IR.IBp x => I.singleton x end). fold (compute_inputs prec hyps cf). match goal with | |- IR.valid _ _ _ _ _ ?fi => let fi' := eval pattern cbu, cbv in fi in change fi with fi' end. apply IR.valid_at_point ; try easy. apply (app_merge_hyps_eval_bnd prec _ _ cf) in H'. clear -H' Hp. intros ui vi u v Hu Hv. set (i := IT.taylor_integral_naive_intersection _ _ _ _ _ _). apply RInt_helper. intros Hi. assert (ex_RInt (fun t => nth 0 (Prog.eval_real pf (t :: vars ++ map (fun c => eval c nil) cf)) 0%R) u v) as [I HI]. apply (A.BndValuator.ex_RInt_eval prec) with (xi := I.join ui vi) (1 := H') (2 := Hp). apply contains_connected. apply Rmin_case ; apply I.join_correct. now left. now right. apply Rmax_case ; apply I.join_correct. now left. now right. contradict Hi. unfold i, IT.taylor_integral_naive_intersection. clear i. rewrite I.real_correct. destruct (I.convert (I.mul _ _ _)) as [|il iu] eqn:Hm. easy. exfalso. now rewrite I.mul_propagate_r in Hm. exists I. apply (conj HI). rewrite <- is_RInt_unique with (1 := HI). apply IT.taylor_integral_naive_intersection_correct ; cycle 2. now exists I. exact Hu. exact Hv. apply I.join_correct. now left. apply I.join_correct. now right. intros xi x Ix. now apply A.BndValuator.eval_correct_ext'. apply A.TaylorValuator.TM.get_tm_correct ; cycle 1. exists u. apply I.join_correct. now left. now apply A.TaylorValuator.eval_correct_aux'. Qed. Definition check_goal prec hyps pg cg g := let bounds := hyps ++ map (T.eval_bnd prec) cg in let check := R.eval_goal_bnd prec g in fun b => check (nth 0 (A.BndValuator.eval prec pg (b :: bounds)) I.nai). Definition eval_RInt prec deg limit hyps pg pf pu pv cg cf cu cv g := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_init prec deg hyps pf pu pv cf cu cv in let check := check_goal prec hyps pg cg g in check (IR.bisect prec limit mid Fi check). Theorem eval_RInt_correct : forall prec deg limit vars hyps pg pf pu pv cg cf cu cv g, no_floor_prog pf = true -> eval_RInt prec deg limit hyps pg pf pu pv cg cf cu cv g = true -> eval_hyps hyps vars ( eval_goal g (Prog.eval_real' pg ( (RInt (fun t => Prog.eval_real' pf (t :: vars) cf) (Prog.eval_real' pu vars cu) (Prog.eval_real' pv vars cv)) :: vars) cg)). Proof. intros prec deg limit vars hyps pg pf pu pv cg cf cu cv g Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply (R.eval_goal_bnd_correct prec) with (2 := H). unfold eval_real'. simpl. fold (compute_inputs prec hyps cg). apply A.BndValuator.eval_correct_ext'. now apply app_merge_hyps_eval_bnd. now apply contains_RInt. Qed. Definition eval_RInt_contains prec deg limit hyps pf pu pv cf cu cv b := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_init prec deg hyps pf pu pv cf cu cv in let check yi := I.subset yi b in check (IR.bisect prec limit mid Fi check). Theorem eval_RInt_contains_correct : forall prec deg limit vars hyps pf pu pv cf cu cv b, no_floor_prog pf = true -> eval_RInt_contains prec deg limit hyps pf pu pv cf cu cv b = true -> eval_hyps hyps vars ( contains (I.convert b) (Xreal (RInt (fun t => Prog.eval_real' pf (t :: vars) cf) (Prog.eval_real' pu vars cu) (Prog.eval_real' pv vars cv)))). Proof. intros prec deg limit vars hyps pf pu pv cf cu cv b Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply I.subset_correct with (2 := H). now apply contains_RInt. Qed. Definition check_width prec (w : F.type * bool) yi := let yl := I.lower yi in let yu := I.upper yi in let (f, r) := w in let w := if r then F.mul_UP prec (F.midpoint yl yu) f else f in F'.le' (F.sub_UP prec (I.upper yi) (I.lower yi)) f. Definition eval_RInt_plain prec deg limit hyps pf pu pv cf cu cv w := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_init prec deg hyps pf pu pv cf cu cv in IR.bisect prec limit mid Fi (check_width prec w). Definition bertrand_prog alpha beta p := let x := length p in app p (Prog.Unary (PowerInt alpha) x :: Prog.Unary Ln (S x) :: Prog.Unary (PowerInt (Z_of_nat beta)) 0 :: Prog.Binary Mul 2 0 :: Prog.Binary Mul 4 0 :: nil). Lemma bertrand_prog_correct : forall alpha beta p c x, nth 0 (Prog.eval_real (bertrand_prog alpha beta p) (x :: c)) 0 = (nth 0 (Prog.eval_real p (x :: c)) 0 * (powerRZ x alpha * pow (ln x) beta)). Proof. intros alpha beta p c x. unfold Prog.eval_real, bertrand_prog. rewrite 2!Prog.rev_formula. rewrite rev_app_distr. simpl. replace (nth (length p) _ _) with x. now rewrite <- pow_powerRZ. rewrite <- rev_length. now induction (rev p) as [|h t]. Qed. Definition c1 := F.fromZ 1. Definition bertrand_infty_interval alpha beta prec ui := if F'.le' c1 (I.lower ui) then BI.f_int_fast prec ui alpha beta else I.nai. Definition bertrand_zero_interval alpha beta prec vi := if andb (F'.lt' F.zero (I.lower vi)) (F'.le' (I.upper vi) c1) then BI.f0eps_int prec vi alpha beta else I.nai. Definition invxln_prog beta p := let x := length p in app p (Prog.Unary Ln x :: Prog.Unary (PowerInt (Z_of_nat (S (S beta)))) 0 :: Prog.Binary Mul (S (S x)) 0 :: Prog.Binary Div 3 0 :: nil). Lemma invxln_prog_correct : forall beta p c x, nth 0 (Prog.eval_real (invxln_prog beta p) (x :: c)) 0 = (nth 0 (Prog.eval_real p (x :: c)) 0 / (x * pow (ln x) (S (S beta)))). Proof. intros beta p c x. unfold Prog.eval_real, invxln_prog. rewrite 2!Prog.rev_formula. rewrite rev_app_distr. simpl. replace (nth (length p) _ _) with x. now rewrite Pos2Nat.inj_succ, SuccNat2Pos.id_succ. rewrite <- rev_length. now induction (rev p) as [|h t]. Qed. Definition invxln_interval beta prec ui := if F'.lt' c1 (I.lower ui) then BI.f_neg_int prec ui (S beta) else I.nai. (*Eval cbv -[ln exp powerRZ IZR] in Prog.eval_real (invxln_prog 2 (Prog.Unary Exp 0 :: nil)) (42%R :: nil).*) Definition eval_RInt_gen_infty_init prec deg hyps (mi : F.precision -> I.type -> I.type) pf pfm pu cf cfm cu := let fi := let bounds := hyps ++ map (T.eval_bnd prec) cf in fun b => nth 0 (A.BndValuator.eval prec pf (b :: bounds)) I.nai in let fmi := let bounds := hyps ++ map (T.eval_bnd prec) cfm in fun b => nth 0 (A.BndValuator.eval prec pfm (b :: bounds)) I.nai in let ui := let bounds := hyps ++ map (T.eval_bnd prec) cu in nth 0 (A.BndValuator.eval prec pu bounds) I.nai in let mid u v := match u, v with | IR.IBu, IR.IBv => I.midpoint (I.upper_extent ui) | IR.IBu, IR.IBp v => I.midpoint (I.join ui (I.singleton v)) | IR.IBp u, IR.IBv => I.midpoint (I.upper_extent (I.singleton u)) | IR.IBp u, IR.IBp v => I.midpoint (I.bnd u v) | _, _ => F.zero end in let Fi1 := let bounds := hyps ++ map (T.eval_bnd prec) cfm in let bounds := map A.TaylorValuator.TM.const bounds in fun ui vi => let xi := I.join ui vi in let gi := A.TaylorValuator.TM.get_tm (prec, deg) xi (nth 0 (A.TaylorValuator.eval prec deg xi pfm (A.TaylorValuator.TM.var :: bounds)) A.TaylorValuator.TM.dummy) in IT.taylor_integral_naive_intersection prec fmi gi xi ui vi in let Fi2 := let bounds := hyps ++ map (T.eval_bnd prec) cf in let bounds := map A.TaylorValuator.TM.const bounds in fun ui => let yi := fi (I.upper_extent ui) in if I.bounded yi then I.mul prec yi (mi prec ui) else I.nai in let Fi u v := match u, v with | IR.IBu, IR.IBv => Fi2 ui | IR.IBu, IR.IBp v => Fi1 ui (I.singleton v) | IR.IBp u, IR.IBv => Fi2 (I.singleton u) | IR.IBp u, IR.IBp v => Fi1 (I.singleton u) (I.singleton v) | _, _ => I.nai end in (mid, Fi). Lemma contains_RInt_gen_infty : forall prec deg limit check vars hyps mi mp mr pf pu cf cu, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> (forall yi ui f u, contains (I.convert ui) (Xreal u) -> (forall t, (u <= t)%R -> continuous f t) -> (forall t, (u <= t)%R -> contains (I.convert yi) (Xreal (f t))) -> I.bounded yi = true -> I.convert (mi prec ui) <> Inan -> exists I : R, is_RInt_gen (fun t : R => f t * mr t) (at_point u) (Rbar_locally p_infty) I /\ contains (I.convert (I.mul prec yi (mi prec ui))) (Xreal I)) -> (forall c t, nth 0 (Prog.eval_real mp (t :: c)) 0 = nth 0 (Prog.eval_real pf (t :: c)) 0 * mr t)%R -> no_floor_prog mp = true -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_infty_init prec deg hyps mi pf mp pu cf cf cu in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * mr t) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty))). Proof. intros prec deg limit check vars hyps mi mp mr pf pu cf cu H' Hf Hm1 Hm2 Hp. unfold Prog.eval_real'. simpl. fold (compute_inputs prec hyps cu). assert (Hcu := app_merge_hyps_eval_bnd prec _ _ cu H'). generalize (A.BndValuator.eval_correct' prec pu _ _ Hcu 0). generalize (nth 0 (A.BndValuator.eval prec pu (compute_inputs prec hyps cu)) I.nai). generalize (nth 0 (Prog.eval_real pu (vars ++ map (fun c => eval c nil) cu)) 0%R). clear -H' Hf Hm1 Hm2 Hp. intros u ui Hu. apply IR.bisect_correct with (uf := at_point u) (vf := Rbar_locally p_infty) ; [ typeclasses eauto .. | idtac ]. intros u' v'. fold (compute_inputs prec hyps cf). set (bounds := compute_inputs prec hyps cf). apply (app_merge_hyps_eval_bnd prec _ _ cf) in H'. set (fi := fun b => nth 0 (A.BndValuator.eval prec pf (b :: bounds)) I.nai). set (fmi := fun b => nth 0 (A.BndValuator.eval prec mp (b :: bounds)) I.nai). set (Fi1 := let bounds := map A.TaylorValuator.TM.const bounds in fun ui vi => let xi := I.join ui vi in let gi := A.TaylorValuator.TM.get_tm (prec, deg) xi (nth 0 (A.TaylorValuator.eval prec deg xi mp (A.TaylorValuator.TM.var :: bounds)) A.TaylorValuator.TM.dummy) in IT.taylor_integral_naive_intersection prec fmi gi xi ui vi). set (Fi2 := let bounds := map A.TaylorValuator.TM.const bounds in fun ui => let yi := fi (I.upper_extent ui) in if I.bounded yi then I.mul prec yi (mi prec ui) else I.nai). apply IR.valid_at_mixed with (u := u) (v := Rbar_locally p_infty) (fi1 := Fi1) (fi2 := Fi2) (ui := ui) (u' := u') (v' := v'). - typeclasses eauto. - exact Hu. - clear -H' Hf Hm1 Hm2 Hp. intros ui vi u v Hu Hv. apply RInt_helper. intros Hi. assert (ex_RInt (fun t => nth 0 (Prog.eval_real pf (t :: vars ++ map (fun c => eval c nil) cf)) 0%R * mr t) u v) as [I HI]. eapply ex_RInt_ext. intros x _. apply Hm1. apply (A.BndValuator.ex_RInt_eval prec) with (xi := I.join ui vi) (1 := H'). apply Hm2. apply contains_connected. apply Rmin_case ; apply I.join_correct. now left. now right. apply Rmax_case ; apply I.join_correct. now left. now right. contradict Hi. unfold Fi1, IT.taylor_integral_naive_intersection, fmi. clear -Hi. rewrite I.real_correct. destruct (I.convert (I.mul _ _ _)) as [|il iu] eqn:Hm. easy. exfalso. eapply I.mul_propagate_r in Hi. fold bounds in Hi. now rewrite Hm in Hi. exists I. apply (conj HI). rewrite <- is_RInt_unique with (1 := HI). apply IT.taylor_integral_naive_intersection_correct ; cycle 2. now exists I. exact Hu. exact Hv. apply I.join_correct. now left. apply I.join_correct. now right. intros xi x Hx. rewrite <- Hm1. now apply A.BndValuator.eval_correct_ext'. apply A.TaylorValuator.TM.get_tm_correct ; cycle 1. exists u. apply I.join_correct. now left. eapply A.TaylorValuator.TM.approximates_ext. intros x. rewrite <- Hm1. easy. now apply A.TaylorValuator.eval_correct_aux'. - clear -H' Hp Hf. intros ui u Hu. apply RInt_gen_helper ; [typeclasses eauto .. | idtac]. unfold Fi2. destruct I.bounded eqn:Hb ; cycle 1. now rewrite I.nai_correct. intros Hi. apply Hf with (1 := Hu) (4 := Hb). + intros t Ht. apply A.BndValuator.continuous_eval with (prec := prec) (xi := I.upper_extent ui) (1 := H') (2 := Hp). now apply I.upper_extent_correct with (1 := Hu). change (I.convert (fi (I.upper_extent ui)) <> Inan). contradict Hi. now apply I.mul_propagate_l. + intros t Ht. apply A.BndValuator.eval_correct_ext' with (1 := H'). now apply I.upper_extent_correct with (1 := Hu). + contradict Hi. now apply I.mul_propagate_r. Qed. Definition eval_RInt_gen_infty prec deg limit hyps mi pg pf pfm pu cg cf cfm cu g := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_infty_init prec deg hyps mi pf pfm pu cf cfm cu in let check := check_goal prec hyps pg cg g in check (IR.bisect prec limit mid Fi check). Definition eval_RInt_gen_infty_contains prec deg limit hyps mi pf pfm pu cf cfm cu b := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_infty_init prec deg hyps mi pf pfm pu cf cfm cu in let check yi := I.subset yi b in check (IR.bisect prec limit mid Fi check). Definition eval_RInt_gen_infty_plain prec deg limit hyps mi pf pfm pu cf cfm cu w := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_infty_init prec deg hyps mi pf pfm pu cf cfm cu in IR.bisect prec limit mid Fi (check_width prec w). Lemma contains_RInt_gen_infty_bertrand : forall prec deg limit check vars hyps alpha beta pf pu cf cu, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> (alpha < -1)%Z -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_infty_init prec deg hyps (bertrand_infty_interval alpha beta) pf (bertrand_prog alpha beta pf) pu cf cf cu in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * (powerRZ t alpha * pow (ln t) beta)) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty))). Proof. intros prec deg limit check vars hyps alpha beta pf pu cf cu H' Halpha Hp. apply contains_RInt_gen_infty ; cycle 2. - apply bertrand_prog_correct. - unfold bertrand_prog, no_floor_prog in Hp |- *. rewrite <- fold_left_rev_right. rewrite rev_app_distr. simpl. rewrite fold_left_rev_right. now rewrite Hp. - exact Hp. - exact H'. - intros fi ui f u Hu Hc Hf Hb. unfold bertrand_infty_interval, c1. destruct F'.le' eqn:Hul ; cycle 1. now rewrite I.nai_correct. intros _. assert (Hu': (1 <= u)%R). apply F'.le'_correct in Hul. rewrite F.fromZ_correct in Hul by easy. rewrite I.lower_correct in Hul by now exists u. destruct (I.convert ui) as [|[|ul] ur] ; try easy. now apply Rle_trans with (2 := proj1 Hu). eapply IU.integral_interval_mul_infty with (1 := Hu) (2 := Hf) (3 := Hb) (4 := Hc). + intros x Hx. assert (Hx': (0 < x)%R). apply Rlt_le_trans with (1 := Rlt_0_1). now apply Rle_trans with u. apply @continuous_mult. apply @ex_derive_continuous. apply ex_derive_powerRZ. right. now apply Rgt_not_eq. apply @ex_derive_continuous. apply ex_derive_pow. eexists. now apply is_derive_ln. + intros x Hx. apply Stdlib.Rmult_le_pos_pos. apply powerRZ_le. lra. apply pow_le. rewrite <- ln_1. apply ln_le. apply Rlt_0_1. now apply Rle_trans with u. + apply f_lim_correct with (2 := Halpha). now apply Rlt_le_trans with (1 := Rlt_0_1). + apply BI.f_int_fast_correct. exact Hu. now apply Rlt_le_trans with (1 := Rlt_0_1). now apply Zlt_not_eq. Qed. Theorem eval_RInt_gen_infty_bertrand : forall prec deg limit vars hyps alpha beta pg pf pu cg cf cu g, (alpha < -1)%Z -> no_floor_prog pf = true -> eval_RInt_gen_infty prec deg limit hyps (bertrand_infty_interval alpha beta) pg pf (bertrand_prog alpha beta pf) pu cg cf cf cu g = true -> eval_hyps hyps vars ( eval_goal g (Prog.eval_real' pg ( (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * (powerRZ t alpha * pow (ln t) beta)) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty)) :: vars) cg)). Proof. intros prec deg limit vars hyps alpha beta pg pf pu cg cf cu g Halpha Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply (R.eval_goal_bnd_correct prec) with (2 := H). unfold eval_real'. simpl. fold (compute_inputs prec hyps cg). apply A.BndValuator.eval_correct_ext'. now apply app_merge_hyps_eval_bnd. now apply contains_RInt_gen_infty_bertrand. Qed. Theorem eval_RInt_gen_infty_contains_bertrand : forall prec deg limit vars hyps alpha beta pf pu cf cu b, (alpha < -1)%Z -> no_floor_prog pf = true -> eval_RInt_gen_infty_contains prec deg limit hyps (bertrand_infty_interval alpha beta) pf (bertrand_prog alpha beta pf) pu cf cf cu b = true -> eval_hyps hyps vars ( contains (I.convert b) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * (powerRZ t alpha * pow (ln t) beta)) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty)))). Proof. intros prec deg limit vars hyps alpha beta pf pu cf cu b Halpha Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply I.subset_correct with (2 := H). now apply contains_RInt_gen_infty_bertrand. Qed. Lemma contains_RInt_gen_infty_invxln : forall prec deg limit check vars hyps beta pf pu cf cu, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_infty_init prec deg hyps (invxln_interval beta) pf (invxln_prog beta pf) pu cf cf cu in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf / (t * pow (ln t) (S (S beta)))) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty))). Proof. intros prec deg limit check vars hyps beta pf pu cf cu H' Hp. apply contains_RInt_gen_infty ; cycle 2. - apply invxln_prog_correct. - unfold invxln_prog, no_floor_prog in Hp |- *. rewrite <- fold_left_rev_right. rewrite rev_app_distr. simpl. rewrite fold_left_rev_right. now rewrite Hp. - exact Hp. - exact H'. - intros fi ui f u Hu Hc Hf Hb. unfold invxln_interval, c1. destruct F'.lt' eqn:Hul ; cycle 1. now rewrite I.nai_correct. intros _. assert (Hu': (1 < u)%R). apply F'.lt'_correct in Hul. rewrite F.fromZ_correct in Hul by easy. rewrite I.lower_correct in Hul by now exists u. destruct (I.convert ui) as [|[|ul] ur] ; try easy. now apply Rlt_le_trans with (2 := proj1 Hu). eapply IU.integral_interval_mul_infty with (1 := Hu) (2 := Hf) (3 := Hb) (4 := Hc). + intros x Hx. assert (Hx': (1 < x)%R). now apply Rlt_le_trans with u. apply (continuous_f_neg x (S (S beta))). now apply Rlt_trans with (1 := Rlt_0_1). now apply Rgt_not_eq. + intros x Hx. apply Rlt_le, Rinv_0_lt_compat, Rmult_lt_0_compat. lra. apply (pow_lt (ln x) (S (S beta))). rewrite <- ln_1. apply ln_increasing. apply Rlt_0_1. now apply Rlt_le_trans with u. + now apply (f_neg_correct_RInt_gen_a_infty u (S beta)). + now apply BI.f_neg_int_correct. Qed. Theorem eval_RInt_gen_infty_invxln : forall prec deg limit vars hyps beta pg pf pu cg cf cu g, no_floor_prog pf = true -> eval_RInt_gen_infty prec deg limit hyps (invxln_interval beta) pg pf (invxln_prog beta pf) pu cg cf cf cu g = true -> eval_hyps hyps vars ( eval_goal g (Prog.eval_real' pg ( (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf / (t * pow (ln t) (S (S beta)))) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty)) :: vars) cg)). Proof. intros prec deg limit vars hyps beta pg pf pu cg cf cu g Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply (R.eval_goal_bnd_correct prec) with (2 := H). unfold eval_real'. simpl. fold (compute_inputs prec hyps cg). apply A.BndValuator.eval_correct_ext'. now apply app_merge_hyps_eval_bnd. now apply contains_RInt_gen_infty_invxln. Qed. Theorem eval_RInt_gen_infty_contains_invxln : forall prec deg limit vars hyps beta pf pu cf cu b, no_floor_prog pf = true -> eval_RInt_gen_infty_contains prec deg limit hyps (invxln_interval beta) pf (invxln_prog beta pf) pu cf cf cu b = true -> eval_hyps hyps vars ( contains (I.convert b) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf / (t * pow (ln t) (S (S beta)))) (at_point (Prog.eval_real' pu vars cu)) (Rbar_locally p_infty)))). Proof. intros prec deg limit vars hyps beta pf pu cf cu b Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply I.subset_correct with (2 := H). now apply contains_RInt_gen_infty_invxln. Qed. Definition eval_RInt_gen_zero_init prec deg hyps (mi : I.precision -> I.type -> I.type) pf pfm pv cf cfm cv := let fi := let bounds := hyps ++ map (T.eval_bnd prec) cf in fun b => nth 0 (A.BndValuator.eval prec pf (b :: bounds)) I.nai in let fmi := let bounds := hyps ++ map (T.eval_bnd prec) cfm in fun b => nth 0 (A.BndValuator.eval prec pfm (b :: bounds)) I.nai in let vi := let bounds := hyps ++ map (T.eval_bnd prec) cv in nth 0 (A.BndValuator.eval prec pv bounds) I.nai in let mid u v := match u, v with | IR.IBu, IR.IBv => I.midpoint (I.join I.zero vi) | IR.IBu, IR.IBp v => I.midpoint (I.bnd F.zero v) | IR.IBp u, IR.IBv => I.midpoint (I.join (I.singleton u) vi) | IR.IBp u, IR.IBp v => I.midpoint (I.bnd u v) | _, _ => F.zero end in let Fi1 := let bounds := hyps ++ map (T.eval_bnd prec) cfm in let bounds := map A.TaylorValuator.TM.const bounds in fun ui vi => let xi := I.join ui vi in let gi := A.TaylorValuator.TM.get_tm (prec, deg) xi (nth 0 (A.TaylorValuator.eval prec deg xi pfm (A.TaylorValuator.TM.var :: bounds)) A.TaylorValuator.TM.dummy) in IT.taylor_integral_naive_intersection prec fmi gi xi ui vi in let Fi2 := let bounds := hyps ++ map (T.eval_bnd prec) cf in let bounds := map A.TaylorValuator.TM.const bounds in fun vi => let yi := fi (I.join I.zero vi) in if I.bounded yi then I.mul prec yi (mi prec vi) else I.nai in let Fi u v := match u, v with | IR.IBu, IR.IBv => Fi2 vi | IR.IBu, IR.IBp v => Fi2 (I.singleton v) | IR.IBp u, IR.IBv => Fi1 (I.singleton u) vi | IR.IBp u, IR.IBp v => Fi1 (I.singleton u) (I.singleton v) | _, _ => I.nai end in (mid, Fi). Lemma contains_RInt_gen_zero : forall prec deg limit check vars hyps mi mp mr pf pv cf cv, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> (forall yi vi f v, contains (I.convert vi) (Xreal v) -> (forall t, (0 <= t <= v)%R -> continuous f t) -> (forall t, (0 <= t <= v)%R -> contains (I.convert yi) (Xreal (f t))) -> I.bounded yi = true -> I.convert (mi prec vi) <> Inan -> exists I : R, is_RInt_gen (fun t : R => f t * mr t) (at_right 0) (at_point v) I /\ contains (I.convert (I.mul prec yi (mi prec vi))) (Xreal I)) -> (forall c t, nth 0 (Prog.eval_real mp (t :: c)) 0 = nth 0 (Prog.eval_real pf (t :: c)) 0 * mr t)%R -> no_floor_prog mp = true -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_zero_init prec deg hyps mi pf mp pv cf cf cv in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * mr t) (at_right 0) (at_point (Prog.eval_real' pv vars cv)))). Proof. intros prec deg limit check vars hyps mi mp mr pf pv cf cv H' Hf Hm1 Hm2 Hp. unfold Prog.eval_real'. simpl. fold (compute_inputs prec hyps cv). assert (Hcv := app_merge_hyps_eval_bnd prec _ _ cv H'). generalize (A.BndValuator.eval_correct' prec pv _ _ Hcv 0). generalize (nth 0 (A.BndValuator.eval prec pv (compute_inputs prec hyps cv)) I.nai). generalize (nth 0 (Prog.eval_real pv (vars ++ map (fun c => eval c nil) cv)) 0%R). clear -H' Hf Hm1 Hm2 Hp. intros v vi Hv. apply IR.bisect_correct with (uf := at_right 0) (vf := at_point v) ; [ typeclasses eauto .. | idtac ]. intros u' v'. fold (compute_inputs prec hyps cf). apply (app_merge_hyps_eval_bnd prec _ _ cf) in H'. set (bounds := compute_inputs prec hyps cf). set (fi := fun b => nth 0 (A.BndValuator.eval prec pf (b :: bounds)) I.nai). set (fmi := fun b => nth 0 (A.BndValuator.eval prec mp (b :: bounds)) I.nai). set (Fi1 := let bounds := map A.TaylorValuator.TM.const bounds in fun ui vi => let xi := I.join ui vi in let gi := A.TaylorValuator.TM.get_tm (prec, deg) xi (nth 0 (A.TaylorValuator.eval prec deg xi mp (A.TaylorValuator.TM.var :: bounds)) A.TaylorValuator.TM.dummy) in IT.taylor_integral_naive_intersection prec fmi gi xi ui vi). set (Fi2 := let bounds := map A.TaylorValuator.TM.const bounds in fun vi => let yi := fi (I.join I.zero vi) in if I.bounded yi then I.mul prec yi (mi prec vi) else I.nai). apply IR.valid_at_mixed' with (u := at_right 0) (v := v) (fi1 := Fi1) (fi2 := Fi2) (vi := vi) (u' := u') (v' := v'). - typeclasses eauto. - exact Hv. - clear -H' Hf Hm1 Hm2 Hp. intros ui vi u v Hu Hv. apply RInt_helper. intros Hi. assert (ex_RInt (fun t => nth 0 (Prog.eval_real pf (t :: vars ++ map (fun c => eval c nil) cf)) 0%R * mr t) u v) as [I HI]. eapply ex_RInt_ext. intros x _. apply Hm1. apply (A.BndValuator.ex_RInt_eval prec) with (xi := I.join ui vi) (1 := H'). apply Hm2. apply contains_connected. apply Rmin_case ; apply I.join_correct. now left. now right. apply Rmax_case ; apply I.join_correct. now left. now right. contradict Hi. unfold Fi1, IT.taylor_integral_naive_intersection, fmi. clear -Hi. rewrite I.real_correct. destruct (I.convert (I.mul _ _ _)) as [|il iu] eqn:Hm. easy. exfalso. eapply I.mul_propagate_r in Hi. fold bounds in Hi. now rewrite Hm in Hi. exists I. apply (conj HI). rewrite <- is_RInt_unique with (1 := HI). apply IT.taylor_integral_naive_intersection_correct ; cycle 2. now exists I. exact Hu. exact Hv. apply I.join_correct. now left. apply I.join_correct. now right. intros xi x Hx. rewrite <- Hm1. now apply A.BndValuator.eval_correct_ext'. apply A.TaylorValuator.TM.get_tm_correct ; cycle 1. exists u. apply I.join_correct. now left. eapply A.TaylorValuator.TM.approximates_ext. intros x. rewrite <- Hm1. easy. now apply A.TaylorValuator.eval_correct_aux'. - clear -H' Hp Hf. intros vi v Hv. apply RInt_gen_helper ; [typeclasses eauto .. | idtac]. unfold Fi2. destruct I.bounded eqn:Hb ; cycle 1. now rewrite I.nai_correct. assert (Ht': forall t, (0 <= t <= v)%R -> contains (I.convert (I.join I.zero vi)) (Xreal t)). apply contains_connected. apply I.join_correct. left. rewrite I.zero_correct. split ; apply Rle_refl. apply I.join_correct. now right. intros Hi. apply Hf with (1 := Hv) (4 := Hb). + intros t Ht. apply A.BndValuator.continuous_eval with (prec := prec) (xi := I.join I.zero vi) (1 := H') (2 := Hp). now apply Ht'. change (I.convert (fi (I.join I.zero vi)) <> Inan). contradict Hi. now apply I.mul_propagate_l. + intros t Ht. apply A.BndValuator.eval_correct_ext' with (1 := H'). now apply Ht'. + contradict Hi. now apply I.mul_propagate_r. Qed. Definition eval_RInt_gen_zero prec deg limit hyps mi pg pf pfm pv cg cf cfm cv g := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_zero_init prec deg hyps mi pf pfm pv cf cfm cv in let check := check_goal prec hyps pg cg g in check (IR.bisect prec limit mid Fi check). Definition eval_RInt_gen_zero_contains prec deg limit hyps mi pf pfm pv cf cfm cv b := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_zero_init prec deg hyps mi pf pfm pv cf cfm cv in let check yi := I.subset yi b in check (IR.bisect prec limit mid Fi check). Definition eval_RInt_gen_zero_plain prec deg limit hyps mi pf pfm pv cf cfm cv w := let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_zero_init prec deg hyps mi pf pfm pv cf cfm cv in IR.bisect prec limit mid Fi (check_width prec w). Lemma contains_RInt_gen_zero_bertrand : forall prec deg limit check vars hyps alpha beta pf pv cf cv, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> (-1 < alpha)%Z -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_zero_init prec deg hyps (bertrand_zero_interval alpha beta) pf (bertrand_prog alpha beta pf) pv cf cf cv in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * (powerRZ t alpha * pow (ln t) beta)) (at_right 0) (at_point (Prog.eval_real' pv vars cv)))). Proof. intros prec deg limit check vars hyps alpha beta pf pv cf cv H' Halpha Hp. apply contains_RInt_gen_zero ; cycle 2. - apply bertrand_prog_correct. - unfold bertrand_prog, no_floor_prog in Hp |- *. rewrite <- fold_left_rev_right. rewrite rev_app_distr. simpl. rewrite fold_left_rev_right. now rewrite Hp. - exact Hp. - exact H'. - intros fi vi f v Hv Hc Hf Hb. unfold bertrand_zero_interval, c1. destruct F'.lt' eqn:Hvl ; cycle 1. cbv [andb]. now rewrite I.nai_correct. destruct F'.le' eqn:Hvu ; cycle 1. cbv [andb]. now rewrite I.nai_correct. intros _. assert (Hv': (0 < v)%R). apply F'.lt'_correct in Hvl. rewrite F.zero_correct in Hvl. rewrite I.lower_correct in Hvl by now exists v. destruct (I.convert vi) as [|[|vl] vr] ; try easy. now apply Rlt_le_trans with (2 := proj1 Hv). eapply IU.integral_interval_mul_zero with (1 := Hv') (2 := Hv) (3 := Hf) (4 := Hb) (5 := Hc). + intros x Hx. apply @continuous_mult. apply @ex_derive_continuous. apply ex_derive_powerRZ. right. now apply Rgt_not_eq. apply @ex_derive_continuous. apply ex_derive_pow. eexists. now apply is_derive_ln. + destruct (Zeven_odd_dec (Z.of_nat beta)) as [Hbeta|Hbeta] ; [left|right] ; intros x Hx. apply Rmult_le_pos_pos. now apply powerRZ_le. apply IT.TM.TMI.ZEven_pow_le. now apply Zeven_equiv. apply Rmult_le_pos_neg. now apply powerRZ_le. apply IT.TM.TMI.ZOdd_pow_le. now apply Zodd_equiv. rewrite <- ln_1. apply ln_le. apply Hx. apply Rle_trans with (1 := proj2 Hx). apply F'.le'_correct in Hvu. rewrite F.fromZ_correct in Hvu by easy. rewrite I.upper_correct in Hvu by now exists v. destruct (I.convert vi) as [|vr [|vu]] ; try easy. now apply Rle_trans with (1 := proj2 Hv). + now apply f0eps_lim_correct with (1 := Halpha). + apply BI.f0eps_correct ; try easy. now apply Zgt_not_eq. Qed. Theorem eval_RInt_gen_zero_bertrand : forall prec deg limit vars hyps alpha beta pg pf pv cg cf cv g, (-1 < alpha)%Z -> no_floor_prog pf = true -> eval_RInt_gen_zero prec deg limit hyps (bertrand_zero_interval alpha beta) pg pf (bertrand_prog alpha beta pf) pv cg cf cf cv g = true -> eval_hyps hyps vars ( eval_goal g (Prog.eval_real' pg ( (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * (powerRZ t alpha * pow (ln t) beta)) (at_right 0) (at_point (Prog.eval_real' pv vars cv))) :: vars) cg)). Proof. intros prec deg limit vars hyps alpha beta pg pf pv cg cf cv g Halpha Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply (R.eval_goal_bnd_correct prec) with (2 := H). unfold eval_real'. simpl. fold (compute_inputs prec hyps cg). apply A.BndValuator.eval_correct_ext'. now apply app_merge_hyps_eval_bnd. now apply contains_RInt_gen_zero_bertrand. Qed. Theorem eval_RInt_gen_zero_contains_bertrand : forall prec deg limit vars hyps alpha beta pf pv cf cv b, (-1 < alpha)%Z -> no_floor_prog pf = true -> eval_RInt_gen_zero_contains prec deg limit hyps (bertrand_zero_interval alpha beta) pf (bertrand_prog alpha beta pf) pv cf cf cv b = true -> eval_hyps hyps vars (contains (I.convert b) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * (powerRZ t alpha * pow (ln t) beta)) (at_right 0) (at_point (Prog.eval_real' pv vars cv))))). Proof. intros prec deg limit vars hyps alpha beta pf pv cf cv b Halpha Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply I.subset_correct with (2 := H). now apply contains_RInt_gen_zero_bertrand. Qed. Lemma contains_RInt_gen_zero_bertrand_pow0 : forall prec deg limit check vars hyps beta pf pv cf cv, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> no_floor_prog pf = true -> let hyps := R.merge_hyps prec hyps in let (mid, Fi) := eval_RInt_gen_zero_init prec deg hyps (bertrand_zero_interval 0 beta) pf (bertrand_prog 0 beta pf) pv cf cf cv in contains (I.convert (IR.bisect prec limit mid Fi check)) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * pow (ln t) beta) (at_right 0) (at_point (Prog.eval_real' pv vars cv)))). Proof. intros prec deg limit check vars hyps beta pf pv cf cv H' Hp. generalize (contains_RInt_gen_zero_bertrand prec deg limit check vars hyps 0 beta pf pv cf cv H' eq_refl Hp). cbv zeta. intro H. rewrite RInt_gen_ext_eq with (g := (fun t : R => eval_real' pf (t :: vars) cf * (powerRZ t 0 * ln t ^ beta))). exact H. intros x. now rewrite powerRZ_O, Rmult_1_l. Qed. Theorem eval_RInt_gen_zero_bertrand_pow0 : forall prec deg limit vars hyps beta pg pf pv cg cf cv g, no_floor_prog pf = true -> eval_RInt_gen_zero prec deg limit hyps (bertrand_zero_interval 0 beta) pg pf (bertrand_prog 0 beta pf) pv cg cf cf cv g = true -> eval_hyps hyps vars ( eval_goal g (Prog.eval_real' pg ( (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * pow (ln t) beta) (at_right 0) (at_point (Prog.eval_real' pv vars cv))) :: vars) cg)). Proof. intros prec deg limit vars hyps beta pg pf pv cg cf cv g Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply (R.eval_goal_bnd_correct prec) with (2 := H). unfold eval_real'. simpl. fold (compute_inputs prec hyps cg). apply A.BndValuator.eval_correct_ext'. now apply app_merge_hyps_eval_bnd. now apply contains_RInt_gen_zero_bertrand_pow0. Qed. Theorem eval_RInt_gen_zero_contains_bertrand_pow0 : forall prec deg limit vars hyps beta pf pv cf cv b, no_floor_prog pf = true -> eval_RInt_gen_zero_contains prec deg limit hyps (bertrand_zero_interval 0 beta) pf (bertrand_prog 0 beta pf) pv cf cf cv b = true -> eval_hyps hyps vars (contains (I.convert b) (Xreal (RInt_gen (fun t => Prog.eval_real' pf (t :: vars) cf * pow (ln t) beta) (at_right 0) (at_point (Prog.eval_real' pv vars cv))))). Proof. intros prec deg limit vars hyps beta pf pv cf cv b Hp H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply I.subset_correct with (2 := H). now apply contains_RInt_gen_zero_bertrand_pow0. Qed. Ltac do_integral prec degree fuel native nocheck := massage_goal ; match goal with | |- eval_goal ?g' ?y => let g := fresh "__goal" in set (g := g') ; lazymatch y with | context [RInt ?f ?u ?v] => reify_RInt y f u v ; apply (eval_RInt_correct prec degree fuel) with (1 := eq_refl true) | context [RInt_gen ?fm (at_point ?u) (Rbar_locally p_infty)] => reify_RInt_gen_infty y fm u ; lazymatch fm with | fun t => (_ / (t * ln t ^ _))%R => apply (eval_RInt_gen_infty_invxln prec degree fuel) with (1 := eq_refl true) | fun t => (_ * / (t * ln t ^ _))%R => apply (eval_RInt_gen_infty_invxln prec degree fuel) with (1 := eq_refl true) | fun t => (_ * (powerRZ t _ * ln t ^ _))%R => apply (eval_RInt_gen_infty_bertrand prec degree fuel) with (1 := eq_refl Lt) (2 := eq_refl true) | _ => fail "No integral recognized" end | context [RInt_gen ?fm (at_right 0) (at_point ?v)] => reify_RInt_gen_zero y fm v ; lazymatch fm with | fun t => (_ * (powerRZ t _ * ln t ^ _))%R => apply (eval_RInt_gen_zero_bertrand prec degree fuel) with (1 := eq_refl Lt) (2 := eq_refl true) | fun t => (_ * ln t ^ _)%R => apply (eval_RInt_gen_zero_bertrand_pow0 prec degree fuel) with (1 := eq_refl true) | _ => fail "No integral recognized" end | _ => fail "No integral recognized" end end ; do_reduction nocheck native. Ltac do_integral_intro y extend prec degree fuel width native nocheck output := let extend := constr:(extent extend) in let width := match width with | (?p, ?b) => constr:((F.scale (F.fromZ 1) (F.ZtoS p), b)) end in let i := fresh "__i" in evar (i : I.type) ; cut (contains (I.convert i) (Xreal y))%R ; cycle 1 ; [ lazymatch y with | RInt ?f ?u ?v => reify_RInt y f u v ; apply (eval_RInt_contains_correct prec degree fuel) with (1 := eq_refl true) ; match goal with | |- _ ?hyps ?pf ?pu ?pv ?cf ?cu ?cv _ = true => let yi := constr:(eval_RInt_plain prec degree fuel hyps pf pu pv cf cu cv width) in do_instantiate i extend native yi end | RInt_gen ?fm (at_point ?u) (Rbar_locally p_infty) => reify_RInt_gen_infty y fm u ; lazymatch fm with | fun t => (_ / (t * ln t ^ _))%R => apply (eval_RInt_gen_infty_contains_invxln prec degree fuel) with (1 := eq_refl true) | fun t => (_ * / (t * ln t ^ _))%R => apply (eval_RInt_gen_infty_contains_invxln prec degree fuel) with (1 := eq_refl true) | fun t => (_ * (powerRZ t _ * ln t ^ _))%R => apply (eval_RInt_gen_infty_contains_bertrand prec degree fuel) with (1 := eq_refl Lt) (2 := eq_refl true) | _ => fail "No integral recognized" end ; match goal with | |- _ ?hyps ?mi ?pf ?pfm ?pu ?cf ?cfm ?cu _ = true => let yi := constr:(eval_RInt_gen_infty_plain prec degree fuel hyps mi pf pfm pu cf cfm cu width) in do_instantiate i extend native yi end | RInt_gen ?fm (at_right 0) (at_point ?v) => reify_RInt_gen_zero y fm v ; lazymatch fm with | fun t => (_ * (powerRZ t _ * ln t ^ _))%R => apply (eval_RInt_gen_zero_contains_bertrand prec degree fuel) with (1 := eq_refl Lt) (2 := eq_refl true) | fun t => (_ * ln t ^ _)%R => apply (eval_RInt_gen_zero_contains_bertrand_pow0 prec degree fuel) with (1 := eq_refl true) | _ => fail "No integral recognized" end ; match goal with | |- _ ?hyps ?mi ?pf ?pfm ?pv ?cf ?cfm ?cv _ = true => let yi := constr:(eval_RInt_gen_zero_plain prec degree fuel hyps mi pf pfm pv cf cfm cv width) in do_instantiate i extend native yi end | _ => fail "No integral recognized" end ; do_reduction nocheck native | unfold i ; clear i ; do_interval_generalize (I.output_correct output) ]. End IntegralTacticAux. interval-4.11.1/src/Tactics/Interval_helper.v000066400000000000000000000416471470547631300211430ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2021, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List ZArith Psatz. From Flocq Require Import Zaux. Require Import Stdlib. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Require Import Eval. Require Import Tree. Require Import Prog. Require Import Reify. Inductive interval_tac_method : Set := | itm_naive | itm_autodiff | itm_taylor. Inductive interval_extent : Set := | ie_none | ie_lower | ie_upper. Ltac tuple_to_list params l := match params with | pair ?a ?b => tuple_to_list a (b :: l) | pair _ ?b => fail 100 "Unknown tactic parameter" b | ?b => constr:(b :: l) | ?b => fail 100 "Unknown tactic parameter" b end. Ltac do_interval_generalize output := let H := fresh "H" in intro H ; apply output in H ; revert H ; match goal with | |- contains_output ?b ?t -> ?G => let b' := eval vm_compute in b in replace b with b' by (vm_cast_no_check (eq_refl b')) ; let o := eval cbv -[IZR Rdiv Rle Q2R] in (contains_output b') in let o := eval cbv beta in (o t) in lazymatch o with | True => fail "Nothing known about" t | _ => change (o -> G) end end. Ltac do_reduction nocheck native := clear ; lazymatch nocheck with | true => match native with | true => native_cast_no_check (eq_refl true) | false => vm_cast_no_check (eq_refl true) end | false => (abstract match native with | true => native_cast_no_check (eq_refl true) | false => vm_cast_no_check (eq_refl true) end) || fail "Numerical evaluation failed to conclude. You may want to adjust some parameters" end. Ltac merge_vars fvar bvars := let rec aux acc l := match l with | ?v :: ?l' => let acc := list_add v acc in aux acc l' | nil => acc end in lazymatch fvar with | Some ?x => aux (cons x nil) bvars | None => aux (@nil R) bvars end. Ltac get_var_indices vars bvars := let rec aux1 v i l := lazymatch l with | v :: _ => i | _ :: ?l' => aux1 v (S i) l' end in let rec aux2 acc l := lazymatch l with | ?v :: ?l' => let i := aux1 v 0%nat vars in aux2 (cons i acc) l' | nil => acc end in aux2 (@nil nat) bvars. Ltac hide_lhs := lazymatch goal with | |- ?l = _ => let l' := fresh "l" in set (l' := l) end. Module IntervalTacticAux (I : IntervalOps). Module J := IntervalExt I. Module A := IntervalAlgos I. Module T := Tree.Bnd I. Module R := Reify.Bnd I. Definition compute_inputs prec hyps consts := R.merge_hyps prec hyps ++ map (T.eval_bnd prec) consts. Theorem app_merge_hyps_eval_bnd : forall prec vars hyps consts, R.eval_hyps_bnd (R.merge_hyps prec hyps) vars -> A.contains_all (compute_inputs prec hyps consts) (vars ++ map (fun c => eval c nil) consts). Proof. intros prec vars hyps consts He. unfold compute_inputs. revert vars He. induction (R.merge_hyps prec hyps) as [|h t IH]. intros [|vars]. 2: easy. intros _. simpl. split. now rewrite 2!map_length. intros n. rewrite (nth_map (Evar 0)). destruct le_lt_dec as [H|H]. now rewrite I.nai_correct. rewrite (nth_map_lt (Evar 0)) by easy. apply T.eval_bnd_correct. intros [|v vars]. easy. simpl. intros [H1 H2]. apply A.contains_all_cons with (2 := H1). now apply IH. Qed. Theorem eval_bisect_aux : forall prec depth idx vars hyps prog consts g fi, ( forall xi x, A.contains_all xi x -> contains (I.convert (fi xi)) (Xreal (nth 0 (eval_real prog x) 0%R)) ) -> A.bisect (compute_inputs prec hyps consts) idx (fun xi => R.eval_goal_bnd prec g (fi xi)) depth = true -> eval_hyps hyps vars (eval_goal g (eval_real' prog vars consts)). Proof. intros prec depth idx vars hyps prog consts g fi Hfi H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply A.bisect_correct with (P := fun x => eval_goal g (nth 0 (eval_real prog x) 0%R)) (2 := H). - intros x xi Ix. apply (R.eval_goal_bnd_correct prec). now apply Hfi. - now apply app_merge_hyps_eval_bnd. Qed. Theorem eval_bisect_contains_aux : forall prec depth idx vars hyps prog consts b fi, ( forall xi x, A.contains_all xi x -> contains (I.convert (fi xi)) (Xreal (nth 0 (eval_real prog x) 0%R)) ) -> A.bisect (compute_inputs prec hyps consts) idx (fun xi => I.subset (fi xi) b) depth = true -> eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec depth idx vars hyps prog consts b fi Hfi H. apply (R.eval_hyps_bnd_correct prec). intros H'. apply A.bisect_correct with (P := fun x => contains (I.convert b) (Xreal (nth 0 (eval_real prog x) 0%R))) (2 := H). - intros x xi Ix H''. apply I.subset_correct with (2 := H''). now apply Hfi. - now apply app_merge_hyps_eval_bnd. Qed. Theorem eval_lookup_contains_aux : forall prec depth extend idx vars hyps prog consts fi, ( forall xi x, A.contains_all xi x -> contains (I.convert (fi xi)) (Xreal (nth 0 (eval_real prog x) 0%R)) ) -> let b := A.lookup fi (compute_inputs prec hyps consts) idx extend depth in eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec depth extend idx vars hyps prog consts fi Hfi. apply (R.eval_hyps_bnd_correct prec). intros H'. apply A.lookup_correct with (1 := Hfi). now apply app_merge_hyps_eval_bnd. Qed. Definition eval_bisect_fun prec prog xi := nth 0 (A.BndValuator.eval prec prog xi) I.nai. Definition eval_bisect prec depth idx hyps prog consts g := let bounds := compute_inputs prec hyps consts in let check := R.eval_goal_bnd prec g in A.bisect bounds idx (fun xi => check (eval_bisect_fun prec prog xi)) depth. Theorem eval_bisect_correct : forall prec depth idx vars hyps prog consts g, eval_bisect prec depth idx hyps prog consts g = true -> eval_hyps hyps vars (eval_goal g (eval_real' prog vars consts)). Proof. intros prec depth idx vars hyps prog consts g H. apply eval_bisect_aux with (2 := H). intros xi x Ix. now apply A.BndValuator.eval_correct'. Qed. Definition eval_bisect_contains prec depth idx hyps prog consts b := let bounds := compute_inputs prec hyps consts in A.bisect bounds idx (fun xi => I.subset (eval_bisect_fun prec prog xi) b) depth. Theorem eval_bisect_contains_correct : forall prec depth idx vars hyps prog consts b, eval_bisect_contains prec depth idx hyps prog consts b = true -> eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec depth idx vars hyps prog consts b H. apply eval_bisect_contains_aux with (2 := H). intros xi x Ix. now apply A.BndValuator.eval_correct'. Qed. Definition eval_bisect_plain prec depth extend idx hyps prog consts := let bounds := compute_inputs prec hyps consts in A.lookup (eval_bisect_fun prec prog) bounds idx extend depth. Theorem eval_bisect_plain_correct : forall prec depth extend idx vars hyps prog consts, let b := eval_bisect_plain prec depth extend idx hyps prog consts in eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec depth extend idx vars hyps prog consts. apply eval_lookup_contains_aux. intros xi x Ix. now apply A.BndValuator.eval_correct'. Qed. Definition eval_bisect_diff_fun prec prog xi := match xi with | nil => I.nai | xi :: li => A.DiffValuator.eval prec prog li 0 xi end. Definition eval_bisect_diff prec depth idx hyps prog consts g := let bounds := compute_inputs prec hyps consts in let check := R.eval_goal_bnd prec g in A.bisect bounds idx (fun xi => check (eval_bisect_diff_fun prec prog xi)) depth. Theorem eval_bisect_diff_correct : forall prec depth idx vars hyps prog consts g, eval_bisect_diff prec depth idx hyps prog consts g = true -> eval_hyps hyps vars (eval_goal g (eval_real' prog vars consts)). Proof. intros prec depth idx vars hyps prog consts g H. apply eval_bisect_aux with (2 := H). intros xi x Ix. destruct xi as [|xi li]. apply J.nai_correct. destruct Ix as [H1 H2]. destruct x as [|x l]. easy. apply A.DiffValuator.eval_correct. split. now injection H1. intros n. apply (H2 (S n)). apply (H2 O). Qed. Definition eval_bisect_contains_diff prec depth idx hyps prog consts b := let bounds := compute_inputs prec hyps consts in A.bisect bounds idx (fun xi => I.subset (eval_bisect_diff_fun prec prog xi) b) depth. Theorem eval_bisect_contains_diff_correct : forall prec depth idx vars hyps prog consts b, eval_bisect_contains_diff prec depth idx hyps prog consts b = true -> eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec depth idx vars hyps prog consts b H. apply eval_bisect_contains_aux with (2 := H). intros xi x Ix. destruct xi as [|xi li]. apply J.nai_correct. destruct Ix as [H1 H2]. destruct x as [|x l]. easy. apply A.DiffValuator.eval_correct. split. now injection H1. intros n. apply (H2 (S n)). apply (H2 O). Qed. Definition eval_bisect_diff_plain prec depth extend idx hyps prog consts := let bounds := compute_inputs prec hyps consts in A.lookup (eval_bisect_diff_fun prec prog) bounds idx extend depth. Theorem eval_bisect_diff_plain_correct : forall prec depth extend idx vars hyps prog consts, let b := eval_bisect_diff_plain prec depth extend idx hyps prog consts in eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec depth extend idx vars hyps prog consts. apply eval_lookup_contains_aux. intros xi x Ix. destruct xi as [|xi li]. apply J.nai_correct. destruct Ix as [H1 H2]. destruct x as [|x l]. easy. apply A.DiffValuator.eval_correct. split. now injection H1. intros n. apply (H2 (S n)). apply (H2 O). Qed. Definition eval_bisect_taylor_fun prec deg prog xi := match xi with | nil => I.nai | xi :: li => let li := A.TaylorValuator.TM.var :: map A.TaylorValuator.TM.const li in A.TaylorValuator.TM.eval (prec, deg) (nth 0 (A.TaylorValuator.eval prec deg xi prog li) A.TaylorValuator.TM.dummy) xi xi end. Definition eval_bisect_taylor prec deg depth idx hyps prog consts g := let bounds := compute_inputs prec hyps consts in let check := R.eval_goal_bnd prec g in A.bisect bounds idx (fun xi => check (eval_bisect_taylor_fun prec deg prog xi)) depth. Theorem eval_bisect_taylor_correct : forall prec deg depth idx vars hyps prog consts g, eval_bisect_taylor prec deg depth idx hyps prog consts g = true -> eval_hyps hyps vars (eval_goal g (eval_real' prog vars consts)). Proof. intros prec deg depth idx vars hyps prog consts g H. apply eval_bisect_aux with (2 := H). intros xi x Ix. destruct xi as [|xi li]. apply J.nai_correct. destruct Ix as [H1 H2]. destruct x as [|x l]. easy. apply A.TaylorValuator.eval_correct. split. now injection H1. intros n. apply (H2 (S n)). apply (H2 O). Qed. Definition eval_bisect_contains_taylor prec deg depth idx hyps prog consts b := let bounds := compute_inputs prec hyps consts in A.bisect bounds idx (fun xi => I.subset (eval_bisect_taylor_fun prec deg prog xi) b) depth. Theorem eval_bisect_contains_taylor_correct : forall prec deg depth idx vars hyps prog consts b, eval_bisect_contains_taylor prec deg depth idx hyps prog consts b = true -> eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec deg depth idx vars hyps prog consts b H. apply eval_bisect_contains_aux with (2 := H). intros xi x Ix. destruct xi as [|xi li]. apply J.nai_correct. destruct Ix as [H1 H2]. destruct x as [|x l]. easy. apply A.TaylorValuator.eval_correct. split. now injection H1. intros n. apply (H2 (S n)). apply (H2 O). Qed. Definition eval_bisect_taylor_plain prec deg depth extend idx hyps prog consts := let bounds := compute_inputs prec hyps consts in A.lookup (eval_bisect_taylor_fun prec deg prog) bounds idx extend depth. Theorem eval_bisect_taylor_plain_correct : forall prec deg depth extend idx vars hyps prog consts, let b := eval_bisect_taylor_plain prec deg depth extend idx hyps prog consts in eval_hyps hyps vars (contains (I.convert b) (Xreal (eval_real' prog vars consts))). Proof. intros prec deg depth extend idx vars hyps prog consts. apply eval_lookup_contains_aux. intros xi x Ix. destruct xi as [|xi li]. apply J.nai_correct. destruct Ix as [H1 H2]. destruct x as [|x l]. easy. apply A.TaylorValuator.eval_correct. split. now injection H1. intros n. apply (H2 (S n)). apply (H2 O). Qed. Definition extent e := match e with | ie_none => fun v => v | ie_lower => I.lower_extent | ie_upper => I.upper_extent end. Ltac do_interval fvar bvars prec degree depth native nocheck eval_tac := let vars := merge_vars fvar bvars in let idx := get_var_indices vars bvars in massage_goal ; reify_full vars ; lazymatch eval_tac with | itm_naive => apply (eval_bisect_correct prec depth idx) | itm_autodiff => apply (eval_bisect_diff_correct prec depth idx) | itm_taylor => apply (eval_bisect_taylor_correct prec degree depth idx) end ; do_reduction nocheck native. Ltac do_instantiate i extend native yi := let yi := lazymatch native with | true => eval native_compute in (extend yi) | false => eval vm_compute in (extend yi) end in instantiate (i := yi). Ltac do_interval_intro y extend fvar bvars prec degree depth native nocheck eval_tac output := let extend := constr:(extent extend) in let vars := merge_vars fvar bvars in let idx := get_var_indices vars bvars in let i := fresh "__i" in evar (i : I.type) ; cut (contains (I.convert i) (Xreal y)) ; cycle 1 ; [ let vars := get_vars y vars in reify_partial y vars ; apply (eq_ind _ (fun z => contains (I.convert i) (Xreal z))) ; find_hyps vars ; lazymatch goal with | |- eval_hyps ?hyps ?vars (contains _ (Xreal (eval_real' ?prog _ ?consts))) => lazymatch eval_tac with | itm_naive => apply (eval_bisect_contains_correct prec depth idx vars hyps prog consts) ; do_instantiate i extend native (eval_bisect_plain prec depth extend idx hyps prog consts) | itm_autodiff => apply (eval_bisect_contains_diff_correct prec depth idx vars hyps prog consts) ; do_instantiate i extend native (eval_bisect_diff_plain prec depth extend idx hyps prog consts) | itm_taylor => apply (eval_bisect_contains_taylor_correct prec degree depth idx vars hyps prog consts) ; do_instantiate i extend native (eval_bisect_taylor_plain prec degree depth extend idx hyps prog consts) end end ; do_reduction nocheck native | unfold i ; clear i ; do_interval_generalize (I.output_correct output) ]. Module SimpleTactic. Inductive interval_tac_parameters : Set := | i_prec (p : positive) | i_bisect (v : R) | i_autodiff (v : R) | i_taylor (v : R) | i_degree (d : nat) | i_depth (d : nat). Ltac do_interval_parse params depth := let rec aux fvar bvars prec degree depth itm params := lazymatch params with | nil => constr:((fvar, bvars, prec, degree, depth, itm)) | cons (i_prec ?p) ?t => aux fvar bvars p degree depth itm t | cons (i_degree ?d) ?t => aux fvar bvars prec d depth itm t | cons (i_bisect ?x) ?t => aux fvar (cons x bvars) prec degree depth itm t | cons (i_autodiff ?x) ?t => aux (Some x) bvars prec degree depth itm_autodiff t | cons (i_taylor ?x) ?t => aux (Some x) bvars prec degree depth itm_taylor t | cons (i_depth ?d) ?t => aux fvar bvars prec degree d itm t | cons ?h _ => fail 100 "Unknown tactic parameter" h end in aux (@None R) (@nil R) 53%positive 10%nat depth itm_naive params. Ltac do_interval_ params := match do_interval_parse params 15%nat with | (?fvar, ?bvars, ?prec, ?degree, ?depth, ?itm) => let prec := eval vm_compute in (I.F.PtoP prec) in do_interval fvar bvars prec degree depth false false itm end. Ltac do_interval_intro_ t extend params := match do_interval_parse params 5%nat with | (?fvar, ?bvars, ?prec, ?degree, ?depth, ?itm) => let prec := eval vm_compute in (I.F.PtoP prec) in do_interval_intro t extend fvar bvars prec degree depth false false itm false end. Tactic Notation "interval" := do_interval_ (@nil interval_tac_parameters). Tactic Notation "interval" "with" constr(params) := do_interval_ ltac:(tuple_to_list params (@nil interval_tac_parameters)). Tactic Notation "interval_intro" constr(t) "with" constr(params) := do_interval_intro_ t ie_none ltac:(tuple_to_list params (@nil interval_tac_parameters)). End SimpleTactic. End IntervalTacticAux. interval-4.11.1/src/Tactics/Plot_helper.v000066400000000000000000000434761470547631300202770ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2021, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List. Require Import Sig. Require Import Generic_proof. Require Import Interval_helper. Require Import Xreal Interval Tree Reify Prog. Definition reify_var : R. Proof. exact 0%R. Qed. Definition plot2 (f : R -> R) (ox dx oy dy : R) (h : Z) (l : list (Z * Z)) := forall i x, (ox + dx * INR i <= x <= ox + dx * INR (S i))%R -> (oy <= f x <= oy + dy * IZR h)%R -> let r := nth i l (0%Z, h) in (oy + dy * IZR (fst r) <= f x <= oy + dy * IZR (snd r))%R. Module PlotTacticAux (F : FloatOps with Definition radix := Zaux.radix2 with Definition sensible_format := true) (I : IntervalOps with Module F := F). Module F' := FloatExt F. Module IH := IntervalTacticAux I. Import IH. Definition plot1 (f : R -> R) (ox dx : R) (l : list I.type) := forall i x, (ox + dx * INR i <= x <= ox + dx * INR (S i))%R -> contains (I.convert (nth i l I.nai)) (Xreal (f x)). Lemma plot_ext : forall f g u d l, (forall x, f x = g x) -> plot1 f u d l -> plot1 g u d l. Proof. intros f g u d l H K i x Hx. specialize (K i x Hx). now rewrite <- H. Qed. Fixpoint bound_plot_aux prec (fi : I.type -> I.type) (ui di : I.type) (xz : Z) (i : nat) (acc : I.type) : I.type := match i with | O => acc | S i => let xz := Z.succ xz in let xi := I.add prec ui (I.mul prec di (I.fromZ prec xz)) in bound_plot_aux prec fi ui di xz i (I.join (fi xi) acc) end. Definition bound_plot prec hyps pf cf oxi dxi nb := let bounds := R.merge_hyps prec hyps ++ map (T.eval_bnd prec) cf in let fi xi := nth 0 (A.BndValuator.eval prec pf (xi :: bounds)) I.nai in bound_plot_aux prec fi oxi dxi 0%Z (Z.to_nat nb) (fi oxi). Fixpoint sample_plot_aux prec (gi : I.type -> I.type -> I.type) (check : I.type -> bool) (ui di zi2 : I.type) (fi : I.type -> I.type) (i : nat) (mz xz rz : Z) (acc : list I.type) : list I.type := match i with | O => acc | S i => let xz' := Z.pred xz in let xi1 := I.add prec ui (I.mul prec di (I.fromZ prec xz')) in let xi2 := I.add prec ui (I.mul prec di (I.fromZ prec xz)) in let xi := I.join xi1 xi2 in let zi1 := fi xi1 in let yi := fi xi in let c := andb (orb (check (I.meet yi (I.lower_extent zi1))) (check (I.meet yi (I.upper_extent zi1)))) (orb (check (I.meet yi (I.lower_extent zi2))) (check (I.meet yi (I.upper_extent zi2)))) in let yizi := if c then (yi, zi1) else let fi := gi xi in (fi xi, fi xi1) in let mz' := if Z.eqb mz xz' then (mz - Z.div2 (3 * rz))%Z else if c then mz else (xz' - 1 - Z.div2 rz)%Z in let mz' := if Z.ltb mz' 0%Z then 0%Z else mz' in let firz := if Z.eqb mz mz' then (fi, rz) else let xi0 := I.add prec ui (I.mul prec di (I.fromZ prec mz')) in (gi (I.join xi0 xi1), (xz' - mz'))%Z in let acc := fst yizi :: acc in sample_plot_aux prec gi check ui di (snd yizi) (fst firz) i mz' xz' (snd firz) acc end. Definition sample_plot prec deg check hyps pf cf oxi dxi nb := let hyps := R.merge_hyps prec hyps in let gi := let bounds := hyps ++ map (T.eval_bnd prec) cf in let fi xi := nth 0 (A.BndValuator.eval prec pf (xi :: bounds)) I.nai in let bounds := A.TaylorValuator.TM.var :: map A.TaylorValuator.TM.const bounds in fun yi => let zi := fi yi in let fi := nth 0 (A.TaylorValuator.eval prec deg yi pf bounds) A.TaylorValuator.TM.dummy in fun xi => let zi' := A.TaylorValuator.TM.eval (prec, deg) fi yi xi in if I.subset xi yi then I.meet zi zi' else zi' in let ui := I.add prec oxi (I.mul prec dxi (I.fromZ prec 0)) in let vi := I.add prec oxi (I.mul prec dxi (I.fromZ prec nb)) in sample_plot_aux prec gi check oxi dxi I.whole (gi (I.join ui vi)) (Z.to_nat nb) 0%Z nb nb nil. Lemma sample_plot_correct : forall prec deg check vars hyps pf cf oxi dxi ox dx nb l, contains (I.convert oxi) (Xreal ox) -> contains (I.convert dxi) (Xreal dx) -> sample_plot prec deg check hyps pf cf oxi dxi (Zpos nb) = l -> eval_hyps hyps vars ( plot1 (fun t => eval_real' pf (t :: vars) cf) ox dx l). Proof. intros prec deg check vars hyps pf cf oxi dxi ox dx nb l Box Bdx <-. apply (R.eval_hyps_bnd_correct prec). intros H'. unfold sample_plot, eval_real'. set (bounds' := R.merge_hyps prec hyps ++ _). set (bounds := A.TaylorValuator.TM.var :: _). set (ui := I.add prec oxi (I.mul prec dxi (I.fromZ prec 0))). set (vi := I.add prec oxi (I.mul prec dxi (I.fromZ prec (Zpos nb)))). set (gi := fun yi => let zi := nth 0 (A.BndValuator.eval prec pf (yi :: bounds')) I.nai in let fi := nth 0 (A.TaylorValuator.eval prec deg yi pf bounds) A.TaylorValuator.TM.dummy in fun xi => let zi' := A.TaylorValuator.TM.eval (prec, deg) fi yi xi in if I.subset xi yi then I.meet zi zi' else zi'). set (f x := nth 0 (eval_real pf ((x :: vars) ++ map (fun c : expr => eval c nil) cf)) 0%R). fold (gi (I.join ui vi)). assert (Hg: forall ti xi x, contains (I.convert xi) (Xreal x) -> contains (I.convert (gi ti xi)) (Xreal (f x))). { intros ti xi x Hx. unfold gi. destruct I.subset eqn:Hs. apply I.meet_correct. apply A.BndValuator.eval_correct_ext'. now apply app_merge_hyps_eval_bnd. now apply I.subset_correct with (2 := Hs). apply A.TaylorValuator.eval_correct with (2 := Hx). now apply app_merge_hyps_eval_bnd. apply A.TaylorValuator.eval_correct with (2 := Hx). now apply app_merge_hyps_eval_bnd. } rewrite <- (Z2Nat.id (Zpos nb)) at 2 by easy. set (i := Z.to_nat (Zpos nb)). cut (plot1 f (ox + dx * INR i) dx nil). 2: intros [|j] x _ ; apply J.nai_correct. generalize (@nil I.type). generalize I.whole (I.join ui vi) 0%Z (Z.pos nb). clearbody f gi i. clear -Box Bdx Hg. induction i as [|n IH]. { simpl. intros _ _ _ _ l. now rewrite Rmult_0_r, Rplus_0_r. } intros zi2 gxi mz rz acc Hacc. cbn beta iota zeta delta [sample_plot_aux]. rewrite <- Nat2Z.inj_pred by apply Nat.lt_0_succ. simpl (Nat.pred (S n)). set (xi1 := I.add prec oxi (I.mul prec dxi (I.fromZ prec (Z.of_nat n)))). set (xi2 := I.add prec oxi (I.mul prec dxi (I.fromZ prec (Z.of_nat (S n))))). set (xi := I.join xi1 xi2). set (zi1 := gi gxi xi1). set (yi := gi gxi xi). set (c := andb (orb (check (I.meet yi (I.lower_extent zi1))) (check (I.meet yi (I.upper_extent zi1)))) (orb (check (I.meet yi (I.lower_extent zi2))) (check (I.meet yi (I.upper_extent zi2))))). clearbody c. set (yizi := if c then (yi, zi1) else (gi xi xi, gi xi xi1)). set (mz' := if Z.eqb mz (Z.of_nat n) then (mz - Z.div2 (3 * rz))%Z else if c then mz else (Z.of_nat n - 1 - Z.div2 rz)%Z). set (mz'' := if Z.ltb mz' 0%Z then 0%Z else mz'). clearbody mz' mz''. set (gxi' := I.join (I.add prec oxi (I.mul prec dxi (I.fromZ prec mz''))) xi1). clearbody gxi'. cut (plot1 f (ox + dx * INR n) dx (fst yizi :: acc)). { destruct Z.eqb ; apply IH. } clear -Box Bdx Hg Hacc. intros [|i] x Hx. 2: { apply Hacc. revert Hx. clear. rewrite !S_INR. replace (ox + dx * INR n + dx * (INR i + 1))%R with (ox + dx * (INR n + 1) + dx * INR i)%R by ring. replace (ox + dx * INR n + dx * (INR i + 1 + 1))%R with (ox + dx * (INR n + 1) + dx * (INR i + 1))%R by ring. easy. } assert (Hxi: contains (I.convert xi) (Xreal x)). { apply J.join_correct with (u := (ox + dx * (IZR (Z.of_nat n)))%R) (v := (ox + dx * (IZR (Z.of_nat (S n))))%R). apply J.add_correct with (1 := Box). apply J.mul_correct with (1 := Bdx). apply I.fromZ_correct. apply J.add_correct with (1 := Box). apply J.mul_correct with (1 := Bdx). apply I.fromZ_correct. rewrite Nat2Z.inj_succ, succ_IZR, <- INR_IZR_INZ. revert Hx. clear. now rewrite Rmult_0_r, Rplus_0_r, Rmult_plus_distr_l, Rplus_assoc. } now destruct c ; simpl ; apply Hg. Qed. Definition clamp_lower (v : Basic.float Basic.radix2) (h : Z) := match v with | Basic.Fzero => 0%Z | Basic.Fnan => 0%Z | Basic.Float true _ _ => 0%Z | Basic.Float false m e => let v := Z.shiftl (Zpos m) e in if Z.leb h v then h else v end. Definition clamp_upper (v : Basic.float Basic.radix2) (h : Z) := match v with | Basic.Fzero => 0%Z | Basic.Fnan => h | Basic.Float true _ _ => 0%Z | Basic.Float false m e => let v:= match e with | Z0 => Zpos m | Zpos e' => Z.shiftl (Zpos m) e | Zneg e' => Z.shiftl (Zpos m + (Z.shiftl 1 (Zpos e')) - 1) e end in if Z.leb h v then h else v end. Definition clamp (xi : I.type) (h : Z) := (clamp_lower (F.toF (I.lower xi)) h, clamp_upper (F.toF (I.upper xi)) h). Theorem clamp_correct : forall xi h x, contains (I.convert xi) (Xreal x) -> (0 <= x <= IZR h)%R -> let yi := clamp xi h in (IZR (fst yi) <= x <= IZR (snd yi))%R. Proof. intros xi h x Bx Hx. unfold clamp. assert (Nx := not_empty_contains _ _ Bx). split ; simpl. - assert (Vl := I.lower_correct _ Nx). change I.F.convert with F.convert in Vl. unfold F.convert in Vl. destruct F.toF as [| |[|] mx ex] ; try easy. destruct (I.convert xi) as [|[|xl] xu] ; try easy. apply Rle_trans with (2 := proj1 Bx). clear -Vl. injection Vl as <-. unfold clamp_lower. apply Rle_trans with (IZR (Z.shiftl (Zpos mx) ex)). { destruct (Z.leb_spec h (Z.shiftl (Zpos mx) ex)) as [H|H]. now apply IZR_le. apply Rle_refl. } unfold Basic.FtoR. destruct ex as [|ex|ex]. + apply Rle_refl. + rewrite Z.shiftl_mul_pow2 by easy. apply Rle_refl. + rewrite Z.shiftl_div_pow2 by easy. rewrite <- Raux.Zfloor_div. apply Raux.Zfloor_lb. apply Zaux.Zgt_not_eq. now apply Z.pow_pos_nonneg. - assert (Vu := I.upper_correct _ Nx). clear Nx. change I.F.convert with F.convert in Vu. unfold F.convert in Vu. destruct (I.convert xi) as [|xl [|xu]] ; try easy. now destruct F.toF. now destruct F.toF. destruct F.toF as [| |[|] mx ex] ; try easy. { apply Rle_trans with (1 := proj2 Bx). injection Vu as <-. apply Rle_refl. } { apply Rle_trans with (1 := proj2 Bx). injection Vu as <-. apply Rlt_le, Generic_proof.FtoR_Rneg. } unfold clamp_upper. destruct Z.leb. { easy. } apply Rle_trans with (1 := proj2 Bx). clear -Vu. injection Vu as <-. destruct ex as [|ex|ex]. + apply Rle_refl. + rewrite Z.shiftl_mul_pow2 by easy. apply Rle_refl. + rewrite Z.shiftl_div_pow2 by easy. rewrite Z.shiftl_mul_pow2 by easy. simpl Z.opp. simpl Basic.FtoR. fold (2 ^ Zpos ex)%Z. apply Generic_proof.Rdiv_ge_mult_pos. apply IZR_lt. now apply Z.pow_pos_nonneg. rewrite <- mult_IZR. apply IZR_le. apply Z.lt_pred_le. replace (Zpos mx + 1 * 2 ^ Zpos ex - 1)%Z with (Zpos mx - 1 + 1 * 2 ^ Zpos ex)%Z by ring. rewrite Zdiv.Z_div_plus_full. apply Z.mul_succ_div_gt. now apply Z.pow_pos_nonneg. apply Zaux.Zgt_not_eq. now apply Z.pow_pos_nonneg. Qed. Fixpoint clamp_plot prec (vi ei : I.type) (h : Z) (l : list I.type) : list (Z * Z) := match l with | nil => nil | cons yi l => let r := clamp (I.mul prec (I.sub prec yi vi) ei) h in cons r (clamp_plot prec vi ei h l) end. Lemma affine_transf : forall oy dy y1 y2 y : R, (0 < dy)%R -> (oy + dy * y1 <= y <= oy + dy * y2)%R <-> (y1 <= (y - oy) / dy <= y2)%R. Proof. intros oy dy y1 y2 y Hdy. replace y with (oy + dy * ((y - oy) / dy))%R at 1 2. 2: now field ; apply Rgt_not_eq. split ; intros [H1 H2] ; split. - apply Rmult_le_reg_l with (1 := Hdy). apply Rplus_le_reg_l with (1 := H1). - apply Rmult_le_reg_l with (1 := Hdy). apply Rplus_le_reg_l with (1 := H2). - apply Rplus_le_compat_l. apply Rmult_le_compat_l with (2 := H1). now apply Rlt_le. - apply Rplus_le_compat_l. apply Rmult_le_compat_l with (2 := H2). now apply Rlt_le. Qed. Lemma clamp_plot_correct : forall prec oyi dyi f ox dx oy dy h l1 l2, (0 < dy)%R -> contains (I.convert oyi) (Xreal oy) -> contains (I.convert dyi) (Xreal (/dy)) -> clamp_plot prec oyi dyi h l1 = l2 -> plot1 f ox dx l1 -> plot2 f ox dx oy dy h l2. Proof. intros prec oyi dyi f ox dx oy dy h l l2 Hdy Boy Bdy <-. intros H i x Hx Hy. specialize (H i x Hx). revert i ox H Hx. induction l as [|yi l IH] ; intros [|i] ox Hl Hx. - now simpl ; rewrite Rmult_0_r, Rplus_0_r. - now simpl ; rewrite Rmult_0_r, Rplus_0_r. - assert (By: contains (I.convert (I.mul prec (I.sub prec yi oyi) dyi)) (Xreal ((f x - oy) / dy))). { apply J.mul_correct with (2 := Bdy). apply J.sub_correct with (2 := Boy). now apply Hl. } simpl nth. generalize (clamp_correct (I.mul prec (I.sub prec yi oyi) dyi) h ((f x - oy) / dy)%R By). destruct clamp as [y1 y2]. clear -Hdy Hy. intros H. apply affine_transf with (1 := Hdy). apply H. apply affine_transf with (1 := Hdy). now rewrite Rmult_0_r, Rplus_0_r. - apply (IH i (ox + dx * INR 1)%R Hl). now rewrite 2!Rplus_assoc, <- 2!Rmult_plus_distr_l, 2!(Rplus_comm 1), <- 2!S_INR. Qed. Definition get_bounds (prec : F.precision) (l : list I.type): F.type * F.type := let yi := match l with | cons hi l => List.fold_left I.join l hi | nil => I.empty end in (* yl and yu might be subnormal (zero), which makes Gnuplot choke, so requantify them *) let yl := I.lower yi in let yu := I.upper yi in let yw := F.sub_UP prec yu yl in (F.sub_DN prec yu yw, F.add_UP prec yl yw). Ltac unify_eq native := match goal with | |- ?f ?p1 = ?p2 => match native with | true => let p1 := eval hnf in p1 in let p := eval native_compute in (f p1) in instantiate (p2 := p) ; native_cast_no_check (eq_refl p2) | false => let p1 := eval hnf in p1 in let p := eval vm_compute in (f p1) in instantiate (p2 := p) ; vm_cast_no_check (eq_refl p2) end end. Ltac plot1_aux1 prec x1 x2 w h d native tac_b := let x1 := reify x1 constr:(@nil R) in let x2 := reify x2 constr:(@nil R) in let ox := eval vm_compute in (I.lower (T.eval_bnd prec x1)) in let dx := eval vm_compute in (F.div_UP prec (F.sub_UP prec (I.upper (T.eval_bnd prec x2)) ox) (F.fromZ_DN prec (Zpos w))) in let oxr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert ox)) in let dxr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert dx)) in match goal with | |- plot1 ?f ?ox' ?dx' ?p => unify ox' oxr ; unify dx' dxr ; let fapp := eval cbv beta in (f reify_var) in let vars := constr:((reify_var :: nil)%list) in let vars := get_vars fapp vars in let vars := match get_vars fapp vars with | (reify_var :: ?vars)%list => vars end in eapply plot_ext ; [ let t := fresh "t" in intros t ; hide_lhs ; let fapp := eval cbv beta in (f t) in reify_partial fapp (t :: vars) ; exact (fun H => H) |] ; find_hyps vars ; let y1y2 := tac_b prec ox dx w in let thr := eval vm_compute in (F.div_UP prec (F.sub_UP prec (snd y1y2) (fst y1y2)) (F.fromZ_DN prec (Zpos h))) in apply (sample_plot_correct prec) with (deg := d) (nb := w) (l := p) (check := fun yi => F'.le' (F.sub_UP prec (I.upper yi) (I.lower yi)) thr) (1 := I.singleton_correct ox) (2 := I.singleton_correct dx) ; unify_eq native end. Ltac plot2_aux prec x1 x2 w d native tac_t tac_b := match goal with | |- plot2 ?f ?ox ?dx ?oy' ?dy' (Zpos ?h) ?p2 => let p1 := fresh "__p1" in evar (p1 : list I.type) ; let Hp := fresh "__Hp" in assert (Hp: plot1 f ox dx p1) by plot1_aux1 prec x1 x2 w h d native tac_t ; revert Hp ; let y1y2 := tac_b prec in let oy := constr:(fst y1y2) in let dy := eval vm_compute in (F.div_UP prec (F.sub_UP prec (snd y1y2) oy) (F.fromZ_DN prec (Zpos h))) in let oyr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert oy)) in let dyr := eval cbv -[IZR Rdiv] in (proj_val (I.F.convert dy)) in unify oy' oyr ; unify dy' dyr ; refine (clamp_plot_correct prec _ _ _ _ _ oyr dyr _ _ _ _ (I.singleton_correct oy) (J.inv_correct prec _ _ (I.singleton_correct dy)) _) ; [ try apply IZR_lt ; apply Rdiv_lt_0_compat ; now apply IZR_lt | unify_eq false ] end. Definition get_threshold prec hyps pf cf ox dx w := let w' := 50%Z in let dx := I.mul prec (I.singleton dx) (I.div prec (I.fromZ prec (Zpos w)) (I.fromZ prec w')) in let yi := bound_plot prec hyps pf cf (I.singleton ox) dx w' in (I.lower yi, I.upper yi). Ltac plot_get_threshold prec ox dx w := match goal with | |- eval_hyps ?hyps _ (plot1 (fun t => eval_real' ?pf (t :: _) ?cf) _ _ _) => eval vm_compute in (get_threshold prec hyps pf cf ox dx w) end. Ltac plot_get_bounds prec := match goal with | |- plot1 _ _ _ ?p -> _ => let p := eval vm_compute in p in eval vm_compute in (get_bounds prec p) end. Ltac plot_y_get_threshold y1 y2 prec ox dx w := constr:((y1, y2)). Ltac plot_y_get_bounds y1 y2 prec := constr:((y1, y2)). Ltac do_plot f x1 x2 prec degree width height native := let p := fresh "__p2" in evar (p : list (Z * Z)) ; refine (_: plot2 f _ _ _ _ (Zpos height) p) ; plot2_aux prec x1 x2 width degree native plot_get_threshold plot_get_bounds. Ltac do_plot_y f x1 x2 y1 y2 prec degree width height native := let p := fresh "__p2" in let y1 := reify y1 constr:(@nil R) in let y2 := reify y2 constr:(@nil R) in let y1 := eval vm_compute in (I.lower (T.eval_bnd prec y1)) in let y2 := eval vm_compute in (I.upper (T.eval_bnd prec y2)) in evar (p : list (Z * Z)) ; refine (_: plot2 f _ _ _ _ (Zpos height) p) ; plot2_aux prec x1 x2 width degree native ltac:(plot_y_get_threshold y1 y2) ltac:(plot_y_get_bounds y1 y2). End PlotTacticAux. interval-4.11.1/src/Tactics/Root_helper.v000066400000000000000000000216561470547631300203000ustar00rootroot00000000000000(** This file is part of the Coq.Interval library for proving bounds of real-valued expressions in Coq: https://coqinterval.gitlabpages.inria.fr/ Copyright (C) 2007-2021, Inria This library is governed by the CeCILL-C license under French law and abiding by the rules of distribution of free software. You can use, modify and/or redistribute the library under the terms of the CeCILL-C license as circulated by CEA, CNRS and Inria at the following URL: http://www.cecill.info/ As a counterpart to the access to the source code and rights to copy, modify and redistribute granted by the license, users are provided only with a limited warranty and the library's author, the holder of the economic rights, and the successive licensors have only limited liability. See the COPYING file for more details. *) From Coq Require Import Reals List ZArith Psatz. From Flocq Require Import Zaux. Require Import Stdlib. Require Import Xreal. Require Import Basic. Require Import Sig. Require Import Interval. Require Import Eval. Require Import Tree. Require Import Prog. Require Import Reify. Require Import Interval_helper. Lemma cut_root : forall (x y : R) (G P : Prop), ((P -> G) -> x = y -> G) -> ((x = y -> P) -> G) -> G. Proof. intros x y G P K L. destruct (Req_dec x y) as [H|H]. apply K with (2 := H). intros N. now apply L. apply L. intros N. now elim H. Qed. Ltac get_root_var Zy := let y := lazymatch type of Zy with | ?y = _ => y | R => Zy | Prop => match Zy with | ?y = _ => y end | _ => fail "No variable found" end in lazymatch Tree.get_vars y (@nil R) with | ?x :: _ => x | _ => fail "No variable found" end. Module RootTacticAux (F : FloatOps with Definition radix := Zaux.radix2 with Definition sensible_format := true) (I : IntervalOps with Module F := F). Module F' := FloatExt F. Module IH := IntervalTacticAux I. Import IH. Definition check_goal prec hyps pg cg g := let bounds := hyps ++ map (T.eval_bnd prec) cg in let check := R.eval_goal_bnd prec g in fun b => check (nth 0 (A.BndValuator.eval prec pg (b :: bounds)) I.nai). Definition fast_enough prec xi xi' := if I.bounded xi then let (xi1, _) := I.bisect xi in I.wider prec xi1 xi' else I.bounded xi'. Fixpoint refine_root_aux depth prec prog bounds xi (check : I.type -> bool) := match depth with | S depth => let xi' := A.DiffValuator.root prec prog bounds xi in if check xi' then true else if fast_enough prec xi xi' then refine_root_aux depth prec prog bounds xi' check else let (xi1,xi2) := I.bisect xi' in if refine_root_aux depth prec prog bounds xi1 check then refine_root_aux depth prec prog bounds xi2 check else false | O => false end. Definition refine_root prec depth hyps px cx pf cf pg cg g := let hyps := R.merge_hyps prec hyps in let xi := nth 0 (A.BndValuator.eval prec px (hyps ++ map (T.eval_bnd prec) cx)) I.nai in let check := check_goal prec hyps pg cg g in refine_root_aux depth prec pf (hyps ++ map (T.eval_bnd prec) cf) xi check. Theorem refine_root_correct : forall prec depth vars hyps px cx pf cf pg cg g, refine_root prec depth hyps px cx pf cf pg cg g = true -> eval_hyps hyps vars (eval_real' pf (eval_real' px vars cx :: vars) cf = 0%R -> eval_goal g (eval_real' pg (eval_real' px vars cx :: vars) cg)). Proof. intros prec depth vars hyps px cx pf cf pg cg g H. apply (R.eval_hyps_bnd_correct prec). set (x := eval_real' px vars cx). intros H1 H2. unfold refine_root in H. revert H. set (xi := nth 0 _ _). assert (Hx: contains (I.convert xi) (Xreal x)). { apply A.BndValuator.eval_correct'. now apply app_merge_hyps_eval_bnd. } clearbody xi. revert xi Hx. induction depth as [|depth IH]. easy. intros xi Hx. simpl. fold (compute_inputs prec hyps cf). refine (_ (A.DiffValuator.root_correct prec pf (compute_inputs prec hyps cf) _ _ xi x Hx H2)). 2: now apply app_merge_hyps_eval_bnd. set (xi' := A.DiffValuator.root _ _ _ _). intros Hx' H. destruct check_goal eqn:Hg ; [|destruct fast_enough]. - clear H IH. apply (R.eval_goal_bnd_correct prec) with (2 := Hg). unfold eval_real'. fold (compute_inputs prec hyps cg). simpl. apply A.BndValuator.eval_correct_ext' with (2 := Hx'). now apply app_merge_hyps_eval_bnd. - now apply (IH _ Hx'). - generalize (I.bisect_correct _ _ Hx'). destruct (I.bisect xi') as [xi1 xi2]. destruct refine_root_aux eqn:Hb. now intros [K|K] ; apply (IH _ K). easy. Qed. Definition root_contains prec depth hyps px cx pf cf b := let hyps := R.merge_hyps prec hyps in let xi := nth 0 (A.BndValuator.eval prec px (hyps ++ map (T.eval_bnd prec) cx)) I.nai in refine_root_aux depth prec pf (hyps ++ map (T.eval_bnd prec) cf) xi (fun xi => I.subset xi b). Theorem root_contains_correct : forall prec depth vars hyps px cx pf cf b, root_contains prec depth hyps px cx pf cf b = true -> eval_hyps hyps vars (eval_real' pf (eval_real' px vars cx :: vars) cf = 0%R -> contains (I.convert b) (Xreal (eval_real' px vars cx ))). Proof. intros prec depth vars hyps px cx pf cf b H. apply (R.eval_hyps_bnd_correct prec). set (x := eval_real' px vars cx). intros H1 H2. unfold root_contains in H. revert H. set (xi := nth 0 _ _). assert (Hx: contains (I.convert xi) (Xreal x)). { apply A.BndValuator.eval_correct'. now apply app_merge_hyps_eval_bnd. } clearbody xi. revert xi Hx. induction depth as [|depth IH]. easy. intros xi Hx. simpl. fold (compute_inputs prec hyps cf). refine (_ (A.DiffValuator.root_correct prec pf (compute_inputs prec hyps cf) _ _ xi x Hx H2)). 2: now apply app_merge_hyps_eval_bnd. set (xi' := A.DiffValuator.root _ _ _ _). intros Hx' H. destruct I.subset eqn:Hg ; [|destruct fast_enough]. - clear H IH. now apply I.subset_correct with (2 := Hg). - now apply (IH _ Hx'). - generalize (I.bisect_correct _ _ Hx'). destruct (I.bisect xi') as [xi1 xi2]. destruct refine_root_aux eqn:Hb. now intros [K|K] ; apply (IH _ K). easy. Qed. (* loc = Lt gives the leftmost root, Gt the rightmost one, Eq all of them *) Fixpoint root_plain_aux depth prec prog bounds xi loc := match depth with | S depth => let xi' := A.DiffValuator.root prec prog bounds xi in if I.is_empty xi' then xi' else if fast_enough prec xi xi' then root_plain_aux depth prec prog bounds xi' loc else let (xi1,xi2) := I.bisect xi' in match loc with | Eq => let xi1' := root_plain_aux depth prec prog bounds xi1 Lt in if I.is_empty xi1' then root_plain_aux depth prec prog bounds xi2 Eq else let xi2' := root_plain_aux depth prec prog bounds xi2 Gt in if I.is_empty xi2' then I.join xi1' (root_plain_aux depth prec prog bounds xi1 Gt) else I.join xi1' xi2' | Lt => let xi1' := root_plain_aux depth prec prog bounds xi1 Lt in if I.is_empty xi1' then root_plain_aux depth prec prog bounds xi2 Lt else xi1' | Gt => let xi2' := root_plain_aux depth prec prog bounds xi2 Gt in if I.is_empty xi2' then root_plain_aux depth prec prog bounds xi1 Gt else xi2' end | O => xi end. Definition root_plain prec depth hyps px cx pf cf := let hyps := R.merge_hyps prec hyps in let xi := nth 0 (A.BndValuator.eval prec px (hyps ++ map (T.eval_bnd prec) cx)) I.nai in root_plain_aux depth prec pf (hyps ++ map (T.eval_bnd prec) cf) xi Eq. Ltac do_root x Zy prec depth native nocheck := massage_goal ; let y := match type of Zy with | (?y = 0)%R => y | _ => fail "Not an equality to zero" end in match goal with | |- eval_goal ?g' ?z => let g := fresh "__goal" in set (g := g') ; let vars := get_vars x (@nil R) in let vars := get_vars y vars in let vars := get_vars z vars in let vars' := constr:(x :: vars) in reify_partial z vars' ; intros <- ; revert Zy ; reify_partial y vars' ; intros <- ; let v := fresh "__vars" in set (v := vars) ; reify_partial x vars ; intros <- ; find_hyps vars ; apply (refine_root_correct prec depth) end ; do_reduction nocheck native. Ltac do_root_intro x Zy prec depth native nocheck output := let y := match type of Zy with | ?y = 0%R => y | _ => fail "Not an equality to zero" end in let i := fresh "__i" in evar (i : I.type) ; cut (contains (I.convert i) (Xreal x))%R ; cycle 1 ; [ let vars := get_vars x (@nil R) in let vars := get_vars y vars in let vars' := constr:(x :: vars) in revert Zy ; reify_partial y vars' ; intros <- ; let v := fresh "__vars" in set (v := vars) ; reify_partial x vars ; intros <- ; find_hyps vars ; apply (root_contains_correct prec depth v) ; match goal with | |- _ ?hyps ?px ?cx ?pf ?cf _ = true => do_instantiate i (fun xi : I.type => xi) native (root_plain prec depth hyps px cx pf cf) end ; do_reduction nocheck native | unfold i ; clear i ; do_interval_generalize (I.output_correct output) ]. End RootTacticAux. interval-4.11.1/testsuite/000077500000000000000000000000001470547631300154655ustar00rootroot00000000000000interval-4.11.1/testsuite/bug-20120927.v000066400000000000000000000003301470547631300173310ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. Goal forall x, (-1/2 <= x <= 0)%R -> True. Proof. intros x Hx. interval_intro (Rabs x + x)%R upper with (i_bisect x, i_autodiff x, i_depth 5). exact I. Qed. interval-4.11.1/testsuite/bug-20140723.v000066400000000000000000000002101470547631300173220ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. Goal True. interval_intro PI lower. interval_intro (PI/2)%R upper. exact I. Qed. interval-4.11.1/testsuite/bug-20140728.v000066400000000000000000000002071470547631300173350ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. Local Open Scope R_scope. Goal forall x : R, exp x >= 0. intros; interval. Qed. interval-4.11.1/testsuite/bug-20150924.v000066400000000000000000000002241470547631300173330ustar00rootroot00000000000000Require Import Reals Interval.Tactic. Goal forall x : R, (Rabs (x - x) <= 1/5)%R. Proof. intros x. interval with (i_autodiff x, i_prec 10). Qed. interval-4.11.1/testsuite/bug-20150925.v000066400000000000000000000002231470547631300173330ustar00rootroot00000000000000Require Import Reals Interval.Tactic. Goal forall x, (-1 / 3 <= x - x <= 1 / 7)%R. Proof. intros x. interval with (i_autodiff x, i_prec 10). Qed. interval-4.11.1/testsuite/bug-20160218.v000066400000000000000000000002101470547631300173230ustar00rootroot00000000000000Require Import Reals Interval.Tactic. Goal forall x, (0 <= x <= 1 -> 2 <= 3)%R. Proof. intros x Hx. interval with (i_autodiff x). Qed. interval-4.11.1/testsuite/bug-20200616.v000066400000000000000000000003221470547631300173240ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Goal forall x, 1 <= x -> sin (x - 1) / (x - 3/4) <= 7/10. Proof. intros. interval with (i_bisect x, i_autodiff x). Qed. interval-4.11.1/testsuite/bug-20201020.v000066400000000000000000000002661470547631300173210ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. Goal forall x, (1 < x <= 5)%R -> (2 > Rabs x)%R -> (2 <= x + 1 <= 3)%R. Proof. intros x H1 H2. interval with (i_prec 30). Qed. interval-4.11.1/testsuite/bug-20201223.v000066400000000000000000000005611470547631300173240ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Core. From Interval Require Import Tactic. Goal forall x, (IZR (1 + 1) <= IZR x -> 1 <= sqrt (IZR x))%R. Proof. intros. interval. Qed. Goal forall prec, (0 <= bpow radix2 (1 - prec) <= 1 / 32 -> 12 / 25 <= (2 - bpow radix2 (1 - prec)) / (2 * (2 + bpow radix2 (1 - prec))))%R. Proof. intros. interval. Qed. interval-4.11.1/testsuite/bug-20210113.v000066400000000000000000000002721470547631300173210ustar00rootroot00000000000000From Interval Require Import Tactic. From Coq Require Import Reals. From Coquelicot Require Import Coquelicot. Open Scope R_scope. Goal RInt (fun x => x) 0 1 <= 2. Proof. integral. Qed.interval-4.11.1/testsuite/bug-20220303.v000066400000000000000000000001651470547631300173240ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Goal (1000 <= exp 800)%R. Proof. interval. Qed. interval-4.11.1/testsuite/bug-20220402.v000066400000000000000000000007571470547631300173330ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Notation "x = y ± z" := (Rle (Rabs (x - y)) z) (at level 70, y at next level). Lemma quintic1 x : x^5 = x + 1 -> x = 11673039782614185/10000000000000000 ± 1/100000000000000. Proof. intros H. root H. Qed. Definition quintic2 x := ltac:(root (x^5 - x - 1)). Goal forall x, x^5 - x - 1 = 0 -> x = 11673039782614185 / 10000000000000000 ± 1/1000000. Proof. intros x H. apply quintic2 in H. interval. Qed. interval-4.11.1/testsuite/bug-20230701.v000066400000000000000000000003101470547631300173170ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Goal forall x : Datatypes.id R, (0 <= x <= 1)%R -> (0 <= x + x <= 2)%R. Proof. intros. interval with (i_taylor x, i_prec 10). Qed. interval-4.11.1/testsuite/bug-20240206.v000066400000000000000000000004741470547631300173330ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Goal forall x, (0 <= x <= 1 -> -1 < x <= 2)%R. Proof. intros x Hx. interval. Qed. Goal forall x, (0 <= x <= 1 -> -1 <= x < 2)%R. Proof. intros x Hx. interval. Qed. Goal forall x, (0 <= x <= 1 -> -1 < x < 2)%R. Proof. intros x Hx. interval. Qed. interval-4.11.1/testsuite/example-20071016.v000066400000000000000000000060131470547631300202050ustar00rootroot00000000000000From Coq Require Import Reals Lra. From Interval Require Import Tactic. Open Scope R_scope. Notation "x = y ± z" := (Rle (Rabs (x - y)) z) (at level 70, y at next level). (* Tactic interval *) Goal forall x, -1 <= x <= 1 -> sqrt (1 - x) <= 3/2. Proof. intros. interval. Qed. Goal forall x, -1 <= x <= 1 -> sqrt (1 - x) <= 141422/100000. Proof. intros. interval. Qed. Goal forall x, -1 <= x <= 1 -> sqrt (1 - x) <= 141422/100000. Proof. intros. interval_intro (sqrt (1 - x)) upper as H'. apply Rle_trans with (1 := H'). lra. Qed. Goal forall x, 3/2 <= x <= 2 -> forall y, 1 <= y <= 33/32 -> sqrt(1 + x/sqrt(x+y)) = 144/1000*x + 118/100 ± 71/32768. Proof. intros. interval with (i_prec 19, i_bisect x). Qed. Goal forall x, 1/2 <= x <= 2 -> sqrt x = ((((122 / 7397 * x + (-1733) / 13547) * x + 529 / 1274) * x + (-767) / 999) * x + 407 / 334) * x + 227 / 925 ± 5/65536. Proof. intros. interval with (i_bisect x, i_taylor x, i_degree 3). Qed. Goal forall x, -1 <= x -> x < 1 + powerRZ x 3. Proof. intros. apply Rminus_lt. interval with (i_bisect x, i_autodiff x). Qed. From Flocq Require Import Core. Notation rnd := (round radix2 (FLT_exp (-1074) 53) ZnearestE). Goal forall x, -1 <= x <= 1 -> rnd (1 + rnd (x * rnd (1 + rnd (x * (922446257493983/2251799813685248))))) = exp x ± 31/100. Proof. intros. interval with (i_taylor x). Qed. (* Tactic integral *) From Coquelicot Require Import Coquelicot. Goal RInt (fun x => atan (sqrt (x*x + 2)) / (sqrt (x*x + 2) * (x*x + 1))) 0 1 = 5/96*PI*PI ± 1/1000. Proof. integral with (i_fuel 2, i_degree 5). Qed. Goal RInt_gen (fun x => 1 * (powerRZ x 3 * ln x^2)) (at_right 0) (at_point 1) = 1/32. Proof. refine ((fun H => Rle_antisym _ _ (proj2 H) (proj1 H)) _). integral with (i_prec 10). Qed. (* Goal Rabs (RInt_gen (fun t => 1/sqrt t * exp (-(1*t))) (at_point 1) (Rbar_locally p_infty) - 2788/10000) <= 1/1000. Proof. interval. Qed. *) (* Tactic root *) Goal forall x:R, 999 <= x <= 1000 -> sin x = 0 -> x = 318 * PI ± 1/1000. Proof. intros x Hx Hs. root Hs. Qed. (* Degenerate forms *) Definition equal_1 x `(0 <= x <= PI/2) := ltac:(interval ((cos x)² + (sin x)²) with (i_taylor x)). Definition equal_PI_over_4 := ltac:(integral (RInt (fun x => 1 / (1+x*x)) 0 1)). Definition equal_0_442854401002 x := ltac:(root (exp x = 2 - x) with i_decimal). (* Tactic plot and command Plot *) From Interval Require Import Plot. Definition p1 := ltac:(plot (fun x => x^2 * sin (x^2)) (-4) 4). Definition p2 := ltac:( plot (fun x => sin (x + exp x)) 0 6 (-5/4) (5/4) with (i_size 120 90, i_degree 6)). Plot p2 as "picture.gnuplot". Plot ltac:(plot (fun x => sqrt (1 - x^2) * sin (x * 200)) (-1) 1 with (i_degree 1, i_size 100 300)) as "picture.gnuplot". (* Commands Do and Def *) Do interval (PI²/6). Do integral (RInt_gen (fun x => 1/(1 + x)^2 * (ln x)^2) (at_right 0) (at_point 1)) with (i_relwidth 30). Def quintic x := root (x^5 - x = 1). interval-4.11.1/testsuite/example-20120205.v000066400000000000000000000007601470547631300202030ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. Goal forall x, (1 <= x)%R -> (0 < x)%R. Proof. intros. interval. Qed. Goal forall x, (1 <= x)%R -> (x <= x * x)%R. Proof. intros. apply Rminus_le. interval with (i_autodiff x, i_prec 10). Qed. Goal forall x, (2 <= x)%R -> (x < x * x)%R. Proof. intros. apply Rminus_lt. interval with (i_autodiff x). Qed. Goal forall x, (-1 <= x)%R -> (x < 1 + powerRZ x 3)%R. Proof. intros. apply Rminus_lt. interval with (i_bisect x, i_autodiff x). Qed. interval-4.11.1/testsuite/example-20140221.v000066400000000000000000000011741470547631300202030ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. Local Open Scope R_scope. (* Example taken from: John Harrison, Verifying the Accuracy of Polynomial Approximations in HOL. In TPHOLs, pages 137-152, 1997. *) Goal forall x : R, (-10831/1000000 <= x /\ x <= 10831/1000000) -> Rabs ((exp x - 1) - (x + (8388676/2^24) * x^2 + (11184876/2^26) * x^3)) <= (23/27) / (2^33). Proof. intros x H. (* Time interval with (i_bisect x, i_autodiff x, i_prec 50, i_depth 16). (* 22 s *) *) Time interval with (i_bisect x, i_taylor x, i_degree 3, i_prec 50). (* 0.12 s *) Qed. (* The timings above were obtained using Coq 8.9.1 *) interval-4.11.1/testsuite/example-20140610.v000066400000000000000000000015621470547631300202060ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Local Open Scope R_scope. (* Example taken from: Marc Daumas and Guillaume Melquiond and César Muñoz, Guaranteed Proofs Using Interval Arithmetic. In IEEE ARITH 17, pages 188-195, 2005. *) Definition a := 6378137. Definition f := 1000000000/298257223563. Definition umf2 := (1 - f)². Definition max := 715/512. Definition rp phi := a / sqrt (1 + umf2 * (tan phi)²). Definition arp phi := let x := max² - phi² in 4439091/4 + x * (9023647/4 + x * ( 13868737/64 + x * (13233647/2048 + x * ( -1898597/16384 + x * (-6661427/131072))))). Goal forall phi, 0 <= phi <= max -> Rabs ((rp phi - arp phi) / rp phi) <= 23/16777216. Proof. intros phi Hphi. (* Time interval with (i_bisect phi, i_autodiff phi). (* 15 s *) *) Time interval with (i_bisect phi, i_taylor phi, i_degree 5). (* 1.2 s *) Qed. interval-4.11.1/testsuite/example-20150105.v000066400000000000000000000011701470547631300202010ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Notation pow2 := (Raux.bpow Zaux.radix2). (* Example taken from: William J. Cody Jr. and William Waite Software Manual for the Elementary Functions *) Goal forall x : R, Rabs x <= 35/100 -> let p := fun t => 1 * pow2 (-2) + t * (1116769 * pow2 (-28)) in let q := fun t => 1 * pow2 (-1) + t * (13418331 * pow2 (-28)) in let r := 2 * (x * p (x^2) / (q (x^2) - x * p (x^2)) + 1 * pow2 (-1)) in Rabs ((r - exp x) / exp x) <= 17 * pow2 (-34). Proof. intros x Hx p q r. interval with (i_prec 40, i_bisect x, i_taylor x, i_degree 3). Qed. interval-4.11.1/testsuite/example-20160218.v000066400000000000000000000014501470547631300202100ustar00rootroot00000000000000Require Import Reals Coquelicot.Coquelicot. Require Import Interval.Tactic. Lemma constant : 3 <= RInt (fun x => 1) 0 3 <= 3. Proof. integral with (i_prec 10). Qed. Lemma exp_0_3 : Rabs (RInt (fun x => exp x) 0 3 - (exp 1 ^ 3 - 1)) <= 1/(1000*1000). Proof. integral with (i_fuel 1). Qed. Lemma x_ln1p_0_1 : Rabs (RInt (fun x => x * ln (1 + x)) 0 1 - 1/4) <= 1/1000. Proof. integral with (i_fuel 1). Qed. Lemma circle : Rabs (RInt (fun x => sqrt (1 - x * x)) 0 1 - PI / 4) <= 1/100. Proof. integral with (i_fuel 7, i_degree 1). Qed. Lemma exp_cos_0_1 : Rabs (RInt (fun x => sin x * exp (cos x)) 0 1 - (exp 1 - exp (cos 1))) <= 1/1000. Proof. integral with (i_fuel 1). Qed. Lemma arctan_0_1 : Rabs (RInt (fun x => 1 / (1 + x*x)) 0 1 - PI / 4) <= 1/1000. Proof. integral with (i_fuel 1). Qed. interval-4.11.1/testsuite/example-20171018.v000066400000000000000000000003331470547631300202070ustar00rootroot00000000000000Require Import Reals. From Interval Require Import Tactic Basic. Open Scope R_scope. Lemma h_54_ln_2 h : -53 <= h <= 0 -> - Rnearbyint rnd_DN (h * ln 2 / ln 5) * ln 5 <= 54 * ln 2. Proof. intros. interval. Qed. interval-4.11.1/testsuite/example-20200428.v000066400000000000000000000010061470547631300202030ustar00rootroot00000000000000Require Import Reals. Require Import Coquelicot.Coquelicot. Require Import Tactic. Goal True. integral_intro (RInt (fun x => ln x) 1 (sqrt 2)) with (i_relwidth 20). integral_intro (RInt_gen (fun x => (1 + 1 / x) / (x * ln x ^ 2)) (at_point (PI * 5)) (Rbar_locally p_infty)). integral_intro (RInt_gen (fun x => (1 + 1 / x) * (powerRZ x (-2) * ln x ^ 2)) (at_point 10) (Rbar_locally p_infty)). integral_intro (RInt_gen (fun x => cos x * (powerRZ x 2 * ln x ^ 3)) (at_right 0) (at_point 2)) with (i_width (-20)). Abort. interval-4.11.1/testsuite/example-20200430.v000066400000000000000000000004331470547631300201770ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Goal forall x y, -1/2 <= x <= 1/2 -> -1/2 <= y <= 1/2 -> Rabs (exp (x + y) / (exp x * exp y) - 1) <= 1/10. Proof. intros x y Hx Hy. interval with (i_autodiff x, i_bisect y, i_bisect x). Qed. interval-4.11.1/testsuite/example-20210218.v000066400000000000000000000016141470547631300202060ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Definition p1 := ltac:(plot (fun x => x^2 * sin (x^2)) (-4) 4 with (i_degree 8)). Definition p2 := ltac:(plot (fun x => 1/x) (-1) 1 (-1) 1 with (i_size 1024 768)). Definition p3 := ltac:(plot (fun x => x*x) 0 1). Definition p4 := ltac:(plot (fun x => 1 + x * (4503599627370587 * powerRZ 2 (-52) + x * (4503599627370551 * powerRZ 2 (-53) + x * (6004799497195935 * powerRZ 2 (-55) + x * (6004799498485985 * powerRZ 2 (-57) + x * (2402017533563707 * powerRZ 2 (-58) + x * (6405354563481393 * powerRZ 2 (-62)))))))- exp x) (-1/32) (1/32) with (i_prec 90)). (* plot [-1./32:1./32] 1 + x * (4503599627370587. * 2**(-52) + x * (4503599627370551. * 2**(-53) + x * (6004799497195935. * 2**(-55) + x * (6004799498485985. * 2**(-57) + x * (2402017533563707. * 2**(-58) + x * (6405354563481393. * 2**(-62))))))) - exp(x) *) interval-4.11.1/testsuite/example-20220302.v000066400000000000000000000030011470547631300201710ustar00rootroot00000000000000From Coq Require Import Reals. From Coquelicot Require Import Coquelicot. From Interval Require Import Tactic. Open Scope R_scope. Definition stirling x eps := sqrt (2 * PI * x) * exp (x * (ln x - 1)) * exp (1 / (12 * x + eps)). Definition digits x := IZR (Raux.Ztrunc (ln x / ln 10)) + 1. Definition fact_50 eps (_: 0 <= eps <= 1) := ltac:(interval (digits (stirling 50 eps)) with (i_prec 30)). (* Notation pow2 := (Raux.bpow Zaux.radix2). Definition p0 := 1 * pow2 (-2). Definition p1 := 4002712888408905 * pow2 (-59). Definition p2 := 1218985200072455 * pow2 (-66). Definition q0 := 1 * pow2 (-1). Definition q1 := 8006155947364787 * pow2 (-57). Definition q2 := 4573527866750985 * pow2 (-63). Definition f t := let t2 := t * t in let p := p0 + t2 * (p1 + t2 * p2) in let q := q0 + t2 * (q1 + t2 * q2) in 2 * ((t * p) / (q - t * p) + 1/2). Lemma method_error : forall t : R, Rabs t <= 0.35 -> Rabs ((f t - exp t) / exp t) <= 5e-18. Proof. intros t Ht. Time interval with (i_bisect t, i_taylor t, i_prec 80). Qed. Goal Rabs (RInt (fun tau => (0.5 * ln (tau^2 + 2.25) + 4.1396 + ln PI)^2 / (0.25 + tau^2)) (-100000) 100000 - 226.8435) <= 2e-4. Proof. Time integral. Qed. Goal Rabs (RInt_gen (fun tau => (1 + (0.5 * ln (1 + 2.25/tau^2) + 4.1396 + ln PI) / ln tau)^2 / (1 + 0.25 / tau^2) * (powerRZ tau (-2) * (ln tau)^2)) (at_point 100000) (Rbar_locally p_infty) - 0.00317742) <= 1e-5. Proof. Time integral. Qed. Definition p := ltac:(plot (fun t => (f t - exp t) / exp t) (-0.35) 0.35 with (i_prec 80)). *) interval-4.11.1/testsuite/example-20220304.v000066400000000000000000000005531470547631300202040ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Goal forall x, x^3 + 1 = 0 -> Rabs (x + 1) <= 1/10000000000. Proof. intros x H. root H. Qed. Goal forall x z, 0 <= x <= 1 -> 2 <= z <= 2 -> (x+1)*(x+1) - z = 0 -> Rabs (x+1 - 1414/1000) <= 1/1000. Proof. intros x z Hx Hz H. root H with (i_autodiff (x+1), i_depth 2). Qed. interval-4.11.1/testsuite/example-20221027.v000066400000000000000000000015301470547631300202030ustar00rootroot00000000000000From Coq Require Import Reals. From Interval Require Import Tactic. Open Scope R_scope. Definition foo x `(3 <= x <= 4) := ltac:(root (tan (x/4) = exp (sin x)) with i_decimal). Goal forall x, 3 <= x <= 4 -> tan (x/4) = exp (sin x) -> Rabs (x - PI) <= 1/1000000000. Proof. intros x Hx H. assert (H' := foo x Hx H). interval. Qed. Notation "x = y ± z" := (Rle (Rabs (x - y)) z) (at level 70, y at next level). From Flocq Require Import Core. Notation round := (round radix2 (FLT_exp (-149) 24) ZnearestE). Definition fadd x y := round (x + y). Definition fmul x y := round (x * y). Goal forall x, -1/256 <= x <= 1/256 -> let c1 := 524289 * bpow radix2 (-19) in let c2 := 1/2 in fadd 1 (fmul x (fadd c1 (fmul x c2))) = exp x ± 7/10 * bpow radix2 (-23). Proof. intros x Hx c2. unfold fadd, fmul, c2. interval with (i_taylor x). Qed. interval-4.11.1/testsuite/example-20221103.v000066400000000000000000000004021470547631300201730ustar00rootroot00000000000000From Coq Require Import Reals. From Coquelicot Require Import Coquelicot. From Interval Require Import Tactic. Open Scope R_scope. Goal Rabs (RInt_gen (fun x => 1/(1+x)^2 * (ln x)^2) (at_right 0) (at_point 1) - PI^2 / 6) <= 1/1000000. Proof. integral. Qed. interval-4.11.1/testsuite/example-20231013.v000066400000000000000000000006131470547631300202000ustar00rootroot00000000000000From Coq Require Import Reals. From Flocq Require Import Core. From Interval Require Import Tactic. Open Scope R_scope. Goal forall x, 0 <= x <= 10 -> Rabs (round radix2 (FLT_exp (-1074) 53) ZnearestE (IZR (Zfloor x)) + - IZR (Zfloor x)) <= 1/1000. Proof. intros x H. interval. Qed. Goal forall x, -1/1000 <= round radix2 (FIX_exp (-4)) Zceil x - x <= 1/10. Proof. intros x. interval. Qed. interval-4.11.1/testsuite/test-failures.v000066400000000000000000000075431470547631300204540ustar00rootroot00000000000000Require Import Reals. Require Import Interval.Tactic. (* Note: the error messages below were obtained with Coq 8.4pl6 *) (** The tactic should always fail for syntax errors *) Lemma fail_tuple_to_list : True. Fail interval with (tt). (* The command has indeed failed with message: *) (* => Error: Tactic failure: Unknown tactic parameter tt (level 99). *) Fail interval with (tt) || idtac. (* The command has indeed failed with message: *) (* => Error: Tactic failure: Unknown tactic parameter tt (level 98). *) Abort. Lemma fail_tuple_to_list_intro : True. Fail interval_intro 0%R with (tt). (* The command has indeed failed with message: *) (* => Error: Tactic failure: Unknown tactic parameter tt (level 99). *) Fail interval_intro 0%R with (tt) || idtac. (* The command has indeed failed with message: *) (* => Error: Tactic failure: Unknown tactic parameter tt (level 98). *) Abort. (** The tactic should fail gracefully for non-syntax errors *) Lemma fail_get_bounds (x y : R) : (x <= y)%R -> (y - x >= 0)%R. intros. Fail interval with (i_prec 40). (* Warning: Silently use the whole real line for the following terms: *) (* y *) (* x *) (* You may need to unfold some of these terms, or provide a bound. *) (* The command has indeed failed with message: *) (* => Error: Tactic failure: *) (* Numerical evaluation failed to conclude. You may want to adjust some parameters. *) Fail interval. (* Warning: Silently use the whole real line for the following terms: *) (* y *) (* x *) (* You may need to unfold some of these terms, or provide a bound. *) (* The command has indeed failed with message: *) (* => Error: Tactic failure: *) (* Numerical evaluation failed to conclude. You may want to adjust some parameters. *) interval || idtac. Abort. Lemma fail_xalgorithm_pre : True. Fail interval with (i_prec 40). (* The command has indeed failed with message: *) (* => Error: Tactic failure: Goal is not an inequality with constant bounds. *) Fail interval. (* The command has indeed failed with message: *) (* => Error: Tactic failure: Goal is not an inequality with constant bounds. *) interval || idtac. Abort. Lemma fail_do_interval : (PI > 314159265358979323846/100000000000000000000)%R. Fail interval with (i_prec 40). (* The command has indeed failed with message: *) (* => Error: Tactic failure: *) (* Numerical evaluation failed to conclude. You may want to adjust some parameters. *) Fail interval. (* The command has indeed failed with message: *) (* => Error: Tactic failure: *) (* Numerical evaluation failed to conclude. You may want to adjust some parameters. *) interval || idtac. Abort. Lemma fail_do_interval_generalize_1 (x : R) : True. Fail interval_intro (tan x) with (i_prec 40). (* Warning: Silently use the whole real line for the following term: *) (* x *) (* You may need to unfold this term, or provide a bound. *) (* The command has indeed failed with message: *) (* => Error: Tactic failure: Nothing known about (tan x). *) Fail interval_intro (tan x). (* Warning: Silently use the whole real line for the following term: *) (* x *) (* You may need to unfold this term, or provide a bound. *) (* The command has indeed failed with message: *) (* => Error: Tactic failure: Nothing known about (tan x). *) interval_intro (tan x) || idtac. Abort. Lemma fail_do_interval_generalize_2 (x : R) : True. Fail interval_intro x with (i_prec 40). (* Warning: Silently use the whole real line for the following term: *) (* x *) (* You may need to unfold this term, or provide a bound. *) (* The command has indeed failed with message: *) (* => Error: Tactic failure: Nothing known about x. *) Fail interval_intro x. (* Warning: Silently use the whole real line for the following term: *) (* x *) (* You may need to unfold this term, or provide a bound. *) (* The command has indeed failed with message: *) (* => Error: Tactic failure: Nothing known about x. *) interval_intro x || idtac. Abort. interval-4.11.1/configure0000755000000000000000000045650414705476313015357 0ustar00rootroot00000000000000#! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.71 for Interval 4.11.1. # # Report bugs to >. # # # Copyright (C) 1992-1996, 1998-2017, 2020-2021 Free Software Foundation, # Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # Use a proper internal environment variable to ensure we don't fall # into an infinite loop, continuously re-executing ourselves. if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then _as_can_reexec=no; export _as_can_reexec; # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi # We don't want this to propagate to other subprocesses. { _as_can_reexec=; unset _as_can_reexec;} if test "x$CONFIG_SHELL" = x; then as_bourne_compatible="as_nop=: if test \${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which # is contrary to our usage. Disable this feature. alias -g '\${1+\"\$@\"}'='\"\$@\"' setopt NO_GLOB_SUBST else \$as_nop case \`(set -o) 2>/dev/null\` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi " as_required="as_fn_return () { (exit \$1); } as_fn_success () { as_fn_return 0; } as_fn_failure () { as_fn_return 1; } as_fn_ret_success () { return 0; } as_fn_ret_failure () { return 1; } exitcode=0 as_fn_success || { exitcode=1; echo as_fn_success failed.; } as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } if ( set x; as_fn_ret_success y && test x = \"\$1\" ) then : else \$as_nop exitcode=1; echo positional parameters were not saved. fi test x\$exitcode = x0 || exit 1 blah=\$(echo \$(echo blah)) test x\"\$blah\" = xblah || exit 1 test -x / || exit 1" as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" if (eval "$as_required") 2>/dev/null then : as_have_required=yes else $as_nop as_have_required=no fi if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null then : else $as_nop as_save_IFS=$IFS; IFS=$PATH_SEPARATOR as_found=false for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac as_found=: case $as_dir in #( /*) for as_base in sh bash ksh sh5; do # Try only shells that exist, to save several forks. as_shell=$as_dir$as_base if { test -f "$as_shell" || test -f "$as_shell.exe"; } && as_run=a "$as_shell" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$as_shell as_have_required=yes if as_run=a "$as_shell" -c "$as_bourne_compatible""$as_suggested" 2>/dev/null then : break 2 fi fi done;; esac as_found=false done IFS=$as_save_IFS if $as_found then : else $as_nop if { test -f "$SHELL" || test -f "$SHELL.exe"; } && as_run=a "$SHELL" -c "$as_bourne_compatible""$as_required" 2>/dev/null then : CONFIG_SHELL=$SHELL as_have_required=yes fi fi if test "x$CONFIG_SHELL" != x then : export CONFIG_SHELL # We cannot yet assume a decent shell, so we have to provide a # neutralization value for shells without unset; and this also # works around shells that cannot unset nonexistent variables. # Preserve -v and -x to the replacement shell. BASH_ENV=/dev/null ENV=/dev/null (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV case $- in # (((( *v*x* | *x*v* ) as_opts=-vx ;; *v* ) as_opts=-v ;; *x* ) as_opts=-x ;; * ) as_opts= ;; esac exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} # Admittedly, this is quite paranoid, since all the known shells bail # out after a failed `exec'. printf "%s\n" "$0: could not re-execute with $CONFIG_SHELL" >&2 exit 255 fi if test x$as_have_required = xno then : printf "%s\n" "$0: This script requires a shell more modern than all" printf "%s\n" "$0: the shells that I found on your system." if test ${ZSH_VERSION+y} ; then printf "%s\n" "$0: In particular, zsh $ZSH_VERSION has bugs and should" printf "%s\n" "$0: be upgraded to zsh 4.3.4 or later." else printf "%s\n" "$0: Please tell bug-autoconf@gnu.org and Guillaume $0: Melquiond about your $0: system, including any error possibly output before this $0: message. Then install a modern shell, or manually run $0: the script under such a shell if you do have one." fi exit 1 fi fi fi SHELL=${CONFIG_SHELL-/bin/sh} export SHELL # Unset more variables known to interfere with behavior of common tools. CLICOLOR_FORCE= GREP_OPTIONS= unset CLICOLOR_FORCE GREP_OPTIONS ## --------------------- ## ## M4sh Shell Functions. ## ## --------------------- ## # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else $as_nop as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else $as_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith # as_fn_nop # --------- # Do nothing but, unlike ":", preserve the value of $?. as_fn_nop () { return $? } as_nop=as_fn_nop # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits as_lineno_1=$LINENO as_lineno_1a=$LINENO as_lineno_2=$LINENO as_lineno_2a=$LINENO eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) sed -n ' p /[$]LINENO/= ' <$as_myself | sed ' s/[$]LINENO.*/&-/ t lineno b :lineno N :loop s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ t loop s/-\n.*// ' >$as_me.lineno && chmod +x "$as_me.lineno" || { printf "%s\n" "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } # If we had to re-execute with $CONFIG_SHELL, we're ensured to have # already done that, so ensure we don't try to do so again and fall # in an infinite loop. This has already happened in practice. _as_can_reexec=no; export _as_can_reexec # Don't try to exec as it changes $[0], causing all sort of problems # (the dirname of $[0] is not the place where we might find the # original and so on. Autoconf is especially sensitive to this). . "./$as_me.lineno" # Exit status is that of the last command. exit } # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" test -n "$DJDIR" || exec 7<&0 &1 # Name of the host. # hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, # so uname gets run too. ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` # # Initializations. # ac_default_prefix=/usr/local ac_clean_files= ac_config_libobj_dir=. LIBOBJS= cross_compiling=no subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='Interval' PACKAGE_TARNAME='interval' PACKAGE_VERSION='4.11.1' PACKAGE_STRING='Interval 4.11.1' PACKAGE_BUGREPORT='Guillaume Melquiond ' PACKAGE_URL='' ac_subst_vars='LTLIBOBJS LIBOBJS ac_ct_CXX CXXFLAGS CXX REMAKE PRIM_FLOAT_TAC PRIM_FLOAT LANG_FILES PLOTPLUGIN COQINTERVALLIB COQUSERCONTRIB PLOT TACTIC_PARAM TACTIC_TARGETS MATHCOMP_1_OR_2 OCAMLFIND COQEXTRAFLAGS COQDOC COQDEP INT63_EXPORT COQROOT COQVERSION COQC COQBIN CPP OBJEXT EXEEXT ac_ct_CC CPPFLAGS LDFLAGS CFLAGS CC target_alias host_alias build_alias LIBS ECHO_T ECHO_N ECHO_C DEFS mandir localedir libdir psdir pdfdir dvidir htmldir infodir docdir oldincludedir includedir runstatedir localstatedir sharedstatedir sysconfdir datadir datarootdir libexecdir sbindir bindir program_transform_name prefix exec_prefix PACKAGE_URL PACKAGE_BUGREPORT PACKAGE_STRING PACKAGE_VERSION PACKAGE_TARNAME PACKAGE_NAME PATH_SEPARATOR SHELL' ac_subst_files='' ac_user_opts=' enable_option_checking enable_tactic enable_native_tactic enable_byte_tactic ' ac_precious_vars='build_alias host_alias target_alias CC CFLAGS LDFLAGS LIBS CPPFLAGS CPP COQBIN COQC COQDEP COQDOC COQEXTRAFLAGS OCAMLFIND COQUSERCONTRIB REMAKE CXX CXXFLAGS CCC' # Initialize some variables set by options. ac_init_help= ac_init_version=false ac_unrecognized_opts= ac_unrecognized_sep= # The variables have the same names as the options, with # dashes changed to underlines. cache_file=/dev/null exec_prefix=NONE no_create= no_recursion= prefix=NONE program_prefix=NONE program_suffix=NONE program_transform_name=s,x,x, silent= site= srcdir= verbose= x_includes=NONE x_libraries=NONE # Installation directory options. # These are left unexpanded so users can "make install exec_prefix=/foo" # and all the variables that are supposed to be based on exec_prefix # by default will actually change. # Use braces instead of parens because sh, perl, etc. also accept them. # (The list follows the same order as the GNU Coding Standards.) bindir='${exec_prefix}/bin' sbindir='${exec_prefix}/sbin' libexecdir='${exec_prefix}/libexec' datarootdir='${prefix}/share' datadir='${datarootdir}' sysconfdir='${prefix}/etc' sharedstatedir='${prefix}/com' localstatedir='${prefix}/var' runstatedir='${localstatedir}/run' includedir='${prefix}/include' oldincludedir='/usr/include' docdir='${datarootdir}/doc/${PACKAGE_TARNAME}' infodir='${datarootdir}/info' htmldir='${docdir}' dvidir='${docdir}' pdfdir='${docdir}' psdir='${docdir}' libdir='${exec_prefix}/lib' localedir='${datarootdir}/locale' mandir='${datarootdir}/man' ac_prev= ac_dashdash= for ac_option do # If the previous option needs an argument, assign it. if test -n "$ac_prev"; then eval $ac_prev=\$ac_option ac_prev= continue fi case $ac_option in *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; *=) ac_optarg= ;; *) ac_optarg=yes ;; esac case $ac_dashdash$ac_option in --) ac_dashdash=yes ;; -bindir | --bindir | --bindi | --bind | --bin | --bi) ac_prev=bindir ;; -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) bindir=$ac_optarg ;; -build | --build | --buil | --bui | --bu) ac_prev=build_alias ;; -build=* | --build=* | --buil=* | --bui=* | --bu=*) build_alias=$ac_optarg ;; -cache-file | --cache-file | --cache-fil | --cache-fi \ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) ac_prev=cache_file ;; -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) cache_file=$ac_optarg ;; --config-cache | -C) cache_file=config.cache ;; -datadir | --datadir | --datadi | --datad) ac_prev=datadir ;; -datadir=* | --datadir=* | --datadi=* | --datad=*) datadir=$ac_optarg ;; -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ | --dataroo | --dataro | --datar) ac_prev=datarootdir ;; -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) datarootdir=$ac_optarg ;; -disable-* | --disable-*) ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=no ;; -docdir | --docdir | --docdi | --doc | --do) ac_prev=docdir ;; -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) docdir=$ac_optarg ;; -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) ac_prev=dvidir ;; -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) dvidir=$ac_optarg ;; -enable-* | --enable-*) ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid feature name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "enable_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval enable_$ac_useropt=\$ac_optarg ;; -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ | --exec | --exe | --ex) ac_prev=exec_prefix ;; -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ | --exec=* | --exe=* | --ex=*) exec_prefix=$ac_optarg ;; -gas | --gas | --ga | --g) # Obsolete; use --with-gas. with_gas=yes ;; -help | --help | --hel | --he | -h) ac_init_help=long ;; -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) ac_init_help=recursive ;; -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) ac_init_help=short ;; -host | --host | --hos | --ho) ac_prev=host_alias ;; -host=* | --host=* | --hos=* | --ho=*) host_alias=$ac_optarg ;; -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) ac_prev=htmldir ;; -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ | --ht=*) htmldir=$ac_optarg ;; -includedir | --includedir | --includedi | --included | --include \ | --includ | --inclu | --incl | --inc) ac_prev=includedir ;; -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ | --includ=* | --inclu=* | --incl=* | --inc=*) includedir=$ac_optarg ;; -infodir | --infodir | --infodi | --infod | --info | --inf) ac_prev=infodir ;; -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) infodir=$ac_optarg ;; -libdir | --libdir | --libdi | --libd) ac_prev=libdir ;; -libdir=* | --libdir=* | --libdi=* | --libd=*) libdir=$ac_optarg ;; -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ | --libexe | --libex | --libe) ac_prev=libexecdir ;; -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ | --libexe=* | --libex=* | --libe=*) libexecdir=$ac_optarg ;; -localedir | --localedir | --localedi | --localed | --locale) ac_prev=localedir ;; -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) localedir=$ac_optarg ;; -localstatedir | --localstatedir | --localstatedi | --localstated \ | --localstate | --localstat | --localsta | --localst | --locals) ac_prev=localstatedir ;; -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) localstatedir=$ac_optarg ;; -mandir | --mandir | --mandi | --mand | --man | --ma | --m) ac_prev=mandir ;; -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) mandir=$ac_optarg ;; -nfp | --nfp | --nf) # Obsolete; use --without-fp. with_fp=no ;; -no-create | --no-create | --no-creat | --no-crea | --no-cre \ | --no-cr | --no-c | -n) no_create=yes ;; -no-recursion | --no-recursion | --no-recursio | --no-recursi \ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) no_recursion=yes ;; -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ | --oldin | --oldi | --old | --ol | --o) ac_prev=oldincludedir ;; -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) oldincludedir=$ac_optarg ;; -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) ac_prev=prefix ;; -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) prefix=$ac_optarg ;; -program-prefix | --program-prefix | --program-prefi | --program-pref \ | --program-pre | --program-pr | --program-p) ac_prev=program_prefix ;; -program-prefix=* | --program-prefix=* | --program-prefi=* \ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) program_prefix=$ac_optarg ;; -program-suffix | --program-suffix | --program-suffi | --program-suff \ | --program-suf | --program-su | --program-s) ac_prev=program_suffix ;; -program-suffix=* | --program-suffix=* | --program-suffi=* \ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) program_suffix=$ac_optarg ;; -program-transform-name | --program-transform-name \ | --program-transform-nam | --program-transform-na \ | --program-transform-n | --program-transform- \ | --program-transform | --program-transfor \ | --program-transfo | --program-transf \ | --program-trans | --program-tran \ | --progr-tra | --program-tr | --program-t) ac_prev=program_transform_name ;; -program-transform-name=* | --program-transform-name=* \ | --program-transform-nam=* | --program-transform-na=* \ | --program-transform-n=* | --program-transform-=* \ | --program-transform=* | --program-transfor=* \ | --program-transfo=* | --program-transf=* \ | --program-trans=* | --program-tran=* \ | --progr-tra=* | --program-tr=* | --program-t=*) program_transform_name=$ac_optarg ;; -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) ac_prev=pdfdir ;; -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) pdfdir=$ac_optarg ;; -psdir | --psdir | --psdi | --psd | --ps) ac_prev=psdir ;; -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) psdir=$ac_optarg ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) silent=yes ;; -runstatedir | --runstatedir | --runstatedi | --runstated \ | --runstate | --runstat | --runsta | --runst | --runs \ | --run | --ru | --r) ac_prev=runstatedir ;; -runstatedir=* | --runstatedir=* | --runstatedi=* | --runstated=* \ | --runstate=* | --runstat=* | --runsta=* | --runst=* | --runs=* \ | --run=* | --ru=* | --r=*) runstatedir=$ac_optarg ;; -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) ac_prev=sbindir ;; -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ | --sbi=* | --sb=*) sbindir=$ac_optarg ;; -sharedstatedir | --sharedstatedir | --sharedstatedi \ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ | --sharedst | --shareds | --shared | --share | --shar \ | --sha | --sh) ac_prev=sharedstatedir ;; -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ | --sha=* | --sh=*) sharedstatedir=$ac_optarg ;; -site | --site | --sit) ac_prev=site ;; -site=* | --site=* | --sit=*) site=$ac_optarg ;; -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) ac_prev=srcdir ;; -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) srcdir=$ac_optarg ;; -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ | --syscon | --sysco | --sysc | --sys | --sy) ac_prev=sysconfdir ;; -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) sysconfdir=$ac_optarg ;; -target | --target | --targe | --targ | --tar | --ta | --t) ac_prev=target_alias ;; -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) target_alias=$ac_optarg ;; -v | -verbose | --verbose | --verbos | --verbo | --verb) verbose=yes ;; -version | --version | --versio | --versi | --vers | -V) ac_init_version=: ;; -with-* | --with-*) ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=\$ac_optarg ;; -without-* | --without-*) ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` # Reject names that are not valid shell variable names. expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && as_fn_error $? "invalid package name: \`$ac_useropt'" ac_useropt_orig=$ac_useropt ac_useropt=`printf "%s\n" "$ac_useropt" | sed 's/[-+.]/_/g'` case $ac_user_opts in *" "with_$ac_useropt" "*) ;; *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" ac_unrecognized_sep=', ';; esac eval with_$ac_useropt=no ;; --x) # Obsolete; use --with-x. with_x=yes ;; -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ | --x-incl | --x-inc | --x-in | --x-i) ac_prev=x_includes ;; -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) x_includes=$ac_optarg ;; -x-libraries | --x-libraries | --x-librarie | --x-librari \ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) ac_prev=x_libraries ;; -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) x_libraries=$ac_optarg ;; -*) as_fn_error $? "unrecognized option: \`$ac_option' Try \`$0 --help' for more information" ;; *=*) ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` # Reject names that are not valid shell variable names. case $ac_envvar in #( '' | [0-9]* | *[!_$as_cr_alnum]* ) as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; esac eval $ac_envvar=\$ac_optarg export $ac_envvar ;; *) # FIXME: should be removed in autoconf 3.0. printf "%s\n" "$as_me: WARNING: you should use --build, --host, --target" >&2 expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && printf "%s\n" "$as_me: WARNING: invalid host type: $ac_option" >&2 : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" ;; esac done if test -n "$ac_prev"; then ac_option=--`echo $ac_prev | sed 's/_/-/g'` as_fn_error $? "missing argument to $ac_option" fi if test -n "$ac_unrecognized_opts"; then case $enable_option_checking in no) ;; fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; *) printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; esac fi # Check all directory arguments for consistency. for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ datadir sysconfdir sharedstatedir localstatedir includedir \ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ libdir localedir mandir runstatedir do eval ac_val=\$$ac_var # Remove trailing slashes. case $ac_val in */ ) ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` eval $ac_var=\$ac_val;; esac # Be sure to have absolute directory names. case $ac_val in [\\/$]* | ?:[\\/]* ) continue;; NONE | '' ) case $ac_var in *prefix ) continue;; esac;; esac as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" done # There might be people who depend on the old broken behavior: `$host' # used to hold the argument of --host etc. # FIXME: To remove some day. build=$build_alias host=$host_alias target=$target_alias # FIXME: To remove some day. if test "x$host_alias" != x; then if test "x$build_alias" = x; then cross_compiling=maybe elif test "x$build_alias" != "x$host_alias"; then cross_compiling=yes fi fi ac_tool_prefix= test -n "$host_alias" && ac_tool_prefix=$host_alias- test "$silent" = yes && exec 6>/dev/null ac_pwd=`pwd` && test -n "$ac_pwd" && ac_ls_di=`ls -di .` && ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || as_fn_error $? "working directory cannot be determined" test "X$ac_ls_di" = "X$ac_pwd_ls_di" || as_fn_error $? "pwd does not report name of working directory" # Find the source files, if location was not specified. if test -z "$srcdir"; then ac_srcdir_defaulted=yes # Try the directory containing this script, then the parent directory. ac_confdir=`$as_dirname -- "$as_myself" || $as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_myself" : 'X\(//\)[^/]' \| \ X"$as_myself" : 'X\(//\)$' \| \ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_myself" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` srcdir=$ac_confdir if test ! -r "$srcdir/$ac_unique_file"; then srcdir=.. fi else ac_srcdir_defaulted=no fi if test ! -r "$srcdir/$ac_unique_file"; then test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" fi ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" ac_abs_confdir=`( cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" pwd)` # When building in place, set srcdir=. if test "$ac_abs_confdir" = "$ac_pwd"; then srcdir=. fi # Remove unnecessary trailing slashes from srcdir. # Double slashes in file names in object file debugging info # mess up M-x gdb in Emacs. case $srcdir in */) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; esac for ac_var in $ac_precious_vars; do eval ac_env_${ac_var}_set=\${${ac_var}+set} eval ac_env_${ac_var}_value=\$${ac_var} eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} eval ac_cv_env_${ac_var}_value=\$${ac_var} done if test "$ac_init_help" = "long"; then ac_init_help=short fi # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures Interval 4.11.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. Configuration: -h, --help display this help and exit --help=short display options specific to this package --help=recursive display the short help of all the included packages -V, --version display version information and exit -q, --quiet, --silent do not print \`checking ...' messages --cache-file=FILE cache test results in FILE [disabled] -C, --config-cache alias for \`--cache-file=config.cache' -n, --no-create do not create output files --srcdir=DIR find the sources in DIR [configure dir or \`..'] Installation directories: --prefix=PREFIX install architecture-independent files in PREFIX [$ac_default_prefix] --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX [PREFIX] By default, \`make install' will install all the files in \`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify an installation prefix other than \`$ac_default_prefix' using \`--prefix', for instance \`--prefix=\$HOME'. For better control, use the options below. Fine tuning of the installation directories: --bindir=DIR user executables [EPREFIX/bin] --sbindir=DIR system admin executables [EPREFIX/sbin] --libexecdir=DIR program executables [EPREFIX/libexec] --sysconfdir=DIR read-only single-machine data [PREFIX/etc] --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] --localstatedir=DIR modifiable single-machine data [PREFIX/var] --runstatedir=DIR modifiable per-process data [LOCALSTATEDIR/run] --libdir=DIR object code libraries [EPREFIX/lib] --includedir=DIR C header files [PREFIX/include] --oldincludedir=DIR C header files for non-gcc [/usr/include] --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] --datadir=DIR read-only architecture-independent data [DATAROOTDIR] --infodir=DIR info documentation [DATAROOTDIR/info] --localedir=DIR locale-dependent data [DATAROOTDIR/locale] --mandir=DIR man documentation [DATAROOTDIR/man] --docdir=DIR documentation root [DATAROOTDIR/doc/interval] --htmldir=DIR html documentation [DOCDIR] --dvidir=DIR dvi documentation [DOCDIR] --pdfdir=DIR pdf documentation [DOCDIR] --psdir=DIR ps documentation [DOCDIR] _ACEOF cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of Interval 4.11.1:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] --disable-tactic do not compile a "plot" tactic --disable-native-tactic do not compile a native "plot" tactic --disable-byte-tactic do not compile a bytecode "plot" tactic Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L if you have libraries in a nonstandard directory LIBS libraries to pass to the linker, e.g. -l CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I if you have headers in a nonstandard directory CPP C preprocessor COQBIN path to Coq executables [empty] COQC Coq compiler command [coqc] COQDEP Coq dependency analyzer command [coqdep] COQDOC Coq documentation generator command [coqdoc] COQEXTRAFLAGS extra flags passed to Coq compiler [empty] OCAMLFIND OCaml package manager [ocamlfind] COQUSERCONTRIB installation directory [`$COQC -where`/user-contrib] REMAKE Remake [vendored version] CXX C++ compiler command CXXFLAGS C++ compiler flags Use these variables to override the choices made by `configure' or to help it to find libraries and programs with nonstandard names/locations. Report bugs to >. _ACEOF ac_status=$? fi if test "$ac_init_help" = "recursive"; then # If there are subdirs, report their specific --help. for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue test -d "$ac_dir" || { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || continue ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix cd "$ac_dir" || { ac_status=$?; continue; } # Check for configure.gnu first; this name is used for a wrapper for # Metaconfig's "Configure" on case-insensitive file systems. if test -f "$ac_srcdir/configure.gnu"; then echo && $SHELL "$ac_srcdir/configure.gnu" --help=recursive elif test -f "$ac_srcdir/configure"; then echo && $SHELL "$ac_srcdir/configure" --help=recursive else printf "%s\n" "$as_me: WARNING: no configuration information is in $ac_dir" >&2 fi || ac_status=$? cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF Interval configure 4.11.1 generated by GNU Autoconf 2.71 Copyright (C) 2021 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF exit fi ## ------------------------ ## ## Autoconf initialization. ## ## ------------------------ ## # ac_fn_c_try_compile LINENO # -------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_c_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_compile # ac_fn_c_try_cpp LINENO # ---------------------- # Try to preprocess conftest.$ac_ext, and return whether this succeeded. ac_fn_c_try_cpp () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack if { { ac_try="$ac_cpp conftest.$ac_ext" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } > conftest.i && { test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || test ! -s conftest.err } then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_c_try_cpp # ac_fn_cxx_try_compile LINENO # ---------------------------- # Try to compile conftest.$ac_ext, and return whether this succeeded. ac_fn_cxx_try_compile () { as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack rm -f conftest.$ac_objext conftest.beam if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>conftest.err ac_status=$? if test -s conftest.err; then grep -v '^ *+' conftest.err >conftest.er1 cat conftest.er1 >&5 mv -f conftest.er1 conftest.err fi printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } && { test -z "$ac_cxx_werror_flag" || test ! -s conftest.err } && test -s conftest.$ac_objext then : ac_retval=0 else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 ac_retval=1 fi eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno as_fn_set_status $ac_retval } # ac_fn_cxx_try_compile ac_configure_args_raw= for ac_arg do case $ac_arg in *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac as_fn_append ac_configure_args_raw " '$ac_arg'" done case $ac_configure_args_raw in *$as_nl*) ac_safe_unquote= ;; *) ac_unsafe_z='|&;<>()$`\\"*?[ '' ' # This string ends in space, tab. ac_unsafe_a="$ac_unsafe_z#~" ac_safe_unquote="s/ '\\([^$ac_unsafe_a][^$ac_unsafe_z]*\\)'/ \\1/g" ac_configure_args_raw=` printf "%s\n" "$ac_configure_args_raw" | sed "$ac_safe_unquote"`;; esac cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. It was created by Interval $as_me 4.11.1, which was generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw _ACEOF exec 5>>config.log { cat <<_ASUNAME ## --------- ## ## Platform. ## ## --------- ## hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` uname -m = `(uname -m) 2>/dev/null || echo unknown` uname -r = `(uname -r) 2>/dev/null || echo unknown` uname -s = `(uname -s) 2>/dev/null || echo unknown` uname -v = `(uname -v) 2>/dev/null || echo unknown` /usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` /bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` /bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` /usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` /usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` /usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` /bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` /usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` /bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` _ASUNAME as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac printf "%s\n" "PATH: $as_dir" done IFS=$as_save_IFS } >&5 cat >&5 <<_ACEOF ## ----------- ## ## Core tests. ## ## ----------- ## _ACEOF # Keep a trace of the command line. # Strip out --no-create and --no-recursion so they do not pile up. # Strip out --silent because we don't want to record it for future runs. # Also quote any args containing shell meta-characters. # Make two passes to allow for proper duplicate-argument suppression. ac_configure_args= ac_configure_args0= ac_configure_args1= ac_must_keep_next=false for ac_pass in 1 2 do for ac_arg do case $ac_arg in -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil) continue ;; *\'*) ac_arg=`printf "%s\n" "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; esac case $ac_pass in 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; 2) as_fn_append ac_configure_args1 " '$ac_arg'" if test $ac_must_keep_next = true; then ac_must_keep_next=false # Got value, back to normal. else case $ac_arg in *=* | --config-cache | -C | -disable-* | --disable-* \ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ | -with-* | --with-* | -without-* | --without-* | --x) case "$ac_configure_args0 " in "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; esac ;; -* ) ac_must_keep_next=true ;; esac fi as_fn_append ac_configure_args " '$ac_arg'" ;; esac done done { ac_configure_args0=; unset ac_configure_args0;} { ac_configure_args1=; unset ac_configure_args1;} # When interrupted or exit'd, cleanup temporary files, and complete # config.log. We remove comments because anyway the quotes in there # would cause problems or look ugly. # WARNING: Use '\'' to represent an apostrophe within the trap. # WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. trap 'exit_status=$? # Sanitize IFS. IFS=" "" $as_nl" # Save into config.log some information that might help in debugging. { echo printf "%s\n" "## ---------------- ## ## Cache variables. ## ## ---------------- ##" echo # The following way of writing the cache mishandles newlines in values, ( for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( *${as_nl}ac_space=\ *) sed -n \ "s/'\''/'\''\\\\'\'''\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" ;; #( *) sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) echo printf "%s\n" "## ----------------- ## ## Output variables. ## ## ----------------- ##" echo for ac_var in $ac_subst_vars do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo if test -n "$ac_subst_files"; then printf "%s\n" "## ------------------- ## ## File substitutions. ## ## ------------------- ##" echo for ac_var in $ac_subst_files do eval ac_val=\$$ac_var case $ac_val in *\'\''*) ac_val=`printf "%s\n" "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; esac printf "%s\n" "$ac_var='\''$ac_val'\''" done | sort echo fi if test -s confdefs.h; then printf "%s\n" "## ----------- ## ## confdefs.h. ## ## ----------- ##" echo cat confdefs.h echo fi test "$ac_signal" != 0 && printf "%s\n" "$as_me: caught signal $ac_signal" printf "%s\n" "$as_me: exit $exit_status" } >&5 rm -f core *.core core.conftest.* && rm -f -r conftest* confdefs* conf$$* $ac_clean_files && exit $exit_status ' 0 for ac_signal in 1 2 13 15; do trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal done ac_signal=0 # confdefs.h avoids OS command line length limits that DEFS can exceed. rm -f -r conftest* confdefs.h printf "%s\n" "/* confdefs.h */" > confdefs.h # Predefined preprocessor variables. printf "%s\n" "#define PACKAGE_NAME \"$PACKAGE_NAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_TARNAME \"$PACKAGE_TARNAME\"" >>confdefs.h printf "%s\n" "#define PACKAGE_VERSION \"$PACKAGE_VERSION\"" >>confdefs.h printf "%s\n" "#define PACKAGE_STRING \"$PACKAGE_STRING\"" >>confdefs.h printf "%s\n" "#define PACKAGE_BUGREPORT \"$PACKAGE_BUGREPORT\"" >>confdefs.h printf "%s\n" "#define PACKAGE_URL \"$PACKAGE_URL\"" >>confdefs.h # Let the site file select an alternate cache file if it wants to. # Prefer an explicitly selected file to automatically selected ones. if test -n "$CONFIG_SITE"; then ac_site_files="$CONFIG_SITE" elif test "x$prefix" != xNONE; then ac_site_files="$prefix/share/config.site $prefix/etc/config.site" else ac_site_files="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" fi for ac_site_file in $ac_site_files do case $ac_site_file in #( */*) : ;; #( *) : ac_site_file=./$ac_site_file ;; esac if test -f "$ac_site_file" && test -r "$ac_site_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 printf "%s\n" "$as_me: loading site script $ac_site_file" >&6;} sed 's/^/| /' "$ac_site_file" >&5 . "$ac_site_file" \ || { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed to load site script $ac_site_file See \`config.log' for more details" "$LINENO" 5; } fi done if test -r "$cache_file"; then # Some versions of bash will fail to source /dev/null (special files # actually), so we avoid doing that. DJGPP emulates it as a regular file. if test /dev/null != "$cache_file" && test -f "$cache_file"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 printf "%s\n" "$as_me: loading cache $cache_file" >&6;} case $cache_file in [\\/]* | ?:[\\/]* ) . "$cache_file";; *) . "./$cache_file";; esac fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 printf "%s\n" "$as_me: creating cache $cache_file" >&6;} >$cache_file fi # Test code for whether the C compiler supports C89 (global declarations) ac_c_conftest_c89_globals=' /* Does the compiler advertise C89 conformance? Do not test the value of __STDC__, because some compilers set it to 0 while being otherwise adequately conformant. */ #if !defined __STDC__ # error "Compiler does not advertise C89 conformance" #endif #include #include struct stat; /* Most of the following tests are stolen from RCS 5.7 src/conf.sh. */ struct buf { int x; }; struct buf * (*rcsopen) (struct buf *, struct stat *, int); static char *e (p, i) char **p; int i; { return p[i]; } static char *f (char * (*g) (char **, int), char **p, ...) { char *s; va_list v; va_start (v,p); s = g (p, va_arg (v,int)); va_end (v); return s; } /* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has function prototypes and stuff, but not \xHH hex character constants. These do not provoke an error unfortunately, instead are silently treated as an "x". The following induces an error, until -std is added to get proper ANSI mode. Curiously \x00 != x always comes out true, for an array size at least. It is necessary to write \x00 == 0 to get something that is true only with -std. */ int osf4_cc_array ['\''\x00'\'' == 0 ? 1 : -1]; /* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters inside strings and character constants. */ #define FOO(x) '\''x'\'' int xlc6_cc_array[FOO(a) == '\''x'\'' ? 1 : -1]; int test (int i, double x); struct s1 {int (*f) (int a);}; struct s2 {int (*f) (double a);}; int pairnames (int, char **, int *(*)(struct buf *, struct stat *, int), int, int);' # Test code for whether the C compiler supports C89 (body of main). ac_c_conftest_c89_main=' ok |= (argc == 0 || f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]); ' # Test code for whether the C compiler supports C99 (global declarations) ac_c_conftest_c99_globals=' // Does the compiler advertise C99 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 199901L # error "Compiler does not advertise C99 conformance" #endif #include extern int puts (const char *); extern int printf (const char *, ...); extern int dprintf (int, const char *, ...); extern void *malloc (size_t); // Check varargs macros. These examples are taken from C99 6.10.3.5. // dprintf is used instead of fprintf to avoid needing to declare // FILE and stderr. #define debug(...) dprintf (2, __VA_ARGS__) #define showlist(...) puts (#__VA_ARGS__) #define report(test,...) ((test) ? puts (#test) : printf (__VA_ARGS__)) static void test_varargs_macros (void) { int x = 1234; int y = 5678; debug ("Flag"); debug ("X = %d\n", x); showlist (The first, second, and third items.); report (x>y, "x is %d but y is %d", x, y); } // Check long long types. #define BIG64 18446744073709551615ull #define BIG32 4294967295ul #define BIG_OK (BIG64 / BIG32 == 4294967297ull && BIG64 % BIG32 == 0) #if !BIG_OK #error "your preprocessor is broken" #endif #if BIG_OK #else #error "your preprocessor is broken" #endif static long long int bignum = -9223372036854775807LL; static unsigned long long int ubignum = BIG64; struct incomplete_array { int datasize; double data[]; }; struct named_init { int number; const wchar_t *name; double average; }; typedef const char *ccp; static inline int test_restrict (ccp restrict text) { // See if C++-style comments work. // Iterate through items via the restricted pointer. // Also check for declarations in for loops. for (unsigned int i = 0; *(text+i) != '\''\0'\''; ++i) continue; return 0; } // Check varargs and va_copy. static bool test_varargs (const char *format, ...) { va_list args; va_start (args, format); va_list args_copy; va_copy (args_copy, args); const char *str = ""; int number = 0; float fnumber = 0; while (*format) { switch (*format++) { case '\''s'\'': // string str = va_arg (args_copy, const char *); break; case '\''d'\'': // int number = va_arg (args_copy, int); break; case '\''f'\'': // float fnumber = va_arg (args_copy, double); break; default: break; } } va_end (args_copy); va_end (args); return *str && number && fnumber; } ' # Test code for whether the C compiler supports C99 (body of main). ac_c_conftest_c99_main=' // Check bool. _Bool success = false; success |= (argc != 0); // Check restrict. if (test_restrict ("String literal") == 0) success = true; char *restrict newvar = "Another string"; // Check varargs. success &= test_varargs ("s, d'\'' f .", "string", 65, 34.234); test_varargs_macros (); // Check flexible array members. struct incomplete_array *ia = malloc (sizeof (struct incomplete_array) + (sizeof (double) * 10)); ia->datasize = 10; for (int i = 0; i < ia->datasize; ++i) ia->data[i] = i * 1.234; // Check named initializers. struct named_init ni = { .number = 34, .name = L"Test wide string", .average = 543.34343, }; ni.number = 58; int dynamic_array[ni.number]; dynamic_array[0] = argv[0][0]; dynamic_array[ni.number - 1] = 543; // work around unused variable warnings ok |= (!success || bignum == 0LL || ubignum == 0uLL || newvar[0] == '\''x'\'' || dynamic_array[ni.number - 1] != 543); ' # Test code for whether the C compiler supports C11 (global declarations) ac_c_conftest_c11_globals=' // Does the compiler advertise C11 conformance? #if !defined __STDC_VERSION__ || __STDC_VERSION__ < 201112L # error "Compiler does not advertise C11 conformance" #endif // Check _Alignas. char _Alignas (double) aligned_as_double; char _Alignas (0) no_special_alignment; extern char aligned_as_int; char _Alignas (0) _Alignas (int) aligned_as_int; // Check _Alignof. enum { int_alignment = _Alignof (int), int_array_alignment = _Alignof (int[100]), char_alignment = _Alignof (char) }; _Static_assert (0 < -_Alignof (int), "_Alignof is signed"); // Check _Noreturn. int _Noreturn does_not_return (void) { for (;;) continue; } // Check _Static_assert. struct test_static_assert { int x; _Static_assert (sizeof (int) <= sizeof (long int), "_Static_assert does not work in struct"); long int y; }; // Check UTF-8 literals. #define u8 syntax error! char const utf8_literal[] = u8"happens to be ASCII" "another string"; // Check duplicate typedefs. typedef long *long_ptr; typedef long int *long_ptr; typedef long_ptr long_ptr; // Anonymous structures and unions -- taken from C11 6.7.2.1 Example 1. struct anonymous { union { struct { int i; int j; }; struct { int k; long int l; } w; }; int m; } v1; ' # Test code for whether the C compiler supports C11 (body of main). ac_c_conftest_c11_main=' _Static_assert ((offsetof (struct anonymous, i) == offsetof (struct anonymous, w.k)), "Anonymous union alignment botch"); v1.i = 2; v1.w.k = 5; ok |= v1.i != 5; ' # Test code for whether the C compiler supports C11 (complete). ac_c_conftest_c11_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} ${ac_c_conftest_c11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} ${ac_c_conftest_c11_main} return ok; } " # Test code for whether the C compiler supports C99 (complete). ac_c_conftest_c99_program="${ac_c_conftest_c89_globals} ${ac_c_conftest_c99_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} ${ac_c_conftest_c99_main} return ok; } " # Test code for whether the C compiler supports C89 (complete). ac_c_conftest_c89_program="${ac_c_conftest_c89_globals} int main (int argc, char **argv) { int ok = 0; ${ac_c_conftest_c89_main} return ok; } " # Test code for whether the C++ compiler supports C++98 (global declarations) ac_cxx_conftest_cxx98_globals=' // Does the compiler advertise C++98 conformance? #if !defined __cplusplus || __cplusplus < 199711L # error "Compiler does not advertise C++98 conformance" #endif // These inclusions are to reject old compilers that // lack the unsuffixed header files. #include #include // and are *not* freestanding headers in C++98. extern void assert (int); namespace std { extern int strcmp (const char *, const char *); } // Namespaces, exceptions, and templates were all added after "C++ 2.0". using std::exception; using std::strcmp; namespace { void test_exception_syntax() { try { throw "test"; } catch (const char *s) { // Extra parentheses suppress a warning when building autoconf itself, // due to lint rules shared with more typical C programs. assert (!(strcmp) (s, "test")); } } template struct test_template { T const val; explicit test_template(T t) : val(t) {} template T add(U u) { return static_cast(u) + val; } }; } // anonymous namespace ' # Test code for whether the C++ compiler supports C++98 (body of main) ac_cxx_conftest_cxx98_main=' assert (argc); assert (! argv[0]); { test_exception_syntax (); test_template tt (2.0); assert (tt.add (4) == 6.0); assert (true && !false); } ' # Test code for whether the C++ compiler supports C++11 (global declarations) ac_cxx_conftest_cxx11_globals=' // Does the compiler advertise C++ 2011 conformance? #if !defined __cplusplus || __cplusplus < 201103L # error "Compiler does not advertise C++11 conformance" #endif namespace cxx11test { constexpr int get_val() { return 20; } struct testinit { int i; double d; }; class delegate { public: delegate(int n) : n(n) {} delegate(): delegate(2354) {} virtual int getval() { return this->n; }; protected: int n; }; class overridden : public delegate { public: overridden(int n): delegate(n) {} virtual int getval() override final { return this->n * 2; } }; class nocopy { public: nocopy(int i): i(i) {} nocopy() = default; nocopy(const nocopy&) = delete; nocopy & operator=(const nocopy&) = delete; private: int i; }; // for testing lambda expressions template Ret eval(Fn f, Ret v) { return f(v); } // for testing variadic templates and trailing return types template auto sum(V first) -> V { return first; } template auto sum(V first, Args... rest) -> V { return first + sum(rest...); } } ' # Test code for whether the C++ compiler supports C++11 (body of main) ac_cxx_conftest_cxx11_main=' { // Test auto and decltype auto a1 = 6538; auto a2 = 48573953.4; auto a3 = "String literal"; int total = 0; for (auto i = a3; *i; ++i) { total += *i; } decltype(a2) a4 = 34895.034; } { // Test constexpr short sa[cxx11test::get_val()] = { 0 }; } { // Test initializer lists cxx11test::testinit il = { 4323, 435234.23544 }; } { // Test range-based for int array[] = {9, 7, 13, 15, 4, 18, 12, 10, 5, 3, 14, 19, 17, 8, 6, 20, 16, 2, 11, 1}; for (auto &x : array) { x += 23; } } { // Test lambda expressions using cxx11test::eval; assert (eval ([](int x) { return x*2; }, 21) == 42); double d = 2.0; assert (eval ([&](double x) { return d += x; }, 3.0) == 5.0); assert (d == 5.0); assert (eval ([=](double x) mutable { return d += x; }, 4.0) == 9.0); assert (d == 5.0); } { // Test use of variadic templates using cxx11test::sum; auto a = sum(1); auto b = sum(1, 2); auto c = sum(1.0, 2.0, 3.0); } { // Test constructor delegation cxx11test::delegate d1; cxx11test::delegate d2(); cxx11test::delegate d3(45); } { // Test override and final cxx11test::overridden o1(55464); } { // Test nullptr char *c = nullptr; } { // Test template brackets test_template<::test_template> v(test_template(12)); } { // Unicode literals char const *utf8 = u8"UTF-8 string \u2500"; char16_t const *utf16 = u"UTF-8 string \u2500"; char32_t const *utf32 = U"UTF-32 string \u2500"; } ' # Test code for whether the C compiler supports C++11 (complete). ac_cxx_conftest_cxx11_program="${ac_cxx_conftest_cxx98_globals} ${ac_cxx_conftest_cxx11_globals} int main (int argc, char **argv) { int ok = 0; ${ac_cxx_conftest_cxx98_main} ${ac_cxx_conftest_cxx11_main} return ok; } " # Test code for whether the C compiler supports C++98 (complete). ac_cxx_conftest_cxx98_program="${ac_cxx_conftest_cxx98_globals} int main (int argc, char **argv) { int ok = 0; ${ac_cxx_conftest_cxx98_main} return ok; } " # Check that the precious variables saved in the cache have kept the same # value. ac_cache_corrupted=false for ac_var in $ac_precious_vars; do eval ac_old_set=\$ac_cv_env_${ac_var}_set eval ac_new_set=\$ac_env_${ac_var}_set eval ac_old_val=\$ac_cv_env_${ac_var}_value eval ac_new_val=\$ac_env_${ac_var}_value case $ac_old_set,$ac_new_set in set,) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} ac_cache_corrupted=: ;; ,set) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 printf "%s\n" "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} ac_cache_corrupted=: ;; ,);; *) if test "x$ac_old_val" != "x$ac_new_val"; then # differences in whitespace do not lead to failure. ac_old_val_w=`echo x $ac_old_val` ac_new_val_w=`echo x $ac_new_val` if test "$ac_old_val_w" != "$ac_new_val_w"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 printf "%s\n" "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} ac_cache_corrupted=: else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 printf "%s\n" "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} eval $ac_var=\$ac_old_val fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 printf "%s\n" "$as_me: former value: \`$ac_old_val'" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 printf "%s\n" "$as_me: current value: \`$ac_new_val'" >&2;} fi;; esac # Pass precious variables to config.status. if test "$ac_new_set" = set; then case $ac_new_val in *\'*) ac_arg=$ac_var=`printf "%s\n" "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; *) ac_arg=$ac_var=$ac_new_val ;; esac case " $ac_configure_args " in *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. *) as_fn_append ac_configure_args " '$ac_arg'" ;; esac fi done if $ac_cache_corrupted; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 printf "%s\n" "$as_me: error: changes in the environment can compromise the build" >&2;} as_fn_error $? "run \`${MAKE-make} distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 fi ## -------------------- ## ## Main body of script. ## ## -------------------- ## ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. set dummy ${ac_tool_prefix}gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "gcc", so it can be a program name with args. set dummy gcc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="gcc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. set dummy ${ac_tool_prefix}cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else ac_prog_rejected=no as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then if test "$as_dir$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then ac_prog_rejected=yes continue fi ac_cv_prog_CC="cc" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS if test $ac_prog_rejected = yes; then # We found a bogon in the path, so make sure we never use it. set dummy $ac_cv_prog_CC shift if test $# != 0; then # We chose a different compiler from the bogus one. # However, it has the same basename, so the bogon will be chosen # first if we set CC to just the basename; use the full file name. shift ac_cv_prog_CC="$as_dir$ac_word${1+' '}$@" fi fi fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then for ac_prog in cl.exe do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CC" && break done fi if test -z "$CC"; then ac_ct_CC=$CC for ac_prog in cl.exe do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CC" && break done if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi fi fi if test -z "$CC"; then if test -n "$ac_tool_prefix"; then # Extract the first word of "${ac_tool_prefix}clang", so it can be a program name with args. set dummy ${ac_tool_prefix}clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CC"; then ac_cv_prog_CC="$CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CC="${ac_tool_prefix}clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CC=$ac_cv_prog_CC if test -n "$CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 printf "%s\n" "$CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi fi if test -z "$ac_cv_prog_CC"; then ac_ct_CC=$CC # Extract the first word of "clang", so it can be a program name with args. set dummy clang; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CC+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CC"; then ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CC="clang" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CC=$ac_cv_prog_ac_ct_CC if test -n "$ac_ct_CC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 printf "%s\n" "$ac_ct_CC" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi if test "x$ac_ct_CC" = x; then CC="" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CC=$ac_ct_CC fi else CC="$ac_cv_prog_CC" fi fi test -z "$CC" && { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "no acceptable C compiler found in \$PATH See \`config.log' for more details" "$LINENO" 5; } # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion -version; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" # Try to create an executable without -o first, disregard a.out. # It will help us diagnose broken compilers, and finding out an intuition # of exeext. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 printf %s "checking whether the C compiler works... " >&6; } ac_link_default=`printf "%s\n" "$ac_link" | sed 's/ -o *conftest[^ ]*//'` # The possible output files: ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" ac_rmfiles= for ac_file in $ac_files do case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; * ) ac_rmfiles="$ac_rmfiles $ac_file";; esac done rm -f $ac_rmfiles if { { ac_try="$ac_link_default" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link_default") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. # So ignore a value of `no', otherwise this would lead to `EXEEXT = no' # in a Makefile. We should not override ac_cv_exeext if it was cached, # so that the user can short-circuit this test for compilers unknown to # Autoconf. for ac_file in $ac_files '' do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; [ab].out ) # We found the default executable, but exeext='' is most # certainly right. break;; *.* ) if test ${ac_cv_exeext+y} && test "$ac_cv_exeext" != no; then :; else ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` fi # We set ac_cv_exeext here because the later test for it is not # safe: cross compilers may not add the suffix if given an `-o' # argument, so we may need to know it at that point already. # Even if this section looks crufty: it has the advantage of # actually working. break;; * ) break;; esac done test "$ac_cv_exeext" = no && ac_cv_exeext= else $as_nop ac_file='' fi if test -z "$ac_file" then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "C compiler cannot create executables See \`config.log' for more details" "$LINENO" 5; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 printf %s "checking for C compiler default output file name... " >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 printf "%s\n" "$ac_file" >&6; } ac_exeext=$ac_cv_exeext rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 printf %s "checking for suffix of executables... " >&6; } if { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : # If both `conftest.exe' and `conftest' are `present' (well, observable) # catch `conftest.exe'. For instance with Cygwin, `ls conftest' will # work properly (i.e., refer to `conftest.exe'), while it won't with # `rm'. for ac_file in conftest.exe conftest conftest.*; do test -f "$ac_file" || continue case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` break;; * ) break;; esac done else $as_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of executables: cannot compile and link See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest conftest$ac_cv_exeext { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 printf "%s\n" "$ac_cv_exeext" >&6; } rm -f conftest.$ac_ext EXEEXT=$ac_cv_exeext ac_exeext=$EXEEXT cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include int main (void) { FILE *f = fopen ("conftest.out", "w"); return ferror (f) || fclose (f) != 0; ; return 0; } _ACEOF ac_clean_files="$ac_clean_files conftest.out" # Check that the compiler produces executables we can run. If not, either # the compiler is broken, or we cross compile. { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 printf %s "checking whether we are cross compiling... " >&6; } if test "$cross_compiling" != yes; then { { ac_try="$ac_link" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_link") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } if { ac_try='./conftest$ac_cv_exeext' { { case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_try") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; }; }; then cross_compiling=no else if test "$cross_compiling" = maybe; then cross_compiling=yes else { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error 77 "cannot run C compiled programs. If you meant to cross compile, use \`--host'. See \`config.log' for more details" "$LINENO" 5; } fi fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 printf "%s\n" "$cross_compiling" >&6; } rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out ac_clean_files=$ac_clean_files_save { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 printf %s "checking for suffix of object files... " >&6; } if test ${ac_cv_objext+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF rm -f conftest.o conftest.obj if { { ac_try="$ac_compile" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compile") 2>&5 ac_status=$? printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } then : for ac_file in conftest.o conftest.obj conftest.*; do test -f "$ac_file" || continue; case $ac_file in *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` break;; esac done else $as_nop printf "%s\n" "$as_me: failed program was:" >&5 sed 's/^/| /' conftest.$ac_ext >&5 { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "cannot compute suffix of object files: cannot compile See \`config.log' for more details" "$LINENO" 5; } fi rm -f conftest.$ac_cv_objext conftest.$ac_ext fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 printf "%s\n" "$ac_cv_objext" >&6; } OBJEXT=$ac_cv_objext ac_objext=$OBJEXT { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C" >&5 printf %s "checking whether the compiler supports GNU C... " >&6; } if test ${ac_cv_c_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_c_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 printf "%s\n" "$ac_cv_c_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_c_compiler_gnu if test $ac_compiler_gnu = yes; then GCC=yes else GCC= fi ac_test_CFLAGS=${CFLAGS+y} ac_save_CFLAGS=$CFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 printf %s "checking whether $CC accepts -g... " >&6; } if test ${ac_cv_prog_cc_g+y} then : printf %s "(cached) " >&6 else $as_nop ac_save_c_werror_flag=$ac_c_werror_flag ac_c_werror_flag=yes ac_cv_prog_cc_g=no CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes else $as_nop CFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : else $as_nop ac_c_werror_flag=$ac_save_c_werror_flag CFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_c_werror_flag=$ac_save_c_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 printf "%s\n" "$ac_cv_prog_cc_g" >&6; } if test $ac_test_CFLAGS; then CFLAGS=$ac_save_CFLAGS elif test $ac_cv_prog_cc_g = yes; then if test "$GCC" = yes; then CFLAGS="-g -O2" else CFLAGS="-g" fi else if test "$GCC" = yes; then CFLAGS="-O2" else CFLAGS= fi fi ac_prog_cc_stdc=no if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C11 features" >&5 printf %s "checking for $CC option to enable C11 features... " >&6; } if test ${ac_cv_prog_cc_c11+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c11=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c11_program _ACEOF for ac_arg in '' -std=gnu11 do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c11" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c11" >&5 printf "%s\n" "$ac_cv_prog_cc_c11" >&6; } CC="$CC $ac_cv_prog_cc_c11" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c11 ac_prog_cc_stdc=c11 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C99 features" >&5 printf %s "checking for $CC option to enable C99 features... " >&6; } if test ${ac_cv_prog_cc_c99+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c99=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c99_program _ACEOF for ac_arg in '' -std=gnu99 -std=c99 -c99 -qlanglvl=extc1x -qlanglvl=extc99 -AC99 -D_STDC_C99= do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c99=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c99" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c99" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c99" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c99" >&5 printf "%s\n" "$ac_cv_prog_cc_c99" >&6; } CC="$CC $ac_cv_prog_cc_c99" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c99 ac_prog_cc_stdc=c99 fi fi if test x$ac_prog_cc_stdc = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CC option to enable C89 features" >&5 printf %s "checking for $CC option to enable C89 features... " >&6; } if test ${ac_cv_prog_cc_c89+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cc_c89=no ac_save_CC=$CC cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_c_conftest_c89_program _ACEOF for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" do CC="$ac_save_CC $ac_arg" if ac_fn_c_try_compile "$LINENO" then : ac_cv_prog_cc_c89=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cc_c89" != "xno" && break done rm -f conftest.$ac_ext CC=$ac_save_CC fi if test "x$ac_cv_prog_cc_c89" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cc_c89" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 printf "%s\n" "$ac_cv_prog_cc_c89" >&6; } CC="$CC $ac_cv_prog_cc_c89" fi ac_cv_prog_cc_stdc=$ac_cv_prog_cc_c89 ac_prog_cc_stdc=c89 fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 printf %s "checking how to run the C preprocessor... " >&6; } # On Suns, sometimes $CPP names a directory. if test -n "$CPP" && test -d "$CPP"; then CPP= fi if test -z "$CPP"; then if test ${ac_cv_prog_CPP+y} then : printf %s "(cached) " >&6 else $as_nop # Double quotes because $CC needs to be expanded for CPP in "$CC -E" "$CC -E -traditional-cpp" cpp /lib/cpp do ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else $as_nop # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else $as_nop # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : break fi done ac_cv_prog_CPP=$CPP fi CPP=$ac_cv_prog_CPP else ac_cv_prog_CPP=$CPP fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 printf "%s\n" "$CPP" >&6; } ac_preproc_ok=false for ac_c_preproc_warn_flag in '' yes do # Use a header file that comes with gcc, so configuring glibc # with a fresh cross-compiler works. # On the NeXT, cc -E runs the code through the compiler's parser, # not just through cpp. "Syntax error" is here to catch this case. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include Syntax error _ACEOF if ac_fn_c_try_cpp "$LINENO" then : else $as_nop # Broken: fails on valid input. continue fi rm -f conftest.err conftest.i conftest.$ac_ext # OK, works on sane cases. Now check whether nonexistent headers # can be detected and how. cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ #include _ACEOF if ac_fn_c_try_cpp "$LINENO" then : # Broken: success on invalid input. continue else $as_nop # Passes both tests. ac_preproc_ok=: break fi rm -f conftest.err conftest.i conftest.$ac_ext done # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. rm -f conftest.i conftest.err conftest.$ac_ext if $ac_preproc_ok then : else $as_nop { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "C preprocessor \"$CPP\" fails sanity check See \`config.log' for more details" "$LINENO" 5; } fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu native_tactic=yes byte_tactic=yes if test ${COQBIN##*/}; then COQBIN=$COQBIN/; fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for coqc" >&5 printf %s "checking for coqc... " >&6; } if test ! "$COQC"; then COQC=`which ${COQBIN}coqc` if test ! "$COQC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } as_fn_error $? "missing Coq compiler" "$LINENO" 5 fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $COQC" >&5 printf "%s\n" "$COQC" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking Coq version" >&5 printf %s "checking Coq version... " >&6; } COQVERSION=`$COQC -v | sed -n -e 's/^.*version \([0-9][0-9.]*\).*$/\1/p' | awk -F. '{ printf("%d%02d%02d\n", $1,$2,$3); }'` if test "$COQVERSION" -lt 81301; then as_fn_error $? "must be at least 8.13.1 (you have version $COQVERSION)." "$LINENO" 5 fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $COQVERSION" >&5 printf "%s\n" "$COQVERSION" >&6; } if test "$COQVERSION" -lt 81400; then COQROOT=coq INT63_EXPORT="From Coq Require Export Int63." INT63_FILE="" else COQROOT=coq-core INT63_EXPORT="Require Export Int63Copy." INT63_FILE="Missing/Int63Copy" fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for coqdep" >&5 printf %s "checking for coqdep... " >&6; } if test ! "$COQDEP"; then COQDEP=`which ${COQBIN}coqdep` if test ! "$COQDEP"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } as_fn_error $? "missing Coq dependency analyzer" "$LINENO" 5 fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $COQDEP" >&5 printf "%s\n" "$COQDEP" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for coqdoc" >&5 printf %s "checking for coqdoc... " >&6; } if test ! "$COQDOC"; then COQDOC=`which ${COQBIN}coqdoc` if test ! "$COQDOC"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: not found" >&5 printf "%s\n" "not found" >&6; } fi fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $COQDOC" >&5 printf "%s\n" "$COQDOC" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for ocamlfind" >&5 printf %s "checking for ocamlfind... " >&6; } if test ! "$OCAMLFIND"; then OCAMLFIND=`$COQC -config | sed -n -e 's/^OCAMLFIND=\(.*\)/\1/p'` if test ! "$OCAMLFIND"; then OCAMLFIND=ocamlfind; fi OCAMLFIND=`which $OCAMLFIND` fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $OCAMLFIND" >&5 printf "%s\n" "$OCAMLFIND" >&6; } if test ! "$OCAMLFIND"; then OCAMLFIND=ocamlfind; fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Flocq" >&5 printf %s "checking for Flocq... " >&6; } if echo "Require Import Flocq.Version BinNat." \ "Goal (30200 <= Flocq_version)%N. easy. Qed." > conftest.v $COQC conftest.v 2> conftest.err then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? " *** Unable to find library Flocq >= 3.2 (http://flocq.gitlabpages.inria.fr/)" "$LINENO" 5 fi rm -f conftest.v conftest.vo conftest.err { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Flocq >= 4.1" >&5 printf %s "checking for Flocq >= 4.1... " >&6; } if echo "Require Import Flocq.Version BinNat." \ "Goal (40100 <= Flocq_version)%N. easy. Qed." > conftest.v $COQC conftest.v 2> conftest.err then : lang_tac=yes else $as_nop lang_tac=no fi rm -f conftest.v conftest.vo conftest.err { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $lang_tac" >&5 printf "%s\n" "$lang_tac" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for primitive floats" >&5 printf %s "checking for primitive floats... " >&6; } if echo "Require Import Flocq.IEEE754.PrimFloat." > conftest.v $COQC conftest.v 2> conftest.err then : prim_float=yes else $as_nop prim_float=no fi rm -f conftest.v conftest.vo conftest.err { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $prim_float" >&5 printf "%s\n" "$prim_float" >&6; } { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Ssreflect" >&5 printf %s "checking for Ssreflect... " >&6; } if echo "Require Import mathcomp.ssreflect.ssreflect." > conftest.v $COQC conftest.v 2> conftest.err then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? " *** Unable to find library mathcomp.ssreflect (http://math-comp.github.io/math-comp/)" "$LINENO" 5 fi rm -f conftest.v conftest.vo conftest.err # meet_morphism is a random constant that only exists in MathComp 2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for MathComp version" >&5 printf %s "checking for MathComp version... " >&6; } if echo "Require Import mathcomp.ssreflect.order. Definition foo := Order.meet_morphism." > conftest.v $COQC conftest.v 2> conftest.err then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: 2" >&5 printf "%s\n" "2" >&6; } MATHCOMP_1_OR_2=2 else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: 1" >&5 printf "%s\n" "1" >&6; } MATHCOMP_1_OR_2=1 fi rm -f conftest.v conftest.vo conftest.err { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Coquelicot" >&5 printf %s "checking for Coquelicot... " >&6; } if echo "Require Import Coquelicot.Coquelicot." \ "Check (RInt (V := R_CompleteNormedModule))." > conftest.v $COQC conftest.v > conftest.err 2>&1 then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? " *** Unable to find library Coquelicot (http://coquelicot.saclay.inria.fr/)" "$LINENO" 5 fi rm -f conftest.v conftest.vo conftest.err { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for Bignums" >&5 printf %s "checking for Bignums... " >&6; } if echo "Require Import Bignums.BigZ.BigZ." > conftest.v $COQC conftest.v 2> conftest.err then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? " *** Unable to find library Bignums (https://github.com/coq/bignums/)" "$LINENO" 5 fi rm -f conftest.v conftest.vo conftest.err # Check whether --enable-tactic was given. if test ${enable_tactic+y} then : enableval=$enable_tactic; if test "$enable_tactic" = "no"; then native_tactic=no ; byte_tactic=no ; fi fi # Check whether --enable-native-tactic was given. if test ${enable_native_tactic+y} then : enableval=$enable_native_tactic; if test "$enable_native_tactic" = "no"; then native_tactic=no ; fi fi # Check whether --enable-byte-tactic was given. if test ${enable_byte_tactic+y} then : enableval=$enable_byte_tactic; if test "$enable_byte_tactic" = "no"; then byte_tactic=no ; fi fi if test "$native_tactic" = yes; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for native development files" >&5 printf %s "checking for native development files... " >&6; } if echo "let _ = (Evd.empty, Big_int_Z.zero_big_int)" > conftest.ml $OCAMLFIND ocamlopt -rectypes -thread -package $COQROOT.engine -package zarith -shared conftest.ml -o conftest.cmxs then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? " *** Failed to compile a native OCaml library " "$LINENO" 5 fi fi if test "$byte_tactic" = yes; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for bytecode development files" >&5 printf %s "checking for bytecode development files... " >&6; } if echo "let _ = (Evd.empty, Big_int_Z.zero_big_int)" > conftest.ml $OCAMLFIND ocamlc -rectypes -thread -package $COQROOT.engine -package zarith -c conftest.ml -o conftest.cmo then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: yes" >&5 printf "%s\n" "yes" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } as_fn_error $? " *** Failed to compile a bytecode OCaml library " "$LINENO" 5 fi fi tactic_mode="" if test "$native_tactic" = yes; then tactic_mode="$tactic_mode native" TACTIC_TARGETS="$TACTIC_TARGETS interval_plot.cmxs" if test "$byte_tactic" = no; then TACTIC_PARAM="-opt" fi fi if test "$byte_tactic" = yes; then tactic_mode="$tactic_mode bytecode" TACTIC_TARGETS="$TACTIC_TARGETS interval_plot.cmo" if test "$native_tactic" = no; then TACTIC_PARAM="-byte" fi fi if test -z "$tactic_mode"; then tactic_mode=" none" PLOT="" else PLOT=Plot fi if test -z "$COQUSERCONTRIB"; then COQUSERCONTRIB="`$COQC -where | tr -d '\r' | tr '\\\\' '/'`/user-contrib" fi if test "$COQVERSION" -ge 81600; then COQINTERVALLIB=`$OCAMLFIND printconf destdir`/coq-interval PLOTPLUGIN="coq-interval.plot" else COQINTERVALLIB=$COQUSERCONTRIB/Interval PLOTPLUGIN="interval_plot" fi if test "$COQVERSION" -lt 81600; then lang_tac=no fi if test "$lang_tac" = "yes"; then LANG_FILES="Language/Lang_expr Language/Lang_simpl Language/Lang_tac" else LANG_FILES= fi if test "$prim_float" = "yes"; then PRIM_FLOAT="$INT63_FILE Missing/Int63Compat Missing/Flocq Float/Primitive_ops" if test "$lang_tac" = "yes"; then PRIM_FLOAT="$PRIM_FLOAT Interval/Float_full_primfloat" PRIM_FLOAT_TAC=src/Tactic_primfloat_opt.v else PRIM_FLOAT_TAC=src/Tactic_primfloat.v fi else PRIM_FLOAT= PRIM_FLOAT_TAC=src/Tactic_bignum.v fi if test -z "$REMAKE"; then ac_ext=cpp ac_cpp='$CXXCPP $CPPFLAGS' ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_cxx_compiler_gnu if test -z "$CXX"; then if test -n "$CCC"; then CXX=$CCC else if test -n "$ac_tool_prefix"; then for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC clang++ do # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. set dummy $ac_tool_prefix$ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_CXX+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$CXX"; then ac_cv_prog_CXX="$CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_CXX="$ac_tool_prefix$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi CXX=$ac_cv_prog_CXX if test -n "$CXX"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 printf "%s\n" "$CXX" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$CXX" && break done fi if test -z "$CXX"; then ac_ct_CXX=$CXX for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC clang++ do # Extract the first word of "$ac_prog", so it can be a program name with args. set dummy $ac_prog; ac_word=$2 { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 printf %s "checking for $ac_word... " >&6; } if test ${ac_cv_prog_ac_ct_CXX+y} then : printf %s "(cached) " >&6 else $as_nop if test -n "$ac_ct_CXX"; then ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test. else as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac for ac_exec_ext in '' $ac_executable_extensions; do if as_fn_executable_p "$as_dir$ac_word$ac_exec_ext"; then ac_cv_prog_ac_ct_CXX="$ac_prog" printf "%s\n" "$as_me:${as_lineno-$LINENO}: found $as_dir$ac_word$ac_exec_ext" >&5 break 2 fi done done IFS=$as_save_IFS fi fi ac_ct_CXX=$ac_cv_prog_ac_ct_CXX if test -n "$ac_ct_CXX"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 printf "%s\n" "$ac_ct_CXX" >&6; } else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: no" >&5 printf "%s\n" "no" >&6; } fi test -n "$ac_ct_CXX" && break done if test "x$ac_ct_CXX" = x; then CXX="g++" else case $cross_compiling:$ac_tool_warned in yes:) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 printf "%s\n" "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} ac_tool_warned=yes ;; esac CXX=$ac_ct_CXX fi fi fi fi # Provide some information about the compiler. printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5 set X $ac_compile ac_compiler=$2 for ac_option in --version -v -V -qversion; do { { ac_try="$ac_compiler $ac_option >&5" case "(($ac_try" in *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; *) ac_try_echo=$ac_try;; esac eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" printf "%s\n" "$ac_try_echo"; } >&5 (eval "$ac_compiler $ac_option >&5") 2>conftest.err ac_status=$? if test -s conftest.err; then sed '10a\ ... rest of stderr output deleted ... 10q' conftest.err >conftest.er1 cat conftest.er1 >&5 fi rm -f conftest.er1 conftest.err printf "%s\n" "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 test $ac_status = 0; } done { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether the compiler supports GNU C++" >&5 printf %s "checking whether the compiler supports GNU C++... " >&6; } if test ${ac_cv_cxx_compiler_gnu+y} then : printf %s "(cached) " >&6 else $as_nop cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { #ifndef __GNUC__ choke me #endif ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : ac_compiler_gnu=yes else $as_nop ac_compiler_gnu=no fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cv_cxx_compiler_gnu=$ac_compiler_gnu fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 printf "%s\n" "$ac_cv_cxx_compiler_gnu" >&6; } ac_compiler_gnu=$ac_cv_cxx_compiler_gnu if test $ac_compiler_gnu = yes; then GXX=yes else GXX= fi ac_test_CXXFLAGS=${CXXFLAGS+y} ac_save_CXXFLAGS=$CXXFLAGS { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 printf %s "checking whether $CXX accepts -g... " >&6; } if test ${ac_cv_prog_cxx_g+y} then : printf %s "(cached) " >&6 else $as_nop ac_save_cxx_werror_flag=$ac_cxx_werror_flag ac_cxx_werror_flag=yes ac_cv_prog_cxx_g=no CXXFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_g=yes else $as_nop CXXFLAGS="" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : else $as_nop ac_cxx_werror_flag=$ac_save_cxx_werror_flag CXXFLAGS="-g" cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main (void) { ; return 0; } _ACEOF if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_g=yes fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext fi rm -f core conftest.err conftest.$ac_objext conftest.beam conftest.$ac_ext ac_cxx_werror_flag=$ac_save_cxx_werror_flag fi { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 printf "%s\n" "$ac_cv_prog_cxx_g" >&6; } if test $ac_test_CXXFLAGS; then CXXFLAGS=$ac_save_CXXFLAGS elif test $ac_cv_prog_cxx_g = yes; then if test "$GXX" = yes; then CXXFLAGS="-g -O2" else CXXFLAGS="-g" fi else if test "$GXX" = yes; then CXXFLAGS="-O2" else CXXFLAGS= fi fi ac_prog_cxx_stdcxx=no if test x$ac_prog_cxx_stdcxx = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CXX option to enable C++11 features" >&5 printf %s "checking for $CXX option to enable C++11 features... " >&6; } if test ${ac_cv_prog_cxx_11+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cxx_11=no ac_save_CXX=$CXX cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_cxx_conftest_cxx11_program _ACEOF for ac_arg in '' -std=gnu++11 -std=gnu++0x -std=c++11 -std=c++0x -qlanglvl=extended0x -AA do CXX="$ac_save_CXX $ac_arg" if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_cxx11=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cxx_cxx11" != "xno" && break done rm -f conftest.$ac_ext CXX=$ac_save_CXX fi if test "x$ac_cv_prog_cxx_cxx11" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cxx_cxx11" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_cxx11" >&5 printf "%s\n" "$ac_cv_prog_cxx_cxx11" >&6; } CXX="$CXX $ac_cv_prog_cxx_cxx11" fi ac_cv_prog_cxx_stdcxx=$ac_cv_prog_cxx_cxx11 ac_prog_cxx_stdcxx=cxx11 fi fi if test x$ac_prog_cxx_stdcxx = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: checking for $CXX option to enable C++98 features" >&5 printf %s "checking for $CXX option to enable C++98 features... " >&6; } if test ${ac_cv_prog_cxx_98+y} then : printf %s "(cached) " >&6 else $as_nop ac_cv_prog_cxx_98=no ac_save_CXX=$CXX cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ $ac_cxx_conftest_cxx98_program _ACEOF for ac_arg in '' -std=gnu++98 -std=c++98 -qlanglvl=extended -AA do CXX="$ac_save_CXX $ac_arg" if ac_fn_cxx_try_compile "$LINENO" then : ac_cv_prog_cxx_cxx98=$ac_arg fi rm -f core conftest.err conftest.$ac_objext conftest.beam test "x$ac_cv_prog_cxx_cxx98" != "xno" && break done rm -f conftest.$ac_ext CXX=$ac_save_CXX fi if test "x$ac_cv_prog_cxx_cxx98" = xno then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 printf "%s\n" "unsupported" >&6; } else $as_nop if test "x$ac_cv_prog_cxx_cxx98" = x then : { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 printf "%s\n" "none needed" >&6; } else $as_nop { printf "%s\n" "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_cxx98" >&5 printf "%s\n" "$ac_cv_prog_cxx_cxx98" >&6; } CXX="$CXX $ac_cv_prog_cxx_cxx98" fi ac_cv_prog_cxx_stdcxx=$ac_cv_prog_cxx_cxx98 ac_prog_cxx_stdcxx=cxx98 fi fi ac_ext=c ac_cpp='$CPP $CPPFLAGS' ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' ac_compiler_gnu=$ac_cv_c_compiler_gnu { printf "%s\n" "$as_me:${as_lineno-$LINENO}: building remake..." >&5 printf "%s\n" "$as_me: building remake..." >&6;} case `$CXX -v 2>&1 | grep -e "^Target:"` in *mingw*) $CXX -Wall -O2 -o remake.exe remake.cpp -lws2_32 if test $? != 0; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed See \`config.log' for more details" "$LINENO" 5; }; fi REMAKE=./remake.exe ;; *) $CXX -Wall -O2 -o remake remake.cpp if test $? != 0; then { { printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 printf "%s\n" "$as_me: error: in \`$ac_pwd':" >&2;} as_fn_error $? "failed See \`config.log' for more details" "$LINENO" 5; }; fi REMAKE=./remake ;; esac fi echo echo "=== Summary ===" echo "Vernacular directory $COQUSERCONTRIB/Interval" echo "Plugin directory $COQINTERVALLIB" echo "Primitive floats $prim_float" echo "Language tactics $lang_tac" echo "Plot tactic $tactic_mode" echo ac_config_files="$ac_config_files Remakefile src/Plot.v src/Missing/Int63Compat.v src/Missing/MathComp1or2.v" cat >confcache <<\_ACEOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs, see configure's option --config-cache. # It is not useful on other systems. If it contains results you don't # want to keep, you may remove or edit it. # # config.status only pays attention to the cache file if you give it # the --recheck option to rerun configure. # # `ac_cv_env_foo' variables (set or unset) will be overridden when # loading this file, other *unset* `ac_cv_foo' will be assigned the # following values. _ACEOF # The following way of writing the cache mishandles newlines in values, # but we know of no workaround that is simple, portable, and efficient. # So, we kill variables containing newlines. # Ultrix sh set writes to stderr and can't be redirected directly, # and sets the high bit in the cache file unless we assign to the vars. ( for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do eval ac_val=\$$ac_var case $ac_val in #( *${as_nl}*) case $ac_var in #( *_cv_*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 printf "%s\n" "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; esac case $ac_var in #( _ | IFS | as_nl) ;; #( BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( *) { eval $ac_var=; unset $ac_var;} ;; esac ;; esac done (set) 2>&1 | case $as_nl`(ac_space=' '; set) 2>&1` in #( *${as_nl}ac_space=\ *) # `set' does not quote correctly, so add quotes: double-quote # substitution turns \\\\ into \\, and sed turns \\ into \. sed -n \ "s/'/'\\\\''/g; s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" ;; #( *) # `set' quotes correctly as required by POSIX, so do not add quotes. sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" ;; esac | sort ) | sed ' /^ac_cv_env_/b end t clear :clear s/^\([^=]*\)=\(.*[{}].*\)$/test ${\1+y} || &/ t end s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ :end' >>confcache if diff "$cache_file" confcache >/dev/null 2>&1; then :; else if test -w "$cache_file"; then if test "x$cache_file" != "x/dev/null"; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 printf "%s\n" "$as_me: updating cache $cache_file" >&6;} if test ! -f "$cache_file" || test -h "$cache_file"; then cat confcache >"$cache_file" else case $cache_file in #( */* | ?:*) mv -f confcache "$cache_file"$$ && mv -f "$cache_file"$$ "$cache_file" ;; #( *) mv -f confcache "$cache_file" ;; esac fi fi else { printf "%s\n" "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 printf "%s\n" "$as_me: not updating unwritable cache $cache_file" >&6;} fi fi rm -f confcache test "x$prefix" = xNONE && prefix=$ac_default_prefix # Let make expand exec_prefix. test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. # # If the first sed substitution is executed (which looks for macros that # take arguments), then branch to the quote section. Otherwise, # look for a macro that doesn't take arguments. ac_script=' :mline /\\$/{ N s,\\\n,, b mline } t clear :clear s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g t quote s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g t quote b any :quote s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g s/\[/\\&/g s/\]/\\&/g s/\$/$$/g H :any ${ g s/^\n// s/\n/ /g p } ' DEFS=`sed -n "$ac_script" confdefs.h` ac_libobjs= ac_ltlibobjs= U= for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue # 1. Remove the extension, and $U if already installed. ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' ac_i=`printf "%s\n" "$ac_i" | sed "$ac_script"` # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR # will be set to the directory where LIBOBJS objects are built. as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' done LIBOBJS=$ac_libobjs LTLIBOBJS=$ac_ltlibobjs : "${CONFIG_STATUS=./config.status}" ac_write_fail=0 ac_clean_files_save=$ac_clean_files ac_clean_files="$ac_clean_files $CONFIG_STATUS" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 printf "%s\n" "$as_me: creating $CONFIG_STATUS" >&6;} as_write_fail=0 cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 #! $SHELL # Generated by $as_me. # Run this file to recreate the current configuration. # Compiler output produced by configure, useful for debugging # configure, is in config.log if it exists. debug=false ac_cs_recheck=false ac_cs_silent=false SHELL=\${CONFIG_SHELL-$SHELL} export SHELL _ASEOF cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 ## -------------------- ## ## M4sh Initialization. ## ## -------------------- ## # Be more Bourne compatible DUALCASE=1; export DUALCASE # for MKS sh as_nop=: if test ${ZSH_VERSION+y} && (emulate sh) >/dev/null 2>&1 then : emulate sh NULLCMD=: # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which # is contrary to our usage. Disable this feature. alias -g '${1+"$@"}'='"$@"' setopt NO_GLOB_SUBST else $as_nop case `(set -o) 2>/dev/null` in #( *posix*) : set -o posix ;; #( *) : ;; esac fi # Reset variables that may have inherited troublesome values from # the environment. # IFS needs to be set, to space, tab, and newline, in precisely that order. # (If _AS_PATH_WALK were called with IFS unset, it would have the # side effect of setting IFS to empty, thus disabling word splitting.) # Quoting is to prevent editors from complaining about space-tab. as_nl=' ' export as_nl IFS=" "" $as_nl" PS1='$ ' PS2='> ' PS4='+ ' # Ensure predictable behavior from utilities with locale-dependent output. LC_ALL=C export LC_ALL LANGUAGE=C export LANGUAGE # We cannot yet rely on "unset" to work, but we need these variables # to be unset--not just set to an empty or harmless value--now, to # avoid bugs in old shells (e.g. pre-3.0 UWIN ksh). This construct # also avoids known problems related to "unset" and subshell syntax # in other old shells (e.g. bash 2.01 and pdksh 5.2.14). for as_var in BASH_ENV ENV MAIL MAILPATH CDPATH do eval test \${$as_var+y} \ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : done # Ensure that fds 0, 1, and 2 are open. if (exec 3>&0) 2>/dev/null; then :; else exec 0&1) 2>/dev/null; then :; else exec 1>/dev/null; fi if (exec 3>&2) ; then :; else exec 2>/dev/null; fi # The user is always right. if ${PATH_SEPARATOR+false} :; then PATH_SEPARATOR=: (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || PATH_SEPARATOR=';' } fi # Find who we are. Look in the path if we contain no directory separator. as_myself= case $0 in #(( *[\\/]* ) as_myself=$0 ;; *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR for as_dir in $PATH do IFS=$as_save_IFS case $as_dir in #((( '') as_dir=./ ;; */) ;; *) as_dir=$as_dir/ ;; esac test -r "$as_dir$0" && as_myself=$as_dir$0 && break done IFS=$as_save_IFS ;; esac # We did not find ourselves, most probably we were run as `sh COMMAND' # in which case we are not to be found in the path. if test "x$as_myself" = x; then as_myself=$0 fi if test ! -f "$as_myself"; then printf "%s\n" "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 exit 1 fi # as_fn_error STATUS ERROR [LINENO LOG_FD] # ---------------------------------------- # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are # provided, also output the error to LOG_FD, referencing LINENO. Then exit the # script with STATUS, using 1 if that was 0. as_fn_error () { as_status=$1; test $as_status -eq 0 && as_status=1 if test "$4"; then as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack printf "%s\n" "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 fi printf "%s\n" "$as_me: error: $2" >&2 as_fn_exit $as_status } # as_fn_error # as_fn_set_status STATUS # ----------------------- # Set $? to STATUS, without forking. as_fn_set_status () { return $1 } # as_fn_set_status # as_fn_exit STATUS # ----------------- # Exit the shell with STATUS, even in a "trap 0" or "set -e" context. as_fn_exit () { set +e as_fn_set_status $1 exit $1 } # as_fn_exit # as_fn_unset VAR # --------------- # Portably unset VAR. as_fn_unset () { { eval $1=; unset $1;} } as_unset=as_fn_unset # as_fn_append VAR VALUE # ---------------------- # Append the text in VALUE to the end of the definition contained in VAR. Take # advantage of any shell optimizations that allow amortized linear growth over # repeated appends, instead of the typical quadratic growth present in naive # implementations. if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null then : eval 'as_fn_append () { eval $1+=\$2 }' else $as_nop as_fn_append () { eval $1=\$$1\$2 } fi # as_fn_append # as_fn_arith ARG... # ------------------ # Perform arithmetic evaluation on the ARGs, and store the result in the # global $as_val. Take advantage of shells that can avoid forks. The arguments # must be portable across $(()) and expr. if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null then : eval 'as_fn_arith () { as_val=$(( $* )) }' else $as_nop as_fn_arith () { as_val=`expr "$@" || test $? -eq 1` } fi # as_fn_arith if expr a : '\(a\)' >/dev/null 2>&1 && test "X`expr 00001 : '.*\(...\)'`" = X001; then as_expr=expr else as_expr=false fi if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then as_basename=basename else as_basename=false fi if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then as_dirname=dirname else as_dirname=false fi as_me=`$as_basename -- "$0" || $as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ X"$0" : 'X\(//\)$' \| \ X"$0" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X/"$0" | sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/ q } /^X\/\(\/\/\)$/{ s//\1/ q } /^X\/\(\/\).*/{ s//\1/ q } s/.*/./; q'` # Avoid depending upon Character Ranges. as_cr_letters='abcdefghijklmnopqrstuvwxyz' as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' as_cr_Letters=$as_cr_letters$as_cr_LETTERS as_cr_digits='0123456789' as_cr_alnum=$as_cr_Letters$as_cr_digits # Determine whether it's possible to make 'echo' print without a newline. # These variables are no longer used directly by Autoconf, but are AC_SUBSTed # for compatibility with existing Makefiles. ECHO_C= ECHO_N= ECHO_T= case `echo -n x` in #((((( -n*) case `echo 'xy\c'` in *c*) ECHO_T=' ';; # ECHO_T is single tab character. xy) ECHO_C='\c';; *) echo `echo ksh88 bug on AIX 6.1` > /dev/null ECHO_T=' ';; esac;; *) ECHO_N='-n';; esac # For backward compatibility with old third-party macros, we provide # the shell variables $as_echo and $as_echo_n. New code should use # AS_ECHO(["message"]) and AS_ECHO_N(["message"]), respectively. as_echo='printf %s\n' as_echo_n='printf %s' rm -f conf$$ conf$$.exe conf$$.file if test -d conf$$.dir; then rm -f conf$$.dir/conf$$.file else rm -f conf$$.dir mkdir conf$$.dir 2>/dev/null fi if (echo >conf$$.file) 2>/dev/null; then if ln -s conf$$.file conf$$ 2>/dev/null; then as_ln_s='ln -s' # ... but there are two gotchas: # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. # In both cases, we have to default to `cp -pR'. ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || as_ln_s='cp -pR' elif ln conf$$.file conf$$ 2>/dev/null; then as_ln_s=ln else as_ln_s='cp -pR' fi else as_ln_s='cp -pR' fi rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file rmdir conf$$.dir 2>/dev/null # as_fn_mkdir_p # ------------- # Create "$as_dir" as a directory, including parents if necessary. as_fn_mkdir_p () { case $as_dir in #( -*) as_dir=./$as_dir;; esac test -d "$as_dir" || eval $as_mkdir_p || { as_dirs= while :; do case $as_dir in #( *\'*) as_qdir=`printf "%s\n" "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( *) as_qdir=$as_dir;; esac as_dirs="'$as_qdir' $as_dirs" as_dir=`$as_dirname -- "$as_dir" || $as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$as_dir" : 'X\(//\)[^/]' \| \ X"$as_dir" : 'X\(//\)$' \| \ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$as_dir" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` test -d "$as_dir" && break done test -z "$as_dirs" || eval "mkdir $as_dirs" } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" } # as_fn_mkdir_p if mkdir -p . 2>/dev/null; then as_mkdir_p='mkdir -p "$as_dir"' else test -d ./-p && rmdir ./-p as_mkdir_p=false fi # as_fn_executable_p FILE # ----------------------- # Test if FILE is an executable regular file. as_fn_executable_p () { test -f "$1" && test -x "$1" } # as_fn_executable_p as_test_x='test -x' as_executable_p=as_fn_executable_p # Sed expression to map a string onto a valid CPP name. as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" # Sed expression to map a string onto a valid variable name. as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" exec 6>&1 ## ----------------------------------- ## ## Main body of $CONFIG_STATUS script. ## ## ----------------------------------- ## _ASEOF test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by Interval $as_me 4.11.1, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ on `(hostname || uname -n) 2>/dev/null | sed 1q` " _ACEOF case $ac_config_files in *" "*) set x $ac_config_files; shift; ac_config_files=$*;; esac cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 # Files that config.status was made for. config_files="$ac_config_files" _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 ac_cs_usage="\ \`$as_me' instantiates files and other configuration actions from templates according to the current configuration. Unless the files and actions are specified as TAGs, all are instantiated by default. Usage: $0 [OPTION]... [TAG]... -h, --help print this help, then exit -V, --version print version number and configuration settings, then exit --config print configuration, then exit -q, --quiet, --silent do not print progress messages -d, --debug don't remove temporary files --recheck update $as_me by reconfiguring in the same conditions --file=FILE[:TEMPLATE] instantiate the configuration file FILE Configuration files: $config_files Report bugs to >." _ACEOF ac_cs_config=`printf "%s\n" "$ac_configure_args" | sed "$ac_safe_unquote"` ac_cs_config_escaped=`printf "%s\n" "$ac_cs_config" | sed "s/^ //; s/'/'\\\\\\\\''/g"` cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ Interval config.status 4.11.1 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" Copyright (C) 2021 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." ac_pwd='$ac_pwd' srcdir='$srcdir' test -n "\$AWK" || AWK=awk _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # The default lists apply if the user does not specify any file. ac_need_defaults=: while test $# != 0 do case $1 in --*=?*) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` ac_shift=: ;; --*=) ac_option=`expr "X$1" : 'X\([^=]*\)='` ac_optarg= ac_shift=: ;; *) ac_option=$1 ac_optarg=$2 ac_shift=shift ;; esac case $ac_option in # Handling of the options. -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) ac_cs_recheck=: ;; --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) printf "%s\n" "$ac_cs_version"; exit ;; --config | --confi | --conf | --con | --co | --c ) printf "%s\n" "$ac_cs_config"; exit ;; --debug | --debu | --deb | --de | --d | -d ) debug=: ;; --file | --fil | --fi | --f ) $ac_shift case $ac_optarg in *\'*) ac_optarg=`printf "%s\n" "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; '') as_fn_error $? "missing file argument" ;; esac as_fn_append CONFIG_FILES " '$ac_optarg'" ac_need_defaults=false;; --he | --h | --help | --hel | -h ) printf "%s\n" "$ac_cs_usage"; exit ;; -q | -quiet | --quiet | --quie | --qui | --qu | --q \ | -silent | --silent | --silen | --sile | --sil | --si | --s) ac_cs_silent=: ;; # This is an error. -*) as_fn_error $? "unrecognized option: \`$1' Try \`$0 --help' for more information." ;; *) as_fn_append ac_config_targets " $1" ac_need_defaults=false ;; esac shift done ac_configure_extra_args= if $ac_cs_silent; then exec 6>/dev/null ac_configure_extra_args="$ac_configure_extra_args --silent" fi _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 if \$ac_cs_recheck; then set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion shift \printf "%s\n" "running CONFIG_SHELL=$SHELL \$*" >&6 CONFIG_SHELL='$SHELL' export CONFIG_SHELL exec "\$@" fi _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 exec 5>>config.log { echo sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX ## Running $as_me. ## _ASBOX printf "%s\n" "$ac_log" } >&5 _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Handling of arguments. for ac_config_target in $ac_config_targets do case $ac_config_target in "Remakefile") CONFIG_FILES="$CONFIG_FILES Remakefile" ;; "src/Plot.v") CONFIG_FILES="$CONFIG_FILES src/Plot.v" ;; "src/Missing/Int63Compat.v") CONFIG_FILES="$CONFIG_FILES src/Missing/Int63Compat.v" ;; "src/Missing/MathComp1or2.v") CONFIG_FILES="$CONFIG_FILES src/Missing/MathComp1or2.v" ;; *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; esac done # If the user did not use the arguments to specify the items to instantiate, # then the envvar interface is used. Set only those that are not. # We use the long form for the default assignment because of an extremely # bizarre bug on SunOS 4.1.3. if $ac_need_defaults; then test ${CONFIG_FILES+y} || CONFIG_FILES=$config_files fi # Have a temporary directory for convenience. Make it in the build tree # simply because there is no reason against having it here, and in addition, # creating and moving files from /tmp can sometimes cause problems. # Hook for its removal unless debugging. # Note that there is a small window in which the directory will not be cleaned: # after its creation but before its name has been assigned to `$tmp'. $debug || { tmp= ac_tmp= trap 'exit_status=$? : "${ac_tmp:=$tmp}" { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status ' 0 trap 'as_fn_exit 1' 1 2 13 15 } # Create a (secure) tmp directory for tmp files. { tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && test -d "$tmp" } || { tmp=./conf$$-$RANDOM (umask 077 && mkdir "$tmp") } || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ac_tmp=$tmp # Set up the scripts for CONFIG_FILES section. # No need to generate them if there are no CONFIG_FILES. # This happens for instance with `./config.status config.h'. if test -n "$CONFIG_FILES"; then ac_cr=`echo X | tr X '\015'` # On cygwin, bash can eat \r inside `` if the user requested igncr. # But we know of no other shell where ac_cr would be empty at this # point, so we can use a bashism as a fallback. if test "x$ac_cr" = x; then eval ac_cr=\$\'\\r\' fi ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then ac_cs_awk_cr='\\r' else ac_cs_awk_cr=$ac_cr fi echo 'BEGIN {' >"$ac_tmp/subs1.awk" && _ACEOF { echo "cat >conf$$subs.awk <<_ACEOF" && echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && echo "_ACEOF" } >conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` ac_delim='%!_!# ' for ac_last_try in false false false false false :; do . ./conf$$subs.sh || as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` if test $ac_delim_n = $ac_delim_num; then break elif $ac_last_try; then as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 else ac_delim="$ac_delim!$ac_delim _$ac_delim!! " fi done rm -f conf$$subs.sh cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && _ACEOF sed -n ' h s/^/S["/; s/!.*/"]=/ p g s/^[^!]*!// :repl t repl s/'"$ac_delim"'$// t delim :nl h s/\(.\{148\}\)..*/\1/ t more1 s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ p n b repl :more1 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t nl :delim h s/\(.\{148\}\)..*/\1/ t more2 s/["\\]/\\&/g; s/^/"/; s/$/"/ p b :more2 s/["\\]/\\&/g; s/^/"/; s/$/"\\/ p g s/.\{148\}// t delim ' >$CONFIG_STATUS || ac_write_fail=1 rm -f conf$$subs.awk cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 _ACAWK cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && for (key in S) S_is_set[key] = 1 FS = "" } { line = $ 0 nfields = split(line, field, "@") substed = 0 len = length(field[1]) for (i = 2; i < nfields; i++) { key = field[i] keylen = length(key) if (S_is_set[key]) { value = S[key] line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) len += length(value) + length(field[++i]) substed = 1 } else len += 1 + keylen } print line } _ACAWK _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" else cat fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 _ACEOF # VPATH may cause trouble with some makes, so we remove sole $(srcdir), # ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and # trailing colons and then remove the whole line if VPATH becomes empty # (actually we leave an empty line to preserve line numbers). if test "x$srcdir" = x.; then ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ h s/// s/^/:/ s/[ ]*$/:/ s/:\$(srcdir):/:/g s/:\${srcdir}:/:/g s/:@srcdir@:/:/g s/^:*// s/:*$// x s/\(=[ ]*\).*/\1/ G s/\n// s/^[^=]*=[ ]*$// }' fi cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 fi # test -n "$CONFIG_FILES" eval set X " :F $CONFIG_FILES " shift for ac_tag do case $ac_tag in :[FHLC]) ac_mode=$ac_tag; continue;; esac case $ac_mode$ac_tag in :[FHL]*:*);; :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; :[FH]-) ac_tag=-:-;; :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; esac ac_save_IFS=$IFS IFS=: set x $ac_tag IFS=$ac_save_IFS shift ac_file=$1 shift case $ac_mode in :L) ac_source=$1;; :[FH]) ac_file_inputs= for ac_f do case $ac_f in -) ac_f="$ac_tmp/stdin";; *) # Look for the file first in the build tree, then in the source tree # (if the path is not absolute). The absolute path cannot be DOS-style, # because $ac_f cannot contain `:'. test -f "$ac_f" || case $ac_f in [\\/$]*) false;; *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; esac || as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; esac case $ac_f in *\'*) ac_f=`printf "%s\n" "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac as_fn_append ac_file_inputs " '$ac_f'" done # Let's still pretend it is `configure' which instantiates (i.e., don't # use $as_me), people would be surprised to read: # /* config.h. Generated by config.status. */ configure_input='Generated from '` printf "%s\n" "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' `' by configure.' if test x"$ac_file" != x-; then configure_input="$ac_file. $configure_input" { printf "%s\n" "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 printf "%s\n" "$as_me: creating $ac_file" >&6;} fi # Neutralize special characters interpreted by sed in replacement strings. case $configure_input in #( *\&* | *\|* | *\\* ) ac_sed_conf_input=`printf "%s\n" "$configure_input" | sed 's/[\\\\&|]/\\\\&/g'`;; #( *) ac_sed_conf_input=$configure_input;; esac case $ac_tag in *:-:* | *:-) cat >"$ac_tmp/stdin" \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac ;; esac ac_dir=`$as_dirname -- "$ac_file" || $as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ X"$ac_file" : 'X\(//\)[^/]' \| \ X"$ac_file" : 'X\(//\)$' \| \ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || printf "%s\n" X"$ac_file" | sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/ q } /^X\(\/\/\)[^/].*/{ s//\1/ q } /^X\(\/\/\)$/{ s//\1/ q } /^X\(\/\).*/{ s//\1/ q } s/.*/./; q'` as_dir="$ac_dir"; as_fn_mkdir_p ac_builddir=. case "$ac_dir" in .) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_dir_suffix=/`printf "%s\n" "$ac_dir" | sed 's|^\.[\\/]||'` # A ".." for each directory in $ac_dir_suffix. ac_top_builddir_sub=`printf "%s\n" "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` case $ac_top_builddir_sub in "") ac_top_builddir_sub=. ac_top_build_prefix= ;; *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; esac ;; esac ac_abs_top_builddir=$ac_pwd ac_abs_builddir=$ac_pwd$ac_dir_suffix # for backward compatibility: ac_top_builddir=$ac_top_build_prefix case $srcdir in .) # We are building in place. ac_srcdir=. ac_top_srcdir=$ac_top_builddir_sub ac_abs_top_srcdir=$ac_pwd ;; [\\/]* | ?:[\\/]* ) # Absolute name. ac_srcdir=$srcdir$ac_dir_suffix; ac_top_srcdir=$srcdir ac_abs_top_srcdir=$srcdir ;; *) # Relative name. ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix ac_top_srcdir=$ac_top_build_prefix$srcdir ac_abs_top_srcdir=$ac_pwd/$srcdir ;; esac ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix case $ac_mode in :F) # # CONFIG_FILE # _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # If the template does not know about datarootdir, expand it. # FIXME: This hack should be removed a few years after 2.60. ac_datarootdir_hack=; ac_datarootdir_seen= ac_sed_dataroot=' /datarootdir/ { p q } /@datadir@/p /@docdir@/p /@infodir@/p /@localedir@/p /@mandir@/p' case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in *datarootdir*) ac_datarootdir_seen=yes;; *@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 printf "%s\n" "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_datarootdir_hack=' s&@datadir@&$datadir&g s&@docdir@&$docdir&g s&@infodir@&$infodir&g s&@localedir@&$localedir&g s&@mandir@&$mandir&g s&\\\${datarootdir}&$datarootdir&g' ;; esac _ACEOF # Neutralize VPATH when `$srcdir' = `.'. # Shell code in configure.ac might set extrasub. # FIXME: do we really want to maintain this feature? cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_sed_extra="$ac_vpsub $extrasub _ACEOF cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 :t /@[a-zA-Z_][a-zA-Z_0-9]*@/!b s|@configure_input@|$ac_sed_conf_input|;t t s&@top_builddir@&$ac_top_builddir_sub&;t t s&@top_build_prefix@&$ac_top_build_prefix&;t t s&@srcdir@&$ac_srcdir&;t t s&@abs_srcdir@&$ac_abs_srcdir&;t t s&@top_srcdir@&$ac_top_srcdir&;t t s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t s&@builddir@&$ac_builddir&;t t s&@abs_builddir@&$ac_abs_builddir&;t t s&@abs_top_builddir@&$ac_abs_top_builddir&;t t $ac_datarootdir_hack " eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ "$ac_tmp/out"`; test -z "$ac_out"; } && { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&5 printf "%s\n" "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' which seems to be undefined. Please make sure it is defined" >&2;} rm -f "$ac_tmp/stdin" case $ac_file in -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; esac \ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; esac done # for ac_tag as_fn_exit 0 _ACEOF ac_clean_files=$ac_clean_files_save test $ac_write_fail = 0 || as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 # configure is writing to config.log, and then calls config.status. # config.status does its own redirection, appending to config.log. # Unfortunately, on DOS this fails, as config.log is still kept open # by configure, so config.status won't be able to write to it; its # output is simply discarded. So we exec the FD to /dev/null, # effectively closing config.log, so it can be properly (re)opened and # appended to by config.status. When coming back to configure, we # need to make the FD available again. if test "$no_create" != yes; then ac_cs_success=: ac_config_status_args= test "$silent" = yes && ac_config_status_args="$ac_config_status_args --quiet" exec 5>/dev/null $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false exec 5>>config.log # Use ||, not &&, to avoid exiting from the if with $? = 1, which # would make configure fail if this is the last instruction. $ac_cs_success || as_fn_exit 1 fi if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then { printf "%s\n" "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 printf "%s\n" "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi